eb15496 · sc-build · git.iko.soy

git.iko.soy/sc-build

on master help sign in

Added docker timeout

eb15496iko7 years ago

src/Data/Tasks/Build.hs+64−29

compare with master

unifiedsplit

@@ -8,6 +8,7 @@ module Data.Tasks.Build

8where

10import Colog

11+import Control.Concurrent

11import Control.GithubCloner

12import Control.GithubCloner

12import Control.Monad.Except

13import Control.Monad.Except

13import Control.Monad.IO.Unlift

14import Control.Monad.IO.Unlift

@@ -30,6 +31,7 @@ import System.Directory

30import System.Exit

31import System.Exit

31import System.Process.Typed

32import System.Process.Typed

32import System.Random

33import System.Random

34+import UnliftIO.Async

33import UnliftIO.Exception

35import UnliftIO.Exception

35data Build

37data Build

@@ -38,7 +40,8 @@ data Build

38 dockerFile :: String,

40 dockerFile :: String,

39 owner :: Name Owner,

41 owner :: Name Owner,

40 repoName :: Name Repo,

42 repoName :: Name Repo,

41− sha :: Name Commit

43+ sha :: Name Commit,

44+ timeoutMinutes :: Int

42 }

45 }

43 deriving (Eq, Show, Generic, FromJSON, ToJSON)

46 deriving (Eq, Show, Generic, FromJSON, ToJSON)

@@ -46,9 +49,7 @@ instance Task Build "build-repo" where

46 type TaskMonad Build m = (MonadUnliftIO m, GithubCloner m, StaticPQ m, HasDockerInfo m)

49 type TaskMonad Build m = (MonadUnliftIO m, GithubCloner m, StaticPQ m, HasDockerInfo m)

48 performTask Build {..} =

51 performTask Build {..} =

49− bracket createDir (liftIO . removePathForcibly) $ \dir -> do

52+ bracket createDir (liftIO . removePathForcibly) $ \dir -> flip catchAny (const $ return Failure) $ do

50− let fullRepoName = T.unpack $ untagName owner <> "/" <> untagName repoName

51− sha' = T.unpack $ untagName sha

52 cloneRepo fullRepoName sha' dir

53 cloneRepo fullRepoName sha' dir

53 (shellCode, _, shellErr) <- readProcess . setWorkingDir dir $ shell preProcessShell

54 (shellCode, _, shellErr) <- readProcess . setWorkingDir dir $ shell preProcessShell

54 case shellCode of

55 case shellCode of

@@ -67,8 +68,16 @@ instance Task Build "build-repo" where

67 h <- liftIO D.defaultHttpHandler

68 h <- liftIO D.defaultHttpHandler

68 dUrl <- getDockerUrl

69 dUrl <- getDockerUrl

69 let opts = D.defaultCreateOpts imageName

70 let opts = D.defaultCreateOpts imageName

70− runDocker :: forall a m. MonadIO m => D.DockerT IO a -> m a

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

71− runDocker = liftIO . D.runDockerT (D.defaultClientOpts {D.baseUrl = dUrl}, h)

80+ runDocker = runEither <=< liftIO . D.runDockerT (D.defaultClientOpts {D.baseUrl = dUrl}, h)

72 imageName = T.pack dir

81 imageName = T.pack dir

73 liftIO $ writeFile (dir <> "/Dockerfile") dockerFile

82 liftIO $ writeFile (dir <> "/Dockerfile") dockerFile

74 absDir <- liftIO $ makeAbsolute dir

83 absDir <- liftIO $ makeAbsolute dir

@@ -76,25 +85,37 @@ instance Task Build "build-repo" where

76 D.waitContainer cid >>= \case

85 D.waitContainer cid >>= \case

77 Left D.GenericDockerError {} -> waitDockerForever cid

86 Left D.GenericDockerError {} -> waitDockerForever cid

78 a -> return a

87 a -> return a

79− dockerRes <- runDocker . runExceptT $ do

88+ cid <- runDocker . runExceptT $ do

80 ExceptT $ D.buildImageFromDockerfile (D.defaultBuildOpts imageName) absDir

89 ExceptT $ D.buildImageFromDockerfile (D.defaultBuildOpts imageName) absDir

