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
|
2019-12-14 10:56:07 +01:00
|
|
|
|
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
|
2021-02-22 12:44:33 +01:00
|
|
|
|
import Handler.JWT
|
2015-12-12 18:53:20 +01:00
|
|
|
|
|
2021-05-29 19:12:24 +02:00
|
|
|
|
import Prelude (read)
|
|
|
|
|
|
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
|
2019-08-12 18:19:02 +02:00
|
|
|
|
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 Data.Proxy as DPR
|
|
|
|
|
import Control.Lens hiding ((.=), (^.))
|
|
|
|
|
import Data.HashMap.Strict.InsOrd (fromList)
|
|
|
|
|
|
2021-07-23 22:14:57 +02:00
|
|
|
|
import qualified Data.Set as S
|
|
|
|
|
|
2019-08-29 09:39:21 +02:00
|
|
|
|
data TestReference = TestReference Text Text
|
|
|
|
|
deriving (Show, Eq, Ord)
|
|
|
|
|
|
2020-12-31 08:46:35 +01:00
|
|
|
|
instance ToJSON TestReference where
|
2021-03-03 15:50:26 +01:00
|
|
|
|
toJSON (TestReference metric n) = object
|
|
|
|
|
[ "name" .= n,
|
2021-05-29 19:12:24 +02:00
|
|
|
|
"metric" .= (Data.Text.pack $ evaluationSchemeName $ read $ Data.Text.unpack metric)
|
2020-12-31 08:46:35 +01:00
|
|
|
|
]
|
|
|
|
|
|
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
|
|
|
|
|
2019-08-29 09:39:21 +02: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,
|
2018-07-24 14:08:47 +02:00
|
|
|
|
leaderboardBestVariant :: Variant,
|
|
|
|
|
leaderboardBestVariantId :: VariantId,
|
2019-08-29 09:39:21 +02:00
|
|
|
|
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],
|
2021-02-22 12:44:33 +01:00
|
|
|
|
leaderboardVersion :: (Int, Int, Int),
|
|
|
|
|
leaderboardIsVisible :: Bool,
|
2021-03-03 15:50:26 +01:00
|
|
|
|
leaderboardIsReevaluable :: Bool,
|
|
|
|
|
leaderboardTeam :: Maybe (Entity Team)
|
2015-12-12 18:53:20 +01:00
|
|
|
|
}
|
|
|
|
|
|
2021-07-23 22:14:57 +02:00
|
|
|
|
-- | Finds parameters shared by all entries (including values) and removes
|
|
|
|
|
-- them from the entries
|
|
|
|
|
extractCommonParams :: [TableEntry] -> ([Entity Parameter], [TableEntry])
|
|
|
|
|
extractCommonParams [] = ([], [])
|
|
|
|
|
extractCommonParams entries@(firstEntry:_) = (commonParams, map removeParams entries)
|
|
|
|
|
where commonParams = filter (\p -> paramToNameVal p `S.member` commonNameVals) $ tableEntryParams firstEntry
|
|
|
|
|
commonNameVals =
|
|
|
|
|
DL.foldl intersection hS tS
|
|
|
|
|
(hS:tS) = map (S.fromList
|
|
|
|
|
. map paramToNameVal
|
|
|
|
|
. tableEntryParams) entries
|
|
|
|
|
paramToNameVal (Entity _ p) = (parameterName p, parameterValue p)
|
|
|
|
|
removeParams e
|
|
|
|
|
= e { tableEntryParams = filter (\p -> paramToNameVal p `S.notMember` commonNameVals) $ tableEntryParams e }
|
|
|
|
|
|
2018-11-12 10:11:58 +01:00
|
|
|
|
data TableEntry = TableEntry {
|
|
|
|
|
tableEntrySubmission :: Entity Submission,
|
|
|
|
|
tableEntryVariant :: Entity Variant,
|
|
|
|
|
tableEntrySubmitter :: Entity User,
|
2019-08-29 09:39:21 +02:00
|
|
|
|
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,
|
2021-03-03 15:50:26 +01:00
|
|
|
|
tableEntryVersion :: (Int, Int, Int),
|
|
|
|
|
tableEntryTeam :: Maybe (Entity Team) }
|
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
|
|
|
|
|
2021-03-03 15:50:26 +01:00
|
|
|
|
formatSubmittingEntity :: TableEntry -> Text
|
|
|
|
|
formatSubmittingEntity tableEntry =
|
|
|
|
|
case tableEntryTeam tableEntry of
|
|
|
|
|
Just teamEnt -> teamIdent $ entityVal teamEnt
|
|
|
|
|
Nothing -> formatSubmitter $ entityVal $ tableEntrySubmitter tableEntry
|
|
|
|
|
|
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-11-12 10:11:58 +01:00
|
|
|
|
++ Table.int "#" tableEntryRank
|
2021-03-03 15:50:26 +01:00
|
|
|
|
++ Table.text "submitter" formatSubmittingEntity
|
2018-11-12 10:11:58 +01:00
|
|
|
|
++ 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
|
2019-08-29 09:39:21 +02:00
|
|
|
|
++ 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
|
|
|
|
|
2019-11-30 11:04:52 +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)
|
2019-08-29 09:39:21 +02:00
|
|
|
|
++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScore $ getTestReference e)) tests)
|
2019-11-30 11:25:53 +01:00
|
|
|
|
++ 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" (
|
2021-03-03 15:50:26 +01:00
|
|
|
|
\(TableEntry (Entity _ s) (Entity _ v) (Entity _ _) _ tagEnts paramEnts _ _ _) -> fragmentWithSubmissionTags
|
|
|
|
|
(descriptionToBeShown s v (map entityVal paramEnts))
|
|
|
|
|
(getInfoLink s mauthId)
|
|
|
|
|
tagEnts)
|
2018-07-14 19:44:33 +02:00
|
|
|
|
|
2021-07-23 20:01:50 +02:00
|
|
|
|
formatListWithLimit :: Int -> (a -> Text) -> [a] -> Text
|
|
|
|
|
formatListWithLimit limit fun l = (Data.Text.unwords $ map fun $ Import.take limit l) <>
|
|
|
|
|
(if length l <= limit
|
|
|
|
|
then ""
|
|
|
|
|
else " [...]")
|
|
|
|
|
|
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
|
2021-07-23 20:01:50 +02:00
|
|
|
|
maximumNumberOfParamsShown = 8
|
|
|
|
|
paramsShown = formatListWithLimit maximumNumberOfParamsShown formatParameter params
|
2017-02-25 22:53:17 +01:00
|
|
|
|
|
2019-08-29 09:39:21 +02: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
|
|
|
|
|
2021-03-03 15:50:26 +01:00
|
|
|
|
formatSubmittingEntityInLeaderboard :: LeaderboardEntry -> Text
|
|
|
|
|
formatSubmittingEntityInLeaderboard entry =
|
|
|
|
|
case leaderboardTeam entry of
|
|
|
|
|
Just teamEnt -> teamIdent $ entityVal teamEnt
|
|
|
|
|
Nothing -> formatSubmitter $ leaderboardUser entry
|
|
|
|
|
|
|
|
|
|
|
2018-09-08 19:21:06 +02: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
|
2021-03-03 15:50:26 +01:00
|
|
|
|
++ Table.text "submitter" (formatSubmittingEntityInLeaderboard . snd)
|
2016-02-17 09:43:25 +01:00
|
|
|
|
++ 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
|
2019-08-29 09:39:21 +02:00
|
|
|
|
++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScoreFromLeaderboardEntry (getTestReference e) . snd)) tests)
|
2016-02-17 09:43:25 +01:00
|
|
|
|
++ Table.int "×" (leaderboardNumberOfSubmissions . snd)
|
2018-06-06 13:43:17 +02:00
|
|
|
|
++ 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
|
|
|
|
|
2019-12-16 16:39: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
|
2019-12-16 16:39:20 +01:00
|
|
|
|
++ 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))
|
2019-12-16 16:39:20 +01:00
|
|
|
|
|
|
|
|
|
|
2019-08-29 09:39:21 +02:00
|
|
|
|
extractScoreFromLeaderboardEntry :: TestReference -> LeaderboardEntry -> Maybe Evaluation
|
2018-09-08 19:21:06 +02:00
|
|
|
|
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" (
|
2018-07-24 14:08:47 +02:00
|
|
|
|
\(_,entry) -> fragmentWithSubmissionTags (descriptionToBeShown (leaderboardBestSubmission entry)
|
|
|
|
|
(leaderboardBestVariant entry)
|
|
|
|
|
(leaderboardParams entry))
|
2018-11-03 21:37:44 +01:00
|
|
|
|
(getInfoLink (leaderboardBestSubmission entry)
|
|
|
|
|
mauthId)
|
2018-07-24 14:08:47 +02:00
|
|
|
|
(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
|
2018-06-06 13:43:17 +02:00
|
|
|
|
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
|
|
|
|
|
|
2021-03-03 15:50:26 +01:00
|
|
|
|
textCellSoftLimit :: Int
|
2020-09-05 23:26:53 +02:00
|
|
|
|
textCellSoftLimit = 140
|
2021-03-03 15:50:26 +01:00
|
|
|
|
|
|
|
|
|
textCellHardLimit :: Int
|
2020-09-05 23:26:53 +02:00
|
|
|
|
textCellHardLimit = 5 * textCellSoftLimit
|
|
|
|
|
|
2021-03-03 15:50:26 +01:00
|
|
|
|
limitedWidget :: Int -> Int -> Text -> WidgetFor site ()
|
2020-09-05 23:26:53 +02:00
|
|
|
|
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
|
2019-12-14 10:56:07 +01:00
|
|
|
|
isReevaluable <- handlerToWidget $ runDB $ canBeReevaluated submissionId
|
2020-03-28 20:59:10 +01:00
|
|
|
|
isVisible <- handlerToWidget $ runDB $ checkWhetherVisible submission mauthId
|
2019-12-14 10:56:07 +01:00
|
|
|
|
$(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
|
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
|
|
|
|
|
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
|
|
|
|
|
|
2020-03-28 20:52:12 +01:00
|
|
|
|
-- 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
|
2020-03-28 20:52:12 +01:00
|
|
|
|
where isPublic = submissionIsPublic submission
|
|
|
|
|
isOwner = (mauthId == Just userId)
|
2020-03-28 20:59:10 +01:00
|
|
|
|
userId = submissionSubmitter submission
|
2020-03-28 20:52:12 +01:00
|
|
|
|
|
|
|
|
|
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
|
2020-03-28 20:52:12 +01:00
|
|
|
|
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
|
2020-03-28 20:52:12 +01:00
|
|
|
|
isOwner = (seerId == userId)
|
2020-03-28 20:59:10 +01:00
|
|
|
|
userId = submissionSubmitter submission
|
2018-11-03 21:37:44 +01:00
|
|
|
|
|
2019-08-29 09:39:21 +02:00
|
|
|
|
getAuxSubmissionEnts :: TestReference -> [TableEntry] -> [(Key User, (User, [(Entity Submission, Entity Variant, Evaluation)]))]
|
2018-06-27 13:09:11 +02:00
|
|
|
|
getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluationMaps
|
2021-03-03 15:50:26 +01:00
|
|
|
|
where processEvaluationMap (TableEntry s v (Entity ui u) m _ _ _ _ _) = (ui, (u, case Map.lookup testId m of
|
2019-08-29 10:01:36 +02:00
|
|
|
|
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)
|
|
|
|
|
|
2019-12-16 16:39:20 +01:00
|
|
|
|
getLeaderboardEntriesByCriterion :: (Ord a) => Int
|
2020-01-04 10:32:52 +01:00
|
|
|
|
-> 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
|
2018-09-08 19:21:06 +02:00
|
|
|
|
let mainTests = getMainTests tests
|
2016-02-11 21:54:22 +01:00
|
|
|
|
let mainTestEnt = getMainTest tests
|
2019-08-29 09:39:21 +02:00
|
|
|
|
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))
|
2019-08-29 09:39:21 +02:00
|
|
|
|
$ filter (\entry -> member mainTestRef $ tableEntryMapping entry)
|
2018-09-08 19:21:06 +02:00
|
|
|
|
$ 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))
|
2018-09-08 19:21:06 +02:00
|
|
|
|
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'
|
2018-09-08 19:21:06 +02:00
|
|
|
|
return (entries, (evaluationMaps, mainTests))
|
2017-03-18 15:57:27 +01:00
|
|
|
|
|
2019-08-29 21:34:13 +02:00
|
|
|
|
|
2021-02-22 12:44:33 +01:00
|
|
|
|
toLeaderboardEntry :: Foldable t => Key Challenge -> [Entity Test] -> t TableEntry -> Handler LeaderboardEntry
|
2018-09-08 19:21:06 +02:00
|
|
|
|
toLeaderboardEntry challengeId tests ss = do
|
2018-06-27 13:09:11 +02:00
|
|
|
|
let bestOne = DL.maximumBy submissionComparator ss
|
2021-03-03 15:50:26 +01:00
|
|
|
|
let (TableEntry bestSubmission bestVariant user evals _ _ _ _ _) = bestOne
|
2018-07-24 14:08:47 +02:00
|
|
|
|
let submissionId = entityKey bestSubmission
|
2017-03-18 15:57:27 +01:00
|
|
|
|
tagEnts <- runDB $ getTags submissionId
|
2018-07-24 14:08:47 +02:00
|
|
|
|
|
2021-02-22 12:44:33 +01:00
|
|
|
|
theParameters <- runDB $ selectList [ParameterVariant ==. (entityKey bestVariant)] [Asc ParameterName]
|
2018-07-24 14:08:47 +02:00
|
|
|
|
|
2019-08-29 21:34:13 +02:00
|
|
|
|
submission <- runDB $ get404 submissionId
|
2021-03-03 15:50:26 +01:00
|
|
|
|
(Just (Entity _ itsVersion)) <- runDB $ getBy $ UniqueVersionByCommit $ submissionVersion submission
|
2019-08-29 21:34:13 +02:00
|
|
|
|
|
2021-03-03 15:50:26 +01:00
|
|
|
|
let theVersion = (versionMajor itsVersion,
|
|
|
|
|
versionMinor itsVersion,
|
|
|
|
|
versionPatch itsVersion)
|
2019-08-29 21:34:13 +02:00
|
|
|
|
|
2018-06-27 13:09:11 +02:00
|
|
|
|
-- 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]
|
2021-02-22 12:44:33 +01:00
|
|
|
|
|
|
|
|
|
mUserId <- maybeAuthPossiblyByToken
|
|
|
|
|
|
|
|
|
|
isReevaluable <- runDB $ canBeReevaluated $ entityKey $ tableEntrySubmission bestOne
|
|
|
|
|
isVisible <- runDB $ checkWhetherVisible submission (entityKey <$> mUserId)
|
|
|
|
|
|
2021-03-03 15:50:26 +01:00
|
|
|
|
mTeam <- case submissionTeam $ entityVal bestSubmission of
|
|
|
|
|
Just teamId -> do
|
|
|
|
|
team <- runDB $ get404 teamId
|
|
|
|
|
return $ Just (Entity teamId team)
|
|
|
|
|
Nothing -> return Nothing
|
|
|
|
|
|
2017-03-18 15:57:27 +01:00
|
|
|
|
return $ LeaderboardEntry {
|
2018-07-24 15:02:37 +02:00
|
|
|
|
leaderboardUser = entityVal user,
|
|
|
|
|
leaderboardUserId = entityKey user,
|
2018-07-24 14:08:47 +02:00
|
|
|
|
leaderboardBestSubmission = entityVal bestSubmission,
|
|
|
|
|
leaderboardBestSubmissionId = entityKey bestSubmission,
|
|
|
|
|
leaderboardBestVariant = entityVal bestVariant,
|
|
|
|
|
leaderboardBestVariantId = entityKey bestVariant,
|
2018-09-08 19:21:06 +02:00
|
|
|
|
leaderboardEvaluationMap = evals,
|
2018-06-27 13:09:11 +02:00
|
|
|
|
leaderboardNumberOfSubmissions = length allUserSubmissions,
|
2018-07-24 14:08:47 +02:00
|
|
|
|
leaderboardTags = tagEnts,
|
2021-02-22 12:44:33 +01:00
|
|
|
|
leaderboardParams = map entityVal theParameters,
|
|
|
|
|
leaderboardVersion = theVersion,
|
|
|
|
|
leaderboardIsReevaluable = isReevaluable,
|
2021-03-03 15:50:26 +01:00
|
|
|
|
leaderboardIsVisible = isVisible,
|
|
|
|
|
leaderboardTeam = mTeam
|
2017-02-25 22:53:17 +01:00
|
|
|
|
}
|
2019-08-29 09:39:21 +02:00
|
|
|
|
where mainTestEnt@(Entity _ mainTest) = getMainTest tests
|
|
|
|
|
mainTestRef = getTestReference mainTestEnt
|
2021-03-03 15:50:26 +01:00
|
|
|
|
submissionComparator (TableEntry _ _ _ em1 _ _ _ v1 _) (TableEntry _ _ _ em2 _ _ _ v2 _) =
|
2019-08-29 21:34:13 +02:00
|
|
|
|
(compareMajorVersions v1 v2)
|
|
|
|
|
<>
|
2019-08-29 09:39:21 +02:00
|
|
|
|
(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
|
|
|
|
|
2019-12-16 16:39:20 +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)
|
2020-01-04 10:32:52 +01:00
|
|
|
|
onlyTheBestVariant
|
2018-11-12 10:11:58 +01:00
|
|
|
|
(\entry -> [entityKey $ tableEntrySubmitter entry])
|
2019-12-16 16:39:20 +01:00
|
|
|
|
getLeaderboardEntries maxPriority ByTag challengeId =
|
|
|
|
|
getLeaderboardEntriesByCriterion maxPriority
|
|
|
|
|
challengeId
|
2018-09-08 21:21:21 +02:00
|
|
|
|
(const True)
|
2020-01-04 10:32:52 +01:00
|
|
|
|
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
|
2019-08-12 18:19:02 +02:00
|
|
|
|
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
|
|
|
|
|
|
2020-01-04 10:32:52 +01:00
|
|
|
|
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)
|
2020-01-04 10:32:52 +01:00
|
|
|
|
-> ([(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
|
2019-08-29 09:39:21 +02:00
|
|
|
|
|
|
|
|
|
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
|
|
|
|
|
|
2020-01-02 21:12:34 +01:00
|
|
|
|
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
|
2019-11-30 11:04:52 +01:00
|
|
|
|
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
|
2020-01-02 21:12:34 +01:00
|
|
|
|
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
|
2020-01-02 21:12:34 +01:00
|
|
|
|
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
|
2021-02-27 11:48:30 +01:00
|
|
|
|
E.&&. (evaluation ^. EvaluationVersion E.==. submission ^. SubmissionVersion)
|
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
|
|
|
|
|
2020-01-02 21:12:34 +01:00
|
|
|
|
data BasicSubmissionInfo = BasicSubmissionInfo {
|
|
|
|
|
basicSubmissionInfoUser :: User,
|
2021-02-05 14:44:46 +01:00
|
|
|
|
basicSubmissionInfoTagEnts :: [(Entity Import.Tag, Entity SubmissionTag)],
|
2021-03-03 15:50:26 +01:00
|
|
|
|
basicSubmissionInfoVersion :: Version,
|
|
|
|
|
basicSubmissionInfoTeam :: Maybe (Entity Team) }
|
2020-01-02 21:12:34 +01:00
|
|
|
|
|
|
|
|
|
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
|
2021-03-03 15:50:26 +01:00
|
|
|
|
mTeam <- case submissionTeam submission of
|
|
|
|
|
Just teamId -> do
|
|
|
|
|
team <- get404 teamId
|
|
|
|
|
return $ Just (Entity teamId team)
|
|
|
|
|
Nothing -> return Nothing
|
2020-01-02 21:12:34 +01:00
|
|
|
|
tagEnts <- getTags submissionId
|
|
|
|
|
let versionHash = submissionVersion submission
|
2021-03-03 15:50:26 +01:00
|
|
|
|
(Entity _ ver) <- getBy404 $ UniqueVersionByCommit versionHash
|
2020-01-02 21:12:34 +01:00
|
|
|
|
return $ (submissionId, BasicSubmissionInfo {
|
|
|
|
|
basicSubmissionInfoUser = user,
|
|
|
|
|
basicSubmissionInfoTagEnts = tagEnts,
|
2021-03-03 15:50:26 +01:00
|
|
|
|
basicSubmissionInfoVersion = ver,
|
|
|
|
|
basicSubmissionInfoTeam = mTeam })
|
2020-01-02 21:12:34 +01:00
|
|
|
|
|
2021-02-27 13:39:48 +01:00
|
|
|
|
getEvaluationMap :: (PersistUniqueRead backend,
|
|
|
|
|
PersistQueryRead backend,
|
|
|
|
|
BackendCompatible SqlBackend backend,
|
|
|
|
|
MonadIO m,
|
|
|
|
|
BaseBackend backend ~ SqlBackend)
|
|
|
|
|
=> Map (Key Test) TestReference
|
|
|
|
|
-> Map (Key Submission) BasicSubmissionInfo
|
|
|
|
|
-> (Int, (Entity Submission, Entity Variant))
|
|
|
|
|
-> ReaderT backend m TableEntry
|
2020-01-02 21:12:34 +01:00
|
|
|
|
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
|
2021-02-27 13:39:48 +01:00
|
|
|
|
let theVersion = basicSubmissionInfoVersion submissionInfo
|
2019-12-14 14:10:50 +01:00
|
|
|
|
let versionHash = submissionVersion submission
|
2021-03-03 15:50:26 +01:00
|
|
|
|
let team = basicSubmissionInfoTeam submissionInfo
|
2021-02-27 13:39:48 +01:00
|
|
|
|
|
|
|
|
|
evaluations <- E.select $ E.from $ \(evaluation, out) ->
|
|
|
|
|
do
|
|
|
|
|
E.where_ (out ^. OutVariant E.==. E.val variantId
|
|
|
|
|
E.&&. evaluation ^. EvaluationTest E.==. out ^. OutTest
|
|
|
|
|
E.&&. evaluation ^. EvaluationChecksum E.==. out ^. OutChecksum
|
|
|
|
|
E.&&. evaluation ^. EvaluationVersion E.==. E.val versionHash)
|
|
|
|
|
E.orderBy [E.asc (out ^. OutId)]
|
|
|
|
|
return evaluation
|
|
|
|
|
|
2019-08-29 09:39:21 +02:00
|
|
|
|
let pairs = map (\(Entity _ e) -> (evaluationTest e, e)) evaluations
|
2020-01-02 21:12:34 +01:00
|
|
|
|
let pairs' = map (\(testId, e) -> (testsMap Map.! testId, e)) pairs
|
2019-08-29 09:39:21 +02:00
|
|
|
|
let m = Map.fromList pairs'
|
2018-07-14 17:10:07 +02:00
|
|
|
|
|
2021-03-03 15:50:26 +01:00
|
|
|
|
params <- selectList [ParameterVariant ==. variantId] [Asc ParameterName]
|
2018-07-14 17:10:07 +02:00
|
|
|
|
|
2021-02-27 13:39:48 +01:00
|
|
|
|
let major = versionMajor theVersion
|
|
|
|
|
let minor = versionMinor theVersion
|
2021-03-03 15:50:26 +01:00
|
|
|
|
let pat = versionPatch theVersion
|
2019-08-29 10:01:36 +02:00
|
|
|
|
|
2021-03-03 15:50:26 +01:00
|
|
|
|
return $ TableEntry s v (Entity (submissionSubmitter submission) user) m tagEnts params rank (major, minor, pat) team
|