5b41806...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+1

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

29 = SubmissionRun TestResult

30 | SubmissionFailed String

31 | BuildScheduled

32+ | PastDeadline

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

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

34newtype TestResult

35newtype TestResult

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

@@ -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,22 +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

48+ type

49+ TaskMonad Build m =

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

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

48 performTask Build {..} =

52 performTask Build {..} =

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

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

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

51− sha' = T.unpack $ untagName sha

52 cloneRepo fullRepoName sha' dir

54 cloneRepo fullRepoName sha' dir

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

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

54 case shellCode of

56 case shellCode of

55 ExitFailure n -> do

57 ExitFailure n -> do

56− let err = BS.unpack shellErr

58+ let err = BS.toString shellErr

57 logError . T.pack $

59 logError . T.pack $

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

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

59 <> show sha

61 <> show sha

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

61 <> show n

63 <> show n

62 <> " and error "

64 <> " and error "

63 <> err

65 <> err

64− scheduleTask erroredTask

66+ scheduleFailedStatus err owner repoName sha

65 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

67 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

66 ExitSuccess -> do

68 ExitSuccess -> do

67 h <- liftIO D.defaultHttpHandler

69 h <- liftIO D.defaultHttpHandler

68 dUrl <- getDockerUrl

70 dUrl <- getDockerUrl

69 let opts = D.defaultCreateOpts imageName

71 let opts = D.defaultCreateOpts imageName

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

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

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

72 imageName = T.pack dir

83 imageName = T.pack dir

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

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

74 absDir <- liftIO $ makeAbsolute dir

85 absDir <- liftIO $ makeAbsolute dir

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

76 D.waitContainer cid >>= \case

87 D.waitContainer cid >>= \case

77 Left D.GenericDockerError {} -> waitDockerForever cid

88 Left D.GenericDockerError {} -> waitDockerForever cid

78 a -> return a

89 a -> return a

79− dockerRes <- runDocker . runExceptT $ do

90+ cid <- runDocker . runExceptT $ do

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

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

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

82− ExceptT $ D.startContainer D.defaultStartOpts cid

105+ ExceptT $ D.startContainer D.defaultStartOpts cid

83− buildCode <- ExceptT $ waitDockerForever cid

106+ buildCode <- ExceptT $ waitDockerForever cid

84− buildOut <-

107+ buildOut <-

85− ExceptT $

108+ ExceptT $

86− D.getContainerLogs

109+ D.getContainerLogs

87− D.LogOpts

110+ D.LogOpts

88− { stdout = True,

111+ { stdout = True,

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

90− since = Nothing,

124+ since = Nothing,

91− timestamps = False,

125+ timestamps = False,

92− tail = D.All

126+ tail = D.All

93− }

127+ }

94− cid

128+ cid

95− return (buildCode, buildOut)

129+ return (buildCode, buildOut, buildErr)

96 case dockerRes of

130 case dockerRes of

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

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

98− let err = BS.unpack buildOut

132+ let err = BS.toString buildErr

99 logError . T.pack $

133 logError . T.pack $

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

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

101 <> show sha

135 <> show sha

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

103 <> show n

137 <> show n

104 <> " and error "

138 <> " and error "

105 <> err

139 <> err

106− scheduleTask erroredTask

140+ scheduleFailedStatus err owner repoName sha

107 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

141 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

108− Left err' -> do

109− let err = show err'

110− logError . T.pack $ err

111− scheduleTask erroredTask

112− updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

113− Right (ExitSuccess, buildOut) ->

142+ (ExitSuccess, buildOut, _) ->

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

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

115 Left err' -> do

144 Left err' -> do

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

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

117 logError . T.pack $

146 logError . T.pack $

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

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

119 <> " at sha "

148 <> " at sha "

120 <> show sha

149 <> show sha

121 <> ": "

150 <> ": "

122 <> err

151 <> err

123− scheduleTask erroredTask

152+ scheduleFailedStatus err owner repoName sha

124− updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

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

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

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

126− let total = M.size tests

155+ scheduleTestedStatus testResult owner repoName sha

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

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

129− status =

130− statusTask

131− NewStatus

132− { newStatusState =

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

134− newStatusTargetUrl = Nothing,

135− newStatusDescription = Just description,

136− newStatusContext = Nothing

137− }