81− cid <- ExceptT $ D.createContainer opts Nothing

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

82− ExceptT $ D.startContainer D.defaultStartOpts cid

103+ ExceptT $ D.startContainer D.defaultStartOpts cid

83− buildCode <- ExceptT $ waitDockerForever cid

104+ buildCode <- ExceptT $ waitDockerForever cid

84− buildOut <-

105+ buildOut <-

85− ExceptT $

106+ ExceptT $

86− D.getContainerLogs

107+ D.getContainerLogs

87− D.LogOpts

108+ D.LogOpts

88− { stdout = True,

109+ { stdout = True,

89− stderr = False,

110+ stderr = False,

90− since = Nothing,

111+ since = Nothing,

91− timestamps = False,

112+ timestamps = False,

92− tail = D.All

113+ tail = D.All

93− }

114+ }

94− cid

115+ cid

95− return (buildCode, buildOut)

116+ return (buildCode, buildOut)

96 case dockerRes of

117 case dockerRes of

97− Right (ExitFailure n, buildOut) -> do

118+ (ExitFailure n, buildOut) -> do

98 let err = BS.unpack buildOut

119 let err = BS.unpack buildOut

99 logError . T.pack $

120 logError . T.pack $

100 "test command for repo " <> show fullRepoName <> " at sha "

121 "test command for repo " <> show fullRepoName <> " at sha "

@@ -105,12 +126,7 @@ instance Task Build "build-repo" where

105 <> err

126 <> err

106 scheduleTask erroredTask

127 scheduleTask erroredTask

107 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

128 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) ->

114 case eitherDecode' (BS.dropWhile (/= '{') buildOut) of

130 case eitherDecode' (BS.dropWhile (/= '{') buildOut) of

115 Left err' -> do

131 Left err' -> do

116 let err = err' <> " " <> BS.unpack buildOut

132 let err = err' <> " " <> BS.unpack buildOut

@@ -148,6 +164,23 @@ instance Task Build "build-repo" where

148 newStatusDescription = Just "Build failed",

164 newStatusDescription = Just "Build failed",

149 newStatusContext = Nothing

165 newStatusContext = Nothing

150 }

166 }

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

151

184

152createDir :: MonadIO m => m FilePath

185createDir :: MonadIO m => m FilePath

153createDir = do

186createDir = do

@@ -172,3 +205,5 @@ getTmpDirName = liftIO $ do

172

205

173class HasDockerInfo m where

206class HasDockerInfo m where

174 getDockerUrl :: m T.Text

207 getDockerUrl :: m T.Text

208+

209+instance Exception D.DockerError

src/Server.hs+26−21

@@ -44,7 +44,7 @@ import Server.Schema

44import Squeal.PostgreSQL

45import System.IO

46import Text.Blaze.Html

47−import UnliftIO.Exception (try)

47+import UnliftIO.Exception (catch, throwIO, try)

49type API =

50 "github-webhook"

@@ -52,8 +52,8 @@ type API =

52 :> GitHubSignedReqBody '[JSON] InstallationEvent

53 :> Post '[JSON] ()

54 :<|> GitHubEvent '[ 'WebhookPushEvent]

55− :> GitHubSignedReqBody '[JSON] PushEvent

55+ :> GitHubSignedReqBody '[JSON] PushEvent

56− :> Post '[JSON] ()

56+ :> Post '[JSON] ()

57 )

58 :<|> "submission"

59 :> Capture "user name" String

@@ -78,7 +78,7 @@ pendingStatus :: NewStatus

78pendingStatus = NewStatus StatusPending Nothing Nothing Nothing

80webhookPushEvent ::

81− (StaticPQ m, WithLog env Message m, MonadUnliftIO m, HasTasks m) =>

81+ (StaticPQ m, WithLog env Message m, MonadUnliftIO m, HasTasks m, MonadError ServerError m) =>

82 RepoWebhookEvent ->

83 ((), PushEvent) ->

84 m ()

@@ -86,8 +86,10 @@ webhookPushEvent _ ((), ev) = do

86 let repo = evPushRepository ev

87 user = T.unpack . whUserLogin . evPushSender $ ev

88 fullRepoName = whRepoFullName repo

