0b85829...master · sc-build

git.iko.soy/sc-build

on master help sign in

21 files changed+653−319

since splitsnapshots

unifiedsplit

.gitignore+1

@@ -1 +1,2 @@

11.stack-work

2+*.cabal

README.mdnew file+64

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

1+# sc-build

3+Need both manual weebohook and app.

5+Installation id needs to be configured manually.

7+## Usage

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

10+

11+

12+Exmaple:

13+

14+```dockerfile

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

16+

17+RUN stack update

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

19+

20+WORKDIR /

21+```

22+

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

24+

25+```bash

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

27+```

28+

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

30+

31+```yaml

32+test-task:

33+ prebuild: |

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

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

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

37+ dockerfile: |

38+ FROM fast-lts-14.27

39+ COPY . src

40+ WORKDIR /src

41+ ENTRYPOINT stack test --fast

42+ timeoutMinutes: 10

43+```

44+

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

46+

47+```json

48+{

49+ "test1": true,

50+ "test2": false

51+}

52+```

53+

54+For macos docker API:

55+

56+```bash

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

58+```

59+

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

61+

62+```bash

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

64+```

app/Main.hs+25−1

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

11module Main (main) where

3+import qualified Data.ByteString.Char8 as BS

4+import Data.Yaml (encode)

5+import Options.Applicative

36import Server

7+import Server.Config

59main :: IO ()

6−main = runServer

10+main =

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

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

13+ RunServer config -> runServer config

14+

15+data Run

16+ = PrintDefaultConfig

17+ | RunServer FilePath

18+

19+getOptions :: Parser Run

20+getOptions =

21+ subparser

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

23+ )

24+ <|> ( RunServer

25+ <$> strOption

26+ ( long "config"

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

28+ <> value "config.yaml"

29+ )

30+ )

package.yaml+7

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

1717library:

1818 source-dirs: src

1919 dependencies:

20+ - http-client-tls

2021 - servant

2122 - servant-server

2223 - process

@@ -49,6 +50,9 @@ library:

4950 - docker

5051 - exceptions

5152 - transformers

53+ - cassava

54+ - http-media

55+ - utf8-string

5256

5357executables:

5458 sc-build-exe:

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

6064 - -with-rtsopts=-N

6165 dependencies:

6266 - sc-build

67+ - bytestring

68+ - yaml

69+ - optparse-applicative

6370 sc-build-migrations:

6471 main: Main.hs

6572 source-dirs: migrations

sc-build.cabaldeleted−106

@@ -1,106 +0,0 @@

1−cabal-version: 1.12

2−

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: 56eccc7f4958f234614ddcff75d3b965ad9a29747591e1e71b73d56faaf48d1c

8−

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− , docker

56− , exceptions

57− , generics-sop

58− , github

59− , github-app

60− , github-webhooks

61− , mtl

62− , process

63− , random

64− , servant

65− , servant-blaze

66− , servant-github-webhook

67− , servant-server

68− , squeal-postgresql

69− , text

70− , time

71− , transformers

72− , typed-process

73− , unliftio

74− , unliftio-core

75− , vector

76− , warp

77− , yaml

78− default-language: Haskell2010

79−

80−executable sc-build-exe

81− main-is: Main.hs

82− other-modules:

83− Paths_sc_build

84− hs-source-dirs:

85− app

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

87− ghc-options: -threaded -rtsopts -with-rtsopts=-N

88− build-depends:

89− base >=4.7 && <5

90− , sc-build

91− default-language: Haskell2010

92−

93−executable sc-build-migrations

94− main-is: Main.hs

95− other-modules:

96− Paths_sc_build

97− hs-source-dirs:

98− migrations

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

100− ghc-options: -threaded -rtsopts -with-rtsopts=-N

101− build-depends:

102− base >=4.7 && <5

103− , bytestring

104− , sc-build

105− , squeal-postgresql

106− default-language: Haskell2010

