@@ -8,6 +8,7 @@ module Data.Tasks.Build
88where
99
1010import Colog
11+import Control.Concurrent
1112import Control.GithubCloner
1213import Control.Monad.Except
1314import Control.Monad.IO.Unlift
@@ -30,6 +31,7 @@ import System.Directory
3031import System.Exit
3132import System.Process.Typed
3233import System.Random
34+import UnliftIO.Async
3335import UnliftIO.Exception
3436
3537data Build
@@ -38,7 +40,8 @@ data Build
3840 dockerFile :: String,
3941 owner :: Name Owner,
4042 repoName :: Name Repo,
41− sha :: Name Commit
43+ sha :: Name Commit,
44+ timeoutMinutes :: Int
4245 }
4346 deriving (Eq, Show, Generic, FromJSON, ToJSON)
4447
@@ -46,9 +49,7 @@ instance Task Build "build-repo" where
4649 type TaskMonad Build m = (MonadUnliftIO m, GithubCloner m, StaticPQ m, HasDockerInfo m)
4750
4851 performTask Build {..} =
49− bracket createDir (liftIO . removePathForcibly) $ \dir -> do
50− let fullRepoName = T.unpack $ untagName owner <> "/" <> untagName repoName
51− sha' = T.unpack $ untagName sha
52+ bracket createDir (liftIO . removePathForcibly) $ \dir -> flip catchAny (const $ return Failure) $ do
5253 cloneRepo fullRepoName sha' dir
5354 (shellCode, _, shellErr) <- readProcess . setWorkingDir dir $ shell preProcessShell
5455 case shellCode of
@@ -67,8 +68,16 @@ instance Task Build "build-repo" where
6768 h <- liftIO D.defaultHttpHandler
6869 dUrl <- getDockerUrl
6970 let opts = D.defaultCreateOpts imageName
70− runDocker :: forall a m. MonadIO m => D.DockerT IO a -> m a
71− runDocker = liftIO . D.runDockerT (D.defaultClientOpts {D.baseUrl = dUrl}, h)
71+ runDocker ::
72+ ( MonadIO m,
73+ Exception err,
74+ WithLog env Message m,
75+ StaticPQ m,
76+ MonadUnliftIO m
77+ ) =>
78+ D.DockerT IO (Either err a) ->
79+ m a
80+ runDocker = runEither <=< liftIO . D.runDockerT (D.defaultClientOpts {D.baseUrl = dUrl}, h)
7281 imageName = T.pack dir
7382 liftIO $ writeFile (dir <> "/Dockerfile") dockerFile
7483 absDir <- liftIO $ makeAbsolute dir
@@ -76,25 +85,37 @@ instance Task Build "build-repo" where
7685 D.waitContainer cid >>= \case
7786 Left D.GenericDockerError {} -> waitDockerForever cid
7887 a -> return a
79− dockerRes <- runDocker . runExceptT $ do
88+ cid <- runDocker . runExceptT $ do
8089 ExceptT $ D.buildImageFromDockerfile (D.defaultBuildOpts imageName) absDir
81− cid <- ExceptT $ D.createContainer opts Nothing
82− ExceptT $ D.startContainer D.defaultStartOpts cid
83− buildCode <- ExceptT $ waitDockerForever cid
84− buildOut <-
85− ExceptT $
86− D.getContainerLogs
87− D.LogOpts
88− { stdout = True,
89− stderr = False,
90− since = Nothing,
91− timestamps = False,
92− tail = D.All
93− }
94− cid
95− return (buildCode, buildOut)
90+ ExceptT $ D.createContainer opts Nothing
91+ dockerRes <- fmap (either id id)
92+ . race (liftIO (threadDelay (timeoutMinutes * 60000000)) >> return (ExitFailure 1, "Time out"))
93+ $ flip
94+ finally
95+ ( runDocker $
96+ D.deleteContainer
97+ D.ContainerDeleteOpts {deleteVolumes = True, force = True}
98+ cid
99+ )
100+ . runDocker
101+ . runExceptT
102+ $ do
103+ ExceptT $ D.startContainer D.defaultStartOpts cid
104+ buildCode <- ExceptT $ waitDockerForever cid
105+ buildOut <-
106+ ExceptT $
107+ D.getContainerLogs
108+ D.LogOpts
109+ { stdout = True,
110+ stderr = False,
111+ since = Nothing,
112+ timestamps = False,
113+ tail = D.All
114+ }
115+ cid
116+ return (buildCode, buildOut)
96117 case dockerRes of
97− Right (ExitFailure n, buildOut) -> do
118+ (ExitFailure n, buildOut) -> do
98119 let err = BS.unpack buildOut
99120 logError . T.pack $
100121 "test command for repo " <> show fullRepoName <> " at sha "
@@ -105,12 +126,7 @@ instance Task Build "build-repo" where
105126 <> err
106127 scheduleTask erroredTask
107128 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
108− Left err' -> do
109− let err = show err'
110− logError . T.pack $ err
111− scheduleTask erroredTask
112− updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
113− Right (ExitSuccess, buildOut) ->
129+ (ExitSuccess, buildOut) ->
114130 case eitherDecode' (BS.dropWhile (/= '{') buildOut) of
115131 Left err' -> do
116132 let err = err' <> " " <> BS.unpack buildOut
@@ -148,6 +164,23 @@ instance Task Build "build-repo" where
148164 newStatusDescription = Just "Build failed",
149165 newStatusContext = Nothing
150166 }
167+ fullRepoName = T.unpack $ untagName owner <> "/" <> untagName repoName
168+ sha' = T.unpack $ untagName sha
169+ runEither ::
170+ ( Exception err,
171+ WithLog env Message m,
172+ StaticPQ m,
173+ MonadUnliftIO m
174+ ) =>
175+ Either err b ->
176+ m b
177+ runEither (Left err) = do
178+ let err' = show err
179+ logError $ T.pack err'
180+ scheduleTask erroredTask
181+ updateSubmissionStatus fullRepoName sha' (SubmissionFailed err')
182+ throwIO err
183+ runEither (Right a) = return a
151184
152185createDir :: MonadIO m => m FilePath
153186createDir = do
@@ -172,3 +205,5 @@ getTmpDirName = liftIO $ do
172205
173206class HasDockerInfo m where
174207 getDockerUrl :: m T.Text
208+
209+instance Exception D.DockerError