summaryrefslogtreecommitdiff
path: root/src/Job.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Job.hs')
-rw-r--r--src/Job.hs110
1 files changed, 64 insertions, 46 deletions
diff --git a/src/Job.hs b/src/Job.hs
index a9effba..21d878c 100644
--- a/src/Job.hs
+++ b/src/Job.hs
@@ -8,6 +8,11 @@ module Job (
jobStatusFinished, jobStatusFailed,
JobManager(..), newJobManager, cancelAllJobs,
runJobs,
+ prepareJob,
+ jobStorageSubdir,
+
+ copyRecursive,
+ copyRecursiveForce,
) where
import Control.Concurrent
@@ -38,8 +43,8 @@ import System.Posix.Signals
import System.Process
import Job.Types
+import Output
import Repo
-import Terminal
data JobOutput = JobOutput
@@ -61,7 +66,7 @@ data JobStatus a = JobQueued
| JobWaiting [JobName]
| JobRunning
| JobSkipped
- | JobError TerminalFootnote
+ | JobError OutputFootnote
| JobFailed
| JobCancelled
| JobDone a
@@ -89,11 +94,16 @@ textJobStatus = \case
JobWaiting _ -> "waiting"
JobRunning -> "running"
JobSkipped -> "skipped"
- JobError err -> "error\n" <> footnoteText err
+ JobError _ -> "error"
JobFailed -> "failed"
JobCancelled -> "cancelled"
JobDone _ -> "done"
+textJobStatusDetails :: JobStatus a -> Text
+textJobStatusDetails = \case
+ JobError err -> footnoteText err <> "\n"
+ _ -> ""
+
data JobManager = JobManager
{ jmSemaphore :: TVar Int
@@ -181,30 +191,30 @@ runManagedJob JobManager {..} tid cancel job = bracket acquire release $ \case
writeTVar jmRunningTasks . M.delete tid =<< readTVar jmRunningTasks
-runJobs :: JobManager -> TerminalOutput -> Maybe Commit -> [ Job ] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ]
-runJobs mngr@JobManager {..} tout commit jobs = do
- tree <- sequence $ fmap getCommitTree commit
+runJobs :: JobManager -> Output -> [ Job ] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ]
+runJobs mngr@JobManager {..} tout jobs = do
results <- atomically $ do
forM jobs $ \job -> do
- let jid = JobId $ concat [ JobIdTree . treeId <$> maybeToList tree, [ JobIdName (jobName job) ] ]
tid <- reserveTaskId mngr
managed <- readTVar jmJobs
- ( job, tid, ) <$> case M.lookup jid managed of
+ ( job, tid, ) <$> case M.lookup (jobId job) managed of
Just origVar -> do
- newTVar . JobDuplicate jid =<< readTVar origVar
+ newTVar . JobDuplicate (jobId job) =<< readTVar origVar
Nothing -> do
statusVar <- newTVar JobQueued
- writeTVar jmJobs $ M.insert jid statusVar managed
+ writeTVar jmJobs $ M.insert (jobId job) statusVar managed
return statusVar
forM_ results $ \( job, tid, outVar ) -> void $ forkIO $ do
- let handler e = if
- | Just JobCancelledException <- fromException e -> do
- atomically $ writeTVar outVar $ JobCancelled
- | otherwise -> do
- footnote <- newFootnote tout $ T.pack $ displayException e
- atomically $ writeTVar outVar $ JobError footnote
+ let handler e = do
+ status <- if
+ | Just JobCancelledException <- fromException e -> do
+ return JobCancelled
+ | otherwise -> do
+ JobError <$> outputFootnote tout (T.pack $ displayException e)
+ atomically $ writeTVar outVar status
+ outputEvent tout $ JobFinished (jobId job) (textJobStatus status)
handle handler $ do
res <- runExceptT $ do
duplicate <- liftIO $ atomically $ do
@@ -219,7 +229,8 @@ runJobs mngr@JobManager {..} tout commit jobs = do
uses <- waitForUsedArtifacts tout job results outVar
runManagedJob mngr tid (return JobCancelled) $ do
liftIO $ atomically $ writeTVar outVar JobRunning
- prepareJob jmDataDir commit job $ \checkoutPath jdir -> do
+ liftIO $ outputEvent tout $ JobStarted (jobId job)
+ prepareJob jmDataDir job $ \checkoutPath jdir -> do
updateStatusFile (jdir </> "status") outVar
JobDone <$> runJob job uses checkoutPath jdir
@@ -239,17 +250,18 @@ runJobs mngr@JobManager {..} tout commit jobs = do
liftIO wait
atomically $ writeTVar outVar $ either id id res
+ outputEvent tout $ JobFinished (jobId job) (textJobStatus $ either id id res)
return $ map (\( job, _, var ) -> ( job, var )) results
waitForUsedArtifacts :: (MonadIO m, MonadError (JobStatus JobOutput) m) =>
- TerminalOutput ->
+ Output ->
Job -> [ ( Job, TaskId, TVar (JobStatus JobOutput) ) ] -> TVar (JobStatus JobOutput) -> m [ ArtifactOutput ]
waitForUsedArtifacts tout job results outVar = do
origState <- liftIO $ atomically $ readTVar outVar
ujobs <- forM (jobUses job) $ \(ujobName@(JobName tjobName), uartName) -> do
case find (\( j, _, _ ) -> jobName j == ujobName) results of
Just ( _, _, var ) -> return ( var, ( ujobName, uartName ))
- Nothing -> throwError . JobError =<< liftIO (newFootnote tout $ "Job '" <> tjobName <> "' not found")
+ Nothing -> throwError . JobError =<< liftIO (outputFootnote tout $ "Job '" <> tjobName <> "' not found")
let loop prev = do
ustatuses <- atomically $ do
@@ -268,7 +280,7 @@ waitForUsedArtifacts tout job results outVar = do
case ustatus of
JobDone out -> case find ((==uartName) . aoutName) $ outArtifacts out of
Just art -> return art
- Nothing -> throwError . JobError =<< liftIO (newFootnote tout $ "Artifact '" <> tjobName <> "." <> tartName <> "' not found")
+ Nothing -> throwError . JobError =<< liftIO (outputFootnote tout $ "Artifact '" <> tjobName <> "." <> tartName <> "' not found")
_ -> throwError JobSkipped
updateStatusFile :: MonadIO m => FilePath -> TVar (JobStatus JobOutput) -> m ()
@@ -279,34 +291,21 @@ updateStatusFile path outVar = void $ liftIO $ forkIO $ loop Nothing
status <- readTVar outVar
when (Just status == prev) retry
return status
- T.writeFile path $ textJobStatus status <> "\n"
+ T.writeFile path $ textJobStatus status <> "\n" <> textJobStatusDetails status
when (not (jobStatusFinished status)) $ loop $ Just status
-prepareJob :: (MonadIO m, MonadMask m, MonadFail m) => FilePath -> Maybe Commit -> Job -> (FilePath -> FilePath -> m a) -> m a
-prepareJob dir mbCommit job inner = do
+jobStorageSubdir :: JobId -> FilePath
+jobStorageSubdir (JobId jidParts) = "jobs" </> joinPath (map (T.unpack . textJobIdPart) (jidParts))
+
+prepareJob :: (MonadIO m, MonadMask m, MonadFail m) => FilePath -> Job -> (FilePath -> FilePath -> m a) -> m a
+prepareJob dir job inner = do
withSystemTempDirectory "minici" $ \checkoutPath -> do
- jdirCommit <- case mbCommit of
- Just commit -> do
- tree <- getCommitTree commit
- forM_ (jobContainingCheckout job) $ \(JobCheckout mbsub dest) -> do
- subtree <- maybe return (getSubtree mbCommit) mbsub $ tree
- checkoutAt subtree $ checkoutPath </> fromMaybe "" dest
- return $ showTreeId (treeId tree) </> stringJobName (jobName job)
- Nothing -> do
- when (not $ null $ jobContainingCheckout job) $ do
- fail $ "no containing repository, can't do checkout"
- return $ stringJobName (jobName job)
-
- jdirOther <- forM (jobOtherCheckout job) $ \( EvaluatedJobRepo repo, revision, JobCheckout mbsub dest ) -> do
- commit <- readCommit repo $ fromMaybe "HEAD" revision
- tree <- getCommitTree commit
- subtree <- maybe return (getSubtree (Just commit)) mbsub $ tree
+ forM_ (jobCheckout job) $ \(JobCheckout tree mbsub dest) -> do
+ subtree <- maybe return (getSubtree Nothing . makeRelative (treeSubdir tree)) mbsub $ tree
checkoutAt subtree $ checkoutPath </> fromMaybe "" dest
- return $ showTreeId (treeId tree)
- let jdir = dir </> "jobs" </> jdirCommit </> joinPath jdirOther
+ let jdir = dir </> jobStorageSubdir (jobId job)
liftIO $ createDirectoryIfMissing True jdir
-
inner checkoutPath jdir
runJob :: Job -> [ArtifactOutput] -> FilePath -> FilePath -> ExceptT (JobStatus JobOutput) IO JobOutput
@@ -314,7 +313,7 @@ runJob job uses checkoutPath jdir = do
liftIO $ forM_ uses $ \aout -> do
let target = checkoutPath </> aoutWorkPath aout
createDirectoryIfMissing True $ takeDirectory target
- copyFile (aoutStorePath aout) target
+ copyRecursive (aoutStorePath aout) target
bracket (liftIO $ openFile (jdir </> "log") WriteMode) (liftIO . hClose) $ \logs -> do
forM_ (jobRecipe job) $ \p -> do
@@ -337,13 +336,13 @@ runJob job uses checkoutPath jdir = do
[ path ] -> return path
found -> do
liftIO $ hPutStrLn logs $
- (if null found then "no file" else "multiple files") <> " found matching pattern `" <>
- decompile pathPattern <> "' for artifact `" <> T.unpack tname <> "'"
+ (if null found then "no file" else "multiple files") <> " found matching pattern ‘" <>
+ decompile pathPattern <> "’ for artifact ‘" <> T.unpack tname <> "’"
throwError JobFailed
let target = adir </> T.unpack tname </> takeFileName path
liftIO $ do
createDirectoryIfMissing True $ takeDirectory target
- copyFile path target
+ copyRecursiveForce path target
return $ ArtifactOutput
{ aoutName = name
, aoutWorkPath = makeRelative checkoutPath path
@@ -354,3 +353,22 @@ runJob job uses checkoutPath jdir = do
{ outName = jobName job
, 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