0b85829..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+7

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

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

49 - docker

50 - docker

50 - exceptions

51 - exceptions

51 - transformers

52 - transformers

53+ - cassava

54+ - http-media

55+ - utf8-string

53executables:

57executables:

54 sc-build-exe:

58 sc-build-exe:

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

60 - -with-rtsopts=-N

64 - -with-rtsopts=-N

61 dependencies:

65 dependencies:

62 - sc-build

66 - sc-build

67+ - bytestring

68+ - yaml

69+ - optparse-applicative

63 sc-build-migrations:

70 sc-build-migrations:

64 main: Main.hs

71 main: Main.hs

65 source-dirs: migrations

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

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

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

8where

10import Colog

11+import Control.Concurrent

11import Control.GithubCloner

12import Control.GithubCloner

13+import Control.HasGithubStatus

12import Control.Monad.Except

14import Control.Monad.Except

13import Control.Monad.IO.Unlift

15import Control.Monad.IO.Unlift

14import Control.Task

16import Control.Task

15−import Control.Task.Scheduler

16import Data.Aeson hiding (Success)

17import Data.Aeson hiding (Success)

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

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

18−import qualified Data.Map as M

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

19import Data.String

20import Data.String

20import Data.Submission

21import Data.Submission

21import Data.Submission.Query

22import Data.Submission.Query

22−import Data.Tasks.StatusUpdate

23import qualified Data.Text as T

24import Data.Time.Clock.POSIX

25import qualified Docker.Client as D

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

30import System.Exit

31import System.Process.Typed

32import System.Random

33+import UnliftIO.Async

33import UnliftIO.Exception

34import UnliftIO.Exception

35data Build

36data Build

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

38 dockerFile :: String,

39 dockerFile :: String,

39 owner :: Name Owner,

40 owner :: Name Owner,

40 repoName :: Name Repo,

41 repoName :: Name Repo,

41− sha :: Name Commit

42+ sha :: Name Commit,

43+ timeoutMinutes :: Int

42 }

44 }

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

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

45instance Task Build "build-repo" where

47instance Task Build "build-repo" where

46−

48+ type

49+ TaskMonad Build m =

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

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

49 performTask Build {..} =

52 performTask Build {..} =

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

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

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

52− sha' = T.unpack $ untagName sha

53 cloneRepo fullRepoName sha' dir

54 cloneRepo fullRepoName sha' dir

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

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

55 case shellCode of

56 case shellCode of

56 ExitFailure n -> do

57 ExitFailure n -> do

57− let err = BS.unpack shellErr

58+ let err = BS.toString shellErr

58 logError . T.pack $

59 logError . T.pack $

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

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

60 <> show sha

61 <> show sha

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

62 <> show n

63 <> show n

63 <> " and error "

64 <> " and error "

64 <> err

65 <> err

65− scheduleTask erroredTask

66+ scheduleFailedStatus err owner repoName sha

66 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

67 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

67 ExitSuccess -> do

68 ExitSuccess -> do

68 h <- liftIO D.defaultHttpHandler

69 h <- liftIO D.defaultHttpHandler

69 dUrl <- getDockerUrl

70 dUrl <- getDockerUrl

70 let opts = D.defaultCreateOpts imageName

71 let opts = D.defaultCreateOpts imageName

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

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

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

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

73 imageName = T.pack dir

83 imageName = T.pack dir

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

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

75 absDir <- liftIO $ makeAbsolute dir

85 absDir <- liftIO $ makeAbsolute dir

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

77 D.waitContainer cid >>= \case

87 D.waitContainer cid >>= \case

78 Left D.GenericDockerError {} -> waitDockerForever cid

88 Left D.GenericDockerError {} -> waitDockerForever cid

79 a -> return a

89 a -> return a

80− dockerRes <- runDocker . runExceptT $ do

90+ cid <- runDocker . runExceptT $ do

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

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

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

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

83− ExceptT $ D.startContainer D.defaultStartOpts cid

105+ ExceptT $ D.startContainer D.defaultStartOpts cid

84− buildCode <- ExceptT $ waitDockerForever cid

106+ buildCode <- ExceptT $ waitDockerForever cid

