master..4597fdc · sc-build

git.iko.soy/sc-build

on 4597fdc help sign in

README.mddeleted−64

since splitsnapshots

unifiedsplit

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

1−# sc-build

2−

3−Need both manual weebohook and app.

4−

5−Installation id needs to be configured manually.

6−

7−## Usage

8−

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+1−25

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

1module Main (main) where

3−import qualified Data.ByteString.Char8 as BS

4−import Data.Yaml (encode)

5−import Options.Applicative

6import Server

3import Server

7−import Server.Config

9main :: IO ()

5main :: IO ()

10−main =

6+main = runServer

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,7 +52,6 @@ library:

52 - transformers

53 - cassava

54 - http-media

55− - utf8-string

57executables:

56executables:

58 sc-build-exe:

57 sc-build-exe:

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

64 - -with-rtsopts=-N

63 - -with-rtsopts=-N

65 dependencies:

64 dependencies:

66 - sc-build

65 - sc-build

67− - bytestring

68− - yaml

69− - optparse-applicative

70 sc-build-migrations:

66 sc-build-migrations:

71 main: Main.hs

67 main: Main.hs

72 source-dirs: migrations

68 source-dirs: migrations

src/Control/HasGithubStatus.hsdeleted−14

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

1−module Control.HasGithubStatus

2− ( HasGithubStatus (..),

3− )

4−where

5−

6−import Colog

7−import Data.Submission

8−import GitHub.Data

9−

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+4−5

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

3module Control.Task.Scheduler

4 ( scheduleTask,

5 runTasks,

6− makeAllRunnable,

7 )

6 )

8where

7where

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

21import GHC.TypeLits

20import GHC.TypeLits

22import Server.Schema

21import Server.Schema

23import Squeal.PostgreSQL

22import Squeal.PostgreSQL

24−import UnliftIO.Exception

26scheduleTask ::

24scheduleTask ::

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

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

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

47rescheduleTaskTime = rescheduleTaskQuery

45rescheduleTaskTime = rescheduleTaskQuery

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

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

48+

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

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

52 taskNames :: [String]

51 taskNames :: [String]

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

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

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

57 RunTasks (t ': tt) m

56 RunTasks (t ': tt) m

58 where

57 where

58+

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

60 case fromJSON @t v of

61 A.Error e ->

@@ -67,9 +67,7 @@ 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 `catchAny` \e -> do

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

71− logError . T.pack . displayException $ e

72− return Failure

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

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

74 case r of

72 case r of

75 Success -> completeTaskQuery t

73 Success -> completeTaskQuery t

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

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

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

83instance RunTasks '[] m where

81instance RunTasks '[] m where

82+

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

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

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

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

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

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

5 completeTaskQuery,

6 rescheduleTaskQuery,

7 pickTasksQuery,

8− makeAllRunnable,

9 PickedTask (..),

8 PickedTask (..),

10 )

9 )

11where

10where

13import Colog

12import Colog

14−import Control.Arrow

15import Control.Monad.IO.Unlift

13import Control.Monad.IO.Unlift

16import Control.Squeal

14import Control.Squeal

17import Control.Task

15import Control.Task

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

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

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

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

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

42 :* Default `as` #creation_time

40 :* Default `as` #creation_time

43− :* Default `as` #started

44− :* Default `as` #failures

45 )

41 )

