f23e84c..master · sc-build

git.iko.soy/sc-build

18 files changed+575−214

unifiedsplit

README.md+64 app/Main.hs+25−1 package.yaml+5 src/Control/GithubCloner.hs+4−10 src/Control/HasGithubStatus.hs+14 src/Control/Task/Scheduler.hs+5−4 src/Control/Task/Scheduler/Query.hs+37−4 src/Data/Submission.hs+1 src/Data/Tasks/Build.hs+92−65 src/Data/Tasks/StatusUpdate.hs−1 src/Server.hs+165−57 src/Server/Config.hs+72−35 src/Server/Html.hs+14−13 src/Server/Schema.hs+3−1 src/Server/Schema/V1.hs+25−22 src/Server/Schema/V2.hs+46 stack.yaml+2−1 tasks.yaml+1

README.mdnew file+64

@@ -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 @@

11module Main (main) where

3+import qualified Data.ByteString.Char8 as BS

4+import Data.Yaml (encode)

5+import Options.Applicative

36import Server

7+import Server.Config

59main :: 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+5

@@ -17,6 +17,7 @@ dependencies:

1717library:

1818 source-dirs: src

1919 dependencies:

20+ - http-client-tls

2021 - servant

2122 - servant-server

2223 - process

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

5152 - transformers

5253 - cassava

5354 - http-media

55+ - utf8-string

5456

5557executables:

5658 sc-build-exe:

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

6264 - -with-rtsopts=-N

6365 dependencies:

6466 - sc-build

67+ - bytestring

68+ - yaml

69+ - optparse-applicative

6570 sc-build-migrations:

6671 main: Main.hs

6772 source-dirs: migrations

src/Control/GithubCloner.hs+4−10

@@ -1,16 +1,10 @@

11module Control.GithubCloner

2− ( GithubAccessToken (..),

3− GithubUserName (..),

4− GithubCloner (..),

2+ ( GithubCloner (..),

3+ InstallationToken (..),

54 )

65where

8−newtype GithubAccessToken = GithubAccessToken String

9−

10−newtype GithubUserName = GithubUserName String

7+newtype InstallationToken = InstallationToken String

118

129class GithubCloner m where

13−

14− getGithubAccessToken :: m GithubAccessToken

15−

16− getGithubUserName :: m GithubUserName

10+ getGithubInstallationToken :: m InstallationToken

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 @@

33module Control.Task.Scheduler

44 ( scheduleTask,

55 runTasks,

6+ makeAllRunnable,

67 )

78where

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

2021import GHC.TypeLits

2122import Server.Schema

2223import Squeal.PostgreSQL

24+import UnliftIO.Exception

2325

2426scheduleTask ::

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

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

4547rescheduleTaskTime = rescheduleTaskQuery

4648

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

48−

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

5051

5152 taskNames :: [String]

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

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

5657 RunTasks (t ': tt) m

5758 where

58−

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

6060 case fromJSON @t v of

6161 A.Error e ->

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

6767 <> e

6868 A.Success t -> do

6969 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

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

7274 case r of

7375 Success -> completeTaskQuery t

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

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

8082

8183instance RunTasks '[] m where

82−

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

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

8586

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

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

55 completeTaskQuery,

66 rescheduleTaskQuery,

77 pickTasksQuery,

8+ makeAllRunnable,

89 PickedTask (..),

910 )

1011where

1112

1213import Colog

14+import Control.Arrow

1315import Control.Monad.IO.Unlift

1416import Control.Squeal

1517import Control.Task

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

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

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

4042 :* Default `as` #creation_time

43+ :* Default `as` #started

44+ :* Default `as` #failures

4145 )

