master..33713bd · sc-build

git.iko.soy/sc-build

on 33713bd help sign in

21 files changed+294−694

since splitsnapshots

unifiedsplit

.gitignore−1

@@ -1,2 +1 @@

11.stack-work

2−*.cabal

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

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

1717library:

1818 source-dirs: src

1919 dependencies:

20− - http-client-tls

2120 - servant

2221 - servant-server

2322 - process

@@ -47,12 +46,6 @@ library:

4746 - blaze-markup

4847 - blaze-html

4948 - clay

50− - docker

51− - exceptions

52− - transformers

53− - cassava

54− - http-media

55− - utf8-string

5649

5750executables:

5851 sc-build-exe:

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

6457 - -with-rtsopts=-N

6558 dependencies:

6659 - sc-build

67− - bytestring

68− - yaml

69− - optparse-applicative

7060 sc-build-migrations:

7161 main: Main.hs

7262 source-dirs: migrations

sc-build.cabalnew file+103

@@ -0,0 +1,103 @@

1+cabal-version: 1.12

3+-- This file has been generated from package.yaml by hpack version 0.31.2.

4+--

5+-- see: https://github.com/sol/hpack

6+--

7+-- hash: bb953e6231fcc3939bfe085afcd3e792cbc40462461bbe4fb82ae69f1796be4c

9+name: sc-build

10+version: 0.1.0.0

11+category: Web

12+homepage: https://github.com/ilyakooo0/sc-build#readme

13+author: Ilya Kostyuchenko

14+maintainer: ilyakooo0@gmail.com

15+copyright: Ilya Kostyuchenko

16+license: BSD3

17+license-file: LICENSE

18+build-type: Simple

19+extra-source-files:

20+ README.md

21+

22+library

23+ exposed-modules:

24+ Control.AppRequestable

25+ Control.GithubCloner

26+ Control.Squeal

27+ Control.Task

28+ Control.Task.Scheduler

29+ Control.Task.Scheduler.Query

30+ Data.Submission

31+ Data.Submission.Query

32+ Data.Tasks.Build

33+ Data.Tasks.StatusUpdate

34+ Server

35+ Server.Config

36+ Server.Html

37+ Server.Schema

38+ Server.Schema.V1

39+ other-modules:

40+ Paths_sc_build

41+ hs-source-dirs:

42+ src

43+ default-extensions: AllowAmbiguousTypes ConstraintKinds DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuantifiedConstraints RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances

44+ build-depends:

45+ aeson

46+ , base >=4.7 && <5

47+ , blaze-html

48+ , blaze-markup

49+ , bytestring

50+ , clay

51+ , co-log

52+ , containers

53+ , cryptonite

54+ , directory

55+ , generics-sop

56+ , github

57+ , github-app

58+ , github-webhooks

59+ , mtl

60+ , process

61+ , random

62+ , servant

63+ , servant-blaze

64+ , servant-github-webhook

65+ , servant-server

66+ , squeal-postgresql

67+ , text

68+ , time

69+ , typed-process

70+ , unliftio

71+ , unliftio-core

72+ , vector

73+ , warp

74+ , yaml

75+ default-language: Haskell2010

76+

77+executable sc-build-exe

78+ main-is: Main.hs

79+ other-modules:

80+ Paths_sc_build

81+ hs-source-dirs:

82+ app

83+ default-extensions: AllowAmbiguousTypes ConstraintKinds DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuantifiedConstraints RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances

84+ ghc-options: -threaded -rtsopts -with-rtsopts=-N

85+ build-depends:

86+ base >=4.7 && <5

87+ , sc-build

88+ default-language: Haskell2010

89+

90+executable sc-build-migrations

91+ main-is: Main.hs

92+ other-modules:

93+ Paths_sc_build

94+ hs-source-dirs:

95+ migrations

96+ default-extensions: AllowAmbiguousTypes ConstraintKinds DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuantifiedConstraints RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances

97+ ghc-options: -threaded -rtsopts -with-rtsopts=-N

98+ build-depends:

99+ base >=4.7 && <5

100+ , bytestring

101+ , sc-build

102+ , squeal-postgresql

103+ default-language: Haskell2010

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

@@ -2,13 +2,10 @@ module Data.Submission

22 ( Submission (..),

33 SubmissionStatus (..),

44 TestResult (..),

5− Score (..),

65 )