138− scheduleTask status

139 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

156 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

140 return Success

157 return Success

141 where

158 where

142− statusTask = StatusUpdate owner repoName sha

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

143− erroredTask =

160+ sha' = T.unpack $ untagName sha

144− statusTask $

161+ runEither ::

145− NewStatus

162+ ( Exception err,

146− { newStatusState = StatusError,

163+ WithLog env Message m,

147− newStatusTargetUrl = Nothing,

164+ StaticPQ m,

148− newStatusDescription = Just "Build failed",

165+ MonadUnliftIO m,

149− newStatusContext = Nothing

166+ HasGithubStatus m

150− }

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

151

177

152createDir :: MonadIO m => m FilePath

178createDir :: MonadIO m => m FilePath

153createDir = do

179createDir = do

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

157

183

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

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

159cloneRepo repoName sha path = do

185cloneRepo repoName sha path = do

160− GithubAccessToken token <- getGithubAccessToken

186+ InstallationToken token <- getGithubInstallationToken

161− GithubUserName username <- getGithubUserName

162 runProcess_ . setWorkingDir path . fromString $

187 runProcess_ . setWorkingDir path . fromString $

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

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

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

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

165 return ()

190 return ()

166

191

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

172

197

173class HasDockerInfo m where

198class HasDockerInfo m where

174 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+165−57

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

19import qualified Data.Csv as Csv

24import qualified Data.Csv as Csv

20import Data.IORef

25import Data.IORef

21import Data.Map (Map)

26import Data.Map (Map)

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

25import Data.Tasks.Build

30import Data.Tasks.Build

26import Data.Tasks.StatusUpdate

31import Data.Tasks.StatusUpdate

27import qualified Data.Text as T

32import qualified Data.Text as T

33+import Data.Time.Clock

28import Data.Yaml

34import Data.Yaml

29import GHC.Generics

35import GHC.Generics

30import GitHub hiding (Accept)

36import GitHub hiding (Accept)

31import GitHub.App.Auth

37import GitHub.App.Auth

32import GitHub.App.Request

38import GitHub.App.Request

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

33import GitHub.Data.Name

40import GitHub.Data.Name

34import GitHub.Data.Webhooks.Events

41import GitHub.Data.Webhooks.Events

35−import GitHub.Data.Webhooks.Payload

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

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

36import Network.HTTP.Media.MediaType

44import Network.HTTP.Media.MediaType

37import Network.Wai.Handler.Warp

45import Network.Wai.Handler.Warp

38import Servant

46import Servant

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

42import Server.Html

50import Server.Html

43import Server.Schema

51import Server.Schema

44import Squeal.PostgreSQL

52import Squeal.PostgreSQL

45−import System.IO

46import Text.Blaze.Html

53import Text.Blaze.Html

47−import UnliftIO.Exception (try)

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

49type API =

56type API =

50 "github-webhook"

57 "github-webhook"

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

52 :> GitHubSignedReqBody '[JSON] InstallationEvent

59 :> GitHubSignedReqBody '[JSON] InstallationEvent

53 :> Post '[JSON] ()

60 :> Post '[JSON] ()

54 :<|> GitHubEvent '[ 'WebhookPushEvent]

61 :<|> GitHubEvent '[ 'WebhookPushEvent]

55− :> GitHubSignedReqBody '[JSON] PushEvent

62+ :> GitHubSignedReqBody '[JSON] PushEvent

56− :> Post '[JSON] ()

63+ :> Post '[JSON] ()

57 )

64 )

58 :<|> "submission"

65 :<|> "submission"

59 :> Capture "user name" String

66 :> Capture "user name" String

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

68 :> Post '[HTML] Markup

75 :> Post '[HTML] Markup

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

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

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

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

72webhookInstallation _ ((), ev) =

79webhookInstallation _ ((), ev) =

73− liftIO $ do

80+ logInfo . T.pack . show $ ev

74− print ev

75− hFlush stdout

76−

77−pendingStatus :: NewStatus

78−pendingStatus = NewStatus StatusPending Nothing Nothing Nothing

80webhookPushEvent ::

82webhookPushEvent ::

