33713bd..master · sc-build

git.iko.soy/sc-build

on master help sign in

.gitignore+1

since splitsnapshots

unifiedsplit

@@ -1 +1,2 @@

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

1module Main (main) where

3+import qualified Data.ByteString.Char8 as BS

4+import Data.Yaml (encode)

5+import Options.Applicative

3import Server

6import Server

7+import Server.Config

5main :: IO ()

9main :: 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+10

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

17library:

18 source-dirs: src

19 dependencies:

20+ - http-client-tls

20 - servant

21 - servant

21 - servant-server

22 - servant-server

22 - process

23 - process

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

46 - blaze-markup

47 - blaze-markup

47 - blaze-html

48 - blaze-html

48 - clay

49 - clay

50+ - docker

51+ - exceptions

52+ - transformers

53+ - cassava

54+ - http-media

55+ - utf8-string

50executables:

57executables:

51 sc-build-exe:

58 sc-build-exe:

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

57 - -with-rtsopts=-N

64 - -with-rtsopts=-N

58 dependencies:

65 dependencies:

59 - sc-build

66 - sc-build

67+ - bytestring

68+ - yaml

69+ - optparse-applicative

60 sc-build-migrations:

70 sc-build-migrations:

61 main: Main.hs

71 main: Main.hs

62 source-dirs: migrations

72 source-dirs: migrations

sc-build.cabaldeleted−103

@@ -1,103 +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: bb953e6231fcc3939bfe085afcd3e792cbc40462461bbe4fb82ae69f1796be4c

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− , 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+4−10

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

1module Control.GithubCloner

2− ( GithubAccessToken (..),

3− GithubUserName (..),

4− GithubCloner (..),

2+ ( GithubCloner (..),

3+ InstallationToken (..),

5 )

4 )

6where

5where

8−newtype GithubAccessToken = GithubAccessToken String

7+newtype InstallationToken = InstallationToken String

9−

10−newtype GithubUserName = GithubUserName String

12class GithubCloner m where

9class GithubCloner m where

13−

10+ getGithubInstallationToken :: m InstallationToken

14− getGithubAccessToken :: m GithubAccessToken

15−

16− getGithubUserName :: m GithubUserName

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

3module Control.Task.Scheduler

4 ( scheduleTask,

5 runTasks,

6+ makeAllRunnable,

6 )

7 )

7where

8where

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

20import GHC.TypeLits

21import GHC.TypeLits

21import Server.Schema

22import Server.Schema

22import Squeal.PostgreSQL

23import Squeal.PostgreSQL

24+import UnliftIO.Exception

24scheduleTask ::

26scheduleTask ::

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

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

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

45rescheduleTaskTime = rescheduleTaskQuery

47rescheduleTaskTime = rescheduleTaskQuery

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

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

48−

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

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

51 taskNames :: [String]

52 taskNames :: [String]

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

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

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

56 RunTasks (t ': tt) m

57 RunTasks (t ': tt) m

57 where

58 where

58−

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

60 case fromJSON @t v of

61 A.Error e ->

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

67 <> e

68 A.Success t -> do

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

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

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

71+ logError . T.pack . displayException $ e

72+ return Failure

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

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

72 case r of

74 case r of

73 Success -> completeTaskQuery t

75 Success -> completeTaskQuery t

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

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

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

81instance RunTasks '[] m where

83instance RunTasks '[] m where

82−

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

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

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

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

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

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

5 completeTaskQuery,

6 rescheduleTaskQuery,

7 pickTasksQuery,

8+ makeAllRunnable,

8 PickedTask (..),

9 PickedTask (..),

9 )

10 )

10where

11where

12import Colog

13import Colog

14+import Control.Arrow

13import Control.Monad.IO.Unlift

15import Control.Monad.IO.Unlift

14import Control.Squeal

16import Control.Squeal

15import Control.Task

17import Control.Task

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

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

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

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

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

40 :* Default `as` #creation_time

42 :* Default `as` #creation_time