src/Control/GithubCloner.hs+4−10

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

11module Control.GithubCloner

2− ( GithubAccessToken (..),

3− GithubUserName (..),

4− GithubCloner (..),

2+ ( GithubCloner (..),

3+ InstallationToken (..),

54 )

65where

8−newtype GithubAccessToken = GithubAccessToken String

9−

10−newtype GithubUserName = GithubUserName String

7+newtype InstallationToken = InstallationToken String

118

129class GithubCloner m where

13−

14− getGithubAccessToken :: m GithubAccessToken

15−

16− getGithubUserName :: m GithubUserName

10+ getGithubInstallationToken :: m InstallationToken

src/Control/HasGithubStatus.hsnew file+14

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

1+module Control.HasGithubStatus

2+ ( HasGithubStatus (..),

3+ )

4+where

6+import Colog

7+import Data.Submission

8+import GitHub.Data

10+class HasGithubStatus m where

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

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

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

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

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

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

33module Control.Task.Scheduler

44 ( scheduleTask,

55 runTasks,

6+ makeAllRunnable,

67 )

78where

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

2021import GHC.TypeLits

2122import Server.Schema

2223import Squeal.PostgreSQL

24+import UnliftIO.Exception

2325

2426scheduleTask ::

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

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

4547rescheduleTaskTime = rescheduleTaskQuery

4648

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

48−

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

5051

5152 taskNames :: [String]

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

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

5657 RunTasks (t ': tt) m

5758 where

58−

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

6060 case fromJSON @t v of

6161 A.Error e ->

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

6767 <> e

6868 A.Success t -> do

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

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

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

71+ logError . T.pack . displayException $ e

72+ return Failure

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

7274 case r of

7375 Success -> completeTaskQuery t

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

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

8082

8183instance RunTasks '[] m where

82−

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

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

8586

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

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

55 completeTaskQuery,

66 rescheduleTaskQuery,

77 pickTasksQuery,

8+ makeAllRunnable,

89 PickedTask (..),

910 )

1011where

1112

1213import Colog

14+import Control.Arrow

1315import Control.Monad.IO.Unlift

1416import Control.Squeal

1517import Control.Task

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

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

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

4042 :* Default `as` #creation_time

43+ :* Default `as` #started

44+ :* Default `as` #failures

4145 )

