master..f23e84c · sc-build

git.iko.soy/sc-build

18 files changed+214−575

unifiedsplit

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

README.mddeleted−64

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

11module Main (main) where

3−import qualified Data.ByteString.Char8 as BS

4−import Data.Yaml (encode)

5−import Options.Applicative

63import Server

7−import Server.Config

95main :: IO ()

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

6+main = runServer

package.yaml−5

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

1717library:

1818 source-dirs: src

1919 dependencies:

20− - http-client-tls

2120 - servant

2221 - servant-server

2322 - process

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

5251 - transformers

5352 - cassava

5453 - http-media

55− - utf8-string

5654

5755executables:

5856 sc-build-exe:

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

6462 - -with-rtsopts=-N

6563 dependencies:

6664 - sc-build

67− - bytestring

68− - yaml

69− - optparse-applicative

7065 sc-build-migrations:

7166 main: Main.hs

7267 source-dirs: migrations

src/Control/GithubCloner.hs+10−4

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

11module Control.GithubCloner

2− ( GithubCloner (..),

3− InstallationToken (..),

2+ ( GithubAccessToken (..),

3+ GithubUserName (..),

4+ GithubCloner (..),

45 )

56where

7−newtype InstallationToken = InstallationToken String

8+newtype GithubAccessToken = GithubAccessToken String

10+newtype GithubUserName = GithubUserName String

811

912class GithubCloner m where

10− getGithubInstallationToken :: m InstallationToken

13+

14+ getGithubAccessToken :: m GithubAccessToken

15+

16+ getGithubUserName :: m GithubUserName

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

33module Control.Task.Scheduler

44 ( scheduleTask,

55 runTasks,

6− makeAllRunnable,

76 )

87where

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

2120import GHC.TypeLits

2221import Server.Schema

2322import Squeal.PostgreSQL

24−import UnliftIO.Exception

2523

2624scheduleTask ::

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

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

4745rescheduleTaskTime = rescheduleTaskQuery

4846

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

48+

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

5150

5251 taskNames :: [String]

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

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

5756 RunTasks (t ': tt) m

5857 where

58+

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

6060 case fromJSON @t v of

6161 A.Error e ->

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

71− logError . T.pack . displayException $ e

72− return Failure

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

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

7472 case r of

7573 Success -> completeTaskQuery t

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

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

8280

8381instance RunTasks '[] m where

82+

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

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

8685

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

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

55 completeTaskQuery,

66 rescheduleTaskQuery,

77 pickTasksQuery,

8− makeAllRunnable,

98 PickedTask (..),

109 )

1110where

1211

1312import Colog

14−import Control.Arrow

1513import Control.Monad.IO.Unlift

1614import Control.Squeal

1715import Control.Task

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

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

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

4240 :* Default `as` #creation_time

43− :* Default `as` #started

44− :* Default `as` #failures

4541 )

