5b41806 · sc-build · git.iko.soy

src/Data/Submission.hs+10

compare with master

unifiedsplit

@@ -2,10 +2,13 @@ module Data.Submission

2 ( Submission (..),

3 SubmissionStatus (..),

4 TestResult (..),

5+ Score (..),

5 )

6 )

6where

7where

7

8

8import Data.Aeson

9import Data.Aeson

10+import Data.Csv

11+import Data.Int

9import Data.Map (Map)

12import Data.Map (Map)

10import Data.Text (Text)

13import Data.Text (Text)

11import GHC.Generics (Generic)

14import GHC.Generics (Generic)

@@ -34,3 +37,10 @@ newtype TestResult

34 }

37 }

35 deriving stock (Eq, Show, Generic)

38 deriving stock (Eq, Show, Generic)

36 deriving anyclass (FromJSON, ToJSON)

39 deriving anyclass (FromJSON, ToJSON)

40+

41+data Score

42+ = Score

43+ { userName :: String,

44+ score :: Int64

45+ }

46+ deriving (Eq, Show, Generic, SOP.Generic, SOP.HasDatatypeInfo, ToRecord)

src/Data/Submission/Query.hs+14

@@ -4,6 +4,7 @@ module Data.Submission.Query

4 ( createSubmission,

5 updateSubmissionStatus,

6 getSubmission,

7+ getResults,

7 )

8 )

8where

9where

9

10

@@ -83,3 +84,16 @@ getSubmission repoFullName sha = do

83 query

84 query

84 (repoFullName, sha)

85 (repoFullName, sha)

85 >>= firstRow

86 >>= firstRow

87+

88+getResults ::

89+ (StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>

90+ String ->

91+ m [Score]

92+getResults task = do

93+ let query :: Query_ Schema (Only String) Score

94+ query = UnsafeQuery "select a.user_name as \"userName\", max(a.correct) as score from (select (select count(*) as correct from jsonb_each_text(submissions.status -> 'contents' -> 'tests') where value = 'true'), user_name from submissions where problem = $1) as a group by user_name"

95+ dbRead (const $ return []) $

96+ runQueryParams

97+ query

98+ (Only task)

99+ >>= getRows

src/Data/Tasks/Build.hs+17−14

@@ -43,7 +43,6 @@ data Build

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

44

45instance Task Build "build-repo" where

46−

47 type TaskMonad Build m = (MonadUnliftIO m, GithubCloner m, StaticPQ m, HasDockerInfo m)

46 type TaskMonad Build m = (MonadUnliftIO m, GithubCloner m, StaticPQ m, HasDockerInfo m)

48

47

49 performTask Build {..} =

48 performTask Build {..} =

@@ -127,24 +126,28 @@ instance Task Build "build-repo" where

127 let total = M.size tests

126 let total = M.size tests

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

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

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

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

129+ status =

130− status = statusTask NewStatus

130+ statusTask

131+ NewStatus

131− { newStatusState =

132+ { newStatusState =

132− if total == passed then StatusSuccess else StatusFailure,

133+ if total == passed then StatusSuccess else StatusFailure,

133− newStatusTargetUrl = Nothing,

134+ newStatusTargetUrl = Nothing,

134− newStatusDescription = Just description,

135+ newStatusDescription = Just description,

135− newStatusContext = Nothing

136+ newStatusContext = Nothing

136− }

137+ }

137 scheduleTask status

138 scheduleTask status

138 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

139 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

139 return Success

140 return Success

140 where

141 where

141 statusTask = StatusUpdate owner repoName sha

142 statusTask = StatusUpdate owner repoName sha

142− erroredTask = statusTask $ NewStatus

143+ erroredTask =

144+ statusTask $

145+ NewStatus

143− { newStatusState = StatusError,

146+ { newStatusState = StatusError,

144− newStatusTargetUrl = Nothing,

147+ newStatusTargetUrl = Nothing,

145− newStatusDescription = Just "Build failed",

148+ newStatusDescription = Just "Build failed",

146− newStatusContext = Nothing

149+ newStatusContext = Nothing

147− }

150+ }

148

151

149createDir :: MonadIO m => m FilePath

152createDir :: MonadIO m => m FilePath

150createDir = do

153createDir = do

src/Server.hs+14−3

@@ -16,6 +16,7 @@ import Control.Monad.Reader

16import Control.Task.Scheduler

17import Data.Aeson

18import Data.ByteString

19+import qualified Data.Csv as Csv

19import Data.IORef

20import Data.IORef

20import Data.Map (Map)

21import Data.Map (Map)

21import qualified Data.Map as M

22import qualified Data.Map as M

@@ -26,12 +27,13 @@ import Data.Tasks.StatusUpdate

26import qualified Data.Text as T

27import qualified Data.Text as T

27import Data.Yaml

28import Data.Yaml

28import GHC.Generics

29import GHC.Generics

29−import GitHub

30+import GitHub hiding (Accept)

30import GitHub.App.Auth

31import GitHub.App.Auth

31import GitHub.App.Request

32import GitHub.App.Request

32import GitHub.Data.Name

33import GitHub.Data.Name

33import GitHub.Data.Webhooks.Events

34import GitHub.Data.Webhooks.Events

34import GitHub.Data.Webhooks.Payload

35import GitHub.Data.Webhooks.Payload

36+import Network.HTTP.Media.MediaType

35import Network.Wai.Handler.Warp

37import Network.Wai.Handler.Warp

36import Servant

38import Servant

37import Servant.GitHub.Webhook

39import Servant.GitHub.Webhook

@@ -64,6 +66,7 @@ type API =

64 :> Capture "sha" String

66 :> Capture "sha" String

65 :> "restart"

67 :> "restart"

66 :> Post '[HTML] Markup

68 :> Post '[HTML] Markup

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

67

70

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

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

69webhookInstallation _ ((), ev) =

72webhookInstallation _ ((), ev) =

@@ -146,7 +149,7 @@ newtype ServerM (schema :: SchemasType) a

146 )

