@@ -3,12 +3,13 @@
33
44module Data.Tasks.Build
55 ( Build (..),
6+ HasDockerInfo (..),
67 )
78where
89
910import Colog
1011import Control.GithubCloner
11−import Control.Monad.IO.Class
12+import Control.Monad.Except
1213import Control.Monad.IO.Unlift
1314import Control.Task
1415import Control.Task.Scheduler
@@ -21,6 +22,7 @@ import Data.Submission.Query
2122import Data.Tasks.StatusUpdate
2223import qualified Data.Text as T
2324import Data.Time.Clock.POSIX
25+import qualified Docker.Client as D
2426import GHC.Generics
2527import GitHub
2628import Server.Schema
@@ -33,7 +35,7 @@ import UnliftIO.Exception
3335data Build
3436 = Build
3537 { preProcessShell :: String,
36− buildCommand :: String,
38+ dockerFile :: String,
3739 owner :: Name Owner,
3840 repoName :: Name Repo,
3941 sha :: Name Commit
@@ -42,7 +44,7 @@ data Build
4244
4345instance Task Build "build-repo" where
4446
45− type TaskMonad Build m = (MonadUnliftIO m, GithubCloner m, StaticPQ m)
47+ type TaskMonad Build m = (MonadUnliftIO m, GithubCloner m, StaticPQ m, HasDockerInfo m)
4648
4749 performTask Build {..} =
4850 bracket createDir (liftIO . removePathForcibly) $ \dir -> do
@@ -63,10 +65,38 @@ instance Task Build "build-repo" where
6365 scheduleTask erroredTask
6466 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
6567 ExitSuccess -> do
66− (buildCode, buildOut, buildErr) <- readProcess . setWorkingDir dir . fromString $ buildCommand
67− case buildCode of
68− ExitFailure n -> do
69− let err = BS.unpack buildErr
68+ h <- liftIO D.defaultHttpHandler
69+ dUrl <- getDockerUrl
70+ let opts = D.defaultCreateOpts imageName
71+ runDocker :: forall a m. MonadIO m => D.DockerT IO a -> m a
72+ runDocker = liftIO . D.runDockerT (D.defaultClientOpts {D.baseUrl = dUrl}, h)
73+ imageName = T.pack dir
74+ liftIO $ writeFile (dir <> "/Dockerfile") dockerFile
75+ absDir <- liftIO $ makeAbsolute dir
76+ let waitDockerForever cid =
77+ D.waitContainer cid >>= \case
78+ Left D.GenericDockerError {} -> waitDockerForever cid
79+ a -> return a
80+ dockerRes <- runDocker . runExceptT $ do
81+ ExceptT $ D.buildImageFromDockerfile (D.defaultBuildOpts imageName) absDir
82+ cid <- ExceptT $ D.createContainer opts Nothing
83+ ExceptT $ D.startContainer D.defaultStartOpts cid
84+ buildCode <- ExceptT $ waitDockerForever cid
85+ buildOut <-
86+ ExceptT $
87+ D.getContainerLogs
88+ D.LogOpts
89+ { stdout = True,
90+ stderr = False,
91+ since = Nothing,
92+ timestamps = False,
93+ tail = D.All
94+ }
95+ cid
96+ return (buildCode, buildOut)
97+ case dockerRes of
98+ Right (ExitFailure n, buildOut) -> do
99+ let err = BS.unpack buildOut
70100 logError . T.pack $
71101 "test command for repo " <> show fullRepoName <> " at sha "
72102 <> show sha
@@ -76,10 +106,15 @@ instance Task Build "build-repo" where
76106 <> err
77107 scheduleTask erroredTask
78108 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
79− ExitSuccess ->
80− case decode buildOut of
81− Nothing -> do
82− let err = BS.unpack buildOut
109+ Left err' -> do
110+ let err = show err'
111+ logError . T.pack $ err
112+ scheduleTask erroredTask
113+ updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
114+ Right (ExitSuccess, buildOut) ->
115+ case eitherDecode' (BS.dropWhile (/= '{') buildOut) of
116+ Left err' -> do
117+ let err = err' <> " " <> BS.unpack buildOut
83118 logError . T.pack $
84119 "could not decode test result from repo " <> show fullRepoName
85120 <> " at sha "
@@ -88,7 +123,7 @@ instance Task Build "build-repo" where
88123 <> err
89124 scheduleTask erroredTask
90125 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
91− Just testResult@TestResult {..} -> do
126+ Right testResult@TestResult {..} -> do
92127 let total = M.size tests
93128 passed = M.size . M.filter id $ tests
94129 description = T.pack $ show passed <> "/" <> show total
@@ -131,3 +166,6 @@ getTmpDirName = liftIO $ do
131166 time :: Integer <- round <$> getPOSIXTime
132167 i <- randomIO @Int
133168 return $ show time <> "-" <> show i
169+
170+class HasDockerInfo m where
171+ getDockerUrl :: m T.Text