From b38342fb0e116e4d42d3508dfa9f2f7b8fb71efc Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Wed, 3 Mar 2021 15:50:26 +0100 Subject: [PATCH] Teams are shown --- Handler/ShowChallenge.hs | 11 +++--- Handler/Tables.hs | 84 +++++++++++++++++++++++++++------------- 2 files changed, 64 insertions(+), 31 deletions(-) diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index aaa62f8..85379fe 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -647,7 +647,8 @@ trigger userId challengeName theUrl mBranch mGitAnnexRemote = do challengeSubmissionDataRepo = RepoSpec { repoSpecUrl=theUrl, repoSpecBranch=branch, - repoSpecGitAnnexRemote=mGitAnnexRemote} + repoSpecGitAnnexRemote=mGitAnnexRemote}, + challengeSubmissionDataTeam = Nothing } case mChallengeEnt of @@ -1356,8 +1357,8 @@ getTestProgressR m d = runViewProgress $ doTestProgress m d doTestProgress :: Int -> Int -> Channel -> Handler () doTestProgress m d chan = do - forM [1..m] $ (\i -> do - msg chan $ (Data.Text.pack $ ("GO\n" ++ show i)) - liftIO $ threadDelay (d * 1000000) - return ()) + _ <- forM [1..m] $ (\i -> do + msg chan $ (Data.Text.pack $ ("GO\n" ++ show i)) + liftIO $ threadDelay (d * 1000000) + return ()) return () diff --git a/Handler/Tables.hs b/Handler/Tables.hs index d8eacce..d8cdce3 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -31,8 +31,6 @@ import GEval.EvaluationScheme import GEval.ParseParams (parseParamsFromFilePath, OutputFileParsed(..)) 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) @@ -41,8 +39,8 @@ data TestReference = TestReference Text Text deriving (Show, Eq, Ord) instance ToJSON TestReference where - toJSON (TestReference metric name) = object - [ "name" .= name, + toJSON (TestReference metric n) = object + [ "name" .= n, "metric" .= metric ] @@ -73,7 +71,8 @@ data LeaderboardEntry = LeaderboardEntry { leaderboardParams :: [Parameter], leaderboardVersion :: (Int, Int, Int), leaderboardIsVisible :: Bool, - leaderboardIsReevaluable :: Bool + leaderboardIsReevaluable :: Bool, + leaderboardTeam :: Maybe (Entity Team) } data TableEntry = TableEntry { @@ -84,15 +83,22 @@ data TableEntry = TableEntry { tableEntryTagsInfo :: [(Entity Import.Tag, Entity SubmissionTag)], tableEntryParams :: [Entity Parameter], tableEntryRank :: Int, - tableEntryVersion :: (Int, Int, Int) } + tableEntryVersion :: (Int, Int, Int), + tableEntryTeam :: Maybe (Entity Team) } tableEntryStamp :: TableEntry -> UTCTime tableEntryStamp = submissionStamp . entityVal . tableEntrySubmission +formatSubmittingEntity :: TableEntry -> Text +formatSubmittingEntity tableEntry = + case tableEntryTeam tableEntry of + Just teamEnt -> teamIdent $ entityVal teamEnt + Nothing -> formatSubmitter $ entityVal $ tableEntrySubmitter tableEntry + submissionsTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App TableEntry submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty ++ Table.int "#" tableEntryRank - ++ Table.text "submitter" (formatSubmitter . entityVal . tableEntrySubmitter) + ++ Table.text "submitter" formatSubmittingEntity ++ timestampCell "when" tableEntryStamp ++ Table.text "ver." (formatVersion . tableEntryVersion) ++ descriptionCell mauthId @@ -125,10 +131,10 @@ paramExtractor paramName = Table.text paramName (\entry -> descriptionCell :: Maybe UserId -> Table App TableEntry descriptionCell mauthId = Table.widget "description" ( - \(TableEntry (Entity _ s) (Entity _ v) (Entity u _) _ tagEnts paramEnts _ _) -> fragmentWithSubmissionTags - (descriptionToBeShown s v (map entityVal paramEnts)) - (getInfoLink s mauthId) - tagEnts) + \(TableEntry (Entity _ s) (Entity _ v) (Entity _ _) _ tagEnts paramEnts _ _ _) -> fragmentWithSubmissionTags + (descriptionToBeShown s v (map entityVal paramEnts)) + (getInfoLink s mauthId) + tagEnts) descriptionToBeShown :: Submission -> Variant -> [Parameter] -> Text @@ -144,10 +150,17 @@ descriptionToBeShown s v params = (submissionDescription s) ++ (Data.Text.pack v extractScore :: TestReference -> TableEntry -> Maybe Evaluation extractScore k tableEntry = lookup k $ tableEntryMapping tableEntry +formatSubmittingEntityInLeaderboard :: LeaderboardEntry -> Text +formatSubmittingEntityInLeaderboard entry = + case leaderboardTeam entry of + Just teamEnt -> teamIdent $ entityVal teamEnt + Nothing -> formatSubmitter $ leaderboardUser entry + + leaderboardTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App (Int, LeaderboardEntry) leaderboardTable mauthId challengeName repoScheme challengeRepo tests = mempty ++ Table.int "#" fst - ++ Table.text "submitter" (formatSubmitter . leaderboardUser . snd) + ++ Table.text "submitter" (formatSubmittingEntityInLeaderboard . snd) ++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd) ++ Table.text "ver." (formatVersion . leaderboardVersion . snd) ++ leaderboardDescriptionCell mauthId @@ -214,9 +227,13 @@ textLimited limit t | otherwise = (Data.Text.take limit t) <> "…" where l = length t +textCellSoftLimit :: Int textCellSoftLimit = 140 + +textCellHardLimit :: Int textCellHardLimit = 5 * textCellSoftLimit +limitedWidget :: Int -> Int -> Text -> WidgetFor site () limitedWidget softLimit hardLimit v = [whamlet|#{textLimited softLimit v}|] @@ -286,7 +303,7 @@ checkWhetherVisible submission (Just seerId) = do getAuxSubmissionEnts :: TestReference -> [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 + where processEvaluationMap (TableEntry s v (Entity ui u) m _ _ _ _ _) = (ui, (u, case Map.lookup testId m of Just e -> [(s, v, e)] Nothing -> [])) @@ -335,18 +352,18 @@ getLeaderboardEntriesByCriterion maxPriority challengeId condition preselector s toLeaderboardEntry :: Foldable t => Key Challenge -> [Entity Test] -> t TableEntry -> Handler LeaderboardEntry toLeaderboardEntry challengeId tests ss = do let bestOne = DL.maximumBy submissionComparator ss - let (TableEntry bestSubmission bestVariant user evals _ _ _ _) = bestOne + let (TableEntry bestSubmission bestVariant user evals _ _ _ _ _) = bestOne let submissionId = entityKey bestSubmission tagEnts <- runDB $ getTags submissionId theParameters <- runDB $ selectList [ParameterVariant ==. (entityKey bestVariant)] [Asc ParameterName] submission <- runDB $ get404 submissionId - (Just (Entity _ version)) <- runDB $ getBy $ UniqueVersionByCommit $ submissionVersion submission + (Just (Entity _ itsVersion)) <- runDB $ getBy $ UniqueVersionByCommit $ submissionVersion submission - let theVersion = (versionMajor version, - versionMinor version, - versionPatch version) + let theVersion = (versionMajor itsVersion, + versionMinor itsVersion, + versionPatch itsVersion) -- get all user submissions, including hidden ones allUserSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId, @@ -358,6 +375,12 @@ toLeaderboardEntry challengeId tests ss = do isReevaluable <- runDB $ canBeReevaluated $ entityKey $ tableEntrySubmission bestOne isVisible <- runDB $ checkWhetherVisible submission (entityKey <$> mUserId) + mTeam <- case submissionTeam $ entityVal bestSubmission of + Just teamId -> do + team <- runDB $ get404 teamId + return $ Just (Entity teamId team) + Nothing -> return Nothing + return $ LeaderboardEntry { leaderboardUser = entityVal user, leaderboardUserId = entityKey user, @@ -371,11 +394,12 @@ toLeaderboardEntry challengeId tests ss = do leaderboardParams = map entityVal theParameters, leaderboardVersion = theVersion, leaderboardIsReevaluable = isReevaluable, - leaderboardIsVisible = isVisible + leaderboardIsVisible = isVisible, + leaderboardTeam = mTeam } where mainTestEnt@(Entity _ mainTest) = getMainTest tests mainTestRef = getTestReference mainTestEnt - submissionComparator (TableEntry _ _ _ em1 _ _ _ v1) (TableEntry _ _ _ em2 _ _ _ v2) = + submissionComparator (TableEntry _ _ _ em1 _ _ _ v1 _) (TableEntry _ _ _ em2 _ _ _ v2 _) = (compareMajorVersions v1 v2) <> (compareResult mainTest) (evaluationScore (em1 Map.! mainTestRef)) @@ -484,7 +508,8 @@ getScore testId variantId = do data BasicSubmissionInfo = BasicSubmissionInfo { basicSubmissionInfoUser :: User, basicSubmissionInfoTagEnts :: [(Entity Import.Tag, Entity SubmissionTag)], - basicSubmissionInfoVersion :: Version } + basicSubmissionInfoVersion :: Version, + basicSubmissionInfoTeam :: Maybe (Entity Team) } getBasicSubmissionInfo :: (MonadIO m, PersistQueryRead backend, PersistUniqueRead backend, @@ -492,13 +517,19 @@ getBasicSubmissionInfo :: (MonadIO m, PersistQueryRead backend, => Entity Submission -> ReaderT backend m (SubmissionId, BasicSubmissionInfo) getBasicSubmissionInfo (Entity submissionId submission) = do user <- get404 $ submissionSubmitter submission + mTeam <- case submissionTeam submission of + Just teamId -> do + team <- get404 teamId + return $ Just (Entity teamId team) + Nothing -> return Nothing tagEnts <- getTags submissionId let versionHash = submissionVersion submission - (Entity _ version) <- getBy404 $ UniqueVersionByCommit versionHash + (Entity _ ver) <- getBy404 $ UniqueVersionByCommit versionHash return $ (submissionId, BasicSubmissionInfo { basicSubmissionInfoUser = user, basicSubmissionInfoTagEnts = tagEnts, - basicSubmissionInfoVersion = version }) + basicSubmissionInfoVersion = ver, + basicSubmissionInfoTeam = mTeam }) getEvaluationMap :: (PersistUniqueRead backend, PersistQueryRead backend, @@ -515,6 +546,7 @@ getEvaluationMap testsMap submissionsMap (rank, (s@(Entity submissionId submissi let tagEnts = basicSubmissionInfoTagEnts submissionInfo let theVersion = basicSubmissionInfoVersion submissionInfo let versionHash = submissionVersion submission + let team = basicSubmissionInfoTeam submissionInfo evaluations <- E.select $ E.from $ \(evaluation, out) -> do @@ -529,10 +561,10 @@ getEvaluationMap testsMap submissionsMap (rank, (s@(Entity submissionId submissi let pairs' = map (\(testId, e) -> (testsMap Map.! testId, e)) pairs let m = Map.fromList pairs' - parameters <- selectList [ParameterVariant ==. variantId] [Asc ParameterName] + params <- selectList [ParameterVariant ==. variantId] [Asc ParameterName] let major = versionMajor theVersion let minor = versionMinor theVersion - let patch = versionPatch theVersion + let pat = versionPatch theVersion - return $ TableEntry s v (Entity (submissionSubmitter submission) user) m tagEnts parameters rank (major, minor, patch) + return $ TableEntry s v (Entity (submissionSubmitter submission) user) m tagEnts params rank (major, minor, pat) team