git.iko.soy/sc-build
on master help sign in
sc-build/src/Data/Tasks/Build.hs
201 lines 7.2 kB history raw
1{-# LANGUAGE TypeApplications #-}
2{-# OPTIONS_GHC -Wno-orphans #-}
4module Data.Tasks.Build
5 ( Build (..),
6 HasDockerInfo (..),
7 )
8where
10import Colog
11import Control.Concurrent
12import Control.GithubCloner
13import Control.HasGithubStatus
14import Control.Monad.Except
15import Control.Monad.IO.Unlift
16import Control.Task
17import Data.Aeson hiding (Success)
18import qualified Data.ByteString.Lazy.Char8 as BS
19import qualified Data.ByteString.Lazy.UTF8 as BS
20import Data.String
21import Data.Submission
22import Data.Submission.Query
23import qualified Data.Text as T
24import Data.Time.Clock.POSIX
25import qualified Docker.Client as D
26import GHC.Generics
27import GitHub
28import Server.Schema
29import System.Directory
30import System.Exit
31import System.Process.Typed
32import System.Random
33import UnliftIO.Async
34import UnliftIO.Exception
36data Build
37 = Build
38 { preProcessShell :: String,
39 dockerFile :: String,
40 owner :: Name Owner,
41 repoName :: Name Repo,
42 sha :: Name Commit,
43 timeoutMinutes :: Int
44 }
45 deriving (Eq, Show, Generic, FromJSON, ToJSON)
47instance Task Build "build-repo" where
48 type
49 TaskMonad Build m =
50 (MonadUnliftIO m, StaticPQ m, HasDockerInfo m, GithubCloner m, HasGithubStatus m)
52 performTask Build {..} =
53 bracket createDir (liftIO . removePathForcibly) $ \dir -> flip catchAny (const $ return Failure) $ do
54 cloneRepo fullRepoName sha' dir
55 (shellCode, _, shellErr) <- readProcess . setWorkingDir dir $ shell preProcessShell
56 case shellCode of
57 ExitFailure n -> do
58 let err = BS.toString shellErr
59 logError . T.pack $
60 "preprocessing command for repo " <> show fullRepoName <> " at sha "
61 <> show sha
62 <> " exited with code "
63 <> show n
64 <> " and error "
65 <> err
66 scheduleFailedStatus err owner repoName sha
67 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
68 ExitSuccess -> do
69 h <- liftIO D.defaultHttpHandler
70 dUrl <- getDockerUrl
71 let opts = D.defaultCreateOpts imageName
72 runDocker ::
73 ( MonadIO m,
74 Exception err,
75 WithLog env Message m,
76 StaticPQ m,
77 MonadUnliftIO m,
78 HasGithubStatus m
79 ) =>
80 D.DockerT IO (Either err a) ->
81 m a
82 runDocker = runEither <=< liftIO . D.runDockerT (D.defaultClientOpts {D.baseUrl = dUrl}, h)
83 imageName = T.pack dir
84 liftIO $ writeFile (dir <> "/Dockerfile") dockerFile
85 absDir <- liftIO $ makeAbsolute dir
86 let waitDockerForever cid =
87 D.waitContainer cid >>= \case
88 Left D.GenericDockerError {} -> waitDockerForever cid
89 a -> return a
90 cid <- runDocker . runExceptT $ do
91 ExceptT $ D.buildImageFromDockerfile (D.defaultBuildOpts imageName) absDir
92 ExceptT $ D.createContainer opts Nothing
93 dockerRes <- fmap (either id id)
94 . race (liftIO (threadDelay (timeoutMinutes * 60000000)) >> return (ExitFailure 1, "Time out", "Time out"))
95 $ flip
96 finally
97 ( runDocker $
98 D.deleteContainer
99 D.ContainerDeleteOpts {deleteVolumes = True, force = True}
100 cid
101 )
102 . runDocker
103 . runExceptT
104 $ do
105 ExceptT $ D.startContainer D.defaultStartOpts cid
106 buildCode <- ExceptT $ waitDockerForever cid
107 buildOut <-
108 ExceptT $
109 D.getContainerLogs
110 D.LogOpts
111 { stdout = True,
112 stderr = False,
113 since = Nothing,
114 timestamps = False,
115 tail = D.All
116 }
117 cid
118 buildErr <-
119 ExceptT $
120 D.getContainerLogs
121 D.LogOpts
122 { stdout = True,
123 stderr = True,
124 since = Nothing,
125 timestamps = False,
126 tail = D.All
127 }
128 cid
129 return (buildCode, buildOut, buildErr)
130 case dockerRes of
131 (ExitFailure n, _, buildErr) -> do
132 let err = BS.toString buildErr
133 logError . T.pack $
134 "test command for repo " <> show fullRepoName <> " at sha "
135 <> show sha
136 <> " exited with code "
137 <> show n
138 <> " and error "
139 <> err
140 scheduleFailedStatus err owner repoName sha
141 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
142 (ExitSuccess, buildOut, _) ->
143 case eitherDecode' (BS.dropWhile (/= '{') buildOut) of
144 Left err' -> do
145 let err = err' <> " " <> BS.toString buildOut
146 logError . T.pack $
147 "could not decode test result from repo " <> show fullRepoName
148 <> " at sha "
149 <> show sha
150 <> ": "
151 <> err
152 scheduleFailedStatus err owner repoName sha
153 updateSubmissionStatus fullRepoName sha' (SubmissionFailed (err <> BS.toString buildOut))
154 Right testResult@TestResult {..} -> do
155 scheduleTestedStatus testResult owner repoName sha
156 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)
157 return Success
158 where
159 fullRepoName = T.unpack $ untagName owner <> "/" <> untagName repoName
160 sha' = T.unpack $ untagName sha
161 runEither ::
162 ( Exception err,
163 WithLog env Message m,
164 StaticPQ m,
165 MonadUnliftIO m,
166 HasGithubStatus m
167 ) =>
168 Either err b ->
169 m b
170 runEither (Left err) = do
171 let err' = show err
172 logError $ T.pack err'
173 scheduleFailedStatus err' owner repoName sha
174 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err')
175 throwIO err
176 runEither (Right a) = return a
178createDir :: MonadIO m => m FilePath
179createDir = do
180 dir <- ("tmp/" <>) <$> getTmpDirName
181 liftIO $ createDirectoryIfMissing True dir
182 return dir
184cloneRepo :: (MonadIO m, GithubCloner m) => String -> String -> FilePath -> m ()
185cloneRepo repoName sha path = do
186 InstallationToken token <- getGithubInstallationToken
187 runProcess_ . setWorkingDir path . fromString $
188 "git clone https://x-access-token:" <> token <> "@github.com/" <> repoName <> ".git ."
189 runProcess_ . setWorkingDir path . fromString $ "git checkout " <> sha
190 return ()
192getTmpDirName :: MonadIO m => m FilePath
193getTmpDirName = liftIO $ do
194 time :: Integer <- round <$> getPOSIXTime
195 i <- randomIO @Int
196 return $ show time <> "-" <> show i
198class HasDockerInfo m where
199 getDockerUrl :: m T.Text
201instance Exception D.DockerError