83+ ( StaticPQ m,

84+ MonadReader (ServerData m) m,

85+ MonadUnliftIO m,

86+ HasTasks m,

87+ MonadError ServerError m,

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

88+ WithLog env Message m

89+ ) =>

82 RepoWebhookEvent ->

90 RepoWebhookEvent ->

83 ((), PushEvent) ->

91 ((), PushEvent) ->

84 m ()

92 m ()

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

86 let repo = evPushRepository ev

94 let repo = evPushRepository ev

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

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

88 fullRepoName = whRepoFullName repo

96 fullRepoName = whRepoFullName repo

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

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

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

99+ _ -> throwError err422

90− Just sha = evPushHeadSha ev

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

91 tasks <- getTasks

101 tasks <- getTasks

92 let task =

102 let task =

93 M.lookupMax $

103 M.lookupMax $

94 M.takeWhileAntitone (repoName >) tasks

104 M.takeWhileAntitone (repoName >) tasks

95 case task of

105 case task of

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

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

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

98− createSubmission $

120+ createSubmission $

99− Submission

121+ Submission

100− user

122+ user

101− (T.unpack fullRepoName)

123+ (T.unpack fullRepoName)

102− (T.unpack name)

124+ (T.unpack name)

103− (T.unpack sha)

125+ (T.unpack sha)

104− (Jsonb BuildScheduled)

126+ (Jsonb BuildScheduled)

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

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

106− liftIO $ do

128+ logInfo . T.pack . show $ ev

107− print ev

108− hFlush stdout

109 _ -> return ()

129 _ -> return ()

110

130

111retestSubmission ::

131retestSubmission ::

112− (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) =>

113 String ->

133 String ->

114 String ->

134 String ->

115 String ->

135 String ->

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

128 M.takeWhileAntitone (repoName' >) tasks

148 M.takeWhileAntitone (repoName' >) tasks

129 case task of

149 case task of

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

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

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

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

132 updateSubmissionStatus fullRepoName sha BuildScheduled

152 updateSubmissionStatus fullRepoName sha BuildScheduled

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

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

134 _ -> return ()

154 _ -> return ()

135 redirectToSubmission owner repoName sha

155 redirectToSubmission owner repoName sha

136

156

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

148 MonadUnliftIO

168 MonadUnliftIO

149 )

169 )

150

170

171+instance MonadError ServerError (ServerM schema) where

172+ throwError = throwIO

173+ catchError = catch

174+

151server :: ServerT API (ServerM Schema)

175server :: ServerT API (ServerM Schema)

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

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

153

177

154−runServer :: IO ()

178+runServer :: FilePath -> IO ()

155−runServer = do

179+runServer config = do

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

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

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

158 auth <- mkInstallationAuth (AppAuth appId appPkPem) installationId

186 auth <- mkInstallationAuth (AppAuth appId appPkPem) installationId

159 ts <- newIORef mempty

187 ts <- newIORef mempty

160 pool <- createConnectionPool databseUrl 1 0.5 10

188 pool <- createConnectionPool databseUrl 1 0.5 10

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

164 let context =

192 let context =

165 gitPolyHubKey (return webhookSecret)

193 gitPolyHubKey (return webhookSecret)

166 :. EmptyContext

194 :. EmptyContext

167− serverData = ServerData

195+ serverData =

196+ ServerData

168− { githubAppAuth = auth,

197+ { githubAppAuth = auth,

169− githubUserName = GithubUserName githubUsername,

170− githubAccessToken = GithubAccessToken personalAccessToken,

171− tasks = ts,

198+ tasks = ts,

172− logger = cfilter ((logSeverity <=) . msgSeverity) richMessageAction,

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

173− baseUrl = baseSiteUrl,

200+ baseUrl = baseSiteUrl,

174− dockerUrl = T.pack cfgDockerUrl

201+ dockerUrl = T.pack cfgDockerUrl,

202+ context = githubContext

175− }

203+ }

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

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

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

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

178 repeatIfNotEmpty n f

206 repeatIfNotEmpty n f

179− _ <-

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

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

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

181 . usingConnectionPool pool

216 . usingConnectionPool pool

182 . (`runReaderT` serverData)

217 . (`runReaderT` serverData)

183 . unApp

218 . unApp

219+ . printingErrors

184− $ runTasks @'[Build] 1

