232979d...master · sc-build

app/Main.hs+23−6

since splitsnapshots

unifiedsplit

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

1module Main (main) where

2

3import qualified Data.ByteString.Char8 as BS

4−import Data.Yaml

4+import Data.Yaml (encode)

5+import Options.Applicative

5import Server

6import Server

6import Server.Config

7import Server.Config

7−import System.Environment

8

9main :: IO ()

10−main = getArgs >>= \case

10+main =

11− [] -> runServer

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

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

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

13− xs -> error . show $ xs

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+ )

package.yaml+2

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

52 - transformers

53 - cassava

54 - http-media

55+ - utf8-string

55

56

56executables:

57executables:

57 sc-build-exe:

58 sc-build-exe:

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

65 - sc-build

66 - sc-build

66 - bytestring

67 - bytestring

67 - yaml

68 - yaml

69+ - optparse-applicative

68 sc-build-migrations:

70 sc-build-migrations:

69 main: Main.hs

71 main: Main.hs

70 source-dirs: migrations

72 source-dirs: migrations

src/Control/HasGithubStatus.hs+1

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

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

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

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

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

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

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

21import GHC.TypeLits

22import Server.Schema

23import Squeal.PostgreSQL

24+import UnliftIO.Exception

24

25

25scheduleTask ::

26scheduleTask ::

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

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

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

66 <> e

67 <> e

67 A.Success t -> do

68 A.Success t -> do

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

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

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

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

71+ logError . T.pack . displayException $ e

72+ return Failure

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

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

71 case r of

74 case r of

72 Success -> completeTaskQuery t

75 Success -> completeTaskQuery t

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

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

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

42 :* Default `as` #creation_time

43 :* Default `as` #started

44+ :* Default `as` #failures

44 )

45 )