4642 ( OnConflict

4743 (OnConstraint #pk_task_payload)

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

8682 query =

8783 update_

8884 #tasks

89− ( Default `as` #creation_time

90− :* Default `as` #started

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

92− )

85+ (Default `as` #creation_time)

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

9487 dbWrite (const $ return ()) $

9588 manipulateParams_

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

10396 Word64 ->

10497 m [PickedTask]

10598pickTasksQuery tasks limitCount = do

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

99+ logDebug "reading tasks"

107100 let query :: Query_ Schema () PickedTask

108101 query =

109102 select_

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

113106 )

114107 ( from (table #tasks)

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

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

117− & where_ (#failures .< 20)

118109 & orderBy [#creation_time & Asc]

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

127111 )

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

112+ dbRead (const $ return []) $

113+ runQuery query >>= getRows

133114

134115data PickedTask

135116 = PickedTask

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

138119 creationTime :: UTCTime

139120 }

140121 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

2929 = SubmissionRun TestResult

3030 | SubmissionFailed String

3131 | BuildScheduled

32− | PastDeadline

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

3433

3534newtype TestResult

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

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

88where

1010import Colog

11−import Control.Concurrent

1211import Control.GithubCloner

13−import Control.HasGithubStatus

1412import Control.Monad.Except

1513import Control.Monad.IO.Unlift

1614import Control.Task

15+import Control.Task.Scheduler

1716import Data.Aeson hiding (Success)

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

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

18+import qualified Data.Map as M

2019import Data.String

2120import Data.Submission

2221import 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,7 +30,6 @@ import System.Directory

3030import System.Exit

3131import System.Process.Typed

3232import System.Random

33−import UnliftIO.Async

3433import UnliftIO.Exception

3534

3635data Build

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

3938 dockerFile :: String,

4039 owner :: Name Owner,

4140 repoName :: Name Repo,

42− sha :: Name Commit,

43− timeoutMinutes :: Int

41+ sha :: Name Commit

4442 }

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

4644

4745instance Task Build "build-repo" where

48− type

49− TaskMonad Build m =

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

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

5147

5248 performTask Build {..} =

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

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

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

51+ sha' = T.unpack $ untagName sha

5452 cloneRepo fullRepoName sha' dir

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

5654 case shellCode of

5755 ExitFailure n -> do

58− let err = BS.toString shellErr

56+ let err = BS.unpack shellErr

5957 logError . T.pack $

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

6159 <> show sha

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

6361 <> show n

6462 <> " and error "

6563 <> err

66− scheduleFailedStatus err owner repoName sha

64+ scheduleTask erroredTask

6765 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

6866 ExitSuccess -> do

6967 h <- liftIO D.defaultHttpHandler

7068 dUrl <- getDockerUrl

7169 let opts = D.defaultCreateOpts imageName

72− runDocker ::

73− ( MonadIO m,

74− Exception err,

75− WithLog env Message m,

76− StaticPQ m,

77− MonadUnliftIO m,

78− HasGithubStatus m

79− ) =>

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

81− m a

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

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

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

8372 imageName = T.pack dir

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

8574 absDir <- liftIO $ makeAbsolute dir

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

8776 D.waitContainer cid >>= \case

8877 Left D.GenericDockerError {} -> waitDockerForever cid

8978 a -> return a

90− cid <- runDocker . runExceptT $ do

79+ dockerRes <- runDocker . runExceptT $ do

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

92− ExceptT $ D.createContainer opts Nothing

93− dockerRes <- fmap (either id id)

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

95− $ flip

96− finally

97− ( runDocker $

98− D.deleteContainer

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

100− cid

101− )

102− . runDocker

103− . runExceptT

104− $ do

105− ExceptT $ D.startContainer D.defaultStartOpts cid

106− buildCode <- ExceptT $ waitDockerForever cid

107− buildOut <-

108− ExceptT $

109− D.getContainerLogs

110− D.LogOpts

111− { stdout = True,

112− stderr = False,

113− since = Nothing,

114− timestamps = False,

115− tail = D.All

116− }

117− cid

118− buildErr <-

119− ExceptT $

120− D.getContainerLogs

121− D.LogOpts

122− { stdout = True,

123− stderr = True,

124− since = Nothing,

125− timestamps = False,

126− tail = D.All

127− }

128− cid

129− return (buildCode, buildOut, buildErr)

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)

13096 case dockerRes of

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

132− let err = BS.toString buildErr

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

98+ let err = BS.unpack buildOut

13399 logError . T.pack $

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

135101 <> show sha

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

137103 <> show n

138104 <> " and error "

139105 <> err

140− scheduleFailedStatus err owner repoName sha

106+ scheduleTask erroredTask

141107 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

142− (ExitSuccess, buildOut, _) ->

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

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

144115 Left err' -> do

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

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

146117 logError . T.pack $

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

148119 <> " at sha "

149120 <> show sha

150121 <> ": "

151122 <> err

152− scheduleFailedStatus err owner repoName sha

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

123+ scheduleTask erroredTask

124+ updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

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

155− scheduleTestedStatus testResult owner repoName sha

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

156139 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

157140 return Success

158141 where

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

160− sha' = T.unpack $ untagName sha

161− runEither ::

162− ( Exception err,

163− WithLog env Message m,

164− StaticPQ m,

165− MonadUnliftIO m,

166− HasGithubStatus m

167− ) =>

168− Either err b ->

169− m b

170− runEither (Left err) = do

171− let err' = show err

172− logError $ T.pack err'

173− scheduleFailedStatus err' owner repoName sha

174− updateSubmissionStatus fullRepoName sha' (SubmissionFailed err')

175− throwIO err

176− runEither (Right a) = return a

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

177151

178152createDir :: MonadIO m => m FilePath

179153createDir = do

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

183157

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

185159cloneRepo repoName sha path = do

186− InstallationToken token <- getGithubInstallationToken

160+ GithubAccessToken token <- getGithubAccessToken

161+ GithubUserName username <- getGithubUserName

187162 runProcess_ . setWorkingDir path . fromString $

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

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

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

190165 return ()

191166

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

197172

198173class HasDockerInfo m where

199174 getDockerUrl :: m T.Text

200−

201−instance Exception D.DockerError

src/Data/Tasks/StatusUpdate.hs+1

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

3131 <*> v .:? "context"

3232

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

34+

3435 type TaskMonad StatusUpdate m = (AppRequestable m)

3536

3637 performTask StatusUpdate {..} = do

src/Server.hs+57−165

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

1010import Control.AppRequestable

1111import Control.Concurrent

1212import Control.GithubCloner

13−import Control.HasGithubStatus

1413import Control.Monad.Except

1514import Control.Monad.IO.Unlift

1615import Control.Monad.Reader

1716import Control.Task.Scheduler

18−import Crypto.PubKey.RSA.Read

1917import Data.Aeson

2018import 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

2419import qualified Data.Csv as Csv

2520import Data.IORef

2621import Data.Map (Map)

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

3025import Data.Tasks.Build

3126import Data.Tasks.StatusUpdate

3227import qualified Data.Text as T

33−import Data.Time.Clock

3428import Data.Yaml

3529import GHC.Generics

3630import GitHub hiding (Accept)

3731import GitHub.App.Auth

3832import GitHub.App.Request

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

4033import GitHub.Data.Name

4134import GitHub.Data.Webhooks.Events

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

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

35+import GitHub.Data.Webhooks.Payload

4436import Network.HTTP.Media.MediaType

4537import Network.Wai.Handler.Warp

4638import Servant

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

5042import Server.Html

5143import Server.Schema

5244import Squeal.PostgreSQL

45+import System.IO

5346import Text.Blaze.Html

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

47+import UnliftIO.Exception (try)

5548

5649type API =

5750 "github-webhook"

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

5952 :> GitHubSignedReqBody '[JSON] InstallationEvent

6053 :> Post '[JSON] ()

6154 :<|> GitHubEvent '[ 'WebhookPushEvent]