4246 ( OnConflict

4347 (OnConstraint #pk_task_payload)

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

8286 query =

8387 update_

8488 #tasks

85− (Default `as` #creation_time)

89+ ( Default `as` #creation_time

90+ :* Default `as` #started

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

92+ )

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

8794 dbWrite (const $ return ()) $

8895 manipulateParams_

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

96103 Word64 ->

97104 m [PickedTask]

98105pickTasksQuery tasks limitCount = do

99− logDebug "reading tasks"

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

100107 let query :: Query_ Schema () PickedTask

101108 query =

102109 select_

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

106113 )

107114 ( from (table #tasks)

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

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

117+ & where_ (#failures .< 20)

109118 & orderBy [#creation_time & Asc]

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

111127 )

112− dbRead (const $ return []) $

113− runQuery query >>= getRows

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

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

130+ pickedTasks <- runQuery query >>= getRows

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

132+ return pickedTasks

114133

115134data PickedTask

116135 = PickedTask

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

119138 creationTime :: UTCTime

120139 }

121140 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

2929 = SubmissionRun TestResult

3030 | SubmissionFailed String

3131 | BuildScheduled

32+ | PastDeadline

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

3334

3435newtype TestResult

src/Data/Tasks/Build.hs+92−65

@@ -8,18 +8,18 @@ module Data.Tasks.Build

88where

1010import Colog

11+import Control.Concurrent

1112import Control.GithubCloner

13+import Control.HasGithubStatus

1214import Control.Monad.Except

1315import Control.Monad.IO.Unlift

1416import Control.Task

15−import Control.Task.Scheduler

1617import Data.Aeson hiding (Success)

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

18−import qualified Data.Map as M

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

1920import Data.String

2021import Data.Submission

2122import Data.Submission.Query

22−import Data.Tasks.StatusUpdate

2323import qualified Data.Text as T

2424import Data.Time.Clock.POSIX

2525import qualified Docker.Client as D

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

3030import System.Exit

3131import System.Process.Typed

3232import System.Random

33+import UnliftIO.Async

3334import UnliftIO.Exception

3435

3536data Build

@@ -38,22 +39,23 @@ data Build

3839 dockerFile :: String,

3940 owner :: Name Owner,

4041 repoName :: Name Repo,

41− sha :: Name Commit

42+ sha :: Name Commit,

43+ timeoutMinutes :: Int

4244 }

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

4446

4547instance Task Build "build-repo" where

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

48+ type

49+ TaskMonad Build m =

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

4751

4852 performTask Build {..} =

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

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

51− sha' = T.unpack $ untagName sha

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

5254 cloneRepo fullRepoName sha' dir

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

5456 case shellCode of

5557 ExitFailure n -> do

56− let err = BS.unpack shellErr

58+ let err = BS.toString shellErr

5759 logError . T.pack $

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

5961 <> show sha

@@ -61,14 +63,23 @@ instance Task Build "build-repo" where

6163 <> show n

6264 <> " and error "

6365 <> err

64− scheduleTask erroredTask

66+ scheduleFailedStatus err owner repoName sha

6567 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

6668 ExitSuccess -> do

6769 h <- liftIO D.defaultHttpHandler

6870 dUrl <- getDockerUrl

6971 let opts = D.defaultCreateOpts imageName

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

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

72+ runDocker ::

73+ ( MonadIO m,

74+ Exception err,

75+ WithLog env Message m,

76+ StaticPQ m,

77+ MonadUnliftIO m,

78+ HasGithubStatus m

79+ ) =>

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

81+ m a

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

7283 imageName = T.pack dir

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

7485 absDir <- liftIO $ makeAbsolute dir

@@ -76,26 +87,49 @@ instance Task Build "build-repo" where

7687 D.waitContainer cid >>= \case

7788 Left D.GenericDockerError {} -> waitDockerForever cid

7889 a -> return a

79− dockerRes <- runDocker . runExceptT $ do

90+ cid <- runDocker . runExceptT $ do

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

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

82− ExceptT $ D.startContainer D.defaultStartOpts cid

83− buildCode <- ExceptT $ waitDockerForever cid

84− buildOut <-

85− ExceptT $

86− D.getContainerLogs

87− D.LogOpts

88− { stdout = True,

89− stderr = False,

90− since = Nothing,

91− timestamps = False,

92− tail = D.All

93− }

94− cid

95− return (buildCode, buildOut)

92+ ExceptT $ D.createContainer opts Nothing

93+ dockerRes <- fmap (either id id)

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

95+ $ flip

96+ finally

97+ ( runDocker $

98+ D.deleteContainer

99+ D.ContainerDeleteOpts {deleteVolumes = True, force = True}

100+ cid

101+ )

102+ . runDocker

103+ . runExceptT

104+ $ do

105+ ExceptT $ D.startContainer D.defaultStartOpts cid

106+ buildCode <- ExceptT $ waitDockerForever cid

107+ buildOut <-

108+ ExceptT $

109+ D.getContainerLogs

110+ D.LogOpts

111+ { stdout = True,

112+ stderr = False,

113+ since = Nothing,

114+ timestamps = False,

115+ tail = D.All

116+ }

117+ cid

118+ buildErr <-

119+ ExceptT $

120+ D.getContainerLogs

121+ D.LogOpts

122+ { stdout = True,

123+ stderr = True,

124+ since = Nothing,

125+ timestamps = False,

126+ tail = D.All

127+ }

128+ cid

129+ return (buildCode, buildOut, buildErr)

96130 case dockerRes of

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

98− let err = BS.unpack buildOut

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

132+ let err = BS.toString buildErr

99133 logError . T.pack $

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

101135 <> show sha

@@ -103,51 +137,43 @@ instance Task Build "build-repo" where

103137 <> show n

104138 <> " and error "

105139 <> err

106− scheduleTask erroredTask

140+ scheduleFailedStatus err owner repoName sha

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

142+ (ExitSuccess, buildOut, _) ->

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

115144 Left err' -> do

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

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

117146 logError . T.pack $

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

119148 <> " at sha "

120149 <> show sha

121150 <> ": "

122151 <> err

123− scheduleTask erroredTask

124− updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

152+ scheduleFailedStatus err owner repoName sha

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

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

126− let total = M.size tests

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

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

129− status =

130− statusTask

131− NewStatus

132− { newStatusState =

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

134− newStatusTargetUrl = Nothing,

135− newStatusDescription = Just description,

136− newStatusContext = Nothing

137− }

138− scheduleTask status

155+ scheduleTestedStatus testResult owner repoName sha

139156 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

140157 return Success

141158 where

142− statusTask = StatusUpdate owner repoName sha

143− erroredTask =

144− statusTask $

145− NewStatus

146− { newStatusState = StatusError,

147− newStatusTargetUrl = Nothing,

148− newStatusDescription = Just "Build failed",

149− newStatusContext = Nothing

150− }

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

160+ sha' = T.unpack $ untagName sha

161+ runEither ::

162+ ( Exception err,

163+ WithLog env Message m,

164+ StaticPQ m,

165+ MonadUnliftIO m,

166+ HasGithubStatus m

167+ ) =>

168+ Either err b ->

169+ m b

170+ runEither (Left err) = do

171+ let err' = show err

172+ logError $ T.pack err'

173+ scheduleFailedStatus err' owner repoName sha

174+ updateSubmissionStatus fullRepoName sha' (SubmissionFailed err')

175+ throwIO err

176+ runEither (Right a) = return a

151177

152178createDir :: MonadIO m => m FilePath

153179createDir = do

@@ -157,10 +183,9 @@ createDir = do

157183

158184cloneRepo :: (MonadIO m, GithubCloner m) => String -> String -> FilePath -> m ()

159185cloneRepo repoName sha path = do

160− GithubAccessToken token <- getGithubAccessToken

161− GithubUserName username <- getGithubUserName

186+ InstallationToken token <- getGithubInstallationToken

162187 runProcess_ . setWorkingDir path . fromString $

163− "git clone https://" <> username <> ":" <> token <> "@github.com/" <> repoName <> ".git ."

188+ "git clone https://x-access-token:" <> token <> "@github.com/" <> repoName <> ".git ."

164189 runProcess_ . setWorkingDir path . fromString $ "git checkout " <> sha

165190 return ()

166191

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

172197

173198class HasDockerInfo m where

174199 getDockerUrl :: m T.Text

200+

201+instance Exception D.DockerError

src/Data/Tasks/StatusUpdate.hs−1

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

3131 <*> v .:? "context"

3232

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

34−

3534 type TaskMonad StatusUpdate m = (AppRequestable m)

3635

3736 performTask StatusUpdate {..} = do

src/Server.hs+165−57

@@ -10,12 +10,17 @@ import Colog

1010import Control.AppRequestable

1111import Control.Concurrent

1212import Control.GithubCloner

13+import Control.HasGithubStatus

1314import Control.Monad.Except

1415import Control.Monad.IO.Unlift

1516import Control.Monad.Reader

1617import Control.Task.Scheduler

18+import Crypto.PubKey.RSA.Read

1719import Data.Aeson

1820import Data.ByteString

21+import qualified Data.ByteString as BS

22+import qualified Data.ByteString.Char8 as BSC

23+import qualified Data.ByteString.Lazy.Char8 as BSCL

1924import qualified Data.Csv as Csv

2025import Data.IORef

2126import Data.Map (Map)

@@ -25,14 +30,17 @@ import Data.Submission.Query

2530import Data.Tasks.Build

2631import Data.Tasks.StatusUpdate

2732import qualified Data.Text as T

33+import Data.Time.Clock

2834import Data.Yaml

2935import GHC.Generics

3036import GitHub hiding (Accept)

3137import GitHub.App.Auth

3238import GitHub.App.Request

39+import GitHub.Auth (Auth (OAuth))

3340import GitHub.Data.Name

3441import GitHub.Data.Webhooks.Events

35−import GitHub.Data.Webhooks.Payload

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

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

3644import Network.HTTP.Media.MediaType

3745import Network.Wai.Handler.Warp

3846import Servant

@@ -42,9 +50,8 @@ import Server.Config

4250import Server.Html

4351import Server.Schema

4452import Squeal.PostgreSQL

45−import System.IO

4653import Text.Blaze.Html

47−import UnliftIO.Exception (try)

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

4855

4956type API =

5057 "github-webhook"

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

5259 :> GitHubSignedReqBody '[JSON] InstallationEvent

5360 :> Post '[JSON] ()

5461 :<|> GitHubEvent '[ 'WebhookPushEvent]

55− :> GitHubSignedReqBody '[JSON] PushEvent

56− :> Post '[JSON] ()

62+ :> GitHubSignedReqBody '[JSON] PushEvent

63+ :> Post '[JSON] ()

5764 )

