pier-core 0.2.0.1 → 0.3.0.0

raw patch · 9 files changed

+404/−376 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• pier-core.cabal +10/−6
• src/Pier/Core/Artifact.hs +24/−191
• src/Pier/Core/Directory.hs +0/−73
• src/Pier/Core/Download.hs +24/−44
• src/Pier/Core/HashableSet.hs +0/−15
• src/Pier/Core/Internal/Directory.hs +73/−0
• src/Pier/Core/Internal/HashableSet.hs +15/−0
• src/Pier/Core/Internal/Store.hs +257/−0
• src/Pier/Core/Run.hs +1/−47

@@ -2,13 +2,13 @@ -- -- see: https://github.com/sol/hpack ----- hash: 9fdad4540272130658b9ff1116618cd490bf74278568ed2b007c908b1c7ee1d0+-- hash: b22a03eb05732ee3ba2170f3e7af25a0c813e45ceb170c7110bcdf6e9d7180ae  name:           pier-core-version:        0.2.0.1+version:        0.3.0.0 synopsis:       A library for writing forwards-declared build systems in haskell. description:    A library for writing build systems in Haskell, built on top of-                <http://shakebuild.com shake>.+                <http://shakebuild.com Shake>.                 .                 Pier provides a generic approach to building and caching file outputs.                 It enables build actions to be written in a "forwards" style, which@@ -16,7 +16,10 @@                 such as make or (normal) Shake, where each step of the build logic must                 be written as a new build rule.                 .-                For more details, see "Pier.Core.Artifact".+                For more details of the API, start with "Pier.Core.Artifact".+                .+                See <https://hackage.haskell.org/package/pier pier> for information+                on the Haskell build tool that uses this package. category:       Development homepage:       https://github.com/judah/pier#readme bug-reports:    https://github.com/judah/pier/issues@@ -37,8 +40,9 @@       Pier.Core.Persistent       Pier.Core.Run   other-modules:-      Pier.Core.Directory-      Pier.Core.HashableSet+      Pier.Core.Internal.Directory+      Pier.Core.Internal.HashableSet+      Pier.Core.Internal.Store   hs-source-dirs:       src   default-extensions: BangPatterns DeriveGeneric FlexibleContexts LambdaCase MultiWayIf NondecreasingIndentation ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeSynonymInstances

