master..2de68b5 · sc-build

git.iko.soy/sc-build

on 2de68b5 help sign in

src/Control/HasGithubStatus.hs−1

since splitsnapshots

unifiedsplit

@@ -11,4 +11,3 @@ 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+1−4

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

21import GHC.TypeLits

22import Server.Schema

23import Squeal.PostgreSQL

24−import UnliftIO.Exception

26scheduleTask ::

25scheduleTask ::

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

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

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

67 <> e

66 <> e

68 A.Success t -> do

67 A.Success t -> do

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

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

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

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

71− logError . T.pack . displayException $ e

72− return Failure

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

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

74 case r of

71 case r of

75 Success -> completeTaskQuery t

72 Success -> completeTaskQuery t

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

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

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

42 :* Default `as` #creation_time

43 :* Default `as` #started

44− :* Default `as` #failures

45 )

44 )

46 ( OnConflict

45 ( OnConflict

47 (OnConstraint #pk_task_payload)

46 (OnConstraint #pk_task_payload)

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

88 #tasks

87 #tasks

89 ( Default `as` #creation_time

88 ( Default `as` #creation_time

90 :* Default `as` #started

89 :* Default `as` #started

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

92 )

90 )

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

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

94 dbWrite (const $ return ()) $

92 dbWrite (const $ return ()) $

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

103 Word64 ->

101 Word64 ->

104 m [PickedTask]

102 m [PickedTask]

105pickTasksQuery tasks limitCount = do

103pickTasksQuery tasks limitCount = do

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

104+ logDebug "reading tasks"

107 let query :: Query_ Schema () PickedTask

105 let query :: Query_ Schema () PickedTask

108 query =

106 query =

109 select_

107 select_

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

114 ( from (table #tasks)

112 ( from (table #tasks)

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

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

116 & where_ (not_ . notNull $ #started)

114 & where_ (not_ . notNull $ #started)

117− & where_ (#failures .< 20)

118− & orderBy [#creation_time & Asc]

119 & limit limitCount

115 & limit limitCount

120− & orderBy [#creation_time & Desc]

121 )

116 )

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

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

123 startedMan =

118 startedMan =

src/Data/Submission.hs−1

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

29 = SubmissionRun TestResult

30 | SubmissionFailed String

31 | BuildScheduled

32− | PastDeadline

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

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

35newtype TestResult

34newtype TestResult

src/Server.hs+19−49

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

30import Data.Tasks.Build

31import Data.Tasks.StatusUpdate

32import qualified Data.Text as T

33−import Data.Time.Clock

34import Data.Yaml

33import Data.Yaml

35import GHC.Generics

34import GHC.Generics

36import GitHub hiding (Accept)

35import GitHub hiding (Accept)

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

50import Server.Html

49import Server.Html

51import Server.Schema

50import Server.Schema

52import Squeal.PostgreSQL

51import Squeal.PostgreSQL

52+import System.IO

53import Text.Blaze.Html

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

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

75 :> Post '[HTML] Markup

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

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

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

79webhookInstallation _ ((), ev) =

80− logInfo . T.pack . show $ ev

80+ liftIO $ do

81+ print ev

82+ hFlush stdout

82webhookPushEvent ::

84webhookPushEvent ::

83− ( StaticPQ m,

84− MonadReader (ServerData m) m,

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

85− MonadUnliftIO m,

86− HasTasks m,

87− MonadError ServerError m,

88− WithLog env Message m

89− ) =>

90 RepoWebhookEvent ->

86 RepoWebhookEvent ->

91 ((), PushEvent) ->

87 ((), PushEvent) ->

92 m ()

88 m ()

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

104 M.takeWhileAntitone (repoName >) tasks

100 M.takeWhileAntitone (repoName >) tasks

105 case task of

101 case task of

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

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

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

120− createSubmission $

104+ createSubmission $

121− Submission

105+ Submission

122− user

106+ user

123− (T.unpack fullRepoName)

107+ (T.unpack fullRepoName)

124− (T.unpack name)

108+ (T.unpack name)

125− (T.unpack sha)

109+ (T.unpack sha)

126− (Jsonb BuildScheduled)

110+ (Jsonb BuildScheduled)

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

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

128− logInfo . T.pack . show $ ev

112+ liftIO $ do

113+ print ev

114+ hFlush stdout

129 _ -> return ()

115 _ -> return ()

130

116

131retestSubmission ::

117retestSubmission ::

@@ -329,21 +315,6 @@ instance (MonadReader (ServerData m) m, StaticPQ m, MonadUnliftIO m) => HasGithu

329 newStatusContext = Just c

315 newStatusContext = Just c

330 }

316 }

331 scheduleTask status

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

344− newStatusContext = Just c

345− }

346− scheduleTask status

347

318

348instance (MonadReader (ServerData n) m) => HasDockerInfo m where

319instance (MonadReader (ServerData n) m) => HasDockerInfo m where

349 getDockerUrl = asks dockerUrl

320 getDockerUrl = asks dockerUrl

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

354 = TaskConfig

325 = TaskConfig

355 { prebuild :: String,

326 { prebuild :: String,

356 dockerfile :: String,

327 dockerfile :: String,

357− timeoutMinutes :: Int,

328+ timeoutMinutes :: Int

358− deadline :: UTCTime

359 }

329 }

360 deriving stock (Show, Eq, Generic)

330 deriving stock (Show, Eq, Generic)

361 deriving anyclass (FromJSON, ToJSON)

331 deriving anyclass (FromJSON, ToJSON)

src/Server/Html.hs−2

@@ -61,8 +61,6 @@ getSubmissionR user repo sha' = do

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

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

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

64− Jsonb PastDeadline ->

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

66 return . docTypeHtml $ do

64 return . docTypeHtml $ do

67 H.head $ do

65 H.head $ do

68 H.title $ toHtml titleText

66 H.title $ toHtml titleText

src/Server/Schema.hs+1−3

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

6where

8import Server.Schema.V1

9−import Server.Schema.V2

10import Squeal.PostgreSQL

9import Squeal.PostgreSQL

12type StaticPQ m = MonadPQ Schema m

11type StaticPQ m = MonadPQ Schema m

14−type Schema = SchemaV2

13+type Schema = SchemaV1

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

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

17migration =

16migration =

18 pureMigration schemaMigrationV1

17 pureMigration schemaMigrationV1

19− :>> pureMigration schemaMigrationV2

20 :>> Done

18 :>> 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− }