master..5b41806 · sc-build

git.iko.soy/sc-build

on 5b41806 help sign in

.gitignore−1

since splitsnapshots

unifiedsplit

@@ -1,2 +1 @@

1.stack-work

2−*.cabal

README.mddeleted−64

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

1−# sc-build

2−

3−Need both manual weebohook and app.

4−

5−Installation id needs to be configured manually.

6−

7−## Usage

8−

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

10−

11−

12−Exmaple:

13−

14−```dockerfile

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

16−

17−RUN stack update

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

19−

20−WORKDIR /

21−```

22−

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

24−

25−```bash

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

27−```

28−

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

30−

31−```yaml

32−test-task:

33− prebuild: |

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

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

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

37− dockerfile: |

38− FROM fast-lts-14.27

39− COPY . src

40− WORKDIR /src

41− ENTRYPOINT stack test --fast

42− timeoutMinutes: 10

43−```

44−

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

46−

47−```json

48−{

49− "test1": true,

50− "test2": false

51−}

52−```

53−

54−For macos docker API:

55−

56−```bash

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

58−```

59−

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

61−

62−```bash

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

64−```

app/Main.hs+1−25

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

1module Main (main) where

3−import qualified Data.ByteString.Char8 as BS

4−import Data.Yaml (encode)

5−import Options.Applicative

6import Server

3import Server

7−import Server.Config

9main :: IO ()

5main :: IO ()

10−main =

6+main = runServer

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,7 +17,6 @@ dependencies:

17library:

18 source-dirs: src

19 dependencies:

20− - http-client-tls

21 - servant

20 - servant

22 - servant-server

21 - servant-server

23 - process

22 - process

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

50 - docker

49 - docker

51 - exceptions

50 - exceptions

52 - transformers

51 - transformers

53− - cassava

54− - http-media

55− - utf8-string

57executables:

53executables:

58 sc-build-exe:

54 sc-build-exe:

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

64 - -with-rtsopts=-N

60 - -with-rtsopts=-N

65 dependencies:

61 dependencies:

66 - sc-build

62 - sc-build

67− - bytestring

68− - yaml

69− - optparse-applicative

70 sc-build-migrations:

63 sc-build-migrations:

71 main: Main.hs

64 main: Main.hs

72 source-dirs: migrations

65 source-dirs: migrations

sc-build.cabalnew file+106

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

1+cabal-version: 1.12

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

4+--

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

6+--

7+-- hash: 56eccc7f4958f234614ddcff75d3b965ad9a29747591e1e71b73d56faaf48d1c

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

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

1module Control.GithubCloner

2+ ( GithubAccessToken (..),

3+ GithubUserName (..),

2− ( GithubCloner (..),

4+ GithubCloner (..),

3− InstallationToken (..),

4 )

5 )

5where

6where

7−newtype InstallationToken = InstallationToken String

8+newtype GithubAccessToken = GithubAccessToken String

10+newtype GithubUserName = GithubUserName String

9class GithubCloner m where

12class GithubCloner m where

10− getGithubInstallationToken :: m InstallationToken

13+

14+ getGithubAccessToken :: m GithubAccessToken

15+

16+ getGithubUserName :: m GithubUserName

src/Control/HasGithubStatus.hsdeleted−14

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

1−module Control.HasGithubStatus

2− ( HasGithubStatus (..),

3− )

4−where

5−

6−import Colog

7−import Data.Submission

8−import GitHub.Data

9−

10−class HasGithubStatus m where

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

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

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

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

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

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

3module Control.Task.Scheduler

4 ( scheduleTask,

5 runTasks,

6− makeAllRunnable,

7 )

6 )

8where

7where

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

21import GHC.TypeLits

20import GHC.TypeLits

22import Server.Schema

21import Server.Schema

23import Squeal.PostgreSQL

22import Squeal.PostgreSQL

24−import UnliftIO.Exception

26scheduleTask ::

24scheduleTask ::

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

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

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

47rescheduleTaskTime = rescheduleTaskQuery

45rescheduleTaskTime = rescheduleTaskQuery

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

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

48+

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

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

52 taskNames :: [String]

51 taskNames :: [String]

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

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

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