76where

98import Data.Aeson

10−import Data.Csv

11−import Data.Int

129import Data.Map (Map)

1310import Data.Text (Text)

1411import GHC.Generics (Generic)

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

2926 = SubmissionRun TestResult

3027 | SubmissionFailed String

3128 | BuildScheduled

32− | PastDeadline

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

3430

3531newtype TestResult

@@ -38,10 +34,3 @@ newtype TestResult

3834 }

3935 deriving stock (Eq, Show, Generic)

4036 deriving anyclass (FromJSON, ToJSON)

41−

42−data Score

43− = Score

44− { userName :: String,

45− score :: Int64

46− }

47− deriving (Eq, Show, Generic, SOP.Generic, SOP.HasDatatypeInfo, ToRecord)

src/Data/Submission/Query.hs−14

@@ -4,7 +4,6 @@ module Data.Submission.Query

44 ( createSubmission,

55 updateSubmissionStatus,

66 getSubmission,

7− getResults,

87 )

98where

109

@@ -84,16 +83,3 @@ getSubmission repoFullName sha = do

8483 query

8584 (repoFullName, sha)

8685 >>= firstRow

87−

88−getResults ::

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

90− String ->

91− m [Score]

92−getResults task = do

93− let query :: Query_ Schema (Only String) Score

94− query = UnsafeQuery "select a.user_name as \"userName\", max(a.correct) as score from (select (select count(*) as correct from jsonb_each_text(submissions.status -> 'contents' -> 'tests') where value = 'true'), user_name from submissions where problem = $1) as a group by user_name"

95− dbRead (const $ return []) $

96− runQueryParams

97− query

98− (Only task)

99− >>= getRows

src/Data/Tasks/Build.hs+46−114

@@ -3,26 +3,24 @@

44module Data.Tasks.Build

55 ( Build (..),

6− HasDockerInfo (..),

76 )

87where

109import Colog

11−import Control.Concurrent

1210import Control.GithubCloner

13−import Control.HasGithubStatus

14−import Control.Monad.Except

11+import Control.Monad.IO.Class

1512import Control.Monad.IO.Unlift

1613import Control.Task

14+import Control.Task.Scheduler

1715import Data.Aeson hiding (Success)

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

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

17+import qualified Data.Map as M

2018import Data.String

2119import Data.Submission

2220import Data.Submission.Query

21+import Data.Tasks.StatusUpdate

2322import qualified Data.Text as T

2423import Data.Time.Clock.POSIX

25−import qualified Docker.Client as D

2624import GHC.Generics

2725import GitHub

2826import Server.Schema

@@ -30,32 +28,31 @@ import System.Directory

3028import System.Exit

3129import System.Process.Typed

3230import System.Random

33−import UnliftIO.Async

3431import UnliftIO.Exception

3532

3633data Build

3734 = Build

3835 { preProcessShell :: String,

39− dockerFile :: String,

36+ buildCommand :: String,

4037 owner :: Name Owner,

4138 repoName :: Name Repo,

42− sha :: Name Commit,

43− timeoutMinutes :: Int

39+ sha :: Name Commit

4440 }

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

4642

4743instance Task Build "build-repo" where

48− type

49− TaskMonad Build m =

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

44+

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

5146

5247 performTask Build {..} =

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

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

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

50+ sha' = T.unpack $ untagName sha

5451 cloneRepo fullRepoName sha' dir

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

5653 case shellCode of

5754 ExitFailure n -> do

58− let err = BS.toString shellErr

55+ let err = BS.unpack shellErr

5956 logError . T.pack $

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

6158 <> show sha

@@ -63,73 +60,13 @@ instance Task Build "build-repo" where

6360 <> show n

6461 <> " and error "

6562 <> err

66− scheduleFailedStatus err owner repoName sha

63+ scheduleTask erroredTask

6764 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

6865 ExitSuccess -> do

69− h <- liftIO D.defaultHttpHandler

70− dUrl <- getDockerUrl

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

83− imageName = T.pack dir

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

85− absDir <- liftIO $ makeAbsolute dir

86− let waitDockerForever cid =

87− D.waitContainer cid >>= \case

88− Left D.GenericDockerError {} -> waitDockerForever cid

89− a -> return a

90− cid <- runDocker . runExceptT $ do

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

130− case dockerRes of

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

132− let err = BS.toString buildErr