45 ( OnConflict

46 ( OnConflict

46 (OnConstraint #pk_task_payload)

47 (OnConstraint #pk_task_payload)

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

87 #tasks

88 #tasks

88 ( Default `as` #creation_time

89 ( Default `as` #creation_time

89 :* Default `as` #started

90 :* Default `as` #started

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

90 )

92 )

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

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

92 dbWrite (const $ return ()) $

94 dbWrite (const $ return ()) $

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

101 Word64 ->

103 Word64 ->

102 m [PickedTask]

104 m [PickedTask]

103pickTasksQuery tasks limitCount = do

105pickTasksQuery tasks limitCount = do

104− logDebug "reading tasks"

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

105 let query :: Query_ Schema () PickedTask

107 let query :: Query_ Schema () PickedTask

106 query =

108 query =

107 select_

109 select_

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

112 ( from (table #tasks)

114 ( from (table #tasks)

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

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

114 & where_ (not_ . notNull $ #started)

116 & where_ (not_ . notNull $ #started)

117+ & where_ (#failures .< 20)

118+ & orderBy [#creation_time & Asc]

115 & limit limitCount

119 & limit limitCount

120+ & orderBy [#creation_time & Desc]

116 )

121 )

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

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

118 startedMan =

123 startedMan =

src/Data/Submission.hs+1

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

29 = SubmissionRun TestResult

30 | SubmissionFailed String

31 | BuildScheduled

32+ | PastDeadline

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

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

33

34

34newtype TestResult

35newtype TestResult

src/Data/Tasks/Build.hs+5−5

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

16import Control.Task

17import Data.Aeson hiding (Success)

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

19−import Data.Char

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

20import Data.String

21import Data.Submission

22import Data.Submission.Query

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

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

56 case shellCode of

57 ExitFailure n -> do

58− let err = BS.unpack shellErr

58+ let err = BS.toString shellErr

59 logError . T.pack $

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

61 <> show sha

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

129 return (buildCode, buildOut, buildErr)

130 case dockerRes of

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

132− let err = filter isPrint . BS.unpack $ buildErr

132+ let err = BS.toString buildErr

133 logError . T.pack $

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

135 <> show sha

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

142 (ExitSuccess, buildOut, _) ->

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

144 Left err' -> do

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

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

146 logError . T.pack $

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

148 <> " at sha "

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

150 <> ": "

151 <> err

152 scheduleFailedStatus err owner repoName sha

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

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

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

155 scheduleTestedStatus testResult owner repoName sha

156 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

src/Server.hs+55−25

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

30import Data.Tasks.Build

31import Data.Tasks.StatusUpdate

32import qualified Data.Text as T

33+import Data.Time.Clock

33import Data.Yaml

34import Data.Yaml

34import GHC.Generics

35import GHC.Generics

35import GitHub hiding (Accept)

36import GitHub hiding (Accept)

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

49import Server.Html

50import Server.Html

50import Server.Schema

51import Server.Schema

51import Squeal.PostgreSQL

52import Squeal.PostgreSQL

52−import System.IO

53import Text.Blaze.Html

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

55

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

75 :> Post '[HTML] Markup

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

77

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

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

79webhookInstallation _ ((), ev) =

80− liftIO $ do

80+ logInfo . T.pack . show $ ev

81− print ev

82− hFlush stdout

83

81

84webhookPushEvent ::

82webhookPushEvent ::

83+ ( StaticPQ m,

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

84+ MonadReader (ServerData m) m,

85+ MonadUnliftIO m,

86+ HasTasks m,

87+ MonadError ServerError m,

88+ WithLog env Message m

89+ ) =>

86 RepoWebhookEvent ->

90 RepoWebhookEvent ->

87 ((), PushEvent) ->

91 ((), PushEvent) ->

88 m ()

92 m ()

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

100 M.takeWhileAntitone (repoName >) tasks

104 M.takeWhileAntitone (repoName >) tasks

101 case task of

105 case task of

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

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

107+ nowTime <- liftIO getCurrentTime

108+ if nowTime > deadline

109+ then do

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

111+ createSubmission $

112+ Submission

113+ user

114+ (T.unpack fullRepoName)

115+ (T.unpack name)

116+ (T.unpack sha)

117+ (Jsonb PastDeadline)

118+ else do

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

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

104− createSubmission $

120+ createSubmission $

105− Submission

121+ Submission

106− user

122+ user

107− (T.unpack fullRepoName)

123+ (T.unpack fullRepoName)

108− (T.unpack name)

124+ (T.unpack name)

109− (T.unpack sha)

125+ (T.unpack sha)

110− (Jsonb BuildScheduled)

126+ (Jsonb BuildScheduled)

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

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

112− liftIO $ do

128+ logInfo . T.pack . show $ ev

113− print ev

114− hFlush stdout

115 _ -> return ()

129 _ -> return ()

116

130

117retestSubmission ::

131retestSubmission ::

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

161server :: ServerT API (ServerM Schema)

175server :: ServerT API (ServerM Schema)

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

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

163

177

164−runServer :: IO ()

178+runServer :: FilePath -> IO ()

165−runServer = do

179+runServer config = do

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

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

167 print c

181 print c

168 pem <- BS.readFile appPkPemPath

182 pem <- BS.readFile appPkPemPath

169 appPkPem <- case readRsaPem pem of

183 appPkPem <- case readRsaPem pem of

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

278 ( NewStatus

292 ( NewStatus

279 StatusPending

293 StatusPending

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

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

281− Nothing

295+ (Just "⌛")

282 (Just c)

296 (Just c)

283 )

297 )

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

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

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

286 c <- asks context

300 c <- asks context

287 let total = M.size tests

301 let total = M.size tests

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

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

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

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

290 status =

304 status =

291 StatusUpdate

305 StatusUpdate

292 nOwner

306 nOwner

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

311 NewStatus

325 NewStatus

312 { newStatusState = StatusError,

326 { newStatusState = StatusError,

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

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

314− newStatusDescription = Just "Build failed",

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 ⏰",

315 newStatusContext = Just c

344 newStatusContext = Just c

316 }

345 }

317 scheduleTask status

346 scheduleTask status

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

325 = TaskConfig

354 = TaskConfig

326 { prebuild :: String,

355 { prebuild :: String,

327 dockerfile :: String,

356 dockerfile :: String,

328− timeoutMinutes :: Int

357+ timeoutMinutes :: Int,

358+ deadline :: UTCTime

329 }

359 }

330 deriving stock (Show, Eq, Generic)

360 deriving stock (Show, Eq, Generic)

331 deriving anyclass (FromJSON, ToJSON)

361 deriving anyclass (FromJSON, ToJSON)

src/Server/Config.hs+2−2

@@ -71,8 +71,8 @@ defaultConfig =

71 githubContext = "MY CI NAME"

72 }

73

74−getConfig :: IO Config

74+getConfig :: FilePath -> IO Config

75−getConfig = decodeFileThrow "config.yaml"

75+getConfig = decodeFileThrow

76

77-- getConfig :: IO Config

78-- getConfig =

src/Server/Html.hs+7−4

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

39 Nothing ->

40 return . ("Not found",) $

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

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

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

43 H.h1 $ toHtml problem

44 H.h2 $ toHtml userName

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

45 case status of

46 case status of

46 Jsonb BuildScheduled -> do

47 Jsonb BuildScheduled -> do

47− H.h3 "Waiting to build"

48+ H.h3 "Waiting to build ⌛"

48 restartBuild

49 restartBuild

49 Jsonb (SubmissionFailed err) -> do

50 Jsonb (SubmissionFailed err) -> do

50− H.h3 "Failed to build"

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

51 restartBuild

52 restartBuild

52 H.code . H.pre $ toHtml err

53 H.code . H.pre $ toHtml err

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

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

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

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

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

56 H.h3 . toHtml $

57 H.h3 . toHtml $

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

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

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

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

59 restartBuild

60 restartBuild

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

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

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

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

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

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

64+ Jsonb PastDeadline ->

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

63 return . docTypeHtml $ do

66 return . docTypeHtml $ do

64 H.head $ do

67 H.head $ do

65 H.title $ toHtml titleText

68 H.title $ toHtml titleText

src/Server/Schema.hs+3−1

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

6where

7

8import Server.Schema.V1

9+import Server.Schema.V2

9import Squeal.PostgreSQL

10import Squeal.PostgreSQL

10

11

11type StaticPQ m = MonadPQ Schema m

12type StaticPQ m = MonadPQ Schema m

12

13

13−type Schema = SchemaV1

14+type Schema = SchemaV2

14

15

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

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

16migration =

17migration =

17 pureMigration schemaMigrationV1

18 pureMigration schemaMigrationV1

19+ :>> pureMigration schemaMigrationV2

18 :>> Done

20 :>> Done

src/Server/Schema/V2.hsnew file+46

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

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+2−1

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

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

47 commit: 0bede85ab53eb8f953cf6f4e58a756a205e88e0b

48- servant-github-webhook-0.4.2.0

49−- docker-0.6.0.3

50- http-client-0.5.14

49- http-client-0.5.14

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

51+ commit: 5cfdc4d7facd7043f530bce4ce0f0c57c923b029

51

52

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

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

53# flags: {}

54# flags: {}