57 RunTasks (t ': tt) m

56 RunTasks (t ': tt) m

58 where

57 where

58+

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

60 case fromJSON @t v of

61 A.Error e ->

@@ -67,9 +67,7 @@ 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 `catchAny` \e -> do

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

71− logError . T.pack . displayException $ e

72− return Failure

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

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

74 case r of

72 case r of

75 Success -> completeTaskQuery t

73 Success -> completeTaskQuery t

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

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

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

83instance RunTasks '[] m where

81instance RunTasks '[] m where

82+

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

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

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

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

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

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

5 completeTaskQuery,

6 rescheduleTaskQuery,

7 pickTasksQuery,

8− makeAllRunnable,

9 PickedTask (..),

8 PickedTask (..),

10 )

9 )

11where

10where

13import Colog

12import Colog

14−import Control.Arrow

15import Control.Monad.IO.Unlift

13import Control.Monad.IO.Unlift

16import Control.Squeal

14import Control.Squeal

17import Control.Task

15import Control.Task

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

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

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

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

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

42 :* Default `as` #creation_time

40 :* Default `as` #creation_time

43− :* Default `as` #started

44− :* Default `as` #failures

45 )

41 )

46 ( OnConflict

42 ( OnConflict

47 (OnConstraint #pk_task_payload)

43 (OnConstraint #pk_task_payload)

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

86 query =

82 query =

87 update_

83 update_

88 #tasks

84 #tasks

89− ( Default `as` #creation_time

85+ (Default `as` #creation_time)

90− :* Default `as` #started

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

92− )

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

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

94 dbWrite (const $ return ()) $

87 dbWrite (const $ return ()) $

95 manipulateParams_

88 manipulateParams_

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

103 Word64 ->

96 Word64 ->

104 m [PickedTask]

97 m [PickedTask]

105pickTasksQuery tasks limitCount = do

98pickTasksQuery tasks limitCount = do

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

99+ logDebug "reading tasks"

107 let query :: Query_ Schema () PickedTask

100 let query :: Query_ Schema () PickedTask

108 query =

101 query =

109 select_

102 select_

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

113 )

106 )

114 ( from (table #tasks)

107 ( from (table #tasks)

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

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

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

117− & where_ (#failures .< 20)

118 & orderBy [#creation_time & Asc]

109 & orderBy [#creation_time & Asc]

119 & limit limitCount

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

127 )

111 )

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

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

112+ dbRead (const $ return []) $

130− pickedTasks <- runQuery query >>= getRows

113+ runQuery query >>= getRows

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

132− return pickedTasks

133

114

134data PickedTask

115data PickedTask

135 = PickedTask

116 = PickedTask

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

138 creationTime :: UTCTime

119 creationTime :: UTCTime

139 }

120 }

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

121 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,7 +29,6 @@ data SubmissionStatus

29 = SubmissionRun TestResult

30 | SubmissionFailed String

31 | BuildScheduled

32− | PastDeadline

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

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

35newtype TestResult

34newtype TestResult

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

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

8where

10import Colog

11−import Control.Concurrent

12import Control.GithubCloner

11import Control.GithubCloner

13−import Control.HasGithubStatus

14import Control.Monad.Except

12import Control.Monad.Except

15import Control.Monad.IO.Unlift

13import Control.Monad.IO.Unlift

16import Control.Task

14import Control.Task

15+import Control.Task.Scheduler

17import Data.Aeson hiding (Success)

16import Data.Aeson hiding (Success)

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

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

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

18+import qualified Data.Map as M

20import Data.String

19import Data.String

21import Data.Submission

20import Data.Submission

22import Data.Submission.Query

21import 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,7 +30,6 @@ import System.Directory

30import System.Exit

31import System.Process.Typed

32import System.Random

33−import UnliftIO.Async

34import UnliftIO.Exception

33import UnliftIO.Exception

36data Build

35data Build

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

39 dockerFile :: String,

38 dockerFile :: String,

40 owner :: Name Owner,

39 owner :: Name Owner,

41 repoName :: Name Repo,

40 repoName :: Name Repo,

42− sha :: Name Commit,

41+ sha :: Name Commit

43− timeoutMinutes :: Int

44 }

42 }

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

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

47instance Task Build "build-repo" where

45instance Task Build "build-repo" where

48− type

49− TaskMonad Build m =

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

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

52 performTask Build {..} =

48 performTask Build {..} =

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

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

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

51+ sha' = T.unpack $ untagName sha

54 cloneRepo fullRepoName sha' dir

52 cloneRepo fullRepoName sha' dir

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

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

56 case shellCode of

54 case shellCode of

57 ExitFailure n -> do

55 ExitFailure n -> do

58− let err = BS.toString shellErr

56+ let err = BS.unpack shellErr

59 logError . T.pack $

57 logError . T.pack $

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

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

61 <> show sha

59 <> show sha

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

63 <> show n

61 <> show n

64 <> " and error "

62 <> " and error "

65 <> err

63 <> err

66− scheduleFailedStatus err owner repoName sha

64+ scheduleTask erroredTask

67 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

65 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

68 ExitSuccess -> do

66 ExitSuccess -> do

69 h <- liftIO D.defaultHttpHandler

67 h <- liftIO D.defaultHttpHandler

70 dUrl <- getDockerUrl

68 dUrl <- getDockerUrl

71 let opts = D.defaultCreateOpts imageName

69 let opts = D.defaultCreateOpts imageName

72− runDocker ::

70+ runDocker :: forall a m. MonadIO m => D.DockerT IO a -> m a

73− ( MonadIO m,

74− Exception err,

75− WithLog env Message m,

76− StaticPQ m,

77− MonadUnliftIO m,

78− HasGithubStatus m

79− ) =>

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

81− m a

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

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

83 imageName = T.pack dir

72 imageName = T.pack dir

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

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

85 absDir <- liftIO $ makeAbsolute dir

74 absDir <- liftIO $ makeAbsolute dir

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

87 D.waitContainer cid >>= \case

76 D.waitContainer cid >>= \case

88 Left D.GenericDockerError {} -> waitDockerForever cid

77 Left D.GenericDockerError {} -> waitDockerForever cid

89 a -> return a

78 a -> return a

90− cid <- runDocker . runExceptT $ do

79+ dockerRes <- runDocker . runExceptT $ do

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

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

92− ExceptT $ D.createContainer opts Nothing

81+ cid <- ExceptT $ D.createContainer opts Nothing

93− dockerRes <- fmap (either id id)

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

95− $ flip

96− finally

97− ( runDocker $

98− D.deleteContainer

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

100− cid

101− )

102− . runDocker

103− . runExceptT

104− $ do

105− ExceptT $ D.startContainer D.defaultStartOpts cid

82+ ExceptT $ D.startContainer D.defaultStartOpts cid

106− buildCode <- ExceptT $ waitDockerForever cid

83+ buildCode <- ExceptT $ waitDockerForever cid

107− buildOut <-

84+ buildOut <-

108− ExceptT $

85+ ExceptT $

109− D.getContainerLogs

86+ D.getContainerLogs

110− D.LogOpts

87+ D.LogOpts

111− { stdout = True,

88+ { stdout = True,

112− stderr = False,

89+ stderr = False,

113− since = Nothing,

90+ since = Nothing,

114− timestamps = False,

91+ timestamps = False,

115− tail = D.All

92+ tail = D.All

116− }

93+ }

117− cid

118− buildErr <-

119− ExceptT $

120− D.getContainerLogs

121− D.LogOpts

122− { stdout = True,

123− stderr = True,

124− since = Nothing,

125− timestamps = False,

126− tail = D.All

127− }

128− cid

94+ cid

129− return (buildCode, buildOut, buildErr)

95+ return (buildCode, buildOut)

130 case dockerRes of

96 case dockerRes of

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

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

132− let err = BS.toString buildErr

98+ let err = BS.unpack buildOut

133 logError . T.pack $

99 logError . T.pack $

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

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

135 <> show sha

101 <> show sha

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

137 <> show n

103 <> show n

138 <> " and error "

104 <> " and error "

139 <> err

105 <> err

140− scheduleFailedStatus err owner repoName sha

106+ scheduleTask erroredTask

141 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

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

142− (ExitSuccess, buildOut, _) ->

113+ Right (ExitSuccess, buildOut) ->

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

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

144 Left err' -> do

115 Left err' -> do

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

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

146 logError . T.pack $

117 logError . T.pack $

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

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

148 <> " at sha "

119 <> " at sha "

149 <> show sha

120 <> show sha

150 <> ": "

121 <> ": "

151 <> err

122 <> err

152− scheduleFailedStatus err owner repoName sha

123+ scheduleTask erroredTask

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

124+ updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

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

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

155− scheduleTestedStatus testResult owner repoName sha

126+ let total = M.size tests

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

156 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

139 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

157 return Success

140 return Success

158 where

141 where

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

142+ statusTask = StatusUpdate owner repoName sha

160− sha' = T.unpack $ untagName sha

143+ erroredTask =

161− runEither ::

144+ statusTask $

162− ( Exception err,

145+ NewStatus

163− WithLog env Message m,

146+ { newStatusState = StatusError,

164− StaticPQ m,

147+ newStatusTargetUrl = Nothing,

165− MonadUnliftIO m,

148+ newStatusDescription = Just "Build failed",

166− HasGithubStatus m

149+ newStatusContext = Nothing

167− ) =>

150+ }

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

177

151

178createDir :: MonadIO m => m FilePath

152createDir :: MonadIO m => m FilePath

179createDir = do

153createDir = do

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

183

157

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

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

185cloneRepo repoName sha path = do

159cloneRepo repoName sha path = do

186− InstallationToken token <- getGithubInstallationToken

160+ GithubAccessToken token <- getGithubAccessToken

161+ GithubUserName username <- getGithubUserName

187 runProcess_ . setWorkingDir path . fromString $

162 runProcess_ . setWorkingDir path . fromString $

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

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

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

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

190 return ()

165 return ()

191

166

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

197

172

198class HasDockerInfo m where

173class HasDockerInfo m where

199 getDockerUrl :: m T.Text

174 getDockerUrl :: m T.Text

200−

201−instance Exception D.DockerError

src/Data/Tasks/StatusUpdate.hs+1

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

31 <*> v .:? "context"

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

34+

34 type TaskMonad StatusUpdate m = (AppRequestable m)

35 type TaskMonad StatusUpdate m = (AppRequestable m)

36 performTask StatusUpdate {..} = do

37 performTask StatusUpdate {..} = do

src/Server.hs+57−165

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

10import Control.AppRequestable

11import Control.Concurrent

12import Control.GithubCloner

13−import Control.HasGithubStatus

14import Control.Monad.Except

13import Control.Monad.Except

15import Control.Monad.IO.Unlift

14import Control.Monad.IO.Unlift

16import Control.Monad.Reader

15import Control.Monad.Reader

17import Control.Task.Scheduler

16import Control.Task.Scheduler

18−import Crypto.PubKey.RSA.Read

19import Data.Aeson

17import Data.Aeson

20import Data.ByteString

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

24import qualified Data.Csv as Csv

19import qualified Data.Csv as Csv

25import Data.IORef

20import Data.IORef

26import Data.Map (Map)

21import Data.Map (Map)

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

30import Data.Tasks.Build

25import Data.Tasks.Build

31import Data.Tasks.StatusUpdate

26import Data.Tasks.StatusUpdate

32import qualified Data.Text as T

27import qualified Data.Text as T

33−import Data.Time.Clock

34import Data.Yaml

28import Data.Yaml

35import GHC.Generics

29import GHC.Generics

36import GitHub hiding (Accept)

30import GitHub hiding (Accept)

37import GitHub.App.Auth

31import GitHub.App.Auth

38import GitHub.App.Request

32import GitHub.App.Request

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

40import GitHub.Data.Name

33import GitHub.Data.Name

41import GitHub.Data.Webhooks.Events

34import GitHub.Data.Webhooks.Events

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

35+import GitHub.Data.Webhooks.Payload

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

44import Network.HTTP.Media.MediaType

36import Network.HTTP.Media.MediaType

45import Network.Wai.Handler.Warp

37import Network.Wai.Handler.Warp

46import Servant

38import Servant

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

50import Server.Html

42import Server.Html

51import Server.Schema

43import Server.Schema

52import Squeal.PostgreSQL

44import Squeal.PostgreSQL

45+import System.IO

53import Text.Blaze.Html

46import Text.Blaze.Html

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

47+import UnliftIO.Exception (try)

56type API =

49type API =

57 "github-webhook"

50 "github-webhook"

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

59 :> GitHubSignedReqBody '[JSON] InstallationEvent

52 :> GitHubSignedReqBody '[JSON] InstallationEvent

60 :> Post '[JSON] ()

53 :> Post '[JSON] ()

61 :<|> GitHubEvent '[ 'WebhookPushEvent]

54 :<|> GitHubEvent '[ 'WebhookPushEvent]

62− :> GitHubSignedReqBody '[JSON] PushEvent

55+ :> GitHubSignedReqBody '[JSON] PushEvent

63− :> Post '[JSON] ()

56+ :> Post '[JSON] ()

64 )

57 )

