From 5b4180688899cc8acca0516de8e5b77cf9dbfc25 Mon Sep 17 00:00:00 2001 From: iko Date: Sun, 23 Feb 2020 22:09:31 +0300 Subject: [PATCH] Added result table --- src/Data/Submission.hs | 10 ++++++++++ src/Data/Submission/Query.hs | 14 ++++++++++++++ src/Data/Tasks/Build.hs | 31 +++++++++++++++++-------------- src/Server.hs | 17 ++++++++++++++--- src/Server/Config.hs | 5 ++++- src/Server/Html.hs | 35 +++++++++++++++++++++++++++++++++++ 6 files changed, 94 insertions(+), 18 deletions(-) diff --git a/src/Data/Submission.hs b/src/Data/Submission.hs index 0e6a9dc..a2f75b3 100644 --- a/src/Data/Submission.hs +++ b/src/Data/Submission.hs @@ -2,10 +2,13 @@ module Data.Submission ( Submission (..), SubmissionStatus (..), TestResult (..), + Score (..), ) where import Data.Aeson +import Data.Csv +import Data.Int import Data.Map (Map) import Data.Text (Text) import GHC.Generics (Generic) @@ -34,3 +37,10 @@ newtype TestResult } deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) + +data Score + = Score + { userName :: String, + score :: Int64 + } + deriving (Eq, Show, Generic, SOP.Generic, SOP.HasDatatypeInfo, ToRecord) diff --git a/src/Data/Submission/Query.hs b/src/Data/Submission/Query.hs index 0b6cd3d..c572be4 100644 --- a/src/Data/Submission/Query.hs +++ b/src/Data/Submission/Query.hs @@ -4,6 +4,7 @@ module Data.Submission.Query ( createSubmission, updateSubmissionStatus, getSubmission, + getResults, ) where @@ -83,3 +84,16 @@ getSubmission repoFullName sha = do query (repoFullName, sha) >>= firstRow + +getResults :: + (StaticPQ m, WithLog env Message m, MonadUnliftIO m) => + String -> + m [Score] +getResults task = do + let query :: Query_ Schema (Only String) Score + 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" + dbRead (const $ return []) $ + runQueryParams + query + (Only task) + >>= getRows diff --git a/src/Data/Tasks/Build.hs b/src/Data/Tasks/Build.hs index 824ccf3..aa5d005 100644 --- a/src/Data/Tasks/Build.hs +++ b/src/Data/Tasks/Build.hs @@ -43,7 +43,6 @@ data Build deriving (Eq, Show, Generic, FromJSON, ToJSON) instance Task Build "build-repo" where - type TaskMonad Build m = (MonadUnliftIO m, GithubCloner m, StaticPQ m, HasDockerInfo m) performTask Build {..} = @@ -127,24 +126,28 @@ instance Task Build "build-repo" where let total = M.size tests passed = M.size . M.filter id $ tests description = T.pack $ show passed <> "/" <> show total - status = statusTask NewStatus - { newStatusState = - if total == passed then StatusSuccess else StatusFailure, - newStatusTargetUrl = Nothing, - newStatusDescription = Just description, - newStatusContext = Nothing - } + status = + statusTask + NewStatus + { newStatusState = + if total == passed then StatusSuccess else StatusFailure, + newStatusTargetUrl = Nothing, + newStatusDescription = Just description, + newStatusContext = Nothing + } scheduleTask status updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult) return Success where statusTask = StatusUpdate owner repoName sha - erroredTask = statusTask $ NewStatus - { newStatusState = StatusError, - newStatusTargetUrl = Nothing, - newStatusDescription = Just "Build failed", - newStatusContext = Nothing - } + erroredTask = + statusTask $ + NewStatus + { newStatusState = StatusError, + newStatusTargetUrl = Nothing, + newStatusDescription = Just "Build failed", + newStatusContext = Nothing + } createDir :: MonadIO m => m FilePath createDir = do diff --git a/src/Server.hs b/src/Server.hs index 40fa18f..149f26c 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -16,6 +16,7 @@ import Control.Monad.Reader import Control.Task.Scheduler import Data.Aeson import Data.ByteString +import qualified Data.Csv as Csv import Data.IORef import Data.Map (Map) import qualified Data.Map as M @@ -26,12 +27,13 @@ import Data.Tasks.StatusUpdate import qualified Data.Text as T import Data.Yaml import GHC.Generics -import GitHub +import GitHub hiding (Accept) import GitHub.App.Auth import GitHub.App.Request import GitHub.Data.Name import GitHub.Data.Webhooks.Events import GitHub.Data.Webhooks.Payload +import Network.HTTP.Media.MediaType import Network.Wai.Handler.Warp import Servant import Servant.GitHub.Webhook @@ -64,6 +66,7 @@ type API = :> Capture "sha" String :> "restart" :> Post '[HTML] Markup + :<|> "results" :> Capture "task name" String :> Get '[CSV, HTML] [Score] webhookInstallation :: MonadIO m => RepoWebhookEvent -> ((), InstallationEvent) -> m () webhookInstallation _ ((), ev) = @@ -146,7 +149,7 @@ newtype ServerM (schema :: SchemasType) a ) server :: ServerT API (ServerM Schema) -server = (webhookInstallation :<|> webhookPushEvent) :<|> getSubmissionR :<|> retestSubmission +server = (webhookInstallation :<|> webhookPushEvent) :<|> getSubmissionR :<|> retestSubmission :<|> getResults runServer :: IO () runServer = do @@ -166,7 +169,7 @@ runServer = do githubUserName = GithubUserName githubUsername, githubAccessToken = GithubAccessToken personalAccessToken, tasks = ts, - logger = simpleMessageAction, + logger = cfilter ((logSeverity <=) . msgSeverity) richMessageAction, baseUrl = baseSiteUrl, dockerUrl = T.pack cfgDockerUrl } @@ -260,3 +263,11 @@ instance HasLog (ServerData m) Message m where setLogAction :: LogAction m Message -> ServerData m -> ServerData m setLogAction newLogAction env = env {logger = newLogAction} {-# INLINE setLogAction #-} + +data CSV + +instance Accept CSV where + contentType Proxy = "text" // "csv" + +instance Csv.ToRecord a => MimeRender CSV [a] where + mimeRender Proxy = Csv.encode diff --git a/src/Server/Config.hs b/src/Server/Config.hs index 211f657..fdea563 100644 --- a/src/Server/Config.hs +++ b/src/Server/Config.hs @@ -6,6 +6,7 @@ module Server.Config ) where +import Colog import Crypto.PubKey.RSA (PrivateKey) import Crypto.PubKey.RSA.Read import Data.ByteString as BS @@ -29,7 +30,8 @@ data Config databseUrl :: !ByteString, baseSiteUrl :: !String, cfgDockerUrl :: !String, - cfgDockerFile :: !FilePath + cfgDockerFile :: !FilePath, + logSeverity :: !Severity } deriving (Show) @@ -48,6 +50,7 @@ getConfig = <*> (fromMaybe "http://localhost:8080" <$> lookupEnv "PORT") <*> (fromMaybe "http://localhost:1234" <$> lookupEnv "DOCKER_URL") <*> (fromMaybe "TmpDockerfile" <$> lookupEnv "DOCKER_FILE") + <*> (maybe Info read <$> lookupEnv "LOG_SEVERITY") where readPem :: IO PrivateKey readPem = do diff --git a/src/Server/Html.hs b/src/Server/Html.hs index 18ef200..ff3b072 100644 --- a/src/Server/Html.hs +++ b/src/Server/Html.hs @@ -12,6 +12,7 @@ import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Data.Aeson hiding (Success) import qualified Data.ByteString.Lazy.Char8 as BS +import Data.Foldable import qualified Data.Map as M import Data.String import Data.Submission @@ -84,6 +85,9 @@ getSubmissionR user repo sha = do C.td ? do C.padding (px 4) (px 4) (px 4) (px 4) C.form ? do + C.display C.block + C.width (pct 100) + C.input ? do C.display C.block C.marginLeft auto C.marginRight auto @@ -109,3 +113,34 @@ redirectToSubmission user repo sha = do H.meta H.! A.httpEquiv "refresh" H.! A.content (fromString $ "0; URL=" <> rUrl) + +instance ToMarkup [Score] where + toMarkup xs = docTypeHtml $ do + H.style . preEscapedToHtml . render $ do + C.body ? do + fontFamily [] [sansSerif] + C.maxWidth (px 800) + C.display C.block + C.marginLeft auto + C.marginRight auto + C.paddingLeft (px 16) + C.paddingRight (px 16) + (C.h1 <> C.h2 <> C.h3) ? do + textAlign center + C.pre ? do + C.whiteSpace C.preWrap + (C.tr <> C.td) ? do + C.width (pct 50) + C.td ? do + C.padding (px 4) (px 4) (px 4) (px 4) + C.border solid (px 1) black + C.margin (px 0) (px 0) (px 0) (px 0) + C.table ? do + C.borderCollapse (other "collapse") + C.width (pct 100) + H.body + $ H.table + $ for_ xs + $ \(Score user score) -> H.tr $ do + (H.td H.! A.align "right") . H.code $ toHtml user + H.td $ toHtml score