Push declaration within a jobHEADmaster

4 files changed, 73 insertions, 2 deletions

diff --git a/src/Config.hs b/src/Config.hs
index 40eb1e5..651b05c 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -27,6 +27,7 @@ import System.FilePath.Glob
 import System.Process
 
 import Destination
+import Job
 import Job.Types
 import Repo
 
@@ -101,6 +102,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"
+    jobPush <- maybe (return []) parsePush =<< j .:? "push"
     return Job {..}
 
 parseSingleCheckout :: Node Pos -> Parser [ JobCheckout Declared ]
@@ -164,6 +166,25 @@ parsePublish ownName = withSeq "Publish list" $ mapM $
         jpPath <- fmap T.unpack <$> m .:? "path"
         return JobPublish {..}
 
+parsePush :: Node Pos -> Parser [ JobPush Declared ]
+parsePush = withSeq "Push list" $ mapM $
+    withMap "Push specification" $ \m -> do
+        source <- m .: "source"
+        jpushSource <- case T.split (== '.') source of
+            [ repo, sel ]
+                | sel == "commit"
+                -> return $ currentCommitExpr (RepoName repo)
+            _ -> mzero
+        destination <- m .: "destination"
+        jpushDestination <- case T.split (== '.') destination of
+            [ repo, sel ]
+                | [ fn, bname, fn' ] <- T.split (== '"') sel
+                , fn == "branch("
+                , fn' == ")"
+                -> return $ branchExpr (RepoName repo) bname
+            _ -> mzero
+        return JobPush {..}
+
 
 parseRepo :: Text -> Node Pos -> Parser DeclaredRepo
 parseRepo name node = choice
diff --git a/src/Eval.hs b/src/Eval.hs
index a918910..bd011cb 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -17,6 +17,7 @@ import Control.Monad.Catch
 import Control.Monad.Except
 import Control.Monad.Reader
 
+import Data.Bifunctor
 import Data.Either
 import Data.List
 import Data.Maybe
@@ -114,8 +115,9 @@ collectJobSetRepos revisionOverrides dset = do
                 return ( rname, RepoRefCommit commit )
 
 getJobExprDependencies :: DeclaredJob -> [ JobSetDep ]
-getJobExprDependencies _ = concat
-    [
+getJobExprDependencies job = concat
+    [ concatMap (collectDependencies . jpushSource) $ jobPush job
+    , concatMap (collectDependencies . jpushDestination) $ jobPush job
     ]
 
 collectOtherRepos :: DeclaredJobSet -> DeclaredJob -> Eval [ ( Maybe ( RepoName, Maybe Text ), RepoDepLevel ) ]
@@ -202,6 +204,11 @@ evalJobs (current : evaluating) evaluated repos dset reqs = do
                     return $ Just ( idpart, repoRef' )
         return $ fmap (\subtree -> ( mbrepo, subtree )) mbSubtree
     let otherRepoTrees = catMaybes otherRepoTreesMb
+
+    let jscRepos = maybe id ((:) . ( Nothing, )) eiContainingRepo $ map (first Just) eiOtherRepos
+    let jscRepoRefs = map (\( repo, ( _, ref ) ) -> ( fst <$> repo, ref )) otherRepoTrees
+    let ctx = JobSetContext {..}
+
     if all isJust otherRepoTreesMb
       then do
         let otherRepoIds = flip mapMaybe otherRepoTrees $ \case
@@ -239,6 +246,14 @@ evalJobs (current : evaluating) evaluated repos dset reqs = do
                     }
                 Nothing -> throwError $ OtherEvalError $ "no url defined for destination ‘" <> textDestinationName (jpDestination dpublish) <> "’"
 
+        pushes <- forM (jobPush current) $ \JobPush {..} -> do
+            commit <- eval ctx jpushSource
+            branch <- eval ctx jpushDestination
+            return JobPush
+                { jpushSource = commit
+                , jpushDestination = branch
+                }
+
         let job = Job
                 { jobId = currentJobId
                 , jobName = jobName current
@@ -247,6 +262,7 @@ evalJobs (current : evaluating) evaluated repos dset reqs = do
                 , jobArtifacts = jobArtifacts current
                 , jobUses = uses
                 , jobPublish = destinations
+                , jobPush = pushes
                 }
         evalJobs evaluating (Right job : evaluated) repos dset reqs
       else do
diff --git a/src/Job.hs b/src/Job.hs
index 10fe865..5b88130 100644
--- a/src/Job.hs
+++ b/src/Job.hs
@@ -18,6 +18,9 @@ module Job (
 
     copyRecursive,
     copyRecursiveForce,
+
+    currentCommitExpr,
+    branchExpr,
 ) where
 
 import Control.Concurrent
@@ -49,6 +52,7 @@ import System.Posix.Signals
 import System.Process
 
 import Destination
+import Expr
 import Job.Types
 import Output
 import Repo
@@ -477,6 +481,9 @@ runJob job uses checkoutPath jdir = do
                 , aoutStorePath = target
                 }
 
+        forM_ (jobPush job) $ \JobPush {..} -> do
+            pushToBranch jpushDestination jpushSource
+
         forM_ (jobPublish job) $ \pub -> do
             Just aout <- return $ lookup (jpArtifact pub) $ map (\aout -> ( ( jobId job, aoutName aout ), aout )) artifacts ++ uses
             let ppath = case jpPath pub of
@@ -489,3 +496,19 @@ runJob job uses checkoutPath jdir = do
         return JobOutput
             { outArtifacts = artifacts
             }
+
+
+
+currentCommitExpr :: RepoName -> Expr JobSetContext Commit
+currentCommitExpr rname =
+    addDependency [ RepoDependency rname RepoDepCommit ] $
+        (pure getCommit) <*> (lookup (Just rname) . jscRepoRefs <$> GetContext)
+  where
+    getCommit = \case
+        Nothing -> error $ "currentCommitExpr: repo ‘" <> showRepoName rname <> "’ not found"
+        Just (RepoRefTree _) -> error $ "currentCommitExpr: expected commit in ‘" <> showRepoName rname <> "’, but got a tree"
+        Just (RepoRefCommit commit) -> commit
+        Just (RepoRefTag commit _) -> commit
+
+branchExpr :: RepoName -> Text -> Expr JobSetContext Branch
+branchExpr rname bname = pure ((\repo -> Branch repo bname) . fromJust) <*> (lookup (Just rname) . jscRepos <$> GetContext)
diff --git a/src/Job/Types.hs b/src/Job/Types.hs
index 682e056..50f550d 100644
--- a/src/Job/Types.hs
+++ b/src/Job/Types.hs
@@ -20,6 +20,11 @@ import Repo
 data Declared
 data Evaluated
 
+type family ExprD d c a :: Type where
+    ExprD Declared c a = Expr c a
+    ExprD Evaluated c a = a
+
+
 data Job' d = Job
     { jobId :: JobId' d
     , jobName :: JobName
@@ -28,6 +33,7 @@ data Job' d = Job
     , jobArtifacts :: [ ( ArtifactName, Pattern ) ]
     , jobUses :: [ ArtifactSpec d ]
     , jobPublish :: [ JobPublish d ]
+    , jobPush :: [ JobPush d ]
     }
 
 type Job = Job' Evaluated
@@ -70,6 +76,11 @@ data JobPublish d = JobPublish
     , jpPath :: Maybe FilePath
     }
 
+data JobPush d = JobPush
+    { jpushSource :: ExprD d JobSetContext Commit
+    , jpushDestination :: ExprD d JobSetContext Branch
+    }
+
 
 data ArtifactName = ArtifactName Text
     deriving (Eq, Ord, Show)