gonito/Handler/Tables.hs

206 lines
11 KiB
Haskell
Raw Normal View History

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,
leaderboardBestVariant :: Variant,
leaderboardBestVariantId :: VariantId,
2015-12-12 18:53:20 +01:00
leaderboardEvaluation :: Evaluation,
2017-03-18 15:57:27 +01:00
leaderboardNumberOfSubmissions :: Int,
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
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
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)
++ 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
leaderboardDescriptionCell :: Table site (a, LeaderboardEntry)
2017-03-18 15:57:27 +01:00
leaderboardDescriptionCell = Table.widget "description" (
\(_,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"
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)
statusCellWidget :: Eq a => Text -> RepoScheme -> Repo -> (SubmissionId, Submission, a, Maybe a) -> WidgetFor App ()
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
Just $ browsableGitRepoBranch repoScheme challengeRepo challengeName publicSubmissionBranch
2016-02-16 21:26:57 +01:00
else
Nothing
2016-02-16 21:10:10 +01:00
getAuxSubmissionEnts :: Key Test -> [TableEntry] -> [(Key User, (User, [(Entity Submission, Entity Variant, Evaluation)]))]
getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluationMaps
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 -> []))
2018-07-24 15:02:37 +02:00
getLeaderboardEntriesByCriterion :: (Ord a) => Key Challenge -> (TableEntry -> a) -> Handler (Test, [LeaderboardEntry])
getLeaderboardEntriesByCriterion challengeId selector = do
2015-12-12 18:53:20 +01:00
(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
2018-07-24 15:02:37 +02:00
let auxItems = map (\i -> (selector i, [i])) $ filter (\(TableEntry _ _ _ em _ _) -> member mainTestId em) $ evaluationMaps
let auxItemsMap = Map.fromListWith (++) auxItems
2015-12-12 18:53:20 +01:00
let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluation a) (evaluationScore $ leaderboardEvaluation b)
2018-07-24 15:02:37 +02:00
entries' <- mapM (toLeaderboardEntry challengeId mainTestEnt) $ filter (\ll -> not (null ll)) $ map snd $ Map.toList auxItemsMap
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 15:02:37 +02:00
toLeaderboardEntry :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site, Foldable t) => Key Challenge -> Entity Test -> t TableEntry -> HandlerFor site LeaderboardEntry
toLeaderboardEntry challengeId (Entity mainTestId mainTest) ss = do
let bestOne = DL.maximumBy submissionComparator ss
2018-07-24 15:02:37 +02:00
let (TableEntry bestSubmission bestVariant user evals _ _) = bestOne
let bestEvaluation = evals Map.! mainTestId
let submissionId = entityKey bestSubmission
2017-03-18 15:57:27 +01:00
tagEnts <- runDB $ getTags submissionId
parameters <- runDB $ selectList [ParameterVariant ==. (entityKey bestVariant)] [Asc ParameterName]
-- get all user submissions, including hidden ones
2018-07-24 15:02:37 +02:00
allUserSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId, SubmissionSubmitter ==. entityKey user] [Desc SubmissionStamp]
2017-03-18 15:57:27 +01:00
return $ LeaderboardEntry {
2018-07-24 15:02:37 +02:00
leaderboardUser = entityVal user,
leaderboardUserId = entityKey user,
leaderboardBestSubmission = entityVal bestSubmission,
leaderboardBestSubmissionId = entityKey bestSubmission,
leaderboardBestVariant = entityVal bestVariant,
leaderboardBestVariantId = entityKey bestVariant,
leaderboardEvaluation = bestEvaluation,
leaderboardNumberOfSubmissions = length allUserSubmissions,
leaderboardTags = tagEnts,
leaderboardParams = map entityVal parameters
2017-02-25 22:53:17 +01:00
}
2018-07-24 15:02:37 +02:00
where submissionComparator (TableEntry _ _ _ em1 _ _) (TableEntry _ _ _ em2 _ _) = (compareResult mainTest) (evaluationScore (em1 Map.! mainTestId)) (evaluationScore (em2 Map.! mainTestId))
2017-02-25 22:53:17 +01:00
2018-07-24 15:02:37 +02:00
getLeaderboardEntries :: Key Challenge -> Handler (Test, [LeaderboardEntry])
getLeaderboardEntries challengeId = getLeaderboardEntriesByCriterion challengeId (\(TableEntry _ _ (Entity userId _) _ _ _) -> userId)
2017-02-25 22:53:17 +01:00
2015-12-12 18:53:20 +01:00
compareResult :: Test -> Maybe Double -> Maybe Double -> Ordering
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
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] []
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
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
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