43+ :* Default `as` #started

44+ :* Default `as` #failures

41 )

45 )

42 ( OnConflict

46 ( OnConflict

43 (OnConstraint #pk_task_payload)

47 (OnConstraint #pk_task_payload)

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

82 query =

86 query =

83 update_

87 update_

84 #tasks

88 #tasks

85− (Default `as` #creation_time)

89+ ( Default `as` #creation_time

90+ :* Default `as` #started

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

92+ )

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

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

87 dbWrite (const $ return ()) $

94 dbWrite (const $ return ()) $

88 manipulateParams_

95 manipulateParams_

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

96 Word64 ->

103 Word64 ->

97 m [PickedTask]

104 m [PickedTask]

98pickTasksQuery tasks limitCount = do

105pickTasksQuery tasks limitCount = do

99− logDebug "reading tasks"

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

100 let query :: Query_ Schema () PickedTask

107 let query :: Query_ Schema () PickedTask

101 query =

108 query =

102 select_

109 select_

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

106 )

113 )

107 ( from (table #tasks)

114 ( from (table #tasks)

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

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

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

117+ & where_ (#failures .< 20)

109 & orderBy [#creation_time & Asc]

118 & orderBy [#creation_time & Asc]

110 & limit limitCount

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

111 )

127 )

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

112− dbRead (const $ return []) $

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

113− runQuery query >>= getRows

130+ pickedTasks <- runQuery query >>= getRows

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

132+ return pickedTasks

114

133

115data PickedTask

134data PickedTask

116 = PickedTask

135 = PickedTask

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

119 creationTime :: UTCTime

138 creationTime :: UTCTime

120 }

139 }

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

140 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

2 ( Submission (..),

3 SubmissionStatus (..),

4 TestResult (..),

5+ Score (..),

5 )

6 )

6where

7where

8import Data.Aeson

9import Data.Aeson

10+import Data.Csv

11+import Data.Int

9import Data.Map (Map)

12import Data.Map (Map)

10import Data.Text (Text)

13import Data.Text (Text)

11import GHC.Generics (Generic)

14import GHC.Generics (Generic)

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

26 = SubmissionRun TestResult

29 = SubmissionRun TestResult

27 | SubmissionFailed String

30 | SubmissionFailed String

28 | BuildScheduled

31 | BuildScheduled

32+ | PastDeadline

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

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

31newtype TestResult

35newtype TestResult

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

34 }

38 }

35 deriving stock (Eq, Show, Generic)

39 deriving stock (Eq, Show, Generic)

36 deriving anyclass (FromJSON, ToJSON)

40 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

4 ( createSubmission,

5 updateSubmissionStatus,

6 getSubmission,

7+ getResults,

7 )

8 )

8where

9where

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

83 query

84 query

84 (repoFullName, sha)

85 (repoFullName, sha)

85 >>= firstRow

86 >>= 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+114−46

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

4module Data.Tasks.Build

5 ( Build (..),

6+ HasDockerInfo (..),

6 )

7 )

7where

8where

9import Colog

10import Colog

11+import Control.Concurrent

10import Control.GithubCloner

12import Control.GithubCloner

11−import Control.Monad.IO.Class

13+import Control.HasGithubStatus

14+import Control.Monad.Except

12import Control.Monad.IO.Unlift

15import Control.Monad.IO.Unlift

13import Control.Task

16import Control.Task

14−import Control.Task.Scheduler

15import Data.Aeson hiding (Success)

17import Data.Aeson hiding (Success)

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

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

17−import qualified Data.Map as M

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

18import Data.String

20import Data.String

19import Data.Submission

21import Data.Submission

20import Data.Submission.Query

22import Data.Submission.Query

21−import Data.Tasks.StatusUpdate

22import qualified Data.Text as T

23import qualified Data.Text as T

23import Data.Time.Clock.POSIX

24import Data.Time.Clock.POSIX

25+import qualified Docker.Client as D

24import GHC.Generics

26import GHC.Generics

25import GitHub

27import GitHub

26import Server.Schema

28import Server.Schema

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

28import System.Exit

30import System.Exit

29import System.Process.Typed

31import System.Process.Typed

30import System.Random

32import System.Random

33+import UnliftIO.Async

31import UnliftIO.Exception

34import UnliftIO.Exception

33data Build

36data Build

34 = Build

37 = Build

35 { preProcessShell :: String,

38 { preProcessShell :: String,

36− buildCommand :: String,

39+ dockerFile :: String,

37 owner :: Name Owner,

40 owner :: Name Owner,

38 repoName :: Name Repo,

41 repoName :: Name Repo,

39− sha :: Name Commit

42+ sha :: Name Commit,

43+ timeoutMinutes :: Int

40 }

44 }

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

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

43instance Task Build "build-repo" where

47instance Task Build "build-repo" where

44−

48+ type

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

49+ TaskMonad Build m =

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

47 performTask Build {..} =

52 performTask Build {..} =

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

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

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

50− sha' = T.unpack $ untagName sha

51 cloneRepo fullRepoName sha' dir

54 cloneRepo fullRepoName sha' dir

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

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

53 case shellCode of

56 case shellCode of

54 ExitFailure n -> do

57 ExitFailure n -> do

55− let err = BS.unpack shellErr

58+ let err = BS.toString shellErr

56 logError . T.pack $

59 logError . T.pack $

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

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

58 <> show sha

61 <> show sha

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

60 <> show n

63 <> show n

61 <> " and error "

64 <> " and error "

62 <> err

65 <> err

63− scheduleTask erroredTask

66+ scheduleFailedStatus err owner repoName sha

64 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

67 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

65 ExitSuccess -> do

68 ExitSuccess -> do

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

69+ h <- liftIO D.defaultHttpHandler

67− case buildCode of

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

68− ExitFailure n -> do

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

69− let err = BS.unpack buildErr

132+ let err = BS.toString buildErr

70 logError . T.pack $

133 logError . T.pack $

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

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

72 <> show sha

135 <> show sha

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

74 <> show n

137 <> show n

75 <> " and error "

138 <> " and error "

76 <> err

139 <> err

77− scheduleTask erroredTask

140+ scheduleFailedStatus err owner repoName sha

78 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

141 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

79− ExitSuccess ->

142+ (ExitSuccess, buildOut, _) ->

80− case decode buildOut of

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

81− Nothing -> do

144+ Left err' -> do

82− let err = BS.unpack buildOut

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

83 logError . T.pack $

146 logError . T.pack $

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

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

85 <> " at sha "

148 <> " at sha "

86 <> show sha

149 <> show sha

87 <> ": "

150 <> ": "

88 <> err

151 <> err

89− scheduleTask erroredTask

152+ scheduleFailedStatus err owner repoName sha

90− updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

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

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

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

92− let total = M.size tests

155+ scheduleTestedStatus testResult owner repoName sha

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

103 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

156 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

104 return Success

157 return Success

105 where

158 where

106− statusTask = StatusUpdate owner repoName sha

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

107− erroredTask = statusTask $ NewStatus

160+ sha' = T.unpack $ untagName sha

108− { newStatusState = StatusError,

161+ runEither ::

109− newStatusTargetUrl = Nothing,

162+ ( Exception err,

110− newStatusDescription = Just "Build failed",

163+ WithLog env Message m,

111− newStatusContext = Nothing

164+ StaticPQ m,

112− }

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

113

177

114createDir :: MonadIO m => m FilePath

178createDir :: MonadIO m => m FilePath

115createDir = do

179createDir = do

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

119

183

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

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

121cloneRepo repoName sha path = do

185cloneRepo repoName sha path = do

122− GithubAccessToken token <- getGithubAccessToken

186+ InstallationToken token <- getGithubInstallationToken

123− GithubUserName username <- getGithubUserName

124 runProcess_ . setWorkingDir path . fromString $

187 runProcess_ . setWorkingDir path . fromString $

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

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

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

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

127 return ()

190 return ()

128

191

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

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

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

132 i <- randomIO @Int

195 i <- randomIO @Int

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

196 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,7 +31,6 @@ instance FromJSON NewStatus where

31 <*> v .:? "context"

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

34−

35 type TaskMonad StatusUpdate m = (AppRequestable m)

34 type TaskMonad StatusUpdate m = (AppRequestable m)

37 performTask StatusUpdate {..} = do

36 performTask StatusUpdate {..} = do

src/Server.hs+182−57

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

10import Control.AppRequestable

11import Control.Concurrent

12import Control.GithubCloner

13+import Control.HasGithubStatus

13import Control.Monad.Except

14import Control.Monad.Except

14import Control.Monad.IO.Unlift

15import Control.Monad.IO.Unlift

15import Control.Monad.Reader

16import Control.Monad.Reader

16import Control.Task.Scheduler

17import Control.Task.Scheduler

18+import Crypto.PubKey.RSA.Read

17import Data.Aeson

19import Data.Aeson

18import Data.ByteString

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

19import Data.IORef

25import Data.IORef

20import Data.Map (Map)

26import Data.Map (Map)

21import qualified Data.Map as M

27import qualified Data.Map as M

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

24import Data.Tasks.Build

30import Data.Tasks.Build

25import Data.Tasks.StatusUpdate

31import Data.Tasks.StatusUpdate

26import qualified Data.Text as T

32import qualified Data.Text as T

33+import Data.Time.Clock

27import Data.Yaml

34import Data.Yaml

28import GHC.Generics

35import GHC.Generics

29−import GitHub

36+import GitHub hiding (Accept)

30import GitHub.App.Auth

37import GitHub.App.Auth

31import GitHub.App.Request

38import GitHub.App.Request

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

32import GitHub.Data.Name

40import GitHub.Data.Name

33import GitHub.Data.Webhooks.Events

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

35import Network.Wai.Handler.Warp

45import Network.Wai.Handler.Warp

36import Servant

46import Servant

37import Servant.GitHub.Webhook

47import Servant.GitHub.Webhook

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

40import Server.Html

50import Server.Html

41import Server.Schema

51import Server.Schema

42import Squeal.PostgreSQL

52import Squeal.PostgreSQL

43−import System.IO

44import Text.Blaze.Html

53import Text.Blaze.Html

45−import UnliftIO.Exception (try)

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

47type API =

56type API =

48 "github-webhook"

57 "github-webhook"

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

50 :> GitHubSignedReqBody '[JSON] InstallationEvent

59 :> GitHubSignedReqBody '[JSON] InstallationEvent

51 :> Post '[JSON] ()

60 :> Post '[JSON] ()

52 :<|> GitHubEvent '[ 'WebhookPushEvent]

61 :<|> GitHubEvent '[ 'WebhookPushEvent]