85− buildOut <-

107+ buildOut <-

86− ExceptT $

108+ ExceptT $

87− D.getContainerLogs

109+ D.getContainerLogs

88− D.LogOpts

110+ D.LogOpts

89− { stdout = True,

111+ { stdout = True,

90− stderr = False,

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,

91− since = Nothing,

124+ since = Nothing,

92− timestamps = False,

125+ timestamps = False,

93− tail = D.All

126+ tail = D.All

94− }

127+ }

95− cid

128+ cid

96− return (buildCode, buildOut)

129+ return (buildCode, buildOut, buildErr)

97 case dockerRes of

130 case dockerRes of

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

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

99− let err = BS.unpack buildOut

132+ let err = BS.toString buildErr

100 logError . T.pack $

133 logError . T.pack $

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

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

102 <> show sha

135 <> show sha

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

104 <> show n

137 <> show n

105 <> " and error "

138 <> " and error "

106 <> err

139 <> err

107− scheduleTask erroredTask

140+ scheduleFailedStatus err owner repoName sha

108− updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

109− Left err' -> do

110− let err = show err'

111− logError . T.pack $ err

112− scheduleTask erroredTask

113 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

141 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

114− Right (ExitSuccess, buildOut) ->

142+ (ExitSuccess, buildOut, _) ->

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

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

116 Left err' -> do

144 Left err' -> do

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

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

118 logError . T.pack $

146 logError . T.pack $

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

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

120 <> " at sha "

148 <> " at sha "

121 <> show sha

149 <> show sha

122 <> ": "

150 <> ": "

123 <> err

151 <> err

124− scheduleTask erroredTask

152+ scheduleFailedStatus err owner repoName sha

125− updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

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

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

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

127− let total = M.size tests

155+ scheduleTestedStatus testResult owner repoName sha

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

138 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

156 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

139 return Success

157 return Success

140 where

158 where

141− statusTask = StatusUpdate owner repoName sha

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

142− erroredTask = statusTask $ NewStatus

160+ sha' = T.unpack $ untagName sha

