add leaderboard

Handler/CreateChallenge.hs

@@ -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,

Handler/ShowChallenge.hs

@@ -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
+  challengeEnt@(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
-  allSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId] [Desc SubmissionStamp]
+  (evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId
-  let submissions = filter condition allSubmissions
-  tests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] []
-  evaluationMaps <- mapM getEvaluationMap submissions
   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

Handler/Tables.hs

@@ -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)

Handler/YourAccount.hs

@@ -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

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:

PersistMetric.hs

@@ -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

config/models

@@ -33,6 +33,7 @@ Challenge
     stamp UTCTime default=now()
 Test
     challenge ChallengeId
+    metric Metric Maybe
     name Text
     checksum SHA1
     commit SHA1

gonito.cabal

@@ -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

stack.yaml

@@ -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

templates/challenge-all-submissions.hamlet

@@ -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}

templates/show-challenge.hamlet

@@ -2,3 +2,7 @@
   <tt> #{repoUrl repo}
   \ Branch:
   <tt> #{repoBranch repo}
+
+<h2>Leaderboard
+
+^{Table.buildBootstrap leaderboardTable leaderboardWithRanks}