Publish artifacts to destinationsHEADmaster

Changelog: Job section to publish artifacts to specified destination

11 files changed, 303 insertions, 57 deletions

diff --git a/src/Command.hs b/src/Command.hs
index 30b0df0..1ef52ed 100644
--- a/src/Command.hs
+++ b/src/Command.hs
@@ -30,6 +30,7 @@ import System.Exit
 import System.IO
 
 import Config
+import Destination
 import Eval
 import Output
 import Repo
@@ -37,12 +38,14 @@ import Repo
 data CommonOptions = CommonOptions
     { optJobs :: Int
     , optRepo :: [ ( RepoName, FilePath ) ]
+    , optDestination :: [ ( DestinationName, Text ) ]
     }
 
 defaultCommonOptions :: CommonOptions
 defaultCommonOptions = CommonOptions
     { optJobs = 2
     , optRepo = []
+    , optDestination = []
     }
 
 class CommandArgumentsType (CommandArguments c) => Command c where
@@ -102,6 +105,7 @@ data CommandInput = CommandInput
     , ciJobRoot :: JobRoot
     , ciContainingRepo :: Maybe Repo
     , ciOtherRepos :: [ ( RepoName, Repo ) ]
+    , ciDestinations :: [ ( DestinationName, Destination ) ]
     , ciOutput :: Output
     , ciStorageDir :: FilePath
     }
@@ -137,6 +141,7 @@ getEvalInput = CommandExec $ do
     eiCurrentIdRev <- return []
     eiContainingRepo <- asks ciContainingRepo
     eiOtherRepos <- asks ciOtherRepos
+    eiDestinations <- asks ciDestinations
     return EvalInput {..}
 
 cmdEvalWith :: (EvalInput -> EvalInput) -> Eval a -> CommandExec a
diff --git a/src/Config.hs b/src/Config.hs
index 9c0a79d..d643f27 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -97,6 +97,7 @@ parseJob name node = flip (withMap "Job") node $ \j -> do
         ]
     jobArtifacts <- parseArtifacts j
     jobUses <- maybe (return []) parseUses =<< j .:? "uses"
+    jobPublish <- maybe (return []) (parsePublish jobName) =<< j .:? "publish"
     return Job {..}
 
 parseSingleCheckout :: Node Pos -> Parser [ JobCheckout Declared ]
@@ -143,6 +144,18 @@ parseUses = withSeq "Uses list" $ mapM $
         [job, art] <- return $ T.split (== '.') text
         return (JobName job, ArtifactName art)
 
+parsePublish :: JobName -> Node Pos -> Parser [ JobPublish Declared ]
+parsePublish ownName = withSeq "Publish list" $ mapM $
+    withMap "Publish specification" $ \m -> do
+        artifact <- m .: "artifact"
+        jpArtifact <- case T.split (== '.') artifact of
+            [ job, art ] -> return ( JobName job, ArtifactName art )
+            [ art ] -> return ( ownName, ArtifactName art )
+            _ -> mzero
+        jpDestination <- DestinationName <$> m .: "to"
+        jpPath <- fmap T.unpack <$> m .:? "path"
+        return JobPublish {..}
+
 
 parseRepo :: Text -> Node Pos -> Parser DeclaredRepo
 parseRepo name node = choice
diff --git a/src/Destination.hs b/src/Destination.hs
index f96e88c..dccac03 100644
--- a/src/Destination.hs
+++ b/src/Destination.hs
@@ -1,14 +1,22 @@
 module Destination (
     Destination,
     DeclaredDestination(..),
-    DestinationName(..),
+    DestinationName(..), textDestinationName, showDestinationName,
 
     openDestination,
+    copyToDestination,
+
+    copyRecursive,
+    copyRecursiveForce,
 ) where
 
+import Control.Monad
+import Control.Monad.IO.Class
+
 import Data.Text (Text)
 import Data.Text qualified as T
 
+import System.FilePath
 import System.Directory
 
 
@@ -24,9 +32,41 @@ data DeclaredDestination = DeclaredDestination
 newtype DestinationName = DestinationName Text
     deriving (Eq, Ord, Show)
 
+textDestinationName :: DestinationName -> Text
+textDestinationName (DestinationName text) = text
+
+showDestinationName :: DestinationName -> String
+showDestinationName = T.unpack . textDestinationName
+
 
-openDestination :: Text -> IO Destination
-openDestination url = do
-    let path = T.unpack url
+openDestination :: FilePath -> Text -> IO Destination
+openDestination baseDir url = do
+    let path = baseDir </> T.unpack url
     createDirectoryIfMissing True path
     return $ FilesystemDestination path