46 ( OnConflict

42 ( OnConflict

47 (OnConstraint #pk_task_payload)

43 (OnConstraint #pk_task_payload)

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

86 query =

82 query =

87 update_

83 update_

88 #tasks

84 #tasks

89− ( Default `as` #creation_time

85+ (Default `as` #creation_time)

90− :* Default `as` #started

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

92− )

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

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

94 dbWrite (const $ return ()) $

87 dbWrite (const $ return ()) $

95 manipulateParams_

88 manipulateParams_

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

103 Word64 ->

96 Word64 ->

104 m [PickedTask]

97 m [PickedTask]

105pickTasksQuery tasks limitCount = do

98pickTasksQuery tasks limitCount = do

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

99+ logDebug "reading tasks"

107 let query :: Query_ Schema () PickedTask

100 let query :: Query_ Schema () PickedTask

108 query =

101 query =

109 select_

102 select_

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

113 )

106 )

114 ( from (table #tasks)

107 ( from (table #tasks)

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

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

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

117− & where_ (#failures .< 20)

118 & orderBy [#creation_time & Asc]

109 & orderBy [#creation_time & Asc]

119 & limit limitCount

110 & 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

127 )

111 )

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

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

112+ dbRead (const $ return []) $

130− pickedTasks <- runQuery query >>= getRows

113+ runQuery query >>= getRows

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

132− return pickedTasks

133

114

134data PickedTask

115data PickedTask

135 = PickedTask

116 = PickedTask

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

138 creationTime :: UTCTime

119 creationTime :: UTCTime

139 }

120 }

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

121 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,7 +29,6 @@ data SubmissionStatus

29 = SubmissionRun TestResult

30 | SubmissionFailed String

31 | BuildScheduled

32− | PastDeadline

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

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

35newtype TestResult

34newtype TestResult

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

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

10import Colog

11import Control.Concurrent

12import Control.GithubCloner

13−import Control.HasGithubStatus

14import Control.Monad.Except

13import Control.Monad.Except

15import Control.Monad.IO.Unlift

14import Control.Monad.IO.Unlift

16import Control.Task

15import Control.Task

16+import Control.Task.Scheduler

17import Data.Aeson hiding (Success)

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

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

19+import qualified Data.Map as M

20import Data.String

21import Data.Submission

22import Data.Submission.Query

23+import Data.Tasks.StatusUpdate

23import qualified Data.Text as T

24import qualified Data.Text as T

24import Data.Time.Clock.POSIX

25import Data.Time.Clock.POSIX

25import qualified Docker.Client as D

26import qualified Docker.Client as D

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

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

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

47instance Task Build "build-repo" where

48instance Task Build "build-repo" where

48− type

49− TaskMonad Build m =

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

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

52 performTask Build {..} =

51 performTask Build {..} =

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

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

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

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

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

56 case shellCode of

55 case shellCode of

57 ExitFailure n -> do

56 ExitFailure n -> do

58− let err = BS.toString shellErr

57+ let err = BS.unpack shellErr

59 logError . T.pack $

58 logError . T.pack $

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

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

61 <> show sha

60 <> show sha

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

63 <> show n

62 <> show n

64 <> " and error "

63 <> " and error "

65 <> err

64 <> err

66− scheduleFailedStatus err owner repoName sha

65+ scheduleTask erroredTask

67 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

66 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

68 ExitSuccess -> do

67 ExitSuccess -> do

69 h <- liftIO D.defaultHttpHandler

68 h <- liftIO D.defaultHttpHandler

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

74 Exception err,

73 Exception err,

75 WithLog env Message m,

74 WithLog env Message m,

76 StaticPQ m,

75 StaticPQ m,

77− MonadUnliftIO m,

76+ MonadUnliftIO m

78− HasGithubStatus m

79 ) =>

77 ) =>

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

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

81 m a

79 m a

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

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

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

92 ExceptT $ D.createContainer opts Nothing

90 ExceptT $ D.createContainer opts Nothing

93 dockerRes <- fmap (either id id)

91 dockerRes <- fmap (either id id)

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

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

95 $ flip

93 $ flip

96 finally

94 finally

97 ( runDocker $

95 ( runDocker $

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

115 tail = D.All

113 tail = D.All

116 }

114 }

117 cid

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

116+ return (buildCode, buildOut)

130 case dockerRes of

117 case dockerRes of

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

118+ (ExitFailure n, buildOut) -> do

132− let err = BS.toString buildErr

119+ let err = BS.unpack buildOut

133 logError . T.pack $

120 logError . T.pack $

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

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

135 <> show sha

122 <> show sha

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

137 <> show n

124 <> show n

138 <> " and error "

125 <> " and error "

139 <> err

126 <> err

140− scheduleFailedStatus err owner repoName sha

127+ scheduleTask erroredTask

141 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

128 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

142− (ExitSuccess, buildOut, _) ->

129+ (ExitSuccess, buildOut) ->

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

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

144 Left err' -> do

131 Left err' -> do

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

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

146 logError . T.pack $

133 logError . T.pack $

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

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

148 <> " at sha "

135 <> " at sha "

149 <> show sha

136 <> show sha

150 <> ": "

137 <> ": "

151 <> err

138 <> err

152− scheduleFailedStatus err owner repoName sha

139+ scheduleTask erroredTask

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

140+ updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

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

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

155− scheduleTestedStatus testResult owner repoName sha

142+ let total = M.size tests

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

156 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

155 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

157 return Success

156 return Success

158 where

157 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+ }

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

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

160 sha' = T.unpack $ untagName sha

168 sha' = T.unpack $ untagName sha

161 runEither ::

169 runEither ::

162 ( Exception err,

170 ( Exception err,

163 WithLog env Message m,

171 WithLog env Message m,

164 StaticPQ m,

172 StaticPQ m,

165− MonadUnliftIO m,

173+ MonadUnliftIO m

166− HasGithubStatus m

167 ) =>

174 ) =>

168 Either err b ->

175 Either err b ->

169 m b

176 m b

170 runEither (Left err) = do

177 runEither (Left err) = do

171 let err' = show err

178 let err' = show err

172 logError $ T.pack err'

179 logError $ T.pack err'

173− scheduleFailedStatus err' owner repoName sha

180+ scheduleTask erroredTask

174 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err')

181 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err')

175 throwIO err

182 throwIO err

176 runEither (Right a) = return a

183 runEither (Right a) = return a

src/Data/Tasks/StatusUpdate.hs+1

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

31 <*> v .:? "context"

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

34+

34 type TaskMonad StatusUpdate m = (AppRequestable m)

35 type TaskMonad StatusUpdate m = (AppRequestable m)

36 performTask StatusUpdate {..} = do

37 performTask StatusUpdate {..} = do

src/Server.hs+34−119

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

10import Control.AppRequestable

11import Control.Concurrent

12import Control.GithubCloner

13−import Control.HasGithubStatus

14import Control.Monad.Except

13import Control.Monad.Except

15import Control.Monad.IO.Unlift

14import Control.Monad.IO.Unlift

16import Control.Monad.Reader

15import Control.Monad.Reader

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

30import Data.Tasks.Build

29import Data.Tasks.Build

31import Data.Tasks.StatusUpdate

30import Data.Tasks.StatusUpdate

32import qualified Data.Text as T

31import qualified Data.Text as T

33−import Data.Time.Clock

34import Data.Yaml

32import Data.Yaml

35import GHC.Generics

33import GHC.Generics

36import GitHub hiding (Accept)

34import GitHub hiding (Accept)

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

39import GitHub.Auth (Auth (OAuth))

37import GitHub.Auth (Auth (OAuth))

40import GitHub.Data.Name

38import GitHub.Data.Name

41import GitHub.Data.Webhooks.Events

39import GitHub.Data.Webhooks.Events

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

40+import GitHub.Data.Webhooks.Payload

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

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

44import Network.HTTP.Media.MediaType

42import Network.HTTP.Media.MediaType

45import Network.Wai.Handler.Warp

43import Network.Wai.Handler.Warp

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

50import Server.Html

48import Server.Html

51import Server.Schema

49import Server.Schema

52import Squeal.PostgreSQL

50import Squeal.PostgreSQL

51+import System.IO

53import Text.Blaze.Html

52import Text.Blaze.Html

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

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

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

75 :> Post '[HTML] Markup

74 :> Post '[HTML] Markup

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

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

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

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

79webhookInstallation _ ((), ev) =

78webhookInstallation _ ((), ev) =

80− logInfo . T.pack . show $ ev

79+ liftIO $ do

80+ print ev

81+ hFlush stdout

82+

83+pendingStatus :: NewStatus

84+pendingStatus = NewStatus StatusPending Nothing Nothing Nothing

82webhookPushEvent ::

86webhookPushEvent ::

83− ( StaticPQ m,

84− MonadReader (ServerData m) m,

85− MonadUnliftIO m,

86− HasTasks m,

87− MonadError ServerError m,

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

88− WithLog env Message m

89− ) =>

90 RepoWebhookEvent ->

88 RepoWebhookEvent ->

91 ((), PushEvent) ->

89 ((), PushEvent) ->

92 m ()

90 m ()

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

104 M.takeWhileAntitone (repoName >) tasks

102 M.takeWhileAntitone (repoName >) tasks

105 case task of

103 case task of

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

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

107− nowTime <- liftIO getCurrentTime

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

108− if nowTime > deadline

109− then do

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

111− createSubmission $

106+ createSubmission $

112− Submission

107+ Submission

113− user

108+ user

114− (T.unpack fullRepoName)

109+ (T.unpack fullRepoName)

115− (T.unpack name)

110+ (T.unpack name)

116− (T.unpack sha)

111+ (T.unpack sha)

117− (Jsonb PastDeadline)

118− else do

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

120− createSubmission $

121− Submission

122− user

123− (T.unpack fullRepoName)

124− (T.unpack name)

125− (T.unpack sha)

126− (Jsonb BuildScheduled)

112+ (Jsonb BuildScheduled)

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

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

128− logInfo . T.pack . show $ ev

114+ liftIO $ do

115+ print ev

116+ hFlush stdout

129 _ -> return ()

117 _ -> return ()

130

118

131retestSubmission ::

119retestSubmission ::

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

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

133 String ->

121 String ->

134 String ->

122 String ->

135 String ->

123 String ->

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

148 M.takeWhileAntitone (repoName' >) tasks

136 M.takeWhileAntitone (repoName' >) tasks

149 case task of

137 case task of

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

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

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

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

152 updateSubmissionStatus fullRepoName sha BuildScheduled

140 updateSubmissionStatus fullRepoName sha BuildScheduled

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

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

154 _ -> return ()

142 _ -> return ()

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

175server :: ServerT API (ServerM Schema)

163server :: ServerT API (ServerM Schema)

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

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

177

165

178−runServer :: FilePath -> IO ()

166+runServer :: IO ()

179−runServer config = do

167+runServer = do

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

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

181 print c

169 print c

182 pem <- BS.readFile appPkPemPath

170 pem <- BS.readFile appPkPemPath

183 appPkPem <- case readRsaPem pem of

171 appPkPem <- case readRsaPem pem of

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

198 tasks = ts,

186 tasks = ts,

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

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

200 baseUrl = baseSiteUrl,

188 baseUrl = baseSiteUrl,

201− dockerUrl = T.pack cfgDockerUrl,

189+ dockerUrl = T.pack cfgDockerUrl

202− context = githubContext

203 }

190 }

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

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

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

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

206 repeatIfNotEmpty n f

193 repeatIfNotEmpty n f

207 printingErrors =

194 printingErrors =

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

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

209− usingConnectionPool pool

196+ _ <-

210− . (`runReaderT` serverData)

211− . unApp

212− . handleAny (error . displayException)

213− $ makeAllRunnable

214− replicateM_ builderCount

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

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

216 . usingConnectionPool pool

198 . usingConnectionPool pool

217 . (`runReaderT` serverData)

199 . (`runReaderT` serverData)

218 . unApp

200 . unApp

219 . printingErrors

201 . printingErrors

220− $ runTasks @'[Build] 1

202+ $ runTasks @'[Build] 1

221 _ <-

203 _ <-

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

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

223 . usingConnectionPool pool

205 . usingConnectionPool pool

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

243 { githubAppAuth :: !InstallationAuth,

225 { githubAppAuth :: !InstallationAuth,

244 tasks :: IORef TasksConfig,

226 tasks :: IORef TasksConfig,

245 logger :: LogAction m Message,

227 logger :: LogAction m Message,

246− baseUrl :: T.Text,

228+ baseUrl :: String,

247− dockerUrl :: T.Text,

229+ dockerUrl :: T.Text

248− context :: T.Text

249 }

230 }

250

231

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

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

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

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

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

281 getTasks = asks tasks >>= liftIO . readIORef

262 getTasks = asks tasks >>= liftIO . readIORef

282

263

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−

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

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

349 getDockerUrl = asks dockerUrl

265 getDockerUrl = asks dockerUrl

350

266

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

354 = TaskConfig

270 = TaskConfig

355 { prebuild :: String,

271 { prebuild :: String,

356 dockerfile :: String,

272 dockerfile :: String,

357− timeoutMinutes :: Int,

273+ timeoutMinutes :: Int

358− deadline :: UTCTime

359 }

274 }

360 deriving stock (Show, Eq, Generic)

275 deriving stock (Show, Eq, Generic)

361 deriving anyclass (FromJSON, ToJSON)

276 deriving anyclass (FromJSON, ToJSON)

src/Server/Config.hs+7−17

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

28 installationId :: !(Id Installation),

29 tasksPath :: !FilePath,

30 databseUrl :: !ByteString,

31− baseSiteUrl :: !Text,

31+ baseSiteUrl :: !String,

32 cfgDockerUrl :: !String,

33+ cfgDockerFile :: !FilePath,

33− logSeverity :: !Severity,

34+ logSeverity :: !Severity

34− builderCount :: !Int,

35− githubContext :: !Text

36 }

35 }

37 deriving (Show, Generic)

36 deriving (Show, Generic)

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

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

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

41 parseJSON _ = fail "not a string"

40 parseJSON _ = fail "not a string"

43−instance ToJSON ByteString where

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

45−

46instance FromJSON Severity where

42instance FromJSON Severity where

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

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

48 parseJSON _ = fail "not a string"

44 parseJSON _ = fail "not a string"

50−instance ToJSON Severity where

51− toJSON = String . T.pack . show

52−

53instance FromJSON Config

46instance FromJSON Config

55−instance ToJSON Config

56−

57defaultConfig :: Config

48defaultConfig :: Config

58defaultConfig =

49defaultConfig =

59 Config

50 Config

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

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

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

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

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

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

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

60+ cfgDockerFile = "TmpDockerfile",

69− logSeverity = Info,

61+ logSeverity = Info

70− builderCount = 2,

71− githubContext = "MY CI NAME"

72 }

