Initial working commit

.gitignore

@@ -0,0 +1 @@
+.stack-work

LICENSE

@@ -1,6 +1,6 @@
 MIT License
 
-Copyright (c) 2020 iko
+Copyright (c) 2020 Ilya Kostyuchenko
 
 Permission is hereby granted, free of charge, to any person obtaining a copy
 of this software and associated documentation files (the "Software"), to deal

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

app/Main.hs

@@ -0,0 +1,6 @@
+module Main (main) where
+
+import Server
+
+main :: IO ()
+main = runServer

hie.yaml

@@ -0,0 +1,4 @@
+cradle:
+  stack:
+    - path: "."
+      component: "sc-build:lib"

migrations/Main.hs

@@ -0,0 +1,14 @@
+module Main
+  ( main,
+  )
+where
+
+import Data.ByteString.Char8 (pack)
+import Server.Schema
+import Squeal.PostgreSQL
+import System.Environment
+
+main :: IO ()
+main = do
+  Just dbString <- fmap pack <$> lookupEnv "DATABASE_URL"
+  defaultMain dbString migration

package.yaml

@@ -0,0 +1,102 @@
+name:                sc-build
+version:             0.1.0.0
+#synopsis:
+#description:
+homepage:            https://github.com/ilyakooo0/sc-build#readme
+license:             BSD3
+author:              Ilya Kostyuchenko
+maintainer:          ilyakooo0@gmail.com
+copyright:           Ilya Kostyuchenko
+category:            Web
+extra-source-files:
+- README.md
+
+dependencies:
+- base >= 4.7 && < 5
+
+library:
+  source-dirs: src
+  dependencies:
+  - servant
+  - servant-server
+  - process
+  - yaml
+  - aeson
+  - github
+  - github-app
+  - github-webhooks
+  - warp
+  - vector
+  - bytestring
+  - servant-github-webhook
+  - cryptonite
+  - mtl
+  - text
+  - containers
+  - random
+  - time
+  - typed-process
+  - directory
+  - squeal-postgresql
+  - generics-sop
+  - co-log
+  - unliftio-core
+  - unliftio
+  - servant-blaze
+  - blaze-markup
+  - blaze-html
+  - clay
+
+executables:
+  sc-build-exe:
+    main:                Main.hs
+    source-dirs:         app
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - sc-build
+  sc-build-migrations:
+    main:                Main.hs
+    source-dirs:         migrations
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - sc-build
+    - bytestring
+    - squeal-postgresql
+
+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

sc-build.cabal

@@ -0,0 +1,103 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.31.2.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: bb953e6231fcc3939bfe085afcd3e792cbc40462461bbe4fb82ae69f1796be4c
+
+name:           sc-build
+version:        0.1.0.0
+category:       Web
+homepage:       https://github.com/ilyakooo0/sc-build#readme
+author:         Ilya Kostyuchenko
+maintainer:     ilyakooo0@gmail.com
+copyright:      Ilya Kostyuchenko
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+extra-source-files:
+    README.md
+
+library
+  exposed-modules:
+      Control.AppRequestable
+      Control.GithubCloner
+      Control.Squeal
+      Control.Task
+      Control.Task.Scheduler
+      Control.Task.Scheduler.Query
+      Data.Submission
+      Data.Submission.Query
+      Data.Tasks.Build
+      Data.Tasks.StatusUpdate
+      Server
+      Server.Config
+      Server.Html
+      Server.Schema
+      Server.Schema.V1
+  other-modules:
+      Paths_sc_build
+  hs-source-dirs:
+      src
+  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
+  build-depends:
+      aeson
+    , base >=4.7 && <5
+    , blaze-html
+    , blaze-markup
+    , bytestring
+    , clay
+    , co-log
+    , containers
+    , cryptonite
+    , directory
+    , generics-sop
+    , github
+    , github-app
+    , github-webhooks
+    , mtl
+    , process
+    , random
+    , servant
+    , servant-blaze
+    , servant-github-webhook
+    , servant-server
+    , squeal-postgresql
+    , text
+    , time
+    , typed-process
+    , unliftio
+    , unliftio-core
+    , vector
+    , warp
+    , yaml
+  default-language: Haskell2010
+
+executable sc-build-exe
+  main-is: Main.hs
+  other-modules:
+      Paths_sc_build
+  hs-source-dirs:
+      app
+  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
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base >=4.7 && <5
+    , sc-build
+  default-language: Haskell2010
+
+executable sc-build-migrations
+  main-is: Main.hs
+  other-modules:
+      Paths_sc_build
+  hs-source-dirs:
+      migrations
+  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
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base >=4.7 && <5
+    , bytestring
+    , sc-build
+    , squeal-postgresql
+  default-language: Haskell2010

src/Control/AppRequestable.hs

@@ -0,0 +1,10 @@
+module Control.AppRequestable
+  ( AppRequestable (..),
+  )
+where
+
+import Data.Aeson
+import GitHub
+
+class AppRequestable m where
+  appRequest :: FromJSON a => GenRequest 'MtJSON rw a -> m (Either Error a)

src/Control/GithubCloner.hs

@@ -0,0 +1,16 @@
+module Control.GithubCloner
+  ( GithubAccessToken (..),
+    GithubUserName (..),
+    GithubCloner (..),
+  )
+where
+
+newtype GithubAccessToken = GithubAccessToken String
+
+newtype GithubUserName = GithubUserName String
+
+class GithubCloner m where
+
+  getGithubAccessToken :: m GithubAccessToken
+
+  getGithubUserName :: m GithubUserName

src/Control/Squeal.hs

