master..33713bd · sc-build

git.iko.soy/sc-build

on 33713bd 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−10

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

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

47 - blaze-markup

46 - blaze-markup

48 - blaze-html

47 - blaze-html

49 - clay

48 - clay

50− - docker

51− - exceptions

52− - transformers

53− - cassava

54− - http-media

55− - utf8-string

57executables:

50executables:

58 sc-build-exe:

51 sc-build-exe:

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

64 - -with-rtsopts=-N

57 - -with-rtsopts=-N

65 dependencies:

58 dependencies:

66 - sc-build

59 - sc-build

67− - bytestring

68− - yaml

69− - optparse-applicative

70 sc-build-migrations:

60 sc-build-migrations:

71 main: Main.hs

61 main: Main.hs

72 source-dirs: migrations

62 source-dirs: migrations

sc-build.cabalnew file+103

@@ -0,0 +1,103 @@

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: bb953e6231fcc3939bfe085afcd3e792cbc40462461bbe4fb82ae69f1796be4c

9+name: sc-build

10+version: 0.1.0.0

11+category: Web

12+homepage: https://github.com/ilyakooo0/sc-build#readme

13+author: Ilya Kostyuchenko

14+maintainer: ilyakooo0@gmail.com

15+copyright: Ilya Kostyuchenko

16+license: BSD3

17+license-file: LICENSE

18+build-type: Simple

19+extra-source-files:

20+ README.md

21+

22+library

23+ exposed-modules:

24+ Control.AppRequestable

25+ Control.GithubCloner

26+ Control.Squeal

27+ Control.Task

28+ Control.Task.Scheduler

29+ Control.Task.Scheduler.Query

30+ Data.Submission

31+ Data.Submission.Query

32+ Data.Tasks.Build

33+ Data.Tasks.StatusUpdate

34+ Server

35+ Server.Config

36+ Server.Html

37+ Server.Schema

38+ Server.Schema.V1

39+ other-modules:

40+ Paths_sc_build

41+ hs-source-dirs:

42+ src

43+ default-extensions: AllowAmbiguousTypes ConstraintKinds DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuantifiedConstraints RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances

44+ build-depends:

45+ aeson

46+ , base >=4.7 && <5

47+ , blaze-html

48+ , blaze-markup

49+ , bytestring

50+ , clay

51+ , co-log

52+ , containers

53+ , cryptonite

54+ , directory

55+ , generics-sop

56+ , github

57+ , github-app

58+ , github-webhooks

59+ , mtl

60+ , process

61+ , random

62+ , servant

63+ , servant-blaze

64+ , servant-github-webhook

65+ , servant-server

66+ , squeal-postgresql

67+ , text

68+ , time

69+ , typed-process

70+ , unliftio

71+ , unliftio-core

72+ , vector

73+ , warp

74+ , yaml

75+ default-language: Haskell2010

76+

77+executable sc-build-exe

78+ main-is: Main.hs

79+ other-modules:

80+ Paths_sc_build

81+ hs-source-dirs:

82+ app

83+ default-extensions: AllowAmbiguousTypes ConstraintKinds DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuantifiedConstraints RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances

84+ ghc-options: -threaded -rtsopts -with-rtsopts=-N

85+ build-depends:

86+ base >=4.7 && <5

87+ , sc-build

88+ default-language: Haskell2010

89+

90+executable sc-build-migrations

91+ main-is: Main.hs

92+ other-modules:

93+ Paths_sc_build

94+ hs-source-dirs:

95+ migrations

96+ default-extensions: AllowAmbiguousTypes ConstraintKinds DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuantifiedConstraints RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances

97+ ghc-options: -threaded -rtsopts -with-rtsopts=-N

98+ build-depends:

99+ base >=4.7 && <5

100+ , bytestring

101+ , sc-build

102+ , squeal-postgresql

103+ default-language: Haskell2010

src/Control/GithubCloner.hs+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−11

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

2 ( Submission (..),

3 SubmissionStatus (..),

4 TestResult (..),

5− Score (..),

6 )

5 )

7where

6where

9import Data.Aeson

8import Data.Aeson

10−import Data.Csv

11−import Data.Int

12import Data.Map (Map)

9import Data.Map (Map)

