s464900/gonito
1
0
Fork 0
forked from filipg/gonito
Code Issues Pull Requests Projects Releases Wiki Activity

Teams are shown

Browse Source
This commit is contained in:
Filip Gralinski 2021-03-03 15:50:26 +01:00
parent af2c789a83
commit b38342fb0e
2 changed files with 64 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
Handler/ShowChallenge.hs
View File

@ -647,7 +647,8 @@ trigger userId challengeName theUrl mBranch mGitAnnexRemote = do
challengeSubmissionDataRepo = RepoSpec { challengeSubmissionDataRepo = RepoSpec {
repoSpecUrl=theUrl, repoSpecUrl=theUrl,
repoSpecBranch=branch, repoSpecBranch=branch,
repoSpecGitAnnexRemote=mGitAnnexRemote} repoSpecGitAnnexRemote=mGitAnnexRemote},
challengeSubmissionDataTeam = Nothing
} }
case mChallengeEnt of case mChallengeEnt of
@ -1356,8 +1357,8 @@ getTestProgressR m d = runViewProgress $ doTestProgress m d
doTestProgress :: Int -> Int -> Channel -> Handler () doTestProgress :: Int -> Int -> Channel -> Handler ()
doTestProgress m d chan = do doTestProgress m d chan = do
forM [1..m] $ (\i -> do _ <- forM [1..m] $ (\i -> do
msg chan $ (Data.Text.pack $ ("GO\n" ++ show i)) msg chan $ (Data.Text.pack $ ("GO\n" ++ show i))
liftIO $ threadDelay (d * 1000000) liftIO $ threadDelay (d * 1000000)
return ()) return ())
return () return ()

84
Handler/Tables.hs
View File

