From 33713bd3071c1d28b7e4dde35f0f6f638c0d9bff Mon Sep 17 00:00:00 2001 From: iko Date: Sat, 11 Jan 2020 15:19:07 +0300 Subject: [PATCH] Initial working commit --- .gitignore | 1 + LICENSE | 2 +- Setup.hs | 2 + app/Main.hs | 6 + hie.yaml | 4 + migrations/Main.hs | 14 ++ package.yaml | 102 +++++++++++ sc-build.cabal | 103 +++++++++++ src/Control/AppRequestable.hs | 10 ++ src/Control/GithubCloner.hs | 16 ++ src/Control/Squeal.hs | 81 +++++++++ src/Control/Task.hs | 26 +++ src/Control/Task/Scheduler.hs | 86 ++++++++++ src/Control/Task/Scheduler/Query.hs | 121 +++++++++++++ src/Data/Submission.hs | 36 ++++ src/Data/Submission/Query.hs | 85 +++++++++ src/Data/Tasks/Build.hs | 133 +++++++++++++++ src/Data/Tasks/StatusUpdate.hs | 41 +++++ src/Server.hs | 256 ++++++++++++++++++++++++++++ src/Server/Config.hs | 56 ++++++ src/Server/Html.hs | 111 ++++++++++++ src/Server/Schema.hs | 18 ++ src/Server/Schema/V1.hs | 63 +++++++ stack.yaml | 75 ++++++++ 24 files changed, 1447 insertions(+), 1 deletion(-) create mode 100644 .gitignore create mode 100644 Setup.hs create mode 100644 app/Main.hs create mode 100644 hie.yaml create mode 100644 migrations/Main.hs create mode 100644 package.yaml create mode 100644 sc-build.cabal create mode 100644 src/Control/AppRequestable.hs create mode 100644 src/Control/GithubCloner.hs create mode 100644 src/Control/Squeal.hs create mode 100644 src/Control/Task.hs create mode 100644 src/Control/Task/Scheduler.hs create mode 100644 src/Control/Task/Scheduler/Query.hs create mode 100644 src/Data/Submission.hs create mode 100644 src/Data/Submission/Query.hs create mode 100644 src/Data/Tasks/Build.hs create mode 100644 src/Data/Tasks/StatusUpdate.hs create mode 100644 src/Server.hs create mode 100644 src/Server/Config.hs create mode 100644 src/Server/Html.hs create mode 100644 src/Server/Schema.hs create mode 100644 src/Server/Schema/V1.hs create mode 100644 stack.yaml diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..8ee1bf9 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +.stack-work diff --git a/LICENSE b/LICENSE index 5731e1e..4891138 100644 --- a/LICENSE +++ b/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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..927e3a9 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Server + +main :: IO () +main = runServer diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000..4c90f71 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,4 @@ +cradle: + stack: + - path: "." + component: "sc-build:lib" diff --git a/migrations/Main.hs b/migrations/Main.hs new file mode 100644 index 0000000..be4ec24 --- /dev/null +++ b/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 diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..2a39fee --- /dev/null +++ b/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 diff --git a/sc-build.cabal b/sc-build.cabal new file mode 100644 index 0000000..f5adc11 --- /dev/null +++ b/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 diff --git a/src/Control/AppRequestable.hs b/src/Control/AppRequestable.hs new file mode 100644 index 0000000..2ad8709 --- /dev/null +++ b/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) diff --git a/src/Control/GithubCloner.hs b/src/Control/GithubCloner.hs new file mode 100644 index 0000000..5186009 --- /dev/null +++ b/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 diff --git a/src/Control/Squeal.hs b/src/Control/Squeal.hs new file mode 100644 index 0000000..2d6ee09 --- /dev/null +++ b/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) diff --git a/src/Control/Task.hs b/src/Control/Task.hs new file mode 100644 index 0000000..db3fe2f --- /dev/null +++ b/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 diff --git a/src/Control/Task/Scheduler.hs b/src/Control/Task/Scheduler.hs new file mode 100644 index 0000000..9ac8199 --- /dev/null +++ b/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 = [] diff --git a/src/Control/Task/Scheduler/Query.hs b/src/Control/Task/Scheduler/Query.hs new file mode 100644 index 0000000..7ac3b7d --- /dev/null +++ b/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) diff --git a/src/Data/Submission.hs b/src/Data/Submission.hs new file mode 100644 index 0000000..0e6a9dc --- /dev/null +++ b/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) diff --git a/src/Data/Submission/Query.hs b/src/Data/Submission/Query.hs new file mode 100644 index 0000000..0b6cd3d --- /dev/null +++ b/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 diff --git a/src/Data/Tasks/Build.hs b/src/Data/Tasks/Build.hs new file mode 100644 index 0000000..5975ea0 --- /dev/null +++ b/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 diff --git a/src/Data/Tasks/StatusUpdate.hs b/src/Data/Tasks/StatusUpdate.hs new file mode 100644 index 0000000..195e0f1 --- /dev/null +++ b/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 diff --git a/src/Server.hs b/src/Server.hs new file mode 100644 index 0000000..c285744 --- /dev/null +++ b/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 #-} diff --git a/src/Server/Config.hs b/src/Server/Config.hs new file mode 100644 index 0000000..338f3f6 --- /dev/null +++ b/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 diff --git a/src/Server/Html.hs b/src/Server/Html.hs new file mode 100644 index 0000000..18ef200 --- /dev/null +++ b/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) diff --git a/src/Server/Schema.hs b/src/Server/Schema.hs new file mode 100644 index 0000000..45656c3 --- /dev/null +++ b/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 diff --git a/src/Server/Schema/V1.hs b/src/Server/Schema/V1.hs new file mode 100644 index 0000000..b83f21f --- /dev/null +++ b/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);" diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..ddb92a9 --- /dev/null +++ b/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