diff options
Diffstat (limited to 'src/Job.hs')
-rw-r--r-- | src/Job.hs | 110 |
1 files changed, 64 insertions, 46 deletions
@@ -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 |