diff --git a/Handler/CreateChallenge.hs b/Handler/CreateChallenge.hs index 66b495a..07f2db0 100644 --- a/Handler/CreateChallenge.hs +++ b/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, diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index d467dba..fd8f061 100644 --- a/Handler/ShowChallenge.hs +++ b/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 - 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 diff --git a/Handler/Tables.hs b/Handler/Tables.hs new file mode 100644 index 0000000..9c977f7 --- /dev/null +++ b/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) diff --git a/Handler/YourAccount.hs b/Handler/YourAccount.hs index 58ca425..6653d43 100644 --- a/Handler/YourAccount.hs +++ b/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 diff --git a/Model.hs b/Model.hs index f6820d4..ab15558 100644 --- a/Model.hs +++ b/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: diff --git a/PersistMetric.hs b/PersistMetric.hs new file mode 100644 index 0000000..1383df2 --- /dev/null +++ b/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 diff --git a/config/models b/config/models index ec3117c..be6d909 100644 --- a/config/models +++ b/config/models @@ -33,6 +33,7 @@ Challenge stamp UTCTime default=now() Test challenge ChallengeId + metric Metric Maybe name Text checksum SHA1 commit SHA1 diff --git a/gonito.cabal b/gonito.cabal index 7e26918..231b35d 100644 --- a/gonito.cabal +++ b/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 diff --git a/stack.yaml b/stack.yaml index 44d1937..15caf75 100644 --- a/stack.yaml +++ b/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 diff --git a/templates/challenge-all-submissions.hamlet b/templates/challenge-all-submissions.hamlet index ac7b7c6..9d2edd5 100644 --- a/templates/challenge-all-submissions.hamlet +++ b/templates/challenge-all-submissions.hamlet @@ -1 +1,3 @@ +

(This is a long list of all submissions, if you want to see only the best, click leaderboard.) + ^{Table.buildBootstrap (submissionsTable tests) submissions} diff --git a/templates/show-challenge.hamlet b/templates/show-challenge.hamlet index ed049e1..a97bccf 100644 --- a/templates/show-challenge.hamlet +++ b/templates/show-challenge.hamlet @@ -2,3 +2,7 @@ #{repoUrl repo} \ Branch: #{repoBranch repo} + +

Leaderboard + +^{Table.buildBootstrap leaderboardTable leaderboardWithRanks}