53− :> GitHubSignedReqBody '[JSON] PushEvent

62+ :> GitHubSignedReqBody '[JSON] PushEvent

54− :> Post '[JSON] ()

63+ :> Post '[JSON] ()

55 )

64 )

56 :<|> "submission"

65 :<|> "submission"

57 :> Capture "user name" String

66 :> Capture "user name" String

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

64 :> Capture "sha" String

73 :> Capture "sha" String

65 :> "restart"

74 :> "restart"

66 :> Post '[HTML] Markup

75 :> Post '[HTML] Markup

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

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

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

69webhookInstallation _ ((), ev) =

79webhookInstallation _ ((), ev) =

70− liftIO $ do

80+ logInfo . T.pack . show $ ev

71− print ev

72− hFlush stdout

73−

74−pendingStatus :: NewStatus

75−pendingStatus = NewStatus StatusPending Nothing Nothing Nothing

77webhookPushEvent ::

82webhookPushEvent ::

83+ ( StaticPQ m,

84+ MonadReader (ServerData m) m,

85+ MonadUnliftIO m,

86+ HasTasks m,

87+ MonadError ServerError m,

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

88+ WithLog env Message m

89+ ) =>

79 RepoWebhookEvent ->

90 RepoWebhookEvent ->

80 ((), PushEvent) ->