5865 :<|> "submission"

5966 :> Capture "user name" String

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

6875 :> Post '[HTML] Markup

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

7077

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

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

7279webhookInstallation _ ((), ev) =

73− liftIO $ do

74− print ev

75− hFlush stdout

76−

77−pendingStatus :: NewStatus

78−pendingStatus = NewStatus StatusPending Nothing Nothing Nothing

80+ logInfo . T.pack . show $ ev

7981

8082webhookPushEvent ::

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

83+ ( StaticPQ m,

84+ MonadReader (ServerData m) m,

85+ MonadUnliftIO m,

86+ HasTasks m,

87+ MonadError ServerError m,

88+ WithLog env Message m

89+ ) =>

8290 RepoWebhookEvent ->

8391 ((), PushEvent) ->

8492 m ()

@@ -86,30 +94,42 @@ webhookPushEvent _ ((), ev) = do

8694 let repo = evPushRepository ev

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

8896 fullRepoName = whRepoFullName repo

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

90− Just sha = evPushHeadSha ev

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

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

99+ _ -> throwError err422

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

91101 tasks <- getTasks

92102 let task =

93103 M.lookupMax $

94104 M.takeWhileAntitone (repoName >) tasks

95105 case task of

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

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

98− createSubmission $

99− Submission

100− user