13import Data.Text (Text)

10import Data.Text (Text)

14import GHC.Generics (Generic)

11import GHC.Generics (Generic)

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

29 = SubmissionRun TestResult

26 = SubmissionRun TestResult

30 | SubmissionFailed String

27 | SubmissionFailed String

31 | BuildScheduled

28 | BuildScheduled

32− | PastDeadline

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

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

35newtype TestResult

31newtype TestResult

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

38 }

34 }

39 deriving stock (Eq, Show, Generic)

35 deriving stock (Eq, Show, Generic)

40 deriving anyclass (FromJSON, ToJSON)

36 deriving anyclass (FromJSON, ToJSON)

41−

42−data Score

43− = Score

44− { userName :: String,

45− score :: Int64

46− }

47− deriving (Eq, Show, Generic, SOP.Generic, SOP.HasDatatypeInfo, ToRecord)

src/Data/Submission/Query.hs−14

@@ -4,7 +4,6 @@ module Data.Submission.Query

4 ( createSubmission,

5 updateSubmissionStatus,

6 getSubmission,

7− getResults,

8 )

7 )

9where

8where

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

84 query

83 query

85 (repoFullName, sha)

84 (repoFullName, sha)

86 >>= firstRow

85 >>= firstRow

87−

88−getResults ::

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

90− String ->

91− m [Score]

92−getResults task = do

93− let query :: Query_ Schema (Only String) Score

94− query = UnsafeQuery "select a.user_name as \"userName\", max(a.correct) as score from (select (select count(*) as correct from jsonb_each_text(submissions.status -> 'contents' -> 'tests') where value = 'true'), user_name from submissions where problem = $1) as a group by user_name"

95− dbRead (const $ return []) $

96− runQueryParams

97− query

98− (Only task)

99− >>= getRows

src/Data/Tasks/Build.hs+46−114

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

4module Data.Tasks.Build

5 ( Build (..),

6− HasDockerInfo (..),

7 )

6 )

8where

7where

10import Colog

9import Colog

11−import Control.Concurrent

12import Control.GithubCloner

10import Control.GithubCloner

13−import Control.HasGithubStatus

11+import Control.Monad.IO.Class

14−import Control.Monad.Except

15import Control.Monad.IO.Unlift

12import Control.Monad.IO.Unlift

16import Control.Task

13import Control.Task

14+import Control.Task.Scheduler

17import Data.Aeson hiding (Success)

15import Data.Aeson hiding (Success)

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

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

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

17+import qualified Data.Map as M

20import Data.String

18import Data.String

21import Data.Submission

19import Data.Submission

22import Data.Submission.Query

20import Data.Submission.Query

21+import Data.Tasks.StatusUpdate

23import qualified Data.Text as T

22import qualified Data.Text as T

24import Data.Time.Clock.POSIX

23import Data.Time.Clock.POSIX

25−import qualified Docker.Client as D

26import GHC.Generics

24import GHC.Generics

27import GitHub

25import GitHub

28import Server.Schema

26import Server.Schema

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

30import System.Exit

28import System.Exit

31import System.Process.Typed

29import System.Process.Typed

32import System.Random

30import System.Random

33−import UnliftIO.Async

34import UnliftIO.Exception

31import UnliftIO.Exception

36data Build

33data Build

37 = Build

34 = Build

38 { preProcessShell :: String,

35 { preProcessShell :: String,

39− dockerFile :: String,

36+ buildCommand :: String,

40 owner :: Name Owner,

37 owner :: Name Owner,

41 repoName :: Name Repo,

38 repoName :: Name Repo,

42− sha :: Name Commit,

39+ sha :: Name Commit

43− timeoutMinutes :: Int

44 }

40 }

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

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

47instance Task Build "build-repo" where

43instance Task Build "build-repo" where

48− type

44+

49− TaskMonad Build m =

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

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

52 performTask Build {..} =

47 performTask Build {..} =

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

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

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

50+ sha' = T.unpack $ untagName sha

54 cloneRepo fullRepoName sha' dir

51 cloneRepo fullRepoName sha' dir

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

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

56 case shellCode of

53 case shellCode of

57 ExitFailure n -> do

54 ExitFailure n -> do