91 ((), PushEvent) ->

81 m ()

92 m ()

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

83 let repo = evPushRepository ev

94 let repo = evPushRepository ev

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

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

85 fullRepoName = whRepoFullName repo

96 fullRepoName = whRepoFullName repo

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

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

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

99+ _ -> throwError err422

87− Just sha = evPushHeadSha ev

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

88 tasks <- getTasks

101 tasks <- getTasks

89 let task =

102 let task =

90 M.lookupMax $

103 M.lookupMax $

91 M.takeWhileAntitone (repoName >) tasks

104 M.takeWhileAntitone (repoName >) tasks

92 case task of

105 case task of

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

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

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

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)

95− createSubmission $

120+ createSubmission $

96− Submission

121+ Submission

97− user

122+ user

98− (T.unpack fullRepoName)

123+ (T.unpack fullRepoName)

99− (T.unpack name)

124+ (T.unpack name)

100− (T.unpack sha)

125+ (T.unpack sha)

101− (Jsonb BuildScheduled)

126+ (Jsonb BuildScheduled)

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

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

103− liftIO $ do

128+ logInfo . T.pack . show $ ev

104− print ev

105− hFlush stdout

106 _ -> return ()

129 _ -> return ()

107

130

108retestSubmission ::

131retestSubmission ::

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