65 :<|> "submission"

58 :<|> "submission"

66 :> Capture "user name" String

59 :> Capture "user name" String

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

75 :> Post '[HTML] Markup

68 :> Post '[HTML] Markup

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

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

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

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

79webhookInstallation _ ((), ev) =

72webhookInstallation _ ((), ev) =

80− logInfo . T.pack . show $ ev

73+ liftIO $ do

74+ print ev

75+ hFlush stdout

76+

77+pendingStatus :: NewStatus

78+pendingStatus = NewStatus StatusPending Nothing Nothing Nothing

82webhookPushEvent ::

80webhookPushEvent ::

83− ( StaticPQ m,

84− MonadReader (ServerData m) m,

85− MonadUnliftIO m,

86− HasTasks m,

87− MonadError ServerError m,

88− WithLog env Message m

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

89− ) =>

90 RepoWebhookEvent ->

82 RepoWebhookEvent ->

91 ((), PushEvent) ->

83 ((), PushEvent) ->

92 m ()

84 m ()

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

94 let repo = evPushRepository ev

86 let repo = evPushRepository ev

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

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

96 fullRepoName = whRepoFullName repo

88 fullRepoName = whRepoFullName repo

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

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

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

99− _ -> throwError err422

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

90+ Just sha = evPushHeadSha ev