101− (T.unpack fullRepoName)

102− (T.unpack name)

103− (T.unpack sha)

104− (Jsonb BuildScheduled)

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

106− liftIO $ do

107− print ev

108− hFlush stdout

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)

120+ createSubmission $

121+ Submission

122+ user

123+ (T.unpack fullRepoName)

124+ (T.unpack name)

125+ (T.unpack sha)

126+ (Jsonb BuildScheduled)

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

128+ logInfo . T.pack . show $ ev

109129 _ -> return ()

110130

111131retestSubmission ::

112− (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) =>

113133 String ->

114134 String ->

115135 String ->

@@ -128,9 +148,9 @@ retestSubmission owner repoName sha = do

128148 M.takeWhileAntitone (repoName' >) tasks

129149 case task of

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

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

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

132152 updateSubmissionStatus fullRepoName sha BuildScheduled

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

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

134154 _ -> return ()

135155 redirectToSubmission owner repoName sha

136156

@@ -148,13 +168,21 @@ newtype ServerM (schema :: SchemasType) a

148168 MonadUnliftIO

149169 )

150170

171+instance MonadError ServerError (ServerM schema) where

172+ throwError = throwIO

173+ catchError = catch

174+

151175server :: ServerT API (ServerM Schema)

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

153177

154−runServer :: IO ()