+
+copyToDestination :: MonadIO m => FilePath -> Destination -> FilePath -> m ()
+copyToDestination source (FilesystemDestination base) inner = do
+    let target = base </> dropWhile isPathSeparator inner
+    liftIO $ do
+        createDirectoryIfMissing True $ takeDirectory target
+        copyRecursiveForce source target
+
+
+copyRecursive :: FilePath -> FilePath -> IO ()
+copyRecursive from to = do
+    doesDirectoryExist from >>= \case
+        False -> do
+            copyFile from to
+        True -> do
+            createDirectory to
+            content <- listDirectory from
+            forM_ content $ \name -> do
+                copyRecursive  (from </> name) (to </> name)
+
+copyRecursiveForce :: FilePath -> FilePath -> IO ()
+copyRecursiveForce from to = do
+    doesDirectoryExist to >>= \case
+        False -> return ()
+        True  -> removeDirectoryRecursive to
+    copyRecursive from to
diff --git a/src/Eval.hs b/src/Eval.hs
index cc3c45c..018d031 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -24,6 +24,7 @@ import Data.Text qualified as T
 import System.FilePath
 
 import Config
+import Destination
 import Job.Types
 import Repo
 
@@ -33,6 +34,7 @@ data EvalInput = EvalInput
     , eiCurrentIdRev :: [ JobIdPart ]
     , eiContainingRepo :: Maybe Repo
     , eiOtherRepos :: [ ( RepoName, Repo ) ]
+    , eiDestinations :: [ ( DestinationName, Destination ) ]
     }
 
 data EvalError
@@ -105,6 +107,11 @@ evalJob revisionOverrides dset decl = do
                     ]
             }
 
+    destinations <- forM (jobPublish decl) $ \dpublish -> do
+        case lookup (jpDestination dpublish) eiDestinations of
+            Just dest -> return $ dpublish { jpDestination = dest }
+            Nothing -> throwError $ OtherEvalError $ "no url defined for destination ‘" <> textDestinationName (jpDestination dpublish) <> "’"
+
     let otherRepoIds = map (\( repo, ( subtree, tree )) -> JobIdTree (fst <$> repo) subtree (treeId tree)) otherRepoTrees
     return
         ( Job
@@ -114,6 +121,7 @@ evalJob revisionOverrides dset decl = do
             , jobRecipe = jobRecipe decl
             , jobArtifacts = jobArtifacts decl
             , jobUses = jobUses decl
+            , jobPublish = destinations
             }
         , JobSetId $ reverse $ reverse otherRepoIds ++ eiCurrentIdRev
         )
@@ -265,7 +273,7 @@ fillInDependencies jset = do
         = gather djobs cur rest
 
         | Just djob <- find ((name ==) . jobName) djobs
-        = gather djobs (S.insert name cur) $ map fst (jobUses djob) ++ rest
+        = gather djobs (S.insert name cur) $ map fst (jobUses djob) ++ map (fst . jpArtifact) (jobPublish djob) ++ rest
 
         | otherwise
         = throwError $ OtherEvalError $ "dependency ‘" <> textJobName name <> "’ not found"
diff --git a/src/Job.hs b/src/Job.hs
index ffbb0c1..41b3abc 100644
--- a/src/Job.hs
+++ b/src/Job.hs
@@ -23,6 +23,7 @@ import Control.Monad.Catch
 import Control.Monad.Except
 import Control.Monad.IO.Class
 
+import Data.Containers.ListUtils
 import Data.List
 import Data.Map (Map)
 import Data.Map qualified as M
@@ -42,6 +43,7 @@ import System.IO.Temp
 import System.Posix.Signals
 import System.Process
 
+import Destination
 import Job.Types
 import Output
 import Repo
@@ -286,12 +288,16 @@ runJobs mngr@JobManager {..} tout jobs rerun = do
             outputJobFinishedEvent tout job $ either id id res
     return $ map (\( job, _, var ) -> ( job, var )) results
 
-waitForUsedArtifacts :: (MonadIO m, MonadError (JobStatus JobOutput) m) =>
-    Output ->
-    Job -> [ ( Job, TaskId, TVar (JobStatus JobOutput) ) ] -> TVar (JobStatus JobOutput) -> m [ ArtifactOutput ]
+waitForUsedArtifacts
+    :: (MonadIO m, MonadError (JobStatus JobOutput) m)
+    => Output -> Job
+    -> [ ( Job, TaskId, TVar (JobStatus JobOutput) ) ]
+    -> TVar (JobStatus JobOutput)
+    -> m [ ( ArtifactSpec, ArtifactOutput ) ]
 waitForUsedArtifacts tout job results outVar = do
     origState <- liftIO $ atomically $ readTVar outVar