110 String ->

133 String ->

111 String ->

134 String ->

112 String ->

135 String ->

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

125 M.takeWhileAntitone (repoName' >) tasks

148 M.takeWhileAntitone (repoName' >) tasks

126 case task of

149 case task of

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

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

129 updateSubmissionStatus fullRepoName sha BuildScheduled

152 updateSubmissionStatus fullRepoName sha BuildScheduled

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

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

131 _ -> return ()

154 _ -> return ()

132 redirectToSubmission owner repoName sha

155 redirectToSubmission owner repoName sha

133

156

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

145 MonadUnliftIO

168 MonadUnliftIO

146 )

169 )

147

170

171+instance MonadError ServerError (ServerM schema) where

172+ throwError = throwIO

173+ catchError = catch

174+

148server :: ServerT API (ServerM Schema)

175server :: ServerT API (ServerM Schema)

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

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

150

177

151−runServer :: IO ()

178+runServer :: FilePath -> IO ()

152−runServer = do

179+runServer config = do

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

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

154 print c

181 print c

182+ pem <- BS.readFile appPkPemPath

183+ appPkPem <- case readRsaPem pem of

184+ Right k -> return k

185+ Left e -> error (show e)

155 auth <- mkInstallationAuth (AppAuth appId appPkPem) installationId

186 auth <- mkInstallationAuth (AppAuth appId appPkPem) installationId

156 ts <- newIORef mempty

187 ts <- newIORef mempty

157 pool <- createConnectionPool databseUrl 1 0.5 10

188 pool <- createConnectionPool databseUrl 1 0.5 10

158 _ <- forkIO $ do

189 _ <- forkIO $ do

159 updateTasks ts tasksPath

190 updateTasks ts tasksPath

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

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

161 let context =

192 let context =

162 gitPolyHubKey (return webhookSecret)

193 gitPolyHubKey (return webhookSecret)

163 :. EmptyContext

194 :. EmptyContext

164− serverData = ServerData

195+ serverData =

196+ ServerData

165− { githubAppAuth = auth,

197+ { githubAppAuth = auth,

166− githubUserName = GithubUserName githubUsername,

167− githubAccessToken = GithubAccessToken personalAccessToken,

168− tasks = ts,

198+ tasks = ts,

169− logger = simpleMessageAction,

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

170− baseUrl = baseSiteUrl

200+ baseUrl = baseSiteUrl,

201+ dockerUrl = T.pack cfgDockerUrl,

202+ context = githubContext

171− }

203+ }

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

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

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

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