@@ -4,9 +4,9 @@ "forwards" style.  For example:  > runPier $ action $ do->     contents <- lines <$> readArtifactA (externalFile "result.txt")+>     contents <- lines <$> readArtifactA (external "result.txt") >     let result = "result.tar"->     runCommand (output result)+>     runCommandOutput result >        $ foldMap input contents >          <> prog "tar" (["-cf", result] ++ map pathIn contents) @@ -42,9 +42,10 @@     ( -- * Rules       artifactRules     , SharedCache(..)+    , HandleTemps(..)       -- * Artifact     , Artifact-    , externalFile+    , external     , (/>)     , replaceArtifactExtension     , readArtifact@@ -56,6 +57,7 @@       -- * Creating artifacts     , writeArtifact     , runCommand+    , runCommandOutput     , runCommand_     , runCommandStdout     , Command@@ -78,13 +80,11 @@     , createDirectoryA     ) where -import Control.Monad (forM_, when, unless, void)+import Control.Monad (forM_, when, unless) import Control.Monad.IO.Class-import Crypto.Hash.SHA256-import Data.ByteString.Base64 import Data.Set (Set) import Development.Shake-import Development.Shake.Classes hiding (hash)+import Development.Shake.Classes import Development.Shake.FilePath import Distribution.Simple.Utils (matchDirFileGlob) import GHC.Generics@@ -92,7 +92,6 @@ import System.Exit (ExitCode(..)) import System.Process.Internals (translate) -import qualified Data.Binary as Binary import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Data.List as List@@ -102,10 +101,10 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T hiding (replace) -import Pier.Core.Directory-import Pier.Core.HashableSet+import Pier.Core.Internal.Directory+import Pier.Core.Internal.HashableSet+import Pier.Core.Internal.Store import Pier.Core.Persistent-import Pier.Core.Run  -- | A hermetic build step.  Consists of a sequence of calls to 'message', -- 'prog'/'progA'/'progTemp', and/or 'shadow', which may be combined using '<>'/'mappend'.@@ -212,105 +211,24 @@ -- The input must be a relative path and nontrivial (i.e., not @"."@ or @""@). output :: FilePath -> Output Artifact output f-    | normaliseMore f == "." = error $ "Can't output empty path " ++ show f+    | ds `elem` [[], ["."]] = error $ "can't output empty path " ++ show f+    | ".." `elem` ds  = error $ "output: can't have \"..\" as a path component: "+                                    ++ show f+    | normalise f == "." = error $ "Can't output empty path " ++ show f     | isAbsolute f = error $ "Can't output absolute path " ++ show f-    | otherwise = Output [f] $ flip Artifact (normaliseMore f) . Built---- | Unique identifier of a command-newtype Hash = Hash B.ByteString-    deriving (Show, Eq, Ord, Binary, NFData, Hashable, Generic)--makeHash :: Binary a => a -> Action Hash-makeHash x = do-    version <- askOracle GetArtifactVersion-    return . Hash . fixChars . dropPadding . encode . hashlazy . Binary.encode-         . tagVersion version-        $ x+    | otherwise = Output [f] $ flip builtArtifact f   where-    -- Remove slashes, since the strings will appear in filepaths.-    fixChars = BC.map $ \case-                                '/' -> '_'-                                c -> c-    -- Padding just adds noise, since we don't have length requirements (and indeed-    -- every sha256 hash is 32 bytes)-    dropPadding c-        | BC.last c == '=' = BC.init c-        -- Shouldn't happen since each hash is the same length:-        | otherwise = c-    tagVersion = (,)---- | Version number of artifacts being generated.-newtype ArtifactVersion = ArtifactVersion Int-    deriving (Show,Typeable,Eq,Hashable,Binary,NFData,Generic)--data GetArtifactVersion = GetArtifactVersion-    deriving (Show,Typeable,Eq,Hashable,Binary,NFData,Generic)-type instance RuleResult GetArtifactVersion = ArtifactVersion--artifactVersionRule :: Rules ()-artifactVersionRule = void $ addOracle $ \GetArtifactVersion-    -- Bumping this will cause every artifact to be regenerated, and should-    -- only be done in case of backwards-incompatible changes.-    -> return $ ArtifactVersion 1--hashDir :: Hash -> FilePath-hashDir h = artifactDir </> hashString h--newtype SharedCache = SharedCache FilePath--globalHashDir :: SharedCache -> Hash -> FilePath-globalHashDir (SharedCache f) h = f </> hashString h--artifactDir :: FilePath-artifactDir = pierFile "artifact"+    ds = splitDirectories f  externalArtifactDir :: FilePath externalArtifactDir = artifactDir </> "external" -hashString :: Hash -> String-hashString (Hash h) = BC.unpack h---- | An 'Artifact' is a file or folder that was created by a build command.-data Artifact = Artifact Source FilePath-    deriving (Eq, Ord, Generic, Hashable, Binary, NFData)--instance Show Artifact where-    show (Artifact External f) = "external:" ++ show f-    show (Artifact (Built h) f) = hashString h ++ ":" ++ show f--data Source = Built Hash | External-    deriving (Show, Eq, Ord, Generic, Hashable, Binary, NFData)---- | Create an 'Artifact' from an input file to the build (for example, a--- source file created by the user).------ If it is a relative path, changes to the file will cause rebuilds of--- Commands and Rules that dependended on it.-externalFile :: FilePath -> Artifact-externalFile f-    | null f' = error "externalFile: empty input"-    | artifactDir `List.isPrefixOf` f' = error $ "externalFile: forbidden prefix: " ++ show f'-    | otherwise = Artifact External f'-  where-    f' = normaliseMore f---- | Normalize a filepath, also dropping the trailing slash.-normaliseMore :: FilePath -> FilePath-normaliseMore = dropTrailingPathSeparator . normalise---- | Create a reference to a sub-file of the given 'Artifact', which must--- refer to a directory.-(/>) :: Artifact -> FilePath -> Artifact-Artifact source f /> g = Artifact source $ normaliseMore $ f </> g--infixr 5 />  -- Same as </>- artifactRules :: Maybe SharedCache -> HandleTemps -> Rules () artifactRules cache ht = do     liftIO createExternalLink     commandRules cache ht     writeArtifactRules cache-    artifactVersionRule+    storeRules  createExternalLink :: IO () createExternalLink = do@@ -352,7 +270,7 @@                         ]     need externalFiles     -- TODO: streaming hash-    userFileHashes <- liftIO $ map hash <$> mapM B.readFile externalFiles+    userFileHashes <- liftIO $ mapM hashExternalFile externalFiles     makeHash ("commandHash", cmdQ, userFileHashes)  -- | Run the given command, capturing the specified outputs.@@ -360,10 +278,13 @@ runCommand (Output outs mk) c     = mk <$> askPersistent (CommandQ c outs) +runCommandOutput :: FilePath -> Command -> Action Artifact+runCommandOutput f = runCommand (output f)+ -- Run the given command and record its stdout. runCommandStdout :: Command -> Action String runCommandStdout c = do-    out <- runCommand (output stdoutOutput) c+    out <- runCommandOutput stdoutOutput c     liftIO $ readFile $ pathIn out  -- | Run the given command without capturing its output.  Can be used to check@@ -423,80 +344,6 @@     checkAllDistinctPaths inps'     liftIO $ mapM_ (linkArtifact tmp) inps' --- | Create a directory containing Artifacts.------ If the output directory already exists, don't do anything.  Otherwise, run--- the given function with a temporary directory, and then move that directory--- atomically to the final output directory for those Artifacts.--- Files and (sub)directories, as well as the directory itself, will--- be made read-only.-createArtifacts ::-       Maybe SharedCache-    -> Hash-    -> [String] -- ^ Messages to print if cached-    -> (FilePath -> Action ())-    -> Action ()-createArtifacts maybeSharedCache h messages act = do-    let destDir = hashDir h-    exists <- liftIO $ Directory.doesDirectoryExist destDir-    -- Skip if the output directory already exists; we'll produce it atomically-    -- below.  This could happen if Shake's database was cleaned, or if the-    -- action stops before Shake registers it as complete, due to either a-    -- synchronous or asynchronous exception.-    if exists-        then mapM_ cacheMessage messages-        else do-            tempDir <- createPierTempDirectory $ hashString h ++ "-result"-            case maybeSharedCache of-                Nothing -> act tempDir-                Just cache -> do-                    getFromSharedCache <- liftIO $ copyFromCache cache h tempDir-                    if getFromSharedCache-                        then mapM_ sharedCacheMessage messages-                        else do-                            act tempDir-                            liftIO $ copyToCache cache h tempDir-            liftIO $ finish tempDir destDir-  where-    cacheMessage m = putNormal $ "(from cache: " ++ m ++ ")"-    sharedCacheMessage m = putNormal $ "(from shared cache: " ++ m ++ ")"-    finish tempDir destDir = do-        -- Move the created directory to its final location,-        -- with all the files and directories inside set to-        -- read-only.-        -- Don't set permissions on symbolic links; they're ignored-        -- on most systems (e.g., Linux).-        let freeze RegularFile = freezePath-            freeze DirectoryEnd = freezePath-            freeze _ = const $ return ()-        -- TODO: why is getRegularContents used?-        -- Ah, to avoid the current directory.-        getRegularContents tempDir-            >>= mapM_ (forFileRecursive_ freeze . (tempDir </>))-        createParentIfMissing destDir-        Directory.renameDirectory tempDir destDir-        -- Also set the directory itself to read-only, but wait-        -- until the last step since read-only files can't be moved.-        freezePath destDir---- TODO: consider using hard links for these copies, to save space--- TODO: make sure the directories are read-only-copyFromCache :: SharedCache -> Hash -> FilePath -> IO Bool-copyFromCache cache h tempDir = do-    let globalDir = globalHashDir cache h-    globalExists <- liftIO $ Directory.doesDirectoryExist globalDir-    if globalExists-        then copyDirectory globalDir tempDir >> return True-        else return False--copyToCache :: SharedCache -> Hash -> FilePath -> IO ()-copyToCache cache h src = do-    tempDir <- createPierTempDirectory $ hashString h ++ "-cache"-    copyDirectory src tempDir-    let dest = globalHashDir cache h-    createParentIfMissing dest-    Directory.renameDirectory tempDir dest- -- Call a process inside the given directory and capture its stdout. -- TODO: more flexibility around the env vars -- Also: limit valid parameters for the *prog* binary (rather than taking it@@ -633,20 +480,6 @@     loop (f:fs) = f : loop fs     loop [] = [] -freezePath :: FilePath -> IO ()-freezePath f =-    getPermissions f >>= setPermissions f . setOwnerWritable False---- | Make all artifacts user-writable, so they can be deleted by `clean-all`.-unfreezeArtifacts :: IO ()-unfreezeArtifacts = forM_ [artifactDir, pierTempDirectory] $ \dir -> do-    exists <- Directory.doesDirectoryExist dir-    when exists $ forFileRecursive_ unfreeze dir-  where-    unfreeze DirectoryStart f =-        getPermissions f >>= setPermissions f . setOwnerWritable True-    unfreeze _ _ = return ()- -- Symlink the artifact into the given destination directory. linkArtifact :: FilePath -> Artifact -> IO () linkArtifact _ (Artifact External f)@@ -718,7 +551,7 @@         let out = tmpDir </> path         createParentIfMissing out         liftIO $ writeFile out contents-    return $ Artifact (Built h) $ normaliseMore path+    return $ builtArtifact h path  doesArtifactExist :: Artifact -> Action Bool doesArtifactExist (Artifact External f) = Development.Shake.doesFileExist f@@ -746,7 +579,7 @@ -- | Group source files by shadowing into a single directory. groupFiles :: Artifact -> [(FilePath, FilePath)] -> Action Artifact groupFiles dir files = let out = "group"-                   in runCommand (output out)+                   in runCommandOutput out                         $ createDirectoryA out                         <> foldMap (\(f, g) -> shadow (dir /> f) (out </> g))                             files