62 }

74−getConfig :: FilePath -> IO Config

64+getConfig :: IO Config

75−getConfig = decodeFileThrow

65+getConfig = decodeThrow "config.yaml"

77-- getConfig :: IO Config

67-- getConfig :: IO Config

78-- getConfig =

68-- getConfig =

src/Server/Html.hs+6−10

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

16import Data.String

17import Data.Submission

18import Data.Submission.Query

19−import qualified Data.Text as T

20import Server.Schema

19import Server.Schema

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

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

22import Text.Blaze

21import Text.Blaze

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

39 Nothing ->

38 Nothing ->

40 return . ("Not found",) $

39 return . ("Not found",) $

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

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

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

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

43 H.h1 $ toHtml problem

42 H.h1 $ toHtml problem

44 H.h2 $ toHtml userName

43 H.h2 $ toHtml userName

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

46 case status of

44 case status of

47 Jsonb BuildScheduled -> do

45 Jsonb BuildScheduled -> do

48− H.h3 "Waiting to build ⌛"

46+ H.h3 "Waiting to build"

49 restartBuild

47 restartBuild

50 Jsonb (SubmissionFailed err) -> do

48 Jsonb (SubmissionFailed err) -> do

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

49+ H.h3 "Failed to build"

52 restartBuild

50 restartBuild