155−runServer = do

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

178+runServer :: FilePath -> IO ()

179+runServer config = do

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

157181 print c

182+ pem <- BS.readFile appPkPemPath

183+ appPkPem <- case readRsaPem pem of

184+ Right k -> return k

185+ Left e -> error (show e)

158186 auth <- mkInstallationAuth (AppAuth appId appPkPem) installationId

159187 ts <- newIORef mempty

160188 pool <- createConnectionPool databseUrl 1 0.5 10

@@ -164,29 +192,38 @@ runServer = do

164192 let context =

165193 gitPolyHubKey (return webhookSecret)

166194 :. EmptyContext

167− serverData = ServerData

168− { githubAppAuth = auth,

169− githubUserName = GithubUserName githubUsername,

170− githubAccessToken = GithubAccessToken personalAccessToken,

171− tasks = ts,

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

173− baseUrl = baseSiteUrl,

174− dockerUrl = T.pack cfgDockerUrl

175− }

195+ serverData =

196+ ServerData

197+ { githubAppAuth = auth,

198+ tasks = ts,

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

200+ baseUrl = baseSiteUrl,

201+ dockerUrl = T.pack cfgDockerUrl,

202+ context = githubContext

203+ }

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

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

178206 repeatIfNotEmpty n f

179− _ <-

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

207+ printingErrors =

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

209+ usingConnectionPool pool

210+ . (`runReaderT` serverData)

211+ . unApp

212+ . handleAny (error . displayException)

213+ $ makeAllRunnable

214+ replicateM_ builderCount

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

181216 . usingConnectionPool pool

182217 . (`runReaderT` serverData)

183218 . unApp

184− $ runTasks @'[Build] 1

219+ . printingErrors

220+ $ runTasks @'[Build] 1

185221 _ <-

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

187223 . usingConnectionPool pool

188224 . (`runReaderT` serverData)

189225 . unApp

226+ . printingErrors

190227 $ runTasks @'[StatusUpdate] 5

191228 run port $ serveWithContext (Proxy @API) context $

192229 hoistServerWithContext

@@ -204,12 +241,11 @@ updateTasks ref path =

204241data ServerData m

205242 = ServerData

206243 { githubAppAuth :: !InstallationAuth,

207− githubUserName :: !GithubUserName,

208− githubAccessToken :: !GithubAccessToken,

209244 tasks :: IORef TasksConfig,

210245 logger :: LogAction m Message,

211− baseUrl :: String,

212− dockerUrl :: T.Text

246+ baseUrl :: T.Text,

247+ dockerUrl :: T.Text,

248+ context :: T.Text

213249 }

214250

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