174 repeatIfNotEmpty n f

206 repeatIfNotEmpty n f

175− _ <-

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

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

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

177 . usingConnectionPool pool

216 . usingConnectionPool pool

178 . (`runReaderT` serverData)

217 . (`runReaderT` serverData)

179 . unApp

218 . unApp

219+ . printingErrors

180− $ runTasks @'[Build] 1

220+ $ runTasks @'[Build] 1

181 _ <-

221 _ <-

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

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

183 . usingConnectionPool pool

223 . usingConnectionPool pool

184 . (`runReaderT` serverData)

224 . (`runReaderT` serverData)

185 . unApp

225 . unApp

226+ . printingErrors

186 $ runTasks @'[StatusUpdate] 5

227 $ runTasks @'[StatusUpdate] 5

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

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

188 hoistServerWithContext

229 hoistServerWithContext

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

200data ServerData m

241data ServerData m

201 = ServerData

242 = ServerData

202 { githubAppAuth :: !InstallationAuth,

243 { githubAppAuth :: !InstallationAuth,

203− githubUserName :: !GithubUserName,

204− githubAccessToken :: !GithubAccessToken,

205 tasks :: IORef TasksConfig,

244 tasks :: IORef TasksConfig,

206 logger :: LogAction m Message,

245 logger :: LogAction m Message,

207− baseUrl :: String

246+ baseUrl :: T.Text,

247+ dockerUrl :: T.Text,

248+ context :: T.Text

208 }

249 }

209

250

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

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

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

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

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

216 getContextEntry (PolyGitHubKey x :. _) = x

257 getContextEntry (PolyGitHubKey x :. _) = x

217

258

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

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

219−

260+ getGithubInstallationToken =

220− getGithubAccessToken = asks githubAccessToken

261+ either

221−

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

222− getGithubUserName = asks githubUserName

263+ return

264+ <=< runExceptT

265+ $ do

266+ iAuth <- asks githubAppAuth

267+ manager <- newTlsManager

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

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

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

223

271

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

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

225 appRequest req = do

273 appRequest req = do

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

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

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

233 getTasks = asks tasks >>= liftIO . readIORef

281 getTasks = asks tasks >>= liftIO . readIORef

234

282

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+

235type TasksConfig = Map T.Text TaskConfig

351type TasksConfig = Map T.Text TaskConfig

236

352

237data TaskConfig

353data TaskConfig

238 = TaskConfig

354 = TaskConfig

239 { prebuild :: String,

355 { prebuild :: String,

240− build :: String

356+ dockerfile :: String,

357+ timeoutMinutes :: Int,

358+ deadline :: UTCTime

241 }

359 }

242 deriving stock (Show, Eq, Generic)

360 deriving stock (Show, Eq, Generic)

243 deriving anyclass (FromJSON, ToJSON)

361 deriving anyclass (FromJSON, ToJSON)

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

246 getTasks :: m TasksConfig

364 getTasks :: m TasksConfig

247

365

248instance HasLog (ServerData m) Message m where

366instance HasLog (ServerData m) Message m where

249−

250 getLogAction :: ServerData m -> LogAction m Message

367 getLogAction :: ServerData m -> LogAction m Message

251 getLogAction = logger

368 getLogAction = logger

