add leaderboard
This commit is contained in:
parent
5bca45faf3
commit
88b5d80953
|
|
@ -102,6 +102,7 @@ checkTestDir chan challengeId commit testDir = do
|
|||
checksum <- liftIO $ gatherSHA1 testDir
|
||||
testId <- runDB $ insert $ Test {
|
||||
testChallenge=challengeId,
|
||||
testMetric=Nothing,
|
||||
testName=T.pack $ takeFileName testDir,
|
||||
testChecksum=(SHA1 checksum),
|
||||
testCommit=commit,
|
||||
|
|
|
|||
|
|
@ -5,8 +5,6 @@ import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3,
|
|||
withSmallInput)
|
||||
|
||||
import Data.Monoid
|
||||
import qualified Yesod.Table as Table
|
||||
import Yesod.Table (Table)
|
||||
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import Text.Markdown
|
||||
|
|
@ -14,8 +12,12 @@ import Text.Markdown
|
|||
import System.Directory (doesFileExist)
|
||||
import qualified Data.Text as T
|
||||
|
||||
import qualified Yesod.Table as Table
|
||||
import Yesod.Table (Table)
|
||||
|
||||
import Handler.Extract
|
||||
import Handler.Shared
|
||||
import Handler.Tables
|
||||
|
||||
import GEval.Core
|
||||
import GEval.OptionsParser
|
||||
|
|
@ -29,9 +31,10 @@ import Options.Applicative
|
|||
|
||||
getShowChallengeR :: Text -> Handler Html
|
||||
getShowChallengeR name = do
|
||||
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName name
|
||||
(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
|
||||
Just repo <- runDB $ get $ challengePublicRepo challenge
|
||||
challengeLayout True challenge (showChallengeWidget challenge repo)
|
||||
leaderboard <- getLeaderboardEntries challengeId
|
||||
challengeLayout True challenge (showChallengeWidget challenge repo leaderboard)
|
||||
|
||||
getChallengeReadmeR :: Text -> Handler Html
|
||||
getChallengeReadmeR name = do
|
||||
|
|
@ -42,7 +45,8 @@ getChallengeReadmeR name = do
|
|||
contents <- readFile readmeFilePath
|
||||
challengeLayout False challenge $ toWidget $ markdown def $ TL.fromStrict contents
|
||||
|
||||
showChallengeWidget challenge repo = $(widgetFile "show-challenge")
|
||||
showChallengeWidget challenge repo leaderboard = $(widgetFile "show-challenge")
|
||||
where leaderboardWithRanks = zip [1..] leaderboard
|
||||
|
||||
getChallengeHowToR :: Text -> Handler Html
|
||||
getChallengeHowToR name = do
|
||||
|
|
@ -237,44 +241,12 @@ getChallengeAllSubmissionsR name = getChallengeSubmissions (\_ -> True) name
|
|||
|
||||
getChallengeSubmissions :: ((Entity Submission) -> Bool) -> Text -> Handler Html
|
||||
getChallengeSubmissions condition name = do
|
||||
(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
|
||||
allSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId] [Desc SubmissionStamp]
|
||||
let submissions = filter condition allSubmissions
|
||||
tests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] []
|
||||
evaluationMaps <- mapM getEvaluationMap submissions
|
||||
challengeEnt@(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
|
||||
(evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId
|
||||
challengeLayout True challenge (challengeAllSubmissionsWidget challenge evaluationMaps tests)
|
||||
|
||||
|
||||
|
||||
getEvaluationMap :: Entity Submission -> Handler (Entity Submission, User, Map (Key Test) Evaluation)
|
||||
getEvaluationMap s@(Entity submissionId submission) = do
|
||||
outs <- runDB $ selectList [OutSubmission ==. submissionId] []
|
||||
user <- runDB $ get404 $ submissionSubmitter submission
|
||||
maybeEvaluations <- runDB $ mapM (\(Entity _ o) -> getBy $ UniqueEvaluationTestChecksum (outTest o) (outChecksum o)) outs
|
||||
let evaluations = catMaybes maybeEvaluations
|
||||
let m = Map.fromList $ map (\(Entity _ e) -> (evaluationTest e, e)) evaluations
|
||||
return (s, user, m)
|
||||
|
||||
challengeAllSubmissionsWidget challenge submissions tests = $(widgetFile "challenge-all-submissions")
|
||||
|
||||
submissionsTable :: [Entity Test] -> Table site (Entity Submission, User, Map (Key Test) Evaluation)
|
||||
submissionsTable tests = mempty
|
||||
++ Table.text "submitter" (formatSubmitter . \(_, submitter, _) -> submitter)
|
||||
++ Table.string "when" (show . submissionStamp . \(Entity _ s, _, _) -> s)
|
||||
++ Table.text "description" (submissionDescription . \(Entity _ s, _, _) -> s)
|
||||
++ mconcat (map (\(Entity k t) -> Table.string (testName t) (submissionScore k)) tests)
|
||||
|
||||
formatSubmitter :: User -> Text
|
||||
formatSubmitter user = case userName user of
|
||||
Just name -> name
|
||||
Nothing -> "[name not given]"
|
||||
|
||||
submissionScore :: Key Test -> (Entity Submission, User, Map (Key Test) Evaluation) -> String
|
||||
submissionScore k (_, _, m) = fromMaybe "N/A" (presentScore <$> lookup k m)
|
||||
|
||||
presentScore :: Evaluation -> String
|
||||
presentScore evaluation = fromMaybe "???" (show <$> evaluationScore evaluation)
|
||||
|
||||
challengeLayout withHeader challenge widget = do
|
||||
bc <- widgetToPageContent widget
|
||||
defaultLayout $ do
|
||||
|
|
|
|||
|
|
@ -0,0 +1,101 @@
|
|||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Handler.Tables where
|
||||
|
||||
import Import
|
||||
|
||||
import qualified Yesod.Table as Table
|
||||
import Yesod.Table (Table)
|
||||
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Data.Maybe as DM
|
||||
|
||||
import qualified Data.List as DL
|
||||
|
||||
import GEval.Core
|
||||
|
||||
data LeaderboardEntry = LeaderboardEntry {
|
||||
leaderboardUser :: User,
|
||||
leaderboardBestSubmission :: Submission,
|
||||
leaderboardEvaluation :: Evaluation,
|
||||
leaderboardNumberOfSubmissions :: Int
|
||||
}
|
||||
|
||||
submissionsTable :: [Entity Test] -> Table site (Entity Submission, Entity User, Map (Key Test) Evaluation)
|
||||
submissionsTable tests = mempty
|
||||
++ Table.text "submitter" (formatSubmitter . \(_, Entity _ submitter, _) -> submitter)
|
||||
++ Table.string "when" (show . submissionStamp . \(Entity _ s, _, _) -> s)
|
||||
++ Table.text "description" (submissionDescription . \(Entity _ s, _, _) -> s)
|
||||
++ mconcat (map (\(Entity k t) -> Table.string (testName t) (submissionScore k)) tests)
|
||||
|
||||
|
||||
leaderboardTable :: Table site (Int, LeaderboardEntry)
|
||||
leaderboardTable = mempty
|
||||
++ Table.int "#" fst
|
||||
++ Table.text "submitter" (formatSubmitter . leaderboardUser . snd)
|
||||
++ Table.string "when" (show . submissionStamp . leaderboardBestSubmission . snd)
|
||||
++ Table.text "description" (submissionDescription . leaderboardBestSubmission . snd)
|
||||
++ Table.string "result" (presentScore . leaderboardEvaluation . snd)
|
||||
++ Table.int "×" (leaderboardNumberOfSubmissions . snd)
|
||||
|
||||
getLeaderboardEntries :: Key Challenge -> Handler [LeaderboardEntry]
|
||||
getLeaderboardEntries challengeId = do
|
||||
(evaluationMaps, tests) <- getChallengeSubmissionInfos (\_ -> True) challengeId
|
||||
let mainTestEnt = DL.maximumBy (\(Entity _ a) (Entity _ b) -> ((testName a) `compare` (testName b))) tests
|
||||
let (Entity mainTestId mainTest) = mainTestEnt
|
||||
let auxSubmissions = map (processEvaluationMap mainTestId) evaluationMaps
|
||||
let submissionsByUser = Map.fromListWith (\(u1, l1) (_, l2) -> (u1, l1++l2)) auxSubmissions
|
||||
let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluation a) (evaluationScore $ leaderboardEvaluation b)
|
||||
let entries = sortBy (flip entryComparator) $ map (toEntry mainTest) $ filter (\(_, (_, s)) -> not (null s)) $ Map.toList submissionsByUser
|
||||
return entries
|
||||
where submissionComparator mainTest (_, e1) (_, e2) = (compareResult mainTest) (evaluationScore e1) (evaluationScore e2)
|
||||
toEntry mainTest (_, (u, ss)) = LeaderboardEntry {
|
||||
leaderboardUser = u,
|
||||
leaderboardBestSubmission = fst bestOne,
|
||||
leaderboardEvaluation = snd bestOne,
|
||||
leaderboardNumberOfSubmissions = length ss }
|
||||
where bestOne = DL.maximumBy (submissionComparator mainTest) ss
|
||||
processEvaluationMap mainTestId ((Entity _ s), (Entity ui u), m) = (ui, (u, case Map.lookup mainTestId m of
|
||||
Just e -> [(s, e)]
|
||||
Nothing -> []))
|
||||
|
||||
compareResult :: Test -> Maybe Double -> Maybe Double -> Ordering
|
||||
compareResult test (Just x) (Just y) = (DM.fromMaybe compare (compareFun <$> getMetricOrdering <$> testMetric test)) x y
|
||||
compareResult _ (Just _) Nothing = GT
|
||||
compareResult _ Nothing (Just _) = LT
|
||||
compareResult _ Nothing Nothing = EQ
|
||||
|
||||
compareFun :: MetricOrdering -> Double -> Double -> Ordering
|
||||
compareFun TheLowerTheBetter = flip compare
|
||||
compareFun TheHigherTheBetter = compare
|
||||
|
||||
getChallengeSubmissionInfos :: ((Entity Submission) -> Bool) -> Key Challenge -> Handler ([(Entity Submission, Entity User, Map (Key Test) Evaluation)], [Entity Test])
|
||||
getChallengeSubmissionInfos condition challengeId = do
|
||||
allSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId] [Desc SubmissionStamp]
|
||||
let submissions = filter condition allSubmissions
|
||||
tests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] []
|
||||
evaluationMaps <- mapM getEvaluationMap submissions
|
||||
return (evaluationMaps, tests)
|
||||
|
||||
getEvaluationMap :: Entity Submission -> Handler (Entity Submission, Entity User, Map (Key Test) Evaluation)
|
||||
getEvaluationMap s@(Entity submissionId submission) = do
|
||||
outs <- runDB $ selectList [OutSubmission ==. submissionId] []
|
||||
user <- runDB $ get404 $ submissionSubmitter submission
|
||||
maybeEvaluations <- runDB $ mapM (\(Entity _ o) -> getBy $ UniqueEvaluationTestChecksum (outTest o) (outChecksum o)) outs
|
||||
let evaluations = catMaybes maybeEvaluations
|
||||
let m = Map.fromList $ map (\(Entity _ e) -> (evaluationTest e, e)) evaluations
|
||||
return (s, Entity (submissionSubmitter submission) user, m)
|
||||
|
||||
|
||||
formatSubmitter :: User -> Text
|
||||
formatSubmitter user = case userName user of
|
||||
Just name -> name
|
||||
Nothing -> "[name not given]"
|
||||
|
||||
submissionScore :: Key Test -> (Entity Submission, Entity User, Map (Key Test) Evaluation) -> String
|
||||
submissionScore k (_, _, m) = fromMaybe "N/A" (presentScore <$> lookup k m)
|
||||
|
||||
presentScore :: Evaluation -> String
|
||||
presentScore evaluation = fromMaybe "???" (show <$> evaluationScore evaluation)
|
||||
|
|
@ -77,7 +77,7 @@ updateLocalIdAndPubKey userId (Just localId) maybeSshPubKey = do
|
|||
case userLocalId user of
|
||||
Just prevLocalId -> do
|
||||
unless (prevLocalId == localId) $ setMessage $ toHtml ("only the administrator can change your ID" :: Text)
|
||||
Nothing -> return ()
|
||||
Nothing -> runDB $ update userId [UserLocalId =. Just localId]
|
||||
runDB $ deleteWhere [PublicKeyUser ==. userId]
|
||||
case maybeSshPubKey of
|
||||
Just key -> do
|
||||
|
|
|
|||
3
Model.hs
3
Model.hs
|
|
@ -5,6 +5,9 @@ import Database.Persist.Quasi
|
|||
|
||||
import PersistSHA1
|
||||
|
||||
import GEval.Core
|
||||
import PersistMetric
|
||||
|
||||
-- You can define all of your database entities in the entities file.
|
||||
-- You can find more information on persistent and how to declare entities
|
||||
-- at:
|
||||
|
|
|
|||
|
|
@ -0,0 +1,18 @@
|
|||
module PersistMetric where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
import Database.Persist.Sql
|
||||
|
||||
import GEval.Core
|
||||
import qualified Data.Text as T
|
||||
|
||||
instance PersistField Metric where
|
||||
toPersistValue m = PersistText (T.pack $ show m)
|
||||
|
||||
fromPersistValue (PersistText t) = case readMay t of
|
||||
Just val -> Right val
|
||||
Nothing -> Left "Unexpected value"
|
||||
fromPersistValue _ = Left "Unexpected value"
|
||||
|
||||
instance PersistFieldSql Metric where
|
||||
sqlType _ = SqlString
|
||||
|
|
@ -33,6 +33,7 @@ Challenge
|
|||
stamp UTCTime default=now()
|
||||
Test
|
||||
challenge ChallengeId
|
||||
metric Metric Maybe
|
||||
name Text
|
||||
checksum SHA1
|
||||
commit SHA1
|
||||
|
|
|
|||
|
|
@ -24,6 +24,7 @@ library
|
|||
Import
|
||||
Import.NoFoundation
|
||||
Model
|
||||
PersistMetric
|
||||
PersistSHA1
|
||||
Settings
|
||||
Settings.StaticFiles
|
||||
|
|
@ -36,6 +37,7 @@ library
|
|||
Handler.Shared
|
||||
Handler.ShowChallenge
|
||||
Handler.Extract
|
||||
Handler.Tables
|
||||
Handler.YourAccount
|
||||
|
||||
if flag(dev) || flag(library-only)
|
||||
|
|
@ -109,7 +111,7 @@ library
|
|||
, filemanip
|
||||
, cryptohash
|
||||
, markdown
|
||||
, geval
|
||||
, geval >= 0.2.2.0
|
||||
, filepath
|
||||
, yesod-table
|
||||
, regex-tdfa
|
||||
|
|
|
|||
|
|
@ -5,5 +5,5 @@ flags:
|
|||
packages:
|
||||
- '.'
|
||||
- '../geval'
|
||||
extra-deps: [markdown-0.1.13.2,geval-0.2.0.0]
|
||||
extra-deps: [markdown-0.1.13.2,geval-0.2.2.0]
|
||||
resolver: lts-3.13
|
||||
|
|
|
|||
|
|
@ -1 +1,3 @@
|
|||
<p>(This is a long list of all submissions, if you want to see only the best, click <a href="@{ShowChallengeR (challengeName challenge)}">leaderboard</a>.)
|
||||
|
||||
^{Table.buildBootstrap (submissionsTable tests) submissions}
|
||||
|
|
|
|||
|
|
@ -2,3 +2,7 @@
|
|||
<tt> #{repoUrl repo}
|
||||
\ Branch:
|
||||
<tt> #{repoBranch repo}
|
||||
|
||||
<h2>Leaderboard
|
||||
|
||||
^{Table.buildBootstrap leaderboardTable leaderboardWithRanks}
|
||||
|
|
|
|||
Loading…
Reference in New Issue