149 )

147

150

148server :: ServerT API (ServerM Schema)

151server :: ServerT API (ServerM Schema)

149−server = (webhookInstallation :<|> webhookPushEvent) :<|> getSubmissionR :<|> retestSubmission

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

150

153

151runServer :: IO ()

154runServer :: IO ()

152runServer = do

155runServer = do

@@ -166,7 +169,7 @@ runServer = do

166 githubUserName = GithubUserName githubUsername,

169 githubUserName = GithubUserName githubUsername,

167 githubAccessToken = GithubAccessToken personalAccessToken,

170 githubAccessToken = GithubAccessToken personalAccessToken,

168 tasks = ts,

171 tasks = ts,

169− logger = simpleMessageAction,

172+ logger = cfilter ((logSeverity <=) . msgSeverity) richMessageAction,

170 baseUrl = baseSiteUrl,

173 baseUrl = baseSiteUrl,

171 dockerUrl = T.pack cfgDockerUrl

174 dockerUrl = T.pack cfgDockerUrl

172 }

175 }

@@ -260,3 +263,11 @@ instance HasLog (ServerData m) Message m where

260 setLogAction :: LogAction m Message -> ServerData m -> ServerData m

263 setLogAction :: LogAction m Message -> ServerData m -> ServerData m

261 setLogAction newLogAction env = env {logger = newLogAction}

264 setLogAction newLogAction env = env {logger = newLogAction}

262 {-# INLINE setLogAction #-}

265 {-# INLINE setLogAction #-}

266+

267+data CSV

268+

269+instance Accept CSV where

270+ contentType Proxy = "text" // "csv"

271+

272+instance Csv.ToRecord a => MimeRender CSV [a] where

273+ mimeRender Proxy = Csv.encode

src/Server/Config.hs+4−1

@@ -6,6 +6,7 @@ module Server.Config

6 )

7where

8

9+import Colog

9import Crypto.PubKey.RSA (PrivateKey)

10import Crypto.PubKey.RSA (PrivateKey)

10import Crypto.PubKey.RSA.Read

11import Crypto.PubKey.RSA.Read

11import Data.ByteString as BS

12import Data.ByteString as BS

@@ -29,7 +30,8 @@ data Config

29 databseUrl :: !ByteString,

30 databseUrl :: !ByteString,

30 baseSiteUrl :: !String,

31 baseSiteUrl :: !String,

31 cfgDockerUrl :: !String,

32 cfgDockerUrl :: !String,

32− cfgDockerFile :: !FilePath

33+ cfgDockerFile :: !FilePath,

34+ logSeverity :: !Severity

33 }

