forked from filipg/gonito
Teams are shown
This commit is contained in:
parent
af2c789a83
commit
b38342fb0e
@ -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,7 +1357,7 @@ 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 ())
|
||||||
|
@ -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,7 +131,7 @@ 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)
|
||||||
@ -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
|
||||||
|
Loading…
Reference in New Issue
Block a user