101 tasks <- getTasks

91 tasks <- getTasks

102 let task =

92 let task =

103 M.lookupMax $

93 M.lookupMax $

104 M.takeWhileAntitone (repoName >) tasks

94 M.takeWhileAntitone (repoName >) tasks

105 case task of

95 case task of

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

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

107− nowTime <- liftIO getCurrentTime

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

108− if nowTime > deadline

109− then do

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

111− createSubmission $

98+ createSubmission $

112− Submission

99+ Submission

113− user

100+ user

114− (T.unpack fullRepoName)

101+ (T.unpack fullRepoName)

115− (T.unpack name)

102+ (T.unpack name)

116− (T.unpack sha)

103+ (T.unpack sha)

117− (Jsonb PastDeadline)

118− else do

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

120− createSubmission $

121− Submission

122− user

123− (T.unpack fullRepoName)

124− (T.unpack name)

125− (T.unpack sha)

126− (Jsonb BuildScheduled)

104+ (Jsonb BuildScheduled)

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

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

128− logInfo . T.pack . show $ ev

106+ liftIO $ do

107+ print ev

108+ hFlush stdout

129 _ -> return ()

109 _ -> return ()

130

110

131retestSubmission ::

111retestSubmission ::

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

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

133 String ->

113 String ->

134 String ->