62− :> GitHubSignedReqBody '[JSON] PushEvent

63− :> Post '[JSON] ()

55+ :> GitHubSignedReqBody '[JSON] PushEvent

56+ :> Post '[JSON] ()

6457 )

6558 :<|> "submission"

6659 :> Capture "user name" String

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

7568 :> Post '[HTML] Markup

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

7770

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

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

7972webhookInstallation _ ((), ev) =

80− logInfo . T.pack . show $ ev

73+ liftIO $ do

74+ print ev

75+ hFlush stdout

76+

77+pendingStatus :: NewStatus

78+pendingStatus = NewStatus StatusPending Nothing Nothing Nothing

8179

8280webhookPushEvent ::

83− ( StaticPQ m,

84− MonadReader (ServerData m) m,

85− MonadUnliftIO m,

86− HasTasks m,

87− MonadError ServerError m,

88− WithLog env Message m

89− ) =>

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

9082 RepoWebhookEvent ->

9183 ((), PushEvent) ->

9284 m ()

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

9486 let repo = evPushRepository ev

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

9688 fullRepoName = whRepoFullName repo

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

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

90+ Just sha = evPushHeadSha ev

10191 tasks <- getTasks

10292 let task =

10393 M.lookupMax $

10494 M.takeWhileAntitone (repoName >) tasks