89− [owner, repoName] = T.splitOn "/" fullRepoName

89+ (owner, repoName) <- case T.splitOn "/" fullRepoName of

90+ [a, b] -> return (a, b)

91+ _ -> throwError err422

90− Just sha = evPushHeadSha ev

92+ sha <- maybe (throwError err422) return $ evPushHeadSha ev

91 tasks <- getTasks

93 tasks <- getTasks

92 let task =

94 let task =

93 M.lookupMax $

95 M.lookupMax $

@@ -102,7 +104,7 @@ webhookPushEvent _ ((), ev) = do

102 (T.unpack name)

104 (T.unpack name)

103 (T.unpack sha)

105 (T.unpack sha)

104 (Jsonb BuildScheduled)

106 (Jsonb BuildScheduled)

105− scheduleTask $ Build prebuild dockerfile (N owner) (N repoName) (N sha)

107+ scheduleTask $ Build prebuild dockerfile (N owner) (N repoName) (N sha) timeoutMinutes

106 liftIO $ do

108 liftIO $ do

107 print ev

109 print ev

108 hFlush stdout

110 hFlush stdout

@@ -130,7 +132,7 @@ retestSubmission owner repoName sha = do

130 Just (name, TaskConfig {..}) | T.take (T.length name) repoName' == name -> do

132 Just (name, TaskConfig {..}) | T.take (T.length name) repoName' == name -> do

