master..08b0dd2 · sc-build

app/Main.hs+6−23

@@ -1,30 +1,13 @@

11module Main (main) where

22

33import qualified Data.ByteString.Char8 as BS

4−import Data.Yaml (encode)

5−import Options.Applicative

4+import Data.Yaml

65import Server

76import Server.Config

7+import System.Environment

88

99main :: IO ()

10−main =

11− execParser (info (getOptions <**> helper) fullDesc) >>= \case

12− PrintDefaultConfig -> putStrLn . BS.unpack . encode $ defaultConfig

13− RunServer config -> runServer config

14−

15−data Run

16− = PrintDefaultConfig

17− | RunServer FilePath

18−

19−getOptions :: Parser Run

20−getOptions =

21− subparser

22− ( command "default" (info (pure PrintDefaultConfig <**> helper) fullDesc)

23− )

24− <|> ( RunServer

25− <$> strOption

26− ( long "config"

27− <> help "Path to yaml config file."

28− <> value "config.yaml"

29− )

30− )

10+main = getArgs >>= \case

11+ [] -> runServer

12+ ["default"] -> putStrLn . BS.unpack . encode $ defaultConfig

13+ xs -> error . show $ xs

package.yaml−2

@@ -52,7 +52,6 @@ library:

5252 - transformers

5353 - cassava

5454 - http-media

55− - utf8-string

5655

5756executables:

5857 sc-build-exe:

@@ -66,7 +65,6 @@ executables:

6665 - sc-build

6766 - bytestring

6867 - yaml

69− - optparse-applicative

7068 sc-build-migrations:

7169 main: Main.hs

7270 source-dirs: migrations

src/Control/HasGithubStatus.hs−1

@@ -11,4 +11,3 @@ class HasGithubStatus m where

1111 schedulePendingStatus :: WithLog env Message m => Name Owner -> Name Repo -> Name Commit -> m ()

1212 scheduleTestedStatus :: WithLog env Message m => TestResult -> Name Owner -> Name Repo -> Name Commit -> m ()

1313 scheduleFailedStatus :: WithLog env Message m => String -> Name Owner -> Name Repo -> Name Commit -> m ()

14− deadlineHasPassedStatus :: WithLog env Message m => Name Owner -> Name Repo -> Name Commit -> m ()

src/Control/Task/Scheduler.hs+1−4

@@ -21,7 +21,6 @@ import Data.Word

2121import GHC.TypeLits

2222import Server.Schema

2323import Squeal.PostgreSQL

24−import UnliftIO.Exception

2524

2625scheduleTask ::

2726 (StaticPQ m, WithLog env Message m, Task t s, MonadUnliftIO m) =>

@@ -67,9 +66,7 @@ instance

6766 <> e

6867 A.Success t -> do

6968 logInfo . T.pack $ "running task " <> task <> " with " <> show t <> " created at " <> show initialStartTime

70− r <- performTask @t @ts @m t `catchAny` \e -> do

71− logError . T.pack . displayException $ e

72− return Failure

69+ r <- performTask @t @ts @m t

7370 when (r == Failure) $ logWarning . T.pack $ "Task " <> task <> " failed"

7471 case r of

7572 Success -> completeTaskQuery t

src/Control/Task/Scheduler/Query.hs+1−6

@@ -41,7 +41,6 @@ scheduleTaskQuery task = do

4141 :* Set (param @2) `as` #payload

4242 :* Default `as` #creation_time

4343 :* Default `as` #started

44− :* Default `as` #failures

4544 )

