4597fdc...master · sc-build

git.iko.soy/sc-build

on master help sign in

README.mdnew file+64

since splitsnapshots

unifiedsplit

@@ -0,0 +1,64 @@

1+# sc-build

3+Need both manual weebohook and app.

5+Installation id needs to be configured manually.

7+## Usage

9+You want to have some predefined docker container with maximum dependencies cached.

10+

11+

12+Exmaple:

13+

14+```dockerfile

15+FROM fpco/stack-build:lts-14.27

16+

17+RUN stack update

18+RUN stack build tasty tasty-hspec aeson containers bytestring

19+

20+WORKDIR /

21+```

22+

23+You need to build that container and git it a name:

24+

25+```bash

26+docker build -t fast-lts-14.27 - < FastDockerFile

27+```

28+

29+After that you can use it in your `tasks.yaml`:

30+

31+```yaml

32+test-task:

33+ prebuild: |

34+ cp -f ../../test-task/package.yaml .

35+ cp -f ../../test-task/stack.yaml .

36+ cp -f -R ../../test-task/test .

37+ dockerfile: |

38+ FROM fast-lts-14.27

39+ COPY . src

40+ WORKDIR /src

41+ ENTRYPOINT stack test --fast

42+ timeoutMinutes: 10

43+```

44+

45+The docker container is expected to write json to stdout, conating test results:

46+

47+```json

48+{

49+ "test1": true,

50+ "test2": false

51+}

52+```

53+

54+For macos docker API:

55+

56+```bash

57+socat TCP-LISTEN:1234,range=127.0.0.1/32,reuseaddr,fork UNIX-CLIENT:/var/run/docker.sock

58+```

59+

60+or this (didn't work for me):

61+

62+```bash

63+docker run -d -v /var/run/docker.sock:/var/run/docker.sock -p 127.0.0.1:2357:1234 bobrik/socat TCP-LISTEN:1234,fork UNIX-CONNECT:/var/run/docker.sock

64+```

app/Main.hs+25−1

@@ -1,6 +1,30 @@

1module Main (main) where

3+import qualified Data.ByteString.Char8 as BS

4+import Data.Yaml (encode)

5+import Options.Applicative

3import Server

6import Server

7+import Server.Config

5main :: IO ()

9main :: IO ()

6−main = runServer

10+main =

11+ execParser (info (getOptions <**> helper) fullDesc) >>= \case

12+ PrintDefaultConfig -> putStrLn . BS.unpack . encode $ defaultConfig

13+ RunServer config -> runServer config

14+

15+data Run

16+ = PrintDefaultConfig

17+ | RunServer FilePath

18+

19+getOptions :: Parser Run

20+getOptions =

21+ subparser

22+ ( command "default" (info (pure PrintDefaultConfig <**> helper) fullDesc)

23+ )

24+ <|> ( RunServer

25+ <$> strOption

26+ ( long "config"

27+ <> help "Path to yaml config file."

28+ <> value "config.yaml"

29+ )

30+ )

package.yaml+4

@@ -52,6 +52,7 @@ library:

52 - transformers

53 - cassava

54 - http-media

55+ - utf8-string

56executables:

57executables:

57 sc-build-exe:

58 sc-build-exe:

@@ -63,6 +64,9 @@ executables:

63 - -with-rtsopts=-N

64 - -with-rtsopts=-N

64 dependencies:

65 dependencies:

65 - sc-build

66 - sc-build

67+ - bytestring

68+ - yaml

69+ - optparse-applicative

66 sc-build-migrations:

70 sc-build-migrations:

67 main: Main.hs

71 main: Main.hs

68 source-dirs: migrations

72 source-dirs: migrations

src/Control/HasGithubStatus.hsnew file+14

@@ -0,0 +1,14 @@

1+module Control.HasGithubStatus

2+ ( HasGithubStatus (..),

3+ )

4+where

6+import Colog

7+import Data.Submission

8+import GitHub.Data

10+class HasGithubStatus m where

11+ schedulePendingStatus :: WithLog env Message m => Name Owner -> Name Repo -> Name Commit -> m ()

12+ scheduleTestedStatus :: WithLog env Message m => TestResult -> Name Owner -> Name Repo -> Name Commit -> m ()

13+ scheduleFailedStatus :: WithLog env Message m => String -> Name Owner -> Name Repo -> Name Commit -> m ()

14+ deadlineHasPassedStatus :: WithLog env Message m => Name Owner -> Name Repo -> Name Commit -> m ()

src/Control/Task/Scheduler.hs+5−4

@@ -3,6 +3,7 @@

3module Control.Task.Scheduler

4 ( scheduleTask,

5 runTasks,

6+ makeAllRunnable,

6 )

7 )

7where

8where

@@ -20,6 +21,7 @@ import Data.Word

20import GHC.TypeLits

21import GHC.TypeLits

21import Server.Schema

22import Server.Schema

22import Squeal.PostgreSQL

23import Squeal.PostgreSQL

24+import UnliftIO.Exception

24scheduleTask ::

26scheduleTask ::

25 (StaticPQ m, WithLog env Message m, Task t s, MonadUnliftIO m) =>

27 (StaticPQ m, WithLog env Message m, Task t s, MonadUnliftIO m) =>

@@ -45,7 +47,6 @@ rescheduleTaskTime ::

45rescheduleTaskTime = rescheduleTaskQuery

47rescheduleTaskTime = rescheduleTaskQuery

47class RunTasks (ts :: [*]) m where

49class RunTasks (ts :: [*]) m where

48−

49 runTask :: WithLog env Message m => PickedTask -> m ()

50 runTask :: WithLog env Message m => PickedTask -> m ()