-    ujobs <- forM (jobUses job) $ \(ujobName@(JobName tjobName), uartName) -> do
+    let artSpecs = nubOrd $ jobUses job ++ (map jpArtifact $ jobPublish job)
+    ujobs <- forM artSpecs $ \(ujobName@(JobName tjobName), uartName) -> do
         case find (\( j, _, _ ) -> jobName j == ujobName) results of
             Just ( _, _, var ) -> return ( var, ( ujobName, uartName ))
             Nothing -> throwError . JobError =<< liftIO (outputFootnote tout $ "Job '" <> tjobName <> "' not found")
@@ -309,10 +315,10 @@ waitForUsedArtifacts tout job results outVar = do
                else loop $ Just $ map fst ustatuses
     ustatuses <- liftIO $ loop Nothing
 
-    forM ustatuses $ \(ustatus, (JobName tjobName, uartName@(ArtifactName tartName))) -> do
+    forM ustatuses $ \(ustatus, spec@( JobName tjobName, uartName@(ArtifactName tartName)) ) -> do
         case jobResult ustatus of
             Just out -> case find ((==uartName) . aoutName) $ outArtifacts out of
-                Just art -> return art
+                Just art -> return ( spec, art )
                 Nothing -> throwError . JobError =<< liftIO (outputFootnote tout $ "Artifact '" <> tjobName <> "." <> tartName <> "' not found")
             _ -> throwError JobSkipped
 
@@ -363,9 +369,9 @@ prepareJob dir job inner = do
         liftIO $ createDirectoryIfMissing True jdir
         inner checkoutPath
 
-runJob :: Job -> [ArtifactOutput] -> FilePath -> FilePath -> ExceptT (JobStatus JobOutput) IO JobOutput
+runJob :: Job -> [ ( ArtifactSpec, ArtifactOutput) ] -> FilePath -> FilePath -> ExceptT (JobStatus JobOutput) IO JobOutput
 runJob job uses checkoutPath jdir = do
-    liftIO $ forM_ uses $ \aout -> do
+    liftIO $ forM_ (filter ((`elem` jobUses job) . fst) uses) $ \( _, aout ) -> do
         let target = checkoutPath </> aoutWorkPath aout
         createDirectoryIfMissing True $ takeDirectory target
         copyRecursive (aoutStorePath aout) target
@@ -406,25 +412,15 @@ runJob job uses checkoutPath jdir = do
                 , aoutStorePath = target
                 }
 
+        forM_ (jobPublish job) $ \pub -> do
+            Just aout <- return $ lookup (jpArtifact pub) uses
+            let ppath = case jpPath pub of
+                    Just path
+                        | hasTrailingPathSeparator path -> path </> takeFileName (aoutWorkPath aout)
+                        | otherwise                     -> path
+                    Nothing                             -> aoutWorkPath aout
+            copyToDestination (aoutStorePath aout) (jpDestination pub) ppath
+
         return JobOutput
             { outArtifacts = artifacts
             }
-
-
-copyRecursive :: FilePath -> FilePath -> IO ()
-copyRecursive from to = do
-    doesDirectoryExist from >>= \case
-        False -> do
-            copyFile from to
-        True -> do
-            createDirectory to
-            content <- listDirectory from
-            forM_ content $ \name -> do
-                copyRecursive  (from </> name) (to </> name)
-
-copyRecursiveForce :: FilePath -> FilePath -> IO ()
-copyRecursiveForce from to = do
-    doesDirectoryExist to >>= \case
-        False -> return ()
-        True  -> removeDirectoryRecursive to
-    copyRecursive from to
diff --git a/src/Job/Types.hs b/src/Job/Types.hs
index a0c1d47..d9fa08e 100644
--- a/src/Job/Types.hs
+++ b/src/Job/Types.hs
@@ -7,6 +7,7 @@ import Data.Text qualified as T
 import System.FilePath.Glob
 import System.Process
 
+import Destination
 import Repo
 
 
@@ -19,7 +20,8 @@ data Job' d = Job
     , jobCheckout :: [ JobCheckout d ]
     , jobRecipe :: [ CreateProcess ]
     , jobArtifacts :: [ ( ArtifactName, Pattern ) ]
-    , jobUses :: [ ( JobName, ArtifactName ) ]
+    , jobUses :: [ ArtifactSpec ]
+    , jobPublish :: [ JobPublish d ]
     }
 
 type Job = Job' Evaluated
