content: {- | A generic approach to building and caching file outputs.
  
  This is a layer on top of Shake which enables build actions to be written in a
  "forwards" style.  For example:
  
  > runPier $ action $ do
  >     contents <- lines <$> readArtifactA (external "result.txt")
  >     let result = "result.tar"
  >     runCommandOutput result
  >        $ foldMap input contents
  >          <> prog "tar" (["-cf", result] ++ map pathIn contents)
  
  This approach generally leads to simpler logic than backwards-defined build systems such as
  make or (normal) Shake, where each step of the build logic must be written as a
  new build rule.
  
  Inputs and outputs of a command must be declared up-front, using the 'input'
  and 'output' functions respectively.  This enables isolated, deterministic
  build steps which are each run in their own temporary directory.
  
  Output files are stored in the location
  
  > _pier/artifact/HASH/path/to/file
  
  where @HASH@ is a string that uniquely determines the action generating
  that file.  In particular, there is no need to worry about choosing distinct names
  for outputs of different commands.
  
  Note that 'Development.Shake.Forward' has similar motivation to this module,
  but instead uses @fsatrace@ to detect what files changed after the fact.
  Unfortunately, that approach is not portable.  Additionally, it makes it
  difficult to isolate steps and make the build more reproducible (for example,
  to prevent the output of one step being mutated by a later one) since every
  output file could potentially be an input to every action.  Finally, by
  explicitly declaring outputs we can detect sooner when a command doesn't
  produce the files that we expect.
  
  -}
  {-# LANGUAGE DeriveAnyClass #-}
  {-# LANGUAGE TypeOperators #-}
  module Pier.Core.Artifact
      ( -- * Rules
        artifactRules
      , SharedCache(..)
      , HandleTemps(..)
        -- * Artifact
      , Artifact
      , external
      , (/>)
      , replaceArtifactExtension
      , readArtifact
      , readArtifactB
      , doesArtifactExist
      , matchArtifactGlob
      , unfreezeArtifacts
      , callArtifact
        -- * Creating artifacts
      , writeArtifact
      , runCommand
      , runCommandOutput
      , runCommand_
      , runCommandStdout
      , Command
      , message
        -- ** Command outputs
      , Output
      , output
        -- ** Command inputs
      , input
      , inputs
      , inputList
      , shadow
      , groupFiles
        -- * Running commands
      , prog
      , progA
      , progTemp
      , pathIn
      , withCwd
      , createDirectoryA
      ) where
  
  import Control.Monad (forM_, when, unless)
  import Control.Monad.IO.Class
  import Data.Set (Set)
  import Development.Shake
  import Development.Shake.Classes
  import Development.Shake.FilePath
  import GHC.Generics
  import System.Directory as Directory
  import System.Exit (ExitCode(..))
  import System.Process.Internals (translate)
  
  import qualified Data.ByteString as B
  import qualified Data.ByteString.Char8 as BC
  import qualified Data.List as List
  import qualified Data.Map.Strict as Map
  import qualified Data.Set as Set
  import qualified Data.Text as T
  import qualified Data.Text.Encoding as T
  import qualified Data.Text.Encoding.Error as T hiding (replace)
  
  import Pier.Core.Internal.Directory
  import Pier.Core.Internal.HashableSet
  import Pier.Core.Internal.Store
  import Pier.Core.Persistent
  
  -- | A hermetic build step.  Consists of a sequence of calls to 'message',
  -- 'prog'/'progA'/'progTemp', and/or 'shadow', which may be combined using '<>'/'mappend'.
  -- Also specifies the input 'Artifacts' that are used by those commands.
  data Command = Command
      { _commandProgs :: [Prog]
      , commandInputs :: HashableSet Artifact
      }
      deriving (Typeable, Eq, Generic, Hashable, Binary, NFData)
  
  data Call
      = CallEnv String -- picked up from $PATH
      | CallArtifact Artifact
      | CallTemp FilePath -- Local file to this Command
                          -- (e.g. generated by an earlier call)
                          -- (This is a hack around shake which tries to resolve
                          -- local files in the env.)
      deriving (Typeable, Eq, Generic, Hashable, Binary, NFData)
  
  data Prog
      = ProgCall { _progCall :: Call
             , _progArgs :: [String]
             , progCwd :: FilePath  -- relative to the root of the sandbox
             }
      | Message String
      | Shadow Artifact FilePath
      deriving (Typeable, Eq, Generic, Hashable, Binary, NFData)
  
  instance Monoid Command where
      Command ps is `mappend` Command ps' is' = Command (ps ++ ps') (is <> is')
      mempty = Command [] mempty
  
  instance Semigroup Command where
      (<>) = mappend
  
  -- | Run an external command-line program with the given arguments.
  prog :: String -> [String] -> Command
  prog p as = Command [ProgCall (CallEnv p) as "."] mempty
  
  -- | Run an artifact as an command-line program with the given arguments.
  progA :: Artifact -> [String] -> Command
  progA p as = Command [ProgCall (CallArtifact p) as "."]
                  $ HashableSet $ Set.singleton p
  
  -- | Run a command-line program with the given arguments, where the program
  -- was created by a previous program.
  progTemp :: FilePath -> [String] -> Command
  progTemp p as = Command [ProgCall (CallTemp p) as "."] mempty
  
  -- | Prints a status message for the user when this command runs.
  message :: String -> Command
  message s = Command [Message s] mempty
  
  -- | Runs a command within the given (relative) directory.
  withCwd :: FilePath -> Command -> Command
  withCwd path (Command ps as)
      | isAbsolute path = error $ "withCwd: expected relative path, got " ++ show path
      | otherwise = Command (map setPath ps) as
    where
      setPath m@Message{} = m
      setPath p = p { progCwd = path }
  
  -- | Specify that an 'Artifact' should be made available to program calls within this
  -- 'Command'.
  --
  -- Note that the order does not matter; `input f <> cmd === cmd <> input f`.
  input :: Artifact -> Command
  input = inputs . Set.singleton
  
  inputList :: [Artifact] -> Command
  inputList = inputs . Set.fromList
  
  -- | Specify that a set of 'Artifact's should be made available to program calls within this
  -- 'Command'.
  inputs :: Set Artifact -> Command
  inputs = Command [] . HashableSet
  
  -- | Make a "shadow" copy of the given input artifact's by create a symlink of
  -- this artifact (if it is a file) or of each sub-file (transitively, if it is
  -- a directory).
  --
  -- The result may be captured as output, for example when grouping multiple outputs
  -- of separate commands into a common directory structure.
  shadow :: Artifact -> FilePath -> Command
  shadow a f
      | isAbsolute f = error $ "shadowArtifact: need relative destination, found "
                              ++ show f
      | otherwise = Command [Shadow a f] mempty
  
  -- | The output of a given command.
  --
  -- Multiple outputs may be combined using the 'Applicative' instance.
  data Output a = Output [FilePath] (Hash -> a)
  
  instance Functor Output where
      fmap f (Output g h) = Output g (f . h)
  
  instance Applicative Output where
      pure = Output [] . const
      Output f g <*> Output f' g' = Output (f ++ f') (g <*> g')
  
  -- | Register a single output of a command.
  --
  -- The input must be a relative path and nontrivial (i.e., not @"."@ or @""@).
  output :: FilePath -> Output Artifact
  output 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 builtArtifact f
    where
      ds = splitDirectories f
  
  externalArtifactDir :: FilePath
  externalArtifactDir = artifactDir </> "external"
  
  artifactRules :: Maybe SharedCache -> HandleTemps -> Rules ()
  artifactRules cache ht = do
      liftIO createExternalLink
      commandRules cache ht
      writeArtifactRules cache
      storeRules
  
  createExternalLink :: IO ()
  createExternalLink = do
      exists <- doesPathExist externalArtifactDir
      unless exists $ do
          createParentIfMissing externalArtifactDir
          createDirectoryLink "../.." externalArtifactDir
  
  -- | The build rule type for commands.
  data CommandQ = CommandQ
      { commandQCmd :: Command
      , _commandQOutputs :: [FilePath]
      }
      deriving (Eq, Generic)
  
  instance Show CommandQ where
      show CommandQ { commandQCmd = Command progs _ }
          = let msgs = List.intercalate "; " [m | Message m <- progs]
            in "Command" ++
                  if null msgs
                      then ""
                      else ": " ++ msgs
  
  instance Hashable CommandQ
  instance Binary CommandQ
  instance NFData CommandQ
  
  type instance RuleResult CommandQ = Hash
  
  -- TODO: sanity-check filepaths; for example, normalize, should be relative, no
  -- "..", etc.
  commandHash :: CommandQ -> Action Hash
  commandHash cmdQ = do
      let externalFiles = [f | Artifact External f <- Set.toList
                                                          . unHashableSet
                                                          . commandInputs
                                                          $ commandQCmd cmdQ
                             , isRelative f
                          ]
      need externalFiles
      -- TODO: streaming hash
      userFileHashes <- liftIO $ mapM hashExternalFile externalFiles
      makeHash ("commandHash", cmdQ, userFileHashes)
  
  -- | Run the given command, capturing the specified outputs.
  runCommand :: Output t -> Command -> Action t
  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 <- runCommandOutput stdoutOutput c
      liftIO $ readFile $ pathIn out
  
  -- | Run the given command without capturing its output.  Can be used to check
  -- consistency of the outputs of previous commands.
  runCommand_ :: Command -> Action ()
  runCommand_ = runCommand (pure ())
  
  commandRules :: Maybe SharedCache -> HandleTemps -> Rules ()
  commandRules sharedCache ht = addPersistent $ \cmdQ@(CommandQ (Command progs inps) outs) -> do
      putChatty $ showCommand cmdQ
      h <- commandHash cmdQ
      createArtifacts sharedCache h (progMessages progs) $ \resultDir ->
        -- Run the command within a separate temporary directory.
        -- When it's done, we'll move the explicit set of outputs into
        -- the result location.
        withPierTempDirectoryAction ht (hashString h) $ \tmpDir -> do
          let tmpPathOut = (tmpDir </>)
  
          liftIO $ collectInputs (unHashableSet inps) tmpDir
          mapM_ (createParentIfMissing . tmpPathOut) outs
  
          -- Run the command, and write its stdout to a special file.
          root <- liftIO getCurrentDirectory
          stdoutStr <- B.concat <$> mapM (readProg (root </> tmpDir)) progs
  
          let stdoutPath = tmpPathOut stdoutOutput
          createParentIfMissing stdoutPath
          liftIO $ B.writeFile stdoutPath stdoutStr
  
          -- Check that all the output files exist, and move them
          -- into the output directory.
          liftIO $ forM_ outs $ \f -> do
              let src = tmpPathOut f
              let dest = resultDir </> f
              exist <- Directory.doesPathExist src
              unless exist $
                  error $ "runCommand: missing output "
                          ++ show f
                          ++ " in temporary directory "
                          ++ show tmpDir
              createParentIfMissing dest
              renamePath src dest
      return h
  
  putChatty :: String -> Action ()
  putChatty s = do
      v <- shakeVerbosity <$> getShakeOptions
      when (v >= Chatty) $ putNormal s
  
  progMessages :: [Prog] -> [String]
  progMessages ps = [m | Message m <- ps]
  
  -- TODO: more hermetic?
  collectInputs :: Set Artifact -> FilePath -> IO ()
  collectInputs inps tmp = do
      let inps' = dedupArtifacts inps
      checkAllDistinctPaths inps'
      liftIO $ mapM_ (linkArtifact tmp) inps'
  
  -- 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
  -- from the PATH that the `pier` executable sees).
  readProg :: FilePath -> Prog -> Action B.ByteString
  readProg _ (Message s) = do
      putNormal s
      return B.empty
  readProg dir (ProgCall p as cwd) = readProgCall dir p as cwd
  readProg dir (Shadow a0 f0) = do
      liftIO $ linkShadow dir a0 f0
      return B.empty
  
  readProgCall :: FilePath -> Call -> [String] -> FilePath -> Action BC.ByteString
  readProgCall dir p as cwd = do
      -- hack around shake weirdness w.r.t. relative binary paths
      let p' = case p of
                  CallEnv s -> s
                  CallArtifact f -> dir </> pathIn f
                  CallTemp f -> dir </> f
      (ret, Stdout out, Stderr err)
          <- quietly $ command
                      [ Cwd $ dir </> cwd
                      , Env defaultEnv
                      -- stderr will get printed if there's an error.
                      , EchoStderr False
                      ]
                      p' (map (spliceTempDir dir) as)
      let errStr = T.unpack . T.decodeUtf8With T.lenientDecode $ err
      case ret of
          ExitSuccess -> return out
          ExitFailure ec -> do
              v <- shakeVerbosity <$> getShakeOptions
              fail $ if v < Loud
                  -- TODO: remove trailing newline
                  then errStr
                  else unlines
                          [ showProg (ProgCall p as cwd)
                          , "Working dir: " ++ translate (dir </> cwd)
                          , "Exit code: " ++ show ec
                          , "Stderr:"
                          , errStr
                          ]
  
  -- TODO: use forFileRecursive_
  linkShadow :: FilePath -> Artifact -> FilePath -> IO ()
  linkShadow dir a0 f0 = do
      createParentIfMissing (dir </> f0)
      loop a0 f0
    where
      loop a f = do
          let aPath = pathIn a
          isDir <- Directory.doesDirectoryExist aPath
          if isDir
              then do
                  Directory.createDirectoryIfMissing False (dir </> f)
                  cs <- getRegularContents aPath
                  mapM_ (\c -> loop (a /> c) (f </> c)) cs
              else do
                  srcExists <- Directory.doesFileExist aPath
                  destExists <- Directory.doesPathExist (dir </> f)
                  let aPath' = case a of
                                  Artifact External aa -> "external" </> aa
                                  Artifact (Built h) aa -> hashString h </> aa
                  if
                      | not srcExists -> error $ "linkShadow: missing source "
                                                  ++ show aPath
                      | destExists -> error $ "linkShadow: destination already exists: "
                                                  ++ show f
                      | otherwise -> createFileLink
                                      (relPathUp f </> "../../artifact" </> aPath')
                                      (dir </> f)
      relPathUp = joinPath . map (const "..") . splitDirectories . parentDirectory
  
  showProg :: Prog -> String
  showProg (Shadow a f) = unwords ["Shadow:", pathIn a, "=>", f]
  showProg (Message m) = "Message: " ++ show m
  showProg (ProgCall call args cwd) =
      wrapCwd
          . List.intercalate " \\\n    "
          $ showCall call : args
    where
      wrapCwd s = case cwd of
                      "." -> s
                      _ -> "(cd " ++ translate cwd ++ " &&\n " ++ s ++ ")"
  
      showCall (CallArtifact a) = pathIn a
      showCall (CallEnv f) = f
      showCall (CallTemp f) = f -- TODO: differentiate from CallEnv
  
  showCommand :: CommandQ -> String
  showCommand (CommandQ (Command progs inps) outputs) = unlines $
      map showOutput outputs
      ++ map showInput (Set.toList $ unHashableSet inps)
      ++ map showProg progs
    where
      showOutput a = "Output: " ++ a
      showInput i = "Input: " ++ pathIn i
  
  stdoutOutput :: FilePath
  stdoutOutput = "_stdout"
  
  defaultEnv :: [(String, String)]
  defaultEnv =
      [ ("PATH", "/usr/bin:/bin")
      -- Set LANG to enable TemplateHaskell code reading UTF-8 files correctly.
      , ("LANG", "en_US.UTF-8")
      ]
  
  spliceTempDir :: FilePath -> String -> String
  spliceTempDir tmp = T.unpack . T.replace (T.pack "${TMPDIR}") (T.pack tmp) . T.pack
  
  checkAllDistinctPaths :: Monad m => [Artifact] -> m ()
  checkAllDistinctPaths as =
      case Map.keys . Map.filter (> 1) . Map.fromListWith (+)
              . map (\a -> (pathIn a, 1 :: Integer)) $ as of
          [] -> return ()
          -- TODO: nicer error, telling where they came from:
          fs -> error $ "Artifacts generated from more than one command: " ++ show fs
  
  -- Remove duplicate artifacts that are both outputs of the same command, and where
  -- one is a subdirectory of the other (for example, constructed via `/>`).
  dedupArtifacts :: Set Artifact -> [Artifact]
  dedupArtifacts = loop . Set.toAscList
    where
      -- Loop over artifacts built from the same command.
      -- toAscList plus lexicographic sorting means that
      -- subdirectories with the same hash will appear consecutively after directories
      -- that contain them.
      loop (a@(Artifact (Built h) f) : Artifact (Built h') f' : fs)
          -- TODO BUG: "Picture", "Picture.hs" and Picture/Foo.hs" sort in the wrong way
          -- so "Picture" and "Picture/Foo.hs" aren't deduped.
          | h == h', (f <//> "*") ?== f' = loop (a:fs)
      loop (f:fs) = f : loop fs
      loop [] = []
  
  -- Symlink the artifact into the given destination directory.
  linkArtifact :: FilePath -> Artifact -> IO ()
  linkArtifact _ (Artifact External f)
      | isAbsolute f = return ()
  linkArtifact dir a = do
      curDir <- getCurrentDirectory
      let realPath = curDir </> realPathIn a
      let localPath = dir </> pathIn a
      createParentIfMissing localPath
      isFile <- Directory.doesFileExist realPath
      if isFile
          then createFileLink realPath localPath
          else do
              isDir <- Directory.doesDirectoryExist realPath
              if isDir
                  then createDirectoryLink realPath localPath
                  else error $ "linkArtifact: source does not exist: " ++ show realPath
                          ++ " for artifact " ++ show a
  
  
  -- | Returns the relative path to an Artifact within the sandbox, when provided
  -- to a 'Command' by 'input'.
  pathIn :: Artifact -> FilePath
  pathIn (Artifact External f) = externalArtifactDir </> f
  pathIn (Artifact (Built h) f) = hashDir h </> f
  
  -- | Returns the relative path to an artifact within the root directory.
  realPathIn :: Artifact -> FilePath
  realPathIn (Artifact External f) = f
  realPathIn (Artifact (Built h) f) = hashDir h </> f
  
  
  -- | Replace the extension of an Artifact.  In particular,
  --
  -- > pathIn (replaceArtifactExtension f ext) == replaceExtension (pathIn f) ext@
  replaceArtifactExtension :: Artifact -> String -> Artifact
  replaceArtifactExtension (Artifact s f) ext
      = Artifact s $ replaceExtension f ext
  
  -- | Read the contents of an Artifact.
  readArtifact :: Artifact -> Action String
  readArtifact (Artifact External f) = readFile' f -- includes need
  readArtifact f = liftIO $ readFile $ pathIn f
  
  readArtifactB :: Artifact -> Action B.ByteString
  readArtifactB (Artifact External f) = need [f] >> liftIO (B.readFile f)
  readArtifactB f = liftIO $ B.readFile $ pathIn f
  
  data WriteArtifactQ = WriteArtifactQ
      { writePath :: FilePath
      , writeContents :: String
      }
      deriving (Eq, Typeable, Generic, Hashable, Binary, NFData)
  
  instance Show WriteArtifactQ where
      show w = "Write " ++ writePath w
  
  type instance RuleResult WriteArtifactQ = Artifact
  
  writeArtifact :: FilePath -> String -> Action Artifact
  writeArtifact path contents = askPersistent $ WriteArtifactQ path contents
  
  writeArtifactRules :: Maybe SharedCache -> Rules ()
  writeArtifactRules sharedCache = addPersistent
          $ \WriteArtifactQ {writePath = path, writeContents = contents} -> do
      h <- makeHash . T.encodeUtf8 . T.pack
                  $ "writeArtifact: " ++ contents
      createArtifacts sharedCache h [] $ \tmpDir -> do
          let out = tmpDir </> path
          createParentIfMissing out
          liftIO $ writeFile out contents
      return $ builtArtifact h path
  
  doesArtifactExist :: Artifact -> Action Bool
  doesArtifactExist (Artifact External f) = Development.Shake.doesFileExist f
  doesArtifactExist f = liftIO $ Directory.doesFileExist (pathIn f)
  
  -- Note: this throws an exception if there's no match.
  matchArtifactGlob :: Artifact -> FilePath -> Action [FilePath]
  matchArtifactGlob (Artifact External f) g
      = getDirectoryFiles f [g]
  matchArtifactGlob a g
      = liftIO $ getDirectoryFilesIO (pathIn a) [g]
  
  -- TODO: merge more with above code?  How hermetic should it be?
  callArtifact :: HandleTemps -> Set Artifact -> Artifact -> [String] -> IO ()
  callArtifact ht inps bin args = withPierTempDirectory ht "exec" $ \tmp -> do
      dir <- getCurrentDirectory
      collectInputs (Set.insert bin inps) tmp
      cmd_ [Cwd tmp]
          (dir </> tmp </> pathIn bin) args
  
  createDirectoryA :: FilePath -> Command
  createDirectoryA f = prog "mkdir" ["-p", f]
  
  -- | Group source files by shadowing into a single directory.
  groupFiles :: Artifact -> [(FilePath, FilePath)] -> Action Artifact
  groupFiles dir files = let out = "group"
                     in runCommandOutput out
                          $ createDirectoryA out
                          <> foldMap (\(f, g) -> shadow (dir /> f) (out </> g))
                              files
  