35 }

34 deriving (Show)

36 deriving (Show)

35

37

@@ -48,6 +50,7 @@ getConfig =

48 <*> (fromMaybe "http://localhost:8080" <$> lookupEnv "PORT")

50 <*> (fromMaybe "http://localhost:8080" <$> lookupEnv "PORT")

49 <*> (fromMaybe "http://localhost:1234" <$> lookupEnv "DOCKER_URL")

51 <*> (fromMaybe "http://localhost:1234" <$> lookupEnv "DOCKER_URL")

50 <*> (fromMaybe "TmpDockerfile" <$> lookupEnv "DOCKER_FILE")

52 <*> (fromMaybe "TmpDockerfile" <$> lookupEnv "DOCKER_FILE")

53+ <*> (maybe Info read <$> lookupEnv "LOG_SEVERITY")

51 where

54 where

52 readPem :: IO PrivateKey

55 readPem :: IO PrivateKey

53 readPem = do

56 readPem = do

src/Server/Html.hs+35

@@ -12,6 +12,7 @@ import Control.Monad.IO.Class

12import Control.Monad.IO.Unlift

13import Data.Aeson hiding (Success)

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

15+import Data.Foldable

15import qualified Data.Map as M

16import qualified Data.Map as M

16import Data.String

17import Data.String

17import Data.Submission

18import Data.Submission

@@ -84,6 +85,9 @@ getSubmissionR user repo sha = do

84 C.td ? do

85 C.td ? do

85 C.padding (px 4) (px 4) (px 4) (px 4)

86 C.padding (px 4) (px 4) (px 4) (px 4)

86 C.form ? do

87 C.form ? do

88+ C.display C.block

89+ C.width (pct 100)

90+ C.input ? do

87 C.display C.block

91 C.display C.block

88 C.marginLeft auto

92 C.marginLeft auto

89 C.marginRight auto

93 C.marginRight auto

@@ -109,3 +113,34 @@ redirectToSubmission user repo sha = do

109 H.meta

113 H.meta

110 H.! A.httpEquiv "refresh"

114 H.! A.httpEquiv "refresh"

111 H.! A.content (fromString $ "0; URL=" <> rUrl)

115 H.! A.content (fromString $ "0; URL=" <> rUrl)

116+

117+instance ToMarkup [Score] where

118+ toMarkup xs = docTypeHtml $ do

119+ H.style . preEscapedToHtml . render $ do

120+ C.body ? do

121+ fontFamily [] [sansSerif]

122+ C.maxWidth (px 800)

123+ C.display C.block

124+ C.marginLeft auto

125+ C.marginRight auto

126+ C.paddingLeft (px 16)

127+ C.paddingRight (px 16)

128+ (C.h1 <> C.h2 <> C.h3) ? do

129+ textAlign center

130+ C.pre ? do

131+ C.whiteSpace C.preWrap

132+ (C.tr <> C.td) ? do

133+ C.width (pct 50)

134+ C.td ? do

135+ C.padding (px 4) (px 4) (px 4) (px 4)

136+ C.border solid (px 1) black

137+ C.margin (px 0) (px 0) (px 0) (px 0)

138+ C.table ? do

139+ C.borderCollapse (other "collapse")

140+ C.width (pct 100)

141+ H.body

142+ $ H.table

143+ $ for_ xs

144+ $ \(Score user score) -> H.tr $ do

145+ (H.td H.! A.align "right") . H.code $ toHtml user

146+ H.td $ toHtml score