diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Command/Extract.hs | 105 | ||||
| -rw-r--r-- | src/Main.hs | 2 | 
2 files changed, 107 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 diff --git a/src/Main.hs b/src/Main.hs index 89fab39..0227e74 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -21,6 +21,7 @@ import System.IO  import Command  import Command.Checkout +import Command.Extract  import Command.JobId  import Command.Log  import Command.Run @@ -88,6 +89,7 @@ commands :: NE.NonEmpty SomeCommandType  commands =      ( SC $ Proxy @RunCommand) NE.:|      [ SC $ Proxy @CheckoutCommand +    , SC $ Proxy @ExtractCommand      , SC $ Proxy @JobIdCommand      , SC $ Proxy @LogCommand      ] |