git.iko.soy/sc-build
on 9a05dcd help sign in
991579d
swap
0 ahead, 37 behind
.gitignoredeleted−2
since splitsnapshots
unifiedsplit
@@ -1,2 +0,0 @@
1−.stack-work
2−*.cabal
LICENSE+1−1
@@ -1,6 +1,6 @@
1MIT License
1MIT License
2
2
3−Copyright (c) 2020 Ilya Kostyuchenko
3+Copyright (c) 2020 iko
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.mddeleted−64
@@ -1,64 +0,0 @@
1−# sc-build
2−
3−Need both manual weebohook and app.
4−
5−Installation id needs to be configured manually.
6−
7−## Usage
8−
9−You want to have some predefined docker container with maximum dependencies cached.
10−
11−
12−Exmaple:
13−
14−```dockerfile
15−FROM fpco/stack-build:lts-14.27
16−
17−RUN stack update
18−RUN stack build tasty tasty-hspec aeson containers bytestring
19−
20−WORKDIR /
21−```
22−
23−You need to build that container and git it a name:
24−
25−```bash
26−docker build -t fast-lts-14.27 - < FastDockerFile
27−```
28−
29−After that you can use it in your `tasks.yaml`:
30−
31−```yaml
32−test-task:
33− prebuild: |
34− cp -f ../../test-task/package.yaml .
35− cp -f ../../test-task/stack.yaml .
36− cp -f -R ../../test-task/test .
37− dockerfile: |
38− FROM fast-lts-14.27
39− COPY . src
40− WORKDIR /src
41− ENTRYPOINT stack test --fast
42− timeoutMinutes: 10
43−```
44−
45−The docker container is expected to write json to stdout, conating test results:
46−
47−```json
48−{
49− "test1": true,
50− "test2": false
51−}
52−```
53−
54−For macos docker API:
55−
56−```bash
57−socat TCP-LISTEN:1234,range=127.0.0.1/32,reuseaddr,fork UNIX-CLIENT:/var/run/docker.sock
58−```
59−
60−or this (didn't work for me):
61−
62−```bash
63−docker run -d -v /var/run/docker.sock:/var/run/docker.sock -p 127.0.0.1:2357:1234 bobrik/socat TCP-LISTEN:1234,fork UNIX-CONNECT:/var/run/docker.sock
64−```
Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
app/Main.hsdeleted−30
@@ -1,30 +0,0 @@
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.yamldeleted−4
@@ -1,4 +0,0 @@
1−cradle:
2− stack:
3− - path: "."
4− component: "sc-build:lib"
migrations/Main.hsdeleted−14
@@ -1,14 +0,0 @@
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.yamldeleted−112
@@ -1,112 +0,0 @@
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.hsdeleted−10
@@ -1,10 +0,0 @@
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.hsdeleted−10
@@ -1,10 +0,0 @@
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.hsdeleted−14
@@ -1,14 +0,0 @@
1−module Control.HasGithubStatus
2− ( HasGithubStatus (..),
3− )
4−where
5−
6−import Colog
7−import Data.Submission
8−import GitHub.Data
9−
10−class HasGithubStatus m where
11− schedulePendingStatus :: WithLog env Message m => Name Owner -> Name Repo -> Name Commit -> m ()
12− scheduleTestedStatus :: WithLog env Message m => TestResult -> Name Owner -> Name Repo -> Name Commit -> m ()
13− scheduleFailedStatus :: WithLog env Message m => String -> Name Owner -> Name Repo -> Name Commit -> m ()
14− deadlineHasPassedStatus :: WithLog env Message m => Name Owner -> Name Repo -> Name Commit -> m ()
src/Control/Squeal.hsdeleted−81
@@ -1,81 +0,0 @@
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.hsdeleted−26
@@ -1,26 +0,0 @@
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.hsdeleted−87
@@ -1,87 +0,0 @@
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.hsdeleted−154
@@ -1,154 +0,0 @@
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.hsdeleted−47
@@ -1,47 +0,0 @@
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.hsdeleted−99
@@ -1,99 +0,0 @@
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.hsdeleted−201
@@ -1,201 +0,0 @@
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.hsdeleted−40
@@ -1,40 +0,0 @@
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.hsdeleted−381
@@ -1,381 +0,0 @@
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.hsdeleted−100
@@ -1,100 +0,0 @@
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.hsdeleted−147
@@ -1,147 +0,0 @@
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.hsdeleted−20
@@ -1,20 +0,0 @@
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.hsdeleted−66
@@ -1,66 +0,0 @@
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.hsdeleted−46
@@ -1,46 +0,0 @@
1−module Server.Schema.V2
2− ( SchemaV2,
3− schemaMigrationV2,
4− )
5−where
6−
7−import Data.Aeson
8−import Data.Int
9−import Data.Submission
10−import Data.Text (Text)
11−import Data.Time
12−import Server.Schema.V1
13−import Squeal.PostgreSQL
14−
15−type SchemaV2 =
16− Public
17− '[ "tasks"
18− ::: 'Table
19− ( '[ "pk_task_payload" :=> 'PrimaryKey '["task", "payload"]
20− ]
21− :=> '[ "task" ::: 'NoDef :=> 'NotNull (PG Text),
22− "payload" ::: 'NoDef :=> 'NotNull (PG (Jsonb Value)),
23− "creation_time" ::: 'Def :=> 'NotNull (PG UTCTime),
24− "started" ::: 'Def :=> 'NotNull (PG Bool),
25− "failures" ::: 'Def :=> 'NotNull (PG Int32)
26− ]
27− ),
28− "submissions"
29− ::: 'Table
30− ( '["pk_submission_repo_full_name_sha" :=> 'PrimaryKey '["repo_full_name", "sha"]]
31− :=> '[ "user_name" ::: 'NoDef :=> 'NotNull (PG String),
32− "repo_full_name" ::: 'NoDef :=> 'NotNull (PG String),
33− "problem" ::: 'NoDef :=> 'NotNull (PG String),
34− "sha" ::: 'NoDef :=> 'NotNull (PG String),
35− "status" ::: 'NoDef :=> 'NotNull (PG (Jsonb SubmissionStatus))
36− ]
37− )
38− ]
39−
40−schemaMigrationV2 :: Migration Definition SchemaV1 SchemaV2
41−schemaMigrationV2 =
42− Migration
43− { name = "v2",
44− up = alterTable #tasks (addColumn #failures (default_ 0 $ notNullable int)),
45− down = alterTable #tasks (dropColumn #failures)
46− }
stack.yamldeleted−78
@@ -1,78 +0,0 @@
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.yamldeleted−11
@@ -1,11 +0,0 @@
1−test-task:
2− prebuild: |
3− cp -f ../../test-task/package.yaml .
4− cp -f ../../test-task/stack.yaml .
5− cp -f -R ../../test-task/test .
6− dockerfile: |
7− FROM fast-lts-14.20
8− COPY . src
9− WORKDIR /src
10− ENTRYPOINT stack test --fast
11− timeoutMinutes: 10