220+ $ runTasks @'[Build] 1

185 _ <-

221 _ <-

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

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

187 . usingConnectionPool pool

223 . usingConnectionPool pool

188 . (`runReaderT` serverData)

224 . (`runReaderT` serverData)

189 . unApp

225 . unApp

226+ . printingErrors

190 $ runTasks @'[StatusUpdate] 5

227 $ runTasks @'[StatusUpdate] 5

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

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

192 hoistServerWithContext

229 hoistServerWithContext

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

204data ServerData m

241data ServerData m

205 = ServerData

242 = ServerData

206 { githubAppAuth :: !InstallationAuth,

243 { githubAppAuth :: !InstallationAuth,

207− githubUserName :: !GithubUserName,

208− githubAccessToken :: !GithubAccessToken,

209 tasks :: IORef TasksConfig,

244 tasks :: IORef TasksConfig,

210 logger :: LogAction m Message,

245 logger :: LogAction m Message,

211− baseUrl :: String,

246+ baseUrl :: T.Text,

212− dockerUrl :: T.Text

247+ dockerUrl :: T.Text,

248+ context :: T.Text

213 }

249 }

214

250

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

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

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

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

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

221 getContextEntry (PolyGitHubKey x :. _) = x

257 getContextEntry (PolyGitHubKey x :. _) = x

222

258

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

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

224−

260+ getGithubInstallationToken =

225− getGithubAccessToken = asks githubAccessToken

261+ either

226−

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

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

228

271

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

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

230 appRequest req = do

273 appRequest req = do

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

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

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

238 getTasks = asks tasks >>= liftIO . readIORef

281 getTasks = asks tasks >>= liftIO . readIORef

239

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+

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

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

241 getDockerUrl = asks dockerUrl

349 getDockerUrl = asks dockerUrl

242

350

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

245data TaskConfig

353data TaskConfig

246 = TaskConfig

354 = TaskConfig

247 { prebuild :: String,

355 { prebuild :: String,

248− dockerfile :: String

356+ dockerfile :: String,

249− -- build :: T.Text

357+ timeoutMinutes :: Int,

358+ deadline :: UTCTime

250 }

359 }

251 deriving stock (Show, Eq, Generic)

360 deriving stock (Show, Eq, Generic)

252 deriving anyclass (FromJSON, ToJSON)

361 deriving anyclass (FromJSON, ToJSON)

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

255 getTasks :: m TasksConfig

364 getTasks :: m TasksConfig

256

365

257instance HasLog (ServerData m) Message m where

366instance HasLog (ServerData m) Message m where

258−

259 getLogAction :: ServerData m -> LogAction m Message

367 getLogAction :: ServerData m -> LogAction m Message

260 getLogAction = logger

368 getLogAction = logger