@@ -49,10 +51,22 @@ data JobCheckout d = JobCheckout
     , jcDestination :: Maybe FilePath
     }
 
+type family JobDestination d :: Type where
+    JobDestination Declared = DestinationName
+    JobDestination Evaluated = Destination
+
+data JobPublish d = JobPublish
+    { jpArtifact :: ArtifactSpec
+    , jpDestination :: JobDestination d
+    , jpPath :: Maybe FilePath
+    }
+
 
 data ArtifactName = ArtifactName Text
     deriving (Eq, Ord, Show)
 
+type ArtifactSpec = ( JobName, ArtifactName )
+
 
 data JobSet' d = JobSet
     { jobsetId :: JobSetId' d
diff --git a/src/Main.hs b/src/Main.hs
index 91d3acd..647231d 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -28,6 +28,7 @@ import Command.Run
 import Command.Shell
 import Command.Subtree
 import Config
+import Destination
 import Output
 import Repo
 import Version
@@ -71,6 +72,17 @@ options =
                 _ -> throwError $ "--repo: invalid value ‘" <> value <> "’"
         ) "<repo>:<path>")
         ("override or declare repo path")
+    , Option [] [ "destination" ]
+        (ReqArg (\value opts ->
+            case span (/= ':') value of
+                ( dest, ':' : url ) -> return opts
+                    { optCommon = (optCommon opts)
+                        { optDestination = ( DestinationName $ T.pack dest, T.pack url ) : optDestination (optCommon opts)
+                        }
+                    }
+                _ -> throwError $ "--repo: invalid value ‘" <> value <> "’"
+        ) "<destination>:<url>")
+        ("override or declare destination")
     , Option [] [ "storage" ]
         (ReqArg (\value opts -> return opts { optStorage = Just value }) "<path>")
         "set storage path"
@@ -268,7 +280,28 @@ runSomeCommand rootPath gopts (SC tproxy) args = do
                             exitFailure
         _ -> return []
 
+    let openDeclaredDestination dir ( name, url ) = do
+            dest <- openDestination dir url
+            return ( name, dest )
+
+    cmdlineDestinations <- forM (optDestination ciOptions) (openDeclaredDestination "")
+    cfgDestinations <- case ciJobRoot of
+        JobRootConfig config -> do
+            forM (configDestinations config) $ \decl -> do
+                case lookup (destinationName decl) cmdlineDestinations of
+                    Just dest -> return ( destinationName decl, dest )
+                    Nothing
+                        | Just url <- destinationUrl decl
+                        -> openDeclaredDestination (takeDirectory ciRootPath) ( destinationName decl, url )
+
+                        | otherwise
+                        -> do
+                            hPutStrLn stderr $ "No url defined for destination ‘" <> showDestinationName (destinationName decl) <> "’"
+                            exitFailure
+        _ -> return []
+
     let ciOtherRepos = configRepos ++ cmdlineRepos
+        ciDestinations = cfgDestinations ++ cmdlineDestinations
 
     outputTypes <- case optOutput gopts of
         Just types -> return types