10595 case task of

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

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

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

129109 _ -> return ()

130110

131111retestSubmission ::

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

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

133113 String ->

134114 String ->

135115 String ->

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

148128 M.takeWhileAntitone (repoName' >) tasks

149129 case task of

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

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

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

152132 updateSubmissionStatus fullRepoName sha BuildScheduled

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

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

154134 _ -> return ()

155135 redirectToSubmission owner repoName sha

156136

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

168148 MonadUnliftIO

169149 )

170150

171−instance MonadError ServerError (ServerM schema) where

172− throwError = throwIO

173− catchError = catch

174−

175151server :: ServerT API (ServerM Schema)

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

177153

178−runServer :: FilePath -> IO ()

179−runServer config = do

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

154+runServer :: IO ()

155+runServer = do

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

181157 print c

182− pem <- BS.readFile appPkPemPath

183− appPkPem <- case readRsaPem pem of

184− Right k -> return k

185− Left e -> error (show e)

186158 auth <- mkInstallationAuth (AppAuth appId appPkPem) installationId

187159 ts <- newIORef mempty

188160 pool <- createConnectionPool databseUrl 1 0.5 10

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

192164 let context =

193165 gitPolyHubKey (return webhookSecret)

194166 :. EmptyContext

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

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

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

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

206178 repeatIfNotEmpty n f

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

179+ _ <-

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

216181 . usingConnectionPool pool

217182 . (`runReaderT` serverData)

218183 . unApp

219− . printingErrors

220− $ runTasks @'[Build] 1

184+ $ runTasks @'[Build] 1

221185 _ <-

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

223187 . usingConnectionPool pool

224188 . (`runReaderT` serverData)

225189 . unApp

226− . printingErrors

227190 $ runTasks @'[StatusUpdate] 5

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

229192 hoistServerWithContext

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

241204data ServerData m

242205 = ServerData

243206 { githubAppAuth :: !InstallationAuth,

207+ githubUserName :: !GithubUserName,

208+ githubAccessToken :: !GithubAccessToken,

244209 tasks :: IORef TasksConfig,

245210 logger :: LogAction m Message,

246− baseUrl :: T.Text,

247− dockerUrl :: T.Text,

248− context :: T.Text

211+ baseUrl :: String,

212+ dockerUrl :: T.Text

249213 }

250214

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

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

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

257221 getContextEntry (PolyGitHubKey x :. _) = x

258222

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."

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

224+

225+ getGithubAccessToken = asks githubAccessToken

226+

227+ getGithubUserName = asks githubUserName

271228

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

273230 appRequest req = do

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

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

281238 getTasks = asks tasks >>= liftIO . readIORef

282239

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−

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

349241 getDockerUrl = asks dockerUrl

350242

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

353245data TaskConfig

354246 = TaskConfig

355247 { prebuild :: String,

356− dockerfile :: String,

357− timeoutMinutes :: Int,

358− deadline :: UTCTime

248+ dockerfile :: String

249+ -- build :: T.Text

359250 }

360251 deriving stock (Show, Eq, Generic)

361252 deriving anyclass (FromJSON, ToJSON)

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

364255 getTasks :: m TasksConfig

365256

366257instance HasLog (ServerData m) Message m where

258+

367259 getLogAction :: ServerData m -> LogAction m Message

368260 getLogAction = logger