252 {-# INLINE getLogAction #-}

369 {-# INLINE getLogAction #-}

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

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

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

255 setLogAction newLogAction env = env {logger = newLogAction}

372 setLogAction newLogAction env = env {logger = newLogAction}

256 {-# INLINE setLogAction #-}

373 {-# 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+74−30

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

3module Server.Config

4 ( Config (..),

5+ defaultConfig,

5 getConfig,

6 getConfig,

6 )

7 )

7where

8where

9−import Crypto.PubKey.RSA (PrivateKey)

10+import Colog

10import Crypto.PubKey.RSA.Read

11import Crypto.PubKey.RSA.Read

11−import Data.ByteString as BS

12+import Data.Aeson as A

12−import qualified Data.ByteString.Char8 as BS8

13+import Data.ByteString.Char8 as BS

14+import Data.Text as T

13−import Data.Maybe

15+import Data.Yaml

16+import GHC.Generics

14import GitHub.Data.Apps

17import GitHub.Data.Apps

15import GitHub.Data.Id

18import GitHub.Data.Id

16import GitHub.Data.Installations

19import GitHub.Data.Installations

17−import System.Environment

20+import Text.Read (readMaybe)

19data Config

22data Config

20 = Config

23 = Config

21 { webhookSecret :: !ByteString,

24 { webhookSecret :: !ByteString,

22 appId :: !(Id App),

25 appId :: !(Id App),

23− appPkPem :: !PrivateKey,

26+ appPkPemPath :: !FilePath,

24 port :: !Int,

27 port :: !Int,

25 installationId :: !(Id Installation),

28 installationId :: !(Id Installation),

26− personalAccessToken :: !String,

27− githubUsername :: !String,

28 tasksPath :: !FilePath,

29 tasksPath :: !FilePath,

29 databseUrl :: !ByteString,

30 databseUrl :: !ByteString,

30− baseSiteUrl :: !String

31+ baseSiteUrl :: !Text,

32+ cfgDockerUrl :: !String,

33+ logSeverity :: !Severity,

34+ builderCount :: !Int,

35+ githubContext :: !Text

31 }

36 }

32− deriving (Show)

37+ deriving (Show, Generic)

34−getConfig :: IO Config

39+instance FromJSON ByteString where

35−getConfig =

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 =

36 Config

59 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

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

80+-- <$> (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")

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

39− <*> readPem

82+-- <*> readPem

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

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

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

84+-- <*> (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")

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

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

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

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

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

47− where

91+-- where

48− readPem :: IO PrivateKey

92+-- readPem :: IO PrivateKey

49− readPem = do

93+-- readPem = do

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

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

51− pem <- BS.readFile path

95+-- pem <- BS.readFile path

52− case readRsaPem pem of

96+-- case readRsaPem pem of

53− Right k -> return k

97+-- Right k -> return k

54− Left e -> error (show e)

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

56deriving instance Show ReadRsaKeyError

100deriving instance Show ReadRsaKeyError

src/Server/Html.hs+49−13

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

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

1module Server.Html

3module Server.Html

2 ( getSubmissionR,

4 ( getSubmissionR,

3 MonadHasBaseUrl (..),

5 MonadHasBaseUrl (..),

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

9import Clay as C

11import Clay as C

10import Colog

12import Colog

11−import Control.Monad.IO.Class

12import Control.Monad.IO.Unlift

13import Control.Monad.IO.Unlift

13−import Data.Aeson hiding (Success)

14+import Data.Foldable

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

15import qualified Data.Map as M

16import Data.String

17import Data.Submission

18import Data.Submission.Query

19import qualified Data.Text as T

20−import GHC.Generics

21import Server.Schema

20import Server.Schema

22import Squeal.PostgreSQL (Jsonb (..))

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

23import Text.Blaze

22import Text.Blaze

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

31 String ->

30 String ->

32 String ->

31 String ->

33 m Markup

32 m Markup

34−getSubmissionR user repo sha = do

33+getSubmissionR user repo sha' = do

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

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

36 let restartBuild = do

35 let restartBuild = do

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

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

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

37 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

40 Nothing ->

39 Nothing ->

41 return . ("Not found",) $

40 return . ("Not found",) $

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

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

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

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

44 H.h1 $ toHtml problem

43 H.h1 $ toHtml problem

45 H.h2 $ toHtml userName

44 H.h2 $ toHtml userName

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

46 case status of

47 Jsonb BuildScheduled -> do

48− H.h3 "Waiting to build"

48+ H.h3 "Waiting to build ⌛"

49 restartBuild

50 Jsonb (SubmissionFailed err) -> do

51− H.h3 "Failed to build"

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

52 restartBuild

53 H.code . H.pre $ toHtml err

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

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

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

57 H.h3 . toHtml $

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

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

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

60 restartBuild

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

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

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

64+ Jsonb PastDeadline ->

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

64 return . docTypeHtml $ do

66 return . docTypeHtml $ do

65 H.head $ do

67 H.head $ do

66 H.title $ toHtml titleText

68 H.title $ toHtml titleText

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

84 C.td ? do

86 C.td ? do

85 C.padding (px 4) (px 4) (px 4) (px 4)

87 C.padding (px 4) (px 4) (px 4) (px 4)

86 C.form ? do

88 C.form ? do

89+ C.display C.block

90+ C.width (pct 100)

91+ C.input ? do

87 C.display C.block

92 C.display C.block

88 C.marginLeft auto

93 C.marginLeft auto

89 C.marginRight auto

94 C.marginRight auto

90 H.body inner

95 H.body inner

92class MonadHasBaseUrl m where

97class MonadHasBaseUrl m where

93− getBaseUrl :: m String

98+ getBaseUrl :: m T.Text

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

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

96getUrl fullName sha = do

101getUrl fullName sha = do

97 siteBase <- getBaseUrl

102 siteBase <- getBaseUrl

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

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

104

100redirectToSubmission ::

105redirectToSubmission ::

101 (MonadHasBaseUrl m, Monad m) =>

106 (MonadHasBaseUrl m, Monad m) =>

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

109 H.meta

114 H.meta

110 H.! A.httpEquiv "refresh"

115 H.! A.httpEquiv "refresh"

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

116 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

6where

8import Server.Schema.V1

9+import Server.Schema.V2

9import Squeal.PostgreSQL

10import Squeal.PostgreSQL

11type StaticPQ m = MonadPQ Schema m

12type StaticPQ m = MonadPQ Schema m

13−type Schema = SchemaV1

14+type Schema = SchemaV2

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

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

16migration =

17migration =

17 pureMigration schemaMigrationV1

18 pureMigration schemaMigrationV1

19+ :>> pureMigration schemaMigrationV2

18 :>> Done

20 :>> Done

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

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

18 ]

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

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

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

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

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

22 ]

23 ]

23 ),

24 ),

24 "submissions"

25 "submissions"

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

34 ]

35 ]

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

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