114 String ->

135 String ->

115 String ->

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

148 M.takeWhileAntitone (repoName' >) tasks

128 M.takeWhileAntitone (repoName' >) tasks

149 case task of

129 case task of

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

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

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

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

152 updateSubmissionStatus fullRepoName sha BuildScheduled

132 updateSubmissionStatus fullRepoName sha BuildScheduled

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

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

154 _ -> return ()

134 _ -> return ()

155 redirectToSubmission owner repoName sha

135 redirectToSubmission owner repoName sha

156

136

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

168 MonadUnliftIO

148 MonadUnliftIO

169 )

149 )

170

150

171−instance MonadError ServerError (ServerM schema) where

172− throwError = throwIO

173− catchError = catch

174−

175server :: ServerT API (ServerM Schema)

151server :: ServerT API (ServerM Schema)

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

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

177

153

178−runServer :: FilePath -> IO ()

154+runServer :: IO ()

179−runServer config = do

155+runServer = do

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

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

181 print c

157 print c

182− pem <- BS.readFile appPkPemPath

183− appPkPem <- case readRsaPem pem of

184− Right k -> return k

185− Left e -> error (show e)

186 auth <- mkInstallationAuth (AppAuth appId appPkPem) installationId

158 auth <- mkInstallationAuth (AppAuth appId appPkPem) installationId

187 ts <- newIORef mempty

159 ts <- newIORef mempty

188 pool <- createConnectionPool databseUrl 1 0.5 10

160 pool <- createConnectionPool databseUrl 1 0.5 10

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

192 let context =

164 let context =

193 gitPolyHubKey (return webhookSecret)

165 gitPolyHubKey (return webhookSecret)

194 :. EmptyContext

166 :. EmptyContext

195− serverData =

167+ serverData = ServerData

196− ServerData

197− { githubAppAuth = auth,

168+ { githubAppAuth = auth,

169+ githubUserName = GithubUserName githubUsername,

170+ githubAccessToken = GithubAccessToken personalAccessToken,

198− tasks = ts,

171+ tasks = ts,

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

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

200− baseUrl = baseSiteUrl,

173+ baseUrl = baseSiteUrl,

201− dockerUrl = T.pack cfgDockerUrl,

174+ dockerUrl = T.pack cfgDockerUrl

202− context = githubContext

203− }

175+ }

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

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

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

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