58− let err = BS.toString shellErr

55+ let err = BS.unpack shellErr

59 logError . T.pack $

56 logError . T.pack $

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

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

61 <> show sha

58 <> show sha

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

63 <> show n

60 <> show n

64 <> " and error "

61 <> " and error "

65 <> err

62 <> err

66− scheduleFailedStatus err owner repoName sha

63+ scheduleTask erroredTask

67 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

64 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

68 ExitSuccess -> do

65 ExitSuccess -> do

69− h <- liftIO D.defaultHttpHandler

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

70− dUrl <- getDockerUrl

67+ case buildCode of

71− let opts = D.defaultCreateOpts imageName

72− runDocker ::

73− ( MonadIO m,

74− Exception err,

75− WithLog env Message m,

76− StaticPQ m,

77− MonadUnliftIO m,

78− HasGithubStatus m

79− ) =>

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

81− m a

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

83− imageName = T.pack dir

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

85− absDir <- liftIO $ makeAbsolute dir

86− let waitDockerForever cid =

87− D.waitContainer cid >>= \case

88− Left D.GenericDockerError {} -> waitDockerForever cid

89− a -> return a

90− cid <- runDocker . runExceptT $ do

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

92− ExceptT $ D.createContainer opts Nothing

93− dockerRes <- fmap (either id id)

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

95− $ flip

96− finally

97− ( runDocker $

98− D.deleteContainer

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

100− cid

101− )

102− . runDocker

103− . runExceptT

104− $ do

105− ExceptT $ D.startContainer D.defaultStartOpts cid

106− buildCode <- ExceptT $ waitDockerForever cid

107− buildOut <-

108− ExceptT $

109− D.getContainerLogs

110− D.LogOpts

111− { stdout = True,

112− stderr = False,

113− since = Nothing,

114− timestamps = False,

115− tail = D.All

116− }

117− cid

118− buildErr <-

119− ExceptT $

120− D.getContainerLogs

121− D.LogOpts

122− { stdout = True,

123− stderr = True,

124− since = Nothing,

125− timestamps = False,

126− tail = D.All

127− }

128− cid

129− return (buildCode, buildOut, buildErr)

130− case dockerRes of

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

68+ ExitFailure n -> do

132− let err = BS.toString buildErr

69+ let err = BS.unpack buildErr

133 logError . T.pack $

70 logError . T.pack $

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

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

135 <> show sha

72 <> show sha

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

137 <> show n

74 <> show n

138 <> " and error "

75 <> " and error "

139 <> err

76 <> err

140− scheduleFailedStatus err owner repoName sha

77+ scheduleTask erroredTask

141 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

78 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

142− (ExitSuccess, buildOut, _) ->

79+ ExitSuccess ->

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

80+ case decode buildOut of

144− Left err' -> do

81+ Nothing -> do

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

82+ let err = BS.unpack buildOut

146 logError . T.pack $

83 logError . T.pack $

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

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

148 <> " at sha "

85 <> " at sha "

149 <> show sha

86 <> show sha

150 <> ": "

87 <> ": "

151 <> err

88 <> err

152− scheduleFailedStatus err owner repoName sha

89+ scheduleTask erroredTask

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

90+ updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

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

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

155− scheduleTestedStatus testResult owner repoName sha

92+ let total = M.size tests

93+ passed = M.size . M.filter id $ tests

94+ description = T.pack $ show passed <> "/" <> show total

95+ status = statusTask NewStatus

96+ { newStatusState =

97+ if total == passed then StatusSuccess else StatusFailure,

98+ newStatusTargetUrl = Nothing,

99+ newStatusDescription = Just description,

100+ newStatusContext = Nothing

101+ }

102+ scheduleTask status

156 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

103 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

157 return Success

104 return Success

158 where

105 where

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

106+ statusTask = StatusUpdate owner repoName sha

160− sha' = T.unpack $ untagName sha

107+ erroredTask = statusTask $ NewStatus

161− runEither ::

108+ { newStatusState = StatusError,

162− ( Exception err,

109+ newStatusTargetUrl = Nothing,

163− WithLog env Message m,

110+ newStatusDescription = Just "Build failed",

164− StaticPQ m,

111+ newStatusContext = Nothing

165− MonadUnliftIO m,

112+ }

166− HasGithubStatus m

167− ) =>

