diff --git a/pier-core.cabal b/pier-core.cabal --- a/pier-core.cabal +++ b/pier-core.cabal @@ -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 - . + . . 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 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 diff --git a/src/Pier/Core/Artifact.hs b/src/Pier/Core/Artifact.hs --- a/src/Pier/Core/Artifact.hs +++ b/src/Pier/Core/Artifact.hs @@ -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 diff --git a/src/Pier/Core/Directory.hs b/src/Pier/Core/Directory.hs deleted file mode 100644 --- a/src/Pier/Core/Directory.hs +++ /dev/null @@ -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 () diff --git a/src/Pier/Core/Download.hs b/src/Pier/Core/Download.hs --- a/src/Pier/Core/Download.hs +++ b/src/Pier/Core/Download.hs @@ -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 diff --git a/src/Pier/Core/HashableSet.hs b/src/Pier/Core/HashableSet.hs deleted file mode 100644 --- a/src/Pier/Core/HashableSet.hs +++ /dev/null @@ -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 diff --git a/src/Pier/Core/Internal/Directory.hs b/src/Pier/Core/Internal/Directory.hs new file mode 100644 --- /dev/null +++ b/src/Pier/Core/Internal/Directory.hs @@ -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 () diff --git a/src/Pier/Core/Internal/HashableSet.hs b/src/Pier/Core/Internal/HashableSet.hs new file mode 100644 --- /dev/null +++ b/src/Pier/Core/Internal/HashableSet.hs @@ -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 diff --git a/src/Pier/Core/Internal/Store.hs b/src/Pier/Core/Internal/Store.hs new file mode 100644 --- /dev/null +++ b/src/Pier/Core/Internal/Store.hs @@ -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 diff --git a/src/Pier/Core/Run.hs b/src/Pier/Core/Run.hs --- a/src/Pier/Core/Run.hs +++ b/src/Pier/Core/Run.hs @@ -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 ""