Extract command

Changelog: Added `extract` command to extract artifacts

1 files changed, 105 insertions, 0 deletions

diff --git a/src/Command/Extract.hs b/src/Command/Extract.hs
new file mode 100644
index 0000000..b24a1af
--- /dev/null
+++ b/src/Command/Extract.hs
@@ -0,0 +1,105 @@
+module Command.Extract (
+    ExtractCommand,
+) where
+
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.IO.Class
+
+import Data.Text qualified as T
+
+import System.Console.GetOpt
+import System.Directory
+import System.FilePath
+
+import Command
+import Eval
+import Job.Types
+
+
+data ExtractCommand = ExtractCommand ExtractOptions ExtractArguments
+
+data ExtractArguments = ExtractArguments
+    { extractArtifacts :: [ ( JobRef, ArtifactName ) ]
+    , extractDestination :: FilePath
+    }
+
+instance CommandArgumentsType ExtractArguments where
+    argsFromStrings = \case
+        args@(_:_:_) -> do
+            extractArtifacts <- mapM toArtifactRef (init args)
+            extractDestination <- return (last args)
+            return ExtractArguments {..}
+          where
+            toArtifactRef tref = case T.splitOn "." (T.pack tref) of
+                parts@(_:_:_) -> return ( JobRef (init parts), ArtifactName (last parts) )
+                _             -> throwError $ "too few parts in artifact ref ‘" <> tref <> "’"
+        _ -> throwError "too few arguments"
+
+data ExtractOptions = ExtractOptions
+    { extractForce :: Bool
+    }
+
+instance Command ExtractCommand where
+    commandName _ = "extract"
+    commandDescription _ = "Extract artifacts generated by jobs"
+
+    type CommandArguments ExtractCommand = ExtractArguments
+
+    commandUsage _ = T.pack $ unlines $
+        [ "Usage: minici jobid [<option>...] <job ref>.<artifact>... <destination>"
+        ]
+
+    type CommandOptions ExtractCommand = ExtractOptions
+    defaultCommandOptions _ = ExtractOptions
+        { extractForce = False
+        }
+
+    commandOptions _ =
+        [ Option [ 'f' ] [ "force" ]
+            (NoArg $ \opts -> opts { extractForce = True })
+            "owerwrite existing files"
+        ]
+
+    commandInit _ = ExtractCommand
+    commandExec = cmdExtract
+
+
+cmdExtract :: ExtractCommand -> CommandExec ()
+cmdExtract (ExtractCommand ExtractOptions {..} ExtractArguments {..}) = do
+    einput <- getEvalInput
+    storageDir <- getStorageDir
+
+    isdir <- liftIO (doesDirectoryExist extractDestination) >>= \case
+        True -> return True
+        False -> case extractArtifacts of
+            _:_:_ -> tfail $ "destination ‘" <> T.pack extractDestination <> "’ is not a directory"
+            _     -> return False
+
+    forM_ extractArtifacts $ \( ref, ArtifactName aname ) -> do
+        jid@(JobId ids) <- either (tfail . textEvalError) return =<<
+            liftIO (runEval (evalJobReference ref) einput)
+
+        let jdir = joinPath $ (storageDir :) $ ("jobs" :) $ map (T.unpack . textJobIdPart) ids
+            adir = jdir </> "artifacts" </> T.unpack aname
+
+        liftIO (doesDirectoryExist jdir) >>= \case
+            True -> return ()
+            False -> tfail $ "job ‘" <> textJobId jid <> "’ not yet executed"
+
+        liftIO (doesDirectoryExist adir) >>= \case
+            True -> return ()
+            False -> tfail $ "artifact ‘" <> aname <> "’ of job ‘" <> textJobId jid <> "’ not found"
+
+        afile <- liftIO (listDirectory adir) >>= \case
+            [ file ] -> return file
+            []       -> tfail $ "artifact ‘" <> aname <> "’ of job ‘" <> textJobId jid <> "’ not found"
+            _:_:_    -> tfail $ "unexpected files in ‘" <> T.pack adir <> "’"
+
+        let tpath | isdir = extractDestination </> afile
+                  | otherwise = extractDestination
+        when (not extractForce) $ do
+            liftIO (doesPathExist tpath) >>= \case
+                True -> tfail $ "destination ‘" <> T.pack tpath <> "’ already exists"
+                False -> return ()
+        liftIO $ copyFile (adir </> afile) tpath