├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── app ├── Main.hs └── PackageInfo.hs ├── purify.cabal └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Chris Done (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Chris Done nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # DEPRECATED :warning: 2 | 3 | See [psc-package](https://github.com/purescript/psc-package) which provides the same functionality and is updated regularly. 4 | 5 | ----- 6 | 7 | # purify 8 | 9 | Reproducible builds for PureScript, inspired by Haskell's `stack` tool 10 | 11 | See [purify-template](https://github.com/chrisdone/purify-template) 12 | for a template repo that you can clone and build in 5 minutes. 13 | 14 | See [purify-sets](https://github.com/chrisdone/purify-sets) 15 | for sets of packages that are known to build together. 16 | 17 | ## Commands 18 | 19 | * `purify build` - Build the current project. 20 | * `purify ide` - Launch the PureScript IDE server (for Emacs integration). 21 | 22 | See examples of these commands at [purify-template](https://github.com/chrisdone/purify-template). 23 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module Main where 6 | 7 | import Control.Applicative 8 | import Control.Concurrent.STM 9 | import Control.Exception.Safe 10 | import Control.Monad 11 | import Control.Monad.IO.Class 12 | import Control.Monad.Trans.State.Strict 13 | import Data.Aeson 14 | import Data.Char 15 | import Data.Function 16 | import Data.List 17 | import qualified Data.Map as Map 18 | import Data.Maybe 19 | import Data.Monoid 20 | import Data.Yaml 21 | import Options.Applicative.Simple 22 | import PackageInfo 23 | import qualified Paths_purify 24 | import System.Directory 25 | import System.Environment 26 | import System.Exit 27 | import qualified System.FilePath.Glob as Glob 28 | import qualified System.FSNotify as FS 29 | import System.Process 30 | 31 | data Purify = Purify 32 | { outputFile :: FilePath 33 | , extraDeps :: [Dep] 34 | } deriving (Eq,Show) 35 | 36 | instance ToJSON Purify where 37 | toJSON (Purify outFile deps) = object 38 | [ "output-file" .= outFile 39 | , "extra-deps" .= deps 40 | ] 41 | 42 | instance FromJSON Purify where 43 | parseJSON j = do 44 | o <- parseJSON j 45 | outputFile <- o .: "output-file" 46 | extraDeps <- 47 | ((o .: "extra-deps") <|> 48 | fmap flattenDeps (o .: "extra-deps")) {-backwards compat-} 49 | pure (Purify {..}) 50 | where 51 | flattenDeps :: Map.Map String Dep -> [Dep] 52 | flattenDeps = map (\(k, v) -> v { depName = k }) . Map.toList 53 | 54 | data Dep = Dep 55 | { depRepo :: String 56 | , depCommit :: String 57 | , depName :: String 58 | , depModules :: Maybe [String] 59 | , depDeps :: [String] 60 | } deriving (Eq,Show) 61 | 62 | instance ToJSON Dep where 63 | toJSON d = object 64 | (maybe id (\m -> (("modules" .= m):)) (depModules d) 65 | [ "repo" .= depRepo d 66 | , "commit" .= depCommit d 67 | , "name" .= depName d 68 | , "deps" .= depDeps d 69 | ]) 70 | 71 | instance FromJSON Dep where 72 | parseJSON j = do 73 | o <- parseJSON j 74 | repo <- o .: "repo" 75 | commit <- o .: "commit" 76 | let name' = takeWhile (/='.') (reverse (takeWhile (/='/') (reverse repo))) 77 | name <- o .:? "name" .!= name' 78 | mmodules <- o .:? "modules" 79 | deps <- o .:? "deps" .!= [] 80 | pure (Dep repo commit name mmodules deps) 81 | 82 | main :: IO () 83 | main = do 84 | exists <- doesFileExist "purify.yaml" 85 | if not exists 86 | then die "Expected purify.yaml in the directory of your PureScript project." 87 | else do 88 | result <- decodeFileEither "purify.yaml" 89 | case result of 90 | Left _ -> die "Couldn't parse purify.yaml file." 91 | Right config -> do 92 | args <- getArgs 93 | if null args 94 | then purify [] config False 95 | else join $ fmap snd $ simpleOptions 96 | $(simpleVersion Paths_purify.version) 97 | "purify build tool for PureScript" 98 | "Fully reproducible builds for PureScript" 99 | (pure ()) $ do 100 | addCommand "build" "Build code" id $ purify 101 | <$> pure [] 102 | <*> pure config 103 | <*> switch (long "file-watch" <> help "Auto-rebuild on file change") 104 | addCommand "ide" "Launch IDE interaction" id $ pure ide 105 | addCommand "add-deps" "Add dependencies to purify.yaml" id $ addDeps 106 | <$> pure config 107 | <*> some (strArgument (metavar "PACKAGE-NAME")) 108 | 109 | data FetchState = Didn'tFetch | Fetched 110 | 111 | purify :: [FilePath] -> Purify -> Bool -> IO () 112 | purify inputFiles config fileWatch = do 113 | createDirectoryIfMissing True ".purify-work/extra-deps" 114 | when 115 | (nub (extraDeps config) /= extraDeps config || 116 | nubBy (on (==) depName) (extraDeps config) /= extraDeps config) 117 | (die "Dependencies contain duplicates.") 118 | mapM_ 119 | (\dep -> do 120 | let depDir = getDepDir dep 121 | gitDir = depDir 122 | exists <- doesDirectoryExist depDir 123 | let clone = 124 | if not exists 125 | then do 126 | putStrLn ("Cloning " ++ depName dep ++ " ...") 127 | ok <- rawSystem "git" ["clone", "-q", depRepo dep, depDir] 128 | case ok of 129 | ExitFailure {} -> 130 | die 131 | ("Failed to clone package " ++ 132 | depName dep ++ " from " ++ depRepo dep) 133 | _ -> checkout 134 | else checkout 135 | checkout = do 136 | tags <- 137 | fmap 138 | lines 139 | (readProcess 140 | "git" 141 | ["-C", gitDir, "tag", "--points-at", "HEAD"] 142 | "") 143 | if any (== depCommit dep) tags 144 | then return () 145 | else do 146 | cur <- readProcess "git" ["-C", gitDir, "rev-parse", "HEAD"] "" 147 | let commit = takeWhile isAlphaNum cur 148 | shortDepCommit = take 7 (depCommit dep) 149 | if commit == depCommit dep 150 | then return () 151 | else do 152 | fetch shortDepCommit Didn'tFetch 153 | fetch shortDepCommit fetchState = do 154 | case fetchState of 155 | Didn'tFetch -> 156 | putStrLn 157 | ("Checking out " ++ 158 | depName dep ++ " (" ++ shortDepCommit ++ ") ...") 159 | _ -> return () 160 | res <- 161 | rawSystem 162 | "git" 163 | ["-C", gitDir, "checkout", "-f", "-q", depCommit dep] 164 | case res of 165 | ExitFailure {} -> 166 | case fetchState of 167 | Didn'tFetch -> do 168 | putStrLn 169 | ("Failed to checkout, fetching latest from remote ...") 170 | fres <- rawSystem "git" ["-C", gitDir, "fetch", "-q"] 171 | case fres of 172 | ExitFailure {} -> 173 | die 174 | ("Tried to checkout " ++ 175 | depCommit dep ++ 176 | ", but it failed. Tried to fetch from the remote, but that failed too. Giving up.") 177 | _ -> fetch shortDepCommit Fetched 178 | Fetched -> 179 | die 180 | ("Checking out version failed for " ++ 181 | depName dep ++ ": " ++ depCommit dep) 182 | _ -> return () 183 | clone) 184 | (extraDeps config) 185 | srcExists <- doesDirectoryExist "src/" 186 | if not srcExists 187 | then die 188 | "There is no src/ directory in this project. Please create one and put your PureScript files in there." 189 | else do 190 | let dirs = 191 | map 192 | (++ "/src") 193 | ("." : 194 | map 195 | getDepDir 196 | (filter (isNothing . depModules) (extraDeps config))) 197 | buildCmd = purifyDirs inputFiles config dirs 198 | if fileWatch 199 | then watchDirs dirs buildCmd 200 | else buildCmd 201 | 202 | watchDirs :: [FilePath] -> IO () -> IO () 203 | watchDirs dirs inner = do 204 | toRunVar <- newTVarIO True -- do an initial build immediately 205 | FS.withManager (\manager -> do 206 | forM_ dirs $ \dir -> FS.watchTree manager dir (const True) 207 | (const (atomically (writeTVar toRunVar True))) 208 | forever (do 209 | atomically (do 210 | toRun <- readTVar toRunVar 211 | check toRun 212 | writeTVar toRunVar False) 213 | putStrLn "Starting build" 214 | eres <- tryAny inner 215 | case eres of 216 | Left e -> print e 217 | Right () -> return () 218 | putStrLn "Build command finished, waiting for file changes")) 219 | 220 | getDepDir :: Dep -> FilePath 221 | getDepDir dep = ".purify-work/extra-deps/" ++ depName dep 222 | 223 | purifyDirs :: [FilePath] 224 | -> Purify 225 | -> [FilePath] 226 | -> IO () 227 | purifyDirs inputFiles config dirs = do 228 | let pattern = Glob.compile "**/*.purs" 229 | foundPurs <- concat <$> mapM (Glob.globDir1 pattern) dirs 230 | let explicitPurs = 231 | concat 232 | (mapMaybe 233 | (\dep -> do 234 | modules <- depModules dep 235 | pure 236 | (map 237 | (\modn -> getDepDir dep ++ "/" ++ topath modn) 238 | modules)) 239 | (extraDeps config)) 240 | where 241 | topath m = "src/" ++ replace m ++ ".purs" 242 | replace ('.':cs) = '/' : replace cs 243 | replace (c:cs) = c : replace cs 244 | replace [] = [] 245 | let allPurs = inputFiles ++ foundPurs ++ explicitPurs 246 | putStrLn ("Compiling " ++ show (length allPurs) ++ " modules ...") 247 | let outputDir = ".purify-work/js-output" 248 | status <- rawSystem "purs" (["compile", "-o", outputDir] ++ allPurs) 249 | case status of 250 | ExitFailure {} -> die "Compile failed." 251 | _ -> do 252 | putStrLn "Bundling ..." 253 | stat <- 254 | rawSystem 255 | "purs" 256 | [ "bundle" 257 | , ".purify-work/js-output/**/*.js" 258 | , "-m" 259 | , "Main" 260 | , "--main" 261 | , "Main" 262 | , "-o" 263 | , outputFile config 264 | ] 265 | case stat of 266 | ExitFailure {} -> die "Bundling failed." 267 | _ -> putStrLn ("Output bundled to " ++ outputFile config) 268 | 269 | ide :: IO () 270 | ide = rawSystem 271 | "purs" 272 | ["ide","server", "--output-directory", ".purify-work/js-output" 273 | ,".purify-work/extra-deps/*/src/**/*.purs", "src/**/*.purs"] 274 | >>= exitWith 275 | 276 | addDeps :: Purify -> [String] -> IO () 277 | addDeps (Purify outFile deps) newDeps = 278 | void (runStateT (mapM_ (addDep outFile []) newDeps) depsMap) 279 | where 280 | depsMap = Map.unions (map (\dep -> Map.singleton (depName dep) dep) deps) 281 | 282 | addDep :: FilePath -- ^ out file 283 | -> [String] -- ^ call stack, to avoid cycles 284 | -> String -- ^ new dep 285 | -> StateT (Map.Map String Dep) IO () 286 | addDep _ depStack newDep 287 | | newDep `elem` depStack = error ("Dep cycle detected: " ++ show (newDep : depStack)) 288 | addDep outFile depStack newDep = do 289 | let newStack = newDep : depStack 290 | allDeps <- get 291 | case Map.lookup newDep allDeps of 292 | Nothing -> do 293 | liftIO (putStrLn ("Adding dep: " ++ newDep)) 294 | (repo, deps) <- liftIO (lookupPackage newDep) 295 | master <- liftIO (getMasterCommit repo) 296 | modify (Map.insert newDep (Dep 297 | { depRepo = repo 298 | , depCommit = master 299 | , depName = newDep 300 | , depModules = Nothing 301 | , depDeps = deps 302 | })) 303 | deps' <- get 304 | liftIO (encodeFile "purify.yaml" (Purify outFile (Map.elems deps'))) 305 | mapM_ (addDep outFile newStack) deps 306 | Just ed -> mapM_ (addDep outFile newStack) (depDeps ed) 307 | -------------------------------------------------------------------------------- /app/PackageInfo.hs: -------------------------------------------------------------------------------- 1 | -- | A whole bunch of ugly web screen scraping. It would be great if 2 | -- Pursuit had a JSON API and Github's API didn't have ridiculously 3 | -- low rate limits for unauthenticated requests. 4 | {-# LANGUAGE OverloadedStrings #-} 5 | module PackageInfo 6 | ( lookupPackage 7 | , getMasterCommit 8 | ) where 9 | 10 | import Data.Text (Text) 11 | import qualified Data.Text as T 12 | import Network.HTTP.Simple 13 | import Text.HTML.DOM (sinkDoc) 14 | import Text.XML.Cursor 15 | 16 | lookupPackage :: String -- ^ package name 17 | -> IO (String, [String]) -- ^ repo URL, dependencies 18 | 19 | -- Some hard-coded hacks for packages that don't appear on Pursuit. It 20 | -- would be great to get rid of these. 21 | lookupPackage "purescript-dom-indexed" = return ("https://github.com/slamdata/purescript-dom-indexed", []) 22 | lookupPackage "purescript-fork" = return ("https://github.com/slamdata/purescript-fork", []) 23 | 24 | lookupPackage name = do 25 | let url = "https://pursuit.purescript.org/packages/" ++ name 26 | req <- parseRequest url 27 | doc <- httpSink req $ const sinkDoc 28 | let cursor = fromDocument doc 29 | repos = cursor 30 | $// element "dt" 31 | >=> hasContent "Repository" 32 | >=> followingSibling 33 | &// element "a" 34 | >=> attribute "href" 35 | 36 | repo <- 37 | case repos of 38 | [] -> error ("Could not parse repo from: " ++ url) 39 | x:_ -> return x 40 | 41 | let deps = cursor 42 | $// element "a" 43 | >=> attributeIs "class" "deplink__link" 44 | &// content 45 | return (T.unpack repo, map T.unpack deps) 46 | 47 | hasContent :: Text -> Axis 48 | hasContent t c 49 | | T.strip (T.concat (c $// content)) == t = [c] 50 | | otherwise = [] 51 | 52 | -- | Get the commit SHA for the master branch 53 | -- 54 | -- Technically will take whatever is the displayed branch on the 55 | -- Github UI 56 | getMasterCommit :: String -- ^ repo URL 57 | -> IO String 58 | getMasterCommit repo = do 59 | req <- parseRequest repo 60 | res <- httpSink req (const sinkDoc) 61 | let cursor = fromDocument res 62 | oldStyle = cursor 63 | $// element "a" 64 | >=> attributeIs "class" "commit-tease-sha" 65 | >=> attribute "href" 66 | newStyle = cursor 67 | $// element "include-fragment" 68 | >=> attributeIs "class" "commit-tease commit-loader" 69 | >=> attribute "src" 70 | case oldStyle ++ newStyle of 71 | [x] -> return (T.unpack (T.reverse (T.takeWhile (/= '/') (T.reverse x)))) 72 | _ -> error ("Could not find commit from " ++ repo) 73 | -------------------------------------------------------------------------------- /purify.cabal: -------------------------------------------------------------------------------- 1 | name: purify 2 | version: 0.1.0.0 3 | synopsis: Initial project template from stack 4 | description: Please see README.md 5 | homepage: https://github.com/chrisdone/purify#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Chris Done 9 | maintainer: chrisdone@gmail.com 10 | copyright: 2016 Chris Done 11 | category: Web 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | executable purify 17 | hs-source-dirs: app 18 | main-is: Main.hs 19 | other-modules: PackageInfo 20 | ghc-options: -Wall -threaded -O 21 | build-depends: base 22 | , aeson 23 | , containers 24 | , directory 25 | , fsnotify 26 | , Glob 27 | , html-conduit 28 | , http-conduit 29 | , optparse-simple 30 | , process 31 | , safe-exceptions 32 | , stm 33 | , text 34 | , transformers 35 | , xml-conduit 36 | , yaml 37 | default-language: Haskell2010 38 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-8.17 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.1" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | --------------------------------------------------------------------------------