206 repeatIfNotEmpty n f

178 repeatIfNotEmpty n f

207− printingErrors =

179+ _ <-

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

209− usingConnectionPool pool

210− . (`runReaderT` serverData)

211− . unApp

212− . handleAny (error . displayException)

213− $ makeAllRunnable

214− replicateM_ builderCount

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

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

216 . usingConnectionPool pool

181 . usingConnectionPool pool

217 . (`runReaderT` serverData)

182 . (`runReaderT` serverData)

218 . unApp

183 . unApp

219− . printingErrors

220− $ runTasks @'[Build] 1

184+ $ runTasks @'[Build] 1

221 _ <-

185 _ <-

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

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

223 . usingConnectionPool pool

187 . usingConnectionPool pool

224 . (`runReaderT` serverData)

188 . (`runReaderT` serverData)

225 . unApp

189 . unApp

226− . printingErrors

227 $ runTasks @'[StatusUpdate] 5

190 $ runTasks @'[StatusUpdate] 5

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

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

229 hoistServerWithContext

192 hoistServerWithContext

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

241data ServerData m

204data ServerData m

242 = ServerData

205 = ServerData

243 { githubAppAuth :: !InstallationAuth,

206 { githubAppAuth :: !InstallationAuth,

207+ githubUserName :: !GithubUserName,

208+ githubAccessToken :: !GithubAccessToken,

244 tasks :: IORef TasksConfig,

209 tasks :: IORef TasksConfig,

245 logger :: LogAction m Message,

210 logger :: LogAction m Message,

246− baseUrl :: T.Text,

211+ baseUrl :: String,

247− dockerUrl :: T.Text,

212+ dockerUrl :: T.Text

248− context :: T.Text

249 }

213 }

250

214

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

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

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

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

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

257 getContextEntry (PolyGitHubKey x :. _) = x

221 getContextEntry (PolyGitHubKey x :. _) = x

258

222

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

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

260− getGithubInstallationToken =

224+

261− either

225+ getGithubAccessToken = asks githubAccessToken

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

226+

263− return

227+ getGithubUserName = asks githubUserName

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

271

228

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

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

273 appRequest req = do

230 appRequest req = do

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

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

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

281 getTasks = asks tasks >>= liftIO . readIORef

238 getTasks = asks tasks >>= liftIO . readIORef

282

239

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−

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

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

349 getDockerUrl = asks dockerUrl

241 getDockerUrl = asks dockerUrl

350

242

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

353data TaskConfig

245data TaskConfig

354 = TaskConfig

246 = TaskConfig

355 { prebuild :: String,

247 { prebuild :: String,

356− dockerfile :: String,

248+ dockerfile :: String

357− timeoutMinutes :: Int,

249+ -- build :: T.Text

358− deadline :: UTCTime

359 }

250 }

360 deriving stock (Show, Eq, Generic)

251 deriving stock (Show, Eq, Generic)

361 deriving anyclass (FromJSON, ToJSON)

252 deriving anyclass (FromJSON, ToJSON)

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

364 getTasks :: m TasksConfig

255 getTasks :: m TasksConfig

365

256

366instance HasLog (ServerData m) Message m where

257instance HasLog (ServerData m) Message m where

258+

367 getLogAction :: ServerData m -> LogAction m Message

259 getLogAction :: ServerData m -> LogAction m Message

368 getLogAction = logger

260 getLogAction = logger