@@ -1,73 +0,0 @@-module Pier.Core.Directory-    ( forFileRecursive_-    , FileItem(..)-    , getRegularContents-    , createParentIfMissing-    , copyDirectory-    , parentDirectory-    ) where--import Control.Monad.IO.Class-import Development.Shake.FilePath-import System.Directory-import qualified System.Posix.Files as Posix---- | Create recursively the parent of the given path, if it doesn't exist.-createParentIfMissing :: MonadIO m => FilePath -> m ()-createParentIfMissing-    = liftIO . createDirectoryIfMissing True . parentDirectory---- | Get the parent of the given directory or file.------ Examples:------ parentDirectory "foo/bar"  == "foo"--- parentDirectory "foo/bar/" == "foo"--- parentDirectory "foo" == ""-parentDirectory :: FilePath -> FilePath-parentDirectory = fixPeriod . takeDirectory . dropTrailingPathSeparator-  where-    fixPeriod "." = ""-    fixPeriod x = x--data FileItem = RegularFile | DirectoryStart | DirectoryEnd | SymbolicLink--forFileRecursive_ :: (FileItem -> FilePath -> IO ()) -> FilePath -> IO ()-forFileRecursive_ act f = do-    isSymLink <- pathIsSymbolicLink f-    if isSymLink-        then act SymbolicLink f-        else do-            isDir <- doesDirectoryExist f-            if not isDir-                then act RegularFile f-                else do-                    act DirectoryStart f-                    getRegularContents f-                        >>= mapM_ (forFileRecursive_ act . (f </>))-                    act DirectoryEnd f---- | Get the contents of this path, excluding the special files "." and ".."-getRegularContents :: FilePath -> IO [FilePath]-getRegularContents f =-    filter (not . specialFile) <$> getDirectoryContents f-  where-    specialFile "." = True-    specialFile ".." = True-    specialFile _ = False---- | Copy the directory recursively from the source to the target location.--- Hard-link files, and copy any symlinks.-copyDirectory :: FilePath -> FilePath -> IO ()-copyDirectory src dest = do-    createParentIfMissing dest-    forFileRecursive_ act src-  where-    act RegularFile f = Posix.createLink f $ dest </> makeRelative src f-    act SymbolicLink f = do-        target <- getSymbolicLinkTarget f-        let g = dest </> makeRelative src f-        createParentIfMissing g-        createFileLink target g-    act DirectoryStart f = createDirectoryIfMissing False (dest </> makeRelative src f)-    act DirectoryEnd _ = return ()