@ -31,8 +31,6 @@ import GEval.EvaluationScheme
import GEval.ParseParams (parseParamsFromFilePath, OutputFileParsed(..)) import GEval.ParseParams (parseParamsFromFilePath, OutputFileParsed(..))
import Data.Swagger hiding (get) import Data.Swagger hiding (get)
import qualified Data.Swagger as DS
import Data.Swagger.Declare
import Data.Proxy as DPR import Data.Proxy as DPR
import Control.Lens hiding ((.=), (^.)) import Control.Lens hiding ((.=), (^.))
import Data.HashMap.Strict.InsOrd (fromList) import Data.HashMap.Strict.InsOrd (fromList)
@ -41,8 +39,8 @@ data TestReference = TestReference Text Text
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
instance ToJSON TestReference where instance ToJSON TestReference where
toJSON (TestReference metric name) = object toJSON (TestReference metric n) = object
[ "name" .= name, [ "name" .= n,
"metric" .= metric "metric" .= metric
] ]
@ -73,7 +71,8 @@ data LeaderboardEntry = LeaderboardEntry {
leaderboardParams :: [Parameter], leaderboardParams :: [Parameter],
leaderboardVersion :: (Int, Int, Int), leaderboardVersion :: (Int, Int, Int),
leaderboardIsVisible :: Bool, leaderboardIsVisible :: Bool,
leaderboardIsReevaluable :: Bool leaderboardIsReevaluable :: Bool,
leaderboardTeam :: Maybe (Entity Team)
} }
data TableEntry = TableEntry { data TableEntry = TableEntry {
@ -84,15 +83,22 @@ data TableEntry = TableEntry {
tableEntryTagsInfo :: [(Entity Import.Tag, Entity SubmissionTag)], tableEntryTagsInfo :: [(Entity Import.Tag, Entity SubmissionTag)],
tableEntryParams :: [Entity Parameter], tableEntryParams :: [Entity Parameter],
tableEntryRank :: Int, tableEntryRank :: Int,
tableEntryVersion :: (Int, Int, Int) } tableEntryVersion :: (Int, Int, Int),
tableEntryTeam :: Maybe (Entity Team) }
tableEntryStamp :: TableEntry -> UTCTime tableEntryStamp :: TableEntry -> UTCTime
tableEntryStamp = submissionStamp . entityVal . tableEntrySubmission 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 :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App TableEntry
submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty
++ Table.int "#" tableEntryRank ++ Table.int "#" tableEntryRank
++ Table.text "submitter" (formatSubmitter . entityVal . tableEntrySubmitter) ++ Table.text "submitter" formatSubmittingEntity
++ timestampCell "when" tableEntryStamp ++ timestampCell "when" tableEntryStamp
++ Table.text "ver." (formatVersion . tableEntryVersion) ++ Table.text "ver." (formatVersion . tableEntryVersion)
++ descriptionCell mauthId ++ descriptionCell mauthId
@ -125,10 +131,10 @@ paramExtractor paramName = Table.text paramName (\entry ->
descriptionCell :: Maybe UserId -> Table App TableEntry descriptionCell :: Maybe UserId -> Table App TableEntry
descriptionCell mauthId = Table.widget "description" ( descriptionCell mauthId = Table.widget "description" (
\(TableEntry (Entity _ s) (Entity _ v) (Entity u _) _ tagEnts paramEnts _ _) -> fragmentWithSubmissionTags \(TableEntry (Entity _ s) (Entity _ v) (Entity _ _) _ tagEnts paramEnts _ _ _) -> fragmentWithSubmissionTags
(descriptionToBeShown s v (map entityVal paramEnts)) (descriptionToBeShown s v (map entityVal paramEnts))
(getInfoLink s mauthId) (getInfoLink s mauthId)
tagEnts) tagEnts)
descriptionToBeShown :: Submission -> Variant -> [Parameter] -> Text 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 :: TestReference -> TableEntry -> Maybe Evaluation
extractScore k tableEntry = lookup k $ tableEntryMapping tableEntry 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 :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App (Int, LeaderboardEntry)
leaderboardTable mauthId challengeName repoScheme challengeRepo tests = mempty leaderboardTable mauthId challengeName repoScheme challengeRepo tests = mempty
++ Table.int "#" fst ++ Table.int "#" fst
++ Table.text "submitter" (formatSubmitter . leaderboardUser . snd) ++ Table.text "submitter" (formatSubmittingEntityInLeaderboard . snd)
++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd) ++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd)
++ Table.text "ver." (formatVersion . leaderboardVersion . snd) ++ Table.text "ver." (formatVersion . leaderboardVersion . snd)
++ leaderboardDescriptionCell mauthId ++ leaderboardDescriptionCell mauthId
@ -214,9 +227,13 @@ textLimited limit t
| otherwise = (Data.Text.take limit t) <> "…" | otherwise = (Data.Text.take limit t) <> "…"
where l = length t where l = length t
textCellSoftLimit :: Int
textCellSoftLimit = 140 textCellSoftLimit = 140
textCellHardLimit :: Int
textCellHardLimit = 5 * textCellSoftLimit textCellHardLimit = 5 * textCellSoftLimit
limitedWidget :: Int -> Int -> Text -> WidgetFor site ()
limitedWidget softLimit hardLimit v = limitedWidget softLimit hardLimit v =
[whamlet|<span title="#{textLimited hardLimit v}"><tt>#{textLimited softLimit v}</tt>|] [whamlet|<span title="#{textLimited hardLimit v}"><tt>#{textLimited softLimit v}</tt>|]
@ -286,7 +303,7 @@ checkWhetherVisible submission (Just seerId) = do
getAuxSubmissionEnts :: TestReference -> [TableEntry] -> [(Key User, (User, [(Entity Submission, Entity Variant, Evaluation)]))] getAuxSubmissionEnts :: TestReference -> [TableEntry] -> [(Key User, (User, [(Entity Submission, Entity Variant, Evaluation)]))]
getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluationMaps 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)] Just e -> [(s, v, e)]
Nothing -> [])) Nothing -> []))
@ -335,18 +352,18 @@ getLeaderboardEntriesByCriterion maxPriority challengeId condition preselector s
toLeaderboardEntry :: Foldable t => Key Challenge -> [Entity Test] -> t TableEntry -> Handler LeaderboardEntry toLeaderboardEntry :: Foldable t => Key Challenge -> [Entity Test] -> t TableEntry -> Handler LeaderboardEntry
toLeaderboardEntry challengeId tests ss = do toLeaderboardEntry challengeId tests ss = do
let bestOne = DL.maximumBy submissionComparator ss let bestOne = DL.maximumBy submissionComparator ss
let (TableEntry bestSubmission bestVariant user evals _ _ _ _) = bestOne let (TableEntry bestSubmission bestVariant user evals _ _ _ _ _) = bestOne
let submissionId = entityKey bestSubmission let submissionId = entityKey bestSubmission
tagEnts <- runDB $ getTags submissionId tagEnts <- runDB $ getTags submissionId
theParameters <- runDB $ selectList [ParameterVariant ==. (entityKey bestVariant)] [Asc ParameterName] theParameters <- runDB $ selectList [ParameterVariant ==. (entityKey bestVariant)] [Asc ParameterName]
submission <- runDB $ get404 submissionId submission <- runDB $ get404 submissionId
(Just (Entity _ version)) <- runDB $ getBy $ UniqueVersionByCommit $ submissionVersion submission (Just (Entity _ itsVersion)) <- runDB $ getBy $ UniqueVersionByCommit $ submissionVersion submission
let theVersion = (versionMajor version, let theVersion = (versionMajor itsVersion,
versionMinor version, versionMinor itsVersion,
versionPatch version) versionPatch itsVersion)
-- get all user submissions, including hidden ones -- get all user submissions, including hidden ones
allUserSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId, allUserSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId,
@ -358,6 +375,12 @@ toLeaderboardEntry challengeId tests ss = do
isReevaluable <- runDB $ canBeReevaluated $ entityKey $ tableEntrySubmission bestOne isReevaluable <- runDB $ canBeReevaluated $ entityKey $ tableEntrySubmission bestOne
isVisible <- runDB $ checkWhetherVisible submission (entityKey <$> mUserId) 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 { return $ LeaderboardEntry {
leaderboardUser = entityVal user, leaderboardUser = entityVal user,
leaderboardUserId = entityKey user, leaderboardUserId = entityKey user,
@ -371,11 +394,12 @@ toLeaderboardEntry challengeId tests ss = do
leaderboardParams = map entityVal theParameters, leaderboardParams = map entityVal theParameters,
leaderboardVersion = theVersion, leaderboardVersion = theVersion,
leaderboardIsReevaluable = isReevaluable, leaderboardIsReevaluable = isReevaluable,
leaderboardIsVisible = isVisible leaderboardIsVisible = isVisible,
leaderboardTeam = mTeam
} }
where mainTestEnt@(Entity _ mainTest) = getMainTest tests where mainTestEnt@(Entity _ mainTest) = getMainTest tests
mainTestRef = getTestReference mainTestEnt mainTestRef = getTestReference mainTestEnt
submissionComparator (TableEntry _ _ _ em1 _ _ _ v1) (TableEntry _ _ _ em2 _ _ _ v2) = submissionComparator (TableEntry _ _ _ em1 _ _ _ v1 _) (TableEntry _ _ _ em2 _ _ _ v2 _) =
(compareMajorVersions v1 v2) (compareMajorVersions v1 v2)
<> <>
(compareResult mainTest) (evaluationScore (em1 Map.! mainTestRef)) (compareResult mainTest) (evaluationScore (em1 Map.! mainTestRef))
@ -484,7 +508,8 @@ getScore testId variantId = do
data BasicSubmissionInfo = BasicSubmissionInfo { data BasicSubmissionInfo = BasicSubmissionInfo {
basicSubmissionInfoUser :: User, basicSubmissionInfoUser :: User,
basicSubmissionInfoTagEnts :: [(Entity Import.Tag, Entity SubmissionTag)], basicSubmissionInfoTagEnts :: [(Entity Import.Tag, Entity SubmissionTag)],
basicSubmissionInfoVersion :: Version } basicSubmissionInfoVersion :: Version,
basicSubmissionInfoTeam :: Maybe (Entity Team) }
getBasicSubmissionInfo :: (MonadIO m, PersistQueryRead backend, getBasicSubmissionInfo :: (MonadIO m, PersistQueryRead backend,
PersistUniqueRead backend, PersistUniqueRead backend,
@ -492,13 +517,19 @@ getBasicSubmissionInfo :: (MonadIO m, PersistQueryRead backend,
=> Entity Submission -> ReaderT backend m (SubmissionId, BasicSubmissionInfo) => Entity Submission -> ReaderT backend m (SubmissionId, BasicSubmissionInfo)
getBasicSubmissionInfo (Entity submissionId submission) = do getBasicSubmissionInfo (Entity submissionId submission) = do
user <- get404 $ submissionSubmitter submission 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 tagEnts <- getTags submissionId
let versionHash = submissionVersion submission let versionHash = submissionVersion submission
(Entity _ version) <- getBy404 $ UniqueVersionByCommit versionHash (Entity _ ver) <- getBy404 $ UniqueVersionByCommit versionHash
return $ (submissionId, BasicSubmissionInfo { return $ (submissionId, BasicSubmissionInfo {
basicSubmissionInfoUser = user, basicSubmissionInfoUser = user,
basicSubmissionInfoTagEnts = tagEnts, basicSubmissionInfoTagEnts = tagEnts,
basicSubmissionInfoVersion = version }) basicSubmissionInfoVersion = ver,
basicSubmissionInfoTeam = mTeam })
getEvaluationMap :: (PersistUniqueRead backend, getEvaluationMap :: (PersistUniqueRead backend,
PersistQueryRead backend, PersistQueryRead backend,
@ -515,6 +546,7 @@ getEvaluationMap testsMap submissionsMap (rank, (s@(Entity submissionId submissi
let tagEnts = basicSubmissionInfoTagEnts submissionInfo let tagEnts = basicSubmissionInfoTagEnts submissionInfo
let theVersion = basicSubmissionInfoVersion submissionInfo let theVersion = basicSubmissionInfoVersion submissionInfo
let versionHash = submissionVersion submission let versionHash = submissionVersion submission
let team = basicSubmissionInfoTeam submissionInfo
evaluations <- E.select $ E.from $ \(evaluation, out) -> evaluations <- E.select $ E.from $ \(evaluation, out) ->
do do
@ -529,10 +561,10 @@ getEvaluationMap testsMap submissionsMap (rank, (s@(Entity submissionId submissi
let pairs' = map (\(testId, e) -> (testsMap Map.! testId, e)) pairs let pairs' = map (\(testId, e) -> (testsMap Map.! testId, e)) pairs
let m = Map.fromList pairs' let m = Map.fromList pairs'
parameters <- selectList [ParameterVariant ==. variantId] [Asc ParameterName] params <- selectList [ParameterVariant ==. variantId] [Asc ParameterName]
let major = versionMajor theVersion let major = versionMajor theVersion
let minor = versionMinor 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