@@ -0,0 +1,81 @@
+{-# LANGUAGE TypeApplications #-}
+
+module Control.Squeal
+  ( db,
+    db',
+    dbRead,
+    dbRead',
+    dbWrite,
+    dbWrite',
+  )
+where
+
+import Colog
+import Control.Monad.Except
+import Control.Monad.IO.Unlift
+import qualified Data.Text as T
+import Squeal.PostgreSQL
+
+db ::
+  forall schemas m env x.
+  (MonadPQ schemas m, WithLog env Message m, MonadUnliftIO m) =>
+  Maybe TransactionMode ->
+  (SquealException -> m x) ->
+  m x ->
+  m x
+db tr err pqx = (trySqueal . maybe id transactionallyRetry tr) pqx >>= \case
+  Left e -> do
+    logWarning . T.pack $ "SQL ERROR: " <> show e
+    err e
+  Right x -> return x
+
+dbRead ::
+  (MonadPQ schemas m, WithLog env Message m, MonadUnliftIO m) =>
+  (SquealException -> m x) ->
+  m x ->
+  m x
+dbRead = db Nothing
+
+dbRead' ::
+  ( MonadPQ schemas m,
+    MonadError err m,
+    WithLog env Message m,
+    MonadUnliftIO m
+  ) =>
+  err ->
+  m x ->
+  m x
+dbRead' = db' Nothing
+
+dbWrite ::
+  (MonadPQ schemas m, WithLog env Message m, MonadUnliftIO m) =>
+  (SquealException -> m x) ->
+  m x ->
+  m x
+dbWrite = db $ Just defaultWriteTransactionMode
+
+dbWrite' ::
+  ( MonadPQ schemas m,
+    MonadError err m,
+    WithLog env Message m,
+    MonadUnliftIO m
+  ) =>
+  err ->
+  m x ->
+  m x
+dbWrite' = db' $ Just defaultWriteTransactionMode
+
+defaultWriteTransactionMode :: TransactionMode
+defaultWriteTransactionMode = TransactionMode RepeatableRead ReadWrite NotDeferrable
+
+db' ::
+  ( MonadPQ schemas m,
+    MonadError err m,
+    WithLog env Message m,
+    MonadUnliftIO m
+  ) =>
+  Maybe TransactionMode ->
+  err ->
+  m x ->
+  m x
+db' tr err = db tr (const $ throwError err)

src/Control/Task.hs

@@ -0,0 +1,26 @@
+module Control.Task
+  ( Task (..),
+    Result (..),
+  )
+where
+
+import Colog
+import Data.Aeson hiding (Result)
+import Data.Kind
+import GHC.Generics
+import GHC.TypeLits
+
+data Result
+  = Success
+  | Failure
+  deriving (Eq, Ord, Show, Generic)
+
+class
+  (ToJSON t, FromJSON t, KnownSymbol s, Show t) =>
+  Task t s
+    | s -> t,
+      t -> s where
+
+  type TaskMonad t (m :: * -> *) :: Constraint
+
+  performTask :: (TaskMonad t m, WithLog env Message m) => t -> m Result

src/Control/Task/Scheduler.hs

@@ -0,0 +1,86 @@
+{-# LANGUAGE TypeApplications #-}
+
+module Control.Task.Scheduler
+  ( scheduleTask,
+    runTasks,
+  )
+where
+
+import Colog
+import Control.Monad
+import Control.Monad.IO.Unlift
+import Control.Task
+import Control.Task.Scheduler.Query
+import Data.Aeson hiding (Result (..))
+import qualified Data.Aeson as A
+import Data.Foldable
+import Data.Proxy
+import qualified Data.Text as T
+import Data.Word
+import GHC.TypeLits
+import Server.Schema
+import Squeal.PostgreSQL
+
+scheduleTask ::
+  (StaticPQ m, WithLog env Message m, Task t s, MonadUnliftIO m) =>
+  t ->
+  m ()
+scheduleTask = scheduleTaskQuery
+
+runTasks ::
+  forall tt m env.
+  (StaticPQ m, WithLog env Message m, RunTasks tt m, MonadUnliftIO m) =>
+  Word64 ->
+  m Int
+runTasks n = do
+  tasks <- pickTasksQuery (taskNames @tt @m) n
+  for_ tasks $ runTask @tt @m
+  return $ length tasks
+
+rescheduleTaskTime ::
+  forall t s m env.
+  (Task t s, StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>
+  t ->
+  m ()
+rescheduleTaskTime = rescheduleTaskQuery
+
+class RunTasks (ts :: [*]) m where
+
+  runTask :: WithLog env Message m => PickedTask -> m ()
+
+  taskNames :: [String]
+
+instance
+  forall t ts tt m.
+  (Task t ts, TaskMonad t m, StaticPQ m, RunTasks tt m, MonadUnliftIO m) =>
+  RunTasks (t ': tt) m
+  where
+
+  runTask (PickedTask s (Jsonb v) initialStartTime) | symbolVal @ts Proxy == s =
+    case fromJSON @t v of
+      A.Error e ->
+        logError . T.pack $
+          "Coulndn't decode payload for task " <> s
+            <> " with payload "
+            <> show v
+            <> " with error "
+            <> e
+      A.Success t -> do
+        logInfo . T.pack $ "running task " <> task <> " with " <> show t <> " created at " <> show initialStartTime
+        r <- performTask @t @ts @m t
+        when (r == Failure) $ logWarning . T.pack $ "Task " <> task <> " failed"
+        case r of
+          Success -> completeTaskQuery t
+          Failure -> rescheduleTaskTime t
+    where
+      task = symbolVal @ts Proxy
+  runTask t = runTask @tt @m t
+
+  taskNames = symbolVal @ts Proxy : taskNames @tt @m
+
+instance RunTasks '[] m where
+
+  runTask (PickedTask s (Jsonb v) _) =
+    logError . T.pack $ "Unknown task " <> s <> " with payload " <> show v
+
+  taskNames = []

src/Control/Task/Scheduler/Query.hs

@@ -0,0 +1,121 @@
+{-# LANGUAGE TypeApplications #-}
+
+module Control.Task.Scheduler.Query
+  ( scheduleTaskQuery,
+    completeTaskQuery,
+    rescheduleTaskQuery,
+    pickTasksQuery,
+    PickedTask (..),
+  )
+where
+
+import Colog
+import Control.Monad.IO.Unlift
+import Control.Squeal
+import Control.Task
+import Data.Aeson hiding (Result (..))
+import Data.Proxy
+import qualified Data.Text as T
+import Data.Time
+import Data.Word
+import GHC.Generics (Generic)
+import GHC.TypeLits
+import qualified Generics.SOP as SOP
+import Server.Schema
+import Squeal.PostgreSQL
+
+scheduleTaskQuery ::
+  forall m t s env.
+  (StaticPQ m, Task t s, WithLog env Message m, MonadUnliftIO m) =>
+  t ->
+  m ()
+scheduleTaskQuery task = do
+  logInfo . T.pack $ "schdeuling task: " <> show task
+  let query =
+        insertInto
+          #tasks
+          ( Values_ $
+              Set (param @1) `as` #task
+                :* Set (param @2) `as` #payload
+                :* Default `as` #creation_time
+          )
+          ( OnConflict
+              (OnConstraint #pk_task_payload)
+              (DoUpdate (Default `as` #creation_time) [])
+          )
+          (Returning_ Nil)
+  dbWrite (const $ return ()) $
+    manipulateParams_
+      query
+      (symbolVal @s Proxy, Jsonb $ toJSON task)
+
+completeTaskQuery ::
+  forall m t s env.
+  (StaticPQ m, Task t s, WithLog env Message m, MonadUnliftIO m) =>
+  t ->
+  m ()
+completeTaskQuery payload = do
+  let task = symbolVal @s Proxy
+  logInfo . T.pack $ "Completing task: " <> task <> " with payload " <> show payload
+  let query :: Manipulation_ Schema (String, Jsonb Value) ()
+      query =
+        deleteFrom_
+          #tasks
+          (param @1 .== #task .&& param @2 .== #payload)
+  dbWrite (const $ return ()) $
+    manipulateParams_
+      query
+      (symbolVal @s Proxy, Jsonb $ toJSON payload)
+
+rescheduleTaskQuery ::
+  forall s t m env.
+  (StaticPQ m, Task t s, WithLog env Message m, MonadUnliftIO m) =>
+  t ->
+  m ()
+rescheduleTaskQuery payload = do
+  let task = symbolVal @s Proxy
+  logInfo . T.pack $
+    "reschdeuling task: " <> task
+      <> " with payload "
+      <> show payload
+  let query :: Manipulation_ Schema (String, Jsonb Value) ()
+      query =
+        update_
+          #tasks
+          (Default `as` #creation_time)
+          (param @1 .== #task .&& param @2 .== #payload)
+  dbWrite (const $ return ()) $
+    manipulateParams_
+      query
+      (symbolVal @s Proxy, Jsonb $ toJSON payload)
+
+pickTasksQuery ::
+  forall m env.
+  (StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>
+  [String] ->
+  Word64 ->
+  m [PickedTask]
+pickTasksQuery tasks limitCount = do
+  logDebug "reading tasks"
+  let query :: Query_ Schema () PickedTask
+      query =
+        select_
+          ( #task `as` #task
+              :* #payload `as` #payload
+              :* #creation_time `as` #creationTime
+          )
+          ( from (table #tasks)
+              & where_ (#task `in_` (literal <$> tasks))
+              & orderBy [#creation_time & Asc]
+              & limit limitCount
+          )
+  dbRead (const $ return []) $
+    runQuery query >>= getRows
+
+data PickedTask
+  = PickedTask
+      { task :: String,
+        payload :: Jsonb Value,
+        creationTime :: UTCTime
+      }
+  deriving (Eq, Show, Generic, SOP.Generic, SOP.HasDatatypeInfo)

src/Data/Submission.hs

@@ -0,0 +1,36 @@
+module Data.Submission
+  ( Submission (..),
+    SubmissionStatus (..),
+    TestResult (..),
+  )
+where
+
+import Data.Aeson
+import Data.Map (Map)
+import Data.Text (Text)
+import GHC.Generics (Generic)
+import qualified Generics.SOP as SOP
+import Squeal.PostgreSQL
+
+data Submission
+  = Submission
+      { userName :: String,
+        repoFullName :: String,
+        problem :: String,
+        sha :: String,
+        status :: Jsonb SubmissionStatus
+      }
+  deriving (Eq, Show, Generic, SOP.Generic, SOP.HasDatatypeInfo)
+
+data SubmissionStatus
+  = SubmissionRun TestResult
+  | SubmissionFailed String
+  | BuildScheduled
+  deriving (Generic, FromJSON, ToJSON, Eq, Show)
+
+newtype TestResult
+  = TestResult
+      { tests :: Map Text Bool
+      }
+  deriving stock (Eq, Show, Generic)
+  deriving anyclass (FromJSON, ToJSON)

src/Data/Submission/Query.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE TypeApplications #-}
+
+module Data.Submission.Query
+  ( createSubmission,
+    updateSubmissionStatus,
+    getSubmission,
+  )
+where
+
+import Colog
+import Control.Monad.IO.Unlift
+import Control.Squeal
+import Data.Submission
+import qualified Data.Text as T
+import Server.Schema
+import Squeal.PostgreSQL
+
+createSubmission ::
+  (StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>
+  Submission ->
+  m ()
+createSubmission s@Submission {..} = do
+  logInfo . T.pack $ "Creating submission: " <> show s
+  let query =
+        insertInto
+          #submissions
+          ( Values_ $
+              Set (param @1) `as` #user_name
+                :* Set (param @2) `as` #repo_full_name
+                :* Set (param @3) `as` #problem
+                :* Set (param @4) `as` #sha
+                :* Set (param @5) `as` #status
+          )
+          ( OnConflict
+              (OnConstraint #pk_submission_repo_full_name_sha)
+              DoNothing
+          )
+          (Returning_ Nil)
+  dbWrite (const $ return ()) $
+    manipulateParams_
+      query
+      (userName, repoFullName, problem, sha, status)
+
+updateSubmissionStatus ::
+  (StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>
+  String ->
+  String ->
+  SubmissionStatus ->
+  m ()
+updateSubmissionStatus repoFullName sha status = do
+  let query :: Manipulation_ Schema (Jsonb SubmissionStatus, String, String) ()
+      query =
+        update_
+          #submissions
+          (Set (param @1) `as` #status)
+          (#repo_full_name .== param @2 .&& #sha .== param @3)
+  dbWrite (const $ return ()) $
+    manipulateParams_
+      query
+      (Jsonb status, repoFullName, sha)
+
+getSubmission ::
+  (StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>
+  String ->
+  String ->
+  m (Maybe Submission)
+getSubmission repoFullName sha = do
+  let query :: Query_ Schema (String, String) Submission
+      query =
+        select_
+          ( #user_name `as` #userName
+              :* #repo_full_name `as` #repoFullName
+              :* #problem `as` #problem
+              :* #sha `as` #sha
+              :* #status `as` #status
+          )
+          ( from (table #submissions)
+              & where_
+                (#repo_full_name .== param @1 .&& #sha .== param @2)
+          )
+  dbRead (const $ return Nothing) $
+    runQueryParams
+      query
+      (repoFullName, sha)
+      >>= firstRow

src/Data/Tasks/Build.hs

@@ -0,0 +1,133 @@
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Data.Tasks.Build
+  ( Build (..),
+  )
+where
+
+import Colog
+import Control.GithubCloner
+import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift
+import Control.Task
+import Control.Task.Scheduler
+import Data.Aeson hiding (Success)
+import qualified Data.ByteString.Lazy.Char8 as BS
+import qualified Data.Map as M
+import Data.String
+import Data.Submission
+import Data.Submission.Query
+import Data.Tasks.StatusUpdate
+import qualified Data.Text as T
+import Data.Time.Clock.POSIX
+import GHC.Generics
+import GitHub
+import Server.Schema
+import System.Directory
+import System.Exit
+import System.Process.Typed
+import System.Random
+import UnliftIO.Exception
+
+data Build
+  = Build
+      { preProcessShell :: String,
+        buildCommand :: String,
+        owner :: Name Owner,
+        repoName :: Name Repo,
+        sha :: Name Commit
+      }
+  deriving (Eq, Show, Generic, FromJSON, ToJSON)
+
+instance Task Build "build-repo" where
+
+  type TaskMonad Build m = (MonadUnliftIO m, GithubCloner m, StaticPQ m)
+
+  performTask Build {..} =
+    bracket createDir (liftIO . removePathForcibly) $ \dir -> do
+      let fullRepoName = T.unpack $ untagName owner <> "/" <> untagName repoName
+          sha' = T.unpack $ untagName sha
+      cloneRepo fullRepoName sha' dir
+      (shellCode, _, shellErr) <- readProcess . setWorkingDir dir $ shell preProcessShell
+      case shellCode of
+        ExitFailure n -> do
+          let err = BS.unpack shellErr
+          logError . T.pack $
+            "preprocessing command for repo " <> show fullRepoName <> " at sha "
+              <> show sha
+              <> " exited with code "
+              <> show n
+              <> " and error "
+              <> err
+          scheduleTask erroredTask
+          updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
+        ExitSuccess -> do
+          (buildCode, buildOut, buildErr) <- readProcess . setWorkingDir dir . fromString $ buildCommand
+          case buildCode of
+            ExitFailure n -> do
+              let err = BS.unpack buildErr
+              logError . T.pack $
+                "test command for repo " <> show fullRepoName <> " at sha "
+                  <> show sha
+                  <> " exited with code "
+                  <> show n
+                  <> " and error "
+                  <> err
+              scheduleTask erroredTask
+              updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
+            ExitSuccess ->
+              case decode buildOut of
+                Nothing -> do
+                  let err = BS.unpack buildOut
+                  logError . T.pack $
+                    "could not decode test result from repo " <> show fullRepoName
+                      <> " at sha "
+                      <> show sha
+                      <> ": "
+                      <> err
+                  scheduleTask erroredTask
+                  updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
+                Just testResult@TestResult {..} -> do
+                  let total = M.size tests
+                      passed = M.size . M.filter id $ tests
+                      description = T.pack $ show passed <> "/" <> show total
+                      status = statusTask NewStatus
+                        { newStatusState =
+                            if total == passed then StatusSuccess else StatusFailure,
+                          newStatusTargetUrl = Nothing,
+                          newStatusDescription = Just description,
+                          newStatusContext = Nothing
+                        }
+                  scheduleTask status
+                  updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)
+      return Success
+    where
+      statusTask = StatusUpdate owner repoName sha
+      erroredTask = statusTask $ NewStatus
+        { newStatusState = StatusError,
+          newStatusTargetUrl = Nothing,
+          newStatusDescription = Just "Build failed",
+          newStatusContext = Nothing
+        }
+
+createDir :: MonadIO m => m FilePath
+createDir = do
+  dir <- ("tmp/" <>) <$> getTmpDirName
+  liftIO $ createDirectoryIfMissing True dir
+  return dir
+
+cloneRepo :: (MonadIO m, GithubCloner m) => String -> String -> FilePath -> m ()
+cloneRepo repoName sha path = do
+  GithubAccessToken token <- getGithubAccessToken
+  GithubUserName username <- getGithubUserName
+  runProcess_ . setWorkingDir path . fromString $
+    "git clone https://" <> username <> ":" <> token <> "@github.com/" <> repoName <> ".git ."
+  runProcess_ . setWorkingDir path . fromString $ "git checkout " <> sha
+  return ()
+
+getTmpDirName :: MonadIO m => m FilePath
+getTmpDirName = liftIO $ do
+  time :: Integer <- round <$> getPOSIXTime
+  i <- randomIO @Int
+  return $ show time <> "-" <> show i

src/Data/Tasks/StatusUpdate.hs

@@ -0,0 +1,41 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Data.Tasks.StatusUpdate
+  ( StatusUpdate (..),
+  )
+where
+
+import Colog
+import Control.AppRequestable
+import Control.Task
+import Data.Aeson hiding (Success)
+import qualified Data.Text as T
+import GHC.Generics
+import GitHub
+
+data StatusUpdate
+  = StatusUpdate
+      { owner :: Name Owner,
+        repoName :: Name Repo,
+        sha :: Name Commit,
+        status :: NewStatus
+      }
+  deriving (Eq, Show, Generic, ToJSON, FromJSON)
+
+instance FromJSON NewStatus where
+  parseJSON = withObject "NewStatus" $ \v ->
+    NewStatus
+      <$> v .: "state"
+      <*> v .:? "target_url"
+      <*> v .:? "description"
+      <*> v .:? "context"
+
+instance Task StatusUpdate "update-commit-ci-status" where
+
+  type TaskMonad StatusUpdate m = (AppRequestable m)
+
+  performTask StatusUpdate {..} = do
+    response <- appRequest $ createStatusR owner repoName sha status
+    case response of
+      Left err -> logError (T.pack $ show err) >> return Failure
+      Right st -> logDebug (T.pack $ show st) >> return Success

src/Server.hs

@@ -0,0 +1,256 @@
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Server
+  ( runServer,
+  )
+where
+
+import Colog
+import Control.AppRequestable
+import Control.Concurrent
+import Control.GithubCloner
+import Control.Monad.Except
+import Control.Monad.IO.Unlift
+import Control.Monad.Reader
+import Control.Task.Scheduler
+import Data.Aeson
+import Data.ByteString
+import Data.IORef
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Submission
+import Data.Submission.Query
+import Data.Tasks.Build
+import Data.Tasks.StatusUpdate
+import qualified Data.Text as T
+import Data.Yaml
+import GHC.Generics
+import GitHub
+import GitHub.App.Auth
+import GitHub.App.Request
+import GitHub.Data.Name
+import GitHub.Data.Webhooks.Events
+import GitHub.Data.Webhooks.Payload
+import Network.Wai.Handler.Warp
+import Servant
+import Servant.GitHub.Webhook
+import Servant.HTML.Blaze
+import Server.Config
+import Server.Html
+import Server.Schema
+import Squeal.PostgreSQL
+import System.IO
+import Text.Blaze.Html
+import UnliftIO.Exception (try)
+
+type API =
+  "github-webhook"
+    :> ( GitHubEvent '[ 'WebhookInstallationEvent]
+           :> GitHubSignedReqBody '[JSON] InstallationEvent
+           :> Post '[JSON] ()
+           :<|> GitHubEvent '[ 'WebhookPushEvent]
+             :> GitHubSignedReqBody '[JSON] PushEvent
+             :> Post '[JSON] ()
+       )
+    :<|> "submission"
+      :> Capture "user name" String
+      :> Capture "repo name" String
+      :> Capture "sha" String
+      :> Get '[HTML] Markup
+    :<|> "submission"
+      :> Capture "user name" String
+      :> Capture "repo name" String
+      :> Capture "sha" String
+      :> "restart"
+      :> Post '[HTML] Markup
+
+webhookInstallation :: MonadIO m => RepoWebhookEvent -> ((), InstallationEvent) -> m ()
+webhookInstallation _ ((), ev) =
+  liftIO $ do
+    print ev
+    hFlush stdout
+
+pendingStatus :: NewStatus
+pendingStatus = NewStatus StatusPending Nothing Nothing Nothing
+
+webhookPushEvent ::
+  (StaticPQ m, WithLog env Message m, MonadUnliftIO m, HasTasks m) =>
+  RepoWebhookEvent ->
+  ((), PushEvent) ->
+  m ()
+webhookPushEvent _ ((), ev) = do
+  let repo = evPushRepository ev
+      user = T.unpack . whUserLogin . evPushSender $ ev
+      fullRepoName = whRepoFullName repo
+      [owner, repoName] = T.splitOn "/" fullRepoName
+      Just sha = evPushHeadSha ev
+  tasks <- getTasks
+  let task =
+        M.lookupMax $
+          M.takeWhileAntitone (repoName >) tasks
+  case task of
+    Just (name, TaskConfig {..}) | T.take (T.length name) repoName == name -> do
+      scheduleTask $ StatusUpdate (N owner) (N repoName) (N sha) pendingStatus
+      createSubmission $
+        Submission
+          user
+          (T.unpack fullRepoName)
+          (T.unpack name)
+          (T.unpack sha)
+          (Jsonb BuildScheduled)
+      scheduleTask $ Build prebuild build (N owner) (N repoName) (N sha)
+      liftIO $ do
+        print ev
+        hFlush stdout
+    _ -> return ()
+
+retestSubmission ::
+  (StaticPQ m, WithLog env Message m, MonadUnliftIO m, HasTasks m, MonadHasBaseUrl m) =>
+  String ->
+  String ->
+  String ->
+  m Markup
+retestSubmission owner repoName sha = do
+  let fullRepoName = owner <> "/" <> repoName
+      repoName' = T.pack repoName
+      sha' = T.pack sha
+      owner' = T.pack owner
+  getSubmission fullRepoName sha >>= \case
+    Nothing -> return ()
+    Just _ -> do
+      tasks <- getTasks
+      let task =
+            M.lookupMax $
+              M.takeWhileAntitone (repoName' >) tasks
+      case task of
+        Just (name, TaskConfig {..}) | T.take (T.length name) repoName' == name -> do
+          scheduleTask $ StatusUpdate (N owner') (N repoName') (N sha') pendingStatus
+          updateSubmissionStatus fullRepoName sha BuildScheduled
+          scheduleTask $ Build prebuild build (N owner') (N repoName') (N sha')
+        _ -> return ()
+  redirectToSubmission owner repoName sha
+
+newtype ServerM (schema :: SchemasType) a
+  = ServerM
+      { unApp :: ReaderT (ServerData (ServerM schema)) (PQ schema schema IO) a
+      }
+  deriving newtype
+    ( Functor,
+      Applicative,
+      Monad,
+      MonadIO,
+      MonadReader (ServerData (ServerM schema)),
+      MonadPQ schema,
+      MonadUnliftIO
+    )
+
+server :: ServerT API (ServerM Schema)
+server = (webhookInstallation :<|> webhookPushEvent) :<|> getSubmissionR :<|> retestSubmission
+
+runServer :: IO ()
+runServer = do
+  c@Config {..} <- getConfig
+  print c
+  auth <- mkInstallationAuth (AppAuth appId appPkPem) installationId
+  ts <- newIORef mempty
+  pool <- createConnectionPool databseUrl 1 0.5 10
+  _ <- forkIO $ do
+    updateTasks ts tasksPath
+    threadDelay $ 10 * 60 * (10 ^ (6 :: Int))
+  let context =
+        gitPolyHubKey (return webhookSecret)
+          :. EmptyContext
+      serverData = ServerData
+        { githubAppAuth = auth,
+          githubUserName = GithubUserName githubUsername,
+          githubAccessToken = GithubAccessToken personalAccessToken,
+          tasks = ts,
+          logger = simpleMessageAction,
+          baseUrl = baseSiteUrl
+        }
+      repeatIfNotEmpty n f = f >>= \m -> do
+        when (m == 0) $ liftIO $ threadDelay n
+        repeatIfNotEmpty n f
+  _ <-
+    forkIO . repeatIfNotEmpty (10 ^ (6 :: Int))
+      . usingConnectionPool pool
+      . (`runReaderT` serverData)
+      . unApp
+      $ runTasks @'[Build] 1
+  _ <-
+    forkIO . repeatIfNotEmpty (10 ^ (6 :: Int))
+      . usingConnectionPool pool
+      . (`runReaderT` serverData)
+      . unApp
+      $ runTasks @'[StatusUpdate] 5
+  run port $ serveWithContext (Proxy @API) context $
+    hoistServerWithContext
+      (Proxy @API)
+      (Proxy @'[PolyGitHubKey])
+      (Handler . ExceptT . try . usingConnectionPool pool . (`runReaderT` serverData) . unApp)
+      server
+
+updateTasks :: IORef TasksConfig -> FilePath -> IO ()
+updateTasks ref path =
+  decodeFileEither path >>= \case
+    Right a -> writeIORef ref a
+    Left e -> print e
+
+data ServerData m
+  = ServerData
+      { githubAppAuth :: !InstallationAuth,
+        githubUserName :: !GithubUserName,
+        githubAccessToken :: !GithubAccessToken,
+        tasks :: IORef TasksConfig,
+        logger :: LogAction m Message,
+        baseUrl :: String
+      }
+
+newtype PolyGitHubKey = PolyGitHubKey (forall result. GitHubKey result)
+
+gitPolyHubKey :: IO ByteString -> PolyGitHubKey
+gitPolyHubKey k = PolyGitHubKey (Servant.GitHub.Webhook.gitHubKey k)
+
+instance HasContextEntry '[PolyGitHubKey] (GitHubKey result) where
+  getContextEntry (PolyGitHubKey x :. _) = x
+
+instance MonadReader (ServerData n) m => GithubCloner m where
+
+  getGithubAccessToken = asks githubAccessToken
+
+  getGithubUserName = asks githubUserName
+
+instance (MonadIO m, MonadReader (ServerData n) m) => AppRequestable m where
+  appRequest req = do
+    auth <- asks githubAppAuth
+    liftIO $ executeAppRequest auth req
+
+instance MonadReader (ServerData n) m => MonadHasBaseUrl m where
+  getBaseUrl = asks baseUrl
+
+instance (MonadIO m, MonadReader (ServerData n) m) => HasTasks m where
+  getTasks = asks tasks >>= liftIO . readIORef
+
+type TasksConfig = Map T.Text TaskConfig
+
+data TaskConfig
+  = TaskConfig
+      { prebuild :: String,
+        build :: String
+      }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (FromJSON, ToJSON)
+
+class HasTasks m where
+  getTasks :: m TasksConfig
+
+instance HasLog (ServerData m) Message m where
+
+  getLogAction :: ServerData m -> LogAction m Message
+  getLogAction = logger
+  {-# INLINE getLogAction #-}
+
+  setLogAction :: LogAction m Message -> ServerData m -> ServerData m
+  setLogAction newLogAction env = env {logger = newLogAction}
+  {-# INLINE setLogAction #-}

src/Server/Config.hs

@@ -0,0 +1,56 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Server.Config
+  ( Config (..),
+    getConfig,
+  )
+where
+
+import Crypto.PubKey.RSA (PrivateKey)
+import Crypto.PubKey.RSA.Read
+import Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
+import Data.Maybe
+import GitHub.Data.Apps
+import GitHub.Data.Id
+import GitHub.Data.Installations
+import System.Environment
+
+data Config
+  = Config
+      { webhookSecret :: !ByteString,
+        appId :: !(Id App),
+        appPkPem :: !PrivateKey,
+        port :: !Int,
+        installationId :: !(Id Installation),
+        personalAccessToken :: !String,
+        githubUsername :: !String,
+        tasksPath :: !FilePath,
+        databseUrl :: !ByteString,
+        baseSiteUrl :: !String
+      }
+  deriving (Show)
+
+getConfig :: IO Config
+getConfig =
+  Config
+    <$> (maybe (error "no GITHUB_WEBHOOK_SECRET") BS8.pack <$> lookupEnv "GITHUB_WEBHOOK_SECRET")
+    <*> (maybe (error "no GITHUB_APP_ID") (Id . read) <$> lookupEnv "GITHUB_APP_ID")
+    <*> readPem
+    <*> (maybe 8080 read <$> lookupEnv "PORT")
+    <*> (maybe (error "no GITHUB_INSTALLATION_ID") (Id . read) <$> lookupEnv "GITHUB_INSTALLATION_ID")
+    <*> (fromMaybe (error "no PERSONAL_ACCESS_TOKEN") <$> lookupEnv "PERSONAL_ACCESS_TOKEN")
+    <*> (fromMaybe (error "no GITHUB_USERNAME") <$> lookupEnv "GITHUB_USERNAME")
+    <*> (fromMaybe (error "no TASKS") <$> lookupEnv "TASKS")
+    <*> (maybe (error "no DATABASE_URL") BS8.pack <$> lookupEnv "DATABASE_URL")
+    <*> (fromMaybe "http://localhost:8080" <$> lookupEnv "PORT")
+  where
+    readPem :: IO PrivateKey
+    readPem = do
+      path <- fromMaybe (error "no app pk") <$> lookupEnv "GITHUB_APP_PK"
+      pem <- BS.readFile path
+      case readRsaPem pem of
+        Right k -> return k
+        Left e -> error (show e)
+
+deriving instance Show ReadRsaKeyError

src/Server/Html.hs

@@ -0,0 +1,111 @@
+module Server.Html
+  ( getSubmissionR,
+    MonadHasBaseUrl (..),
+    redirectToSubmission,
+    getUrl,
+  )
+where
+
+import Clay as C
+import Colog
+import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift
+import Data.Aeson hiding (Success)
+import qualified Data.ByteString.Lazy.Char8 as BS
+import qualified Data.Map as M
+import Data.String
+import Data.Submission
+import Data.Submission.Query
+import qualified Data.Text as T
+import GHC.Generics
+import Server.Schema
+import Squeal.PostgreSQL (Jsonb (..))
+import Text.Blaze
+import Text.Blaze.Html
+import Text.Blaze.Html4.Strict.Attributes as A
+import Text.Blaze.Html5 as H
+
+getSubmissionR ::
+  (MonadUnliftIO m, StaticPQ m, WithLog env Message m, MonadHasBaseUrl m) =>
+  String ->
+  String ->
+  String ->
+  m Markup
+getSubmissionR user repo sha = do
+  restartUrl <- (<> "/restart") <$> getUrl (user <> "/" <> repo) sha
+  let restartBuild = do
+        H.form H.! A.action (fromString restartUrl) H.! A.method "post" $
+          H.input H.! A.type_ "submit" H.! A.value "Restart test"
+  (titleText, inner) <- getSubmission (user <> "/" <> repo) sha >>= \case
+    Nothing ->
+      return . ("Not found",) $
+        H.h1 "404. not found. go away."
+    Just Submission {..} -> return . (repo,) $ do
+      H.h1 $ toHtml problem
+      H.h2 $ toHtml userName
+      case status of
+        Jsonb BuildScheduled -> do
+          H.h3 "Waiting to build"
+          restartBuild
+        Jsonb (SubmissionFailed err) -> do
+          H.h3 "Failed to build"
+          restartBuild
+          H.code . H.pre $ toHtml err
+        Jsonb (SubmissionRun (TestResult tests)) -> do
+          let total = M.size tests
+              passed = M.size . M.filter Prelude.id $ tests
+          H.h3 . toHtml $
+            "Tests have run: " <> show passed <> "/" <> show total
+              <> if passed == total then " ✅" else ""
+          restartBuild
+          H.table $ flip M.foldMapWithKey tests $ \testName testPassed -> H.tr $ do
+            (H.td H.! A.align "right") . H.p $ toHtml testName
+            H.td $ if testPassed then "✅" else "❌"
+  return . docTypeHtml $ do
+    H.head $ do
+      H.title $ toHtml titleText
+      H.style . preEscapedToHtml . render $ do
+        C.body ? do
+          fontFamily [] [sansSerif]
+          C.maxWidth (px 800)
+          C.display C.block
+          C.marginLeft auto
+          C.marginRight auto
+          C.paddingLeft (px 16)
+          C.paddingRight (px 16)
+        (C.h1 <> C.h2 <> C.h3) ? do
+          textAlign center
+        C.pre ? do
+          C.whiteSpace C.preWrap
+        C.table ? do
+          C.width (pct 100)
+        (C.tr <> C.td) ? do
+          C.width (pct 50)
+        C.td ? do
+          C.padding (px 4) (px 4) (px 4) (px 4)
+        C.form ? do
+          C.display C.block
+          C.marginLeft auto
+          C.marginRight auto
+    H.body inner
+
+class MonadHasBaseUrl m where
+  getBaseUrl :: m String
+
+getUrl :: (MonadHasBaseUrl m, Monad m) => String -> String -> m String
+getUrl fullName sha = do
+  siteBase <- getBaseUrl
+  return $ siteBase <> "/submission/" <> fullName <> "/" <> sha
+
+redirectToSubmission ::
+  (MonadHasBaseUrl m, Monad m) =>
+  String ->
+  String ->
+  String ->
+  m Markup
+redirectToSubmission user repo sha = do
+  rUrl <- getUrl (user <> "/" <> repo) sha
+  return $ docTypeHtml $ H.head $
+    H.meta
+      H.! A.httpEquiv "refresh"
+      H.! A.content (fromString $ "0; URL=" <> rUrl)

src/Server/Schema.hs

@@ -0,0 +1,18 @@
+module Server.Schema
+  ( StaticPQ,
+    Schema,
+    migration,
+  )
+where
+
+import Server.Schema.V1
+import Squeal.PostgreSQL
+
+type StaticPQ m = MonadPQ Schema m
+
+type Schema = SchemaV1
+
+migration :: AlignedList (Migration (Terminally PQ IO)) (Public '[]) Schema
+migration =
+  pureMigration schemaMigrationV1
+    :>> Done

src/Server/Schema/V1.hs

@@ -0,0 +1,63 @@
+module Server.Schema.V1
+  ( SchemaV1,
+    schemaMigrationV1,
+  )
+where
+
+import Data.Aeson
+import Data.Submission
+import Data.Text (Text)
+import Data.Time
+import Squeal.PostgreSQL
+
+type SchemaV1 =
+  Public
+    '[ "tasks"
+         ::: 'Table
+               ( '[ "pk_task_payload" :=> 'PrimaryKey '["task", "payload"]
+                  ]
+                   :=> '[ "task" ::: 'NoDef :=> 'NotNull (PG Text),
+                          "payload" ::: 'NoDef :=> 'NotNull (PG (Jsonb Value)),
+                          "creation_time" ::: 'Def :=> 'NotNull (PG UTCTime)
+                        ]
+               ),
+       "submissions"
+         ::: 'Table
+               ( '["pk_submission_repo_full_name_sha" :=> 'PrimaryKey '["repo_full_name", "sha"]]
+                   :=> '[ "user_name" ::: 'NoDef :=> 'NotNull (PG String),
+                          "repo_full_name" ::: 'NoDef :=> 'NotNull (PG String),
+                          "problem" ::: 'NoDef :=> 'NotNull (PG String),
+                          "sha" ::: 'NoDef :=> 'NotNull (PG String),
+                          "status" ::: 'NoDef :=> 'NotNull (PG (Jsonb SubmissionStatus))
+                        ]
+               )
+     ]
+
+schemaMigrationV1 :: Migration Definition (Public '[]) SchemaV1
+schemaMigrationV1 = Migration
+  { name = "v1",
+    up =
+      createTable
+        #tasks
+        ( notNullable text `as` #task
+            :* notNullable jsonb `as` #payload
+            :* default_ now (notNullable timestampWithTimeZone) `as` #creation_time
+        )
+        (primaryKey (#task :* #payload) `as` #pk_task_payload)
+        >>> createTable
+          #submissions
+          ( notNullable text `as` #user_name
+              :* notNullable text `as` #repo_full_name
+              :* notNullable text `as` #problem
+              :* notNullable text `as` #sha
+              :* notNullable jsonb `as` #status
+          )
+          (primaryKey (#repo_full_name :* #sha) `as` #pk_submission_repo_full_name_sha)
+        >>> createIndexes,
+    down = dropTable #tasks >>> dropTable #submissions
+  }
+  where
+    createIndexes :: Definition sch sch
+    createIndexes =
+      UnsafeDefinition
+        "CREATE INDEX ON tasks (creation_time);"

stack.yaml

@@ -0,0 +1,75 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver: lts-14.19
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+#   subdirs:
+#   - auto-update
+#   - wai
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver.
+# These entries can reference officially published versions as well as
+# forks / in-progress versions pinned to a git hash. For example:
+#
+# extra-deps:
+# - acme-missiles-0.3
+# - git: https://github.com/commercialhaskell/stack.git
+#   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#
+extra-deps:
+- github-0.24
+- binary-instances-1
+- squeal-postgresql-0.5.2.0
+- git: https://github.com/ilyakooo0/github-app
+  commit: 0bede85ab53eb8f953cf6f4e58a756a205e88e0b
+- servant-github-webhook-0.4.2.0
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=2.1"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor
+
+ghc-options:
+  "$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