@@ -2,10 +2,8 @@     ( askDownload     , Download(..)     , downloadRules-    , DownloadLocation(..)     ) where -import Control.Exception (bracketOnError) import Control.Monad (unless) import Development.Shake import Development.Shake.Classes@@ -17,12 +15,13 @@  import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as L-import qualified System.Directory as Directory+import qualified Data.Text as T+import qualified Data.Text.Encoding as T  import Pier.Core.Artifact-import Pier.Core.Directory+import Pier.Core.Internal.Directory+import Pier.Core.Internal.Store import Pier.Core.Persistent-import Pier.Core.Run  -- | Downloads @downloadUrlPrefix / downloadName@ to -- @downloadFilePrefix / downloadName@.@@ -30,14 +29,12 @@ data Download = Download     { downloadUrlPrefix :: String     , downloadName :: FilePath-    , downloadFilePrefix :: FilePath-        }+    }     deriving (Typeable, Eq, Generic)  instance Show Download where     show d = "Download " ++ show (downloadName d)             ++ " from " ++ show (downloadUrlPrefix d)-            ++ " into " ++ show (downloadFilePrefix d)  instance Hashable Download instance Binary Download@@ -48,43 +45,26 @@ askDownload :: Download -> Action Artifact askDownload = askPersistent --- TODO: make this its own rule type?-downloadRules :: DownloadLocation -> Rules ()-downloadRules loc = do+downloadRules :: Maybe SharedCache -> Rules ()+downloadRules sharedCache = do     manager <- liftIO $ newManager tlsManagerSettings     addPersistent $ \d -> do-    -- Download to a shared location under $HOME/.pier, if it doesn't-    -- already exist (atomically); then make an artifact that symlinks to it.-    downloadsDir <- liftIO $ pierDownloadsDir loc-    let result = downloadsDir </> downloadFilePrefix d-                                        </> downloadName d-    exists <- liftIO $ Directory.doesFileExist result-    unless exists $ do-        putNormal $ "Downloading " ++ downloadName d-        -- TODO: fix the race-        liftIO $ bracketOnError-            (createPierTempFile $ takeFileName $ downloadName d)-            Directory.removeFile-            $ \tmp -> do-                        let url = downloadUrlPrefix d ++ "/" ++ downloadName d-                        req <- parseRequest url-                        resp <- httpLbs req manager-                        unless (statusIsSuccessful . responseStatus $ resp)-                            $ error $ "Unable to download " ++ show url-                                    ++ "\nStatus: " ++ showStatus (responseStatus resp)-                        liftIO . L.writeFile tmp . responseBody $ resp-                        createParentIfMissing result-                        Directory.renameFile tmp result-    return $ externalFile result+    h <- makeHash . T.encodeUtf8 . T.pack+            $ "download: " ++ show d+    let name = downloadName d+    let msg = "Downloading " ++ name+    createArtifacts sharedCache h [msg] $ \tmpDir -> do+        let out = tmpDir </> name+        createParentIfMissing out+        putNormal msg+        liftIO $ do+            let url = downloadUrlPrefix d ++ "/" ++ downloadName d+            req <- parseRequest url+            resp <- httpLbs req manager+            unless (statusIsSuccessful . responseStatus $ resp)+                $ error $ "Unable to download " ++ show url+                        ++ "\nStatus: " ++ showStatus (responseStatus resp)+            liftIO . L.writeFile out . responseBody $ resp+    return $ builtArtifact h name   where     showStatus s = show (statusCode s) ++ " " ++ BC.unpack (statusMessage s)--pierDownloadsDir :: DownloadLocation -> IO FilePath-pierDownloadsDir DownloadToHome = do-    home <- Directory.getHomeDirectory-    return $ home </> ".pier/downloads"-pierDownloadsDir DownloadLocal = return $ pierFile "downloads"--data DownloadLocation-    = DownloadToHome-    | DownloadLocal