168− Either err b ->

169− m b

170− runEither (Left err) = do

171− let err' = show err

172− logError $ T.pack err'

173− scheduleFailedStatus err' owner repoName sha

174− updateSubmissionStatus fullRepoName sha' (SubmissionFailed err')

175− throwIO err

176− runEither (Right a) = return a

177

113

178createDir :: MonadIO m => m FilePath

114createDir :: MonadIO m => m FilePath

179createDir = do

115createDir = do

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

183

119

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

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

185cloneRepo repoName sha path = do

121cloneRepo repoName sha path = do

186− InstallationToken token <- getGithubInstallationToken

122+ GithubAccessToken token <- getGithubAccessToken

123+ GithubUserName username <- getGithubUserName

187 runProcess_ . setWorkingDir path . fromString $

124 runProcess_ . setWorkingDir path . fromString $

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

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

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

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

190 return ()

127 return ()

191

128

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

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

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

195 i <- randomIO @Int

132 i <- randomIO @Int

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

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

197−

198−class HasDockerInfo m where

199− getDockerUrl :: m T.Text

200−

201−instance Exception D.DockerError

src/Data/Tasks/StatusUpdate.hs+1

@@ -31,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−182

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

24−import qualified Data.Csv as Csv

25import Data.IORef

19import Data.IORef

26import Data.Map (Map)

20import Data.Map (Map)

27import qualified Data.Map as M

21import qualified Data.Map as M

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

30import Data.Tasks.Build

24import Data.Tasks.Build

31import Data.Tasks.StatusUpdate

25import Data.Tasks.StatusUpdate

32import qualified Data.Text as T

26import qualified Data.Text as T

33−import Data.Time.Clock

34import Data.Yaml

27import Data.Yaml

35import GHC.Generics

28import GHC.Generics

36−import GitHub hiding (Accept)

29+import GitHub

37import GitHub.App.Auth

30import GitHub.App.Auth

38import GitHub.App.Request

31import GitHub.App.Request

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

40import GitHub.Data.Name

32import GitHub.Data.Name

41import GitHub.Data.Webhooks.Events

33import GitHub.Data.Webhooks.Events

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

34+import GitHub.Data.Webhooks.Payload

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

44−import Network.HTTP.Media.MediaType

45import Network.Wai.Handler.Warp

35import Network.Wai.Handler.Warp

46import Servant

36import Servant

47import Servant.GitHub.Webhook

37import Servant.GitHub.Webhook

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

50import Server.Html

40import Server.Html

51import Server.Schema

41import Server.Schema

52import Squeal.PostgreSQL

42import Squeal.PostgreSQL

43+import System.IO

53import Text.Blaze.Html

44import Text.Blaze.Html

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

45+import UnliftIO.Exception (try)

56type API =

47type API =

57 "github-webhook"

48 "github-webhook"

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

59 :> GitHubSignedReqBody '[JSON] InstallationEvent

50 :> GitHubSignedReqBody '[JSON] InstallationEvent

60 :> Post '[JSON] ()

51 :> Post '[JSON] ()

61 :<|> GitHubEvent '[ 'WebhookPushEvent]

52 :<|> GitHubEvent '[ 'WebhookPushEvent]

62− :> GitHubSignedReqBody '[JSON] PushEvent

53+ :> GitHubSignedReqBody '[JSON] PushEvent

63− :> Post '[JSON] ()

54+ :> Post '[JSON] ()

64 )

55 )

65 :<|> "submission"

56 :<|> "submission"

66 :> Capture "user name" String

57 :> Capture "user name" String

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

73 :> Capture "sha" String

64 :> Capture "sha" String

74 :> "restart"

65 :> "restart"

75 :> Post '[HTML] Markup

66 :> Post '[HTML] Markup

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

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

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

79webhookInstallation _ ((), ev) =

69webhookInstallation _ ((), ev) =

80− logInfo . T.pack . show $ ev

70+ liftIO $ do

71+ print ev

72+ hFlush stdout

73+

74+pendingStatus :: NewStatus

75+pendingStatus = NewStatus StatusPending Nothing Nothing Nothing