261 {-# INLINE getLogAction #-}

369 {-# INLINE getLogAction #-}

src/Server/Config.hs+72−35

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

3module Server.Config

4 ( Config (..),

5+ defaultConfig,

5 getConfig,

6 getConfig,

6 )

7 )

7where

8where

9import Colog

10import Colog

10−import Crypto.PubKey.RSA (PrivateKey)

11import Crypto.PubKey.RSA.Read

12−import Data.ByteString as BS

12+import Data.Aeson as A

13−import qualified Data.ByteString.Char8 as BS8

13+import Data.ByteString.Char8 as BS

14+import Data.Text as T

14−import Data.Maybe

15+import Data.Yaml

16+import GHC.Generics

15import GitHub.Data.Apps

17import GitHub.Data.Apps

16import GitHub.Data.Id

18import GitHub.Data.Id

17import GitHub.Data.Installations

19import GitHub.Data.Installations

18−import System.Environment

20+import Text.Read (readMaybe)

20data Config

22data Config

21 = Config

23 = Config

22 { webhookSecret :: !ByteString,

24 { webhookSecret :: !ByteString,

23 appId :: !(Id App),

25 appId :: !(Id App),

24− appPkPem :: !PrivateKey,

26+ appPkPemPath :: !FilePath,

25 port :: !Int,

27 port :: !Int,

26 installationId :: !(Id Installation),

28 installationId :: !(Id Installation),

27− personalAccessToken :: !String,

28− githubUsername :: !String,

29 tasksPath :: !FilePath,

30 databseUrl :: !ByteString,

31− baseSiteUrl :: !String,

31+ baseSiteUrl :: !Text,

32 cfgDockerUrl :: !String,

33− cfgDockerFile :: !FilePath,

34− logSeverity :: !Severity

33+ logSeverity :: !Severity,

34+ builderCount :: !Int,

35+ githubContext :: !Text

35 }

36 }

36− deriving (Show)

37+ deriving (Show, Generic)

38−getConfig :: IO Config

39+instance FromJSON ByteString where

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

40 Config

59 Config

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

60+ { webhookSecret = "GITHUB SECRET",

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

61+ appId = Id 69,

43− <*> readPem

62+ appPkPemPath = "PRIVATE KEY PATH",

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

63+ port = 8080,

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

64+ installationId = Id 69,

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

65+ tasksPath = "TASKS PATH",

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

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

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

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

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

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

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

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

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

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

53− <*> (maybe Info read <$> lookupEnv "LOG_SEVERITY")

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

54− where

91+-- where

55− readPem :: IO PrivateKey

92+-- readPem :: IO PrivateKey

56− readPem = do

93+-- readPem = do

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

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

58− pem <- BS.readFile path

95+-- pem <- BS.readFile path

59− case readRsaPem pem of

96+-- case readRsaPem pem of

60− Right k -> return k

97+-- Right k -> return k

61− Left e -> error (show e)

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

63deriving instance Show ReadRsaKeyError

100deriving instance Show ReadRsaKeyError

src/Server/Html.hs+14−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,17 +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 qualified Data.ByteString.Lazy.Char8 as BS

15import Data.Foldable

14import Data.Foldable

16import qualified Data.Map as M

15import qualified Data.Map as M

17import Data.String

16import Data.String

18import Data.Submission

17import Data.Submission

19import Data.Submission.Query

18import Data.Submission.Query

20import qualified Data.Text as T

19import qualified Data.Text as T

21−import GHC.Generics

22import Server.Schema

20import Server.Schema

23import Squeal.PostgreSQL (Jsonb (..))

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

24import Text.Blaze

22import Text.Blaze

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

32 String ->

30 String ->

33 String ->

31 String ->

34 m Markup

32 m Markup

35−getSubmissionR user repo sha = do

33+getSubmissionR user repo sha' = do

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

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

37 let restartBuild = do

35 let restartBuild = do

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

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

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

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

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

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

41 Nothing ->

39 Nothing ->

42 return . ("Not found",) $

40 return . ("Not found",) $

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

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

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

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

45 H.h1 $ toHtml problem

43 H.h1 $ toHtml problem

46 H.h2 $ toHtml userName

44 H.h2 $ toHtml userName

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

47 case status of

46 case status of

48 Jsonb BuildScheduled -> do

47 Jsonb BuildScheduled -> do

49− H.h3 "Waiting to build"

48+ H.h3 "Waiting to build ⌛"

50 restartBuild

49 restartBuild

51 Jsonb (SubmissionFailed err) -> do

50 Jsonb (SubmissionFailed err) -> do

52− H.h3 "Failed to build"

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

53 restartBuild

52 restartBuild

54 H.code . H.pre $ toHtml err

53 H.code . H.pre $ toHtml err

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

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

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

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

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

58 H.h3 . toHtml $

57 H.h3 . toHtml $

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

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

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

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

61 restartBuild

60 restartBuild

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

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

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

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

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

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

64+ Jsonb PastDeadline ->

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

65 return . docTypeHtml $ do

66 return . docTypeHtml $ do

66 H.head $ do

67 H.head $ do

67 H.title $ toHtml titleText

68 H.title $ toHtml titleText

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

94 H.body inner

95 H.body inner

96class MonadHasBaseUrl m where

97class MonadHasBaseUrl m where

97− getBaseUrl :: m String

98+ getBaseUrl :: m T.Text

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

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

100getUrl fullName sha = do

101getUrl fullName sha = do

101 siteBase <- getBaseUrl

102 siteBase <- getBaseUrl

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

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

103

104

104redirectToSubmission ::

105redirectToSubmission ::

105 (MonadHasBaseUrl m, Monad m) =>

106 (MonadHasBaseUrl m, Monad m) =>

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