66+ (buildCode, buildOut, buildErr) <- readProcess . setWorkingDir dir . fromString $ buildCommand

67+ case buildCode of

68+ ExitFailure n -> do

69+ let err = BS.unpack buildErr

13370 logError . T.pack $

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

13572 <> show sha

@@ -137,43 +74,42 @@ instance Task Build "build-repo" where

13774 <> show n

13875 <> " and error "

13976 <> err

140− scheduleFailedStatus err owner repoName sha

77+ scheduleTask erroredTask

14178 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

142− (ExitSuccess, buildOut, _) ->

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

144− Left err' -> do

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

79+ ExitSuccess ->

80+ case decode buildOut of

81+ Nothing -> do

82+ let err = BS.unpack buildOut

14683 logError . T.pack $

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

14885 <> " at sha "

14986 <> show sha

15087 <> ": "

15188 <> err

152− scheduleFailedStatus err owner repoName sha

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

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

155− scheduleTestedStatus testResult owner repoName sha

89+ scheduleTask erroredTask

90+ updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

91+ Just testResult@TestResult {..} -> do

92+ let total = M.size tests

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

94+ description = T.pack $ show passed <> "/" <> show total

95+ status = statusTask NewStatus

96+ { newStatusState =

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

98+ newStatusTargetUrl = Nothing,

99+ newStatusDescription = Just description,

100+ newStatusContext = Nothing

101+ }

102+ scheduleTask status

156103 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

157104 return Success

158105 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

106+ statusTask = StatusUpdate owner repoName sha

107+ erroredTask = statusTask $ NewStatus

108+ { newStatusState = StatusError,

109+ newStatusTargetUrl = Nothing,

110+ newStatusDescription = Just "Build failed",

111+ newStatusContext = Nothing

112+ }

177113

178114createDir :: MonadIO m => m FilePath

179115createDir = do

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

183119

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

185121cloneRepo repoName sha path = do

186− InstallationToken token <- getGithubInstallationToken

122+ GithubAccessToken token <- getGithubAccessToken

123+ GithubUserName username <- getGithubUserName

187124 runProcess_ . setWorkingDir path . fromString $

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

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

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

190127 return ()

191128

@@ -194,8 +131,3 @@ getTmpDirName = liftIO $ do

194131 time :: Integer <- round <$> getPOSIXTime

195132 i <- randomIO @Int

196133 return $ show time <> "-" <> show i

197−

198−class HasDockerInfo m where

199− 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−182

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

24−import qualified Data.Csv as Csv

2519import Data.IORef

2620import Data.Map (Map)

2721import qualified Data.Map as M

@@ -30,18 +24,14 @@ import Data.Submission.Query

3024import Data.Tasks.Build

3125import Data.Tasks.StatusUpdate

3226import qualified Data.Text as T

33−import Data.Time.Clock

3427import Data.Yaml

3528import GHC.Generics

36−import GitHub hiding (Accept)

29+import GitHub

3730import GitHub.App.Auth

3831import GitHub.App.Request

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

4032import GitHub.Data.Name

4133import GitHub.Data.Webhooks.Events

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

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

44−import Network.HTTP.Media.MediaType

34+import GitHub.Data.Webhooks.Payload

4535import Network.Wai.Handler.Warp

4636import Servant

4737import Servant.GitHub.Webhook

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

5040import Server.Html

5141import Server.Schema

5242import Squeal.PostgreSQL

43+import System.IO

5344import Text.Blaze.Html

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

45+import UnliftIO.Exception (try)

5546

5647type API =

5748 "github-webhook"

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

5950 :> GitHubSignedReqBody '[JSON] InstallationEvent

6051 :> Post '[JSON] ()

6152 :<|> GitHubEvent '[ 'WebhookPushEvent]

62− :> GitHubSignedReqBody '[JSON] PushEvent

63− :> Post '[JSON] ()

53+ :> GitHubSignedReqBody '[JSON] PushEvent

54+ :> Post '[JSON] ()

6455 )

6556 :<|> "submission"

6657 :> Capture "user name" String

@@ -73,20 +64,18 @@ type API =

7364 :> Capture "sha" String

7465 :> "restart"

7566 :> Post '[HTML] Markup

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

7767

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

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

7969webhookInstallation _ ((), ev) =

80− logInfo . T.pack . show $ ev

70+ liftIO $ do

