Added result table

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)

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

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

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

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

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