git.iko.soy/sc-build
on master help sign in
swap
991579d37 ahead, 0 behind
.gitignorenew file+2
since splitsnapshots
unifiedsplit
@@ -0,0 +1,2 @@
1+.stack-work
2+*.cabal
LICENSE+1−1
@@ -1,6 +1,6 @@
1MIT License
1MIT License
2
2
3−Copyright (c) 2020 iko
3+Copyright (c) 2020 Ilya Kostyuchenko
4
4
5Permission is hereby granted, free of charge, to any person obtaining a copy
5Permission is hereby granted, free of charge, to any person obtaining a copy
6of this software and associated documentation files (the "Software"), to deal
6of this software and associated documentation files (the "Software"), to deal
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+```
Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
app/Main.hsnew file+30
@@ -0,0 +1,30 @@
1+module Main (main) where
2+
3+import qualified Data.ByteString.Char8 as BS
4+import Data.Yaml (encode)
5+import Options.Applicative
6+import Server
7+import Server.Config
8+
9+main :: IO ()
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+ )
hie.yamlnew file+4
@@ -0,0 +1,4 @@
1+cradle:
2+ stack:
3+ - path: "."
4+ component: "sc-build:lib"
migrations/Main.hsnew file+14
@@ -0,0 +1,14 @@
1+module Main
2+ ( main,
3+ )
4+where
5+
6+import Data.ByteString.Char8 (pack)
7+import Server.Schema
8+import Squeal.PostgreSQL
9+import System.Environment
10+
11+main :: IO ()
12+main = do
13+ Just dbString <- fmap pack <$> lookupEnv "DATABASE_URL"
14+ defaultMain dbString migration
package.yamlnew file+112
@@ -0,0 +1,112 @@
1+name: sc-build
2+version: 0.1.0.0
3+#synopsis:
4+#description:
5+homepage: https://github.com/ilyakooo0/sc-build#readme
6+license: BSD3
7+author: Ilya Kostyuchenko
8+maintainer: ilyakooo0@gmail.com
9+copyright: Ilya Kostyuchenko
10+category: Web
11+extra-source-files:
12+- README.md
13+
14+dependencies:
15+- base >= 4.7 && < 5
16+
17+library:
18+ source-dirs: src
19+ dependencies:
20+ - http-client-tls
21+ - servant
22+ - servant-server
23+ - process
24+ - yaml
25+ - aeson
26+ - github
27+ - github-app
28+ - github-webhooks
29+ - warp
30+ - vector
31+ - bytestring
32+ - servant-github-webhook
33+ - cryptonite
34+ - mtl
35+ - text
36+ - containers
37+ - random
38+ - time
39+ - typed-process
40+ - directory
41+ - squeal-postgresql
42+ - generics-sop
43+ - co-log
44+ - unliftio-core
45+ - unliftio
46+ - servant-blaze
47+ - blaze-markup
48+ - blaze-html
49+ - clay
50+ - docker
51+ - exceptions
52+ - transformers
53+ - cassava
54+ - http-media
55+ - utf8-string
56+
57+executables:
58+ sc-build-exe:
59+ main: Main.hs
60+ source-dirs: app
61+ ghc-options:
62+ - -threaded
63+ - -rtsopts
64+ - -with-rtsopts=-N
65+ dependencies:
66+ - sc-build
67+ - bytestring
68+ - yaml
69+ - optparse-applicative
70+ sc-build-migrations:
71+ main: Main.hs
72+ source-dirs: migrations
73+ ghc-options:
74+ - -threaded
75+ - -rtsopts
76+ - -with-rtsopts=-N
77+ dependencies:
78+ - sc-build
79+ - bytestring
80+ - squeal-postgresql
81+
82+default-extensions:
83+- AllowAmbiguousTypes
84+- ConstraintKinds
85+- DataKinds
86+- DeriveAnyClass
87+- DeriveFunctor
88+- DeriveGeneric
89+- DerivingStrategies
90+- DuplicateRecordFields
91+- FlexibleContexts
92+- FlexibleInstances
93+- FunctionalDependencies
94+- GADTs
95+- GeneralizedNewtypeDeriving
96+- InstanceSigs
97+- LambdaCase
98+- MultiParamTypeClasses
99+- OverloadedLabels
100+- OverloadedStrings
101+- PatternSynonyms
102+- PolyKinds
103+- QuantifiedConstraints
104+- RankNTypes
105+- RecordWildCards
106+- ScopedTypeVariables
107+- StandaloneDeriving
108+- TupleSections
109+- TypeApplications
110+- TypeFamilies
111+- TypeOperators
112+- UndecidableInstances
src/Control/AppRequestable.hsnew file+10
@@ -0,0 +1,10 @@
1+module Control.AppRequestable
2+ ( AppRequestable (..),
3+ )
4+where
5+
6+import Data.Aeson
7+import GitHub
8+
9+class AppRequestable m where
10+ appRequest :: FromJSON a => GenRequest 'MtJSON rw a -> m (Either Error a)
src/Control/GithubCloner.hsnew file+10
@@ -0,0 +1,10 @@
1+module Control.GithubCloner
2+ ( GithubCloner (..),
3+ InstallationToken (..),
4+ )
5+where
6+
7+newtype InstallationToken = InstallationToken String
8+
9+class GithubCloner m where
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/Squeal.hsnew file+81
@@ -0,0 +1,81 @@
1+{-# LANGUAGE TypeApplications #-}
2+
3+module Control.Squeal
4+ ( db,
5+ db',
6+ dbRead,
7+ dbRead',
8+ dbWrite,
9+ dbWrite',
10+ )
11+where
12+
13+import Colog
14+import Control.Monad.Except
15+import Control.Monad.IO.Unlift
16+import qualified Data.Text as T
17+import Squeal.PostgreSQL
18+
19+db ::
20+ forall schemas m env x.
21+ (MonadPQ schemas m, WithLog env Message m, MonadUnliftIO m) =>
22+ Maybe TransactionMode ->
23+ (SquealException -> m x) ->
24+ m x ->
25+ m x
26+db tr err pqx = (trySqueal . maybe id transactionallyRetry tr) pqx >>= \case
27+ Left e -> do
28+ logWarning . T.pack $ "SQL ERROR: " <> show e
29+ err e
30+ Right x -> return x
31+
32+dbRead ::
33+ (MonadPQ schemas m, WithLog env Message m, MonadUnliftIO m) =>
34+ (SquealException -> m x) ->
35+ m x ->
36+ m x
37+dbRead = db Nothing
38+
39+dbRead' ::
40+ ( MonadPQ schemas m,
41+ MonadError err m,
42+ WithLog env Message m,
43+ MonadUnliftIO m
44+ ) =>
45+ err ->
46+ m x ->
47+ m x
48+dbRead' = db' Nothing
49+
50+dbWrite ::
51+ (MonadPQ schemas m, WithLog env Message m, MonadUnliftIO m) =>
52+ (SquealException -> m x) ->
53+ m x ->
54+ m x
55+dbWrite = db $ Just defaultWriteTransactionMode
56+
57+dbWrite' ::
58+ ( MonadPQ schemas m,
59+ MonadError err m,
60+ WithLog env Message m,
61+ MonadUnliftIO m
62+ ) =>
63+ err ->
64+ m x ->
65+ m x
66+dbWrite' = db' $ Just defaultWriteTransactionMode
67+
68+defaultWriteTransactionMode :: TransactionMode
69+defaultWriteTransactionMode = TransactionMode RepeatableRead ReadWrite NotDeferrable
70+
71+db' ::
72+ ( MonadPQ schemas m,
73+ MonadError err m,
74+ WithLog env Message m,
75+ MonadUnliftIO m
76+ ) =>
77+ Maybe TransactionMode ->
78+ err ->
79+ m x ->
80+ m x
81+db' tr err = db tr (const $ throwError err)
src/Control/Task.hsnew file+26
@@ -0,0 +1,26 @@
1+module Control.Task
2+ ( Task (..),
3+ Result (..),
4+ )
5+where
6+
7+import Colog
8+import Data.Aeson hiding (Result)
9+import Data.Kind
10+import GHC.Generics
11+import GHC.TypeLits
12+
13+data Result
14+ = Success
15+ | Failure
16+ deriving (Eq, Ord, Show, Generic)
17+
18+class
19+ (ToJSON t, FromJSON t, KnownSymbol s, Show t) =>
20+ Task t s
21+ | s -> t,
22+ t -> s where
23+
24+ type TaskMonad t (m :: * -> *) :: Constraint
25+
26+ performTask :: (TaskMonad t m, WithLog env Message m) => t -> m Result
src/Control/Task/Scheduler.hsnew file+87
@@ -0,0 +1,87 @@
1+{-# LANGUAGE TypeApplications #-}
2+
3+module Control.Task.Scheduler
4+ ( scheduleTask,
5+ runTasks,
6+ makeAllRunnable,
7+ )
8+where
9+
10+import Colog
11+import Control.Monad
12+import Control.Monad.IO.Unlift
13+import Control.Task
14+import Control.Task.Scheduler.Query
15+import Data.Aeson hiding (Result (..))
16+import qualified Data.Aeson as A
17+import Data.Foldable
18+import Data.Proxy
19+import qualified Data.Text as T
20+import Data.Word
21+import GHC.TypeLits
22+import Server.Schema
23+import Squeal.PostgreSQL
24+import UnliftIO.Exception
25+
26+scheduleTask ::
27+ (StaticPQ m, WithLog env Message m, Task t s, MonadUnliftIO m) =>
28+ t ->
29+ m ()
30+scheduleTask = scheduleTaskQuery
31+
32+runTasks ::
33+ forall tt m env.
34+ (StaticPQ m, WithLog env Message m, RunTasks tt m, MonadUnliftIO m) =>
35+ Word64 ->
36+ m Int
37+runTasks n = do
38+ tasks <- pickTasksQuery (taskNames @tt @m) n
39+ for_ tasks $ runTask @tt @m
40+ return $ length tasks
41+
42+rescheduleTaskTime ::
43+ forall t s m env.
44+ (Task t s, StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>
45+ t ->
46+ m ()
47+rescheduleTaskTime = rescheduleTaskQuery
48+
49+class RunTasks (ts :: [*]) m where
50+ runTask :: WithLog env Message m => PickedTask -> m ()
51+
52+ taskNames :: [String]
53+
54+instance
55+ forall t ts tt m.
56+ (Task t ts, TaskMonad t m, StaticPQ m, RunTasks tt m, MonadUnliftIO m) =>
57+ RunTasks (t ': tt) m
58+ where
59+ runTask (PickedTask s (Jsonb v) initialStartTime) | symbolVal @ts Proxy == s =
60+ case fromJSON @t v of
61+ A.Error e ->
62+ logError . T.pack $
63+ "Coulndn't decode payload for task " <> s
64+ <> " with payload "
65+ <> show v
66+ <> " with error "
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
71+ logError . T.pack . displayException $ e
72+ return Failure
73+ when (r == Failure) $ logWarning . T.pack $ "Task " <> task <> " failed"
74+ case r of
75+ Success -> completeTaskQuery t
76+ Failure -> rescheduleTaskTime t
77+ where
78+ task = symbolVal @ts Proxy
79+ runTask t = runTask @tt @m t
80+
81+ taskNames = symbolVal @ts Proxy : taskNames @tt @m
82+
83+instance RunTasks '[] m where
84+ runTask (PickedTask s (Jsonb v) _) =
85+ logError . T.pack $ "Unknown task " <> s <> " with payload " <> show v
86+
87+ taskNames = []
src/Control/Task/Scheduler/Query.hsnew file+154
@@ -0,0 +1,154 @@
1+{-# LANGUAGE TypeApplications #-}
2+
3+module Control.Task.Scheduler.Query
4+ ( scheduleTaskQuery,
5+ completeTaskQuery,
6+ rescheduleTaskQuery,
7+ pickTasksQuery,
8+ makeAllRunnable,
9+ PickedTask (..),
10+ )
11+where
12+
13+import Colog
14+import Control.Arrow
15+import Control.Monad.IO.Unlift
16+import Control.Squeal
17+import Control.Task
18+import Data.Aeson hiding (Result (..))
19+import Data.Proxy
20+import qualified Data.Text as T
21+import Data.Time
22+import Data.Word
23+import GHC.Generics (Generic)
24+import GHC.TypeLits
25+import qualified Generics.SOP as SOP
26+import Server.Schema
27+import Squeal.PostgreSQL
28+
29+scheduleTaskQuery ::
30+ forall m t s env.
31+ (StaticPQ m, Task t s, WithLog env Message m, MonadUnliftIO m) =>
32+ t ->
33+ m ()
34+scheduleTaskQuery task = do
35+ logInfo . T.pack $ "schdeuling task: " <> show task
36+ let query =
37+ insertInto
38+ #tasks
39+ ( Values_ $
40+ Set (param @1) `as` #task
41+ :* Set (param @2) `as` #payload
42+ :* Default `as` #creation_time
43+ :* Default `as` #started
44+ :* Default `as` #failures
45+ )
46+ ( OnConflict
47+ (OnConstraint #pk_task_payload)
48+ (DoUpdate (Default `as` #creation_time) [])
49+ )
50+ (Returning_ Nil)
51+ dbWrite (const $ return ()) $
52+ manipulateParams_
53+ query
54+ (symbolVal @s Proxy, Jsonb $ toJSON task)
55+
56+completeTaskQuery ::
57+ forall m t s env.
58+ (StaticPQ m, Task t s, WithLog env Message m, MonadUnliftIO m) =>
59+ t ->
60+ m ()
61+completeTaskQuery payload = do
62+ let task = symbolVal @s Proxy
63+ logInfo . T.pack $ "Completing task: " <> task <> " with payload " <> show payload
64+ let query :: Manipulation_ Schema (String, Jsonb Value) ()
65+ query =
66+ deleteFrom_
67+ #tasks
68+ (param @1 .== #task .&& param @2 .== #payload)
69+ dbWrite (const $ return ()) $
70+ manipulateParams_
71+ query
72+ (symbolVal @s Proxy, Jsonb $ toJSON payload)
73+
74+rescheduleTaskQuery ::
75+ forall s t m env.
76+ (StaticPQ m, Task t s, WithLog env Message m, MonadUnliftIO m) =>
77+ t ->
78+ m ()
79+rescheduleTaskQuery payload = do
80+ let task = symbolVal @s Proxy
81+ logInfo . T.pack $
82+ "reschdeuling task: " <> task
83+ <> " with payload "
84+ <> show payload
85+ let query :: Manipulation_ Schema (String, Jsonb Value) ()
86+ query =
87+ update_
88+ #tasks
89+ ( Default `as` #creation_time
90+ :* Default `as` #started
91+ :* Set (#failures + 1) `as` #failures
92+ )
93+ (param @1 .== #task .&& param @2 .== #payload)
94+ dbWrite (const $ return ()) $
95+ manipulateParams_
96+ query
97+ (symbolVal @s Proxy, Jsonb $ toJSON payload)
98+
99+pickTasksQuery ::
100+ forall m env.
101+ (StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>
102+ [String] ->
103+ Word64 ->
104+ m [PickedTask]
105+pickTasksQuery tasks limitCount = do
106+ logDebug $ "reading tasks " <> T.unwords (T.pack <$> tasks)
107+ let query :: Query_ Schema () PickedTask
108+ query =
109+ select_
110+ ( #task `as` #task
111+ :* #payload `as` #payload
112+ :* #creation_time `as` #creationTime
113+ )
114+ ( from (table #tasks)
115+ & where_ (#task `in_` (literal <$> tasks))
116+ & where_ (not_ . notNull $ #started)
117+ & where_ (#failures .< 20)
118+ & orderBy [#creation_time & Asc]
119+ & limit limitCount
120+ & orderBy [#creation_time & Desc]
121+ )
122+ startedMan :: Manipulation_ Schema (String, Jsonb Value) ()
123+ startedMan =
124+ update_
125+ #tasks
126+ ( Set true `as` #started
127+ )
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
133+
134+data PickedTask
135+ = PickedTask
136+ { task :: String,
137+ payload :: Jsonb Value,
138+ creationTime :: UTCTime
139+ }
140+ deriving (Eq, Show, Generic, SOP.Generic, SOP.HasDatatypeInfo)
141+
142+makeAllRunnable ::
143+ (StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>
144+ m ()
145+makeAllRunnable = do
146+ let startAll :: Manipulation_ Schema () ()
147+ startAll =
148+ update_
149+ #tasks
150+ ( Set false `as` #started
151+ )
152+ (notNull #started)
153+ dbWrite (const $ return ()) $
154+ manipulate_ startAll
src/Data/Submission.hsnew file+47
@@ -0,0 +1,47 @@
1+module Data.Submission
2+ ( Submission (..),
3+ SubmissionStatus (..),
4+ TestResult (..),
5+ Score (..),
6+ )
7+where
8+
9+import Data.Aeson
10+import Data.Csv
11+import Data.Int
12+import Data.Map (Map)
13+import Data.Text (Text)
14+import GHC.Generics (Generic)
15+import qualified Generics.SOP as SOP
16+import Squeal.PostgreSQL
17+
18+data Submission
19+ = Submission
20+ { userName :: String,
21+ repoFullName :: String,
22+ problem :: String,
23+ sha :: String,
24+ status :: Jsonb SubmissionStatus
25+ }
26+ deriving (Eq, Show, Generic, SOP.Generic, SOP.HasDatatypeInfo)
27+
28+data SubmissionStatus
29+ = SubmissionRun TestResult
30+ | SubmissionFailed String
31+ | BuildScheduled
32+ | PastDeadline
33+ deriving (Generic, FromJSON, ToJSON, Eq, Show)
34+
35+newtype TestResult
36+ = TestResult
37+ { tests :: Map Text Bool
38+ }
39+ deriving stock (Eq, Show, Generic)
40+ deriving anyclass (FromJSON, ToJSON)
41+
42+data Score
43+ = Score
44+ { userName :: String,
45+ score :: Int64
46+ }
47+ deriving (Eq, Show, Generic, SOP.Generic, SOP.HasDatatypeInfo, ToRecord)
src/Data/Submission/Query.hsnew file+99
@@ -0,0 +1,99 @@
1+{-# LANGUAGE TypeApplications #-}
2+
3+module Data.Submission.Query
4+ ( createSubmission,
5+ updateSubmissionStatus,
6+ getSubmission,
7+ getResults,
8+ )
9+where
10+
11+import Colog
12+import Control.Monad.IO.Unlift
13+import Control.Squeal
14+import Data.Submission
15+import qualified Data.Text as T
16+import Server.Schema
17+import Squeal.PostgreSQL
18+
19+createSubmission ::
20+ (StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>
21+ Submission ->
22+ m ()
23+createSubmission s@Submission {..} = do
24+ logInfo . T.pack $ "Creating submission: " <> show s
25+ let query =
26+ insertInto
27+ #submissions
28+ ( Values_ $
29+ Set (param @1) `as` #user_name
30+ :* Set (param @2) `as` #repo_full_name
31+ :* Set (param @3) `as` #problem
32+ :* Set (param @4) `as` #sha
33+ :* Set (param @5) `as` #status
34+ )
35+ ( OnConflict
36+ (OnConstraint #pk_submission_repo_full_name_sha)
37+ DoNothing
38+ )
39+ (Returning_ Nil)
40+ dbWrite (const $ return ()) $
41+ manipulateParams_
42+ query
43+ (userName, repoFullName, problem, sha, status)
44+
45+updateSubmissionStatus ::
46+ (StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>
47+ String ->
48+ String ->
49+ SubmissionStatus ->
50+ m ()
51+updateSubmissionStatus repoFullName sha status = do
52+ let query :: Manipulation_ Schema (Jsonb SubmissionStatus, String, String) ()
53+ query =
54+ update_
55+ #submissions
56+ (Set (param @1) `as` #status)
57+ (#repo_full_name .== param @2 .&& #sha .== param @3)
58+ dbWrite (const $ return ()) $
59+ manipulateParams_
60+ query
61+ (Jsonb status, repoFullName, sha)
62+
63+getSubmission ::
64+ (StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>
65+ String ->
66+ String ->
67+ m (Maybe Submission)
68+getSubmission repoFullName sha = do
69+ let query :: Query_ Schema (String, String) Submission
70+ query =
71+ select_
72+ ( #user_name `as` #userName
73+ :* #repo_full_name `as` #repoFullName
74+ :* #problem `as` #problem
75+ :* #sha `as` #sha
76+ :* #status `as` #status
77+ )
78+ ( from (table #submissions)
79+ & where_
80+ (#repo_full_name .== param @1 .&& #sha .== param @2)
81+ )
82+ dbRead (const $ return Nothing) $
83+ runQueryParams
84+ query
85+ (repoFullName, sha)
86+ >>= firstRow
87+
88+getResults ::
89+ (StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>
90+ String ->
91+ m [Score]
92+getResults task = do
93+ let query :: Query_ Schema (Only String) Score
94+ query = UnsafeQuery "select a.user_name as \"userName\", max(a.correct) as score from (select (select count(*) as correct from jsonb_each_text(submissions.status -> 'contents' -> 'tests') where value = 'true'), user_name from submissions where problem = $1) as a group by user_name"
95+ dbRead (const $ return []) $
96+ runQueryParams
97+ query
98+ (Only task)
99+ >>= getRows
src/Data/Tasks/Build.hsnew file+201
@@ -0,0 +1,201 @@
1+{-# LANGUAGE TypeApplications #-}
2+{-# OPTIONS_GHC -Wno-orphans #-}
3+
4+module Data.Tasks.Build
5+ ( Build (..),
6+ HasDockerInfo (..),
7+ )
8+where
9+
10+import Colog
11+import Control.Concurrent
12+import Control.GithubCloner
13+import Control.HasGithubStatus
14+import Control.Monad.Except
15+import Control.Monad.IO.Unlift
16+import Control.Task
17+import Data.Aeson hiding (Success)
18+import qualified Data.ByteString.Lazy.Char8 as BS
19+import qualified Data.ByteString.Lazy.UTF8 as BS
20+import Data.String
21+import Data.Submission
22+import Data.Submission.Query
23+import qualified Data.Text as T
24+import Data.Time.Clock.POSIX
25+import qualified Docker.Client as D
26+import GHC.Generics
27+import GitHub
28+import Server.Schema
29+import System.Directory
30+import System.Exit
31+import System.Process.Typed
32+import System.Random
33+import UnliftIO.Async
34+import UnliftIO.Exception
35+
36+data Build
37+ = Build
38+ { preProcessShell :: String,
39+ dockerFile :: String,
40+ owner :: Name Owner,
41+ repoName :: Name Repo,
42+ sha :: Name Commit,
43+ timeoutMinutes :: Int
44+ }
45+ deriving (Eq, Show, Generic, FromJSON, ToJSON)
46+
47+instance Task Build "build-repo" where
48+ type
49+ TaskMonad Build m =
50+ (MonadUnliftIO m, StaticPQ m, HasDockerInfo m, GithubCloner m, HasGithubStatus m)
51+
52+ performTask Build {..} =
53+ bracket createDir (liftIO . removePathForcibly) $ \dir -> flip catchAny (const $ return Failure) $ do
54+ cloneRepo fullRepoName sha' dir
55+ (shellCode, _, shellErr) <- readProcess . setWorkingDir dir $ shell preProcessShell
56+ case shellCode of
57+ ExitFailure n -> do
58+ let err = BS.toString shellErr
59+ logError . T.pack $
60+ "preprocessing command for repo " <> show fullRepoName <> " at sha "
61+ <> show sha
62+ <> " exited with code "
63+ <> show n
64+ <> " and error "
65+ <> err
66+ scheduleFailedStatus err owner repoName sha
67+ updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
68+ ExitSuccess -> do
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
133+ logError . T.pack $
134+ "test command for repo " <> show fullRepoName <> " at sha "
135+ <> show sha
136+ <> " exited with code "
137+ <> show n
138+ <> " and error "
139+ <> err
140+ scheduleFailedStatus err owner repoName sha
141+ updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
142+ (ExitSuccess, buildOut, _) ->
143+ case eitherDecode' (BS.dropWhile (/= '{') buildOut) of
144+ Left err' -> do
145+ let err = err' <> " " <> BS.toString buildOut
146+ logError . T.pack $
147+ "could not decode test result from repo " <> show fullRepoName
148+ <> " at sha "
149+ <> show sha
150+ <> ": "
151+ <> err
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
156+ updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)
157+ return Success
158+ where
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
177+
178+createDir :: MonadIO m => m FilePath
179+createDir = do
180+ dir <- ("tmp/" <>) <$> getTmpDirName
181+ liftIO $ createDirectoryIfMissing True dir
182+ return dir
183+
184+cloneRepo :: (MonadIO m, GithubCloner m) => String -> String -> FilePath -> m ()
185+cloneRepo repoName sha path = do
186+ InstallationToken token <- getGithubInstallationToken
187+ runProcess_ . setWorkingDir path . fromString $
188+ "git clone https://x-access-token:" <> token <> "@github.com/" <> repoName <> ".git ."
189+ runProcess_ . setWorkingDir path . fromString $ "git checkout " <> sha
190+ return ()
191+
192+getTmpDirName :: MonadIO m => m FilePath
193+getTmpDirName = liftIO $ do
194+ time :: Integer <- round <$> getPOSIXTime
195+ i <- randomIO @Int
196+ 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.hsnew file+40
@@ -0,0 +1,40 @@
1+{-# OPTIONS_GHC -Wno-orphans #-}
2+
3+module Data.Tasks.StatusUpdate
4+ ( StatusUpdate (..),
5+ )
6+where
7+
8+import Colog
9+import Control.AppRequestable
10+import Control.Task
11+import Data.Aeson hiding (Success)
12+import qualified Data.Text as T
13+import GHC.Generics
14+import GitHub
15+
16+data StatusUpdate
17+ = StatusUpdate
18+ { owner :: Name Owner,
19+ repoName :: Name Repo,
20+ sha :: Name Commit,
21+ status :: NewStatus
22+ }
23+ deriving (Eq, Show, Generic, ToJSON, FromJSON)
24+
25+instance FromJSON NewStatus where
26+ parseJSON = withObject "NewStatus" $ \v ->
27+ NewStatus
28+ <$> v .: "state"
29+ <*> v .:? "target_url"
30+ <*> v .:? "description"
31+ <*> v .:? "context"
32+
33+instance Task StatusUpdate "update-commit-ci-status" where
34+ type TaskMonad StatusUpdate m = (AppRequestable m)
35+
36+ performTask StatusUpdate {..} = do
37+ response <- appRequest $ createStatusR owner repoName sha status
38+ case response of
39+ Left err -> logError (T.pack $ show err) >> return Failure
40+ Right st -> logDebug (T.pack $ show st) >> return Success
src/Server.hsnew file+381
@@ -0,0 +1,381 @@
1+{-# LANGUAGE TypeApplications #-}
2+{-# OPTIONS_GHC -Wno-orphans #-}
3+
4+module Server
5+ ( runServer,
6+ )
7+where
8+
9+import Colog
10+import Control.AppRequestable
11+import Control.Concurrent
12+import Control.GithubCloner
13+import Control.HasGithubStatus
14+import Control.Monad.Except
15+import Control.Monad.IO.Unlift
16+import Control.Monad.Reader
17+import Control.Task.Scheduler
18+import Crypto.PubKey.RSA.Read
19+import Data.Aeson
20+import 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
25+import Data.IORef
26+import Data.Map (Map)
27+import qualified Data.Map as M
28+import Data.Submission
29+import Data.Submission.Query
30+import Data.Tasks.Build
31+import Data.Tasks.StatusUpdate
32+import qualified Data.Text as T
33+import Data.Time.Clock
34+import Data.Yaml
35+import GHC.Generics
36+import GitHub hiding (Accept)
37+import GitHub.App.Auth
38+import GitHub.App.Request
39+import GitHub.Auth (Auth (OAuth))
40+import GitHub.Data.Name
41+import GitHub.Data.Webhooks.Events
42+import GitHub.Data.Webhooks.Payload hiding (URL (..))
43+import Network.HTTP.Client.TLS (newTlsManager)
44+import Network.HTTP.Media.MediaType
45+import Network.Wai.Handler.Warp
46+import Servant
47+import Servant.GitHub.Webhook
48+import Servant.HTML.Blaze
49+import Server.Config
50+import Server.Html
51+import Server.Schema
52+import Squeal.PostgreSQL
53+import Text.Blaze.Html
54+import UnliftIO.Exception (catch, displayException, handleAny, throwIO, try)
55+
56+type API =
57+ "github-webhook"
58+ :> ( GitHubEvent '[ 'WebhookInstallationEvent]
59+ :> GitHubSignedReqBody '[JSON] InstallationEvent
60+ :> Post '[JSON] ()
61+ :<|> GitHubEvent '[ 'WebhookPushEvent]
62+ :> GitHubSignedReqBody '[JSON] PushEvent
63+ :> Post '[JSON] ()
64+ )
65+ :<|> "submission"
66+ :> Capture "user name" String
67+ :> Capture "repo name" String
68+ :> Capture "sha" String
69+ :> Get '[HTML] Markup
70+ :<|> "submission"
71+ :> Capture "user name" String
72+ :> Capture "repo name" String
73+ :> Capture "sha" String
74+ :> "restart"
75+ :> Post '[HTML] Markup
76+ :<|> "results" :> Capture "task name" String :> Get '[CSV, HTML] [Score]
77+
78+webhookInstallation :: WithLog env Message m => RepoWebhookEvent -> ((), InstallationEvent) -> m ()
79+webhookInstallation _ ((), ev) =
80+ logInfo . T.pack . show $ ev
81+
82+webhookPushEvent ::
83+ ( StaticPQ m,
84+ MonadReader (ServerData m) m,
85+ MonadUnliftIO m,
86+ HasTasks m,
87+ MonadError ServerError m,
88+ WithLog env Message m
89+ ) =>
90+ RepoWebhookEvent ->
91+ ((), PushEvent) ->
92+ m ()
93+webhookPushEvent _ ((), ev) = do
94+ let repo = evPushRepository ev
95+ user = T.unpack . whUserLogin . evPushSender $ ev
96+ fullRepoName = whRepoFullName repo
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
101+ tasks <- getTasks
102+ let task =
103+ M.lookupMax $
104+ M.takeWhileAntitone (repoName >) tasks
105+ case task of
106+ Just (name, TaskConfig {..}) | T.take (T.length name) repoName == name -> do
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
129+ _ -> return ()
130+
131+retestSubmission ::
132+ (StaticPQ m, MonadReader (ServerData m) m, MonadUnliftIO m, HasTasks m, MonadHasBaseUrl m) =>
133+ String ->
134+ String ->
135+ String ->
136+ m Markup
137+retestSubmission owner repoName sha = do
138+ let fullRepoName = owner <> "/" <> repoName
139+ repoName' = T.pack repoName
140+ sha' = T.pack sha
141+ owner' = T.pack owner
142+ getSubmission fullRepoName sha >>= \case
143+ Nothing -> return ()
144+ Just _ -> do
145+ tasks <- getTasks
146+ let task =
147+ M.lookupMax $
148+ M.takeWhileAntitone (repoName' >) tasks
149+ case task of
150+ Just (name, TaskConfig {..}) | T.take (T.length name) repoName' == name -> do
151+ schedulePendingStatus (N owner') (N repoName') (N sha')
152+ updateSubmissionStatus fullRepoName sha BuildScheduled
153+ scheduleTask $ Build prebuild dockerfile (N owner') (N repoName') (N sha') timeoutMinutes
154+ _ -> return ()
155+ redirectToSubmission owner repoName sha
156+
157+newtype ServerM (schema :: SchemasType) a
158+ = ServerM
159+ { unApp :: ReaderT (ServerData (ServerM schema)) (PQ schema schema IO) a
160+ }
161+ deriving newtype
162+ ( Functor,
163+ Applicative,
164+ Monad,
165+ MonadIO,
166+ MonadReader (ServerData (ServerM schema)),
167+ MonadPQ schema,
168+ MonadUnliftIO
169+ )
170+
171+instance MonadError ServerError (ServerM schema) where
172+ throwError = throwIO
173+ catchError = catch
174+
175+server :: ServerT API (ServerM Schema)
176+server = (webhookInstallation :<|> webhookPushEvent) :<|> getSubmissionR :<|> retestSubmission :<|> getResults
177+
178+runServer :: FilePath -> IO ()
179+runServer config = do
180+ c@Config {..} <- getConfig config
181+ print c
182+ pem <- BS.readFile appPkPemPath
183+ appPkPem <- case readRsaPem pem of
184+ Right k -> return k
185+ Left e -> error (show e)
186+ auth <- mkInstallationAuth (AppAuth appId appPkPem) installationId
187+ ts <- newIORef mempty
188+ pool <- createConnectionPool databseUrl 1 0.5 10
189+ _ <- forkIO $ do
190+ updateTasks ts tasksPath
191+ threadDelay $ 5 * 60 * (10 ^ (6 :: Int))
192+ let context =
193+ gitPolyHubKey (return webhookSecret)
194+ :. EmptyContext
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+ }
204+ repeatIfNotEmpty n f = f >>= \m -> do
205+ when (m == 0) $ liftIO $ threadDelay n
206+ repeatIfNotEmpty n f
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))
216+ . usingConnectionPool pool
217+ . (`runReaderT` serverData)
218+ . unApp
219+ . printingErrors
220+ $ runTasks @'[Build] 1
221+ _ <-
222+ forkIO . repeatIfNotEmpty (10 ^ (6 :: Int))
223+ . usingConnectionPool pool
224+ . (`runReaderT` serverData)
225+ . unApp
226+ . printingErrors
227+ $ runTasks @'[StatusUpdate] 5
228+ run port $ serveWithContext (Proxy @API) context $
229+ hoistServerWithContext
230+ (Proxy @API)
231+ (Proxy @'[PolyGitHubKey])
232+ (Handler . ExceptT . try . usingConnectionPool pool . (`runReaderT` serverData) . unApp)
233+ server
234+
235+updateTasks :: IORef TasksConfig -> FilePath -> IO ()
236+updateTasks ref path =
237+ decodeFileEither path >>= \case
238+ Right a -> writeIORef ref a
239+ Left e -> print e
240+
241+data ServerData m
242+ = ServerData
243+ { githubAppAuth :: !InstallationAuth,
244+ tasks :: IORef TasksConfig,
245+ logger :: LogAction m Message,
246+ baseUrl :: T.Text,
247+ dockerUrl :: T.Text,
248+ context :: T.Text
249+ }
250+
251+newtype PolyGitHubKey = PolyGitHubKey (forall result. GitHubKey result)
252+
253+gitPolyHubKey :: IO ByteString -> PolyGitHubKey
254+gitPolyHubKey k = PolyGitHubKey (Servant.GitHub.Webhook.gitHubKey k)
255+
256+instance HasContextEntry '[PolyGitHubKey] (GitHubKey result) where
257+ getContextEntry (PolyGitHubKey x :. _) = x
258+
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."
271+
272+instance (MonadIO m, MonadReader (ServerData n) m) => AppRequestable m where
273+ appRequest req = do
274+ auth <- asks githubAppAuth
275+ liftIO $ executeAppRequest auth req
276+
277+instance MonadReader (ServerData n) m => MonadHasBaseUrl m where
278+ getBaseUrl = asks baseUrl
279+
280+instance (MonadIO m, MonadReader (ServerData n) m) => HasTasks m where
281+ getTasks = asks tasks >>= liftIO . readIORef
282+
283+instance (MonadReader (ServerData m) m, StaticPQ m, MonadUnliftIO m) => HasGithubStatus m where
284+ schedulePendingStatus nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do
285+ h <- asks baseUrl
286+ c <- asks context
287+ scheduleTask $
288+ StatusUpdate
289+ nOwner
290+ nRepo
291+ nCommit
292+ ( NewStatus
293+ StatusPending
294+ (Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha)
295+ (Just "⌛")
296+ (Just c)
297+ )
298+ scheduleTestedStatus TestResult {..} nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do
299+ h <- asks baseUrl
300+ c <- asks context
301+ let total = M.size tests
302+ passed = M.size . M.filter id $ tests
303+ description = T.pack $ show passed <> "/" <> show total <> if passed == total then " ✅" else " ❌"
304+ status =
305+ StatusUpdate
306+ nOwner
307+ nRepo
308+ nCommit
309+ NewStatus
310+ { newStatusState =
311+ if total == passed then StatusSuccess else StatusFailure,
312+ newStatusTargetUrl = Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha,
313+ newStatusDescription = Just description,
314+ newStatusContext = Just c
315+ }
316+ scheduleTask status
317+ scheduleFailedStatus _ nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do
318+ h <- asks baseUrl
319+ c <- asks context
320+ let status =
321+ StatusUpdate
322+ nOwner
323+ nRepo
324+ nCommit
325+ NewStatus
326+ { newStatusState = StatusError,
327+ newStatusTargetUrl = Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha,
328+ newStatusDescription = Just "Build failed ☠️",
329+ newStatusContext = Just c
330+ }
331+ scheduleTask status
332+ deadlineHasPassedStatus nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do
333+ h <- asks baseUrl
334+ c <- asks context
335+ let status =
336+ StatusUpdate
337+ nOwner
338+ nRepo
339+ nCommit
340+ NewStatus
341+ { newStatusState = StatusError,
342+ newStatusTargetUrl = Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha,
343+ newStatusDescription = Just "The deadline has passed ⏰",
344+ newStatusContext = Just c
345+ }
346+ scheduleTask status
347+
348+instance (MonadReader (ServerData n) m) => HasDockerInfo m where
349+ getDockerUrl = asks dockerUrl
350+
351+type TasksConfig = Map T.Text TaskConfig
352+
353+data TaskConfig
354+ = TaskConfig
355+ { prebuild :: String,
356+ dockerfile :: String,
357+ timeoutMinutes :: Int,
358+ deadline :: UTCTime
359+ }
360+ deriving stock (Show, Eq, Generic)
361+ deriving anyclass (FromJSON, ToJSON)
362+
363+class HasTasks m where
364+ getTasks :: m TasksConfig
365+
366+instance HasLog (ServerData m) Message m where
367+ getLogAction :: ServerData m -> LogAction m Message
368+ getLogAction = logger
369+ {-# INLINE getLogAction #-}
370+
371+ setLogAction :: LogAction m Message -> ServerData m -> ServerData m
372+ setLogAction newLogAction env = env {logger = newLogAction}
373+ {-# INLINE setLogAction #-}
374+
375+data CSV
376+
377+instance Accept CSV where
378+ contentType Proxy = "text" // "csv"
379+
380+instance Csv.ToRecord a => MimeRender CSV [a] where
381+ mimeRender Proxy = Csv.encode
src/Server/Config.hsnew file+100
@@ -0,0 +1,100 @@
1+{-# OPTIONS_GHC -Wno-orphans #-}
2+
3+module Server.Config
4+ ( Config (..),
5+ defaultConfig,
6+ getConfig,
7+ )
8+where
9+
10+import Colog
11+import Crypto.PubKey.RSA.Read
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
17+import GitHub.Data.Apps
18+import GitHub.Data.Id
19+import GitHub.Data.Installations
20+import Text.Read (readMaybe)
21+
22+data Config
23+ = Config
24+ { webhookSecret :: !ByteString,
25+ appId :: !(Id App),
26+ appPkPemPath :: !FilePath,
27+ port :: !Int,
28+ installationId :: !(Id Installation),
29+ tasksPath :: !FilePath,
30+ databseUrl :: !ByteString,
31+ baseSiteUrl :: !Text,
32+ cfgDockerUrl :: !String,
33+ logSeverity :: !Severity,
34+ builderCount :: !Int,
35+ githubContext :: !Text
36+ }
37+ deriving (Show, Generic)
38+
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 =
59+ 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")
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)
99+
100+deriving instance Show ReadRsaKeyError
src/Server/Html.hsnew file+147
@@ -0,0 +1,147 @@
1+{-# OPTIONS_GHC -Wno-orphans #-}
2+
3+module Server.Html
4+ ( getSubmissionR,
5+ MonadHasBaseUrl (..),
6+ redirectToSubmission,
7+ getUrl,
8+ )
9+where
10+
11+import Clay as C
12+import Colog
13+import Control.Monad.IO.Unlift
14+import Data.Foldable
15+import qualified Data.Map as M
16+import Data.String
17+import Data.Submission
18+import Data.Submission.Query
19+import qualified Data.Text as T
20+import Server.Schema
21+import Squeal.PostgreSQL (Jsonb (..))
22+import Text.Blaze
23+import Text.Blaze.Html
24+import Text.Blaze.Html4.Strict.Attributes as A
25+import Text.Blaze.Html5 as H
26+
27+getSubmissionR ::
28+ (MonadUnliftIO m, StaticPQ m, WithLog env Message m, MonadHasBaseUrl m) =>
29+ String ->
30+ String ->
31+ String ->
32+ m Markup
33+getSubmissionR user repo sha' = do
34+ restartUrl <- (<> "/restart") <$> getUrl (user <> "/" <> repo) sha'
35+ let restartBuild = do
36+ H.form H.! A.action (fromString restartUrl) H.! A.method "post" $
37+ H.input H.! A.type_ "submit" H.! A.value "Restart test"
38+ (titleText, inner) <- getSubmission (user <> "/" <> repo) sha' >>= \case
39+ Nothing ->
40+ return . ("Not found",) $
41+ H.h1 "404. not found. go away."
42+ Just Submission {..} -> return . (problem,) $ do
43+ H.h1 $ toHtml problem
44+ H.h2 $ toHtml userName
45+ H.h3 . H.code . toHtml . take 7 $ sha
46+ case status of
47+ Jsonb BuildScheduled -> do
48+ H.h3 "Waiting to build ⌛"
49+ restartBuild
50+ Jsonb (SubmissionFailed err) -> do
51+ H.h3 "Failed to build ☠️"
52+ restartBuild
53+ H.code . H.pre $ toHtml err
54+ Jsonb (SubmissionRun (TestResult tests)) -> do
55+ let total = M.size tests
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 " 🍌"
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
67+ H.head $ do
68+ H.title $ toHtml titleText
69+ H.style . preEscapedToHtml . render $ do
70+ C.body ? do
71+ fontFamily [] [sansSerif]
72+ C.maxWidth (px 800)
73+ C.display C.block
74+ C.marginLeft auto
75+ C.marginRight auto
76+ C.paddingLeft (px 16)
77+ C.paddingRight (px 16)
78+ (C.h1 <> C.h2 <> C.h3) ? do
79+ textAlign center
80+ C.pre ? do
81+ C.whiteSpace C.preWrap
82+ C.table ? do
83+ C.width (pct 100)
84+ (C.tr <> C.td) ? do
85+ C.width (pct 50)
86+ C.td ? do
87+ C.padding (px 4) (px 4) (px 4) (px 4)
88+ C.form ? do
89+ C.display C.block
90+ C.width (pct 100)
91+ C.input ? do
92+ C.display C.block
93+ C.marginLeft auto
94+ C.marginRight auto
95+ H.body inner
96+
97+class MonadHasBaseUrl m where
98+ getBaseUrl :: m T.Text
99+
100+getUrl :: (MonadHasBaseUrl m, Monad m) => String -> String -> m String
101+getUrl fullName sha = do
102+ siteBase <- getBaseUrl
103+ return $ T.unpack siteBase <> "/submission/" <> fullName <> "/" <> sha
104+
105+redirectToSubmission ::
106+ (MonadHasBaseUrl m, Monad m) =>
107+ String ->
108+ String ->
109+ String ->
110+ m Markup
111+redirectToSubmission user repo sha = do
112+ rUrl <- getUrl (user <> "/" <> repo) sha
113+ return $ docTypeHtml $ H.head $
114+ H.meta
115+ H.! A.httpEquiv "refresh"
116+ H.! A.content (fromString $ "0; URL=" <> rUrl)
117+
118+instance ToMarkup [Score] where
119+ toMarkup xs = docTypeHtml $ do
120+ H.style . preEscapedToHtml . render $ do
121+ C.body ? do
122+ fontFamily [] [sansSerif]
123+ C.maxWidth (px 800)
124+ C.display C.block
125+ C.marginLeft auto
126+ C.marginRight auto
127+ C.paddingLeft (px 16)
128+ C.paddingRight (px 16)
129+ (C.h1 <> C.h2 <> C.h3) ? do
130+ textAlign center
131+ C.pre ? do
132+ C.whiteSpace C.preWrap
133+ (C.tr <> C.td) ? do
134+ C.width (pct 50)
135+ C.td ? do
136+ C.padding (px 4) (px 4) (px 4) (px 4)
137+ C.border solid (px 1) black
138+ C.margin (px 0) (px 0) (px 0) (px 0)
139+ C.table ? do
140+ C.borderCollapse (other "collapse")
141+ C.width (pct 100)
142+ H.body
143+ $ H.table
144+ $ for_ xs
145+ $ \(Score user score) -> H.tr $ do
146+ (H.td H.! A.align "right") . H.code $ toHtml user
147+ H.td $ toHtml score
src/Server/Schema.hsnew file+20
@@ -0,0 +1,20 @@
1+module Server.Schema
2+ ( StaticPQ,
3+ Schema,
4+ migration,
5+ )
6+where
7+
8+import Server.Schema.V1
9+import Server.Schema.V2
10+import Squeal.PostgreSQL
11+
12+type StaticPQ m = MonadPQ Schema m
13+
14+type Schema = SchemaV2
15+
16+migration :: AlignedList (Migration (Terminally PQ IO)) (Public '[]) Schema
17+migration =
18+ pureMigration schemaMigrationV1
19+ :>> pureMigration schemaMigrationV2
20+ :>> Done
src/Server/Schema/V1.hsnew file+66
@@ -0,0 +1,66 @@
1+module Server.Schema.V1
2+ ( SchemaV1,
3+ schemaMigrationV1,
4+ )
5+where
6+
7+import Data.Aeson
8+import Data.Submission
9+import Data.Text (Text)
10+import Data.Time
11+import Squeal.PostgreSQL
12+
13+type SchemaV1 =
14+ Public
15+ '[ "tasks"
16+ ::: 'Table
17+ ( '[ "pk_task_payload" :=> 'PrimaryKey '["task", "payload"]
18+ ]
19+ :=> '[ "task" ::: 'NoDef :=> 'NotNull (PG Text),
20+ "payload" ::: 'NoDef :=> 'NotNull (PG (Jsonb Value)),
21+ "creation_time" ::: 'Def :=> 'NotNull (PG UTCTime),
22+ "started" ::: 'Def :=> 'NotNull (PG Bool)
23+ ]
24+ ),
25+ "submissions"
26+ ::: 'Table
27+ ( '["pk_submission_repo_full_name_sha" :=> 'PrimaryKey '["repo_full_name", "sha"]]
28+ :=> '[ "user_name" ::: 'NoDef :=> 'NotNull (PG String),
29+ "repo_full_name" ::: 'NoDef :=> 'NotNull (PG String),
30+ "problem" ::: 'NoDef :=> 'NotNull (PG String),
31+ "sha" ::: 'NoDef :=> 'NotNull (PG String),
32+ "status" ::: 'NoDef :=> 'NotNull (PG (Jsonb SubmissionStatus))
33+ ]
34+ )
35+ ]
36+
37+schemaMigrationV1 :: Migration Definition (Public '[]) SchemaV1
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
48+ )
49+ (primaryKey (#task :* #payload) `as` #pk_task_payload)
50+ >>> createTable
51+ #submissions
52+ ( notNullable text `as` #user_name
53+ :* notNullable text `as` #repo_full_name
54+ :* notNullable text `as` #problem
55+ :* notNullable text `as` #sha
56+ :* notNullable jsonb `as` #status
57+ )
58+ (primaryKey (#repo_full_name :* #sha) `as` #pk_submission_repo_full_name_sha)
59+ >>> createIndexes,
60+ down = dropTable #tasks >>> dropTable #submissions
61+ }
62+ where
63+ createIndexes :: Definition sch sch
64+ createIndexes =
65+ UnsafeDefinition
66+ "CREATE INDEX ON tasks (creation_time);"
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.yamlnew file+78
@@ -0,0 +1,78 @@
1+# This file was automatically generated by 'stack init'
2+#
3+# Some commonly used options have been documented as comments in this file.
4+# For advanced use and comprehensive documentation of the format, please see:
5+# https://docs.haskellstack.org/en/stable/yaml_configuration/
6+
7+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
8+# A snapshot resolver dictates the compiler version and the set of packages
9+# to be used for project dependencies. For example:
10+#
11+# resolver: lts-3.5
12+# resolver: nightly-2015-09-21
13+# resolver: ghc-7.10.2
14+#
15+# The location of a snapshot can be provided as a file or url. Stack assumes
16+# a snapshot provided as a file might change, whereas a url resource does not.
17+#
18+# resolver: ./custom-snapshot.yaml
19+# resolver: https://example.com/snapshots/2018-01-01.yaml
20+resolver: lts-14.27
21+
22+# User packages to be built.
23+# Various formats can be used as shown in the example below.
24+#
25+# packages:
26+# - some-directory
27+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
28+# subdirs:
29+# - auto-update
30+# - wai
31+packages:
32+- .
33+# Dependency packages to be pulled from upstream that are not in the resolver.
34+# These entries can reference officially published versions as well as
35+# forks / in-progress versions pinned to a git hash. For example:
36+#
37+# extra-deps:
38+# - acme-missiles-0.3
39+# - git: https://github.com/commercialhaskell/stack.git
40+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
41+#
42+extra-deps:
43+- github-0.25
44+- binary-instances-1
45+- squeal-postgresql-0.5.2.0
46+- git: https://github.com/ilyakooo0/github-app
47+ commit: 0bede85ab53eb8f953cf6f4e58a756a205e88e0b
48+- servant-github-webhook-0.4.2.0
49+- http-client-0.5.14
50+- git: https://github.com/ilyakooo0/docker-hs
51+ commit: 5cfdc4d7facd7043f530bce4ce0f0c57c923b029
52+
53+# Override default flag values for local packages and extra-deps
54+# flags: {}
55+
56+# Extra package databases containing global packages
57+# extra-package-dbs: []
58+
59+# Control whether we use the GHC we find on the path
60+# system-ghc: true
61+#
62+# Require a specific version of stack, using version ranges
63+# require-stack-version: -any # Default
64+# require-stack-version: ">=2.1"
65+#
66+# Override the architecture used by stack, especially useful on Windows
67+# arch: i386
68+# arch: x86_64
69+#
70+# Extra directories used by stack for building
71+# extra-include-dirs: [/path/to/dir]
72+# extra-lib-dirs: [/path/to/dir]
73+#
74+# Allow a newer minor version of GHC than the snapshot specifies
75+# compiler-check: newer-minor
76+
77+ghc-options:
78+ "$locals": -ddump-to-file -ddump-hi -fwarn-unused-binds -fwarn-unused-imports -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -Werror=missing-home-modules -Wmissing-home-modules -Widentities -Wredundant-constraints -Wmissing-export-lists
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