369 {-# INLINE getLogAction #-}

261 {-# INLINE getLogAction #-}

src/Server/Config.hs+35−72

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

3module Server.Config

4 ( Config (..),

5− defaultConfig,

6 getConfig,

5 getConfig,

7 )

6 )

8where

7where

10import Colog

9import Colog

10+import Crypto.PubKey.RSA (PrivateKey)

11import Crypto.PubKey.RSA.Read

12−import Data.Aeson as A

13−import Data.ByteString.Char8 as BS

12+import Data.ByteString as BS

14−import Data.Text as T

13+import qualified Data.ByteString.Char8 as BS8

15−import Data.Yaml

14+import Data.Maybe

16−import GHC.Generics

17import GitHub.Data.Apps

15import GitHub.Data.Apps

18import GitHub.Data.Id

16import GitHub.Data.Id

19import GitHub.Data.Installations

17import GitHub.Data.Installations

20−import Text.Read (readMaybe)

18+import System.Environment

22data Config

20data Config

23 = Config

21 = Config

24 { webhookSecret :: !ByteString,

22 { webhookSecret :: !ByteString,

25 appId :: !(Id App),

23 appId :: !(Id App),

26− appPkPemPath :: !FilePath,

24+ appPkPem :: !PrivateKey,

27 port :: !Int,

25 port :: !Int,

28 installationId :: !(Id Installation),

26 installationId :: !(Id Installation),

27+ personalAccessToken :: !String,

28+ githubUsername :: !String,

29 tasksPath :: !FilePath,

30 databseUrl :: !ByteString,

31− baseSiteUrl :: !Text,

31+ baseSiteUrl :: !String,

32 cfgDockerUrl :: !String,

33+ cfgDockerFile :: !FilePath,

33− logSeverity :: !Severity,

34+ logSeverity :: !Severity

34− builderCount :: !Int,

35− githubContext :: !Text

36 }

35 }

37− deriving (Show, Generic)

36+ deriving (Show)

39−instance FromJSON ByteString where

38+getConfig :: IO Config

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

39+getConfig =

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 =

59 Config

40 Config

60− { webhookSecret = "GITHUB SECRET",

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

61− appId = Id 69,

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

62− appPkPemPath = "PRIVATE KEY PATH",

43+ <*> readPem

63− port = 8080,

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

64− installationId = Id 69,

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

65− tasksPath = "TASKS PATH",

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

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

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

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

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

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

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

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

69− logSeverity = Info,

70− builderCount = 2,

71− githubContext = "MY CI NAME"

72− }

73−

74−getConfig :: FilePath -> IO Config

75−getConfig = decodeFileThrow

76−

77−-- getConfig :: IO Config

78−-- getConfig =

79−-- Config

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

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

82−-- <*> readPem

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

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

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

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

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

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

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

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

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

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

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

91−-- where

54+ where

92−-- readPem :: IO PrivateKey

55+ readPem :: IO PrivateKey

93−-- readPem = do

56+ readPem = do

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

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

95−-- pem <- BS.readFile path

58+ pem <- BS.readFile path

96−-- case readRsaPem pem of

59+ case readRsaPem pem of

97−-- Right k -> return k

60+ Right k -> return k

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

61+ Left e -> error (show e)

100deriving instance Show ReadRsaKeyError

63deriving instance Show ReadRsaKeyError

src/Server/Html.hs+13−14

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

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

2−

3module Server.Html

1module Server.Html

4 ( getSubmissionR,

2 ( getSubmissionR,

5 MonadHasBaseUrl (..),

3 MonadHasBaseUrl (..),

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

11import Clay as C

9import Clay as C

12import Colog

10import Colog

11+import Control.Monad.IO.Class

13import Control.Monad.IO.Unlift

12import Control.Monad.IO.Unlift

13+import Data.Aeson hiding (Success)

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

14import Data.Foldable

15import Data.Foldable

15import qualified Data.Map as M

16import qualified Data.Map as M

16import Data.String

17import Data.String

17import Data.Submission

18import Data.Submission

18import Data.Submission.Query

19import Data.Submission.Query

19import qualified Data.Text as T

20import qualified Data.Text as T

21+import GHC.Generics

20import Server.Schema

22import Server.Schema

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

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

22import Text.Blaze

24import Text.Blaze

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

30 String ->

32 String ->

31 String ->

33 String ->

32 m Markup

34 m Markup

33−getSubmissionR user repo sha' = do

35+getSubmissionR user repo sha = do

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

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

35 let restartBuild = do

37 let restartBuild = do

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

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

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

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

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

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

39 Nothing ->

41 Nothing ->

40 return . ("Not found",) $

42 return . ("Not found",) $

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

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

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

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

43 H.h1 $ toHtml problem

45 H.h1 $ toHtml problem

44 H.h2 $ toHtml userName

46 H.h2 $ toHtml userName

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

46 case status of

47 case status of

47 Jsonb BuildScheduled -> do

48 Jsonb BuildScheduled -> do

48− H.h3 "Waiting to build ⌛"

49+ H.h3 "Waiting to build"

49 restartBuild

50 restartBuild

50 Jsonb (SubmissionFailed err) -> do

51 Jsonb (SubmissionFailed err) -> do

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

52+ H.h3 "Failed to build"

52 restartBuild

53 restartBuild

53 H.code . H.pre $ toHtml err

54 H.code . H.pre $ toHtml err

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

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

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

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

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

57 H.h3 . toHtml $

58 H.h3 . toHtml $

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

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

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

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

60 restartBuild

61 restartBuild

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

62 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 H.! A.align "right") . H.p $ toHtml testName

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

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

64− Jsonb PastDeadline ->

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

66 return . docTypeHtml $ do

65 return . docTypeHtml $ do

67 H.head $ do

66 H.head $ do

68 H.title $ toHtml titleText

67 H.title $ toHtml titleText

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

95 H.body inner

94 H.body inner

97class MonadHasBaseUrl m where

96class MonadHasBaseUrl m where

98− getBaseUrl :: m T.Text

97+ getBaseUrl :: m String

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

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

101getUrl fullName sha = do

100getUrl fullName sha = do

102 siteBase <- getBaseUrl

101 siteBase <- getBaseUrl

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

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

104

103

105redirectToSubmission ::

104redirectToSubmission ::

106 (MonadHasBaseUrl m, Monad m) =>

105 (MonadHasBaseUrl m, Monad m) =>

src/Server/Schema.hs+1−3

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

6where

8import Server.Schema.V1

9−import Server.Schema.V2

10import Squeal.PostgreSQL

9import Squeal.PostgreSQL

12type StaticPQ m = MonadPQ Schema m

11type StaticPQ m = MonadPQ Schema m

14−type Schema = SchemaV2

13+type Schema = SchemaV1

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

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

17migration =

16migration =

18 pureMigration schemaMigrationV1

17 pureMigration schemaMigrationV1

19− :>> pureMigration schemaMigrationV2

20 :>> Done

18 :>> Done

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

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

23 ]

22 ]