4246 ( OnConflict

4347 (OnConstraint #pk_task_payload)

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

8286 query =

8387 update_

8488 #tasks

85− (Default `as` #creation_time)

89+ ( Default `as` #creation_time

90+ :* Default `as` #started

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

92+ )

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

8794 dbWrite (const $ return ()) $

8895 manipulateParams_

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

96103 Word64 ->

97104 m [PickedTask]

98105pickTasksQuery tasks limitCount = do

99− logDebug "reading tasks"

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

100107 let query :: Query_ Schema () PickedTask

101108 query =

102109 select_

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

106113 )

107114 ( from (table #tasks)

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

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

117+ & where_ (#failures .< 20)

109118 & orderBy [#creation_time & Asc]

110119 & limit limitCount

120+ & orderBy [#creation_time & Desc]

121+ )

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

123+ startedMan =

124+ update_

125+ #tasks

126+ ( Set true `as` #started

111127 )

112− dbRead (const $ return []) $

113− runQuery query >>= getRows

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

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

130+ pickedTasks <- runQuery query >>= getRows

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

132+ return pickedTasks

114133

115134data PickedTask

116135 = PickedTask

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

119138 creationTime :: UTCTime

120139 }

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

141+

142+makeAllRunnable ::

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

144+ m ()

145+makeAllRunnable = do

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

147+ startAll =

148+ update_

149+ #tasks

150+ ( Set false `as` #started

151+ )

152+ (notNull #started)

153+ dbWrite (const $ return ()) $

154+ manipulate_ startAll

src/Data/Submission.hs+11

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

22 ( Submission (..),

33 SubmissionStatus (..),

44 TestResult (..),

5+ Score (..),

56 )

67where

89import Data.Aeson

10+import Data.Csv

11+import Data.Int

912import Data.Map (Map)

1013import Data.Text (Text)

1114import GHC.Generics (Generic)

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

2629 = SubmissionRun TestResult

2730 | SubmissionFailed String

2831 | BuildScheduled

32+ | PastDeadline

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

3034

3135newtype TestResult

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

3438 }

3539 deriving stock (Eq, Show, Generic)

3640 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,6 +4,7 @@ module Data.Submission.Query

44 ( createSubmission,

55 updateSubmissionStatus,

66 getSubmission,

7+ getResults,

78 )

89where

910

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

8384 query

8485 (repoFullName, sha)

8586 >>= 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+92−62

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

88where

1010import Colog

11+import Control.Concurrent

1112import Control.GithubCloner

13+import Control.HasGithubStatus

1214import Control.Monad.Except

1315import Control.Monad.IO.Unlift

1416import Control.Task

15−import Control.Task.Scheduler

1617import Data.Aeson hiding (Success)

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

18−import qualified Data.Map as M

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

1920import Data.String

2021import Data.Submission

2122import Data.Submission.Query

22−import Data.Tasks.StatusUpdate

2323import qualified Data.Text as T

2424import Data.Time.Clock.POSIX

2525import qualified Docker.Client as D

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

3030import System.Exit

3131import System.Process.Typed

3232import System.Random

33+import UnliftIO.Async

3334import UnliftIO.Exception

3435

3536data Build

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

3839 dockerFile :: String,

3940 owner :: Name Owner,

4041 repoName :: Name Repo,

41− sha :: Name Commit

42+ sha :: Name Commit,

43+ timeoutMinutes :: Int

4244 }

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

4446

4547instance Task Build "build-repo" where

46−

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

48+ type

49+ TaskMonad Build m =

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

4851

4952 performTask Build {..} =

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

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

52− sha' = T.unpack $ untagName sha

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

5354 cloneRepo fullRepoName sha' dir

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

5556 case shellCode of

5657 ExitFailure n -> do

57− let err = BS.unpack shellErr

58+ let err = BS.toString shellErr

5859 logError . T.pack $

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

6061 <> show sha

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

6263 <> show n

6364 <> " and error "

6465 <> err

65− scheduleTask erroredTask

66+ scheduleFailedStatus err owner repoName sha

6667 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

6768 ExitSuccess -> do

6869 h <- liftIO D.defaultHttpHandler

6970 dUrl <- getDockerUrl

7071 let opts = D.defaultCreateOpts imageName

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

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

72+ runDocker ::

73+ ( MonadIO m,

74+ Exception err,

75+ WithLog env Message m,

76+ StaticPQ m,

77+ MonadUnliftIO m,

78+ HasGithubStatus m

79+ ) =>

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

81+ m a

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

7383 imageName = T.pack dir

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

7585 absDir <- liftIO $ makeAbsolute dir

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

7787 D.waitContainer cid >>= \case

7888 Left D.GenericDockerError {} -> waitDockerForever cid

7989 a -> return a

80− dockerRes <- runDocker . runExceptT $ do

90+ cid <- runDocker . runExceptT $ do

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

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

83− ExceptT $ D.startContainer D.defaultStartOpts cid

84− buildCode <- ExceptT $ waitDockerForever cid

85− buildOut <-

86− ExceptT $

87− D.getContainerLogs

88− D.LogOpts

89− { stdout = True,

90− stderr = False,

91− since = Nothing,

92− timestamps = False,

93− tail = D.All

94− }

95− cid

96− return (buildCode, buildOut)

92+ ExceptT $ D.createContainer opts Nothing

93+ dockerRes <- fmap (either id id)

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

95+ $ flip

96+ finally

97+ ( runDocker $

98+ D.deleteContainer

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

100+ cid

101+ )

102+ . runDocker

103+ . runExceptT

104+ $ do

105+ ExceptT $ D.startContainer D.defaultStartOpts cid

106+ buildCode <- ExceptT $ waitDockerForever cid

107+ buildOut <-

108+ ExceptT $

109+ D.getContainerLogs

110+ D.LogOpts

111+ { stdout = True,

112+ stderr = False,

113+ since = Nothing,

114+ timestamps = False,

115+ tail = D.All

116+ }

117+ cid

118+ buildErr <-

119+ ExceptT $

120+ D.getContainerLogs

121+ D.LogOpts

122+ { stdout = True,

123+ stderr = True,

124+ since = Nothing,

125+ timestamps = False,

126+ tail = D.All

127+ }

128+ cid

129+ return (buildCode, buildOut, buildErr)

97130 case dockerRes of

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

99− let err = BS.unpack buildOut

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

132+ let err = BS.toString buildErr

100133 logError . T.pack $

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

102135 <> show sha

@@ -104,47 +137,43 @@ instance Task Build "build-repo" where

104137 <> show n

105138 <> " and error "

106139 <> err

107− scheduleTask erroredTask

108− updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

109− Left err' -> do

110− let err = show err'

111− logError . T.pack $ err

112− scheduleTask erroredTask

140+ scheduleFailedStatus err owner repoName sha

113141 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

114− Right (ExitSuccess, buildOut) ->

142+ (ExitSuccess, buildOut, _) ->

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

116144 Left err' -> do

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

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

118146 logError . T.pack $

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

120148 <> " at sha "

121149 <> show sha

122150 <> ": "

123151 <> err

124− scheduleTask erroredTask

125− updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

152+ scheduleFailedStatus err owner repoName sha

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

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

127− let total = M.size tests

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

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

130− status = statusTask NewStatus

131− { newStatusState =

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

133− newStatusTargetUrl = Nothing,

134− newStatusDescription = Just description,

135− newStatusContext = Nothing

136− }

137− scheduleTask status

155+ scheduleTestedStatus testResult owner repoName sha

138156 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

139157 return Success

140158 where

141− statusTask = StatusUpdate owner repoName sha

142− erroredTask = statusTask $ NewStatus

143− { newStatusState = StatusError,

144− newStatusTargetUrl = Nothing,

145− newStatusDescription = Just "Build failed",

146− newStatusContext = Nothing

147− }

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

148177

149178createDir :: MonadIO m => m FilePath

150179createDir = do

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

154183

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

156185cloneRepo repoName sha path = do

157− GithubAccessToken token <- getGithubAccessToken

158− GithubUserName username <- getGithubUserName

186+ InstallationToken token <- getGithubInstallationToken

159187 runProcess_ . setWorkingDir path . fromString $

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

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

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

162190 return ()

163191

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

169197

170198class HasDockerInfo m where

171199 getDockerUrl :: m T.Text

200+

201+instance Exception D.DockerError

src/Data/Tasks/StatusUpdate.hs−1

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

3131 <*> v .:? "context"

3232

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

34−

3534 type TaskMonad StatusUpdate m = (AppRequestable m)

3635

3736 performTask StatusUpdate {..} = do

src/Server.hs+178−59

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

1010import Control.AppRequestable

1111import Control.Concurrent

1212import Control.GithubCloner

13+import Control.HasGithubStatus

1314import Control.Monad.Except

1415import Control.Monad.IO.Unlift

1516import Control.Monad.Reader

1617import Control.Task.Scheduler

18+import Crypto.PubKey.RSA.Read

1719import Data.Aeson

1820import Data.ByteString

21+import qualified Data.ByteString as BS

22+import qualified Data.ByteString.Char8 as BSC

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

24+import qualified Data.Csv as Csv

1925import Data.IORef

2026import Data.Map (Map)

2127import qualified Data.Map as M

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

2430import Data.Tasks.Build

2531import Data.Tasks.StatusUpdate

2632import qualified Data.Text as T

33+import Data.Time.Clock

2734import Data.Yaml

2835import GHC.Generics

29−import GitHub

36+import GitHub hiding (Accept)

3037import GitHub.App.Auth

3138import GitHub.App.Request

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

3240import GitHub.Data.Name

3341import GitHub.Data.Webhooks.Events

34−import GitHub.Data.Webhooks.Payload

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

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

44+import Network.HTTP.Media.MediaType

3545import Network.Wai.Handler.Warp

3646import Servant

3747import Servant.GitHub.Webhook

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

4050import Server.Html

4151import Server.Schema

4252import Squeal.PostgreSQL

43−import System.IO

4453import Text.Blaze.Html

45−import UnliftIO.Exception (try)

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

4655

4756type API =

4857 "github-webhook"

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

5059 :> GitHubSignedReqBody '[JSON] InstallationEvent

5160 :> Post '[JSON] ()

5261 :<|> GitHubEvent '[ 'WebhookPushEvent]

53− :> GitHubSignedReqBody '[JSON] PushEvent

54− :> Post '[JSON] ()

62+ :> GitHubSignedReqBody '[JSON] PushEvent

63+ :> Post '[JSON] ()

5564 )

5665 :<|> "submission"

5766 :> Capture "user name" String

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

6473 :> Capture "sha" String

6574 :> "restart"

6675 :> Post '[HTML] Markup

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

6777

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

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

6979webhookInstallation _ ((), ev) =

70− liftIO $ do

71− print ev

72− hFlush stdout

73−

74−pendingStatus :: NewStatus

75−pendingStatus = NewStatus StatusPending Nothing Nothing Nothing

80+ logInfo . T.pack . show $ ev

7681

7782webhookPushEvent ::

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

83+ ( StaticPQ m,

84+ MonadReader (ServerData m) m,

85+ MonadUnliftIO m,

86+ HasTasks m,

87+ MonadError ServerError m,

88+ WithLog env Message m

89+ ) =>

7990 RepoWebhookEvent ->

8091 ((), PushEvent) ->

8192 m ()

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

8394 let repo = evPushRepository ev

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

8596 fullRepoName = whRepoFullName repo

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

87− Just sha = evPushHeadSha ev

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

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

99+ _ -> throwError err422

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

88101 tasks <- getTasks

89102 let task =

90103 M.lookupMax $

91104 M.takeWhileAntitone (repoName >) tasks

92105 case task of

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

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 dockerfile (N owner) (N repoName) (N sha)

103− liftIO $ do

104− print ev

105− hFlush stdout

107+ nowTime <- liftIO getCurrentTime

108+ if nowTime > deadline

109+ then do

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

111+ createSubmission $

112+ Submission

113+ user

114+ (T.unpack fullRepoName)

115+ (T.unpack name)

116+ (T.unpack sha)

117+ (Jsonb PastDeadline)

118+ else do

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

120+ createSubmission $

121+ Submission

122+ user

123+ (T.unpack fullRepoName)

124+ (T.unpack name)

125+ (T.unpack sha)

126+ (Jsonb BuildScheduled)

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

128+ logInfo . T.pack . show $ ev

106129 _ -> return ()

107130

108131retestSubmission ::

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

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

110133 String ->

111134 String ->

112135 String ->

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

125148 M.takeWhileAntitone (repoName' >) tasks

126149 case task of

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

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

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

129152 updateSubmissionStatus fullRepoName sha BuildScheduled

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

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

131154 _ -> return ()

132155 redirectToSubmission owner repoName sha

133156

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

145168 MonadUnliftIO

146169 )

147170

171+instance MonadError ServerError (ServerM schema) where

172+ throwError = throwIO

173+ catchError = catch

174+

148175server :: ServerT API (ServerM Schema)

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

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

150177

151−runServer :: IO ()

152−runServer = do

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

178+runServer :: FilePath -> IO ()

179+runServer config = do

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

154181 print c

182+ pem <- BS.readFile appPkPemPath

183+ appPkPem <- case readRsaPem pem of

184+ Right k -> return k

185+ Left e -> error (show e)

155186 auth <- mkInstallationAuth (AppAuth appId appPkPem) installationId

156187 ts <- newIORef mempty

157188 pool <- createConnectionPool databseUrl 1 0.5 10

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

161192 let context =

162193 gitPolyHubKey (return webhookSecret)

163194 :. EmptyContext

164− serverData = ServerData

165− { githubAppAuth = auth,

166− githubUserName = GithubUserName githubUsername,

167− githubAccessToken = GithubAccessToken personalAccessToken,

168− tasks = ts,

169− logger = simpleMessageAction,

170− baseUrl = baseSiteUrl,

171− dockerUrl = T.pack cfgDockerUrl

172− }

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

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

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

175206 repeatIfNotEmpty n f

176− _ <-

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

207+ printingErrors =

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

209+ usingConnectionPool pool

210+ . (`runReaderT` serverData)

211+ . unApp

212+ . handleAny (error . displayException)

213+ $ makeAllRunnable

214+ replicateM_ builderCount

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

178216 . usingConnectionPool pool

179217 . (`runReaderT` serverData)

180218 . unApp

181− $ runTasks @'[Build] 1

219+ . printingErrors

220+ $ runTasks @'[Build] 1

182221 _ <-

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

184223 . usingConnectionPool pool

185224 . (`runReaderT` serverData)

186225 . unApp

226+ . printingErrors

187227 $ runTasks @'[StatusUpdate] 5

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

189229 hoistServerWithContext

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

201241data ServerData m

202242 = ServerData

203243 { githubAppAuth :: !InstallationAuth,

204− githubUserName :: !GithubUserName,

205− githubAccessToken :: !GithubAccessToken,

206244 tasks :: IORef TasksConfig,

207245 logger :: LogAction m Message,

208− baseUrl :: String,

209− dockerUrl :: T.Text

246+ baseUrl :: T.Text,

247+ dockerUrl :: T.Text,

248+ context :: T.Text

210249 }

211250

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

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

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

218257 getContextEntry (PolyGitHubKey x :. _) = x

219258

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

221−

222− getGithubAccessToken = asks githubAccessToken

223−

224− getGithubUserName = asks githubUserName

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

260+ getGithubInstallationToken =

261+ either

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

263+ return

264+ <=< runExceptT

265+ $ do

266+ iAuth <- asks githubAppAuth

267+ manager <- newTlsManager

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

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

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

225271

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

227273 appRequest req = do

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

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

235281 getTasks = asks tasks >>= liftIO . readIORef

236282

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+

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

238349 getDockerUrl = asks dockerUrl

239350

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

242353data TaskConfig

243354 = TaskConfig

244355 { prebuild :: String,

245− dockerfile :: String

246− -- build :: T.Text

356+ dockerfile :: String,

357+ timeoutMinutes :: Int,

358+ deadline :: UTCTime

247359 }

248360 deriving stock (Show, Eq, Generic)

249361 deriving anyclass (FromJSON, ToJSON)

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

252364 getTasks :: m TasksConfig

253365

254366instance HasLog (ServerData m) Message m where

255−

256367 getLogAction :: ServerData m -> LogAction m Message

257368 getLogAction = logger

258369 {-# INLINE getLogAction #-}

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

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

261372 setLogAction newLogAction env = env {logger = newLogAction}

262373 {-# 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+73−33

@@ -2,59 +2,99 @@

33module Server.Config

44 ( Config (..),

5+ defaultConfig,

56 getConfig,

67 )

78where

9−import Crypto.PubKey.RSA (PrivateKey)

10+import Colog

1011import Crypto.PubKey.RSA.Read

11−import Data.ByteString as BS

12−import qualified Data.ByteString.Char8 as BS8

13−import Data.Maybe

12+import Data.Aeson as A

13+import Data.ByteString.Char8 as BS

14+import Data.Text as T

15+import Data.Yaml

16+import GHC.Generics

1417import GitHub.Data.Apps

1518import GitHub.Data.Id

1619import GitHub.Data.Installations

17−import System.Environment

20+import Text.Read (readMaybe)

1821

1922data Config

2023 = Config

2124 { webhookSecret :: !ByteString,

2225 appId :: !(Id App),

23− appPkPem :: !PrivateKey,

26+ appPkPemPath :: !FilePath,

2427 port :: !Int,

2528 installationId :: !(Id Installation),

26− personalAccessToken :: !String,

27− githubUsername :: !String,

2829 tasksPath :: !FilePath,

2930 databseUrl :: !ByteString,

30− baseSiteUrl :: !String,

31+ baseSiteUrl :: !Text,

3132 cfgDockerUrl :: !String,

32− cfgDockerFile :: !FilePath

33+ logSeverity :: !Severity,

34+ builderCount :: !Int,

35+ githubContext :: !Text

3336 }

34− deriving (Show)

37+ deriving (Show, Generic)

3538

36−getConfig :: IO Config

37−getConfig =

39+instance FromJSON ByteString where

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

41+ parseJSON _ = fail "not a string"

42+

43+instance ToJSON ByteString where

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

45+

46+instance FromJSON Severity where

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

48+ parseJSON _ = fail "not a string"

49+

50+instance ToJSON Severity where

51+ toJSON = String . T.pack . show

52+

53+instance FromJSON Config

54+

55+instance ToJSON Config

56+

57+defaultConfig :: Config

58+defaultConfig =

3859 Config

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

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

41− <*> readPem

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

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

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

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

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

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

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

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

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

51− where

52− readPem :: IO PrivateKey

53− readPem = do

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

55− pem <- BS.readFile path

56− case readRsaPem pem of

57− Right k -> return k

58− Left e -> error (show e)

60+ { webhookSecret = "GITHUB SECRET",

61+ appId = Id 69,

62+ appPkPemPath = "PRIVATE KEY PATH",

63+ port = 8080,

64+ installationId = Id 69,

65+ tasksPath = "TASKS PATH",

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

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

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

69+ logSeverity = Info,

70+ builderCount = 2,

71+ githubContext = "MY CI NAME"

72+ }

73+

74+getConfig :: FilePath -> IO Config

75+getConfig = decodeFileThrow

76+

77+-- getConfig :: IO Config

78+-- getConfig =

79+-- Config

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

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

82+-- <*> readPem

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

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

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

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

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

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

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

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

91+-- where

92+-- readPem :: IO PrivateKey

93+-- readPem = do

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

95+-- pem <- BS.readFile path

96+-- case readRsaPem pem of

97+-- Right k -> return k

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

5999

60100deriving instance Show ReadRsaKeyError

src/Server/Html.hs+49−13

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

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

13module Server.Html

24 ( getSubmissionR,

35 MonadHasBaseUrl (..),

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

810

911import Clay as C

1012import Colog

11−import Control.Monad.IO.Class

1213import Control.Monad.IO.Unlift

13−import Data.Aeson hiding (Success)

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

14+import Data.Foldable

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

2120import Server.Schema

2221import Squeal.PostgreSQL (Jsonb (..))

2322import Text.Blaze

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

3130 String ->

3231 String ->

3332 m Markup

34−getSubmissionR user repo sha = do

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

33+getSubmissionR user repo sha' = do

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

3635 let restartBuild = do

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

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

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

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

4039 Nothing ->

4140 return . ("Not found",) $

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

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

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

4443 H.h1 $ toHtml problem

4544 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,11 +56,13 @@ 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 ⏰"

6466 return . docTypeHtml $ do

6567 H.head $ do

6668 H.title $ toHtml titleText

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

8486 C.td ? do

8587 C.padding (px 4) (px 4) (px 4) (px 4)

8688 C.form ? do

89+ C.display C.block

90+ C.width (pct 100)

91+ C.input ? do

8792 C.display C.block

8893 C.marginLeft auto

8994 C.marginRight auto

9095 H.body inner

9196

9297class MonadHasBaseUrl m where

93− getBaseUrl :: m String

98+ getBaseUrl :: m T.Text

9499

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

96101getUrl fullName sha = do

97102 siteBase <- getBaseUrl

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

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

99104

100105redirectToSubmission ::

101106 (MonadHasBaseUrl m, Monad m) =>

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

109114 H.meta

110115 H.! A.httpEquiv "refresh"

111116 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+3−1

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

66where

88import Server.Schema.V1

9+import Server.Schema.V2

910import Squeal.PostgreSQL

1011

1112type StaticPQ m = MonadPQ Schema m

1213

13−type Schema = SchemaV1

14+type Schema = SchemaV2

1415

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

1617migration =

1718 pureMigration schemaMigrationV1

19+ :>> pureMigration schemaMigrationV2

1820 :>> Done

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

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

1818 ]

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

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

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

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

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

2223 ]

2324 ),

2425 "submissions"

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

3435 ]

3536

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

37−schemaMigrationV1 = Migration

38− { name = "v1",

39− up =

40− createTable

41− #tasks

42− ( notNullable text `as` #task

43− :* notNullable jsonb `as` #payload

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

45− )

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

47− >>> createTable

48− #submissions

49− ( notNullable text `as` #user_name

50− :* notNullable text `as` #repo_full_name

51− :* notNullable text `as` #problem

52− :* notNullable text `as` #sha

53− :* notNullable jsonb `as` #status

38+schemaMigrationV1 =

39+ Migration

40+ { name = "v1",

41+ up =

42+ createTable

43+ #tasks

44+ ( notNullable text `as` #task

45+ :* notNullable jsonb `as` #payload

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

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

5448 )

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

56− >>> createIndexes,

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

58− }

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

50+ >>> createTable

51+ #submissions

52+ ( notNullable text `as` #user_name

53+ :* notNullable text `as` #repo_full_name

54+ :* notNullable text `as` #problem

55+ :* notNullable text `as` #sha

56+ :* notNullable jsonb `as` #status

57+ )

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

59+ >>> createIndexes,

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

61+ }

5962 where

6063 createIndexes :: Definition sch sch

6164 createIndexes =

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

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

1+module Server.Schema.V2

2+ ( SchemaV2,

3+ schemaMigrationV2,

4+ )

5+where

7+import Data.Aeson

8+import Data.Int

9+import Data.Submission

10+import Data.Text (Text)

11+import Data.Time

12+import Server.Schema.V1

13+import Squeal.PostgreSQL

14+

15+type SchemaV2 =

16+ Public

17+ '[ "tasks"

18+ ::: 'Table

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

20+ ]

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

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

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

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

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

26+ ]

27+ ),

28+ "submissions"

29+ ::: 'Table

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

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

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

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

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

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

36+ ]

37+ )

38+ ]

39+

40+schemaMigrationV2 :: Migration Definition SchemaV1 SchemaV2

41+schemaMigrationV2 =

42+ Migration

43+ { name = "v2",

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

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

46+ }

stack.yaml+4−3

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

1717#

1818# resolver: ./custom-snapshot.yaml

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

20−resolver: lts-14.19

20+resolver: lts-14.27

2121

2222# User packages to be built.

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

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

4040# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

4141#

4242extra-deps:

43−- github-0.24

43+- github-0.25

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−- docker-0.6.0.2

5049- http-client-0.5.14

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

51+ commit: 5cfdc4d7facd7043f530bce4ce0f0c57c923b029

5152

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

5354# flags: {}

tasks.yaml+1

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

88 COPY . src

99 WORKDIR /src

1010 ENTRYPOINT stack test --fast

11+ timeoutMinutes: 10