71+ print ev

72+ hFlush stdout

73+

74+pendingStatus :: NewStatus

75+pendingStatus = NewStatus StatusPending Nothing Nothing Nothing

8176

8277webhookPushEvent ::

83− ( StaticPQ m,

84− MonadReader (ServerData m) m,

85− MonadUnliftIO m,

86− HasTasks m,

87− MonadError ServerError m,

88− WithLog env Message m

89− ) =>

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

9079 RepoWebhookEvent ->

9180 ((), PushEvent) ->

9281 m ()

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

9483 let repo = evPushRepository ev

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

9685 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

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

87+ Just sha = evPushHeadSha ev

10188 tasks <- getTasks

10289 let task =

10390 M.lookupMax $

10491 M.takeWhileAntitone (repoName >) tasks

10592 case task of

10693 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

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

95+ createSubmission $

96+ Submission

97+ user

98+ (T.unpack fullRepoName)

99+ (T.unpack name)

100+ (T.unpack sha)

101+ (Jsonb BuildScheduled)

102+ scheduleTask $ Build prebuild build (N owner) (N repoName) (N sha)

103+ liftIO $ do

104+ print ev

105+ hFlush stdout

129106 _ -> return ()

130107

131108retestSubmission ::

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

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

133110 String ->

134111 String ->

135112 String ->

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

148125 M.takeWhileAntitone (repoName' >) tasks

149126 case task of

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

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

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

152129 updateSubmissionStatus fullRepoName sha BuildScheduled

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

130+ scheduleTask $ Build prebuild build (N owner') (N repoName') (N sha')

154131 _ -> return ()

155132 redirectToSubmission owner repoName sha

156133

@@ -168,62 +145,44 @@ newtype ServerM (schema :: SchemasType) a

168145 MonadUnliftIO

169146 )

170147

171−instance MonadError ServerError (ServerM schema) where

172− throwError = throwIO

173− catchError = catch

174−

175148server :: ServerT API (ServerM Schema)

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

149+server = (webhookInstallation :<|> webhookPushEvent) :<|> getSubmissionR :<|> retestSubmission

177150

178−runServer :: FilePath -> IO ()

179−runServer config = do

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

151+runServer :: IO ()

152+runServer = do

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

181154 print c

182− pem <- BS.readFile appPkPemPath

183− appPkPem <- case readRsaPem pem of

184− Right k -> return k

185− Left e -> error (show e)

186155 auth <- mkInstallationAuth (AppAuth appId appPkPem) installationId

187156 ts <- newIORef mempty

188157 pool <- createConnectionPool databseUrl 1 0.5 10

189158 _ <- forkIO $ do

190159 updateTasks ts tasksPath

191− threadDelay $ 5 * 60 * (10 ^ (6 :: Int))

160+ threadDelay $ 10 * 60 * (10 ^ (6 :: Int))

192161 let context =

193162 gitPolyHubKey (return webhookSecret)

194163 :. 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− }

164+ serverData = ServerData

165+ { githubAppAuth = auth,

166+ githubUserName = GithubUserName githubUsername,

167+ githubAccessToken = GithubAccessToken personalAccessToken,

168+ tasks = ts,

169+ logger = simpleMessageAction,

170+ baseUrl = baseSiteUrl

171+ }

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

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

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

175+ _ <-

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

216177 . usingConnectionPool pool

217178 . (`runReaderT` serverData)

218179 . unApp

219− . printingErrors

220− $ runTasks @'[Build] 1

180+ $ runTasks @'[Build] 1

221181 _ <-

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

223183 . usingConnectionPool pool

224184 . (`runReaderT` serverData)

225185 . unApp

226− . printingErrors

227186 $ runTasks @'[StatusUpdate] 5

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

229188 hoistServerWithContext

@@ -241,11 +200,11 @@ updateTasks ref path =

241200data ServerData m

242201 = ServerData

243202 { githubAppAuth :: !InstallationAuth,

203+ githubUserName :: !GithubUserName,

204+ githubAccessToken :: !GithubAccessToken,

244205 tasks :: IORef TasksConfig,

245206 logger :: LogAction m Message,

246− baseUrl :: T.Text,

247− dockerUrl :: T.Text,

248− context :: T.Text

207+ baseUrl :: String

249208 }

250209

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

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

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

257216 getContextEntry (PolyGitHubKey x :. _) = x

