gonito/Handler/Tables.hs

244 lines
13 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,
leaderboardEvaluationMap :: Map (Key Test) 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
2018-07-28 17:04:27 +02:00
-- TODO change into a record
tableEntryParams (TableEntry _ _ _ _ _ paramEnts) = paramEnts
tableEntryMapping (TableEntry _ _ _ mapping _ _) = mapping
tableEntryTagsInfo (TableEntry _ _ _ _ tagsInfo _) = tagsInfo
2018-09-21 17:55:00 +02:00
tableEntryStamp :: TableEntry -> UTCTime
tableEntryStamp (TableEntry submission _ _ _ _ _) = submissionStamp $ entityVal submission
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-30 07:59:38 +02:00
++ statusCell challengeName repoScheme challengeRepo (\(TableEntry (Entity submissionId submission) (Entity variantId variant) (Entity userId _) _ _ _) -> (submissionId, submission, variantId, variant, 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
2018-07-28 17:04:27 +02:00
paramsShown = Data.Text.unwords $ map formatParameter 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 -> [Entity Test] -> Table App (Int, LeaderboardEntry)
leaderboardTable mauthId challengeName repoScheme challengeRepo tests = 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
++ mconcat (map (\(Entity k t) -> resultCell t (extractScoreFromLeaderboardEntry k . snd)) tests)
2016-02-17 09:43:25 +01:00
++ Table.int "×" (leaderboardNumberOfSubmissions . snd)
++ statusCell challengeName repoScheme challengeRepo (\(_, e) -> (leaderboardBestSubmissionId e,
2016-02-16 21:10:10 +01:00
leaderboardBestSubmission e,
2018-07-30 07:59:38 +02:00
leaderboardBestVariantId e,
leaderboardBestVariant e,
2016-02-16 21:10:10 +01:00
leaderboardUserId e,
mauthId))
2015-12-12 18:53:20 +01:00
extractScoreFromLeaderboardEntry :: Key Test -> LeaderboardEntry -> Maybe Evaluation
extractScoreFromLeaderboardEntry k entry = lookup k (leaderboardEvaluationMap entry)
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"
2018-07-30 07:59:38 +02:00
statusCell :: Text -> RepoScheme -> Repo -> (a -> (SubmissionId, Submission, VariantId, Variant, 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 (formatTestForHtml test) (formatTruncatedScore (testPrecision test) . fun) (formatFullScore . fun)
2016-02-17 09:34:34 +01:00
2018-07-30 07:59:38 +02:00
statusCellWidget :: Eq a => Text -> RepoScheme -> Repo -> (SubmissionId, Submission, VariantId, Variant, a, Maybe a) -> WidgetFor App ()
statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, variantId, _, 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-28 21:53:13 +02:00
getLeaderboardEntriesByCriterion :: (Ord a) => Key Challenge
-> ((Entity Submission) -> Bool)
2018-09-08 21:21:21 +02:00
-> (TableEntry -> [a])
-> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
getLeaderboardEntriesByCriterion challengeId condition selector = do
(evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId
let mainTests = getMainTests tests
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-09-08 21:21:21 +02:00
let auxItems = concat
$ map (\i -> map (\s -> (s, [i])) (selector i))
$ filter (\(TableEntry _ _ _ em _ _) -> member mainTestId em)
$ evaluationMaps
2018-07-24 15:02:37 +02:00
let auxItemsMap = Map.fromListWith (++) auxItems
let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluationMap a Map.! mainTestId)
(evaluationScore $ leaderboardEvaluationMap b Map.! mainTestId)
entries' <- mapM (toLeaderboardEntry challengeId mainTests)
2018-07-28 21:53:13 +02:00
$ filter (\ll -> not (null ll))
$ map snd
$ Map.toList auxItemsMap
2018-09-08 21:21:21 +02:00
let entries = DL.nubBy (\a b -> leaderboardBestVariantId a == leaderboardBestVariantId b)
$ sortBy (flip entryComparator) entries'
return (entries, (evaluationMaps, mainTests))
2017-03-18 15:57:27 +01:00
toLeaderboardEntry :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site, Foldable t) => Key Challenge -> [Entity Test] -> t TableEntry -> HandlerFor site LeaderboardEntry
toLeaderboardEntry challengeId tests ss = do
let bestOne = DL.maximumBy submissionComparator ss
2018-07-24 15:02:37 +02:00
let (TableEntry bestSubmission bestVariant user evals _ _) = bestOne
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-28 21:53:13 +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,
leaderboardEvaluationMap = evals,
leaderboardNumberOfSubmissions = length allUserSubmissions,
leaderboardTags = tagEnts,
leaderboardParams = map entityVal parameters
2017-02-25 22:53:17 +01:00
}
where (Entity mainTestId mainTest) = getMainTest tests
submissionComparator (TableEntry _ _ _ em1 _ _) (TableEntry _ _ _ em2 _ _) =
(compareResult mainTest) (evaluationScore (em1 Map.! mainTestId))
(evaluationScore (em2 Map.! mainTestId))
2017-02-25 22:53:17 +01:00
2018-09-08 21:21:21 +02:00
getLeaderboardEntries :: LeaderboardStyle -> Key Challenge -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
getLeaderboardEntries BySubmitter challengeId =
2018-07-28 21:53:13 +02:00
getLeaderboardEntriesByCriterion challengeId
(const True)
2018-09-08 21:21:21 +02:00
(\(TableEntry _ _ (Entity userId _) _ _ _) -> [userId])
getLeaderboardEntries ByTag challengeId =
getLeaderboardEntriesByCriterion challengeId
(const True)
(noEmptyList . (map (entityKey . fst)) . tableEntryTagsInfo)
where noEmptyList [] = [Nothing]
noEmptyList l = map Just l
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
2018-07-28 21:53:13 +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-07-28 21:53:13 +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] []
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