143− { newStatusState = StatusError,

161+ runEither ::

144− newStatusTargetUrl = Nothing,

162+ ( Exception err,

145− newStatusDescription = Just "Build failed",

163+ WithLog env Message m,

146− newStatusContext = Nothing

164+ StaticPQ m,

147− }

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

148

177

149createDir :: MonadIO m => m FilePath

178createDir :: MonadIO m => m FilePath

150createDir = do

179createDir = do

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

154

183

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

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

156cloneRepo repoName sha path = do

185cloneRepo repoName sha path = do

157− GithubAccessToken token <- getGithubAccessToken

186+ InstallationToken token <- getGithubInstallationToken

158− GithubUserName username <- getGithubUserName

159 runProcess_ . setWorkingDir path . fromString $

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

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

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

162 return ()

190 return ()

163

191

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

169

197

170class HasDockerInfo m where

198class HasDockerInfo m where

171 getDockerUrl :: m T.Text

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+178−59

@@ -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 dockerfile (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 dockerfile (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,13 +168,21 @@ 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

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

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,

171− dockerUrl = T.pack cfgDockerUrl

201+ dockerUrl = T.pack cfgDockerUrl,

202+ context = githubContext

172− }

203+ }

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

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

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

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

175 repeatIfNotEmpty n f

206 repeatIfNotEmpty n f

176− _ <-

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

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

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

178 . usingConnectionPool pool

216 . usingConnectionPool pool

179 . (`runReaderT` serverData)

217 . (`runReaderT` serverData)

180 . unApp

218 . unApp

219+ . printingErrors

181− $ runTasks @'[Build] 1

220+ $ runTasks @'[Build] 1

182 _ <-

221 _ <-

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

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

184 . usingConnectionPool pool

223 . usingConnectionPool pool

185 . (`runReaderT` serverData)

224 . (`runReaderT` serverData)

186 . unApp

225 . unApp

226+ . printingErrors

187 $ runTasks @'[StatusUpdate] 5

227 $ runTasks @'[StatusUpdate] 5

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

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

189 hoistServerWithContext

229 hoistServerWithContext

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

201data ServerData m

241data ServerData m

202 = ServerData

242 = ServerData

203 { githubAppAuth :: !InstallationAuth,

243 { githubAppAuth :: !InstallationAuth,

204− githubUserName :: !GithubUserName,

205− githubAccessToken :: !GithubAccessToken,

206 tasks :: IORef TasksConfig,

244 tasks :: IORef TasksConfig,

207 logger :: LogAction m Message,

245 logger :: LogAction m Message,

208− baseUrl :: String,

246+ baseUrl :: T.Text,

209− dockerUrl :: T.Text

247+ dockerUrl :: T.Text,

248+ context :: T.Text

210 }

249 }

211

250

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

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

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

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

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

218 getContextEntry (PolyGitHubKey x :. _) = x

257 getContextEntry (PolyGitHubKey x :. _) = x

219

258

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

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

221−

260+ getGithubInstallationToken =

222− getGithubAccessToken = asks githubAccessToken

261+ either

223−

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

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

225

271

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

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

227 appRequest req = do

273 appRequest req = do

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

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

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

235 getTasks = asks tasks >>= liftIO . readIORef

281 getTasks = asks tasks >>= liftIO . readIORef

236

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+

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

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

238 getDockerUrl = asks dockerUrl

349 getDockerUrl = asks dockerUrl

239

350

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

242data TaskConfig

353data TaskConfig

243 = TaskConfig

354 = TaskConfig

244 { prebuild :: String,

355 { prebuild :: String,

245− dockerfile :: String

356+ dockerfile :: String,

246− -- build :: T.Text

357+ timeoutMinutes :: Int,

358+ deadline :: UTCTime

247 }

359 }

248 deriving stock (Show, Eq, Generic)

360 deriving stock (Show, Eq, Generic)

249 deriving anyclass (FromJSON, ToJSON)

361 deriving anyclass (FromJSON, ToJSON)

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

252 getTasks :: m TasksConfig

364 getTasks :: m TasksConfig

253

365

254instance HasLog (ServerData m) Message m where

366instance HasLog (ServerData m) Message m where

255−

256 getLogAction :: ServerData m -> LogAction m Message

367 getLogAction :: ServerData m -> LogAction m Message

257 getLogAction = logger

368 getLogAction = logger

258 {-# INLINE getLogAction #-}

369 {-# INLINE getLogAction #-}

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

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

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

261 setLogAction newLogAction env = env {logger = newLogAction}

372 setLogAction newLogAction env = env {logger = newLogAction}

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

@@ -2,59 +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,

31 cfgDockerUrl :: !String,

32 cfgDockerUrl :: !String,

32− cfgDockerFile :: !FilePath

33+ logSeverity :: !Severity,

34+ builderCount :: !Int,

35+ githubContext :: !Text

33 }

36 }

34− deriving (Show)

37+ deriving (Show, Generic)

36−getConfig :: IO Config

39+instance FromJSON ByteString where

37−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 =

38 Config

59 Config

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

60+ { webhookSecret = "GITHUB SECRET",

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

61+ appId = Id 69,

41− <*> readPem

62+ appPkPemPath = "PRIVATE KEY PATH",

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

63+ port = 8080,

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

64+ installationId = Id 69,

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

65+ tasksPath = "TASKS PATH",

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

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

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

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

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

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

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

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

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

51− where

91+-- where

52− readPem :: IO PrivateKey

92+-- readPem :: IO PrivateKey

53− readPem = do

93+-- readPem = do

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

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

55− pem <- BS.readFile path

95+-- pem <- BS.readFile path

56− case readRsaPem pem of

96+-- case readRsaPem pem of

57− Right k -> return k

97+-- Right k -> return k

58− Left e -> error (show e)

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

60deriving 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+4−3

@@ -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,14 +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−- docker-0.6.0.2

50- http-client-0.5.14

49- http-client-0.5.14

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

51+ commit: 5cfdc4d7facd7043f530bce4ce0f0c57c923b029

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

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

53# flags: {}

54# flags: {}

tasks.yaml+1

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

8 COPY . src

9 WORKDIR /src

10 ENTRYPOINT stack test --fast

11+ timeoutMinutes: 10