82webhookPushEvent ::

77webhookPushEvent ::

83− ( StaticPQ m,

84− MonadReader (ServerData m) m,

85− MonadUnliftIO m,

86− HasTasks m,

87− MonadError ServerError m,

88− WithLog env Message m

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

89− ) =>

90 RepoWebhookEvent ->

79 RepoWebhookEvent ->

91 ((), PushEvent) ->

80 ((), PushEvent) ->

92 m ()

81 m ()

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

94 let repo = evPushRepository ev

83 let repo = evPushRepository ev

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

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

96 fullRepoName = whRepoFullName repo

85 fullRepoName = whRepoFullName repo

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

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

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

99− _ -> throwError err422

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

87+ Just sha = evPushHeadSha ev

101 tasks <- getTasks

88 tasks <- getTasks

102 let task =

89 let task =

103 M.lookupMax $

90 M.lookupMax $

104 M.takeWhileAntitone (repoName >) tasks

91 M.takeWhileAntitone (repoName >) tasks

105 case task of

92 case task of

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

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

107− nowTime <- liftIO getCurrentTime

94+ 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 $

95+ createSubmission $

112− Submission

96+ Submission

113− user

97+ user

114− (T.unpack fullRepoName)

98+ (T.unpack fullRepoName)

115− (T.unpack name)

99+ (T.unpack name)

116− (T.unpack sha)

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

101+ (Jsonb BuildScheduled)

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

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

128− logInfo . T.pack . show $ ev

103+ liftIO $ do

104+ print ev

105+ hFlush stdout

129 _ -> return ()

106 _ -> return ()

130

107

131retestSubmission ::

108retestSubmission ::

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

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

133 String ->

110 String ->

134 String ->

111 String ->

135 String ->

112 String ->

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

148 M.takeWhileAntitone (repoName' >) tasks

125 M.takeWhileAntitone (repoName' >) tasks

149 case task of

126 case task of

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

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

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

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

152 updateSubmissionStatus fullRepoName sha BuildScheduled

129 updateSubmissionStatus fullRepoName sha BuildScheduled

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

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

154 _ -> return ()

131 _ -> return ()

155 redirectToSubmission owner repoName sha

132 redirectToSubmission owner repoName sha

156

133

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

168 MonadUnliftIO

145 MonadUnliftIO

169 )

146 )

170

147

171−instance MonadError ServerError (ServerM schema) where

172− throwError = throwIO

173− catchError = catch

174−

175server :: ServerT API (ServerM Schema)

148server :: ServerT API (ServerM Schema)

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

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

177

150

178−runServer :: FilePath -> IO ()

151+runServer :: IO ()

179−runServer config = do

152+runServer = do

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

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

181 print c

154 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

155 auth <- mkInstallationAuth (AppAuth appId appPkPem) installationId

187 ts <- newIORef mempty

156 ts <- newIORef mempty

188 pool <- createConnectionPool databseUrl 1 0.5 10

157 pool <- createConnectionPool databseUrl 1 0.5 10

189 _ <- forkIO $ do

158 _ <- forkIO $ do

190 updateTasks ts tasksPath

159 updateTasks ts tasksPath

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

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

192 let context =

161 let context =

193 gitPolyHubKey (return webhookSecret)

162 gitPolyHubKey (return webhookSecret)

194 :. EmptyContext

163 :. EmptyContext

195− serverData =

164+ serverData = ServerData

196− ServerData

197− { githubAppAuth = auth,

165+ { githubAppAuth = auth,

166+ githubUserName = GithubUserName githubUsername,

167+ githubAccessToken = GithubAccessToken personalAccessToken,

198− tasks = ts,

168+ tasks = ts,

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

169+ logger = simpleMessageAction,

200− baseUrl = baseSiteUrl,

170+ baseUrl = baseSiteUrl

201− dockerUrl = T.pack cfgDockerUrl,

202− context = githubContext

203− }

171+ }

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

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

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

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

206 repeatIfNotEmpty n f

174 repeatIfNotEmpty n f

207− printingErrors =

175+ _ <-

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

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

216 . usingConnectionPool pool

177 . usingConnectionPool pool

217 . (`runReaderT` serverData)

178 . (`runReaderT` serverData)