4645 ( OnConflict

4746 (OnConstraint #pk_task_payload)

@@ -88,7 +87,6 @@ rescheduleTaskQuery payload = do

8887 #tasks

8988 ( Default `as` #creation_time

9089 :* Default `as` #started

91− :* Set (#failures + 1) `as` #failures

9290 )

9391 (param @1 .== #task .&& param @2 .== #payload)

9492 dbWrite (const $ return ()) $

@@ -103,7 +101,7 @@ pickTasksQuery ::

103101 Word64 ->

104102 m [PickedTask]

105103pickTasksQuery tasks limitCount = do

106− logDebug $ "reading tasks " <> T.unwords (T.pack <$> tasks)

104+ logDebug "reading tasks"

107105 let query :: Query_ Schema () PickedTask

108106 query =

109107 select_

@@ -114,10 +112,7 @@ pickTasksQuery tasks limitCount = do

114112 ( from (table #tasks)

115113 & where_ (#task `in_` (literal <$> tasks))

116114 & where_ (not_ . notNull $ #started)

117− & where_ (#failures .< 20)

118− & orderBy [#creation_time & Asc]

119115 & limit limitCount

120− & orderBy [#creation_time & Desc]

121116 )

122117 startedMan :: Manipulation_ Schema (String, Jsonb Value) ()

123118 startedMan =

src/Data/Submission.hs−1

@@ -29,7 +29,6 @@ data SubmissionStatus

2929 = SubmissionRun TestResult

3030 | SubmissionFailed String

3131 | BuildScheduled

32− | PastDeadline

3332 deriving (Generic, FromJSON, ToJSON, Eq, Show)

3433

3534newtype TestResult

src/Data/Tasks/Build.hs+8−20

@@ -16,7 +16,6 @@ import Control.Monad.IO.Unlift

1616import Control.Task

1717import Data.Aeson hiding (Success)

1818import qualified Data.ByteString.Lazy.Char8 as BS

19−import qualified Data.ByteString.Lazy.UTF8 as BS

2019import Data.String

2120import Data.Submission

2221import Data.Submission.Query

@@ -55,7 +54,7 @@ instance Task Build "build-repo" where

5554 (shellCode, _, shellErr) <- readProcess . setWorkingDir dir $ shell preProcessShell

5655 case shellCode of

5756 ExitFailure n -> do

58− let err = BS.toString shellErr

57+ let err = BS.unpack shellErr

5958 logError . T.pack $

6059 "preprocessing command for repo " <> show fullRepoName <> " at sha "

6160 <> show sha

@@ -91,7 +90,7 @@ instance Task Build "build-repo" where

9190 ExceptT $ D.buildImageFromDockerfile (D.defaultBuildOpts imageName) absDir

9291 ExceptT $ D.createContainer opts Nothing

9392 dockerRes <- fmap (either id id)

94− . race (liftIO (threadDelay (timeoutMinutes * 60000000)) >> return (ExitFailure 1, "Time out", "Time out"))

93+ . race (liftIO (threadDelay (timeoutMinutes * 60000000)) >> return (ExitFailure 1, "Time out"))

9594 $ flip

9695 finally

9796 ( runDocker $

@@ -115,21 +114,10 @@ instance Task Build "build-repo" where

115114 tail = D.All

116115 }

117116 cid

118− buildErr <-

119− ExceptT $

120− D.getContainerLogs

121− D.LogOpts

122− { stdout = True,

123− stderr = True,

124− since = Nothing,

125− timestamps = False,

126− tail = D.All

127− }

128− cid

129− return (buildCode, buildOut, buildErr)

117+ return (buildCode, buildOut)

130118 case dockerRes of

131− (ExitFailure n, _, buildErr) -> do

132− let err = BS.toString buildErr

119+ (ExitFailure n, buildOut) -> do

120+ let err = BS.unpack buildOut

133121 logError . T.pack $

134122 "test command for repo " <> show fullRepoName <> " at sha "

135123 <> show sha

@@ -139,10 +127,10 @@ instance Task Build "build-repo" where

139127 <> err

140128 scheduleFailedStatus err owner repoName sha

141129 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

142− (ExitSuccess, buildOut, _) ->

130+ (ExitSuccess, buildOut) ->

143131 case eitherDecode' (BS.dropWhile (/= '{') buildOut) of

144132 Left err' -> do

145− let err = err' <> " " <> BS.toString buildOut

133+ let err = err' <> " " <> BS.unpack buildOut

146134 logError . T.pack $

147135 "could not decode test result from repo " <> show fullRepoName

148136 <> " at sha "

@@ -150,7 +138,7 @@ instance Task Build "build-repo" where

150138 <> ": "

151139 <> err

152140 scheduleFailedStatus err owner repoName sha

153− updateSubmissionStatus fullRepoName sha' (SubmissionFailed (err <> BS.toString buildOut))

141+ updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

154142 Right testResult@TestResult {..} -> do

155143 scheduleTestedStatus testResult owner repoName sha

156144 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

src/Server.hs+25−55

@@ -30,7 +30,6 @@ import Data.Submission.Query

3030import Data.Tasks.Build

3131import Data.Tasks.StatusUpdate

3232import qualified Data.Text as T

33−import Data.Time.Clock

3433import Data.Yaml

3534import GHC.Generics

3635import GitHub hiding (Accept)

@@ -50,6 +49,7 @@ import Server.Config

5049import Server.Html

5150import Server.Schema

5251import Squeal.PostgreSQL

52+import System.IO

5353import Text.Blaze.Html

5454import UnliftIO.Exception (catch, displayException, handleAny, throwIO, try)

5555

@@ -75,18 +75,14 @@ type API =

7575 :> Post '[HTML] Markup

7676 :<|> "results" :> Capture "task name" String :> Get '[CSV, HTML] [Score]

7777

78−webhookInstallation :: WithLog env Message m => RepoWebhookEvent -> ((), InstallationEvent) -> m ()

78+webhookInstallation :: MonadIO m => RepoWebhookEvent -> ((), InstallationEvent) -> m ()

7979webhookInstallation _ ((), ev) =

80− logInfo . T.pack . show $ ev

80+ liftIO $ do

81+ print ev

82+ hFlush stdout

8183

8284webhookPushEvent ::

83− ( StaticPQ m,

84− MonadReader (ServerData m) m,

85− MonadUnliftIO m,

86− HasTasks m,

87− MonadError ServerError m,

88− WithLog env Message m

89− ) =>

85+ (StaticPQ m, MonadReader (ServerData m) m, MonadUnliftIO m, HasTasks m, MonadError ServerError m) =>

9086 RepoWebhookEvent ->

9187 ((), PushEvent) ->

9288 m ()

@@ -104,28 +100,18 @@ webhookPushEvent _ ((), ev) = do

104100 M.takeWhileAntitone (repoName >) tasks

105101 case task of

106102 Just (name, TaskConfig {..}) | T.take (T.length name) repoName == name -> do

107− nowTime <- liftIO getCurrentTime

108− if nowTime > deadline

109− then do

110− deadlineHasPassedStatus (N owner) (N repoName) (N sha)

111− createSubmission $

112− Submission

113− user

114− (T.unpack fullRepoName)

115− (T.unpack name)

116− (T.unpack sha)

117− (Jsonb PastDeadline)

118− else do

119− schedulePendingStatus (N owner) (N repoName) (N sha)

120− createSubmission $

121− Submission

122− user

123− (T.unpack fullRepoName)

124− (T.unpack name)

125− (T.unpack sha)

126− (Jsonb BuildScheduled)

127− scheduleTask $ Build prebuild dockerfile (N owner) (N repoName) (N sha) timeoutMinutes

128− logInfo . T.pack . show $ ev

103+ schedulePendingStatus (N owner) (N repoName) (N sha)

104+ createSubmission $

105+ Submission

106+ user

107+ (T.unpack fullRepoName)

108+ (T.unpack name)

109+ (T.unpack sha)

110+ (Jsonb BuildScheduled)

111+ scheduleTask $ Build prebuild dockerfile (N owner) (N repoName) (N sha) timeoutMinutes

112+ liftIO $ do

113+ print ev

114+ hFlush stdout

129115 _ -> return ()

130116

131117retestSubmission ::

@@ -175,9 +161,9 @@ instance MonadError ServerError (ServerM schema) where

175161server :: ServerT API (ServerM Schema)

176162server = (webhookInstallation :<|> webhookPushEvent) :<|> getSubmissionR :<|> retestSubmission :<|> getResults

177163

178−runServer :: FilePath -> IO ()

179−runServer config = do

180− c@Config {..} <- getConfig config

164+runServer :: IO ()

165+runServer = do

166+ c@Config {..} <- getConfig

181167 print c

182168 pem <- BS.readFile appPkPemPath

183169 appPkPem <- case readRsaPem pem of

@@ -292,7 +278,7 @@ instance (MonadReader (ServerData m) m, StaticPQ m, MonadUnliftIO m) => HasGithu

292278 ( NewStatus

293279 StatusPending

294280 (Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha)

295− (Just "⌛")

281+ Nothing

296282 (Just c)

297283 )

298284 scheduleTestedStatus TestResult {..} nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do

@@ -300,7 +286,7 @@ instance (MonadReader (ServerData m) m, StaticPQ m, MonadUnliftIO m) => HasGithu

300286 c <- asks context

301287 let total = M.size tests

302288 passed = M.size . M.filter id $ tests

303− description = T.pack $ show passed <> "/" <> show total <> if passed == total then " ✅" else " ❌"

289+ description = T.pack $ show passed <> "/" <> show total

304290 status =

305291 StatusUpdate

306292 nOwner

@@ -325,22 +311,7 @@ instance (MonadReader (ServerData m) m, StaticPQ m, MonadUnliftIO m) => HasGithu

325311 NewStatus

326312 { newStatusState = StatusError,

327313 newStatusTargetUrl = Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha,

328− newStatusDescription = Just "Build failed ☠️",

329− newStatusContext = Just c

330− }

331− scheduleTask status

332− deadlineHasPassedStatus nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do

333− h <- asks baseUrl

334− c <- asks context

335− let status =

336− StatusUpdate

337− nOwner

338− nRepo

339− nCommit

340− NewStatus

341− { newStatusState = StatusError,

342− newStatusTargetUrl = Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha,

343− newStatusDescription = Just "The deadline has passed ⏰",

314+ newStatusDescription = Just "Build failed",

344315 newStatusContext = Just c

345316 }

346317 scheduleTask status

@@ -354,8 +325,7 @@ data TaskConfig

354325 = TaskConfig

355326 { prebuild :: String,

356327 dockerfile :: String,

357− timeoutMinutes :: Int,

358− deadline :: UTCTime

328+ timeoutMinutes :: Int

359329 }

360330 deriving stock (Show, Eq, Generic)

361331 deriving anyclass (FromJSON, ToJSON)

src/Server/Config.hs+4−2

@@ -30,6 +30,7 @@ data Config

3030 databseUrl :: !ByteString,

3131 baseSiteUrl :: !Text,

3232 cfgDockerUrl :: !String,

33+ cfgDockerFile :: !FilePath,

3334 logSeverity :: !Severity,

3435 builderCount :: !Int,

3536 githubContext :: !Text

@@ -66,13 +67,14 @@ defaultConfig =

6667 databseUrl = "host=localhost port=5432 dbname=sc-build connect_timeout=10",

6768 baseSiteUrl = "http://localhost:8080",

6869 cfgDockerUrl = "http://localhost:1234",

70+ cfgDockerFile = "TmpDockerfile",

6971 logSeverity = Info,

7072 builderCount = 2,

7173 githubContext = "MY CI NAME"

7274 }

7375

74−getConfig :: FilePath -> IO Config

75−getConfig = decodeFileThrow

76+getConfig :: IO Config

77+getConfig = decodeFileThrow "config.yaml"

7678

7779-- getConfig :: IO Config

7880-- getConfig =

src/Server/Html.hs+4−7

@@ -39,16 +39,15 @@ getSubmissionR user repo sha' = do

3939 Nothing ->

4040 return . ("Not found",) $

4141 H.h1 "404. not found. go away."

42− Just Submission {..} -> return . (problem,) $ do

42+ Just Submission {..} -> return . (repo,) $ do

4343 H.h1 $ toHtml problem

4444 H.h2 $ toHtml userName

45− H.h3 . H.code . toHtml . take 7 $ sha

4645 case status of

4746 Jsonb BuildScheduled -> do

48− H.h3 "Waiting to build ⌛"

47+ H.h3 "Waiting to build"

4948 restartBuild

5049 Jsonb (SubmissionFailed err) -> do

51− H.h3 "Failed to build ☠️"

50+ H.h3 "Failed to build"

5251 restartBuild

5352 H.code . H.pre $ toHtml err

5453 Jsonb (SubmissionRun (TestResult tests)) -> do

@@ -56,13 +55,11 @@ getSubmissionR user repo sha' = do

5655 passed = M.size . M.filter Prelude.id $ tests

5756 H.h3 . toHtml $

5857 "Tests have run: " <> show passed <> "/" <> show total

59− <> if passed == total then " 🎉" else " 🍌"

58+ <> if passed == total then " ✅" else ""

6059 restartBuild

6160 H.table $ flip M.foldMapWithKey tests $ \testName testPassed -> H.tr $ do

6261 (H.td H.! A.align "right") . H.p $ toHtml testName

6362 H.td $ if testPassed then "✅" else "❌"

64− Jsonb PastDeadline ->

65− H.h3 "This was submitted after the deadline ⏰"

6663 return . docTypeHtml $ do

6764 H.head $ do

6865 H.title $ toHtml titleText

src/Server/Schema.hs+1−3

@@ -6,15 +6,13 @@ module Server.Schema

66where

77

88import Server.Schema.V1

9−import Server.Schema.V2

109import Squeal.PostgreSQL

1110

1211type StaticPQ m = MonadPQ Schema m

1312

14−type Schema = SchemaV2

13+type Schema = SchemaV1

1514

1615migration :: AlignedList (Migration (Terminally PQ IO)) (Public '[]) Schema

1716migration =

1817 pureMigration schemaMigrationV1

19− :>> pureMigration schemaMigrationV2

2018 :>> Done

src/Server/Schema/V2.hsdeleted−46

@@ -1,46 +0,0 @@

1−module Server.Schema.V2

2− ( SchemaV2,

3− schemaMigrationV2,

4− )

5−where

6−

7−import Data.Aeson

8−import Data.Int

9−import Data.Submission

10−import Data.Text (Text)

11−import Data.Time

12−import Server.Schema.V1

13−import Squeal.PostgreSQL

14−

15−type SchemaV2 =

16− Public

17− '[ "tasks"

18− ::: 'Table

19− ( '[ "pk_task_payload" :=> 'PrimaryKey '["task", "payload"]

20− ]

21− :=> '[ "task" ::: 'NoDef :=> 'NotNull (PG Text),

22− "payload" ::: 'NoDef :=> 'NotNull (PG (Jsonb Value)),

23− "creation_time" ::: 'Def :=> 'NotNull (PG UTCTime),

24− "started" ::: 'Def :=> 'NotNull (PG Bool),

25− "failures" ::: 'Def :=> 'NotNull (PG Int32)

26− ]

27− ),

28− "submissions"

29− ::: 'Table

30− ( '["pk_submission_repo_full_name_sha" :=> 'PrimaryKey '["repo_full_name", "sha"]]

31− :=> '[ "user_name" ::: 'NoDef :=> 'NotNull (PG String),

32− "repo_full_name" ::: 'NoDef :=> 'NotNull (PG String),

33− "problem" ::: 'NoDef :=> 'NotNull (PG String),

34− "sha" ::: 'NoDef :=> 'NotNull (PG String),

35− "status" ::: 'NoDef :=> 'NotNull (PG (Jsonb SubmissionStatus))

36− ]

37− )

38− ]

39−

40−schemaMigrationV2 :: Migration Definition SchemaV1 SchemaV2

41−schemaMigrationV2 =

42− Migration

43− { name = "v2",

44− up = alterTable #tasks (addColumn #failures (default_ 0 $ notNullable int)),

45− down = alterTable #tasks (dropColumn #failures)

46− }

stack.yaml+1−2

@@ -46,9 +46,8 @@ extra-deps:

4646- git: https://github.com/ilyakooo0/github-app

4747 commit: 0bede85ab53eb8f953cf6f4e58a756a205e88e0b

4848- servant-github-webhook-0.4.2.0

49+- docker-0.6.0.3

4950- http-client-0.5.14

50−- git: https://github.com/ilyakooo0/docker-hs

51− commit: 5cfdc4d7facd7043f530bce4ce0f0c57c923b029

5251

5352# Override default flag values for local packages and extra-deps

5453# flags: {}