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

git.iko.soy/sc-build

Added result table

commit5b4180688899cc8acca0516de8e5b77cf9dbfc25 authoriko <ilyakooo0@gmail.com> dateSun 23 Feb 2020, 22:09 (7 years ago) parent0b85829

6 files changed+94−18

compare with master

unifiedsplit

src/Data/Submission.hs+10 src/Data/Submission/Query.hs+14 src/Data/Tasks/Build.hs+17−14 src/Server.hs+14−3 src/Server/Config.hs+4−1 src/Server/Html.hs+35

src/Data/Submission.hs+10

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

22 ( Submission (..),

33 SubmissionStatus (..),

44 TestResult (..),

5+ Score (..),

56 )

67where

89import Data.Aeson

10+import Data.Csv

11+import Data.Int

912import Data.Map (Map)

1013import Data.Text (Text)

1114import GHC.Generics (Generic)

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

3437 }

3538 deriving stock (Eq, Show, Generic)

3639 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

44 ( createSubmission,

55 updateSubmissionStatus,

66 getSubmission,

7+ getResults,

78 )

89where

910

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

8384 query

8485 (repoFullName, sha)

8586 >>= 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

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

4444

4545instance Task Build "build-repo" where

46−

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

4847

4948 performTask Build {..} =

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

127126 let total = M.size tests

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

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

130− status = statusTask NewStatus

131− { newStatusState =

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

133− newStatusTargetUrl = Nothing,

134− newStatusDescription = Just description,

135− newStatusContext = Nothing

136− }

129+ status =

130+ statusTask

131+ NewStatus

132+ { newStatusState =

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

134+ newStatusTargetUrl = Nothing,

135+ newStatusDescription = Just description,

136+ newStatusContext = Nothing

137+ }

137138 scheduleTask status

138139 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

139140 return Success

140141 where

141142 statusTask = StatusUpdate owner repoName sha

142− erroredTask = statusTask $ NewStatus

143− { newStatusState = StatusError,

144− newStatusTargetUrl = Nothing,

145− newStatusDescription = Just "Build failed",

146− newStatusContext = Nothing

147− }

143+ erroredTask =

144+ statusTask $

145+ NewStatus

146+ { newStatusState = StatusError,

147+ newStatusTargetUrl = Nothing,

148+ newStatusDescription = Just "Build failed",

149+ newStatusContext = Nothing

150+ }

148151

149152createDir :: MonadIO m => m FilePath

150153createDir = do

src/Server.hs+14−3

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

1616import Control.Task.Scheduler

1717import Data.Aeson

1818import Data.ByteString

19+import qualified Data.Csv as Csv

1920import Data.IORef

2021import Data.Map (Map)

2122import qualified Data.Map as M

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

2627import qualified Data.Text as T

2728import Data.Yaml

2829import GHC.Generics

29−import GitHub

30+import GitHub hiding (Accept)

3031import GitHub.App.Auth

3132import GitHub.App.Request

3233import GitHub.Data.Name

3334import GitHub.Data.Webhooks.Events

3435import GitHub.Data.Webhooks.Payload

36+import Network.HTTP.Media.MediaType

3537import Network.Wai.Handler.Warp

3638import Servant

3739import Servant.GitHub.Webhook

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

6466 :> Capture "sha" String

6567 :> "restart"

6668 :> Post '[HTML] Markup

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

6770

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

6972webhookInstallation _ ((), ev) =

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

146149 )

147150

148151server :: ServerT API (ServerM Schema)

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

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

150153

151154runServer :: IO ()

152155runServer = do

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

166169 githubUserName = GithubUserName githubUsername,

167170 githubAccessToken = GithubAccessToken personalAccessToken,

168171 tasks = ts,

169− logger = simpleMessageAction,

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

170173 baseUrl = baseSiteUrl,

171174 dockerUrl = T.pack cfgDockerUrl

172175 }

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

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

261264 setLogAction newLogAction env = env {logger = newLogAction}

262265 {-# 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

66 )

77where

9+import Colog

910import Crypto.PubKey.RSA (PrivateKey)

1011import Crypto.PubKey.RSA.Read

1112import Data.ByteString as BS

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

2930 databseUrl :: !ByteString,

3031 baseSiteUrl :: !String,

3132 cfgDockerUrl :: !String,

32− cfgDockerFile :: !FilePath

33+ cfgDockerFile :: !FilePath,

34+ logSeverity :: !Severity

3335 }

3436 deriving (Show)

3537

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

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

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

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

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

5154 where

5255 readPem :: IO PrivateKey

5356 readPem = do

src/Server/Html.hs+35

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

1212import Control.Monad.IO.Unlift

1313import Data.Aeson hiding (Success)

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

15+import Data.Foldable

1516import qualified Data.Map as M

1617import Data.String

1718import Data.Submission

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

8485 C.td ? do

8586 C.padding (px 4) (px 4) (px 4) (px 4)

8687 C.form ? do

88+ C.display C.block

89+ C.width (pct 100)

90+ C.input ? do

8791 C.display C.block

8892 C.marginLeft auto

8993 C.marginRight auto

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

109113 H.meta

110114 H.! A.httpEquiv "refresh"

111115 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