369261 {-# INLINE getLogAction #-}

src/Server/Config.hs+35−72

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

33module Server.Config

44 ( Config (..),

5− defaultConfig,

65 getConfig,

76 )

87where

109import Colog

10+import Crypto.PubKey.RSA (PrivateKey)

1111import Crypto.PubKey.RSA.Read

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

12+import Data.ByteString as BS

13+import qualified Data.ByteString.Char8 as BS8

14+import Data.Maybe

1715import GitHub.Data.Apps

1816import GitHub.Data.Id

1917import GitHub.Data.Installations

20−import Text.Read (readMaybe)

18+import System.Environment

2119

2220data Config

2321 = Config

2422 { webhookSecret :: !ByteString,

2523 appId :: !(Id App),

26− appPkPemPath :: !FilePath,

24+ appPkPem :: !PrivateKey,

2725 port :: !Int,

2826 installationId :: !(Id Installation),

27+ personalAccessToken :: !String,

28+ githubUsername :: !String,

2929 tasksPath :: !FilePath,

3030 databseUrl :: !ByteString,

31− baseSiteUrl :: !Text,

31+ baseSiteUrl :: !String,

3232 cfgDockerUrl :: !String,

33− logSeverity :: !Severity,

34− builderCount :: !Int,

35− githubContext :: !Text

33+ cfgDockerFile :: !FilePath,

34+ logSeverity :: !Severity

3635 }

37− deriving (Show, Generic)

36+ deriving (Show)

3837

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 =

38+getConfig :: IO Config

39+getConfig =

5940 Config

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)

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)

9962

10063deriving instance Show ReadRsaKeyError

src/Server/Html.hs+13−14

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

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

2−

31module Server.Html

42 ( getSubmissionR,

53 MonadHasBaseUrl (..),

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

108

119import Clay as C

1210import Colog

11+import Control.Monad.IO.Class

1312import Control.Monad.IO.Unlift

13+import Data.Aeson hiding (Success)

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

1415import Data.Foldable

1516import qualified Data.Map as M

1617import Data.String

1718import Data.Submission

1819import Data.Submission.Query

1920import qualified Data.Text as T

21+import GHC.Generics

2022import Server.Schema

2123import Squeal.PostgreSQL (Jsonb (..))

2224import Text.Blaze

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

3032 String ->

3133 String ->

3234 m Markup

33−getSubmissionR user repo sha' = do

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

35+getSubmissionR user repo sha = do

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

3537 let restartBuild = do

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

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

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

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

3941 Nothing ->

4042 return . ("Not found",) $

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

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

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

4345 H.h1 $ toHtml problem

4446 H.h2 $ toHtml userName

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

4647 case status of

4748 Jsonb BuildScheduled -> do

48− H.h3 "Waiting to build ⌛"

49+ H.h3 "Waiting to build"

4950 restartBuild

5051 Jsonb (SubmissionFailed err) -> do

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

52+ H.h3 "Failed to build"

5253 restartBuild

5354 H.code . H.pre $ toHtml err

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

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

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

5758 H.h3 . toHtml $

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

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

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

6061 restartBuild

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

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

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

64− Jsonb PastDeadline ->

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

6665 return . docTypeHtml $ do

6766 H.head $ do

6867 H.title $ toHtml titleText

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

9594 H.body inner

9695

9796class MonadHasBaseUrl m where

98− getBaseUrl :: m T.Text

97+ getBaseUrl :: m String

9998

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

101100getUrl fullName sha = do

102101 siteBase <- getBaseUrl

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

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

104103

105104redirectToSubmission ::

106105 (MonadHasBaseUrl m, Monad m) =>

src/Server/Schema.hs+1−3

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

66where

88import Server.Schema.V1

9−import Server.Schema.V2

109import Squeal.PostgreSQL

1110

1211type StaticPQ m = MonadPQ Schema m

1312

14−type Schema = SchemaV2

13+type Schema = SchemaV1

1514

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

1716migration =

1817 pureMigration schemaMigrationV1

19− :>> pureMigration schemaMigrationV2

2018 :>> Done

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

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

1818 ]

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

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

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

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

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

2322 ]

2423 ),

2524 "submissions"

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

3534 ]

3635

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

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

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

4854 )

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

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

56+ >>> createIndexes,

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

58+ }

6259 where

6360 createIndexes :: Definition sch sch

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

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

4950- http-client-0.5.14

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

51− commit: 5cfdc4d7facd7043f530bce4ce0f0c57c923b029

5251

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

5453# flags: {}

tasks.yaml−1

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

88 COPY . src

99 WORKDIR /src

1010 ENTRYPOINT stack test --fast

11− timeoutMinutes: 10