@@ -220,11 +256,18 @@ gitPolyHubKey k = PolyGitHubKey (Servant.GitHub.Webhook.gitHubKey k)

220256instance HasContextEntry '[PolyGitHubKey] (GitHubKey result) where

221257 getContextEntry (PolyGitHubKey x :. _) = x

222258

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

224−

225− getGithubAccessToken = asks githubAccessToken

226−

227− getGithubUserName = asks githubUserName

259+instance (MonadReader (ServerData n) m, MonadIO m, MonadError ServerError m) => GithubCloner m where

260+ getGithubInstallationToken =

261+ either

262+ (\e -> throwError err500 {errBody = BSCL.pack . displayException $ e})

263+ return

264+ <=< runExceptT

265+ $ do

266+ iAuth <- asks githubAppAuth

267+ manager <- newTlsManager

268+ liftIO (obtainAccessToken manager iAuth) >>= either throwError return >>= \case

269+ OAuth token -> return $ InstallationToken (BSC.unpack token)

270+ _ -> throwError $ UserError "Not OAuth token. This should never happen."

228271

229272instance (MonadIO m, MonadReader (ServerData n) m) => AppRequestable m where

230273 appRequest req = do

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

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

238281 getTasks = asks tasks >>= liftIO . readIORef

239282

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+

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

241349 getDockerUrl = asks dockerUrl

242350

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

245353data TaskConfig

246354 = TaskConfig

247355 { prebuild :: String,

248− dockerfile :: String

249− -- build :: T.Text

356+ dockerfile :: String,

357+ timeoutMinutes :: Int,

358+ deadline :: UTCTime

250359 }

251360 deriving stock (Show, Eq, Generic)

252361 deriving anyclass (FromJSON, ToJSON)

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

255364 getTasks :: m TasksConfig

256365

257366instance HasLog (ServerData m) Message m where

258−

259367 getLogAction :: ServerData m -> LogAction m Message

260368 getLogAction = logger