24 ),

23 ),

25 "submissions"

24 "submissions"

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

35 ]

34 ]

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

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

38−schemaMigrationV1 =

37+schemaMigrationV1 = Migration

39− Migration

40− { name = "v1",

38+ { name = "v1",

41− up =

39+ up =

42− createTable

40+ createTable

43− #tasks

41+ #tasks

44− ( notNullable text `as` #task

42+ ( notNullable text `as` #task

45− :* notNullable jsonb `as` #payload

43+ :* notNullable jsonb `as` #payload

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

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

45+ )

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

47+ >>> createTable

48+ #submissions

49+ ( notNullable text `as` #user_name

50+ :* notNullable text `as` #repo_full_name

51+ :* notNullable text `as` #problem

52+ :* notNullable text `as` #sha

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

53+ :* notNullable jsonb `as` #status

48 )

54 )

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

50− >>> createTable

51− #submissions

52− ( notNullable text `as` #user_name

53− :* notNullable text `as` #repo_full_name

54− :* notNullable text `as` #problem

55− :* notNullable text `as` #sha

56− :* notNullable jsonb `as` #status

57− )

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

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

59− >>> createIndexes,

56+ >>> createIndexes,

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

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

61− }

58+ }

62 where

59 where

63 createIndexes :: Definition sch sch

60 createIndexes :: Definition sch sch

64 createIndexes =

61 createIndexes =

src/Server/Schema/V2.hsdeleted−46

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

1−module Server.Schema.V2

2− ( SchemaV2,

3− schemaMigrationV2,

4− )

5−where

6−

7−import Data.Aeson

8−import Data.Int

9−import Data.Submission

10−import Data.Text (Text)

11−import Data.Time

12−import Server.Schema.V1

13−import Squeal.PostgreSQL

14−

15−type SchemaV2 =

16− Public

17− '[ "tasks"

18− ::: 'Table

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

20− ]

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

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

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

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

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

26− ]

27− ),

28− "submissions"

29− ::: 'Table

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

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

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

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

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

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

36− ]

37− )

38− ]

39−

40−schemaMigrationV2 :: Migration Definition SchemaV1 SchemaV2

41−schemaMigrationV2 =

42− Migration

43− { name = "v2",

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

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

46− }

stack.yaml+3−4

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

17#

18# resolver: ./custom-snapshot.yaml

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

20−resolver: lts-14.27

20+resolver: lts-14.19

22# User packages to be built.

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

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

40# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

41#

42extra-deps:

43−- github-0.25

43+- github-0.24

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

49- http-client-0.5.14

50- http-client-0.5.14

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

51− commit: 5cfdc4d7facd7043f530bce4ce0f0c57c923b029

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

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

54# flags: {}

53# flags: {}

tasks.yaml−1

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

8 COPY . src

9 WORKDIR /src

10 ENTRYPOINT stack test --fast

11− timeoutMinutes: 10