git.iko.soy/sc-build
on master help sign in
Initial working commit
33713bdiko
.gitignorenew file+1
compare with master
unifiedsplit
@@ -0,0 +1 @@
1+.stack-work
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
Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
app/Main.hsnew file+6
@@ -0,0 +1,6 @@
1+module Main (main) where
2+
3+import Server
4+
5+main :: IO ()
6+main = runServer
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+102
@@ -0,0 +1,102 @@
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+ - servant
21+ - servant-server
22+ - process
23+ - yaml
24+ - aeson
25+ - github
26+ - github-app
27+ - github-webhooks
28+ - warp
29+ - vector
30+ - bytestring
31+ - servant-github-webhook
32+ - cryptonite
33+ - mtl
34+ - text
35+ - containers
36+ - random
37+ - time
38+ - typed-process
39+ - directory
40+ - squeal-postgresql
41+ - generics-sop
42+ - co-log
43+ - unliftio-core
44+ - unliftio
45+ - servant-blaze
46+ - blaze-markup
47+ - blaze-html
48+ - clay
49+
50+executables:
51+ sc-build-exe:
52+ main: Main.hs
53+ source-dirs: app
54+ ghc-options:
55+ - -threaded
56+ - -rtsopts
57+ - -with-rtsopts=-N
58+ dependencies:
59+ - sc-build
60+ sc-build-migrations:
61+ main: Main.hs
62+ source-dirs: migrations
63+ ghc-options:
64+ - -threaded
65+ - -rtsopts
66+ - -with-rtsopts=-N
67+ dependencies:
68+ - sc-build
69+ - bytestring
70+ - squeal-postgresql
71+
72+default-extensions:
73+- AllowAmbiguousTypes
74+- ConstraintKinds
75+- DataKinds
76+- DeriveAnyClass
77+- DeriveFunctor
78+- DeriveGeneric
79+- DerivingStrategies
80+- DuplicateRecordFields
81+- FlexibleContexts
82+- FlexibleInstances
83+- FunctionalDependencies
84+- GADTs
85+- GeneralizedNewtypeDeriving
86+- InstanceSigs
87+- LambdaCase
88+- MultiParamTypeClasses
89+- OverloadedLabels
90+- OverloadedStrings
91+- PatternSynonyms
92+- PolyKinds
93+- QuantifiedConstraints
94+- RankNTypes
95+- RecordWildCards
96+- ScopedTypeVariables
97+- StandaloneDeriving
98+- TupleSections
99+- TypeApplications
100+- TypeFamilies
101+- TypeOperators
102+- UndecidableInstances
sc-build.cabalnew file+103
@@ -0,0 +1,103 @@
1+cabal-version: 1.12
2+
3+-- This file has been generated from package.yaml by hpack version 0.31.2.
4+--
5+-- see: https://github.com/sol/hpack
6+--
7+-- hash: bb953e6231fcc3939bfe085afcd3e792cbc40462461bbe4fb82ae69f1796be4c
8+
9+name: sc-build
10+version: 0.1.0.0
11+category: Web
12+homepage: https://github.com/ilyakooo0/sc-build#readme
13+author: Ilya Kostyuchenko
14+maintainer: ilyakooo0@gmail.com
15+copyright: Ilya Kostyuchenko
16+license: BSD3
17+license-file: LICENSE
18+build-type: Simple
19+extra-source-files:
20+ README.md
21+
22+library
23+ exposed-modules:
24+ Control.AppRequestable
25+ Control.GithubCloner
26+ Control.Squeal
27+ Control.Task
28+ Control.Task.Scheduler
29+ Control.Task.Scheduler.Query
30+ Data.Submission
31+ Data.Submission.Query
32+ Data.Tasks.Build
33+ Data.Tasks.StatusUpdate
34+ Server
35+ Server.Config
36+ Server.Html
37+ Server.Schema
38+ Server.Schema.V1
39+ other-modules:
40+ Paths_sc_build
41+ hs-source-dirs:
42+ src
43+ default-extensions: AllowAmbiguousTypes ConstraintKinds DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuantifiedConstraints RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances
44+ build-depends:
45+ aeson
46+ , base >=4.7 && <5
47+ , blaze-html
48+ , blaze-markup
49+ , bytestring
50+ , clay
51+ , co-log
52+ , containers
53+ , cryptonite
54+ , directory
55+ , generics-sop
56+ , github
57+ , github-app
58+ , github-webhooks
59+ , mtl
60+ , process
61+ , random
62+ , servant
63+ , servant-blaze
64+ , servant-github-webhook
65+ , servant-server
66+ , squeal-postgresql
67+ , text
68+ , time
69+ , typed-process
70+ , unliftio
71+ , unliftio-core
72+ , vector
73+ , warp
74+ , yaml
75+ default-language: Haskell2010
76+
77+executable sc-build-exe
78+ main-is: Main.hs
79+ other-modules:
80+ Paths_sc_build
81+ hs-source-dirs:
82+ app
83+ default-extensions: AllowAmbiguousTypes ConstraintKinds DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuantifiedConstraints RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances
84+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
85+ build-depends:
86+ base >=4.7 && <5
87+ , sc-build
88+ default-language: Haskell2010
89+
90+executable sc-build-migrations
91+ main-is: Main.hs
92+ other-modules:
93+ Paths_sc_build
94+ hs-source-dirs:
95+ migrations
96+ default-extensions: AllowAmbiguousTypes ConstraintKinds DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuantifiedConstraints RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances
97+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
98+ build-depends:
99+ base >=4.7 && <5
100+ , bytestring
101+ , sc-build
102+ , squeal-postgresql
103+ default-language: Haskell2010
src/Control/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+16
@@ -0,0 +1,16 @@
1+module Control.GithubCloner
2+ ( GithubAccessToken (..),
3+ GithubUserName (..),
4+ GithubCloner (..),
5+ )
6+where
7+
8+newtype GithubAccessToken = GithubAccessToken String
9+
10+newtype GithubUserName = GithubUserName String
11+
12+class GithubCloner m where
13+
14+ getGithubAccessToken :: m GithubAccessToken
15+
16+ getGithubUserName :: m GithubUserName
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+86
@@ -0,0 +1,86 @@
1+{-# LANGUAGE TypeApplications #-}
2+
3+module Control.Task.Scheduler
4+ ( scheduleTask,
5+ runTasks,
6+ )
7+where
8+
9+import Colog
10+import Control.Monad
11+import Control.Monad.IO.Unlift
12+import Control.Task
13+import Control.Task.Scheduler.Query
14+import Data.Aeson hiding (Result (..))
15+import qualified Data.Aeson as A
16+import Data.Foldable
17+import Data.Proxy
18+import qualified Data.Text as T
19+import Data.Word
20+import GHC.TypeLits
21+import Server.Schema
22+import Squeal.PostgreSQL
23+
24+scheduleTask ::
25+ (StaticPQ m, WithLog env Message m, Task t s, MonadUnliftIO m) =>
26+ t ->
27+ m ()
28+scheduleTask = scheduleTaskQuery
29+
30+runTasks ::
31+ forall tt m env.
32+ (StaticPQ m, WithLog env Message m, RunTasks tt m, MonadUnliftIO m) =>
33+ Word64 ->
34+ m Int
35+runTasks n = do
36+ tasks <- pickTasksQuery (taskNames @tt @m) n
37+ for_ tasks $ runTask @tt @m
38+ return $ length tasks
39+
40+rescheduleTaskTime ::
41+ forall t s m env.
42+ (Task t s, StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>
43+ t ->
44+ m ()
45+rescheduleTaskTime = rescheduleTaskQuery
46+
47+class RunTasks (ts :: [*]) m where
48+
49+ runTask :: WithLog env Message m => PickedTask -> m ()
50+
51+ taskNames :: [String]
52+
53+instance
54+ forall t ts tt m.
55+ (Task t ts, TaskMonad t m, StaticPQ m, RunTasks tt m, MonadUnliftIO m) =>
56+ RunTasks (t ': tt) m
57+ where
58+
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
71+ when (r == Failure) $ logWarning . T.pack $ "Task " <> task <> " failed"
72+ case r of
73+ Success -> completeTaskQuery t
74+ Failure -> rescheduleTaskTime t
75+ where
76+ task = symbolVal @ts Proxy
77+ runTask t = runTask @tt @m t
78+
79+ taskNames = symbolVal @ts Proxy : taskNames @tt @m
80+
81+instance RunTasks '[] m where
82+
83+ runTask (PickedTask s (Jsonb v) _) =
84+ logError . T.pack $ "Unknown task " <> s <> " with payload " <> show v
85+
86+ taskNames = []
src/Control/Task/Scheduler/Query.hsnew file+121
@@ -0,0 +1,121 @@
1+{-# LANGUAGE TypeApplications #-}
2+
3+module Control.Task.Scheduler.Query
4+ ( scheduleTaskQuery,
5+ completeTaskQuery,
6+ rescheduleTaskQuery,
7+ pickTasksQuery,
8+ PickedTask (..),
9+ )
10+where
11+
12+import Colog
13+import Control.Monad.IO.Unlift
14+import Control.Squeal
15+import Control.Task
16+import Data.Aeson hiding (Result (..))
17+import Data.Proxy
18+import qualified Data.Text as T
19+import Data.Time
20+import Data.Word
21+import GHC.Generics (Generic)
22+import GHC.TypeLits
23+import qualified Generics.SOP as SOP
24+import Server.Schema
25+import Squeal.PostgreSQL
26+
27+scheduleTaskQuery ::
28+ forall m t s env.
29+ (StaticPQ m, Task t s, WithLog env Message m, MonadUnliftIO m) =>
30+ t ->
31+ m ()
32+scheduleTaskQuery task = do
33+ logInfo . T.pack $ "schdeuling task: " <> show task
34+ let query =
35+ insertInto
36+ #tasks
37+ ( Values_ $
38+ Set (param @1) `as` #task
39+ :* Set (param @2) `as` #payload
40+ :* Default `as` #creation_time
41+ )
42+ ( OnConflict
43+ (OnConstraint #pk_task_payload)
44+ (DoUpdate (Default `as` #creation_time) [])
45+ )
46+ (Returning_ Nil)
47+ dbWrite (const $ return ()) $
48+ manipulateParams_
49+ query
50+ (symbolVal @s Proxy, Jsonb $ toJSON task)
51+
52+completeTaskQuery ::
53+ forall m t s env.
54+ (StaticPQ m, Task t s, WithLog env Message m, MonadUnliftIO m) =>
55+ t ->
56+ m ()
57+completeTaskQuery payload = do
58+ let task = symbolVal @s Proxy
59+ logInfo . T.pack $ "Completing task: " <> task <> " with payload " <> show payload
60+ let query :: Manipulation_ Schema (String, Jsonb Value) ()
61+ query =
62+ deleteFrom_
63+ #tasks
64+ (param @1 .== #task .&& param @2 .== #payload)
65+ dbWrite (const $ return ()) $
66+ manipulateParams_
67+ query
68+ (symbolVal @s Proxy, Jsonb $ toJSON payload)
69+
70+rescheduleTaskQuery ::
71+ forall s t m env.
72+ (StaticPQ m, Task t s, WithLog env Message m, MonadUnliftIO m) =>
73+ t ->
74+ m ()
75+rescheduleTaskQuery payload = do
76+ let task = symbolVal @s Proxy
77+ logInfo . T.pack $
78+ "reschdeuling task: " <> task
79+ <> " with payload "
80+ <> show payload
81+ let query :: Manipulation_ Schema (String, Jsonb Value) ()
82+ query =
83+ update_
84+ #tasks
85+ (Default `as` #creation_time)
86+ (param @1 .== #task .&& param @2 .== #payload)
87+ dbWrite (const $ return ()) $
88+ manipulateParams_
89+ query
90+ (symbolVal @s Proxy, Jsonb $ toJSON payload)
91+
92+pickTasksQuery ::
93+ forall m env.
94+ (StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>
95+ [String] ->
96+ Word64 ->
97+ m [PickedTask]
98+pickTasksQuery tasks limitCount = do
99+ logDebug "reading tasks"
100+ let query :: Query_ Schema () PickedTask
101+ query =
102+ select_
103+ ( #task `as` #task
104+ :* #payload `as` #payload
105+ :* #creation_time `as` #creationTime
106+ )
107+ ( from (table #tasks)
108+ & where_ (#task `in_` (literal <$> tasks))
109+ & orderBy [#creation_time & Asc]
110+ & limit limitCount
111+ )
112+ dbRead (const $ return []) $
113+ runQuery query >>= getRows
114+
115+data PickedTask
116+ = PickedTask
117+ { task :: String,
118+ payload :: Jsonb Value,
119+ creationTime :: UTCTime
120+ }
121+ deriving (Eq, Show, Generic, SOP.Generic, SOP.HasDatatypeInfo)
src/Data/Submission.hsnew file+36
@@ -0,0 +1,36 @@
1+module Data.Submission
2+ ( Submission (..),
3+ SubmissionStatus (..),
4+ TestResult (..),
5+ )
6+where
7+
8+import Data.Aeson
9+import Data.Map (Map)
10+import Data.Text (Text)
11+import GHC.Generics (Generic)
12+import qualified Generics.SOP as SOP
13+import Squeal.PostgreSQL
14+
15+data Submission
16+ = Submission
17+ { userName :: String,
18+ repoFullName :: String,
19+ problem :: String,
20+ sha :: String,
21+ status :: Jsonb SubmissionStatus
22+ }
23+ deriving (Eq, Show, Generic, SOP.Generic, SOP.HasDatatypeInfo)
24+
25+data SubmissionStatus
26+ = SubmissionRun TestResult
27+ | SubmissionFailed String
28+ | BuildScheduled
29+ deriving (Generic, FromJSON, ToJSON, Eq, Show)
30+
31+newtype TestResult
32+ = TestResult
33+ { tests :: Map Text Bool
34+ }
35+ deriving stock (Eq, Show, Generic)
36+ deriving anyclass (FromJSON, ToJSON)
src/Data/Submission/Query.hsnew file+85
@@ -0,0 +1,85 @@
1+{-# LANGUAGE TypeApplications #-}
2+
3+module Data.Submission.Query
4+ ( createSubmission,
5+ updateSubmissionStatus,
6+ getSubmission,
7+ )
8+where
9+
10+import Colog
11+import Control.Monad.IO.Unlift
12+import Control.Squeal
13+import Data.Submission
14+import qualified Data.Text as T
15+import Server.Schema
16+import Squeal.PostgreSQL
17+
18+createSubmission ::
19+ (StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>
20+ Submission ->
21+ m ()
22+createSubmission s@Submission {..} = do
23+ logInfo . T.pack $ "Creating submission: " <> show s
24+ let query =
25+ insertInto
26+ #submissions
27+ ( Values_ $
28+ Set (param @1) `as` #user_name
29+ :* Set (param @2) `as` #repo_full_name
30+ :* Set (param @3) `as` #problem
31+ :* Set (param @4) `as` #sha
32+ :* Set (param @5) `as` #status
33+ )
34+ ( OnConflict
35+ (OnConstraint #pk_submission_repo_full_name_sha)
36+ DoNothing
37+ )
38+ (Returning_ Nil)
39+ dbWrite (const $ return ()) $
40+ manipulateParams_
41+ query
42+ (userName, repoFullName, problem, sha, status)
43+
44+updateSubmissionStatus ::
45+ (StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>
46+ String ->
47+ String ->
48+ SubmissionStatus ->
49+ m ()
50+updateSubmissionStatus repoFullName sha status = do
51+ let query :: Manipulation_ Schema (Jsonb SubmissionStatus, String, String) ()
52+ query =
53+ update_
54+ #submissions
55+ (Set (param @1) `as` #status)
56+ (#repo_full_name .== param @2 .&& #sha .== param @3)
57+ dbWrite (const $ return ()) $
58+ manipulateParams_
59+ query
60+ (Jsonb status, repoFullName, sha)
61+
62+getSubmission ::
63+ (StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>
64+ String ->
65+ String ->
66+ m (Maybe Submission)
67+getSubmission repoFullName sha = do
68+ let query :: Query_ Schema (String, String) Submission
69+ query =
70+ select_
71+ ( #user_name `as` #userName
72+ :* #repo_full_name `as` #repoFullName
73+ :* #problem `as` #problem
74+ :* #sha `as` #sha
75+ :* #status `as` #status
76+ )
77+ ( from (table #submissions)
78+ & where_
79+ (#repo_full_name .== param @1 .&& #sha .== param @2)
80+ )
81+ dbRead (const $ return Nothing) $
82+ runQueryParams
83+ query
84+ (repoFullName, sha)
85+ >>= firstRow
src/Data/Tasks/Build.hsnew file+133
@@ -0,0 +1,133 @@
1+{-# LANGUAGE TypeApplications #-}
2+{-# OPTIONS_GHC -Wno-orphans #-}
3+
4+module Data.Tasks.Build
5+ ( Build (..),
6+ )
7+where
8+
9+import Colog
10+import Control.GithubCloner
11+import Control.Monad.IO.Class
12+import Control.Monad.IO.Unlift
13+import Control.Task
14+import Control.Task.Scheduler
15+import Data.Aeson hiding (Success)
16+import qualified Data.ByteString.Lazy.Char8 as BS
17+import qualified Data.Map as M
18+import Data.String
19+import Data.Submission
20+import Data.Submission.Query
21+import Data.Tasks.StatusUpdate
22+import qualified Data.Text as T
23+import Data.Time.Clock.POSIX
24+import GHC.Generics
25+import GitHub
26+import Server.Schema
27+import System.Directory
28+import System.Exit
29+import System.Process.Typed
30+import System.Random
31+import UnliftIO.Exception
32+
33+data Build
34+ = Build
35+ { preProcessShell :: String,
36+ buildCommand :: String,
37+ owner :: Name Owner,
38+ repoName :: Name Repo,
39+ sha :: Name Commit
40+ }
41+ deriving (Eq, Show, Generic, FromJSON, ToJSON)
42+
43+instance Task Build "build-repo" where
44+
45+ type TaskMonad Build m = (MonadUnliftIO m, GithubCloner m, StaticPQ m)
46+
47+ performTask Build {..} =
48+ bracket createDir (liftIO . removePathForcibly) $ \dir -> do
49+ let fullRepoName = T.unpack $ untagName owner <> "/" <> untagName repoName
50+ sha' = T.unpack $ untagName sha
51+ cloneRepo fullRepoName sha' dir
52+ (shellCode, _, shellErr) <- readProcess . setWorkingDir dir $ shell preProcessShell
53+ case shellCode of
54+ ExitFailure n -> do
55+ let err = BS.unpack shellErr
56+ logError . T.pack $
57+ "preprocessing command for repo " <> show fullRepoName <> " at sha "
58+ <> show sha
59+ <> " exited with code "
60+ <> show n
61+ <> " and error "
62+ <> err
63+ scheduleTask erroredTask
64+ updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
65+ ExitSuccess -> do
66+ (buildCode, buildOut, buildErr) <- readProcess . setWorkingDir dir . fromString $ buildCommand
67+ case buildCode of
68+ ExitFailure n -> do
69+ let err = BS.unpack buildErr
70+ logError . T.pack $
71+ "test command for repo " <> show fullRepoName <> " at sha "
72+ <> show sha
73+ <> " exited with code "
74+ <> show n
75+ <> " and error "
76+ <> err
77+ scheduleTask erroredTask
78+ updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
79+ ExitSuccess ->
80+ case decode buildOut of
81+ Nothing -> do
82+ let err = BS.unpack buildOut
83+ logError . T.pack $
84+ "could not decode test result from repo " <> show fullRepoName
85+ <> " at sha "
86+ <> show sha
87+ <> ": "
88+ <> err
89+ scheduleTask erroredTask
90+ updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
91+ Just testResult@TestResult {..} -> do
92+ let total = M.size tests
93+ passed = M.size . M.filter id $ tests
94+ description = T.pack $ show passed <> "/" <> show total
95+ status = statusTask NewStatus
96+ { newStatusState =
97+ if total == passed then StatusSuccess else StatusFailure,
98+ newStatusTargetUrl = Nothing,
99+ newStatusDescription = Just description,
100+ newStatusContext = Nothing
101+ }
102+ scheduleTask status
103+ updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)
104+ return Success
105+ where
106+ statusTask = StatusUpdate owner repoName sha
107+ erroredTask = statusTask $ NewStatus
108+ { newStatusState = StatusError,
109+ newStatusTargetUrl = Nothing,
110+ newStatusDescription = Just "Build failed",
111+ newStatusContext = Nothing
112+ }
113+
114+createDir :: MonadIO m => m FilePath
115+createDir = do
116+ dir <- ("tmp/" <>) <$> getTmpDirName
117+ liftIO $ createDirectoryIfMissing True dir
118+ return dir
119+
120+cloneRepo :: (MonadIO m, GithubCloner m) => String -> String -> FilePath -> m ()
121+cloneRepo repoName sha path = do
122+ GithubAccessToken token <- getGithubAccessToken
123+ GithubUserName username <- getGithubUserName
124+ runProcess_ . setWorkingDir path . fromString $
125+ "git clone https://" <> username <> ":" <> token <> "@github.com/" <> repoName <> ".git ."
126+ runProcess_ . setWorkingDir path . fromString $ "git checkout " <> sha
127+ return ()
128+
129+getTmpDirName :: MonadIO m => m FilePath
130+getTmpDirName = liftIO $ do
131+ time :: Integer <- round <$> getPOSIXTime
132+ i <- randomIO @Int
133+ return $ show time <> "-" <> show i
src/Data/Tasks/StatusUpdate.hsnew file+41
@@ -0,0 +1,41 @@
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+
35+ type TaskMonad StatusUpdate m = (AppRequestable m)
36+
37+ performTask StatusUpdate {..} = do
38+ response <- appRequest $ createStatusR owner repoName sha status
39+ case response of
40+ Left err -> logError (T.pack $ show err) >> return Failure
41+ Right st -> logDebug (T.pack $ show st) >> return Success
src/Server.hsnew file+256
@@ -0,0 +1,256 @@
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.Monad.Except
14+import Control.Monad.IO.Unlift
15+import Control.Monad.Reader
16+import Control.Task.Scheduler
17+import Data.Aeson
18+import Data.ByteString
19+import Data.IORef
20+import Data.Map (Map)
21+import qualified Data.Map as M
22+import Data.Submission
23+import Data.Submission.Query
24+import Data.Tasks.Build
25+import Data.Tasks.StatusUpdate
26+import qualified Data.Text as T
27+import Data.Yaml
28+import GHC.Generics
29+import GitHub
30+import GitHub.App.Auth
31+import GitHub.App.Request
32+import GitHub.Data.Name
33+import GitHub.Data.Webhooks.Events
34+import GitHub.Data.Webhooks.Payload
35+import Network.Wai.Handler.Warp
36+import Servant
37+import Servant.GitHub.Webhook
38+import Servant.HTML.Blaze
39+import Server.Config
40+import Server.Html
41+import Server.Schema
42+import Squeal.PostgreSQL
43+import System.IO
44+import Text.Blaze.Html
45+import UnliftIO.Exception (try)
46+
47+type API =
48+ "github-webhook"
49+ :> ( GitHubEvent '[ 'WebhookInstallationEvent]
50+ :> GitHubSignedReqBody '[JSON] InstallationEvent
51+ :> Post '[JSON] ()
52+ :<|> GitHubEvent '[ 'WebhookPushEvent]
53+ :> GitHubSignedReqBody '[JSON] PushEvent
54+ :> Post '[JSON] ()
55+ )
56+ :<|> "submission"
57+ :> Capture "user name" String
58+ :> Capture "repo name" String
59+ :> Capture "sha" String
60+ :> Get '[HTML] Markup
61+ :<|> "submission"
62+ :> Capture "user name" String
63+ :> Capture "repo name" String
64+ :> Capture "sha" String
65+ :> "restart"
66+ :> Post '[HTML] Markup
67+
68+webhookInstallation :: MonadIO m => RepoWebhookEvent -> ((), InstallationEvent) -> m ()
69+webhookInstallation _ ((), ev) =
70+ liftIO $ do
71+ print ev
72+ hFlush stdout
73+
74+pendingStatus :: NewStatus
75+pendingStatus = NewStatus StatusPending Nothing Nothing Nothing
76+
77+webhookPushEvent ::
78+ (StaticPQ m, WithLog env Message m, MonadUnliftIO m, HasTasks m) =>
79+ RepoWebhookEvent ->
80+ ((), PushEvent) ->
81+ m ()
82+webhookPushEvent _ ((), ev) = do
83+ let repo = evPushRepository ev
84+ user = T.unpack . whUserLogin . evPushSender $ ev
85+ fullRepoName = whRepoFullName repo
86+ [owner, repoName] = T.splitOn "/" fullRepoName
87+ Just sha = evPushHeadSha ev
88+ tasks <- getTasks
89+ let task =
90+ M.lookupMax $
91+ M.takeWhileAntitone (repoName >) tasks
92+ case task of
93+ Just (name, TaskConfig {..}) | T.take (T.length name) repoName == name -> do
94+ scheduleTask $ StatusUpdate (N owner) (N repoName) (N sha) pendingStatus
95+ createSubmission $
96+ Submission
97+ user
98+ (T.unpack fullRepoName)
99+ (T.unpack name)
100+ (T.unpack sha)
101+ (Jsonb BuildScheduled)
102+ scheduleTask $ Build prebuild build (N owner) (N repoName) (N sha)
103+ liftIO $ do
104+ print ev
105+ hFlush stdout
106+ _ -> return ()
107+
108+retestSubmission ::
109+ (StaticPQ m, WithLog env Message m, MonadUnliftIO m, HasTasks m, MonadHasBaseUrl m) =>
110+ String ->
111+ String ->
112+ String ->
113+ m Markup
114+retestSubmission owner repoName sha = do
115+ let fullRepoName = owner <> "/" <> repoName
116+ repoName' = T.pack repoName
117+ sha' = T.pack sha
118+ owner' = T.pack owner
119+ getSubmission fullRepoName sha >>= \case
120+ Nothing -> return ()
121+ Just _ -> do
122+ tasks <- getTasks
123+ let task =
124+ M.lookupMax $
125+ M.takeWhileAntitone (repoName' >) tasks
126+ case task of
127+ Just (name, TaskConfig {..}) | T.take (T.length name) repoName' == name -> do
128+ scheduleTask $ StatusUpdate (N owner') (N repoName') (N sha') pendingStatus
129+ updateSubmissionStatus fullRepoName sha BuildScheduled
130+ scheduleTask $ Build prebuild build (N owner') (N repoName') (N sha')
131+ _ -> return ()
132+ redirectToSubmission owner repoName sha
133+
134+newtype ServerM (schema :: SchemasType) a
135+ = ServerM
136+ { unApp :: ReaderT (ServerData (ServerM schema)) (PQ schema schema IO) a
137+ }
138+ deriving newtype
139+ ( Functor,
140+ Applicative,
141+ Monad,
142+ MonadIO,
143+ MonadReader (ServerData (ServerM schema)),
144+ MonadPQ schema,
145+ MonadUnliftIO
146+ )
147+
148+server :: ServerT API (ServerM Schema)
149+server = (webhookInstallation :<|> webhookPushEvent) :<|> getSubmissionR :<|> retestSubmission
150+
151+runServer :: IO ()
152+runServer = do
153+ c@Config {..} <- getConfig
154+ print c
155+ auth <- mkInstallationAuth (AppAuth appId appPkPem) installationId
156+ ts <- newIORef mempty
157+ pool <- createConnectionPool databseUrl 1 0.5 10
158+ _ <- forkIO $ do
159+ updateTasks ts tasksPath
160+ threadDelay $ 10 * 60 * (10 ^ (6 :: Int))
161+ let context =
162+ gitPolyHubKey (return webhookSecret)
163+ :. EmptyContext
164+ serverData = ServerData
165+ { githubAppAuth = auth,
166+ githubUserName = GithubUserName githubUsername,
167+ githubAccessToken = GithubAccessToken personalAccessToken,
168+ tasks = ts,
169+ logger = simpleMessageAction,
170+ baseUrl = baseSiteUrl
171+ }
172+ repeatIfNotEmpty n f = f >>= \m -> do
173+ when (m == 0) $ liftIO $ threadDelay n
174+ repeatIfNotEmpty n f
175+ _ <-
176+ forkIO . repeatIfNotEmpty (10 ^ (6 :: Int))
177+ . usingConnectionPool pool
178+ . (`runReaderT` serverData)
179+ . unApp
180+ $ runTasks @'[Build] 1
181+ _ <-
182+ forkIO . repeatIfNotEmpty (10 ^ (6 :: Int))
183+ . usingConnectionPool pool
184+ . (`runReaderT` serverData)
185+ . unApp
186+ $ runTasks @'[StatusUpdate] 5
187+ run port $ serveWithContext (Proxy @API) context $
188+ hoistServerWithContext
189+ (Proxy @API)
190+ (Proxy @'[PolyGitHubKey])
191+ (Handler . ExceptT . try . usingConnectionPool pool . (`runReaderT` serverData) . unApp)
192+ server
193+
194+updateTasks :: IORef TasksConfig -> FilePath -> IO ()
195+updateTasks ref path =
196+ decodeFileEither path >>= \case
197+ Right a -> writeIORef ref a
198+ Left e -> print e
199+
200+data ServerData m
201+ = ServerData
202+ { githubAppAuth :: !InstallationAuth,
203+ githubUserName :: !GithubUserName,
204+ githubAccessToken :: !GithubAccessToken,
205+ tasks :: IORef TasksConfig,
206+ logger :: LogAction m Message,
207+ baseUrl :: String
208+ }
209+
210+newtype PolyGitHubKey = PolyGitHubKey (forall result. GitHubKey result)
211+
212+gitPolyHubKey :: IO ByteString -> PolyGitHubKey
213+gitPolyHubKey k = PolyGitHubKey (Servant.GitHub.Webhook.gitHubKey k)
214+
215+instance HasContextEntry '[PolyGitHubKey] (GitHubKey result) where
216+ getContextEntry (PolyGitHubKey x :. _) = x
217+
218+instance MonadReader (ServerData n) m => GithubCloner m where
219+
220+ getGithubAccessToken = asks githubAccessToken
221+
222+ getGithubUserName = asks githubUserName
223+
224+instance (MonadIO m, MonadReader (ServerData n) m) => AppRequestable m where
225+ appRequest req = do
226+ auth <- asks githubAppAuth
227+ liftIO $ executeAppRequest auth req
228+
229+instance MonadReader (ServerData n) m => MonadHasBaseUrl m where
230+ getBaseUrl = asks baseUrl
231+
232+instance (MonadIO m, MonadReader (ServerData n) m) => HasTasks m where
233+ getTasks = asks tasks >>= liftIO . readIORef
234+
235+type TasksConfig = Map T.Text TaskConfig
236+
237+data TaskConfig
238+ = TaskConfig
239+ { prebuild :: String,
240+ build :: String
241+ }
242+ deriving stock (Show, Eq, Generic)
243+ deriving anyclass (FromJSON, ToJSON)
244+
245+class HasTasks m where
246+ getTasks :: m TasksConfig
247+
248+instance HasLog (ServerData m) Message m where
249+
250+ getLogAction :: ServerData m -> LogAction m Message
251+ getLogAction = logger
252+ {-# INLINE getLogAction #-}
253+
254+ setLogAction :: LogAction m Message -> ServerData m -> ServerData m
255+ setLogAction newLogAction env = env {logger = newLogAction}
256+ {-# INLINE setLogAction #-}
src/Server/Config.hsnew file+56
@@ -0,0 +1,56 @@
1+{-# OPTIONS_GHC -Wno-orphans #-}
2+
3+module Server.Config
4+ ( Config (..),
5+ getConfig,
6+ )
7+where
8+
9+import Crypto.PubKey.RSA (PrivateKey)
10+import Crypto.PubKey.RSA.Read
11+import Data.ByteString as BS
12+import qualified Data.ByteString.Char8 as BS8
13+import Data.Maybe
14+import GitHub.Data.Apps
15+import GitHub.Data.Id
16+import GitHub.Data.Installations
17+import System.Environment
18+
19+data Config
20+ = Config
21+ { webhookSecret :: !ByteString,
22+ appId :: !(Id App),
23+ appPkPem :: !PrivateKey,
24+ port :: !Int,
25+ installationId :: !(Id Installation),
26+ personalAccessToken :: !String,
27+ githubUsername :: !String,
28+ tasksPath :: !FilePath,
29+ databseUrl :: !ByteString,
30+ baseSiteUrl :: !String
31+ }
32+ deriving (Show)
33+
34+getConfig :: IO Config
35+getConfig =
36+ Config
37+ <$> (maybe (error "no GITHUB_WEBHOOK_SECRET") BS8.pack <$> lookupEnv "GITHUB_WEBHOOK_SECRET")
38+ <*> (maybe (error "no GITHUB_APP_ID") (Id . read) <$> lookupEnv "GITHUB_APP_ID")
39+ <*> readPem
40+ <*> (maybe 8080 read <$> lookupEnv "PORT")
41+ <*> (maybe (error "no GITHUB_INSTALLATION_ID") (Id . read) <$> lookupEnv "GITHUB_INSTALLATION_ID")
42+ <*> (fromMaybe (error "no PERSONAL_ACCESS_TOKEN") <$> lookupEnv "PERSONAL_ACCESS_TOKEN")
43+ <*> (fromMaybe (error "no GITHUB_USERNAME") <$> lookupEnv "GITHUB_USERNAME")
44+ <*> (fromMaybe (error "no TASKS") <$> lookupEnv "TASKS")
45+ <*> (maybe (error "no DATABASE_URL") BS8.pack <$> lookupEnv "DATABASE_URL")
46+ <*> (fromMaybe "http://localhost:8080" <$> lookupEnv "PORT")
47+ where
48+ readPem :: IO PrivateKey
49+ readPem = do
50+ path <- fromMaybe (error "no app pk") <$> lookupEnv "GITHUB_APP_PK"
51+ pem <- BS.readFile path
52+ case readRsaPem pem of
53+ Right k -> return k
54+ Left e -> error (show e)
55+
56+deriving instance Show ReadRsaKeyError
src/Server/Html.hsnew file+111
@@ -0,0 +1,111 @@
1+module Server.Html
2+ ( getSubmissionR,
3+ MonadHasBaseUrl (..),
4+ redirectToSubmission,
5+ getUrl,
6+ )
7+where
8+
9+import Clay as C
10+import Colog
11+import Control.Monad.IO.Class
12+import Control.Monad.IO.Unlift
13+import Data.Aeson hiding (Success)
14+import qualified Data.ByteString.Lazy.Char8 as BS
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 GHC.Generics
21+import Server.Schema
22+import Squeal.PostgreSQL (Jsonb (..))
23+import Text.Blaze
24+import Text.Blaze.Html
25+import Text.Blaze.Html4.Strict.Attributes as A
26+import Text.Blaze.Html5 as H
27+
28+getSubmissionR ::
29+ (MonadUnliftIO m, StaticPQ m, WithLog env Message m, MonadHasBaseUrl m) =>
30+ String ->
31+ String ->
32+ String ->
33+ m Markup
34+getSubmissionR user repo sha = do
35+ restartUrl <- (<> "/restart") <$> getUrl (user <> "/" <> repo) sha
36+ let restartBuild = do
37+ H.form H.! A.action (fromString restartUrl) H.! A.method "post" $
38+ H.input H.! A.type_ "submit" H.! A.value "Restart test"
39+ (titleText, inner) <- getSubmission (user <> "/" <> repo) sha >>= \case
40+ Nothing ->
41+ return . ("Not found",) $
42+ H.h1 "404. not found. go away."
43+ Just Submission {..} -> return . (repo,) $ do
44+ H.h1 $ toHtml problem
45+ H.h2 $ toHtml userName
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+ return . docTypeHtml $ do
65+ H.head $ do
66+ H.title $ toHtml titleText
67+ H.style . preEscapedToHtml . render $ do
68+ C.body ? do
69+ fontFamily [] [sansSerif]
70+ C.maxWidth (px 800)
71+ C.display C.block
72+ C.marginLeft auto
73+ C.marginRight auto
74+ C.paddingLeft (px 16)
75+ C.paddingRight (px 16)
76+ (C.h1 <> C.h2 <> C.h3) ? do
77+ textAlign center
78+ C.pre ? do
79+ C.whiteSpace C.preWrap
80+ C.table ? do
81+ C.width (pct 100)
82+ (C.tr <> C.td) ? do
83+ C.width (pct 50)
84+ C.td ? do
85+ C.padding (px 4) (px 4) (px 4) (px 4)
86+ C.form ? do
87+ C.display C.block
88+ C.marginLeft auto
89+ C.marginRight auto
90+ H.body inner
91+
92+class MonadHasBaseUrl m where
93+ getBaseUrl :: m String
94+
95+getUrl :: (MonadHasBaseUrl m, Monad m) => String -> String -> m String
96+getUrl fullName sha = do
97+ siteBase <- getBaseUrl
98+ return $ siteBase <> "/submission/" <> fullName <> "/" <> sha
99+
100+redirectToSubmission ::
101+ (MonadHasBaseUrl m, Monad m) =>
102+ String ->
103+ String ->
104+ String ->
105+ m Markup
106+redirectToSubmission user repo sha = do
107+ rUrl <- getUrl (user <> "/" <> repo) sha
108+ return $ docTypeHtml $ H.head $
109+ H.meta
110+ H.! A.httpEquiv "refresh"
111+ H.! A.content (fromString $ "0; URL=" <> rUrl)
src/Server/Schema.hsnew file+18
@@ -0,0 +1,18 @@
1+module Server.Schema
2+ ( StaticPQ,
3+ Schema,
4+ migration,
5+ )
6+where
7+
8+import Server.Schema.V1
9+import Squeal.PostgreSQL
10+
11+type StaticPQ m = MonadPQ Schema m
12+
13+type Schema = SchemaV1
14+
15+migration :: AlignedList (Migration (Terminally PQ IO)) (Public '[]) Schema
16+migration =
17+ pureMigration schemaMigrationV1
18+ :>> Done
src/Server/Schema/V1.hsnew file+63
@@ -0,0 +1,63 @@
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+ ]
23+ ),
24+ "submissions"
25+ ::: 'Table
26+ ( '["pk_submission_repo_full_name_sha" :=> 'PrimaryKey '["repo_full_name", "sha"]]
27+ :=> '[ "user_name" ::: 'NoDef :=> 'NotNull (PG String),
28+ "repo_full_name" ::: 'NoDef :=> 'NotNull (PG String),
29+ "problem" ::: 'NoDef :=> 'NotNull (PG String),
30+ "sha" ::: 'NoDef :=> 'NotNull (PG String),
31+ "status" ::: 'NoDef :=> 'NotNull (PG (Jsonb SubmissionStatus))
32+ ]
33+ )
34+ ]
35+
36+schemaMigrationV1 :: Migration Definition (Public '[]) SchemaV1
37+schemaMigrationV1 = Migration
38+ { name = "v1",
39+ up =
40+ createTable
41+ #tasks
42+ ( notNullable text `as` #task
43+ :* notNullable jsonb `as` #payload
44+ :* default_ now (notNullable timestampWithTimeZone) `as` #creation_time
45+ )
46+ (primaryKey (#task :* #payload) `as` #pk_task_payload)
47+ >>> createTable
48+ #submissions
49+ ( notNullable text `as` #user_name
50+ :* notNullable text `as` #repo_full_name
51+ :* notNullable text `as` #problem
52+ :* notNullable text `as` #sha
53+ :* notNullable jsonb `as` #status
54+ )
55+ (primaryKey (#repo_full_name :* #sha) `as` #pk_submission_repo_full_name_sha)
56+ >>> createIndexes,
57+ down = dropTable #tasks >>> dropTable #submissions
58+ }
59+ where
60+ createIndexes :: Definition sch sch
61+ createIndexes =
62+ UnsafeDefinition
63+ "CREATE INDEX ON tasks (creation_time);"
stack.yamlnew file+75
@@ -0,0 +1,75 @@
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.19
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.24
44+- binary-instances-1
45+- squeal-postgresql-0.5.2.0
46+- git: https://github.com/ilyakooo0/github-app
47+ commit: 0bede85ab53eb8f953cf6f4e58a756a205e88e0b
48+- servant-github-webhook-0.4.2.0
49+
50+# Override default flag values for local packages and extra-deps
51+# flags: {}
52+
53+# Extra package databases containing global packages
54+# extra-package-dbs: []
55+
56+# Control whether we use the GHC we find on the path
57+# system-ghc: true
58+#
59+# Require a specific version of stack, using version ranges
60+# require-stack-version: -any # Default
61+# require-stack-version: ">=2.1"
62+#
63+# Override the architecture used by stack, especially useful on Windows
64+# arch: i386
65+# arch: x86_64
66+#
67+# Extra directories used by stack for building
68+# extra-include-dirs: [/path/to/dir]
69+# extra-lib-dirs: [/path/to/dir]
70+#
71+# Allow a newer minor version of GHC than the snapshot specifies
72+# compiler-check: newer-minor
73+
74+ghc-options:
75+ "$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