37−schemaMigrationV1 = Migration

38+schemaMigrationV1 =

39+ Migration

38− { name = "v1",

40+ { name = "v1",

39− up =

41+ up =

40− createTable

42+ createTable

41− #tasks

43+ #tasks

42− ( notNullable text `as` #task

44+ ( notNullable text `as` #task

43− :* notNullable jsonb `as` #payload

45+ :* notNullable jsonb `as` #payload

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

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

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

50− :* notNullable text `as` #repo_full_name

51− :* notNullable text `as` #problem

52− :* notNullable text `as` #sha

53− :* notNullable jsonb `as` #status

54 )

48 )

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

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

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

56− >>> createIndexes,

59+ >>> createIndexes,

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

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

58− }

61+ }

59 where

62 where

60 createIndexes :: Definition sch sch

63 createIndexes :: Definition sch sch

61 createIndexes =

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

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

17#

18# resolver: ./custom-snapshot.yaml

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

20−resolver: lts-14.19

20+resolver: lts-14.27

22# User packages to be built.

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

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

40# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

41#

42extra-deps:

43−- github-0.24

43+- github-0.25

44- binary-instances-1

45- squeal-postgresql-0.5.2.0

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

47 commit: 0bede85ab53eb8f953cf6f4e58a756a205e88e0b

48- servant-github-webhook-0.4.2.0

49+- http-client-0.5.14

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

51+ commit: 5cfdc4d7facd7043f530bce4ce0f0c57c923b029

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

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

51# flags: {}

54# flags: {}

tasks.yamlnew file+11

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

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