51 taskNames :: [String]

52 taskNames :: [String]

@@ -55,7 +56,6 @@ instance

55 (Task t ts, TaskMonad t m, StaticPQ m, RunTasks tt m, MonadUnliftIO m) =>

56 (Task t ts, TaskMonad t m, StaticPQ m, RunTasks tt m, MonadUnliftIO m) =>

56 RunTasks (t ': tt) m

57 RunTasks (t ': tt) m

57 where

58 where

58−

59 runTask (PickedTask s (Jsonb v) initialStartTime) | symbolVal @ts Proxy == s =

60 case fromJSON @t v of

61 A.Error e ->

@@ -67,7 +67,9 @@ instance

67 <> e

68 A.Success t -> do

69 logInfo . T.pack $ "running task " <> task <> " with " <> show t <> " created at " <> show initialStartTime

70− r <- performTask @t @ts @m t

70+ r <- performTask @t @ts @m t `catchAny` \e -> do

71+ logError . T.pack . displayException $ e

72+ return Failure

71 when (r == Failure) $ logWarning . T.pack $ "Task " <> task <> " failed"

73 when (r == Failure) $ logWarning . T.pack $ "Task " <> task <> " failed"

72 case r of

74 case r of

73 Success -> completeTaskQuery t

75 Success -> completeTaskQuery t

@@ -79,7 +81,6 @@ instance

79 taskNames = symbolVal @ts Proxy : taskNames @tt @m

81 taskNames = symbolVal @ts Proxy : taskNames @tt @m

81instance RunTasks '[] m where

83instance RunTasks '[] m where

82−

83 runTask (PickedTask s (Jsonb v) _) =

84 runTask (PickedTask s (Jsonb v) _) =

84 logError . T.pack $ "Unknown task " <> s <> " with payload " <> show v

85 logError . T.pack $ "Unknown task " <> s <> " with payload " <> show v

src/Control/Task/Scheduler/Query.hs+37−4

@@ -5,11 +5,13 @@ module Control.Task.Scheduler.Query

5 completeTaskQuery,

6 rescheduleTaskQuery,

7 pickTasksQuery,

8+ makeAllRunnable,

8 PickedTask (..),

9 PickedTask (..),

9 )

10 )

10where

11where

12import Colog

13import Colog

14+import Control.Arrow

13import Control.Monad.IO.Unlift

15import Control.Monad.IO.Unlift

14import Control.Squeal

16import Control.Squeal

15import Control.Task

17import Control.Task

@@ -38,6 +40,8 @@ scheduleTaskQuery task = do

38 Set (param @1) `as` #task

40 Set (param @1) `as` #task

39 :* Set (param @2) `as` #payload

41 :* Set (param @2) `as` #payload

40 :* Default `as` #creation_time

42 :* Default `as` #creation_time

43+ :* Default `as` #started

44+ :* Default `as` #failures

41 )

45 )