@@ -1,15 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Pier.Core.HashableSet-    ( HashableSet(..)-    ) where--import qualified Data.Set as Set-import Development.Shake.Classes---- | A newtype wrapper for 'Data.Set' which is an instance of 'Hashable',--- so it can be used in Shake rules.-newtype HashableSet a = HashableSet { unHashableSet :: Set.Set a }-    deriving (Eq, Binary, NFData, Semigroup, Monoid)--instance Hashable a => Hashable (HashableSet a) where-    hashWithSalt k = hashWithSalt k . Set.toList . unHashableSet

@@ -0,0 +1,73 @@+module Pier.Core.Internal.Directory+    ( forFileRecursive_+    , FileItem(..)+    , getRegularContents+    , createParentIfMissing+    , copyDirectory+    , parentDirectory+    ) where++import Control.Monad.IO.Class+import Development.Shake.FilePath+import System.Directory+import qualified System.Posix.Files as Posix++-- | Create recursively the parent of the given path, if it doesn't exist.+createParentIfMissing :: MonadIO m => FilePath -> m ()+createParentIfMissing+    = liftIO . createDirectoryIfMissing True . parentDirectory++-- | Get the parent of the given directory or file.+--+-- Examples:+--+-- parentDirectory "foo/bar"  == "foo"+-- parentDirectory "foo/bar/" == "foo"+-- parentDirectory "foo" == ""+parentDirectory :: FilePath -> FilePath+parentDirectory = fixPeriod . takeDirectory . dropTrailingPathSeparator+  where+    fixPeriod "." = ""+    fixPeriod x = x++data FileItem = RegularFile | DirectoryStart | DirectoryEnd | SymbolicLink++forFileRecursive_ :: (FileItem -> FilePath -> IO ()) -> FilePath -> IO ()+forFileRecursive_ act f = do+    isSymLink <- pathIsSymbolicLink f+    if isSymLink+        then act SymbolicLink f+        else do+            isDir <- doesDirectoryExist f+            if not isDir+                then act RegularFile f+                else do+                    act DirectoryStart f+                    getRegularContents f+                        >>= mapM_ (forFileRecursive_ act . (f </>))+                    act DirectoryEnd f++-- | Get the contents of this path, excluding the special files "." and ".."+getRegularContents :: FilePath -> IO [FilePath]+getRegularContents f =+    filter (not . specialFile) <$> getDirectoryContents f+  where+    specialFile "." = True+    specialFile ".." = True+    specialFile _ = False++-- | Copy the directory recursively from the source to the target location.+-- Hard-link files, and copy any symlinks.+copyDirectory :: FilePath -> FilePath -> IO ()+copyDirectory src dest = do+    createParentIfMissing dest+    forFileRecursive_ act src+  where+    act RegularFile f = Posix.createLink f $ dest </> makeRelative src f+    act SymbolicLink f = do+        target <- getSymbolicLinkTarget f+        let g = dest </> makeRelative src f+        createParentIfMissing g+        createFileLink target g+    act DirectoryStart f = createDirectoryIfMissing False (dest </> makeRelative src f)+    act DirectoryEnd _ = return ()

