2015-12-12 18:53:20 +01:00
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
|
|
|
|
|
|
module Handler.Tables where
|
|
|
|
|
|
|
|
|
|
import Import
|
2016-02-16 21:26:57 +01:00
|
|
|
|
import Handler.Shared
|
2017-02-25 22:53:17 +01:00
|
|
|
|
import Handler.SubmissionView
|
2017-03-18 15:57:27 +01:00
|
|
|
|
import Handler.TagUtils
|
2015-12-12 18:53:20 +01:00
|
|
|
|
|
|
|
|
|
import qualified Yesod.Table as Table
|
|
|
|
|
import Yesod.Table (Table)
|
|
|
|
|
|
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
|
|
2018-07-14 19:44:33 +02:00
|
|
|
|
import Data.Text (pack, unpack, unwords)
|
2016-02-16 19:00:26 +01:00
|
|
|
|
|
2016-02-16 21:10:10 +01:00
|
|
|
|
import PersistSHA1
|
|
|
|
|
|
2018-01-25 16:34:05 +01:00
|
|
|
|
import qualified Data.List as DL
|
|
|
|
|
|
2015-12-12 18:53:20 +01:00
|
|
|
|
import GEval.Core
|
|
|
|
|
|
2018-07-14 19:44:33 +02:00
|
|
|
|
import GEval.ParseParams (parseParamsFromFilePath, OutputFileParsed(..))
|
2016-02-17 09:34:34 +01:00
|
|
|
|
|
2015-12-12 18:53:20 +01:00
|
|
|
|
data LeaderboardEntry = LeaderboardEntry {
|
|
|
|
|
leaderboardUser :: User,
|
2016-02-16 21:10:10 +01:00
|
|
|
|
leaderboardUserId :: UserId,
|
2015-12-12 18:53:20 +01:00
|
|
|
|
leaderboardBestSubmission :: Submission,
|
2016-02-16 21:10:10 +01:00
|
|
|
|
leaderboardBestSubmissionId :: SubmissionId,
|
2018-07-24 14:08:47 +02:00
|
|
|
|
leaderboardBestVariant :: Variant,
|
|
|
|
|
leaderboardBestVariantId :: VariantId,
|
2015-12-12 18:53:20 +01:00
|
|
|
|
leaderboardEvaluation :: Evaluation,
|
2017-03-18 15:57:27 +01:00
|
|
|
|
leaderboardNumberOfSubmissions :: Int,
|
2018-07-24 14:08:47 +02:00
|
|
|
|
leaderboardTags :: [(Entity Tag, Entity SubmissionTag)],
|
|
|
|
|
leaderboardParams :: [Parameter]
|
2015-12-12 18:53:20 +01:00
|
|
|
|
}
|
|
|
|
|
|
2018-07-14 17:02:30 +02:00
|
|
|
|
data TableEntry = TableEntry (Entity Submission)
|
|
|
|
|
(Entity Variant)
|
|
|
|
|
(Entity User)
|
|
|
|
|
(Map (Key Test) Evaluation)
|
|
|
|
|
[(Entity Tag, Entity SubmissionTag)]
|
2018-07-14 17:10:07 +02:00
|
|
|
|
[Entity Parameter]
|
2018-07-14 17:02:30 +02:00
|
|
|
|
|
|
|
|
|
submissionsTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App TableEntry
|
2018-06-06 13:43:17 +02:00
|
|
|
|
submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty
|
2018-07-14 17:10:07 +02:00
|
|
|
|
++ Table.text "submitter" (formatSubmitter . (\(TableEntry _ _ (Entity _ submitter) _ _ _) -> submitter))
|
|
|
|
|
++ timestampCell "when" (submissionStamp . (\(TableEntry (Entity _ s) _ _ _ _ _) -> s))
|
2017-02-25 22:53:17 +01:00
|
|
|
|
++ descriptionCell
|
2016-02-17 09:43:25 +01:00
|
|
|
|
++ mconcat (map (\(Entity k t) -> resultCell t (extractScore k)) tests)
|
2018-07-14 17:10:07 +02:00
|
|
|
|
++ statusCell challengeName repoScheme challengeRepo (\(TableEntry (Entity submissionId submission) _ (Entity userId _) _ _ _) -> (submissionId, submission, userId, mauthId))
|
2017-02-25 22:53:17 +01:00
|
|
|
|
|
2018-07-14 17:02:30 +02:00
|
|
|
|
descriptionCell :: Table site TableEntry
|
2017-02-25 22:53:17 +01:00
|
|
|
|
descriptionCell = Table.widget "description" (
|
2018-07-14 19:44:33 +02:00
|
|
|
|
\(TableEntry (Entity _ s) (Entity _ v) _ _ tagEnts paramEnts) -> fragmentWithSubmissionTags
|
|
|
|
|
(descriptionToBeShown s v (map entityVal paramEnts))
|
|
|
|
|
tagEnts)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
descriptionToBeShown :: Submission -> Variant -> [Parameter] -> Text
|
|
|
|
|
descriptionToBeShown s v params = (submissionDescription s) ++ (Data.Text.pack vdescription) ++ " " ++ paramsShown
|
|
|
|
|
where (OutputFileParsed r _) = parseParamsFromFilePath (Data.Text.unpack $ variantName v)
|
|
|
|
|
vdescription = if r == "out"
|
|
|
|
|
then
|
|
|
|
|
""
|
|
|
|
|
else
|
|
|
|
|
" " ++ r
|
|
|
|
|
paramsShown = Data.Text.unwords $ map (\p -> parameterName p ++ "=" ++ parameterValue p) params
|
2017-02-25 22:53:17 +01:00
|
|
|
|
|
2018-07-14 17:02:30 +02:00
|
|
|
|
extractScore :: Key Test -> TableEntry -> Maybe Evaluation
|
2018-07-14 17:10:07 +02:00
|
|
|
|
extractScore k (TableEntry _ _ _ m _ _) = lookup k m
|
2016-02-17 09:34:34 +01:00
|
|
|
|
|
2018-06-06 13:43:17 +02:00
|
|
|
|
leaderboardTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> Test -> Table App (Int, LeaderboardEntry)
|
|
|
|
|
leaderboardTable mauthId challengeName repoScheme challengeRepo test = mempty
|
2016-02-17 09:43:25 +01:00
|
|
|
|
++ Table.int "#" fst
|
|
|
|
|
++ Table.text "submitter" (formatSubmitter . leaderboardUser . snd)
|
|
|
|
|
++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd)
|
2017-03-18 15:57:27 +01:00
|
|
|
|
++ leaderboardDescriptionCell
|
2016-02-17 09:43:25 +01:00
|
|
|
|
++ resultCell test ((\e -> Just e) . leaderboardEvaluation . snd)
|
|
|
|
|
++ Table.int "×" (leaderboardNumberOfSubmissions . snd)
|
2018-06-06 13:43:17 +02:00
|
|
|
|
++ statusCell challengeName repoScheme challengeRepo (\(_, e) -> (leaderboardBestSubmissionId e,
|
2016-02-16 21:10:10 +01:00
|
|
|
|
leaderboardBestSubmission e,
|
|
|
|
|
leaderboardUserId e,
|
|
|
|
|
mauthId))
|
2015-12-12 18:53:20 +01:00
|
|
|
|
|
2018-06-27 13:09:11 +02:00
|
|
|
|
leaderboardDescriptionCell :: Table site (a, LeaderboardEntry)
|
2017-03-18 15:57:27 +01:00
|
|
|
|
leaderboardDescriptionCell = Table.widget "description" (
|
2018-07-24 14:08:47 +02:00
|
|
|
|
\(_,entry) -> fragmentWithSubmissionTags (descriptionToBeShown (leaderboardBestSubmission entry)
|
|
|
|
|
(leaderboardBestVariant entry)
|
|
|
|
|
(leaderboardParams entry))
|
|
|
|
|
(leaderboardTags entry)
|
|
|
|
|
)
|
2017-03-18 15:57:27 +01:00
|
|
|
|
|
|
|
|
|
|
2016-02-11 21:54:22 +01:00
|
|
|
|
|
2016-02-16 19:00:26 +01:00
|
|
|
|
hoverTextCell :: Text -> (a -> Text) -> (a -> Text) -> Table site a
|
|
|
|
|
hoverTextCell h mainTextFun hoverTextFun = Table.widget h (
|
|
|
|
|
\v -> [whamlet|<span title="#{hoverTextFun v}">#{mainTextFun v}|])
|
|
|
|
|
|
|
|
|
|
timestampCell :: Text -> (a -> UTCTime) -> Table site a
|
|
|
|
|
timestampCell h timestampFun = hoverTextCell h (Data.Text.pack . shorterFormat . timestampFun) (Data.Text.pack . show . timestampFun)
|
|
|
|
|
where shorterFormat = formatTime defaultTimeLocale "%Y-%m-%d %H:%M"
|
|
|
|
|
|
2018-06-06 13:43:17 +02:00
|
|
|
|
statusCell :: Text -> RepoScheme -> Repo -> (a -> (SubmissionId, Submission, UserId, Maybe UserId)) -> Table App a
|
|
|
|
|
statusCell challengeName repoScheme challengeRepo fun = Table.widget "" (statusCellWidget challengeName repoScheme challengeRepo . fun)
|
2016-02-16 21:10:10 +01:00
|
|
|
|
|
2016-02-17 09:34:34 +01:00
|
|
|
|
resultCell :: Test -> (a -> Maybe Evaluation) -> Table App a
|
|
|
|
|
resultCell test fun = hoverTextCell ((testName test) ++ "/" ++ (Data.Text.pack $ show $ testMetric test)) (formatTruncatedScore (testPrecision test) . fun) (formatFullScore . fun)
|
|
|
|
|
|
2018-06-27 13:09:11 +02:00
|
|
|
|
statusCellWidget :: Eq a => Text -> RepoScheme -> Repo -> (SubmissionId, Submission, a, Maybe a) -> WidgetFor App ()
|
2018-06-06 13:43:17 +02:00
|
|
|
|
statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, userId, mauthId) = $(widgetFile "submission-status")
|
2016-02-16 21:10:10 +01:00
|
|
|
|
where commitHash = fromSHA1ToText $ submissionCommit submission
|
|
|
|
|
isPublic = submissionIsPublic submission
|
|
|
|
|
isOwner = (mauthId == Just userId)
|
|
|
|
|
isVisible = isPublic || isOwner
|
2016-02-16 21:26:57 +01:00
|
|
|
|
publicSubmissionBranch = getPublicSubmissionBranch submissionId
|
|
|
|
|
maybeBrowsableUrl = if isPublic
|
|
|
|
|
then
|
2018-06-06 13:43:17 +02:00
|
|
|
|
Just $ browsableGitRepoBranch repoScheme challengeRepo challengeName publicSubmissionBranch
|
2016-02-16 21:26:57 +01:00
|
|
|
|
else
|
|
|
|
|
Nothing
|
2016-02-16 21:10:10 +01:00
|
|
|
|
|
2018-07-24 14:08:47 +02:00
|
|
|
|
getAuxSubmissionEnts :: Key Test -> [TableEntry] -> [(Key User, (User, [(Entity Submission, Entity Variant, Evaluation)]))]
|
2018-06-27 13:09:11 +02:00
|
|
|
|
getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluationMaps
|
2018-07-24 14:08:47 +02:00
|
|
|
|
where processEvaluationMap (TableEntry s v (Entity ui u) m _ _) = (ui, (u, case Map.lookup testId m of
|
|
|
|
|
Just e -> [(s, v, e)]
|
2016-02-12 23:21:26 +01:00
|
|
|
|
Nothing -> []))
|
|
|
|
|
|
|
|
|
|
|
2016-02-17 09:34:34 +01:00
|
|
|
|
getLeaderboardEntries :: Key Challenge -> Handler (Test, [LeaderboardEntry])
|
2015-12-12 18:53:20 +01:00
|
|
|
|
getLeaderboardEntries challengeId = do
|
|
|
|
|
(evaluationMaps, tests) <- getChallengeSubmissionInfos (\_ -> True) challengeId
|
2016-02-11 21:54:22 +01:00
|
|
|
|
let mainTestEnt = getMainTest tests
|
2015-12-12 18:53:20 +01:00
|
|
|
|
let (Entity mainTestId mainTest) = mainTestEnt
|
2016-02-16 21:10:10 +01:00
|
|
|
|
let auxSubmissions = getAuxSubmissionEnts mainTestId evaluationMaps
|
2015-12-12 18:53:20 +01:00
|
|
|
|
let submissionsByUser = Map.fromListWith (\(u1, l1) (_, l2) -> (u1, l1++l2)) auxSubmissions
|
|
|
|
|
let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluation a) (evaluationScore $ leaderboardEvaluation b)
|
2018-06-27 13:09:11 +02:00
|
|
|
|
entries' <- mapM (toEntry challengeId mainTest) $ filter (\(_, (_, s)) -> not (null s)) $ Map.toList submissionsByUser
|
2017-03-18 15:57:27 +01:00
|
|
|
|
let entries = sortBy (flip entryComparator) entries'
|
2016-02-17 09:34:34 +01:00
|
|
|
|
return (mainTest, entries)
|
2017-03-18 15:57:27 +01:00
|
|
|
|
|
|
|
|
|
|
2018-07-24 14:08:47 +02:00
|
|
|
|
toEntry :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site, Foldable t) => Key Challenge -> Test -> (Key User, (User, t (Entity Submission, Entity Variant, Evaluation))) -> HandlerFor site LeaderboardEntry
|
2018-06-27 13:09:11 +02:00
|
|
|
|
toEntry challengeId mainTest (ui, (u, ss)) = do
|
|
|
|
|
let bestOne = DL.maximumBy submissionComparator ss
|
2018-07-24 14:08:47 +02:00
|
|
|
|
let (bestSubmission, bestVariant, bestEvaluation) = bestOne
|
|
|
|
|
let submissionId = entityKey bestSubmission
|
2017-03-18 15:57:27 +01:00
|
|
|
|
tagEnts <- runDB $ getTags submissionId
|
2018-07-24 14:08:47 +02:00
|
|
|
|
|
|
|
|
|
parameters <- runDB $ selectList [ParameterVariant ==. (entityKey bestVariant)] [Asc ParameterName]
|
|
|
|
|
|
2018-06-27 13:09:11 +02:00
|
|
|
|
-- get all user submissions, including hidden ones
|
|
|
|
|
allUserSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId, SubmissionSubmitter ==. ui] [Desc SubmissionStamp]
|
2017-03-18 15:57:27 +01:00
|
|
|
|
return $ LeaderboardEntry {
|
2015-12-12 18:53:20 +01:00
|
|
|
|
leaderboardUser = u,
|
2016-02-16 21:10:10 +01:00
|
|
|
|
leaderboardUserId = ui,
|
2018-07-24 14:08:47 +02:00
|
|
|
|
leaderboardBestSubmission = entityVal bestSubmission,
|
|
|
|
|
leaderboardBestSubmissionId = entityKey bestSubmission,
|
|
|
|
|
leaderboardBestVariant = entityVal bestVariant,
|
|
|
|
|
leaderboardBestVariantId = entityKey bestVariant,
|
|
|
|
|
leaderboardEvaluation = bestEvaluation,
|
2018-06-27 13:09:11 +02:00
|
|
|
|
leaderboardNumberOfSubmissions = length allUserSubmissions,
|
2018-07-24 14:08:47 +02:00
|
|
|
|
leaderboardTags = tagEnts,
|
|
|
|
|
leaderboardParams = map entityVal parameters
|
2017-02-25 22:53:17 +01:00
|
|
|
|
}
|
2018-07-24 14:08:47 +02:00
|
|
|
|
where submissionComparator (_, _, e1) (_, _, e2) = (compareResult mainTest) (evaluationScore e1) (evaluationScore e2)
|
2017-02-25 22:53:17 +01:00
|
|
|
|
|
|
|
|
|
|
2015-12-12 18:53:20 +01:00
|
|
|
|
compareResult :: Test -> Maybe Double -> Maybe Double -> Ordering
|
2015-12-20 21:00:00 +01:00
|
|
|
|
compareResult test (Just x) (Just y) = (compareFun $ getMetricOrdering $ testMetric test) x y
|
2015-12-12 18:53:20 +01:00
|
|
|
|
compareResult _ (Just _) Nothing = GT
|
|
|
|
|
compareResult _ Nothing (Just _) = LT
|
|
|
|
|
compareResult _ Nothing Nothing = EQ
|
|
|
|
|
|
|
|
|
|
compareFun :: MetricOrdering -> Double -> Double -> Ordering
|
|
|
|
|
compareFun TheLowerTheBetter = flip compare
|
|
|
|
|
compareFun TheHigherTheBetter = compare
|
|
|
|
|
|
2018-07-14 17:02:30 +02:00
|
|
|
|
getChallengeSubmissionInfos :: ((Entity Submission) -> Bool) -> Key Challenge -> Handler ([TableEntry], [Entity Test])
|
2015-12-12 18:53:20 +01:00
|
|
|
|
getChallengeSubmissionInfos condition challengeId = do
|
2018-06-27 13:09:11 +02:00
|
|
|
|
allSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId, SubmissionIsHidden !=. Just True] [Desc SubmissionStamp]
|
2015-12-12 18:53:20 +01:00
|
|
|
|
let submissions = filter condition allSubmissions
|
|
|
|
|
tests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] []
|
2018-07-06 16:54:17 +02:00
|
|
|
|
evaluationMaps <- mapM getEvaluationMapForSubmission submissions
|
|
|
|
|
return (concat evaluationMaps, tests)
|
2015-12-12 18:53:20 +01:00
|
|
|
|
|
2018-07-14 17:02:30 +02:00
|
|
|
|
getEvaluationMapForSubmission :: Entity Submission -> Handler [TableEntry]
|
|
|
|
|
getEvaluationMapForSubmission s@(Entity submissionId _)= do
|
2018-07-06 16:54:17 +02:00
|
|
|
|
variants <- runDB $ selectList [VariantSubmission ==. submissionId] []
|
|
|
|
|
mapM (getEvaluationMap s) variants
|
|
|
|
|
|
2018-07-14 17:02:30 +02:00
|
|
|
|
getEvaluationMap :: Entity Submission -> Entity Variant -> Handler TableEntry
|
|
|
|
|
getEvaluationMap s@(Entity submissionId submission) v@(Entity variantId _) = do
|
2018-07-06 16:54:17 +02:00
|
|
|
|
outs <- runDB $ selectList [OutVariant ==. variantId] []
|
2015-12-12 18:53:20 +01:00
|
|
|
|
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
|
2017-02-25 22:53:17 +01:00
|
|
|
|
tagEnts <- runDB $ getTags submissionId
|
2018-07-14 17:10:07 +02:00
|
|
|
|
|
|
|
|
|
parameters <- runDB $ selectList [ParameterVariant ==. variantId] [Asc ParameterName]
|
|
|
|
|
|
|
|
|
|
return $ TableEntry s v (Entity (submissionSubmitter submission) user) m tagEnts parameters
|