53 H.code . H.pre $ toHtml err

51 H.code . H.pre $ toHtml err

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

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

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

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

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

57 H.h3 . toHtml $

55 H.h3 . toHtml $

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

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

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

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

60 restartBuild

58 restartBuild

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

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

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

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

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

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

64− Jsonb PastDeadline ->

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

66 return . docTypeHtml $ do

62 return . docTypeHtml $ do

67 H.head $ do

63 H.head $ do

68 H.title $ toHtml titleText

64 H.title $ toHtml titleText

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

95 H.body inner

91 H.body inner

97class MonadHasBaseUrl m where

93class MonadHasBaseUrl m where

98− getBaseUrl :: m T.Text

94+ getBaseUrl :: m String

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

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

101getUrl fullName sha = do

97getUrl fullName sha = do

102 siteBase <- getBaseUrl

98 siteBase <- getBaseUrl

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

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

104

100

105redirectToSubmission ::

101redirectToSubmission ::

106 (MonadHasBaseUrl m, Monad m) =>

102 (MonadHasBaseUrl m, Monad m) =>

src/Server/Schema.hs+1−3

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

6where

8import Server.Schema.V1

9−import Server.Schema.V2

10import Squeal.PostgreSQL

9import Squeal.PostgreSQL

12type StaticPQ m = MonadPQ Schema m