261369 {-# INLINE getLogAction #-}

src/Server/Config.hs+72−35

@@ -2,62 +2,99 @@

33module Server.Config

44 ( Config (..),

5+ defaultConfig,

56 getConfig,

67 )

78where

910import Colog

10−import Crypto.PubKey.RSA (PrivateKey)

1111import Crypto.PubKey.RSA.Read

12−import Data.ByteString as BS

13−import qualified Data.ByteString.Char8 as BS8

14−import Data.Maybe

12+import Data.Aeson as A

13+import Data.ByteString.Char8 as BS

14+import Data.Text as T

15+import Data.Yaml

16+import GHC.Generics

1517import GitHub.Data.Apps

1618import GitHub.Data.Id

1719import GitHub.Data.Installations

18−import System.Environment

20+import Text.Read (readMaybe)

1921

2022data Config

2123 = Config

2224 { webhookSecret :: !ByteString,

2325 appId :: !(Id App),

24− appPkPem :: !PrivateKey,

26+ appPkPemPath :: !FilePath,

2527 port :: !Int,

2628 installationId :: !(Id Installation),

27− personalAccessToken :: !String,

28− githubUsername :: !String,

2929 tasksPath :: !FilePath,

3030 databseUrl :: !ByteString,

31− baseSiteUrl :: !String,

31+ baseSiteUrl :: !Text,

3232 cfgDockerUrl :: !String,

33− cfgDockerFile :: !FilePath,

34− logSeverity :: !Severity

33+ logSeverity :: !Severity,

34+ builderCount :: !Int,

35+ githubContext :: !Text

3536 }

36− deriving (Show)

37+ deriving (Show, Generic)

3738

38−getConfig :: IO Config

39−getConfig =

39+instance FromJSON ByteString where

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

41+ parseJSON _ = fail "not a string"

42+

43+instance ToJSON ByteString where

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

45+

46+instance FromJSON Severity where

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

48+ parseJSON _ = fail "not a string"

49+

50+instance ToJSON Severity where

51+ toJSON = String . T.pack . show

52+

53+instance FromJSON Config

54+

55+instance ToJSON Config

56+

57+defaultConfig :: Config

58+defaultConfig =

4059 Config

41− <$> (maybe (error "no GITHUB_WEBHOOK_SECRET") BS8.pack <$> lookupEnv "GITHUB_WEBHOOK_SECRET")

42− <*> (maybe (error "no GITHUB_APP_ID") (Id . read) <$> lookupEnv "GITHUB_APP_ID")

43− <*> readPem

44− <*> (maybe 8080 read <$> lookupEnv "PORT")

45− <*> (maybe (error "no GITHUB_INSTALLATION_ID") (Id . read) <$> lookupEnv "GITHUB_INSTALLATION_ID")

46− <*> (fromMaybe (error "no PERSONAL_ACCESS_TOKEN") <$> lookupEnv "PERSONAL_ACCESS_TOKEN")

47− <*> (fromMaybe (error "no GITHUB_USERNAME") <$> lookupEnv "GITHUB_USERNAME")

48− <*> (fromMaybe (error "no TASKS") <$> lookupEnv "TASKS")

49− <*> (maybe (error "no DATABASE_URL") BS8.pack <$> lookupEnv "DATABASE_URL")

50− <*> (fromMaybe "http://localhost:8080" <$> lookupEnv "PORT")

51− <*> (fromMaybe "http://localhost:1234" <$> lookupEnv "DOCKER_URL")

52− <*> (fromMaybe "TmpDockerfile" <$> lookupEnv "DOCKER_FILE")

53− <*> (maybe Info read <$> lookupEnv "LOG_SEVERITY")

54− where

55− readPem :: IO PrivateKey

56− readPem = do

57− path <- fromMaybe (error "no app pk") <$> lookupEnv "GITHUB_APP_PK"

58− pem <- BS.readFile path

59− case readRsaPem pem of

60− Right k -> return k

61− Left e -> error (show e)

60+ { webhookSecret = "GITHUB SECRET",

61+ appId = Id 69,

62+ appPkPemPath = "PRIVATE KEY PATH",

63+ port = 8080,

64+ installationId = Id 69,

65+ tasksPath = "TASKS PATH",

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

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

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

69+ logSeverity = Info,

70+ builderCount = 2,

71+ githubContext = "MY CI NAME"

72+ }

73+

74+getConfig :: FilePath -> IO Config

75+getConfig = decodeFileThrow

76+

77+-- getConfig :: IO Config

78+-- getConfig =

79+-- Config

80+-- <$> (maybe (error "no GITHUB_WEBHOOK_SECRET") BS8.pack <$> lookupEnv "GITHUB_WEBHOOK_SECRET")

81+-- <*> (maybe (error "no GITHUB_APP_ID") (Id . read) <$> lookupEnv "GITHUB_APP_ID")

82+-- <*> readPem

83+-- <*> (maybe 8080 read <$> lookupEnv "PORT")

84+-- <*> (maybe (error "no GITHUB_INSTALLATION_ID") (Id . read) <$> lookupEnv "GITHUB_INSTALLATION_ID")

85+-- <*> (fromMaybe (error "no TASKS") <$> lookupEnv "TASKS")

86+-- <*> (maybe (error "no DATABASE_URL") BS8.pack <$> lookupEnv "DATABASE_URL")

87+-- <*> (fromMaybe "http://localhost:8080" <$> lookupEnv "PORT")

88+-- <*> (fromMaybe <$> lookupEnv "DOCKER_URL")

89+-- <*> (fromMaybe "TmpDockerfile" <$> lookupEnv "DOCKER_FILE")

90+-- <*> (maybe Info read <$> lookupEnv "LOG_SEVERITY")

91+-- where

92+-- readPem :: IO PrivateKey

93+-- readPem = do

94+-- path <- fromMaybe (error "no app pk") <$> lookupEnv "GITHUB_APP_PK"

95+-- pem <- BS.readFile path

96+-- case readRsaPem pem of

97+-- Right k -> return k

98+-- Left e -> error (show e)

6299

63100deriving instance Show ReadRsaKeyError

src/Server/Html.hs+14−13

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

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

13module Server.Html

24 ( getSubmissionR,

35 MonadHasBaseUrl (..),

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

810

911import Clay as C

1012import Colog

11−import Control.Monad.IO.Class

1213import Control.Monad.IO.Unlift

13−import Data.Aeson hiding (Success)

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

1514import Data.Foldable

1615import qualified Data.Map as M

1716import Data.String

1817import Data.Submission

1918import Data.Submission.Query

2019import qualified Data.Text as T

21−import GHC.Generics

2220import Server.Schema

2321import Squeal.PostgreSQL (Jsonb (..))

2422import Text.Blaze

@@ -32,24 +30,25 @@ getSubmissionR ::

3230 String ->

3331 String ->

3432 m Markup

35−getSubmissionR user repo sha = do

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

33+getSubmissionR user repo sha' = do

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

3735 let restartBuild = do

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

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

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

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

4139 Nothing ->

4240 return . ("Not found",) $

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

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

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

4543 H.h1 $ toHtml problem

4644 H.h2 $ toHtml userName

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

4746 case status of

4847 Jsonb BuildScheduled -> do

49− H.h3 "Waiting to build"

48+ H.h3 "Waiting to build ⌛"

5049 restartBuild

5150 Jsonb (SubmissionFailed err) -> do

52− H.h3 "Failed to build"

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

5352 restartBuild

5453 H.code . H.pre $ toHtml err

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

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

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

5857 H.h3 . toHtml $

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

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

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

6160 restartBuild

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

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

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

64+ Jsonb PastDeadline ->

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

6566 return . docTypeHtml $ do

6667 H.head $ do

6768 H.title $ toHtml titleText

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

9495 H.body inner

9596

9697class MonadHasBaseUrl m where

97− getBaseUrl :: m String

98+ getBaseUrl :: m T.Text

9899

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

100101getUrl fullName sha = do

101102 siteBase <- getBaseUrl

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

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

103104

104105redirectToSubmission ::

105106 (MonadHasBaseUrl m, Monad m) =>

src/Server/Schema.hs+3−1

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

66where

88import Server.Schema.V1

9+import Server.Schema.V2

910import Squeal.PostgreSQL

1011

1112type StaticPQ m = MonadPQ Schema m

1213

13−type Schema = SchemaV1

14+type Schema = SchemaV2

1415

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

1617migration =

1718 pureMigration schemaMigrationV1

19+ :>> pureMigration schemaMigrationV2

1820 :>> Done

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

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

1818 ]

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

2020 "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)

2223 ]

2324 ),

2425 "submissions"

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

3435 ]

3536

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

37−schemaMigrationV1 = Migration

38− { name = "v1",

39− up =

40− createTable

41− #tasks

42− ( notNullable text `as` #task

43− :* notNullable jsonb `as` #payload

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

53− :* notNullable jsonb `as` #status

38+schemaMigrationV1 =

39+ Migration

40+ { name = "v1",

41+ up =

42+ createTable

43+ #tasks

44+ ( notNullable text `as` #task

45+ :* notNullable jsonb `as` #payload

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

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

5448 )

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

56− >>> createIndexes,

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

58− }

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)

59+ >>> createIndexes,

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

61+ }

5962 where

6063 createIndexes :: Definition sch sch

6164 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:

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

4747 commit: 0bede85ab53eb8f953cf6f4e58a756a205e88e0b

4848- servant-github-webhook-0.4.2.0

49−- docker-0.6.0.3

5049- http-client-0.5.14

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

51+ commit: 5cfdc4d7facd7043f530bce4ce0f0c57c923b029

5152

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

5354# flags: {}

tasks.yaml+1

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

88 COPY . src

99 WORKDIR /src

1010 ENTRYPOINT stack test --fast

11+ timeoutMinutes: 10