131 scheduleTask $ StatusUpdate (N owner') (N repoName') (N sha') pendingStatus

133 scheduleTask $ StatusUpdate (N owner') (N repoName') (N sha') pendingStatus

132 updateSubmissionStatus fullRepoName sha BuildScheduled

134 updateSubmissionStatus fullRepoName sha BuildScheduled

133− scheduleTask $ Build prebuild dockerfile (N owner') (N repoName') (N sha')

135+ scheduleTask $ Build prebuild dockerfile (N owner') (N repoName') (N sha') timeoutMinutes

134 _ -> return ()

136 _ -> return ()

135 redirectToSubmission owner repoName sha

137 redirectToSubmission owner repoName sha

136

138

@@ -148,6 +150,10 @@ newtype ServerM (schema :: SchemasType) a

148 MonadUnliftIO

150 MonadUnliftIO

149 )

151 )

150

152

153+instance MonadError ServerError (ServerM schema) where

154+ throwError = throwIO

155+ catchError = catch

156+

151server :: ServerT API (ServerM Schema)

157server :: ServerT API (ServerM Schema)

152server = (webhookInstallation :<|> webhookPushEvent) :<|> getSubmissionR :<|> retestSubmission :<|> getResults

158server = (webhookInstallation :<|> webhookPushEvent) :<|> getSubmissionR :<|> retestSubmission :<|> getResults

153

159

@@ -164,15 +170,16 @@ runServer = do

164 let context =

170 let context =

165 gitPolyHubKey (return webhookSecret)

171 gitPolyHubKey (return webhookSecret)

166 :. EmptyContext

172 :. EmptyContext

167− serverData = ServerData

173+ serverData =

174+ ServerData

168− { githubAppAuth = auth,

175+ { githubAppAuth = auth,

169− githubUserName = GithubUserName githubUsername,

176+ githubUserName = GithubUserName githubUsername,

170− githubAccessToken = GithubAccessToken personalAccessToken,

177+ githubAccessToken = GithubAccessToken personalAccessToken,

171− tasks = ts,

178+ tasks = ts,

172− logger = cfilter ((logSeverity <=) . msgSeverity) richMessageAction,

179+ logger = cfilter ((logSeverity <=) . msgSeverity) richMessageAction,

173− baseUrl = baseSiteUrl,

180+ baseUrl = baseSiteUrl,

174− dockerUrl = T.pack cfgDockerUrl

181+ dockerUrl = T.pack cfgDockerUrl

175− }

182+ }

176 repeatIfNotEmpty n f = f >>= \m -> do

183 repeatIfNotEmpty n f = f >>= \m -> do

177 when (m == 0) $ liftIO $ threadDelay n

184 when (m == 0) $ liftIO $ threadDelay n

178 repeatIfNotEmpty n f

185 repeatIfNotEmpty n f

@@ -221,7 +228,6 @@ instance HasContextEntry '[PolyGitHubKey] (GitHubKey result) where

221 getContextEntry (PolyGitHubKey x :. _) = x

228 getContextEntry (PolyGitHubKey x :. _) = x

222

229

223instance MonadReader (ServerData n) m => GithubCloner m where

230instance MonadReader (ServerData n) m => GithubCloner m where

224−

225 getGithubAccessToken = asks githubAccessToken

231 getGithubAccessToken = asks githubAccessToken

226

232

227 getGithubUserName = asks githubUserName

233 getGithubUserName = asks githubUserName

@@ -245,8 +251,8 @@ type TasksConfig = Map T.Text TaskConfig

245data TaskConfig

251data TaskConfig

246 = TaskConfig

252 = TaskConfig

247 { prebuild :: String,

253 { prebuild :: String,

248− dockerfile :: String

254+ dockerfile :: String,

249− -- build :: T.Text

255+ timeoutMinutes :: Int

250 }

256 }

251 deriving stock (Show, Eq, Generic)

257 deriving stock (Show, Eq, Generic)

252 deriving anyclass (FromJSON, ToJSON)

258 deriving anyclass (FromJSON, ToJSON)

@@ -255,7 +261,6 @@ class HasTasks m where

255 getTasks :: m TasksConfig

261 getTasks :: m TasksConfig

256

262

257instance HasLog (ServerData m) Message m where

263instance HasLog (ServerData m) Message m where

258−

259 getLogAction :: ServerData m -> LogAction m Message

264 getLogAction :: ServerData m -> LogAction m Message

260 getLogAction = logger

265 getLogAction = logger

261 {-# INLINE getLogAction #-}

266 {-# INLINE getLogAction #-}

src/Server/Html.hs+5−8

@@ -1,3 +1,5 @@

1+{-# OPTIONS_GHC -Wno-orphans #-}

1module Server.Html

3module Server.Html

2 ( getSubmissionR,

4 ( getSubmissionR,

3 MonadHasBaseUrl (..),

5 MonadHasBaseUrl (..),

@@ -8,17 +10,12 @@ where

9import Clay as C

11import Clay as C

10import Colog

12import Colog

11−import Control.Monad.IO.Class

12import Control.Monad.IO.Unlift

13import Control.Monad.IO.Unlift

13−import Data.Aeson hiding (Success)

14−import qualified Data.ByteString.Lazy.Char8 as BS

15import Data.Foldable

14import Data.Foldable

16import qualified Data.Map as M

15import qualified Data.Map as M

17import Data.String

16import Data.String

18import Data.Submission

17import Data.Submission

19import Data.Submission.Query

18import Data.Submission.Query

20−import qualified Data.Text as T

21−import GHC.Generics

22import Server.Schema

19import Server.Schema

23import Squeal.PostgreSQL (Jsonb (..))

20import Squeal.PostgreSQL (Jsonb (..))

24import Text.Blaze

21import Text.Blaze

@@ -32,12 +29,12 @@ getSubmissionR ::

32 String ->

29 String ->

33 String ->

30 String ->

34 m Markup

31 m Markup

35−getSubmissionR user repo sha = do

32+getSubmissionR user repo sha' = do

36− restartUrl <- (<> "/restart") <$> getUrl (user <> "/" <> repo) sha

33+ restartUrl <- (<> "/restart") <$> getUrl (user <> "/" <> repo) sha'

37 let restartBuild = do

34 let restartBuild = do

38 H.form H.! A.action (fromString restartUrl) H.! A.method "post" $

35 H.form H.! A.action (fromString restartUrl) H.! A.method "post" $

39 H.input H.! A.type_ "submit" H.! A.value "Restart test"

36 H.input H.! A.type_ "submit" H.! A.value "Restart test"

40− (titleText, inner) <- getSubmission (user <> "/" <> repo) sha >>= \case

37+ (titleText, inner) <- getSubmission (user <> "/" <> repo) sha' >>= \case

41 Nothing ->

38 Nothing ->

42 return . ("Not found",) $

39 return . ("Not found",) $

43 H.h1 "404. not found. go away."

40 H.h1 "404. not found. go away."