42 ( OnConflict

46 ( OnConflict

43 (OnConstraint #pk_task_payload)

47 (OnConstraint #pk_task_payload)

@@ -82,7 +86,10 @@ rescheduleTaskQuery payload = do

82 query =

86 query =

83 update_

87 update_

84 #tasks

88 #tasks

85− (Default `as` #creation_time)

89+ ( Default `as` #creation_time

90+ :* Default `as` #started

91+ :* Set (#failures + 1) `as` #failures

92+ )

86 (param @1 .== #task .&& param @2 .== #payload)

93 (param @1 .== #task .&& param @2 .== #payload)

87 dbWrite (const $ return ()) $

94 dbWrite (const $ return ()) $

88 manipulateParams_

95 manipulateParams_

@@ -96,7 +103,7 @@ pickTasksQuery ::

96 Word64 ->

103 Word64 ->

97 m [PickedTask]

104 m [PickedTask]

98pickTasksQuery tasks limitCount = do

105pickTasksQuery tasks limitCount = do

99− logDebug "reading tasks"

106+ logDebug $ "reading tasks " <> T.unwords (T.pack <$> tasks)

100 let query :: Query_ Schema () PickedTask

107 let query :: Query_ Schema () PickedTask

101 query =

108 query =

102 select_

109 select_

@@ -106,11 +113,23 @@ pickTasksQuery tasks limitCount = do

106 )

113 )

107 ( from (table #tasks)

114 ( from (table #tasks)

108 & where_ (#task `in_` (literal <$> tasks))

115 & where_ (#task `in_` (literal <$> tasks))

116+ & where_ (not_ . notNull $ #started)

117+ & where_ (#failures .< 20)

109 & orderBy [#creation_time & Asc]

118 & orderBy [#creation_time & Asc]

110 & limit limitCount

119 & limit limitCount

120+ & orderBy [#creation_time & Desc]

121+ )

122+ startedMan :: Manipulation_ Schema (String, Jsonb Value) ()

123+ startedMan =

124+ update_

125+ #tasks

126+ ( Set true `as` #started

111 )

127 )

128+ (param @1 .== #task .&& param @2 .== #payload)

112− dbRead (const $ return []) $

129+ dbWrite (const $ return []) $ do

113− runQuery query >>= getRows

130+ pickedTasks <- runQuery query >>= getRows

131+ traversePrepared_ startedMan $ (task &&& payload) <$> pickedTasks

132+ return pickedTasks

114

133

115data PickedTask

134data PickedTask

116 = PickedTask

135 = PickedTask

@@ -119,3 +138,17 @@ data PickedTask

119 creationTime :: UTCTime

138 creationTime :: UTCTime

120 }

139 }

121 deriving (Eq, Show, Generic, SOP.Generic, SOP.HasDatatypeInfo)

140 deriving (Eq, Show, Generic, SOP.Generic, SOP.HasDatatypeInfo)

141+

142+makeAllRunnable ::

143+ (StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>

144+ m ()

145+makeAllRunnable = do

146+ let startAll :: Manipulation_ Schema () ()

147+ startAll =

148+ update_

149+ #tasks

150+ ( Set false `as` #started

151+ )

152+ (notNull #started)

153+ dbWrite (const $ return ()) $

154+ manipulate_ startAll

src/Data/Submission.hs+1

@@ -29,6 +29,7 @@ data SubmissionStatus

29 = SubmissionRun TestResult

30 | SubmissionFailed String

31 | BuildScheduled

32+ | PastDeadline

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

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

34newtype TestResult

35newtype TestResult

src/Data/Tasks/Build.hs+33−40

@@ -10,17 +10,16 @@ where

10import Colog

11import Control.Concurrent

12import Control.GithubCloner

13+import Control.HasGithubStatus

13import Control.Monad.Except

14import Control.Monad.Except

14import Control.Monad.IO.Unlift

15import Control.Monad.IO.Unlift

15import Control.Task

16import Control.Task

16−import Control.Task.Scheduler

17import Data.Aeson hiding (Success)

18import qualified Data.ByteString.Lazy.Char8 as BS

19−import qualified Data.Map as M

19+import qualified Data.ByteString.Lazy.UTF8 as BS

20import Data.String

21import Data.Submission

22import Data.Submission.Query

23−import Data.Tasks.StatusUpdate

24import qualified Data.Text as T

23import qualified Data.Text as T

25import Data.Time.Clock.POSIX

24import Data.Time.Clock.POSIX

26import qualified Docker.Client as D

25import qualified Docker.Client as D

@@ -46,7 +45,9 @@ data Build

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

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

48instance Task Build "build-repo" where

47instance Task Build "build-repo" where

48+ type

49+ TaskMonad Build m =

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

50+ (MonadUnliftIO m, StaticPQ m, HasDockerInfo m, GithubCloner m, HasGithubStatus m)

51 performTask Build {..} =

52 performTask Build {..} =

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

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

@@ -54,7 +55,7 @@ instance Task Build "build-repo" where

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

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

55 case shellCode of

56 case shellCode of

56 ExitFailure n -> do

57 ExitFailure n -> do

57− let err = BS.unpack shellErr

58+ let err = BS.toString shellErr

58 logError . T.pack $

59 logError . T.pack $

59 "preprocessing command for repo " <> show fullRepoName <> " at sha "

60 "preprocessing command for repo " <> show fullRepoName <> " at sha "

60 <> show sha

61 <> show sha

@@ -62,7 +63,7 @@ instance Task Build "build-repo" where

62 <> show n

63 <> show n

63 <> " and error "

64 <> " and error "

64 <> err

65 <> err

65− scheduleTask erroredTask

66+ scheduleFailedStatus err owner repoName sha

66 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

67 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

67 ExitSuccess -> do

68 ExitSuccess -> do

68 h <- liftIO D.defaultHttpHandler

69 h <- liftIO D.defaultHttpHandler

@@ -73,7 +74,8 @@ instance Task Build "build-repo" where

73 Exception err,

74 Exception err,

74 WithLog env Message m,

75 WithLog env Message m,

75 StaticPQ m,

76 StaticPQ m,

76− MonadUnliftIO m

77+ MonadUnliftIO m,

78+ HasGithubStatus m

77 ) =>

79 ) =>

78 D.DockerT IO (Either err a) ->

80 D.DockerT IO (Either err a) ->

79 m a

81 m a

@@ -89,7 +91,7 @@ instance Task Build "build-repo" where

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

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

90 ExceptT $ D.createContainer opts Nothing

92 ExceptT $ D.createContainer opts Nothing

91 dockerRes <- fmap (either id id)

93 dockerRes <- fmap (either id id)

92− . race (liftIO (threadDelay (timeoutMinutes * 60000000)) >> return (ExitFailure 1, "Time out"))

94+ . race (liftIO (threadDelay (timeoutMinutes * 60000000)) >> return (ExitFailure 1, "Time out", "Time out"))

93 $ flip

95 $ flip

94 finally

96 finally

95 ( runDocker $

97 ( runDocker $

@@ -113,10 +115,21 @@ instance Task Build "build-repo" where

113 tail = D.All

115 tail = D.All

114 }

116 }

115 cid

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

116− return (buildCode, buildOut)

129+ return (buildCode, buildOut, buildErr)

117 case dockerRes of

130 case dockerRes of

118− (ExitFailure n, buildOut) -> do

131+ (ExitFailure n, _, buildErr) -> do

119− let err = BS.unpack buildOut

132+ let err = BS.toString buildErr

120 logError . T.pack $

133 logError . T.pack $

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

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

122 <> show sha

135 <> show sha

@@ -124,60 +137,40 @@ instance Task Build "build-repo" where

124 <> show n

137 <> show n

125 <> " and error "

138 <> " and error "

126 <> err

139 <> err

127− scheduleTask erroredTask

140+ scheduleFailedStatus err owner repoName sha

128 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

141 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

129− (ExitSuccess, buildOut) ->

142+ (ExitSuccess, buildOut, _) ->

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

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

131 Left err' -> do

144 Left err' -> do

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

145+ let err = err' <> " " <> BS.toString buildOut

133 logError . T.pack $

146 logError . T.pack $

134 "could not decode test result from repo " <> show fullRepoName

147 "could not decode test result from repo " <> show fullRepoName

135 <> " at sha "

148 <> " at sha "

136 <> show sha

149 <> show sha

137 <> ": "

150 <> ": "

138 <> err

151 <> err

139− scheduleTask erroredTask

152+ scheduleFailedStatus err owner repoName sha

140− updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

153+ updateSubmissionStatus fullRepoName sha' (SubmissionFailed (err <> BS.toString buildOut))

141 Right testResult@TestResult {..} -> do

154 Right testResult@TestResult {..} -> do

142− let total = M.size tests

155+ scheduleTestedStatus testResult owner repoName sha

143− passed = M.size . M.filter id $ tests

144− description = T.pack $ show passed <> "/" <> show total

145− status =

146− statusTask

147− NewStatus

148− { newStatusState =

149− if total == passed then StatusSuccess else StatusFailure,

150− newStatusTargetUrl = Nothing,

151− newStatusDescription = Just description,

152− newStatusContext = Nothing

153− }

154− scheduleTask status

155 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

156 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

156 return Success

157 return Success

157 where

158 where

158− statusTask = StatusUpdate owner repoName sha

159− erroredTask =

160− statusTask $

161− NewStatus

162− { newStatusState = StatusError,

163− newStatusTargetUrl = Nothing,

164− newStatusDescription = Just "Build failed",

165− newStatusContext = Nothing

166− }

167 fullRepoName = T.unpack $ untagName owner <> "/" <> untagName repoName

159 fullRepoName = T.unpack $ untagName owner <> "/" <> untagName repoName

168 sha' = T.unpack $ untagName sha

160 sha' = T.unpack $ untagName sha

169 runEither ::

161 runEither ::

170 ( Exception err,

162 ( Exception err,

171 WithLog env Message m,

163 WithLog env Message m,

172 StaticPQ m,

164 StaticPQ m,

173− MonadUnliftIO m

165+ MonadUnliftIO m,

166+ HasGithubStatus m

174 ) =>

167 ) =>

175 Either err b ->

168 Either err b ->

176 m b

169 m b

177 runEither (Left err) = do

170 runEither (Left err) = do

178 let err' = show err

171 let err' = show err

179 logError $ T.pack err'

172 logError $ T.pack err'

180− scheduleTask erroredTask

173+ scheduleFailedStatus err' owner repoName sha

181 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err')

174 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err')

182 throwIO err

175 throwIO err

183 runEither (Right a) = return a

176 runEither (Right a) = return a

src/Data/Tasks/StatusUpdate.hs−1

@@ -31,7 +31,6 @@ instance FromJSON NewStatus where

31 <*> v .:? "context"

33instance Task StatusUpdate "update-commit-ci-status" where

34−

35 type TaskMonad StatusUpdate m = (AppRequestable m)

34 type TaskMonad StatusUpdate m = (AppRequestable m)

37 performTask StatusUpdate {..} = do

36 performTask StatusUpdate {..} = do

src/Server.hs+119−34

@@ -10,6 +10,7 @@ import Colog

10import Control.AppRequestable

11import Control.Concurrent

12import Control.GithubCloner

13+import Control.HasGithubStatus

13import Control.Monad.Except

14import Control.Monad.Except

14import Control.Monad.IO.Unlift

15import Control.Monad.IO.Unlift

15import Control.Monad.Reader

16import Control.Monad.Reader

@@ -29,6 +30,7 @@ import Data.Submission.Query

29import Data.Tasks.Build

30import Data.Tasks.Build

30import Data.Tasks.StatusUpdate

31import Data.Tasks.StatusUpdate

31import qualified Data.Text as T

32import qualified Data.Text as T

33+import Data.Time.Clock

32import Data.Yaml

34import Data.Yaml

33import GHC.Generics

35import GHC.Generics

34import GitHub hiding (Accept)

36import GitHub hiding (Accept)

@@ -37,7 +39,7 @@ import GitHub.App.Request

37import GitHub.Auth (Auth (OAuth))

39import GitHub.Auth (Auth (OAuth))

38import GitHub.Data.Name

40import GitHub.Data.Name

39import GitHub.Data.Webhooks.Events

41import GitHub.Data.Webhooks.Events

40−import GitHub.Data.Webhooks.Payload

42+import GitHub.Data.Webhooks.Payload hiding (URL (..))

41import Network.HTTP.Client.TLS (newTlsManager)

43import Network.HTTP.Client.TLS (newTlsManager)

42import Network.HTTP.Media.MediaType

44import Network.HTTP.Media.MediaType

43import Network.Wai.Handler.Warp

45import Network.Wai.Handler.Warp

@@ -48,7 +50,6 @@ import Server.Config

48import Server.Html

50import Server.Html

49import Server.Schema

51import Server.Schema

50import Squeal.PostgreSQL

52import Squeal.PostgreSQL

51−import System.IO

52import Text.Blaze.Html

53import Text.Blaze.Html

53import UnliftIO.Exception (catch, displayException, handleAny, throwIO, try)

54import UnliftIO.Exception (catch, displayException, handleAny, throwIO, try)

@@ -74,17 +75,18 @@ type API =

74 :> Post '[HTML] Markup

75 :> Post '[HTML] Markup

75 :<|> "results" :> Capture "task name" String :> Get '[CSV, HTML] [Score]

76 :<|> "results" :> Capture "task name" String :> Get '[CSV, HTML] [Score]

77−webhookInstallation :: MonadIO m => RepoWebhookEvent -> ((), InstallationEvent) -> m ()

78+webhookInstallation :: WithLog env Message m => RepoWebhookEvent -> ((), InstallationEvent) -> m ()

78webhookInstallation _ ((), ev) =

79webhookInstallation _ ((), ev) =

79− liftIO $ do

80+ logInfo . T.pack . show $ ev

80− print ev

81− hFlush stdout

82−

83−pendingStatus :: NewStatus

84−pendingStatus = NewStatus StatusPending Nothing Nothing Nothing

86webhookPushEvent ::

82webhookPushEvent ::

83+ ( StaticPQ m,

84+ MonadReader (ServerData m) m,

85+ MonadUnliftIO m,

86+ HasTasks m,

87− (StaticPQ m, WithLog env Message m, MonadUnliftIO m, HasTasks m, MonadError ServerError m) =>

87+ MonadError ServerError m,

88+ WithLog env Message m

89+ ) =>

88 RepoWebhookEvent ->

90 RepoWebhookEvent ->

89 ((), PushEvent) ->

91 ((), PushEvent) ->

90 m ()

92 m ()

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

102 M.takeWhileAntitone (repoName >) tasks

104 M.takeWhileAntitone (repoName >) tasks

103 case task of

105 case task of

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

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

105− scheduleTask $ StatusUpdate (N owner) (N repoName) (N sha) pendingStatus

107+ nowTime <- liftIO getCurrentTime

108+ if nowTime > deadline

109+ then do

110+ deadlineHasPassedStatus (N owner) (N repoName) (N sha)

111+ createSubmission $

112+ Submission

113+ user

114+ (T.unpack fullRepoName)

115+ (T.unpack name)

116+ (T.unpack sha)

117+ (Jsonb PastDeadline)

118+ else do

119+ schedulePendingStatus (N owner) (N repoName) (N sha)

106− createSubmission $

120+ createSubmission $

107− Submission

121+ Submission

108− user

122+ user

109− (T.unpack fullRepoName)

123+ (T.unpack fullRepoName)

110− (T.unpack name)

124+ (T.unpack name)

111− (T.unpack sha)

125+ (T.unpack sha)

112− (Jsonb BuildScheduled)

126+ (Jsonb BuildScheduled)

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

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

114− liftIO $ do

128+ logInfo . T.pack . show $ ev

115− print ev

116− hFlush stdout

117 _ -> return ()

129 _ -> return ()

118

130

119retestSubmission ::

131retestSubmission ::

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

132+ (StaticPQ m, MonadReader (ServerData m) m, MonadUnliftIO m, HasTasks m, MonadHasBaseUrl m) =>

121 String ->

133 String ->

122 String ->

134 String ->

123 String ->

135 String ->

@@ -136,7 +148,7 @@ retestSubmission owner repoName sha = do

136 M.takeWhileAntitone (repoName' >) tasks

148 M.takeWhileAntitone (repoName' >) tasks

137 case task of

149 case task of

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

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

139− scheduleTask $ StatusUpdate (N owner') (N repoName') (N sha') pendingStatus

151+ schedulePendingStatus (N owner') (N repoName') (N sha')

140 updateSubmissionStatus fullRepoName sha BuildScheduled

152 updateSubmissionStatus fullRepoName sha BuildScheduled

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

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

142 _ -> return ()

154 _ -> return ()

@@ -163,9 +175,9 @@ instance MonadError ServerError (ServerM schema) where

163server :: ServerT API (ServerM Schema)

175server :: ServerT API (ServerM Schema)

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

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

165

177

166−runServer :: IO ()

178+runServer :: FilePath -> IO ()

167−runServer = do

179+runServer config = do

168− c@Config {..} <- getConfig

180+ c@Config {..} <- getConfig config

169 print c

181 print c

170 pem <- BS.readFile appPkPemPath

182 pem <- BS.readFile appPkPemPath

171 appPkPem <- case readRsaPem pem of

183 appPkPem <- case readRsaPem pem of

@@ -186,20 +198,26 @@ runServer = do

186 tasks = ts,

198 tasks = ts,

187 logger = cfilter ((logSeverity <=) . msgSeverity) richMessageAction,

199 logger = cfilter ((logSeverity <=) . msgSeverity) richMessageAction,

188 baseUrl = baseSiteUrl,

200 baseUrl = baseSiteUrl,

189− dockerUrl = T.pack cfgDockerUrl

201+ dockerUrl = T.pack cfgDockerUrl,

202+ context = githubContext

190 }

203 }

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

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

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

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

193 repeatIfNotEmpty n f

206 repeatIfNotEmpty n f

194 printingErrors =

207 printingErrors =

195 handleAny (logError . T.pack . displayException >=> const (return 0))

208 handleAny (logError . T.pack . displayException >=> const (return 0))

196− _ <-

209+ usingConnectionPool pool

210+ . (`runReaderT` serverData)

211+ . unApp

212+ . handleAny (error . displayException)

213+ $ makeAllRunnable

214+ replicateM_ builderCount

197− forkIO . repeatIfNotEmpty (10 ^ (6 :: Int))

215+ $ forkIO . repeatIfNotEmpty (10 ^ (6 :: Int))

198 . usingConnectionPool pool

216 . usingConnectionPool pool

199 . (`runReaderT` serverData)

217 . (`runReaderT` serverData)

200 . unApp

218 . unApp

201 . printingErrors

219 . printingErrors

202− $ runTasks @'[Build] 1

220+ $ runTasks @'[Build] 1

203 _ <-

221 _ <-

204 forkIO . repeatIfNotEmpty (10 ^ (6 :: Int))

222 forkIO . repeatIfNotEmpty (10 ^ (6 :: Int))

205 . usingConnectionPool pool

223 . usingConnectionPool pool

@@ -225,8 +243,9 @@ data ServerData m

225 { githubAppAuth :: !InstallationAuth,

243 { githubAppAuth :: !InstallationAuth,

226 tasks :: IORef TasksConfig,

244 tasks :: IORef TasksConfig,

227 logger :: LogAction m Message,

245 logger :: LogAction m Message,

228− baseUrl :: String,

246+ baseUrl :: T.Text,

229− dockerUrl :: T.Text

247+ dockerUrl :: T.Text,

248+ context :: T.Text

230 }

249 }

231

250

232newtype PolyGitHubKey = PolyGitHubKey (forall result. GitHubKey result)

251newtype PolyGitHubKey = PolyGitHubKey (forall result. GitHubKey result)

@@ -261,6 +280,71 @@ instance MonadReader (ServerData n) m => MonadHasBaseUrl m where

261instance (MonadIO m, MonadReader (ServerData n) m) => HasTasks m where

280instance (MonadIO m, MonadReader (ServerData n) m) => HasTasks m where

262 getTasks = asks tasks >>= liftIO . readIORef

281 getTasks = asks tasks >>= liftIO . readIORef

263

282

283+instance (MonadReader (ServerData m) m, StaticPQ m, MonadUnliftIO m) => HasGithubStatus m where

284+ schedulePendingStatus nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do

285+ h <- asks baseUrl

286+ c <- asks context

287+ scheduleTask $

288+ StatusUpdate

289+ nOwner

290+ nRepo

291+ nCommit

292+ ( NewStatus

293+ StatusPending

294+ (Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha)

295+ (Just "⌛")

296+ (Just c)

297+ )

298+ scheduleTestedStatus TestResult {..} nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do

299+ h <- asks baseUrl

300+ c <- asks context

301+ let total = M.size tests

302+ passed = M.size . M.filter id $ tests

303+ description = T.pack $ show passed <> "/" <> show total <> if passed == total then " ✅" else " ❌"

304+ status =

305+ StatusUpdate

306+ nOwner

307+ nRepo

308+ nCommit

309+ NewStatus

310+ { newStatusState =

311+ if total == passed then StatusSuccess else StatusFailure,

312+ newStatusTargetUrl = Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha,

313+ newStatusDescription = Just description,

314+ newStatusContext = Just c

315+ }

316+ scheduleTask status

317+ scheduleFailedStatus _ nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do

318+ h <- asks baseUrl

319+ c <- asks context

320+ let status =

321+ StatusUpdate

322+ nOwner

323+ nRepo

324+ nCommit

325+ NewStatus

326+ { newStatusState = StatusError,

327+ newStatusTargetUrl = Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha,

328+ newStatusDescription = Just "Build failed ☠️",

329+ newStatusContext = Just c

330+ }

331+ scheduleTask status

332+ deadlineHasPassedStatus nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do

333+ h <- asks baseUrl

334+ c <- asks context

335+ let status =

336+ StatusUpdate

337+ nOwner

338+ nRepo

339+ nCommit

340+ NewStatus

341+ { newStatusState = StatusError,

342+ newStatusTargetUrl = Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha,

343+ newStatusDescription = Just "The deadline has passed ⏰",

344+ newStatusContext = Just c

345+ }

346+ scheduleTask status

347+

264instance (MonadReader (ServerData n) m) => HasDockerInfo m where

348instance (MonadReader (ServerData n) m) => HasDockerInfo m where

265 getDockerUrl = asks dockerUrl

349 getDockerUrl = asks dockerUrl

266

350

@@ -270,7 +354,8 @@ data TaskConfig

270 = TaskConfig

354 = TaskConfig

271 { prebuild :: String,

355 { prebuild :: String,

272 dockerfile :: String,

356 dockerfile :: String,

273− timeoutMinutes :: Int

357+ timeoutMinutes :: Int,

358+ deadline :: UTCTime

274 }

359 }

275 deriving stock (Show, Eq, Generic)

360 deriving stock (Show, Eq, Generic)

276 deriving anyclass (FromJSON, ToJSON)

361 deriving anyclass (FromJSON, ToJSON)

src/Server/Config.hs+17−7

@@ -28,10 +28,11 @@ data Config

28 installationId :: !(Id Installation),

29 tasksPath :: !FilePath,

30 databseUrl :: !ByteString,

31− baseSiteUrl :: !String,

31+ baseSiteUrl :: !Text,

32 cfgDockerUrl :: !String,

33− cfgDockerFile :: !FilePath,

34− logSeverity :: !Severity

33+ logSeverity :: !Severity,

34+ builderCount :: !Int,

35+ githubContext :: !Text

35 }

36 }

36 deriving (Show, Generic)

37 deriving (Show, Generic)

@@ -39,12 +40,20 @@ instance FromJSON ByteString where

39 parseJSON (String s) = return . BS.pack . T.unpack $ s

40 parseJSON (String s) = return . BS.pack . T.unpack $ s

40 parseJSON _ = fail "not a string"

41 parseJSON _ = fail "not a string"

43+instance ToJSON ByteString where

44+ toJSON = String . T.pack . BS.unpack

45+

42instance FromJSON Severity where

46instance FromJSON Severity where

43 parseJSON (String s) = maybe (fail "oh no") return . readMaybe . T.unpack $ s

47 parseJSON (String s) = maybe (fail "oh no") return . readMaybe . T.unpack $ s

44 parseJSON _ = fail "not a string"

48 parseJSON _ = fail "not a string"

50+instance ToJSON Severity where

51+ toJSON = String . T.pack . show

52+

46instance FromJSON Config

53instance FromJSON Config

55+instance ToJSON Config

56+

48defaultConfig :: Config

57defaultConfig :: Config

49defaultConfig =

58defaultConfig =

50 Config

59 Config

@@ -57,12 +66,13 @@ defaultConfig =

57 databseUrl = "host=localhost port=5432 dbname=sc-build connect_timeout=10",

66 databseUrl = "host=localhost port=5432 dbname=sc-build connect_timeout=10",

58 baseSiteUrl = "http://localhost:8080",

67 baseSiteUrl = "http://localhost:8080",

59 cfgDockerUrl = "http://localhost:1234",

68 cfgDockerUrl = "http://localhost:1234",

60− cfgDockerFile = "TmpDockerfile",

61− logSeverity = Info

69+ logSeverity = Info,

70+ builderCount = 2,

71+ githubContext = "MY CI NAME"

62 }

72 }

64−getConfig :: IO Config

74+getConfig :: FilePath -> IO Config

65−getConfig = decodeThrow "config.yaml"

75+getConfig = decodeFileThrow

67-- getConfig :: IO Config

77-- getConfig :: IO Config

68-- getConfig =

78-- getConfig =

src/Server/Html.hs+10−6

@@ -16,6 +16,7 @@ import qualified Data.Map as M

16import Data.String

17import Data.Submission

18import Data.Submission.Query

19+import qualified Data.Text as T

19import Server.Schema

20import Server.Schema

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

21import Squeal.PostgreSQL (Jsonb (..))

21import Text.Blaze

22import Text.Blaze

@@ -38,15 +39,16 @@ getSubmissionR user repo sha' = do

38 Nothing ->

39 Nothing ->

39 return . ("Not found",) $

40 return . ("Not found",) $

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

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

41− Just Submission {..} -> return . (repo,) $ do

42+ Just Submission {..} -> return . (problem,) $ do

42 H.h1 $ toHtml problem

43 H.h1 $ toHtml problem

43 H.h2 $ toHtml userName

44 H.h2 $ toHtml userName

45+ H.h3 . H.code . toHtml . take 7 $ sha

44 case status of

46 case status of

45 Jsonb BuildScheduled -> do

47 Jsonb BuildScheduled -> do

46− H.h3 "Waiting to build"

48+ H.h3 "Waiting to build ⌛"

47 restartBuild

49 restartBuild

48 Jsonb (SubmissionFailed err) -> do

50 Jsonb (SubmissionFailed err) -> do

49− H.h3 "Failed to build"

51+ H.h3 "Failed to build ☠️"

50 restartBuild

52 restartBuild

51 H.code . H.pre $ toHtml err

53 H.code . H.pre $ toHtml err

52 Jsonb (SubmissionRun (TestResult tests)) -> do

54 Jsonb (SubmissionRun (TestResult tests)) -> do

@@ -54,11 +56,13 @@ getSubmissionR user repo sha' = do

54 passed = M.size . M.filter Prelude.id $ tests

56 passed = M.size . M.filter Prelude.id $ tests

55 H.h3 . toHtml $

57 H.h3 . toHtml $

56 "Tests have run: " <> show passed <> "/" <> show total

58 "Tests have run: " <> show passed <> "/" <> show total

57− <> if passed == total then " ✅" else ""

59+ <> if passed == total then " 🎉" else " 🍌"

58 restartBuild

60 restartBuild

59 H.table $ flip M.foldMapWithKey tests $ \testName testPassed -> H.tr $ do

61 H.table $ flip M.foldMapWithKey tests $ \testName testPassed -> H.tr $ do

60 (H.td H.! A.align "right") . H.p $ toHtml testName

62 (H.td H.! A.align "right") . H.p $ toHtml testName

61 H.td $ if testPassed then "✅" else "❌"

63 H.td $ if testPassed then "✅" else "❌"

64+ Jsonb PastDeadline ->

65+ H.h3 "This was submitted after the deadline ⏰"

62 return . docTypeHtml $ do

66 return . docTypeHtml $ do

63 H.head $ do

67 H.head $ do

64 H.title $ toHtml titleText

68 H.title $ toHtml titleText

@@ -91,12 +95,12 @@ getSubmissionR user repo sha' = do

91 H.body inner

95 H.body inner

93class MonadHasBaseUrl m where

97class MonadHasBaseUrl m where

94− getBaseUrl :: m String

98+ getBaseUrl :: m T.Text

96getUrl :: (MonadHasBaseUrl m, Monad m) => String -> String -> m String

100getUrl :: (MonadHasBaseUrl m, Monad m) => String -> String -> m String

97getUrl fullName sha = do

101getUrl fullName sha = do

98 siteBase <- getBaseUrl

102 siteBase <- getBaseUrl

99− return $ siteBase <> "/submission/" <> fullName <> "/" <> sha

103+ return $ T.unpack siteBase <> "/submission/" <> fullName <> "/" <> sha

100

104

101redirectToSubmission ::

105redirectToSubmission ::

102 (MonadHasBaseUrl m, Monad m) =>

106 (MonadHasBaseUrl m, Monad m) =>

src/Server/Schema.hs+3−1

@@ -6,13 +6,15 @@ module Server.Schema

6where

8import Server.Schema.V1

9+import Server.Schema.V2

9import Squeal.PostgreSQL

10import Squeal.PostgreSQL

11type StaticPQ m = MonadPQ Schema m

12type StaticPQ m = MonadPQ Schema m

13−type Schema = SchemaV1

14+type Schema = SchemaV2

15migration :: AlignedList (Migration (Terminally PQ IO)) (Public '[]) Schema

16migration :: AlignedList (Migration (Terminally PQ IO)) (Public '[]) Schema

16migration =

17migration =

17 pureMigration schemaMigrationV1

18 pureMigration schemaMigrationV1

19+ :>> pureMigration schemaMigrationV2

18 :>> Done

20 :>> Done

src/Server/Schema/V1.hs+25−22

@@ -18,7 +18,8 @@ type SchemaV1 =

18 ]

19 :=> '[ "task" ::: 'NoDef :=> 'NotNull (PG Text),

20 "payload" ::: 'NoDef :=> 'NotNull (PG (Jsonb Value)),

21− "creation_time" ::: 'Def :=> 'NotNull (PG UTCTime)

21+ "creation_time" ::: 'Def :=> 'NotNull (PG UTCTime),

22+ "started" ::: 'Def :=> 'NotNull (PG Bool)

22 ]

23 ]

23 ),

24 ),

24 "submissions"

25 "submissions"

@@ -34,28 +35,30 @@ type SchemaV1 =

34 ]

35 ]

36schemaMigrationV1 :: Migration Definition (Public '[]) SchemaV1

37schemaMigrationV1 :: Migration Definition (Public '[]) SchemaV1

37−schemaMigrationV1 = Migration

38+schemaMigrationV1 =

39+ Migration

38− { name = "v1",

40+ { name = "v1",

39− up =

41+ up =

40− createTable

42+ createTable

41− #tasks

43+ #tasks

42− ( notNullable text `as` #task

44+ ( notNullable text `as` #task

43− :* notNullable jsonb `as` #payload

45+ :* notNullable jsonb `as` #payload

44− :* default_ now (notNullable timestampWithTimeZone) `as` #creation_time

46+ :* default_ now (notNullable timestampWithTimeZone) `as` #creation_time

45− )

46− (primaryKey (#task :* #payload) `as` #pk_task_payload)

47− >>> createTable

48− #submissions

49− ( notNullable text `as` #user_name

47+ :* default_ false (notNullable bool) `as` #started

50− :* notNullable text `as` #repo_full_name

51− :* notNullable text `as` #problem

52− :* notNullable text `as` #sha

53− :* notNullable jsonb `as` #status

54 )

48 )

49+ (primaryKey (#task :* #payload) `as` #pk_task_payload)

50+ >>> createTable

51+ #submissions

52+ ( notNullable text `as` #user_name

53+ :* notNullable text `as` #repo_full_name

54+ :* notNullable text `as` #problem

55+ :* notNullable text `as` #sha

56+ :* notNullable jsonb `as` #status

57+ )

55− (primaryKey (#repo_full_name :* #sha) `as` #pk_submission_repo_full_name_sha)

58+ (primaryKey (#repo_full_name :* #sha) `as` #pk_submission_repo_full_name_sha)

56− >>> createIndexes,

59+ >>> createIndexes,

57− down = dropTable #tasks >>> dropTable #submissions

60+ down = dropTable #tasks >>> dropTable #submissions

58− }

61+ }

59 where

62 where

60 createIndexes :: Definition sch sch

63 createIndexes :: Definition sch sch

61 createIndexes =

64 createIndexes =

src/Server/Schema/V2.hsnew file+46

@@ -0,0 +1,46 @@

1+module Server.Schema.V2

2+ ( SchemaV2,

3+ schemaMigrationV2,

4+ )

5+where

7+import Data.Aeson

8+import Data.Int

9+import Data.Submission

10+import Data.Text (Text)

11+import Data.Time

12+import Server.Schema.V1

13+import Squeal.PostgreSQL

14+

15+type SchemaV2 =

16+ Public

17+ '[ "tasks"

18+ ::: 'Table

19+ ( '[ "pk_task_payload" :=> 'PrimaryKey '["task", "payload"]

20+ ]

21+ :=> '[ "task" ::: 'NoDef :=> 'NotNull (PG Text),

22+ "payload" ::: 'NoDef :=> 'NotNull (PG (Jsonb Value)),

23+ "creation_time" ::: 'Def :=> 'NotNull (PG UTCTime),

24+ "started" ::: 'Def :=> 'NotNull (PG Bool),

25+ "failures" ::: 'Def :=> 'NotNull (PG Int32)

26+ ]

27+ ),

28+ "submissions"

29+ ::: 'Table

30+ ( '["pk_submission_repo_full_name_sha" :=> 'PrimaryKey '["repo_full_name", "sha"]]

31+ :=> '[ "user_name" ::: 'NoDef :=> 'NotNull (PG String),

32+ "repo_full_name" ::: 'NoDef :=> 'NotNull (PG String),

33+ "problem" ::: 'NoDef :=> 'NotNull (PG String),

34+ "sha" ::: 'NoDef :=> 'NotNull (PG String),

35+ "status" ::: 'NoDef :=> 'NotNull (PG (Jsonb SubmissionStatus))

36+ ]

37+ )

38+ ]

39+

40+schemaMigrationV2 :: Migration Definition SchemaV1 SchemaV2

41+schemaMigrationV2 =

42+ Migration

43+ { name = "v2",

44+ up = alterTable #tasks (addColumn #failures (default_ 0 $ notNullable int)),

45+ down = alterTable #tasks (dropColumn #failures)

46+ }

stack.yaml+2−1

@@ -46,8 +46,9 @@ extra-deps:

46- git: https://github.com/ilyakooo0/github-app

47 commit: 0bede85ab53eb8f953cf6f4e58a756a205e88e0b

48- servant-github-webhook-0.4.2.0

49−- docker-0.6.0.3

50- http-client-0.5.14

49- http-client-0.5.14

50+- git: https://github.com/ilyakooo0/docker-hs

51+ commit: 5cfdc4d7facd7043f530bce4ce0f0c57c923b029

52# Override default flag values for local packages and extra-deps

53# Override default flag values for local packages and extra-deps

53# flags: {}

54# flags: {}

tasks.yaml+1

@@ -8,3 +8,4 @@ test-task:

8 COPY . src

9 WORKDIR /src

10 ENTRYPOINT stack test --fast

11+ timeoutMinutes: 10