forked from filipg/gonito
Handle version while sorting
This commit is contained in:
parent
14b78e7cdd
commit
284d7e1acf
@ -20,6 +20,8 @@ import Handler.MakePublic
|
||||
import Handler.Dashboard
|
||||
import Handler.Common
|
||||
|
||||
import Text.Blaze
|
||||
|
||||
import Gonito.ExtractMetadata (ExtractionOptions(..),
|
||||
extractMetadataFromRepoDir,
|
||||
GonitoMetadata(..),
|
||||
@ -88,8 +90,8 @@ challengeReadme name = do
|
||||
let repoId = challengePublicRepo challenge
|
||||
repoDir <- getRepoDir repoId
|
||||
let readmeFilePath = repoDir </> readmeFile
|
||||
contents <- liftIO $ System.IO.readFile readmeFilePath
|
||||
return $ markdown def $ TL.pack contents
|
||||
theContents <- liftIO $ System.IO.readFile readmeFilePath
|
||||
return $ markdown def $ TL.pack theContents
|
||||
|
||||
showChallengeWidget :: Maybe (Entity User)
|
||||
-> Entity Challenge
|
||||
@ -178,6 +180,7 @@ defaultBranch :: IsString a => RepoScheme -> Maybe a
|
||||
defaultBranch SelfHosted = Just "master"
|
||||
defaultBranch Branches = Nothing
|
||||
|
||||
challengeHowTo :: (Text.Blaze.ToMarkup a1, Text.Blaze.ToMarkup a2) => Challenge -> AppSettings -> Repo -> a1 -> Bool -> Bool -> Maybe a2 -> WidgetFor App ()
|
||||
challengeHowTo challenge settings repo shownId isIDSet isSSHUploaded mToken = $(widgetFile "challenge-how-to")
|
||||
where myBranch = case appRepoScheme settings of
|
||||
SelfHosted -> "master" :: Text
|
||||
@ -431,6 +434,7 @@ checkTarget theNow user submissionLink entries indicator target chan = do
|
||||
return ()
|
||||
where indicatorText = prettyIndicatorEntry indicator
|
||||
|
||||
getScoreForOut :: (PersistQueryRead (YesodPersistBackend site), YesodPersist site, BaseBackend (YesodPersistBackend site) ~ SqlBackend) => Key Test -> Out -> HandlerFor site (Maybe Double)
|
||||
getScoreForOut mainTestId out = do
|
||||
mEvaluation <- runDB $ selectFirst [EvaluationChecksum ==. (outChecksum out),
|
||||
EvaluationTest ==. mainTestId]
|
||||
@ -466,7 +470,9 @@ getOuts chan submissionId generalParams = do
|
||||
submission <- runDB $ get404 submissionId
|
||||
let challengeId = submissionChallenge submission
|
||||
repoDir <- getRepoDir $ submissionRepo submission
|
||||
activeTests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] []
|
||||
activeTests <- runDB $ selectList [TestChallenge ==. challengeId,
|
||||
TestActive ==. True,
|
||||
TestCommit ==. submissionVersion submission] []
|
||||
|
||||
outs' <- mapM (outsForTest repoDir submissionId generalParams) activeTests
|
||||
let outs = concat outs'
|
||||
@ -606,6 +612,7 @@ checkRepoAvailibility challengeId repoId chan = do
|
||||
return False
|
||||
Nothing -> return True
|
||||
|
||||
challengeSubmissionWidget :: (ToMarkup a1, ToWidget App a2) => a2 -> a1 -> Challenge -> WidgetFor App ()
|
||||
challengeSubmissionWidget formWidget formEnctype challenge = $(widgetFile "challenge-submission")
|
||||
|
||||
submissionForm :: Maybe Text -> Maybe Text -> Maybe Text -> Form (Maybe Text, Maybe Text, Text, Text, Maybe Text)
|
||||
|
||||
@ -42,7 +42,8 @@ data LeaderboardEntry = LeaderboardEntry {
|
||||
leaderboardEvaluationMap :: Map TestReference Evaluation,
|
||||
leaderboardNumberOfSubmissions :: Int,
|
||||
leaderboardTags :: [(Entity Tag, Entity SubmissionTag)],
|
||||
leaderboardParams :: [Parameter]
|
||||
leaderboardParams :: [Parameter],
|
||||
leaderboardVersion :: (Int, Int, Int)
|
||||
}
|
||||
|
||||
data TableEntry = TableEntry {
|
||||
@ -117,6 +118,7 @@ leaderboardTable mauthId challengeName repoScheme challengeRepo tests = mempty
|
||||
++ Table.int "#" fst
|
||||
++ Table.text "submitter" (formatSubmitter . leaderboardUser . snd)
|
||||
++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd)
|
||||
++ Table.text "ver." (formatVersion . leaderboardVersion . snd)
|
||||
++ leaderboardDescriptionCell mauthId
|
||||
++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScoreFromLeaderboardEntry (getTestReference e) . snd)) tests)
|
||||
++ Table.int "×" (leaderboardNumberOfSubmissions . snd)
|
||||
@ -188,6 +190,14 @@ getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluation
|
||||
Nothing -> []))
|
||||
|
||||
|
||||
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) => Key Challenge
|
||||
-> ((Entity Submission) -> Bool)
|
||||
-> (TableEntry -> [a])
|
||||
@ -203,8 +213,13 @@ getLeaderboardEntriesByCriterion challengeId condition selector = do
|
||||
$ filter (\entry -> member mainTestRef $ tableEntryMapping entry)
|
||||
$ evaluationMaps
|
||||
let auxItemsMap = Map.fromListWith (++) auxItems
|
||||
let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluationMap a Map.! mainTestRef)
|
||||
(evaluationScore $ leaderboardEvaluationMap b Map.! mainTestRef)
|
||||
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)
|
||||
$ filter (\ll -> not (null ll))
|
||||
$ map snd
|
||||
@ -213,7 +228,8 @@ getLeaderboardEntriesByCriterion challengeId condition selector = do
|
||||
$ sortBy (flip entryComparator) entries'
|
||||
return (entries, (evaluationMaps, mainTests))
|
||||
|
||||
toLeaderboardEntry :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site, Foldable t) => Key Challenge -> [Entity Test] -> t TableEntry -> HandlerFor site LeaderboardEntry
|
||||
|
||||
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
|
||||
let (TableEntry bestSubmission bestVariant user evals _ _ _ _) = bestOne
|
||||
@ -222,6 +238,13 @@ toLeaderboardEntry challengeId tests ss = do
|
||||
|
||||
parameters <- runDB $ selectList [ParameterVariant ==. (entityKey bestVariant)] [Asc ParameterName]
|
||||
|
||||
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
|
||||
allUserSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId,
|
||||
SubmissionSubmitter ==. entityKey user]
|
||||
@ -236,13 +259,18 @@ toLeaderboardEntry challengeId tests ss = do
|
||||
leaderboardEvaluationMap = evals,
|
||||
leaderboardNumberOfSubmissions = length allUserSubmissions,
|
||||
leaderboardTags = tagEnts,
|
||||
leaderboardParams = map entityVal parameters
|
||||
leaderboardParams = map entityVal parameters,
|
||||
leaderboardVersion = theVersion
|
||||
}
|
||||
where mainTestEnt@(Entity _ mainTest) = getMainTest tests
|
||||
mainTestRef = getTestReference mainTestEnt
|
||||
submissionComparator (TableEntry _ _ _ em1 _ _ _ _) (TableEntry _ _ _ em2 _ _ _ _) =
|
||||
submissionComparator (TableEntry _ _ _ em1 _ _ _ v1) (TableEntry _ _ _ em2 _ _ _ v2) =
|
||||
(compareMajorVersions v1 v2)
|
||||
<>
|
||||
(compareResult mainTest) (evaluationScore (em1 Map.! mainTestRef))
|
||||
(evaluationScore (em2 Map.! mainTestRef))
|
||||
<>
|
||||
(compareVersions v1 v2)
|
||||
|
||||
getLeaderboardEntries :: LeaderboardStyle -> Key Challenge -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
|
||||
getLeaderboardEntries BySubmitter challengeId =
|
||||
@ -262,6 +290,7 @@ compareResult _ (Just _) Nothing = GT
|
||||
compareResult _ Nothing (Just _) = LT
|
||||
compareResult _ Nothing Nothing = EQ
|
||||
|
||||
getChallengeSubmissionInfos :: (MonadIO m, PersistQueryRead backend, BackendCompatible SqlBackend backend, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) => (Entity Submission -> Bool) -> Key Challenge -> ReaderT backend m ([TableEntry], [Entity Test])
|
||||
getChallengeSubmissionInfos condition challengeId = do
|
||||
|
||||
challenge <- get404 challengeId
|
||||
@ -291,6 +320,7 @@ getChallengeSubmissionInfos condition challengeId = do
|
||||
evaluationMaps <- mapM getEvaluationMap allSubmissionsVariantsWithRanks
|
||||
return (evaluationMaps, tests)
|
||||
|
||||
getScore :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend) => Key Test -> Key Variant -> ReaderT backend m (Maybe Double)
|
||||
getScore testId variantId = do
|
||||
evaluations <- E.select $ E.from $ \(out, evaluation) -> do
|
||||
E.where_ (out ^. OutVariant E.==. E.val variantId
|
||||
@ -303,6 +333,7 @@ getScore testId variantId = do
|
||||
[] -> Nothing
|
||||
|
||||
|
||||
getEvaluationMap :: (MonadIO m, PersistQueryRead backend, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) => (Int, (Entity Submission, Entity Variant)) -> ReaderT backend m TableEntry
|
||||
getEvaluationMap (rank, (s@(Entity submissionId submission), v@(Entity variantId _))) = do
|
||||
outs <- selectList [OutVariant ==. variantId] []
|
||||
user <- get404 $ submissionSubmitter submission
|
||||
|
||||
Loading…
Reference in New Issue
Block a user