diff --git a/test/asset/publish/from_dependency.yaml b/test/asset/publish/from_dependency.yaml
new file mode 100644
index 0000000..40268fc
--- /dev/null
+++ b/test/asset/publish/from_dependency.yaml
@@ -0,0 +1,89 @@
+destination first:
+  url: ./first/dest
+
+destination second:
+  url: ./second/dest
+
+destination third:
+
+destination fourth:
+
+destination fifth:
+
+
+job gen:
+  checkout:
+
+  shell:
+    - mkdir dir
+    - mkdir dir2
+    - mkdir dir2/subdir
+    - touch x
+    - touch dir/y
+    - touch dir2/z2
+    - touch dir2/subdir/z
+
+  artifact x:
+    path: ./x
+
+  artifact y:
+    path: ./dir/y
+
+  artifact z:
+    path: ./dir2/subdir/z
+
+  artifact dir:
+    path: ./dir
+
+  artifact dir2:
+    path: ./dir2
+
+  artifact dir2_subdir:
+    path: ./dir2/subdir
+
+
+job publish:
+  shell:
+    - "true"
+
+  checkout:
+
+  publish:
+    - to: first
+      artifact: gen.x
+
+    - to: first
+      artifact: gen.y
+
+    - to: second
+      artifact: gen.z
+
+    - to: third
+      artifact: gen.dir
+
+    - to: third
+      artifact: gen.dir2_subdir
+
+    - to: fourth
+      artifact: gen.x
+      path: path/for/artifact
+
+    - to: fourth
+      artifact: gen.x
+      path: dir/for/artifact/
+
+    - to: fifth
+      artifact: gen.dir2_subdir
+      path: path/for/artifact
+
+    - to: fifth
+      artifact: gen.dir2_subdir
+      path: dir/for/artifact/
+
+    - to: fifth
+      artifact: gen.dir2
+      path: path2/for/artifact
+
+    - to: fifth
+      artifact: gen.dir2
+      path: dir2/for/artifact/
diff --git a/test/script/common.et b/test/script/common.et
new file mode 100644
index 0000000..8875c79
--- /dev/null
+++ b/test/script/common.et
@@ -0,0 +1,26 @@
+module common
+
+
+export def expect_result from p of job result result:
+    let dummy = job == "" # TODO: forces string type
+    expect from p:
+        /job-start $job/
+        /job-finish $job ([a-z]+)/ capture done
+    guard (done == result)
+
+export def expect_previous_result from p of job result result:
+    let dummy = job == "" # TODO: forces string type
+    expect from p:
+        /job-previous $job ([a-z]+)/ capture done
+    guard (done == result)
+
+export def expect_success from p of job:
+    expect_result from p of job result "done"
+
+export def expect_previous_success from p of job:
+    expect_previous_result from p of job result "done"
+
+export def expect_skip from p of job:
+    let dummy = job == "" # TODO: forces string type
+    expect from p:
+        /job-skip $job/
diff --git a/test/script/publish.et b/test/script/publish.et
new file mode 100644
index 0000000..d5756cb
--- /dev/null
+++ b/test/script/publish.et
@@ -0,0 +1,44 @@
+module publish
+
+import common
+
+
+asset scripts:
+    path: ../asset/publish
+
+
+test PublishFromDependency:
+    node n
+    shell on n:
+        mkdir workdir
+        cp ${scripts.path}/from_dependency.yaml workdir/minici.yaml
+
+    spawn on n as p args [ "--destination=second:second_override", "--destination=third:./third", "--destination=fourth:fourth/with_dir", "--destination=fifth:fifth/with_dir", "workdir/minici.yaml", "run", "publish" ]
+    expect_result from p:
+        of "gen" result "done"
+        of "publish" result "done"
+    local:
+        expect /(.*)/ from p capture done
+        guard (done == "run-finish")
+
+    shell on n as listing:
+        find . -path ./workdir/.minici -prune -o -type f -print
+        echo DONE
+
+    expect from listing:
+        /.\/workdir\/minici.yaml/
+        /.\/workdir\/first\/dest\/x/
+        /.\/workdir\/first\/dest\/dir\/y/
+        /.\/second_override\/dir2\/subdir\/z/
+        /.\/third\/dir\/y/
+        /.\/third\/dir2\/subdir\/z/
+        /.\/fourth\/with_dir\/path\/for\/artifact/
+        /.\/fourth\/with_dir\/dir\/for\/artifact\/x/
+        /.\/fifth\/with_dir\/path\/for\/artifact\/z/
+        /.\/fifth\/with_dir\/dir\/for\/artifact\/subdir\/z/
+        /.\/fifth\/with_dir\/path2\/for\/artifact\/z2/
+        /.\/fifth\/with_dir\/path2\/for\/artifact\/subdir\/z/
+        /.\/fifth\/with_dir\/dir2\/for\/artifact\/dir2\/z2/
+        /.\/fifth\/with_dir\/dir2\/for\/artifact\/dir2\/subdir\/z/
+        /(.*)/ capture done
+    guard (done == "DONE")
diff --git a/test/script/run.et b/test/script/run.et
index 7c3fb38..f33c2fa 100644
--- a/test/script/run.et
+++ b/test/script/run.et
@@ -1,32 +1,10 @@
 module run
 
+import common
+
 asset scripts:
     path: ../asset/run
 
-def expect_result from p of job result result:
-    let dummy = job == ""
-    expect from p:
-        /job-start $job/
-        /job-finish $job ([a-z]+)/ capture done
-    guard (done == result)
-
-def expect_previous_result from p of job result result:
-    let dummy = job == "" # TODO: forces string type
-    expect from p:
-        /job-previous $job ([a-z]+)/ capture done
-    guard (done == result)
-
-def expect_success from p of job:
-    expect_result from p of job result "done"
-
-def expect_previous_success from p of job:
-    expect_previous_result from p of job result "done"
-
-def expect_skip from p of job:
-    let dummy = job == "" # TODO: forces string type
-    expect from p:
-        /job-skip $job/
-
 
 test RunWithoutRepo:
     node n