Store.hs

{-# 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 </>