218 . unApp

179 . unApp

219− . printingErrors

220− $ runTasks @'[Build] 1

180+ $ runTasks @'[Build] 1

221 _ <-

181 _ <-

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

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

223 . usingConnectionPool pool

183 . usingConnectionPool pool

224 . (`runReaderT` serverData)

184 . (`runReaderT` serverData)

225 . unApp

185 . unApp

226− . printingErrors

227 $ runTasks @'[StatusUpdate] 5

186 $ runTasks @'[StatusUpdate] 5

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

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

229 hoistServerWithContext

188 hoistServerWithContext

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

241data ServerData m

200data ServerData m

242 = ServerData

201 = ServerData

243 { githubAppAuth :: !InstallationAuth,

202 { githubAppAuth :: !InstallationAuth,

203+ githubUserName :: !GithubUserName,

204+ githubAccessToken :: !GithubAccessToken,

244 tasks :: IORef TasksConfig,

205 tasks :: IORef TasksConfig,

245 logger :: LogAction m Message,

206 logger :: LogAction m Message,

246− baseUrl :: T.Text,

207+ baseUrl :: String

247− dockerUrl :: T.Text,

248− context :: T.Text

249 }

208 }

250

209

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

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

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

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

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

257 getContextEntry (PolyGitHubKey x :. _) = x

216 getContextEntry (PolyGitHubKey x :. _) = x

258

217

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

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

260− getGithubInstallationToken =

219+

261− either

220+ getGithubAccessToken = asks githubAccessToken

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

221+

263− return

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

223

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

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

273 appRequest req = do

225 appRequest req = do

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

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

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

281 getTasks = asks tasks >>= liftIO . readIORef

233 getTasks = asks tasks >>= liftIO . readIORef

282

234

283−instance (MonadReader (ServerData m) m, StaticPQ m, MonadUnliftIO m) => HasGithubStatus m where

284− schedulePendingStatus nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do

285− h <- asks baseUrl

286− c <- asks context

287− scheduleTask $

288− StatusUpdate

289− nOwner

290− nRepo

291− nCommit

292− ( NewStatus

293− StatusPending

294− (Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha)

295− (Just "⌛")

296− (Just c)

297− )

298− scheduleTestedStatus TestResult {..} nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do

299− h <- asks baseUrl

300− c <- asks context

301− let total = M.size tests

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

303− description = T.pack $ show passed <> "/" <> show total <> if passed == total then " ✅" else " ❌"

304− status =

305− StatusUpdate

306− nOwner

307− nRepo

308− nCommit

309− NewStatus

310− { newStatusState =

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

312− newStatusTargetUrl = Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha,

313− newStatusDescription = Just description,

314− newStatusContext = Just c

315− }

316− scheduleTask status

317− scheduleFailedStatus _ nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do

318− h <- asks baseUrl

319− c <- asks context

320− let status =

321− StatusUpdate

322− nOwner

323− nRepo

324− nCommit

325− NewStatus

326− { newStatusState = StatusError,

327− newStatusTargetUrl = Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha,

328− newStatusDescription = Just "Build failed ☠️",

329− newStatusContext = Just c

330− }

331− scheduleTask status

332− deadlineHasPassedStatus nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do

333− h <- asks baseUrl

334− c <- asks context

335− let status =

336− StatusUpdate

337− nOwner

338− nRepo

339− nCommit

340− NewStatus

341− { newStatusState = StatusError,

342− newStatusTargetUrl = Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha,

343− newStatusDescription = Just "The deadline has passed ⏰",

344− newStatusContext = Just c

345− }

346− scheduleTask status

347−

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

349− getDockerUrl = asks dockerUrl

350−

351type TasksConfig = Map T.Text TaskConfig

235type TasksConfig = Map T.Text TaskConfig

352

236

353data TaskConfig

237data TaskConfig

354 = TaskConfig

238 = TaskConfig

355 { prebuild :: String,

239 { prebuild :: String,

356− dockerfile :: String,

240+ build :: String

357− timeoutMinutes :: Int,

358− deadline :: UTCTime

359 }

241 }

360 deriving stock (Show, Eq, Generic)

242 deriving stock (Show, Eq, Generic)

