git.iko.soy/sc-build
on master help sign in
swap
991579d36 ahead, 0 behind
21 files changed+694−294
since splitsnapshots
unifiedsplit
.gitignore+1 README.md+64 app/Main.hs+25−1 package.yaml+10 sc-build.cabal−103 src/Control/GithubCloner.hs+4−10 src/Control/HasGithubStatus.hs+14 src/Control/Task/Scheduler.hs+5−4 src/Control/Task/Scheduler/Query.hs+37−4 src/Data/Submission.hs+11 src/Data/Submission/Query.hs+14 src/Data/Tasks/Build.hs+114−46 src/Data/Tasks/StatusUpdate.hs−1 src/Server.hs+182−57 src/Server/Config.hs+74−30 src/Server/Html.hs+49−13 src/Server/Schema.hs+3−1 src/Server/Schema/V1.hs+25−22 src/Server/Schema/V2.hs+46 stack.yaml+5−2 tasks.yaml+11
.gitignore+1
@@ -1 +1,2 @@
11.stack-work
2+*.cabal
README.mdnew file+64
@@ -0,0 +1,64 @@
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+25−1
@@ -1,6 +1,30 @@
11module Main (main) where
22
3+import qualified Data.ByteString.Char8 as BS
4+import Data.Yaml (encode)
5+import Options.Applicative
36import Server
7+import Server.Config
48
59main :: IO ()
6−main = runServer
10+main =
11+ execParser (info (getOptions <**> helper) fullDesc) >>= \case
12+ PrintDefaultConfig -> putStrLn . BS.unpack . encode $ defaultConfig
13+ RunServer config -> runServer config
14+
15+data Run
16+ = PrintDefaultConfig
17+ | RunServer FilePath
18+
19+getOptions :: Parser Run
20+getOptions =
21+ subparser
22+ ( command "default" (info (pure PrintDefaultConfig <**> helper) fullDesc)
23+ )
24+ <|> ( RunServer
25+ <$> strOption
26+ ( long "config"
27+ <> help "Path to yaml config file."
28+ <> value "config.yaml"
29+ )
30+ )
package.yaml+10
@@ -17,6 +17,7 @@ dependencies:
1717library:
1818 source-dirs: src
1919 dependencies:
20+ - http-client-tls
2021 - servant
2122 - servant-server
2223 - process
@@ -46,6 +47,12 @@ library:
4647 - blaze-markup
4748 - blaze-html
4849 - clay
50+ - docker
51+ - exceptions
52+ - transformers
53+ - cassava
54+ - http-media
55+ - utf8-string
4956
5057executables:
5158 sc-build-exe:
@@ -57,6 +64,9 @@ executables:
5764 - -with-rtsopts=-N
5865 dependencies:
5966 - sc-build
67+ - bytestring
68+ - yaml
69+ - optparse-applicative
6070 sc-build-migrations:
6171 main: Main.hs
6272 source-dirs: migrations
sc-build.cabaldeleted−103
@@ -1,103 +0,0 @@
1−cabal-version: 1.12
2−
3−-- This file has been generated from package.yaml by hpack version 0.31.2.
4−--
5−-- see: https://github.com/sol/hpack
6−--
7−-- hash: bb953e6231fcc3939bfe085afcd3e792cbc40462461bbe4fb82ae69f1796be4c
8−
9−name: sc-build
10−version: 0.1.0.0
11−category: Web
12−homepage: https://github.com/ilyakooo0/sc-build#readme
13−author: Ilya Kostyuchenko
14−maintainer: ilyakooo0@gmail.com
15−copyright: Ilya Kostyuchenko
16−license: BSD3
17−license-file: LICENSE
18−build-type: Simple
19−extra-source-files:
20− README.md
21−
22−library
23− exposed-modules:
24− Control.AppRequestable
25− Control.GithubCloner
26− Control.Squeal
27− Control.Task
28− Control.Task.Scheduler
29− Control.Task.Scheduler.Query
30− Data.Submission
31− Data.Submission.Query
32− Data.Tasks.Build
33− Data.Tasks.StatusUpdate
34− Server
35− Server.Config
36− Server.Html
37− Server.Schema
38− Server.Schema.V1
39− other-modules:
40− Paths_sc_build
41− hs-source-dirs:
42− src
43− default-extensions: AllowAmbiguousTypes ConstraintKinds DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuantifiedConstraints RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances
44− build-depends:
45− aeson
46− , base >=4.7 && <5
47− , blaze-html
48− , blaze-markup
49− , bytestring
50− , clay
51− , co-log
52− , containers
53− , cryptonite
54− , directory
55− , generics-sop
56− , github
57− , github-app
58− , github-webhooks
59− , mtl
60− , process
61− , random
62− , servant
63− , servant-blaze
64− , servant-github-webhook
65− , servant-server
66− , squeal-postgresql
67− , text
68− , time
69− , typed-process
70− , unliftio
71− , unliftio-core
72− , vector
73− , warp
74− , yaml
75− default-language: Haskell2010
76−
77−executable sc-build-exe
78− main-is: Main.hs
79− other-modules:
80− Paths_sc_build
81− hs-source-dirs:
82− app
83− default-extensions: AllowAmbiguousTypes ConstraintKinds DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuantifiedConstraints RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances
84− ghc-options: -threaded -rtsopts -with-rtsopts=-N
85− build-depends:
86− base >=4.7 && <5
87− , sc-build
88− default-language: Haskell2010
89−
90−executable sc-build-migrations
91− main-is: Main.hs
92− other-modules:
93− Paths_sc_build
94− hs-source-dirs:
95− migrations
96− default-extensions: AllowAmbiguousTypes ConstraintKinds DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuantifiedConstraints RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances
97− ghc-options: -threaded -rtsopts -with-rtsopts=-N
98− build-depends:
99− base >=4.7 && <5
100− , bytestring
101− , sc-build
102− , squeal-postgresql
103− default-language: Haskell2010
src/Control/GithubCloner.hs+4−10
@@ -1,16 +1,10 @@
11module Control.GithubCloner
2− ( GithubAccessToken (..),
3− GithubUserName (..),
4− GithubCloner (..),
2+ ( GithubCloner (..),
3+ InstallationToken (..),
54 )
65where
76
8−newtype GithubAccessToken = GithubAccessToken String
9−
10−newtype GithubUserName = GithubUserName String
7+newtype InstallationToken = InstallationToken String
118
129class GithubCloner m where
13−
14− getGithubAccessToken :: m GithubAccessToken
15−
16− getGithubUserName :: m GithubUserName
10+ getGithubInstallationToken :: m InstallationToken
src/Control/HasGithubStatus.hsnew file+14
@@ -0,0 +1,14 @@
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+5−4
@@ -3,6 +3,7 @@
33module Control.Task.Scheduler
44 ( scheduleTask,
55 runTasks,
6+ makeAllRunnable,
67 )
78where
89
@@ -20,6 +21,7 @@ import Data.Word
2021import GHC.TypeLits
2122import Server.Schema
2223import Squeal.PostgreSQL
24+import UnliftIO.Exception
2325
2426scheduleTask ::
2527 (StaticPQ m, WithLog env Message m, Task t s, MonadUnliftIO m) =>
@@ -45,7 +47,6 @@ rescheduleTaskTime ::
4547rescheduleTaskTime = rescheduleTaskQuery
4648
4749class RunTasks (ts :: [*]) m where
48−
4950 runTask :: WithLog env Message m => PickedTask -> m ()
5051
5152 taskNames :: [String]
@@ -55,7 +56,6 @@ instance
5556 (Task t ts, TaskMonad t m, StaticPQ m, RunTasks tt m, MonadUnliftIO m) =>
5657 RunTasks (t ': tt) m
5758 where
58−
5959 runTask (PickedTask s (Jsonb v) initialStartTime) | symbolVal @ts Proxy == s =
6060 case fromJSON @t v of
6161 A.Error e ->
@@ -67,7 +67,9 @@ instance
6767 <> e
6868 A.Success t -> do
6969 logInfo . T.pack $ "running task " <> task <> " with " <> show t <> " created at " <> show initialStartTime
70− r <- performTask @t @ts @m t
70+ r <- performTask @t @ts @m t `catchAny` \e -> do
71+ logError . T.pack . displayException $ e
72+ return Failure
7173 when (r == Failure) $ logWarning . T.pack $ "Task " <> task <> " failed"
7274 case r of
7375 Success -> completeTaskQuery t
@@ -79,7 +81,6 @@ instance
7981 taskNames = symbolVal @ts Proxy : taskNames @tt @m
8082
8183instance RunTasks '[] m where
82−
8384 runTask (PickedTask s (Jsonb v) _) =
8485 logError . T.pack $ "Unknown task " <> s <> " with payload " <> show v
8586
src/Control/Task/Scheduler/Query.hs+37−4
@@ -5,11 +5,13 @@ module Control.Task.Scheduler.Query
55 completeTaskQuery,
66 rescheduleTaskQuery,
77 pickTasksQuery,
8+ makeAllRunnable,
89 PickedTask (..),
910 )
1011where
1112
1213import Colog
14+import Control.Arrow
1315import Control.Monad.IO.Unlift
1416import Control.Squeal
1517import Control.Task
@@ -38,6 +40,8 @@ scheduleTaskQuery task = do
3840 Set (param @1) `as` #task
3941 :* Set (param @2) `as` #payload
4042 :* Default `as` #creation_time
43+ :* Default `as` #started
44+ :* Default `as` #failures
4145 )
4246 ( OnConflict
4347 (OnConstraint #pk_task_payload)
@@ -82,7 +86,10 @@ rescheduleTaskQuery payload = do
8286 query =
8387 update_
8488 #tasks
85− (Default `as` #creation_time)
89+ ( Default `as` #creation_time
90+ :* Default `as` #started
91+ :* Set (#failures + 1) `as` #failures
92+ )
8693 (param @1 .== #task .&& param @2 .== #payload)
8794 dbWrite (const $ return ()) $
8895 manipulateParams_
@@ -96,7 +103,7 @@ pickTasksQuery ::
96103 Word64 ->
97104 m [PickedTask]
98105pickTasksQuery tasks limitCount = do
99− logDebug "reading tasks"
106+ logDebug $ "reading tasks " <> T.unwords (T.pack <$> tasks)
100107 let query :: Query_ Schema () PickedTask
101108 query =
102109 select_
@@ -106,11 +113,23 @@ pickTasksQuery tasks limitCount = do
106113 )
107114 ( from (table #tasks)
108115 & where_ (#task `in_` (literal <$> tasks))
116+ & where_ (not_ . notNull $ #started)
117+ & where_ (#failures .< 20)
109118 & orderBy [#creation_time & Asc]
110119 & 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
111127 )
112− dbRead (const $ return []) $
113− runQuery query >>= getRows
128+ (param @1 .== #task .&& param @2 .== #payload)
129+ dbWrite (const $ return []) $ do
130+ pickedTasks <- runQuery query >>= getRows
131+ traversePrepared_ startedMan $ (task &&& payload) <$> pickedTasks
132+ return pickedTasks
114133
115134data PickedTask
116135 = PickedTask
@@ -119,3 +138,17 @@ data PickedTask
119138 creationTime :: UTCTime
120139 }
121140 deriving (Eq, Show, Generic, SOP.Generic, SOP.HasDatatypeInfo)
141+
142+makeAllRunnable ::
143+ (StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>
144+ m ()
145+makeAllRunnable = do
146+ let startAll :: Manipulation_ Schema () ()
147+ startAll =
148+ update_
149+ #tasks
150+ ( Set false `as` #started
151+ )
152+ (notNull #started)
153+ dbWrite (const $ return ()) $
154+ manipulate_ startAll
src/Data/Submission.hs+11
@@ -2,10 +2,13 @@ module Data.Submission
22 ( Submission (..),
33 SubmissionStatus (..),
44 TestResult (..),
5+ Score (..),
56 )
67where
78
89import Data.Aeson
10+import Data.Csv
11+import Data.Int
912import Data.Map (Map)
1013import Data.Text (Text)
1114import GHC.Generics (Generic)
@@ -26,6 +29,7 @@ data SubmissionStatus
2629 = SubmissionRun TestResult
2730 | SubmissionFailed String
2831 | BuildScheduled
32+ | PastDeadline
2933 deriving (Generic, FromJSON, ToJSON, Eq, Show)
3034
3135newtype TestResult
@@ -34,3 +38,10 @@ newtype TestResult
3438 }
3539 deriving stock (Eq, Show, Generic)
3640 deriving anyclass (FromJSON, ToJSON)
41+
42+data Score
43+ = Score
44+ { userName :: String,
45+ score :: Int64
46+ }
47+ deriving (Eq, Show, Generic, SOP.Generic, SOP.HasDatatypeInfo, ToRecord)
src/Data/Submission/Query.hs+14
@@ -4,6 +4,7 @@ module Data.Submission.Query
44 ( createSubmission,
55 updateSubmissionStatus,
66 getSubmission,
7+ getResults,
78 )
89where
910
@@ -83,3 +84,16 @@ getSubmission repoFullName sha = do
8384 query
8485 (repoFullName, sha)
8586 >>= firstRow
87+
88+getResults ::
89+ (StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>
90+ String ->
91+ m [Score]
92+getResults task = do
93+ let query :: Query_ Schema (Only String) Score
94+ query = UnsafeQuery "select a.user_name as \"userName\", max(a.correct) as score from (select (select count(*) as correct from jsonb_each_text(submissions.status -> 'contents' -> 'tests') where value = 'true'), user_name from submissions where problem = $1) as a group by user_name"
95+ dbRead (const $ return []) $
96+ runQueryParams
97+ query
98+ (Only task)
99+ >>= getRows
src/Data/Tasks/Build.hs+114−46
@@ -3,24 +3,26 @@
33
44module Data.Tasks.Build
55 ( Build (..),
6+ HasDockerInfo (..),
67 )
78where
89
910import Colog
11+import Control.Concurrent
1012import Control.GithubCloner
11−import Control.Monad.IO.Class
13+import Control.HasGithubStatus
14+import Control.Monad.Except
1215import Control.Monad.IO.Unlift
1316import Control.Task
14−import Control.Task.Scheduler
1517import Data.Aeson hiding (Success)
1618import qualified Data.ByteString.Lazy.Char8 as BS
17−import qualified Data.Map as M
19+import qualified Data.ByteString.Lazy.UTF8 as BS
1820import Data.String
1921import Data.Submission
2022import Data.Submission.Query
21−import Data.Tasks.StatusUpdate
2223import qualified Data.Text as T
2324import Data.Time.Clock.POSIX
25+import qualified Docker.Client as D
2426import GHC.Generics
2527import GitHub
2628import Server.Schema
@@ -28,31 +30,32 @@ import System.Directory
2830import System.Exit
2931import System.Process.Typed
3032import System.Random
33+import UnliftIO.Async
3134import UnliftIO.Exception
3235
3336data Build
3437 = Build
3538 { preProcessShell :: String,
36− buildCommand :: String,
39+ dockerFile :: String,
3740 owner :: Name Owner,
3841 repoName :: Name Repo,
39− sha :: Name Commit
42+ sha :: Name Commit,
43+ timeoutMinutes :: Int
4044 }
4145 deriving (Eq, Show, Generic, FromJSON, ToJSON)
4246
4347instance Task Build "build-repo" where
44−
45− type TaskMonad Build m = (MonadUnliftIO m, GithubCloner m, StaticPQ m)
48+ type
49+ TaskMonad Build m =
50+ (MonadUnliftIO m, StaticPQ m, HasDockerInfo m, GithubCloner m, HasGithubStatus m)
4651
4752 performTask Build {..} =
48− bracket createDir (liftIO . removePathForcibly) $ \dir -> do
49− let fullRepoName = T.unpack $ untagName owner <> "/" <> untagName repoName
50− sha' = T.unpack $ untagName sha
53+ bracket createDir (liftIO . removePathForcibly) $ \dir -> flip catchAny (const $ return Failure) $ do
5154 cloneRepo fullRepoName sha' dir
5255 (shellCode, _, shellErr) <- readProcess . setWorkingDir dir $ shell preProcessShell
5356 case shellCode of
5457 ExitFailure n -> do
55− let err = BS.unpack shellErr
58+ let err = BS.toString shellErr
5659 logError . T.pack $
5760 "preprocessing command for repo " <> show fullRepoName <> " at sha "
5861 <> show sha
@@ -60,13 +63,73 @@ instance Task Build "build-repo" where
6063 <> show n
6164 <> " and error "
6265 <> err
63− scheduleTask erroredTask
66+ scheduleFailedStatus err owner repoName sha
6467 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
6568 ExitSuccess -> do
66− (buildCode, buildOut, buildErr) <- readProcess . setWorkingDir dir . fromString $ buildCommand
67− case buildCode of
68− ExitFailure n -> do
69− let err = BS.unpack buildErr
69+ h <- liftIO D.defaultHttpHandler
70+ dUrl <- getDockerUrl
71+ let opts = D.defaultCreateOpts imageName
72+ runDocker ::
73+ ( MonadIO m,
74+ Exception err,
75+ WithLog env Message m,
76+ StaticPQ m,
77+ MonadUnliftIO m,
78+ HasGithubStatus m
79+ ) =>
80+ D.DockerT IO (Either err a) ->
81+ m a
82+ runDocker = runEither <=< liftIO . D.runDockerT (D.defaultClientOpts {D.baseUrl = dUrl}, h)
83+ imageName = T.pack dir
84+ liftIO $ writeFile (dir <> "/Dockerfile") dockerFile
85+ absDir <- liftIO $ makeAbsolute dir
86+ let waitDockerForever cid =
87+ D.waitContainer cid >>= \case
88+ Left D.GenericDockerError {} -> waitDockerForever cid
89+ a -> return a
90+ cid <- runDocker . runExceptT $ do
91+ ExceptT $ D.buildImageFromDockerfile (D.defaultBuildOpts imageName) absDir
92+ ExceptT $ D.createContainer opts Nothing
93+ dockerRes <- fmap (either id id)
94+ . race (liftIO (threadDelay (timeoutMinutes * 60000000)) >> return (ExitFailure 1, "Time out", "Time out"))
95+ $ flip
96+ finally
97+ ( runDocker $
98+ D.deleteContainer
99+ D.ContainerDeleteOpts {deleteVolumes = True, force = True}
100+ cid
101+ )
102+ . runDocker
103+ . runExceptT
104+ $ do
105+ ExceptT $ D.startContainer D.defaultStartOpts cid
106+ buildCode <- ExceptT $ waitDockerForever cid
107+ buildOut <-
108+ ExceptT $
109+ D.getContainerLogs
110+ D.LogOpts
111+ { stdout = True,
112+ stderr = False,
113+ since = Nothing,
114+ timestamps = False,
115+ tail = D.All
116+ }
117+ cid
118+ buildErr <-
119+ ExceptT $
120+ D.getContainerLogs
121+ D.LogOpts
122+ { stdout = True,
123+ stderr = True,
124+ since = Nothing,
125+ timestamps = False,
126+ tail = D.All
127+ }
128+ cid
129+ return (buildCode, buildOut, buildErr)
130+ case dockerRes of
131+ (ExitFailure n, _, buildErr) -> do
132+ let err = BS.toString buildErr
70133 logError . T.pack $
71134 "test command for repo " <> show fullRepoName <> " at sha "
72135 <> show sha
@@ -74,42 +137,43 @@ instance Task Build "build-repo" where
74137 <> show n
75138 <> " and error "
76139 <> err
77− scheduleTask erroredTask
140+ scheduleFailedStatus err owner repoName sha
78141 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
79− ExitSuccess ->
80− case decode buildOut of
81− Nothing -> do
82− let err = BS.unpack buildOut
142+ (ExitSuccess, buildOut, _) ->
143+ case eitherDecode' (BS.dropWhile (/= '{') buildOut) of
144+ Left err' -> do
145+ let err = err' <> " " <> BS.toString buildOut
83146 logError . T.pack $
84147 "could not decode test result from repo " <> show fullRepoName
85148 <> " at sha "
86149 <> show sha
87150 <> ": "
88151 <> err
89− scheduleTask erroredTask
90− updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
91− Just testResult@TestResult {..} -> do
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
152+ scheduleFailedStatus err owner repoName sha
153+ updateSubmissionStatus fullRepoName sha' (SubmissionFailed (err <> BS.toString buildOut))
154+ Right testResult@TestResult {..} -> do
155+ scheduleTestedStatus testResult owner repoName sha
103156 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)
104157 return Success
105158 where
106− statusTask = StatusUpdate owner repoName sha
107− erroredTask = statusTask $ NewStatus
108− { newStatusState = StatusError,
109− newStatusTargetUrl = Nothing,
110− newStatusDescription = Just "Build failed",
111− newStatusContext = Nothing
112− }
159+ fullRepoName = T.unpack $ untagName owner <> "/" <> untagName repoName
160+ sha' = T.unpack $ untagName sha
161+ runEither ::
162+ ( Exception err,
163+ WithLog env Message m,
164+ StaticPQ m,
165+ MonadUnliftIO m,
166+ HasGithubStatus m
167+ ) =>
168+ Either err b ->
169+ m b
170+ runEither (Left err) = do
171+ let err' = show err
172+ logError $ T.pack err'
173+ scheduleFailedStatus err' owner repoName sha
174+ updateSubmissionStatus fullRepoName sha' (SubmissionFailed err')
175+ throwIO err
176+ runEither (Right a) = return a
113177
114178createDir :: MonadIO m => m FilePath
115179createDir = do
@@ -119,10 +183,9 @@ createDir = do
119183
120184cloneRepo :: (MonadIO m, GithubCloner m) => String -> String -> FilePath -> m ()
121185cloneRepo repoName sha path = do
122− GithubAccessToken token <- getGithubAccessToken
123− GithubUserName username <- getGithubUserName
186+ InstallationToken token <- getGithubInstallationToken
124187 runProcess_ . setWorkingDir path . fromString $
125− "git clone https://" <> username <> ":" <> token <> "@github.com/" <> repoName <> ".git ."
188+ "git clone https://x-access-token:" <> token <> "@github.com/" <> repoName <> ".git ."
126189 runProcess_ . setWorkingDir path . fromString $ "git checkout " <> sha
127190 return ()
128191
@@ -131,3 +194,8 @@ getTmpDirName = liftIO $ do
131194 time :: Integer <- round <$> getPOSIXTime
132195 i <- randomIO @Int
133196 return $ show time <> "-" <> show i
197+
198+class HasDockerInfo m where
199+ getDockerUrl :: m T.Text
200+
201+instance Exception D.DockerError
src/Data/Tasks/StatusUpdate.hs−1
@@ -31,7 +31,6 @@ instance FromJSON NewStatus where
3131 <*> v .:? "context"
3232
3333instance Task StatusUpdate "update-commit-ci-status" where
34−
3534 type TaskMonad StatusUpdate m = (AppRequestable m)
3635
3736 performTask StatusUpdate {..} = do
src/Server.hs+182−57
@@ -10,12 +10,18 @@ import Colog
1010import Control.AppRequestable
1111import Control.Concurrent
1212import Control.GithubCloner
13+import Control.HasGithubStatus
1314import Control.Monad.Except
1415import Control.Monad.IO.Unlift
1516import Control.Monad.Reader
1617import Control.Task.Scheduler
18+import Crypto.PubKey.RSA.Read
1719import Data.Aeson
1820import 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
1925import Data.IORef
2026import Data.Map (Map)
2127import qualified Data.Map as M
@@ -24,14 +30,18 @@ import Data.Submission.Query
2430import Data.Tasks.Build
2531import Data.Tasks.StatusUpdate
2632import qualified Data.Text as T
33+import Data.Time.Clock
2734import Data.Yaml
2835import GHC.Generics
29−import GitHub
36+import GitHub hiding (Accept)
3037import GitHub.App.Auth
3138import GitHub.App.Request
39+import GitHub.Auth (Auth (OAuth))
3240import GitHub.Data.Name
3341import GitHub.Data.Webhooks.Events
34−import GitHub.Data.Webhooks.Payload
42+import GitHub.Data.Webhooks.Payload hiding (URL (..))
43+import Network.HTTP.Client.TLS (newTlsManager)
44+import Network.HTTP.Media.MediaType
3545import Network.Wai.Handler.Warp
3646import Servant
3747import Servant.GitHub.Webhook
@@ -40,9 +50,8 @@ import Server.Config
4050import Server.Html
4151import Server.Schema
4252import Squeal.PostgreSQL
43−import System.IO
4453import Text.Blaze.Html
45−import UnliftIO.Exception (try)
54+import UnliftIO.Exception (catch, displayException, handleAny, throwIO, try)
4655
4756type API =
4857 "github-webhook"
@@ -50,8 +59,8 @@ type API =
5059 :> GitHubSignedReqBody '[JSON] InstallationEvent
5160 :> Post '[JSON] ()
5261 :<|> GitHubEvent '[ 'WebhookPushEvent]
53− :> GitHubSignedReqBody '[JSON] PushEvent
54− :> Post '[JSON] ()
62+ :> GitHubSignedReqBody '[JSON] PushEvent
63+ :> Post '[JSON] ()
5564 )
5665 :<|> "submission"
5766 :> Capture "user name" String
@@ -64,18 +73,20 @@ type API =
6473 :> Capture "sha" String
6574 :> "restart"
6675 :> Post '[HTML] Markup
76+ :<|> "results" :> Capture "task name" String :> Get '[CSV, HTML] [Score]
6777
68−webhookInstallation :: MonadIO m => RepoWebhookEvent -> ((), InstallationEvent) -> m ()
78+webhookInstallation :: WithLog env Message m => RepoWebhookEvent -> ((), InstallationEvent) -> m ()
6979webhookInstallation _ ((), ev) =
70− liftIO $ do
71− print ev
72− hFlush stdout
73−
74−pendingStatus :: NewStatus
75−pendingStatus = NewStatus StatusPending Nothing Nothing Nothing
80+ logInfo . T.pack . show $ ev
7681
7782webhookPushEvent ::
78− (StaticPQ m, WithLog env Message m, MonadUnliftIO m, HasTasks m) =>
83+ ( StaticPQ m,
84+ MonadReader (ServerData m) m,
85+ MonadUnliftIO m,
86+ HasTasks m,
87+ MonadError ServerError m,
88+ WithLog env Message m
89+ ) =>
7990 RepoWebhookEvent ->
8091 ((), PushEvent) ->
8192 m ()
@@ -83,30 +94,42 @@ webhookPushEvent _ ((), ev) = do
8394 let repo = evPushRepository ev
8495 user = T.unpack . whUserLogin . evPushSender $ ev
8596 fullRepoName = whRepoFullName repo
86− [owner, repoName] = T.splitOn "/" fullRepoName
87− Just sha = evPushHeadSha ev
97+ (owner, repoName) <- case T.splitOn "/" fullRepoName of
98+ [a, b] -> return (a, b)
99+ _ -> throwError err422
100+ sha <- maybe (throwError err422) return $ evPushHeadSha ev
88101 tasks <- getTasks
89102 let task =
90103 M.lookupMax $
91104 M.takeWhileAntitone (repoName >) tasks
92105 case task of
93106 Just (name, TaskConfig {..}) | T.take (T.length name) repoName == name -> do
94− scheduleTask $ StatusUpdate (N owner) (N repoName) (N sha) pendingStatus
95− createSubmission $
96− Submission
97− user
98− (T.unpack fullRepoName)
99− (T.unpack name)
100− (T.unpack sha)
101− (Jsonb BuildScheduled)
102− scheduleTask $ Build prebuild build (N owner) (N repoName) (N sha)
103− liftIO $ do
104− print ev
105− hFlush stdout
107+ nowTime <- liftIO getCurrentTime
108+ if nowTime > deadline
109+ then do
110+ deadlineHasPassedStatus (N owner) (N repoName) (N sha)
111+ createSubmission $
112+ Submission
113+ user
114+ (T.unpack fullRepoName)
115+ (T.unpack name)
116+ (T.unpack sha)
117+ (Jsonb PastDeadline)
118+ else do
119+ schedulePendingStatus (N owner) (N repoName) (N sha)
120+ createSubmission $
121+ Submission
122+ user
123+ (T.unpack fullRepoName)
124+ (T.unpack name)
125+ (T.unpack sha)
126+ (Jsonb BuildScheduled)
127+ scheduleTask $ Build prebuild dockerfile (N owner) (N repoName) (N sha) timeoutMinutes
128+ logInfo . T.pack . show $ ev
106129 _ -> return ()
107130
108131retestSubmission ::
109− (StaticPQ m, WithLog env Message m, MonadUnliftIO m, HasTasks m, MonadHasBaseUrl m) =>
132+ (StaticPQ m, MonadReader (ServerData m) m, MonadUnliftIO m, HasTasks m, MonadHasBaseUrl m) =>
110133 String ->
111134 String ->
112135 String ->
@@ -125,9 +148,9 @@ retestSubmission owner repoName sha = do
125148 M.takeWhileAntitone (repoName' >) tasks
126149 case task of
127150 Just (name, TaskConfig {..}) | T.take (T.length name) repoName' == name -> do
128− scheduleTask $ StatusUpdate (N owner') (N repoName') (N sha') pendingStatus
151+ schedulePendingStatus (N owner') (N repoName') (N sha')
129152 updateSubmissionStatus fullRepoName sha BuildScheduled
130− scheduleTask $ Build prebuild build (N owner') (N repoName') (N sha')
153+ scheduleTask $ Build prebuild dockerfile (N owner') (N repoName') (N sha') timeoutMinutes
131154 _ -> return ()
132155 redirectToSubmission owner repoName sha
133156
@@ -145,44 +168,62 @@ newtype ServerM (schema :: SchemasType) a
145168 MonadUnliftIO
146169 )
147170
171+instance MonadError ServerError (ServerM schema) where
172+ throwError = throwIO
173+ catchError = catch
174+
148175server :: ServerT API (ServerM Schema)
149−server = (webhookInstallation :<|> webhookPushEvent) :<|> getSubmissionR :<|> retestSubmission
176+server = (webhookInstallation :<|> webhookPushEvent) :<|> getSubmissionR :<|> retestSubmission :<|> getResults
150177
151−runServer :: IO ()
152−runServer = do
153− c@Config {..} <- getConfig
178+runServer :: FilePath -> IO ()
179+runServer config = do
180+ c@Config {..} <- getConfig config
154181 print c
182+ pem <- BS.readFile appPkPemPath
183+ appPkPem <- case readRsaPem pem of
184+ Right k -> return k
185+ Left e -> error (show e)
155186 auth <- mkInstallationAuth (AppAuth appId appPkPem) installationId
156187 ts <- newIORef mempty
157188 pool <- createConnectionPool databseUrl 1 0.5 10
158189 _ <- forkIO $ do
159190 updateTasks ts tasksPath
160− threadDelay $ 10 * 60 * (10 ^ (6 :: Int))
191+ threadDelay $ 5 * 60 * (10 ^ (6 :: Int))
161192 let context =
162193 gitPolyHubKey (return webhookSecret)
163194 :. EmptyContext
164− serverData = ServerData
165− { githubAppAuth = auth,
166− githubUserName = GithubUserName githubUsername,
167− githubAccessToken = GithubAccessToken personalAccessToken,
168− tasks = ts,
169− logger = simpleMessageAction,
170− baseUrl = baseSiteUrl
171− }
195+ serverData =
196+ ServerData
197+ { githubAppAuth = auth,
198+ tasks = ts,
199+ logger = cfilter ((logSeverity <=) . msgSeverity) richMessageAction,
200+ baseUrl = baseSiteUrl,
201+ dockerUrl = T.pack cfgDockerUrl,
202+ context = githubContext
203+ }
172204 repeatIfNotEmpty n f = f >>= \m -> do
173205 when (m == 0) $ liftIO $ threadDelay n
174206 repeatIfNotEmpty n f
175− _ <-
176− forkIO . repeatIfNotEmpty (10 ^ (6 :: Int))
207+ printingErrors =
208+ handleAny (logError . T.pack . displayException >=> const (return 0))
209+ usingConnectionPool pool
210+ . (`runReaderT` serverData)
211+ . unApp
212+ . handleAny (error . displayException)
213+ $ makeAllRunnable
214+ replicateM_ builderCount
215+ $ forkIO . repeatIfNotEmpty (10 ^ (6 :: Int))
177216 . usingConnectionPool pool
178217 . (`runReaderT` serverData)
179218 . unApp
180− $ runTasks @'[Build] 1
219+ . printingErrors
220+ $ runTasks @'[Build] 1
181221 _ <-
182222 forkIO . repeatIfNotEmpty (10 ^ (6 :: Int))
183223 . usingConnectionPool pool
184224 . (`runReaderT` serverData)
185225 . unApp
226+ . printingErrors
186227 $ runTasks @'[StatusUpdate] 5
187228 run port $ serveWithContext (Proxy @API) context $
188229 hoistServerWithContext
@@ -200,11 +241,11 @@ updateTasks ref path =
200241data ServerData m
201242 = ServerData
202243 { githubAppAuth :: !InstallationAuth,
203− githubUserName :: !GithubUserName,
204− githubAccessToken :: !GithubAccessToken,
205244 tasks :: IORef TasksConfig,
206245 logger :: LogAction m Message,
207− baseUrl :: String
246+ baseUrl :: T.Text,
247+ dockerUrl :: T.Text,
248+ context :: T.Text
208249 }
209250
210251newtype PolyGitHubKey = PolyGitHubKey (forall result. GitHubKey result)
@@ -215,11 +256,18 @@ gitPolyHubKey k = PolyGitHubKey (Servant.GitHub.Webhook.gitHubKey k)
215256instance HasContextEntry '[PolyGitHubKey] (GitHubKey result) where
216257 getContextEntry (PolyGitHubKey x :. _) = x
217258
218−instance MonadReader (ServerData n) m => GithubCloner m where
219−
220− getGithubAccessToken = asks githubAccessToken
221−
222− getGithubUserName = asks githubUserName
259+instance (MonadReader (ServerData n) m, MonadIO m, MonadError ServerError m) => GithubCloner m where
260+ getGithubInstallationToken =
261+ either
262+ (\e -> throwError err500 {errBody = BSCL.pack . displayException $ e})
263+ return
264+ <=< runExceptT
265+ $ do
266+ iAuth <- asks githubAppAuth
267+ manager <- newTlsManager
268+ liftIO (obtainAccessToken manager iAuth) >>= either throwError return >>= \case
269+ OAuth token -> return $ InstallationToken (BSC.unpack token)
270+ _ -> throwError $ UserError "Not OAuth token. This should never happen."
223271
224272instance (MonadIO m, MonadReader (ServerData n) m) => AppRequestable m where
225273 appRequest req = do
@@ -232,12 +280,82 @@ instance MonadReader (ServerData n) m => MonadHasBaseUrl m where
232280instance (MonadIO m, MonadReader (ServerData n) m) => HasTasks m where
233281 getTasks = asks tasks >>= liftIO . readIORef
234282
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+
235351type TasksConfig = Map T.Text TaskConfig
236352
237353data TaskConfig
238354 = TaskConfig
239355 { prebuild :: String,
240− build :: String
356+ dockerfile :: String,
357+ timeoutMinutes :: Int,
358+ deadline :: UTCTime
241359 }
242360 deriving stock (Show, Eq, Generic)
243361 deriving anyclass (FromJSON, ToJSON)
@@ -246,7 +364,6 @@ class HasTasks m where
246364 getTasks :: m TasksConfig
247365
248366instance HasLog (ServerData m) Message m where
249−
250367 getLogAction :: ServerData m -> LogAction m Message
251368 getLogAction = logger
252369 {-# INLINE getLogAction #-}
@@ -254,3 +371,11 @@ instance HasLog (ServerData m) Message m where
254371 setLogAction :: LogAction m Message -> ServerData m -> ServerData m
255372 setLogAction newLogAction env = env {logger = newLogAction}
256373 {-# INLINE setLogAction #-}
374+
375+data CSV
376+
377+instance Accept CSV where
378+ contentType Proxy = "text" // "csv"
379+
380+instance Csv.ToRecord a => MimeRender CSV [a] where
381+ mimeRender Proxy = Csv.encode
src/Server/Config.hs+74−30
@@ -2,55 +2,99 @@
22
33module Server.Config
44 ( Config (..),
5+ defaultConfig,
56 getConfig,
67 )
78where
89
9−import Crypto.PubKey.RSA (PrivateKey)
10+import Colog
1011import Crypto.PubKey.RSA.Read
11−import Data.ByteString as BS
12−import qualified Data.ByteString.Char8 as BS8
13−import Data.Maybe
12+import Data.Aeson as A
13+import Data.ByteString.Char8 as BS
14+import Data.Text as T
15+import Data.Yaml
16+import GHC.Generics
1417import GitHub.Data.Apps
1518import GitHub.Data.Id
1619import GitHub.Data.Installations
17−import System.Environment
20+import Text.Read (readMaybe)
1821
1922data Config
2023 = Config
2124 { webhookSecret :: !ByteString,
2225 appId :: !(Id App),
23− appPkPem :: !PrivateKey,
26+ appPkPemPath :: !FilePath,
2427 port :: !Int,
2528 installationId :: !(Id Installation),
26− personalAccessToken :: !String,
27− githubUsername :: !String,
2829 tasksPath :: !FilePath,
2930 databseUrl :: !ByteString,
30− baseSiteUrl :: !String
31+ baseSiteUrl :: !Text,
32+ cfgDockerUrl :: !String,
33+ logSeverity :: !Severity,
34+ builderCount :: !Int,
35+ githubContext :: !Text
3136 }
32− deriving (Show)
37+ deriving (Show, Generic)
3338
34−getConfig :: IO Config
35−getConfig =
39+instance FromJSON ByteString where
40+ parseJSON (String s) = return . BS.pack . T.unpack $ s
41+ parseJSON _ = fail "not a string"
42+
43+instance ToJSON ByteString where
44+ toJSON = String . T.pack . BS.unpack
45+
46+instance FromJSON Severity where
47+ parseJSON (String s) = maybe (fail "oh no") return . readMaybe . T.unpack $ s
48+ parseJSON _ = fail "not a string"
49+
50+instance ToJSON Severity where
51+ toJSON = String . T.pack . show
52+
53+instance FromJSON Config
54+
55+instance ToJSON Config
56+
57+defaultConfig :: Config
58+defaultConfig =
3659 Config
37− <$> (maybe (error "no GITHUB_WEBHOOK_SECRET") BS8.pack <$> lookupEnv "GITHUB_WEBHOOK_SECRET")
38− <*> (maybe (error "no GITHUB_APP_ID") (Id . read) <$> lookupEnv "GITHUB_APP_ID")
39− <*> readPem
40− <*> (maybe 8080 read <$> lookupEnv "PORT")
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")
44− <*> (fromMaybe (error "no TASKS") <$> lookupEnv "TASKS")
45− <*> (maybe (error "no DATABASE_URL") BS8.pack <$> lookupEnv "DATABASE_URL")
46− <*> (fromMaybe "http://localhost:8080" <$> lookupEnv "PORT")
47− where
48− readPem :: IO PrivateKey
49− readPem = do
50− path <- fromMaybe (error "no app pk") <$> lookupEnv "GITHUB_APP_PK"
51− pem <- BS.readFile path
52− case readRsaPem pem of
53− Right k -> return k
54− Left e -> error (show e)
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")
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")
89+-- <*> (fromMaybe "TmpDockerfile" <$> lookupEnv "DOCKER_FILE")
90+-- <*> (maybe Info read <$> lookupEnv "LOG_SEVERITY")
91+-- where
92+-- readPem :: IO PrivateKey
93+-- readPem = do
94+-- path <- fromMaybe (error "no app pk") <$> lookupEnv "GITHUB_APP_PK"
95+-- pem <- BS.readFile path
96+-- case readRsaPem pem of
97+-- Right k -> return k
98+-- Left e -> error (show e)
5599
56100deriving instance Show ReadRsaKeyError
src/Server/Html.hs+49−13
@@ -1,3 +1,5 @@
1+{-# OPTIONS_GHC -Wno-orphans #-}
2+
13module Server.Html
24 ( getSubmissionR,
35 MonadHasBaseUrl (..),
@@ -8,16 +10,13 @@ where
810
911import Clay as C
1012import Colog
11−import Control.Monad.IO.Class
1213import Control.Monad.IO.Unlift
13−import Data.Aeson hiding (Success)
14−import qualified Data.ByteString.Lazy.Char8 as BS
14+import Data.Foldable
1515import qualified Data.Map as M
1616import Data.String
1717import Data.Submission
1818import Data.Submission.Query
1919import qualified Data.Text as T
20−import GHC.Generics
2120import Server.Schema
2221import Squeal.PostgreSQL (Jsonb (..))
2322import Text.Blaze
@@ -31,24 +30,25 @@ getSubmissionR ::
3130 String ->
3231 String ->
3332 m Markup
34−getSubmissionR user repo sha = do
35− restartUrl <- (<> "/restart") <$> getUrl (user <> "/" <> repo) sha
33+getSubmissionR user repo sha' = do
34+ restartUrl <- (<> "/restart") <$> getUrl (user <> "/" <> repo) sha'
3635 let restartBuild = do
3736 H.form H.! A.action (fromString restartUrl) H.! A.method "post" $
3837 H.input H.! A.type_ "submit" H.! A.value "Restart test"
39− (titleText, inner) <- getSubmission (user <> "/" <> repo) sha >>= \case
38+ (titleText, inner) <- getSubmission (user <> "/" <> repo) sha' >>= \case
4039 Nothing ->
4140 return . ("Not found",) $
4241 H.h1 "404. not found. go away."
43− Just Submission {..} -> return . (repo,) $ do
42+ Just Submission {..} -> return . (problem,) $ do
4443 H.h1 $ toHtml problem
4544 H.h2 $ toHtml userName
45+ H.h3 . H.code . toHtml . take 7 $ sha
4646 case status of
4747 Jsonb BuildScheduled -> do
48− H.h3 "Waiting to build"
48+ H.h3 "Waiting to build ⌛"
4949 restartBuild
5050 Jsonb (SubmissionFailed err) -> do
51− H.h3 "Failed to build"
51+ H.h3 "Failed to build ☠️"
5252 restartBuild
5353 H.code . H.pre $ toHtml err
5454 Jsonb (SubmissionRun (TestResult tests)) -> do
@@ -56,11 +56,13 @@ getSubmissionR user repo sha = do
5656 passed = M.size . M.filter Prelude.id $ tests
5757 H.h3 . toHtml $
5858 "Tests have run: " <> show passed <> "/" <> show total
59− <> if passed == total then " ✅" else ""
59+ <> if passed == total then " 🎉" else " 🍌"
6060 restartBuild
6161 H.table $ flip M.foldMapWithKey tests $ \testName testPassed -> H.tr $ do
6262 (H.td H.! A.align "right") . H.p $ toHtml testName
6363 H.td $ if testPassed then "✅" else "❌"
64+ Jsonb PastDeadline ->
65+ H.h3 "This was submitted after the deadline ⏰"
6466 return . docTypeHtml $ do
6567 H.head $ do
6668 H.title $ toHtml titleText
@@ -84,18 +86,21 @@ getSubmissionR user repo sha = do
8486 C.td ? do
8587 C.padding (px 4) (px 4) (px 4) (px 4)
8688 C.form ? do
89+ C.display C.block
90+ C.width (pct 100)
91+ C.input ? do
8792 C.display C.block
8893 C.marginLeft auto
8994 C.marginRight auto
9095 H.body inner
9196
9297class MonadHasBaseUrl m where
93− getBaseUrl :: m String
98+ getBaseUrl :: m T.Text
9499
95100getUrl :: (MonadHasBaseUrl m, Monad m) => String -> String -> m String
96101getUrl fullName sha = do
97102 siteBase <- getBaseUrl
98− return $ siteBase <> "/submission/" <> fullName <> "/" <> sha
103+ return $ T.unpack siteBase <> "/submission/" <> fullName <> "/" <> sha
99104
100105redirectToSubmission ::
101106 (MonadHasBaseUrl m, Monad m) =>
@@ -109,3 +114,34 @@ redirectToSubmission user repo sha = do
109114 H.meta
110115 H.! A.httpEquiv "refresh"
111116 H.! A.content (fromString $ "0; URL=" <> rUrl)
117+
118+instance ToMarkup [Score] where
119+ toMarkup xs = docTypeHtml $ do
120+ H.style . preEscapedToHtml . render $ do
121+ C.body ? do
122+ fontFamily [] [sansSerif]
123+ C.maxWidth (px 800)
124+ C.display C.block
125+ C.marginLeft auto
126+ C.marginRight auto
127+ C.paddingLeft (px 16)
128+ C.paddingRight (px 16)
129+ (C.h1 <> C.h2 <> C.h3) ? do
130+ textAlign center
131+ C.pre ? do
132+ C.whiteSpace C.preWrap
133+ (C.tr <> C.td) ? do
134+ C.width (pct 50)
135+ C.td ? do
136+ C.padding (px 4) (px 4) (px 4) (px 4)
137+ C.border solid (px 1) black
138+ C.margin (px 0) (px 0) (px 0) (px 0)
139+ C.table ? do
140+ C.borderCollapse (other "collapse")
141+ C.width (pct 100)
142+ H.body
143+ $ H.table
144+ $ for_ xs
145+ $ \(Score user score) -> H.tr $ do
146+ (H.td H.! A.align "right") . H.code $ toHtml user
147+ H.td $ toHtml score
src/Server/Schema.hs+3−1
@@ -6,13 +6,15 @@ module Server.Schema
66where
77
88import Server.Schema.V1
9+import Server.Schema.V2
910import Squeal.PostgreSQL
1011
1112type StaticPQ m = MonadPQ Schema m
1213
13−type Schema = SchemaV1
14+type Schema = SchemaV2
1415
1516migration :: AlignedList (Migration (Terminally PQ IO)) (Public '[]) Schema
1617migration =
1718 pureMigration schemaMigrationV1
19+ :>> pureMigration schemaMigrationV2
1820 :>> Done
src/Server/Schema/V1.hs+25−22
@@ -18,7 +18,8 @@ type SchemaV1 =
1818 ]
1919 :=> '[ "task" ::: 'NoDef :=> 'NotNull (PG Text),
2020 "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)
2223 ]
2324 ),
2425 "submissions"
@@ -34,28 +35,30 @@ type SchemaV1 =
3435 ]
3536
3637schemaMigrationV1 :: Migration Definition (Public '[]) SchemaV1
37−schemaMigrationV1 = Migration
38− { name = "v1",
39− up =
40− createTable
41− #tasks
42− ( notNullable text `as` #task
43− :* notNullable jsonb `as` #payload
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
53− :* notNullable jsonb `as` #status
38+schemaMigrationV1 =
39+ Migration
40+ { name = "v1",
41+ up =
42+ createTable
43+ #tasks
44+ ( notNullable text `as` #task
45+ :* notNullable jsonb `as` #payload
46+ :* default_ now (notNullable timestampWithTimeZone) `as` #creation_time
47+ :* default_ false (notNullable bool) `as` #started
5448 )
55− (primaryKey (#repo_full_name :* #sha) `as` #pk_submission_repo_full_name_sha)
56− >>> createIndexes,
57− down = dropTable #tasks >>> dropTable #submissions
58− }
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)
59+ >>> createIndexes,
60+ down = dropTable #tasks >>> dropTable #submissions
61+ }
5962 where
6063 createIndexes :: Definition sch sch
6164 createIndexes =
src/Server/Schema/V2.hsnew file+46
@@ -0,0 +1,46 @@
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+5−2
@@ -17,7 +17,7 @@
1717#
1818# resolver: ./custom-snapshot.yaml
1919# resolver: https://example.com/snapshots/2018-01-01.yaml
20−resolver: lts-14.19
20+resolver: lts-14.27
2121
2222# User packages to be built.
2323# Various formats can be used as shown in the example below.
@@ -40,12 +40,15 @@ packages:
4040# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
4141#
4242extra-deps:
43−- github-0.24
43+- github-0.25
4444- binary-instances-1
4545- squeal-postgresql-0.5.2.0
4646- git: https://github.com/ilyakooo0/github-app
4747 commit: 0bede85ab53eb8f953cf6f4e58a756a205e88e0b
4848- servant-github-webhook-0.4.2.0
49+- http-client-0.5.14
50+- git: https://github.com/ilyakooo0/docker-hs
51+ commit: 5cfdc4d7facd7043f530bce4ce0f0c57c923b029
4952
5053# Override default flag values for local packages and extra-deps
5154# flags: {}
tasks.yamlnew file+11
@@ -0,0 +1,11 @@
1+test-task:
2+ prebuild: |
3+ cp -f ../../test-task/package.yaml .
4+ cp -f ../../test-task/stack.yaml .
5+ cp -f -R ../../test-task/test .
6+ dockerfile: |
7+ FROM fast-lts-14.20
8+ COPY . src
9+ WORKDIR /src
10+ ENTRYPOINT stack test --fast
11+ timeoutMinutes: 10