gonito/Handler/Tables.hs

518 lines
27 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
import Handler.Evaluate
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
2020-09-05 23:26:53 +02:00
import Data.Diff
2015-12-12 18:53:20 +01:00
import qualified Yesod.Table as Table
import Yesod.Table (Table)
2018-11-12 10:11:58 +01:00
import qualified Database.Esqueleto as E
import Database.Esqueleto ((^.))
2015-12-12 18:53:20 +01:00
import qualified Data.Map as Map
2019-12-14 18:21:47 +01:00
import Data.Text (pack, unpack, unwords, take)
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
import GEval.EvaluationScheme
2015-12-12 18:53:20 +01:00
2018-07-14 19:44:33 +02:00
import GEval.ParseParams (parseParamsFromFilePath, OutputFileParsed(..))
2016-02-17 09:34:34 +01:00
2021-02-05 14:44:46 +01:00
import Data.Swagger hiding (get)
import qualified Data.Swagger as DS
import Data.Swagger.Declare
import Data.Proxy as DPR
import Control.Lens hiding ((.=), (^.))
import Data.HashMap.Strict.InsOrd (fromList)
data TestReference = TestReference Text Text
deriving (Show, Eq, Ord)
2020-12-31 08:46:35 +01:00
instance ToJSON TestReference where
toJSON (TestReference metric name) = object
[ "name" .= name,
"metric" .= metric
]
2021-02-05 14:44:46 +01:00
instance ToSchema TestReference where
declareNamedSchema _ = do
stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
return $ NamedSchema (Just "TestReference") $ mempty
& type_ .~ SwaggerObject
& properties .~
Data.HashMap.Strict.InsOrd.fromList [ ("name", stringSchema)
, ("metric", stringSchema)
]
& required .~ [ "name", "metric" ]
2020-12-31 08:46:35 +01:00
getTestReference :: Entity Test -> TestReference
getTestReference (Entity _ test) = TestReference (Data.Text.pack $ show $ testMetric test) (testName test)
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 TestReference Evaluation,
2017-03-18 15:57:27 +01:00
leaderboardNumberOfSubmissions :: Int,
2021-02-05 14:44:46 +01:00
leaderboardTags :: [(Entity Import.Tag, Entity SubmissionTag)],
2019-08-29 21:34:13 +02:00
leaderboardParams :: [Parameter],
leaderboardVersion :: (Int, Int, Int)
2015-12-12 18:53:20 +01:00
}
2018-11-12 10:11:58 +01:00
data TableEntry = TableEntry {
tableEntrySubmission :: Entity Submission,
tableEntryVariant :: Entity Variant,
tableEntrySubmitter :: Entity User,
tableEntryMapping :: Map TestReference Evaluation,
2021-02-05 14:44:46 +01:00
tableEntryTagsInfo :: [(Entity Import.Tag, Entity SubmissionTag)],
2018-11-12 10:11:58 +01:00
tableEntryParams :: [Entity Parameter],
2019-08-29 10:01:36 +02:00
tableEntryRank :: Int,
tableEntryVersion :: (Int, Int, Int) }
2018-07-28 17:04:27 +02:00
2018-09-21 17:55:00 +02:00
tableEntryStamp :: TableEntry -> UTCTime
2018-11-12 10:11:58 +01:00
tableEntryStamp = submissionStamp . entityVal . tableEntrySubmission
2018-09-21 17:55:00 +02:00
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-11-12 10:11:58 +01:00
++ Table.int "#" tableEntryRank
++ Table.text "submitter" (formatSubmitter . entityVal . tableEntrySubmitter)
++ timestampCell "when" tableEntryStamp
2019-08-29 10:01:36 +02:00
++ Table.text "ver." (formatVersion . tableEntryVersion)
2018-11-03 21:37:44 +01:00
++ descriptionCell mauthId
++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScore $ getTestReference e)) tests)
2018-11-12 10:11:58 +01:00
++ statusCell challengeName repoScheme challengeRepo (\tableEntry -> (entityKey $ tableEntrySubmission tableEntry,
entityVal $ tableEntrySubmission tableEntry,
entityKey $ tableEntryVariant tableEntry,
entityVal $ tableEntryVariant tableEntry,
mauthId))
2017-02-25 22:53:17 +01:00
variantTable :: [Text] -> [Entity Test] -> Table App TableEntry
variantTable paramNames tests = mempty
2018-11-12 14:12:51 +01:00
++ Table.int "#" tableEntryRank
++ mconcat (map paramExtractor paramNames)
++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScore $ getTestReference e)) tests)
++ Table.widget "" variantStatusCellWidget
variantStatusCellWidget :: TableEntry -> WidgetFor App ()
variantStatusCellWidget entry = $(widgetFile "variant-status")
where theVariantId = entityKey $ tableEntryVariant entry
2018-11-12 14:12:51 +01:00
paramExtractor :: Text -> Table App TableEntry
paramExtractor paramName = Table.text paramName (\entry ->
fromMaybe ""
$ listToMaybe
$ map parameterValue
$ filter (\p -> parameterName p == paramName)
$ map entityVal
$ tableEntryParams entry)
2018-11-03 21:37:44 +01:00
descriptionCell :: Maybe UserId -> Table App TableEntry
descriptionCell mauthId = Table.widget "description" (
2019-08-29 10:01:36 +02:00
\(TableEntry (Entity _ s) (Entity _ v) (Entity u _) _ tagEnts paramEnts _ _) -> fragmentWithSubmissionTags
(descriptionToBeShown s v (map entityVal paramEnts))
2020-03-28 20:59:10 +01:00
(getInfoLink s mauthId)
2019-08-29 10:01:36 +02:00
tagEnts)
2018-07-14 19:44:33 +02:00
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
extractScore :: TestReference -> TableEntry -> Maybe Evaluation
2018-11-12 10:11:58 +01:00
extractScore k tableEntry = lookup k $ tableEntryMapping tableEntry
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)
2019-08-29 21:34:13 +02:00
++ Table.text "ver." (formatVersion . leaderboardVersion . snd)
2018-11-03 21:37:44 +01:00
++ leaderboardDescriptionCell mauthId
++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScoreFromLeaderboardEntry (getTestReference e) . snd)) tests)
2016-02-17 09:43:25 +01:00
++ Table.int "×" (leaderboardNumberOfSubmissions . snd)
++ statusCell challengeName repoScheme challengeRepo (\(_, e) -> (leaderboardBestSubmissionId e,
2020-03-28 20:59:10 +01:00
leaderboardBestSubmission e,
leaderboardBestVariantId e,
leaderboardBestVariant e,
mauthId))
2015-12-12 18:53:20 +01:00
altLeaderboardTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App (Int, LeaderboardEntry)
altLeaderboardTable mauthId challengeName repoScheme challengeRepo tests = mempty
++ Table.int "#" fst
2019-12-16 16:51:52 +01:00
++ leaderboardOnlyTagsCell mauthId
++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScoreFromLeaderboardEntry (getTestReference e) . snd)) tests)
++ statusCell challengeName repoScheme challengeRepo (\(_, e) -> (leaderboardBestSubmissionId e,
2020-03-28 20:59:10 +01:00
leaderboardBestSubmission e,
leaderboardBestVariantId e,
leaderboardBestVariant e,
mauthId))
extractScoreFromLeaderboardEntry :: TestReference -> LeaderboardEntry -> Maybe Evaluation
extractScoreFromLeaderboardEntry k entry = lookup k (leaderboardEvaluationMap entry)
2018-11-03 21:37:44 +01:00
leaderboardDescriptionCell :: Maybe UserId -> Table App (a, LeaderboardEntry)
leaderboardDescriptionCell mauthId = Table.widget "description" (
\(_,entry) -> fragmentWithSubmissionTags (descriptionToBeShown (leaderboardBestSubmission entry)
(leaderboardBestVariant entry)
(leaderboardParams entry))
2018-11-03 21:37:44 +01:00
(getInfoLink (leaderboardBestSubmission entry)
mauthId)
(leaderboardTags entry)
)
2017-03-18 15:57:27 +01:00
2019-12-16 16:51:52 +01:00
leaderboardOnlyTagsCell :: Maybe UserId -> Table App (a, LeaderboardEntry)
leaderboardOnlyTagsCell mauthId = Table.widget "tags" (
\(_,entry) -> fragmentWithSubmissionTags ("" :: Text)
(getInfoLink (leaderboardBestSubmission entry)
mauthId)
(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"
2020-03-28 20:59:10 +01:00
statusCell :: Text -> RepoScheme -> Repo -> (a -> (SubmissionId, Submission, VariantId, Variant, 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
2020-09-05 16:45:09 +02:00
resultCell test fun = hoverTextCell (formatTestForHtml test) (formatTruncatedScore formattingOpts . fun) (formatFullScore . fun)
where formattingOpts = getTestFormattingOpts test
2016-02-17 09:34:34 +01:00
2019-12-14 18:21:47 +01:00
textLimited :: Int -> Text -> Text
textLimited limit t
| l < limit = t
| otherwise = (Data.Text.take limit t) <> ""
where l = length t
2020-09-05 23:26:53 +02:00
textCellSoftLimit = 140
textCellHardLimit = 5 * textCellSoftLimit
limitedWidget softLimit hardLimit v =
[whamlet|<span title="#{textLimited hardLimit v}"><tt>#{textLimited softLimit v}</tt>|]
2019-12-14 18:21:47 +01:00
limitedTextCell :: Text -> Int -> Int -> (a -> Text) -> Table site a
limitedTextCell h softLimit hardLimit textFun = Table.widget h (
2020-09-05 23:26:53 +02:00
\v -> limitedWidget softLimit hardLimit (textFun v))
2019-12-14 18:21:47 +01:00
theLimitedTextCell :: Text -> (a -> Text) -> Table site a
2020-09-05 23:26:53 +02:00
theLimitedTextCell h textFun = limitedTextCell h textCellSoftLimit textCellHardLimit textFun
2019-12-14 18:21:47 +01:00
2020-09-05 23:26:53 +02:00
theLimitedDiffTextCell :: Text -> (a -> Diff Text) -> Table site a
theLimitedDiffTextCell h textFun = Table.widget h (
\v -> case textFun v of
OneThing u -> limitedWidget textCellSoftLimit textCellHardLimit u
d@(TwoThings _ _) -> [whamlet|#{d}|])
2019-12-14 18:21:47 +01:00
2020-03-28 20:59:10 +01:00
statusCellWidget :: Text -> RepoScheme -> Repo -> (SubmissionId, Submission, VariantId, Variant, Maybe UserId) -> WidgetFor App ()
statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, variantId, _, mauthId) = do
isReevaluable <- handlerToWidget $ runDB $ canBeReevaluated submissionId
2020-03-28 20:59:10 +01:00
isVisible <- handlerToWidget $ runDB $ checkWhetherVisible submission mauthId
$(widgetFile "submission-status")
2016-02-16 21:10:10 +01:00
where commitHash = fromSHA1ToText $ submissionCommit submission
isPublic = submissionIsPublic submission
2020-03-28 20:59:10 +01:00
isOwner = (mauthId == Just (submissionSubmitter submission))
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
2020-03-28 20:59:10 +01:00
getInfoLink :: Submission -> Maybe UserId -> Maybe (Route App)
getInfoLink submission mauthId = if checkSimpleVisibility submission mauthId
then Just $ QueryResultsR commitHash
else Nothing
2018-11-03 21:37:44 +01:00
where commitHash = fromSHA1ToText $ submissionCommit submission
-- sometimes we checker whether we got a teacher, but sometimes
-- fall back to a simpler check...
2020-03-28 20:59:10 +01:00
checkSimpleVisibility :: Submission -> Maybe UserId -> Bool
checkSimpleVisibility submission mauthId = isPublic || isOwner
where isPublic = submissionIsPublic submission
isOwner = (mauthId == Just userId)
2020-03-28 20:59:10 +01:00
userId = submissionSubmitter submission
checkWhetherVisible :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend)
2020-03-28 20:59:10 +01:00
=> Submission -> Maybe (Key User) -> ReaderT backend m Bool
checkWhetherVisible submission Nothing = return $ submissionIsPublic submission
checkWhetherVisible submission (Just seerId) = do
let challengeId = submissionChallenge submission
achvs <- E.select $ E.from $ \(achievement, course, participant, teacher) -> do
E.where_ (achievement ^. AchievementChallenge E.==. E.val challengeId
E.&&. achievement ^. AchievementCourse E.==. course ^. CourseId
E.&&. participant ^. ParticipantUser E.==. E.val userId
E.&&. participant ^. ParticipantCourse E.==. course ^. CourseId
E.&&. teacher ^. TeacherUser E.==. E.val seerId
E.&&. teacher ^. TeacherCourse E.==. course ^. CourseId)
E.limit 2
return ()
let isTeacher = case achvs of
[] -> False
_ -> True
return (isPublic || isOwner || isTeacher)
2018-11-03 21:37:44 +01:00
where isPublic = submissionIsPublic submission
isOwner = (seerId == userId)
2020-03-28 20:59:10 +01:00
userId = submissionSubmitter submission
2018-11-03 21:37:44 +01:00
getAuxSubmissionEnts :: TestReference -> [TableEntry] -> [(Key User, (User, [(Entity Submission, Entity Variant, Evaluation)]))]
getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluationMaps
2019-08-29 10:01:36 +02:00
where processEvaluationMap (TableEntry s v (Entity ui u) m _ _ _ _) = (ui, (u, case Map.lookup testId m of
Just e -> [(s, v, e)]
Nothing -> []))
2016-02-12 23:21:26 +01:00
2019-08-29 21:34:13 +02:00
compareMajorVersions :: (Int, Int, Int) -> (Int, Int, Int) -> Ordering
compareMajorVersions (aM, _, _) (bM, _, _) = aM `compare` bM
compareVersions :: (Int, Int, Int) -> (Int, Int, Int) -> Ordering
compareVersions (aM, aN, aP) (bM, bN, bP) = (aM `compare` bM)
<> (aN `compare` bN)
<> (aP `compare` bP)
getLeaderboardEntriesByCriterion :: (Ord a) => Int
-> Key Challenge
-> ((Entity Submission) -> Bool)
-> ([(Int, (Entity Submission, Entity Variant))] -> [(Int, (Entity Submission, Entity Variant))])
-> (TableEntry -> [a])
-> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
getLeaderboardEntriesByCriterion maxPriority challengeId condition preselector selector = do
(evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos maxPriority condition (const True) preselector challengeId
let mainTests = getMainTests tests
2016-02-11 21:54:22 +01:00
let mainTestEnt = getMainTest tests
let mainTestRef = getTestReference mainTestEnt
let (Entity _ mainTest) = mainTestEnt
2018-09-08 21:21:21 +02:00
let auxItems = concat
$ map (\i -> map (\s -> (s, [i])) (selector i))
$ filter (\entry -> member mainTestRef $ tableEntryMapping entry)
$ evaluationMaps
2018-07-24 15:02:37 +02:00
let auxItemsMap = Map.fromListWith (++) auxItems
2019-08-29 21:34:13 +02:00
let entryComparator a b =
(compareMajorVersions (leaderboardVersion a) (leaderboardVersion b))
<>
((compareResult mainTest) (evaluationScore $ leaderboardEvaluationMap a Map.! mainTestRef)
(evaluationScore $ leaderboardEvaluationMap b Map.! mainTestRef))
<>
(compareVersions (leaderboardVersion a) (leaderboardVersion b))
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
2019-08-29 21:34:13 +02:00
toLeaderboardEntry :: (Foldable t, YesodPersist site, PersistQueryRead (YesodPersistBackend site), PersistUniqueRead (YesodPersistBackend site), BaseBackend (YesodPersistBackend site) ~ SqlBackend) => Key Challenge -> [Entity Test] -> t TableEntry -> HandlerFor site LeaderboardEntry
toLeaderboardEntry challengeId tests ss = do
let bestOne = DL.maximumBy submissionComparator ss
2019-08-29 10:01:36 +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]
2019-08-29 21:34:13 +02:00
submission <- runDB $ get404 submissionId
(Just (Entity _ version)) <- runDB $ getBy $ UniqueVersionByCommit $ submissionVersion submission
let theVersion = (versionMajor version,
versionMinor version,
versionPatch version)
-- 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,
2019-08-29 21:34:13 +02:00
leaderboardParams = map entityVal parameters,
leaderboardVersion = theVersion
2017-02-25 22:53:17 +01:00
}
where mainTestEnt@(Entity _ mainTest) = getMainTest tests
mainTestRef = getTestReference mainTestEnt
2019-08-29 21:34:13 +02:00
submissionComparator (TableEntry _ _ _ em1 _ _ _ v1) (TableEntry _ _ _ em2 _ _ _ v2) =
(compareMajorVersions v1 v2)
<>
(compareResult mainTest) (evaluationScore (em1 Map.! mainTestRef))
(evaluationScore (em2 Map.! mainTestRef))
2019-08-29 21:34:13 +02:00
<>
(compareVersions v1 v2)
2017-02-25 22:53:17 +01:00
getLeaderboardEntries :: Int -> LeaderboardStyle -> Key Challenge -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
getLeaderboardEntries maxPriority BySubmitter challengeId =
getLeaderboardEntriesByCriterion maxPriority
challengeId
2018-07-28 21:53:13 +02:00
(const True)
onlyTheBestVariant
2018-11-12 10:11:58 +01:00
(\entry -> [entityKey $ tableEntrySubmitter entry])
getLeaderboardEntries maxPriority ByTag challengeId =
getLeaderboardEntriesByCriterion maxPriority
challengeId
2018-09-08 21:21:21 +02:00
(const True)
onlyTheBestVariant
2018-09-08 21:21:21 +02:00
(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 $ evaluationSchemeMetric $ testMetric test) x y
2015-12-12 18:53:20 +01:00
compareResult _ (Just _) Nothing = GT
compareResult _ Nothing (Just _) = LT
compareResult _ Nothing Nothing = EQ
onlyTheBestVariant :: [(Int, (Entity Submission, Entity Variant))] -> [(Int, (Entity Submission, Entity Variant))]
2020-01-04 20:53:24 +01:00
onlyTheBestVariant = DL.nubBy (\(_, (Entity aid _, _)) (_, (Entity bid _, _)) -> aid == bid)
. (sortBy (\(r1, (_, Entity _ va)) (r2, (_, Entity _ vb)) -> (r1 `compare` r2)
`thenCmp`
((variantName va) `compare` (variantName vb))))
2019-12-14 22:24:22 +01:00
getChallengeSubmissionInfos :: (MonadIO m,
PersistQueryRead backend,
BackendCompatible SqlBackend backend,
PersistUniqueRead backend, BaseBackend backend ~ SqlBackend)
=> Int
-> (Entity Submission -> Bool)
-> (Entity Variant -> Bool)
-> ([(Int, (Entity Submission, Entity Variant))] -> [(Int, (Entity Submission, Entity Variant))])
-> Key Challenge
-> ReaderT backend m ([TableEntry], [Entity Test])
getChallengeSubmissionInfos maxMetricPriority condition variantCondition preselector challengeId = do
challenge <- get404 challengeId
let commit = challengeVersion challenge
2019-12-14 22:24:22 +01:00
tests' <- selectList [TestChallenge ==. challengeId, TestActive ==. True, TestCommit ==. commit] []
let tests = filter (\t -> (evaluationSchemePriority $ testMetric $ entityVal t) <= maxMetricPriority) tests'
2018-11-12 10:11:58 +01:00
let mainTest = getMainTest tests
2018-11-12 14:12:51 +01:00
allSubmissionsVariants <- E.select $ E.from $ \(submission, variant) -> do
2018-11-12 10:11:58 +01:00
E.where_ (submission ^. SubmissionChallenge E.==. E.val challengeId
2018-11-17 09:49:25 +01:00
E.&&. submission ^. SubmissionIsHidden E.==. E.val False
2018-11-12 10:11:58 +01:00
E.&&. variant ^. VariantSubmission E.==. submission ^. SubmissionId)
return (submission, variant)
2018-11-12 14:12:51 +01:00
scores <- mapM (getScore (entityKey mainTest)) $ map (entityKey . snd) allSubmissionsVariants
2018-11-12 10:11:58 +01:00
let allSubmissionsVariantsWithRanks =
2020-01-04 20:53:24 +01:00
sortBy (\(r1, (s1, _)) (r2, (s2, _)) -> (submissionStamp (entityVal s2) `compare` submissionStamp (entityVal s1))
2018-11-12 10:11:58 +01:00
`thenCmp`
(r2 `compare` r1))
2020-01-04 20:53:24 +01:00
$ preselector
2018-11-12 10:11:58 +01:00
$ filter (\(_, (s, _)) -> condition s)
$ map (\(rank, (_, sv)) -> (rank, sv))
$ zip [1..]
$ sortBy (\(s1, _) (s2, _) -> compareResult (entityVal mainTest) s2 s1)
$ zip scores allSubmissionsVariants
allTests <- selectList [] [Asc TestName]
let testsMap = Map.fromList $ map (\(ent@(Entity testId _)) -> (testId, getTestReference ent)) allTests
let allSubmissions = DL.nubBy (\(Entity a _) (Entity b _) -> a == b) $ map (\(_, (s, _)) -> s) allSubmissionsVariantsWithRanks
subs <- mapM getBasicSubmissionInfo allSubmissions
let submissionMap = Map.fromList subs
-- testsMap and submissionMap are created to speed up getEvaluationMap
evaluationMaps' <- mapM (getEvaluationMap testsMap submissionMap) allSubmissionsVariantsWithRanks
let evaluationMaps = filter (variantCondition . tableEntryVariant) evaluationMaps'
2018-11-12 10:11:58 +01:00
return (evaluationMaps, tests)
2019-12-14 14:10:50 +01:00
getScore :: (MonadIO m, BackendCompatible SqlBackend backend,
PersistQueryRead backend, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend)
=> Key Test -> Key Variant -> ReaderT backend m (Maybe Double)
2018-11-12 10:11:58 +01:00
getScore testId variantId = do
evaluations <- E.select $ E.from $ \(out, evaluation, variant, submission) -> do
2018-11-12 10:11:58 +01:00
E.where_ (out ^. OutVariant E.==. E.val variantId
E.&&. variant ^. VariantId E.==. E.val variantId
E.&&. submission ^. SubmissionId E.==. variant ^. VariantSubmission
2018-11-12 10:11:58 +01:00
E.&&. out ^. OutTest E.==. E.val testId
E.&&. out ^. OutChecksum E.==. evaluation ^. EvaluationChecksum
2019-12-14 14:10:50 +01:00
-- all this complication here and with orderBy due
-- to the legacy issue with evaluation version sometimes missing
E.&&. (evaluation ^. EvaluationVersion E.==. E.just (submission ^. SubmissionVersion)
2019-12-14 14:10:50 +01:00
E.||. E.isNothing (evaluation ^. EvaluationVersion))
2018-11-12 10:11:58 +01:00
E.&&. evaluation ^. EvaluationTest E.==. E.val testId)
2020-01-12 19:27:07 +01:00
E.orderBy [E.asc (evaluation ^. EvaluationScore)]
2018-11-12 10:11:58 +01:00
return evaluation
return $ case evaluations of
(e:_) -> evaluationScore $ entityVal e
[] -> Nothing
2018-11-12 14:12:51 +01:00
data BasicSubmissionInfo = BasicSubmissionInfo {
basicSubmissionInfoUser :: User,
2021-02-05 14:44:46 +01:00
basicSubmissionInfoTagEnts :: [(Entity Import.Tag, Entity SubmissionTag)],
basicSubmissionInfoVersion :: Version }
getBasicSubmissionInfo :: (MonadIO m, PersistQueryRead backend,
PersistUniqueRead backend,
BaseBackend backend ~ SqlBackend)
=> Entity Submission -> ReaderT backend m (SubmissionId, BasicSubmissionInfo)
getBasicSubmissionInfo (Entity submissionId submission) = do
2018-11-12 14:12:51 +01:00
user <- get404 $ submissionSubmitter submission
tagEnts <- getTags submissionId
let versionHash = submissionVersion submission
(Entity _ version) <- getBy404 $ UniqueVersionByCommit versionHash
return $ (submissionId, BasicSubmissionInfo {
basicSubmissionInfoUser = user,
basicSubmissionInfoTagEnts = tagEnts,
basicSubmissionInfoVersion = version })
getEvaluationMap :: (MonadIO m, PersistQueryRead backend, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend)
=> Map.Map TestId TestReference
-> Map.Map SubmissionId BasicSubmissionInfo
-> (Int, (Entity Submission, Entity Variant)) -> ReaderT backend m TableEntry
getEvaluationMap testsMap submissionsMap (rank, (s@(Entity submissionId submission), v@(Entity variantId _))) = do
let submissionInfo = submissionsMap Map.! submissionId
let user = basicSubmissionInfoUser submissionInfo
let tagEnts = basicSubmissionInfoTagEnts submissionInfo
let version = basicSubmissionInfoVersion submissionInfo
2020-01-12 19:27:07 +01:00
outs <- selectList [OutVariant ==. variantId] [Asc OutId]
2019-12-14 14:10:50 +01:00
let versionHash = submissionVersion submission
maybeEvaluations <- mapM (\(Entity _ o) -> fetchTheEvaluation o versionHash) outs
2015-12-12 18:53:20 +01:00
let evaluations = catMaybes maybeEvaluations
let pairs = map (\(Entity _ e) -> (evaluationTest e, e)) evaluations
let pairs' = map (\(testId, e) -> (testsMap Map.! testId, e)) pairs
let m = Map.fromList pairs'
2018-07-14 17:10:07 +02:00
2018-11-12 14:12:51 +01:00
parameters <- selectList [ParameterVariant ==. variantId] [Asc ParameterName]
2018-07-14 17:10:07 +02:00
2019-08-29 10:01:36 +02:00
let major = versionMajor version
let minor = versionMinor version
let patch = versionPatch version
return $ TableEntry s v (Entity (submissionSubmitter submission) user) m tagEnts parameters rank (major, minor, patch)