361 deriving anyclass (FromJSON, ToJSON)

243 deriving anyclass (FromJSON, ToJSON)

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

364 getTasks :: m TasksConfig

246 getTasks :: m TasksConfig

365

247

366instance HasLog (ServerData m) Message m where

248instance HasLog (ServerData m) Message m where

249+

367 getLogAction :: ServerData m -> LogAction m Message

250 getLogAction :: ServerData m -> LogAction m Message

368 getLogAction = logger

251 getLogAction = logger

369 {-# INLINE getLogAction #-}

252 {-# INLINE getLogAction #-}

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

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

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

372 setLogAction newLogAction env = env {logger = newLogAction}

255 setLogAction newLogAction env = env {logger = newLogAction}

373 {-# INLINE setLogAction #-}

256 {-# INLINE setLogAction #-}

374−

375−data CSV

376−

377−instance Accept CSV where

378− contentType Proxy = "text" // "csv"

379−

380−instance Csv.ToRecord a => MimeRender CSV [a] where

381− mimeRender Proxy = Csv.encode

src/Server/Config.hs+30−74

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

3module Server.Config

4 ( Config (..),

5− defaultConfig,

6 getConfig,

5 getConfig,

7 )

6 )

8where

7where

10−import Colog

9+import Crypto.PubKey.RSA (PrivateKey)

11import Crypto.PubKey.RSA.Read

10import Crypto.PubKey.RSA.Read

12−import Data.Aeson as A

13−import Data.ByteString.Char8 as BS

11+import Data.ByteString as BS

14−import Data.Text as T

12+import qualified Data.ByteString.Char8 as BS8

15−import Data.Yaml

13+import Data.Maybe

16−import GHC.Generics

17import GitHub.Data.Apps

14import GitHub.Data.Apps

18import GitHub.Data.Id

15import GitHub.Data.Id

19import GitHub.Data.Installations

16import GitHub.Data.Installations

20−import Text.Read (readMaybe)

17+import System.Environment

22data Config

19data Config

23 = Config

20 = Config

24 { webhookSecret :: !ByteString,

21 { webhookSecret :: !ByteString,

25 appId :: !(Id App),

22 appId :: !(Id App),

26− appPkPemPath :: !FilePath,

23+ appPkPem :: !PrivateKey,

27 port :: !Int,

24 port :: !Int,

28 installationId :: !(Id Installation),

25 installationId :: !(Id Installation),

26+ personalAccessToken :: !String,

27+ githubUsername :: !String,

29 tasksPath :: !FilePath,

28 tasksPath :: !FilePath,

30 databseUrl :: !ByteString,

29 databseUrl :: !ByteString,

31− baseSiteUrl :: !Text,

30+ baseSiteUrl :: !String

32− cfgDockerUrl :: !String,

33− logSeverity :: !Severity,

34− builderCount :: !Int,

35− githubContext :: !Text

36 }

31 }

37− deriving (Show, Generic)

32+ deriving (Show)

39−instance FromJSON ByteString where

34+getConfig :: IO Config

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

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

36 Config

60− { webhookSecret = "GITHUB SECRET",

61− appId = Id 69,

62− appPkPemPath = "PRIVATE KEY PATH",

63− port = 8080,

64− installationId = Id 69,

65− tasksPath = "TASKS PATH",

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

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

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

69− logSeverity = Info,

70− builderCount = 2,

71− githubContext = "MY CI NAME"

72− }

73−

74−getConfig :: FilePath -> IO Config

75−getConfig = decodeFileThrow

76−

77−-- getConfig :: IO Config

78−-- getConfig =

79−-- Config

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

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

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

82−-- <*> readPem

39+ <*> readPem

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

91−-- where

47+ where

92−-- readPem :: IO PrivateKey

48+ readPem :: IO PrivateKey

93−-- readPem = do

49+ readPem = do

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

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

95−-- pem <- BS.readFile path

51+ pem <- BS.readFile path

96−-- case readRsaPem pem of

52+ case readRsaPem pem of

97−-- Right k -> return k

53+ Right k -> return k

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

54+ Left e -> error (show e)

100deriving instance Show ReadRsaKeyError

56deriving instance Show ReadRsaKeyError

src/Server/Html.hs+13−49

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

14−import Data.Foldable

13+import Data.Aeson hiding (Success)

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

15import qualified Data.Map as M

16import Data.String

17import Data.Submission

18import Data.Submission.Query

19import qualified Data.Text as T

20+import GHC.Generics

20import Server.Schema

21import Server.Schema

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

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

22import Text.Blaze

23import Text.Blaze

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

30 String ->

31 String ->

32 String ->

32 m Markup

33 m Markup

33−getSubmissionR user repo sha' = do

34+getSubmissionR user repo sha = do

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

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

35 let restartBuild = do

36 let restartBuild = do

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

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

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

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

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

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

39 Nothing ->

40 Nothing ->

40 return . ("Not found",) $

41 return . ("Not found",) $

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

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

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

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

43 H.h1 $ toHtml problem

44 H.h1 $ toHtml problem

44 H.h2 $ toHtml userName

45 H.h2 $ toHtml userName

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

46 case status of

47 Jsonb BuildScheduled -> do

48− H.h3 "Waiting to build ⌛"

48+ H.h3 "Waiting to build"

49 restartBuild

50 Jsonb (SubmissionFailed err) -> do

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

51+ H.h3 "Failed to build"

52 restartBuild

53 H.code . H.pre $ toHtml err

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

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

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

57 H.h3 . toHtml $

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

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

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

60 restartBuild

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

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

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

64− Jsonb PastDeadline ->

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

66 return . docTypeHtml $ do

64 return . docTypeHtml $ do

67 H.head $ do

65 H.head $ do

68 H.title $ toHtml titleText

66 H.title $ toHtml titleText

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

86 C.td ? do

84 C.td ? do

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

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

88 C.form ? do

86 C.form ? do

89− C.display C.block

90− C.width (pct 100)

91− C.input ? do

92 C.display C.block

87 C.display C.block

93 C.marginLeft auto

88 C.marginLeft auto

94 C.marginRight auto

89 C.marginRight auto

95 H.body inner

90 H.body inner

97class MonadHasBaseUrl m where

92class MonadHasBaseUrl m where

98− getBaseUrl :: m T.Text

93+ getBaseUrl :: m String

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

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

101getUrl fullName sha = do

96getUrl fullName sha = do

102 siteBase <- getBaseUrl

97 siteBase <- getBaseUrl

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

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

104

105redirectToSubmission ::

100redirectToSubmission ::

106 (MonadHasBaseUrl m, Monad m) =>

101 (MonadHasBaseUrl m, Monad m) =>

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

114 H.meta

109 H.meta

115 H.! A.httpEquiv "refresh"

110 H.! A.httpEquiv "refresh"

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

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

117−

118−instance ToMarkup [Score] where

119− toMarkup xs = docTypeHtml $ do

120− H.style . preEscapedToHtml . render $ do

121− C.body ? do

122− fontFamily [] [sansSerif]

123− C.maxWidth (px 800)

124− C.display C.block

125− C.marginLeft auto

126− C.marginRight auto

127− C.paddingLeft (px 16)

128− C.paddingRight (px 16)

129− (C.h1 <> C.h2 <> C.h3) ? do

130− textAlign center

131− C.pre ? do

132− C.whiteSpace C.preWrap

133− (C.tr <> C.td) ? do

134− C.width (pct 50)

135− C.td ? do

136− C.padding (px 4) (px 4) (px 4) (px 4)

137− C.border solid (px 1) black

138− C.margin (px 0) (px 0) (px 0) (px 0)

139− C.table ? do

140− C.borderCollapse (other "collapse")

141− C.width (pct 100)

142− H.body

143− $ H.table

144− $ for_ xs

145− $ \(Score user score) -> H.tr $ do

146− (H.td H.! A.align "right") . H.code $ toHtml user

147− H.td $ toHtml score

src/Server/Schema.hs+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+2−5

@@ -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,12 @@ 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−- 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

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

54# flags: {}

51# flags: {}

tasks.yamldeleted−11

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

1−test-task:

2− prebuild: |

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

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

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

6− dockerfile: |

7− FROM fast-lts-14.20

8− COPY . src

9− WORKDIR /src

10− ENTRYPOINT stack test --fast

11− timeoutMinutes: 10