11type StaticPQ m = MonadPQ Schema m

14−type Schema = SchemaV2

13+type Schema = SchemaV1

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

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

17migration =

16migration =

18 pureMigration schemaMigrationV1

17 pureMigration schemaMigrationV1

19− :>> pureMigration schemaMigrationV2

20 :>> Done

18 :>> Done

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

@@ -18,8 +18,7 @@ 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)

23 ]

22 ]

24 ),

23 ),

25 "submissions"

24 "submissions"

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

35 ]

34 ]

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

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

38−schemaMigrationV1 =

37+schemaMigrationV1 = Migration

39− Migration

40− { name = "v1",

38+ { name = "v1",

41− up =

39+ up =

42− createTable

40+ createTable

43− #tasks

41+ #tasks

44− ( notNullable text `as` #task

42+ ( notNullable text `as` #task

45− :* notNullable jsonb `as` #payload

43+ :* notNullable jsonb `as` #payload

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

44+ :* 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

50+ :* notNullable text `as` #repo_full_name

51+ :* notNullable text `as` #problem

52+ :* notNullable text `as` #sha

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

53+ :* notNullable jsonb `as` #status

48 )

54 )

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

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

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

59− >>> createIndexes,

56+ >>> createIndexes,

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

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

61− }

58+ }

62 where

59 where

63 createIndexes :: Definition sch sch

60 createIndexes :: Definition sch sch

64 createIndexes =

61 createIndexes =

src/Server/Schema/V2.hsdeleted−46

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

1−module Server.Schema.V2

2− ( SchemaV2,

3− schemaMigrationV2,

4− )

5−where

6−

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+1−2

@@ -46,9 +46,8 @@ 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

49- http-client-0.5.14

50- http-client-0.5.14

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

51− commit: 5cfdc4d7facd7043f530bce4ce0f0c57c923b029

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

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

54# flags: {}

53# flags: {}

tasks.yaml−1

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

8 COPY . src

9 WORKDIR /src

10 ENTRYPOINT stack test --fast

11− timeoutMinutes: 10