@@ -0,0 +1,15 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Pier.Core.Internal.HashableSet+    ( HashableSet(..)+    ) where++import qualified Data.Set as Set+import Development.Shake.Classes++-- | A newtype wrapper for 'Data.Set' which is an instance of 'Hashable',+-- so it can be used in Shake rules.+newtype HashableSet a = HashableSet { unHashableSet :: Set.Set a }+    deriving (Eq, Binary, NFData, Semigroup, Monoid)++instance Hashable a => Hashable (HashableSet a) where+    hashWithSalt k = hashWithSalt k . Set.toList . unHashableSet

@@ -0,0 +1,257 @@+{-# LANGUAGE DeriveAnyClass #-}+module Pier.Core.Internal.Store+    ( -- * Temporary files and directories+      HandleTemps(..),+      withPierTempDirectory,+      withPierTempDirectoryAction,+      -- * Build directory+      pierDir,+      -- * Hash directories+      artifactDir,+      Hash,+      hashString,+      hashDir,+      makeHash,+      createArtifacts,+      unfreezeArtifacts,+      SharedCache(..),+      hashExternalFile,+      -- * Artifacts+      Artifact(..),+      Source(..),+      builtArtifact,+      external,+      (/>),+      -- * Rules+      storeRules,+    ) where++import Control.Monad (forM_, when, void)+import Control.Monad.IO.Class+import Crypto.Hash.SHA256 (hashlazy, hash)+import Data.ByteString.Base64 (encode)+import Development.Shake+import Development.Shake.Classes hiding (hash)+import Development.Shake.FilePath+import GHC.Generics+import System.Directory as Directory+import System.IO.Temp++import qualified Data.Binary as Binary+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.List as List++import Pier.Core.Internal.Directory++pierDir :: FilePath+pierDir = "_pier"++data HandleTemps = RemoveTemps | KeepTemps++withPierTempDirectoryAction+    :: HandleTemps -> String -> (FilePath -> Action a) -> Action a+withPierTempDirectoryAction KeepTemps template f =+    createPierTempDirectory template >>= f+withPierTempDirectoryAction RemoveTemps template f = do+    tmp <- createPierTempDirectory template+    f tmp `actionFinally` removeDirectoryRecursive tmp++withPierTempDirectory+    :: HandleTemps -> String -> (FilePath -> IO a) -> IO a+withPierTempDirectory KeepTemps template f =+    createPierTempDirectory template >>= f+withPierTempDirectory RemoveTemps template f = do+    createDirectoryIfMissing True pierTempDirectory+    withTempDirectory pierTempDirectory template f++pierTempDirectory :: String+pierTempDirectory = pierDir </> "tmp"++createPierTempDirectory :: MonadIO m => String -> m FilePath+createPierTempDirectory template = liftIO $ do+    createDirectoryIfMissing True pierTempDirectory+    createTempDirectory pierTempDirectory template++-- | Unique identifier of a command+newtype Hash = Hash B.ByteString+    deriving (Show, Eq, Ord, Binary, NFData, Hashable, Generic)++makeHash :: Binary a => a -> Action Hash+makeHash x = do+    version <- askOracle GetArtifactVersion+    return . Hash . fixChars . dropPadding . encode . hashlazy . Binary.encode+         . tagVersion version+        $ x+  where+    -- Remove slashes, since the strings will appear in filepaths.+    fixChars = BC.map $ \case+                                '/' -> '_'+                                c -> c+    -- Padding just adds noise, since we don't have length requirements (and indeed+    -- every sha256 hash is 32 bytes)+    dropPadding c+        | BC.last c == '=' = BC.init c+        -- Shouldn't happen since each hash is the same length:+        | otherwise = c+    tagVersion = (,)++hashExternalFile :: FilePath -> IO B.ByteString+hashExternalFile = fmap hash . B.readFile++-- | Version number of artifacts being generated.+newtype ArtifactVersion = ArtifactVersion Int+    deriving (Show,Typeable,Eq,Hashable,Binary,NFData,Generic)++data GetArtifactVersion = GetArtifactVersion+    deriving (Show,Typeable,Eq,Hashable,Binary,NFData,Generic)+type instance RuleResult GetArtifactVersion = ArtifactVersion++artifactVersionRule :: Rules ()+artifactVersionRule = void $ addOracle $ \GetArtifactVersion+    -- Bumping this will cause every artifact to be regenerated, and should+    -- only be done in case of backwards-incompatible changes.+    -> return $ ArtifactVersion 1++hashDir :: Hash -> FilePath+hashDir h = artifactDir </> hashString h++hashString :: Hash -> String+hashString (Hash h) = BC.unpack h++storeRules :: Rules ()+storeRules = artifactVersionRule++newtype SharedCache = SharedCache FilePath++globalHashDir :: SharedCache -> Hash -> FilePath+globalHashDir (SharedCache f) h = f </> hashString h++-- | Create a directory containing Artifacts.+--+-- If the output directory already exists, don't do anything.  Otherwise, run+-- the given function with a temporary directory, and then move that directory+-- atomically to the final output directory for those Artifacts.+-- Files and (sub)directories, as well as the directory itself, will+-- be made read-only.+createArtifacts ::+       Maybe SharedCache+    -> Hash+    -> [String] -- ^ Messages to print if cached+    -> (FilePath -> Action ())+    -> Action ()+createArtifacts maybeSharedCache h messages act = do+    let destDir = hashDir h+    exists <- liftIO $ Directory.doesDirectoryExist destDir+    -- Skip if the output directory already exists; we'll produce it atomically+    -- below.  This could happen if Shake's database was cleaned, or if the+    -- action stops before Shake registers it as complete, due to either a+    -- synchronous or asynchronous exception.+    if exists+        then mapM_ cacheMessage messages+        else do+            tempDir <- createPierTempDirectory $ hashString h ++ "-result"+            case maybeSharedCache of+                Nothing -> act tempDir+                Just cache -> do+                    getFromSharedCache <- liftIO $ copyFromCache cache h tempDir+                    if getFromSharedCache+                        then mapM_ sharedCacheMessage messages+                        else do+                            act tempDir+                            liftIO $ copyToCache cache h tempDir+            liftIO $ finish tempDir destDir+  where+    cacheMessage m = putNormal $ "(from cache: " ++ m ++ ")"+    sharedCacheMessage m = putNormal $ "(from shared cache: " ++ m ++ ")"+    finish tempDir destDir = do+        -- Move the created directory to its final location,+        -- with all the files and directories inside set to+        -- read-only.+        -- Don't set permissions on symbolic links; they're ignored+        -- on most systems (e.g., Linux).+        let freeze RegularFile = freezePath+            freeze DirectoryEnd = freezePath+            freeze _ = const $ return ()+        -- TODO: why is getRegularContents used?+        -- Ah, to avoid the current directory.+        getRegularContents tempDir+            >>= mapM_ (forFileRecursive_ freeze . (tempDir </>))+        createParentIfMissing destDir+        Directory.renameDirectory tempDir destDir+        -- Also set the directory itself to read-only, but wait+        -- until the last step since read-only files can't be moved.+        freezePath destDir++-- TODO: consider using hard links for these copies, to save space+-- TODO: make sure the directories are read-only+copyFromCache :: SharedCache -> Hash -> FilePath -> IO Bool+copyFromCache cache h tempDir = do+    let globalDir = globalHashDir cache h+    globalExists <- liftIO $ Directory.doesDirectoryExist globalDir+    if globalExists+        then copyDirectory globalDir tempDir >> return True+        else return False++copyToCache :: SharedCache -> Hash -> FilePath -> IO ()+copyToCache cache h src = do+    tempDir <- createPierTempDirectory $ hashString h ++ "-cache"+    copyDirectory src tempDir+    let dest = globalHashDir cache h+    createParentIfMissing dest+    Directory.renameDirectory tempDir dest++artifactDir :: FilePath+artifactDir = pierDir </> "artifact"++freezePath :: FilePath -> IO ()+freezePath f =+    getPermissions f >>= setPermissions f . setOwnerWritable False++-- | Make all artifacts user-writable, so they can be deleted by `clean-all`.+unfreezeArtifacts :: IO ()+unfreezeArtifacts = forM_ [artifactDir, pierTempDirectory] $ \dir -> do+    exists <- Directory.doesDirectoryExist dir+    when exists $ forFileRecursive_ unfreeze dir+  where+    unfreeze DirectoryStart f =+        getPermissions f >>= setPermissions f . setOwnerWritable True+    unfreeze _ _ = return ()++-- | An 'Artifact' is a file or folder that was created by a build command.+data Artifact = Artifact Source FilePath+    deriving (Eq, Ord, Generic, Hashable, Binary, NFData)++instance Show Artifact where+    show (Artifact External f) = "external:" ++ show f+    show (Artifact (Built h) f) = hashString h ++ ":" ++ show f++data Source = Built Hash | External+    deriving (Show, Eq, Ord, Generic, Hashable, Binary, NFData)++builtArtifact :: Hash -> FilePath -> Artifact+builtArtifact h = Artifact (Built h) . normaliseMore++-- | Create an 'Artifact' from an input file to the build (for example, a+-- source file created by the user).+--+-- If it is a relative path, changes to the file will cause rebuilds of+-- Commands and Rules that dependended on it.+external :: FilePath -> Artifact+external f+    | null f' = error "external: empty input"+    | artifactDir `List.isPrefixOf` f' = error $ "external: forbidden prefix: " ++ show f'+    | otherwise = Artifact External f'+  where+    f' = normaliseMore f++-- | Normalize a filepath, also dropping the trailing slash.+normaliseMore :: FilePath -> FilePath+normaliseMore = dropTrailingPathSeparator . normalise++-- | Create a reference to a sub-file of the given 'Artifact', which must+-- refer to a directory.+(/>) :: Artifact -> FilePath -> Artifact+Artifact source f /> g = Artifact source $ normaliseMore $ f </> g++infixr 5 />  -- Same as </>

@@ -1,29 +1,12 @@ module Pier.Core.Run     ( -- * Build directory       runPier-    , pierFile     , cleanAll-    -- * Temporary files and directories-    , HandleTemps(..)-    , withPierTempDirectory-    , withPierTempDirectoryAction-    , pierTempDirectory-    , createPierTempDirectory-    , createPierTempFile     ) where -import Control.Monad.IO.Class import Development.Shake-import Development.Shake.FilePath-import System.Directory-import System.IO.Temp -pierDir :: FilePath-pierDir = "_pier"---- TODO: newtype describing inputs/outputs:-pierFile :: FilePattern -> FilePattern-pierFile = (pierDir </>)+import Pier.Core.Internal.Store  runPier :: Rules () -> IO () runPier = shakeArgs shakeOptions@@ -39,33 +22,4 @@             putNormal $ "Removing " ++ pierDir             removeFilesAfter pierDir ["//"] -data HandleTemps = RemoveTemps | KeepTemps -withPierTempDirectoryAction-    :: HandleTemps -> String -> (FilePath -> Action a) -> Action a-withPierTempDirectoryAction KeepTemps template f =-    createPierTempDirectory template >>= f-withPierTempDirectoryAction RemoveTemps template f = do-    tmp <- createPierTempDirectory template-    f tmp `actionFinally` removeDirectoryRecursive tmp--withPierTempDirectory-    :: HandleTemps -> String -> (FilePath -> IO a) -> IO a-withPierTempDirectory KeepTemps template f =-    createPierTempDirectory template >>= f-withPierTempDirectory RemoveTemps template f = do-    createDirectoryIfMissing True pierTempDirectory-    withTempDirectory pierTempDirectory template f--pierTempDirectory :: String-pierTempDirectory = pierDir </> "tmp"--createPierTempDirectory :: MonadIO m => String -> m FilePath-createPierTempDirectory template = liftIO $ do-    createDirectoryIfMissing True pierTempDirectory-    createTempDirectory pierTempDirectory template--createPierTempFile :: MonadIO m => String -> m FilePath-createPierTempFile template = liftIO $ do-    createDirectoryIfMissing True pierTempDirectory-    writeTempFile pierTempDirectory template ""