258217

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

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

219+

220+ getGithubAccessToken = asks githubAccessToken

221+

222+ getGithubUserName = asks githubUserName

271223

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

273225 appRequest req = do

@@ -280,82 +232,12 @@ instance MonadReader (ServerData n) m => MonadHasBaseUrl m where

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

281233 getTasks = asks tasks >>= liftIO . readIORef

282234

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−

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

349− getDockerUrl = asks dockerUrl

350−

351235type TasksConfig = Map T.Text TaskConfig

352236

353237data TaskConfig

354238 = TaskConfig

355239 { prebuild :: String,

356− dockerfile :: String,

357− timeoutMinutes :: Int,

358− deadline :: UTCTime

240+ build :: String

359241 }

360242 deriving stock (Show, Eq, Generic)

361243 deriving anyclass (FromJSON, ToJSON)

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

364246 getTasks :: m TasksConfig

365247

366248instance HasLog (ServerData m) Message m where

249+

367250 getLogAction :: ServerData m -> LogAction m Message

368251 getLogAction = logger

369252 {-# INLINE getLogAction #-}

@@ -371,11 +254,3 @@ instance HasLog (ServerData m) Message m where

371254 setLogAction :: LogAction m Message -> ServerData m -> ServerData m

372255 setLogAction newLogAction env = env {logger = newLogAction}

373256 {-# INLINE setLogAction #-}

374−

375−data CSV

376−

377−instance Accept CSV where

378− contentType Proxy = "text" // "csv"

379−

380−instance Csv.ToRecord a => MimeRender CSV [a] where

381− mimeRender Proxy = Csv.encode

src/Server/Config.hs+30−74

@@ -2,99 +2,55 @@

33module Server.Config

44 ( Config (..),

5− defaultConfig,

65 getConfig,

76 )

87where

10−import Colog

9+import Crypto.PubKey.RSA (PrivateKey)

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

11+import Data.ByteString as BS

12+import qualified Data.ByteString.Char8 as BS8

13+import Data.Maybe

1714import GitHub.Data.Apps

1815import GitHub.Data.Id

1916import GitHub.Data.Installations

20−import Text.Read (readMaybe)

17+import System.Environment

2118

2219data Config

2320 = Config

2421 { webhookSecret :: !ByteString,

2522 appId :: !(Id App),

26− appPkPemPath :: !FilePath,

23+ appPkPem :: !PrivateKey,

2724 port :: !Int,

2825 installationId :: !(Id Installation),

26+ personalAccessToken :: !String,

27+ githubUsername :: !String,

2928 tasksPath :: !FilePath,

3029 databseUrl :: !ByteString,

31− baseSiteUrl :: !Text,

32− cfgDockerUrl :: !String,

33− logSeverity :: !Severity,

34− builderCount :: !Int,

35− githubContext :: !Text

30+ baseSiteUrl :: !String

3631 }

37− deriving (Show, Generic)

32+ deriving (Show)

3833

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 =

34+getConfig :: IO Config

35+getConfig =

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

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

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

39+ <*> readPem

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

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

42+ <*> (fromMaybe (error "no PERSONAL_ACCESS_TOKEN") <$> lookupEnv "PERSONAL_ACCESS_TOKEN")

43+ <*> (fromMaybe (error "no GITHUB_USERNAME") <$> lookupEnv "GITHUB_USERNAME")

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

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

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

47+ where

48+ readPem :: IO PrivateKey

49+ readPem = do

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

51+ pem <- BS.readFile path

52+ case readRsaPem pem of

53+ Right k -> return k

54+ Left e -> error (show e)

9955

10056deriving instance Show ReadRsaKeyError

src/Server/Html.hs+13−49

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

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

2−

31module Server.Html

42 ( getSubmissionR,

53 MonadHasBaseUrl (..),

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

108

119import Clay as C

1210import Colog

11+import Control.Monad.IO.Class

1312import Control.Monad.IO.Unlift

14−import Data.Foldable

13+import Data.Aeson hiding (Success)

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

1515import qualified Data.Map as M

1616import Data.String

1717import Data.Submission

1818import Data.Submission.Query

1919import qualified Data.Text as T

20+import GHC.Generics

2021import Server.Schema

2122import Squeal.PostgreSQL (Jsonb (..))

2223import Text.Blaze

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

3031 String ->

3132 String ->

3233 m Markup

33−getSubmissionR user repo sha' = do

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

34+getSubmissionR user repo sha = do

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

3536 let restartBuild = do

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

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

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

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

3940 Nothing ->

4041 return . ("Not found",) $

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

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

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

4344 H.h1 $ toHtml problem

4445 H.h2 $ toHtml userName

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

4646 case status of

4747 Jsonb BuildScheduled -> do

48− H.h3 "Waiting to build ⌛"

48+ H.h3 "Waiting to build"

4949 restartBuild

5050 Jsonb (SubmissionFailed err) -> do

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

51+ H.h3 "Failed to build"

5252 restartBuild

5353 H.code . H.pre $ toHtml err

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

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

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

5757 H.h3 . toHtml $

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

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

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

6060 restartBuild

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

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

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

64− Jsonb PastDeadline ->

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

6664 return . docTypeHtml $ do

6765 H.head $ do

6866 H.title $ toHtml titleText

@@ -86,21 +84,18 @@ getSubmissionR user repo sha' = do

8684 C.td ? do

8785 C.padding (px 4) (px 4) (px 4) (px 4)

8886 C.form ? do

89− C.display C.block

90− C.width (pct 100)

91− C.input ? do

9287 C.display C.block

9388 C.marginLeft auto

9489 C.marginRight auto

9590 H.body inner

9691

9792class MonadHasBaseUrl m where

98− getBaseUrl :: m T.Text

93+ getBaseUrl :: m String

9994

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

10196getUrl fullName sha = do

10297 siteBase <- getBaseUrl

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

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

10499

105100redirectToSubmission ::

106101 (MonadHasBaseUrl m, Monad m) =>

@@ -114,34 +109,3 @@ redirectToSubmission user repo sha = do

114109 H.meta

115110 H.! A.httpEquiv "refresh"

116111 H.! A.content (fromString $ "0; URL=" <> rUrl)

117−

118−instance ToMarkup [Score] where

119− toMarkup xs = docTypeHtml $ do

120− H.style . preEscapedToHtml . render $ do

121− C.body ? do

122− fontFamily [] [sansSerif]

123− C.maxWidth (px 800)

124− C.display C.block

125− C.marginLeft auto

126− C.marginRight auto

127− C.paddingLeft (px 16)

128− C.paddingRight (px 16)

129− (C.h1 <> C.h2 <> C.h3) ? do

130− textAlign center

131− C.pre ? do

132− C.whiteSpace C.preWrap

133− (C.tr <> C.td) ? do

134− C.width (pct 50)

135− C.td ? do

136− C.padding (px 4) (px 4) (px 4) (px 4)

137− C.border solid (px 1) black

138− C.margin (px 0) (px 0) (px 0) (px 0)

139− C.table ? do

140− C.borderCollapse (other "collapse")

141− C.width (pct 100)

142− H.body

143− $ H.table

144− $ for_ xs

145− $ \(Score user score) -> H.tr $ do

146− (H.td H.! A.align "right") . H.code $ toHtml user

147− H.td $ toHtml score

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

@@ -17,7 +17,7 @@

1717#

1818# resolver: ./custom-snapshot.yaml

1919# resolver: https://example.com/snapshots/2018-01-01.yaml

20−resolver: lts-14.27

20+resolver: lts-14.19

2121

2222# User packages to be built.

2323# Various formats can be used as shown in the example below.

@@ -40,15 +40,12 @@ packages:

4040# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

4141#

4242extra-deps:

43−- github-0.25

43+- github-0.24

4444- binary-instances-1

4545- squeal-postgresql-0.5.2.0

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

4747 commit: 0bede85ab53eb8f953cf6f4e58a756a205e88e0b

4848- servant-github-webhook-0.4.2.0

49−- http-client-0.5.14

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

51− commit: 5cfdc4d7facd7043f530bce4ce0f0c57c923b029

5249

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

5451# flags: {}

tasks.yamldeleted−11

@@ -1,11 +0,0 @@

1−test-task:

2− prebuild: |

3− cp -f ../../test-task/package.yaml .

4− cp -f ../../test-task/stack.yaml .

5− cp -f -R ../../test-task/test .

6− dockerfile: |

7− FROM fast-lts-14.20

8− COPY . src

9− WORKDIR /src

10− ENTRYPOINT stack test --fast

11− timeoutMinutes: 10