From 51e98bee68ccae35fd43f33bdf50fbc51e7f78f5 Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Wed, 28 Jul 2021 21:37:06 +0200 Subject: [PATCH] Handle properly cases where there is no test --- Handler/Graph.hs | 22 +++++---- Handler/Shared.hs | 15 +++--- Handler/ShowChallenge.hs | 41 +++++++++------- Handler/Tables.hs | 84 ++++++++++++++++++--------------- messages/en.msg | 1 + templates/show-challenge.hamlet | 21 +++++---- 6 files changed, 104 insertions(+), 80 deletions(-) diff --git a/Handler/Graph.hs b/Handler/Graph.hs index 7f01015..0732a19 100644 --- a/Handler/Graph.hs +++ b/Handler/Graph.hs @@ -89,18 +89,22 @@ submissionsToJSON condition challengeName = do (\entry -> [entityKey $ tableEntrySubmission entry]) - entMainTest <- runDB $ fetchMainTest challengeId - let mainTestRef = getTestReference entMainTest + mEntMainTest <- runDB $ fetchMainTest challengeId + case mEntMainTest of + Just entMainTest -> do + let mainTestRef = getTestReference entMainTest - let naturalRange = getNaturalRange mainTestRef entries - let submissionIds = map leaderboardBestSubmissionId entries + let naturalRange = getNaturalRange mainTestRef entries + let submissionIds = map leaderboardBestSubmissionId entries - forks <- runDB $ selectList [ForkSource <-. submissionIds, ForkTarget <-. submissionIds] [] + forks <- runDB $ selectList [ForkSource <-. submissionIds, ForkTarget <-. submissionIds] [] - return $ object [ "nodes" .= (Data.Maybe.catMaybes - $ map (auxSubmissionToNode mainTestRef naturalRange) - $ entries), - "edges" .= map forkToEdge forks ] + return $ object [ "nodes" .= (Data.Maybe.catMaybes + $ map (auxSubmissionToNode mainTestRef naturalRange) + $ entries), + "edges" .= map forkToEdge forks ] + Nothing -> do + return $ object [] getNaturalRange :: TestReference -> [LeaderboardEntry] -> Double getNaturalRange testRef entries = 2.0 * (interQuantile diff --git a/Handler/Shared.hs b/Handler/Shared.hs index c2b391e..043d6da 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -121,7 +121,7 @@ consoleApp jobId = do case mchan of Nothing -> do sendTextData ("CANNOT FIND THE OUTPUT (ALREADY SHOWN??)" :: Text) - sendCloseE ("" :: Text) + _ <- sendCloseE ("" :: Text) return () Just chan -> do let loop = do @@ -131,7 +131,7 @@ consoleApp jobId = do Just text -> do sendTextData text loop - loop + _ <- loop return () @@ -556,7 +556,7 @@ thenCmp :: Ordering -> Ordering -> Ordering thenCmp EQ o2 = o2 thenCmp o1 _ = o1 -fetchMainTest :: (MonadIO m, PersistQueryRead backend, BaseBackend backend ~ SqlBackend) => Key Challenge -> ReaderT backend m (Entity Test) +fetchMainTest :: (MonadIO m, PersistQueryRead backend, BaseBackend backend ~ SqlBackend) => Key Challenge -> ReaderT backend m (Maybe (Entity Test)) fetchMainTest challengeId = do challenge <- get404 challengeId @@ -568,9 +568,7 @@ fetchMainTest challengeId = do fetchTestByName :: (MonadIO m, PersistQueryRead backend, BaseBackend backend ~ SqlBackend) => Maybe Text -> Key Challenge -> ReaderT backend m (Maybe (Entity Test)) -fetchTestByName Nothing challengeId = do - mainTest <- fetchMainTest challengeId - return $ Just mainTest +fetchTestByName Nothing challengeId = fetchMainTest challengeId fetchTestByName (Just tName) challengeId = do challenge <- get404 challengeId @@ -583,8 +581,9 @@ fetchTestByName (Just tName) challengeId = do -- get the test with the highest priority -getMainTest :: [Entity Test] -> Entity Test -getMainTest tests = DL.maximumBy testComparator tests +getMainTest :: [Entity Test] -> Maybe (Entity Test) +getMainTest [] = Nothing +getMainTest tests = Just $ DL.maximumBy testComparator tests -- get all the non-dev tests starting with the one with the highest priorty -- (or all the tests if there are no non-dev tests) diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index c06f4b7..efd570f 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -851,16 +851,18 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do relevantIndicators <- getOngoingTargets challengeId - (Entity mainTestId mainTest) <- runDB $ fetchMainTest challengeId (Entity _ currentVersion) <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge let submittedMajorVersion = versionMajor currentVersion - let orderDirection = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of - TheHigherTheBetter -> E.desc - TheLowerTheBetter -> E.asc + mMainEnt <- runDB $ fetchMainTest challengeId + bestScoreSoFar <- case mMainEnt of + Just (Entity _ mainTest) -> do + let orderDirection = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of + TheHigherTheBetter -> E.desc + TheLowerTheBetter -> E.asc - bestResultSoFar <- runDB $ E.select $ E.from $ \(evaluation, submission, variant, out, test, theVersion) -> do + bestResultSoFar <- runDB $ E.select $ E.from $ \(evaluation, submission, variant, out, test, theVersion) -> do E.where_ (submission ^. SubmissionChallenge E.==. E.val challengeId E.&&. submission ^. SubmissionIsHidden E.==. E.val False E.&&. variant ^. VariantSubmission E.==. submission ^. SubmissionId @@ -878,7 +880,9 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do E.orderBy [orderDirection (evaluation ^. EvaluationScore)] E.limit 1 return evaluation - let bestScoreSoFar = join (evaluationScore <$> entityVal <$> (listToMaybe bestResultSoFar)) + let bestScoreSoFar' = join (evaluationScore <$> entityVal <$> (listToMaybe bestResultSoFar)) + return bestScoreSoFar' + Nothing -> return Nothing case bestScoreSoFar of Just s -> msg chan ("best score so far is: " ++ (Data.Text.pack $ show s)) @@ -930,19 +934,21 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do app <- getYesod - newScores <- mapM (getScoreForOut mainTestId) outs - let newScores' = catMaybes newScores - let newScores'' = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of - TheHigherTheBetter -> reverse $ sort newScores' - TheLowerTheBetter -> sort newScores' - let compOp = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of - TheLowerTheBetter -> (<) - TheHigherTheBetter -> (>) - let submissionLink = slackLink app "submission" ("q/" ++ (fromSHA1ToText (repoCurrentCommit repo))) - case bestScoreSoFar of - Just b -> case newScores'' of + case mMainEnt of + Just (Entity mainTestId mainTest) -> do + newScores <- mapM (getScoreForOut mainTestId) outs + let newScores' = catMaybes newScores + let newScores'' = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of + TheHigherTheBetter -> reverse $ sort newScores' + TheLowerTheBetter -> sort newScores' + let compOp = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of + TheLowerTheBetter -> (<) + TheHigherTheBetter -> (>) + + case bestScoreSoFar of + Just b -> case newScores'' of (s:_) -> if compOp s b then do @@ -972,6 +978,7 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do Nothing -> return () else return () [] -> return () + Nothing -> return () Nothing -> return () if appAutoOpening $ appSettings app diff --git a/Handler/Tables.hs b/Handler/Tables.hs index f58ccd7..abd09d9 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -276,6 +276,9 @@ theLimitedDiffTextCell h textFun = Table.widget h ( OneThing u -> limitedWidget textCellSoftLimit textCellHardLimit u d@(TwoThings _ _) -> [whamlet|#{d}|]) +extractInt :: [PersistValue] -> Int64 +extractInt ((PersistInt64 x):_) = x + statusCellWidget :: Text -> RepoScheme -> Repo -> (SubmissionId, Submission, VariantId, Variant, Maybe UserId) -> WidgetFor App () statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, variantId, _, mauthId) = do isReevaluable <- handlerToWidget $ runDB $ canBeReevaluated submissionId @@ -351,28 +354,31 @@ getLeaderboardEntriesByCriterion :: (Ord a) => Int getLeaderboardEntriesByCriterion maxPriority challengeId condition preselector selector = do (evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos maxPriority condition (const True) preselector challengeId let mainTests = getMainTests tests - let mainTestEnt = getMainTest tests - let mainTestRef = getTestReference mainTestEnt - let (Entity _ mainTest) = mainTestEnt - let auxItems = concat - $ map (\i -> map (\s -> (s, [i])) (selector i)) - $ filter (\entry -> member mainTestRef $ tableEntryMapping entry) - $ evaluationMaps - let auxItemsMap = Map.fromListWith (++) auxItems - 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 - $ Map.toList auxItemsMap - let entries = DL.nubBy (\a b -> leaderboardBestVariantId a == leaderboardBestVariantId b) - $ sortBy (flip entryComparator) entries' - return (entries, (evaluationMaps, mainTests)) + let mMainTestEnt = getMainTest tests + case mMainTestEnt of + Nothing -> return ([], ([], [])) + Just mainTestEnt -> do + let mainTestRef = getTestReference mainTestEnt + let (Entity _ mainTest) = mainTestEnt + let auxItems = concat + $ map (\i -> map (\s -> (s, [i])) (selector i)) + $ filter (\entry -> member mainTestRef $ tableEntryMapping entry) + $ evaluationMaps + let auxItemsMap = Map.fromListWith (++) auxItems + let entryComparator a b = + (compareMajorVersions (leaderboardVersion a) (leaderboardVersion b)) + <> + ((compareResult $ Just 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 + $ Map.toList auxItemsMap + let entries = DL.nubBy (\a b -> leaderboardBestVariantId a == leaderboardBestVariantId b) + $ sortBy (flip entryComparator) entries' + return (entries, (evaluationMaps, mainTests)) toLeaderboardEntry :: Foldable t => Key Challenge -> [Entity Test] -> t TableEntry -> Handler LeaderboardEntry @@ -423,15 +429,17 @@ toLeaderboardEntry challengeId tests ss = do leaderboardIsVisible = isVisible, leaderboardTeam = mTeam } - where mainTestEnt@(Entity _ mainTest) = getMainTest tests - mainTestRef = getTestReference mainTestEnt - submissionComparator (TableEntry _ _ _ em1 _ _ _ v1 _) (TableEntry _ _ _ em2 _ _ _ v2 _) = - (compareMajorVersions v1 v2) - <> - (compareResult mainTest) (evaluationScore (em1 Map.! mainTestRef)) - (evaluationScore (em2 Map.! mainTestRef)) - <> - (compareVersions v1 v2) + where submissionComparator (TableEntry _ _ _ em1 _ _ _ v1 _) (TableEntry _ _ _ em2 _ _ _ v2 _) = + case getMainTest tests of + Just mainTestEnt@(Entity _ mainTest) -> + let mainTestRef = getTestReference mainTestEnt + in (compareMajorVersions v1 v2) + <> + (compareResult (Just $ mainTest) (evaluationScore (em1 Map.! mainTestRef)) + (evaluationScore (em2 Map.! mainTestRef))) + <> + (compareVersions v1 v2) + Nothing -> EQ getLeaderboardEntries :: Int -> LeaderboardStyle -> Key Challenge -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test])) getLeaderboardEntries maxPriority BySubmitter challengeId = @@ -449,8 +457,9 @@ getLeaderboardEntries maxPriority ByTag challengeId = where noEmptyList [] = [Nothing] noEmptyList l = map Just l -compareResult :: Test -> Maybe Double -> Maybe Double -> Ordering -compareResult test (Just x) (Just y) = (compareFun $ getMetricOrdering $ evaluationSchemeMetric $ testMetric test) x y +compareResult :: Maybe Test -> Maybe Double -> Maybe Double -> Ordering +compareResult Nothing _ _ = EQ +compareResult (Just test) (Just x) (Just y) = (compareFun $ getMetricOrdering $ evaluationSchemeMetric $ testMetric test) x y compareResult _ (Just _) Nothing = GT compareResult _ Nothing (Just _) = LT compareResult _ Nothing Nothing = EQ @@ -485,7 +494,7 @@ getChallengeSubmissionInfos maxMetricPriority condition variantCondition presele E.&&. variant ^. VariantSubmission E.==. submission ^. SubmissionId) return (submission, variant) - scores <- mapM (getScore (entityKey mainTest)) $ map (entityKey . snd) allSubmissionsVariants + scores <- mapM (getScore (entityKey <$> mainTest)) $ map (entityKey . snd) allSubmissionsVariants let allSubmissionsVariantsWithRanks = sortBy (\(r1, (s1, _)) (r2, (s2, _)) -> (submissionStamp (entityVal s2) `compare` submissionStamp (entityVal s1)) @@ -495,7 +504,7 @@ getChallengeSubmissionInfos maxMetricPriority condition variantCondition presele $ filter (\(_, (s, _)) -> condition s) $ map (\(rank, (_, sv)) -> (rank, sv)) $ zip [1..] - $ sortBy (\(s1, _) (s2, _) -> compareResult (entityVal mainTest) s2 s1) + $ sortBy (\(s1, _) (s2, _) -> compareResult (entityVal <$> mainTest) s2 s1) $ zip scores allSubmissionsVariants allTests <- selectList [] [Asc TestName] @@ -512,8 +521,9 @@ getChallengeSubmissionInfos maxMetricPriority condition variantCondition presele getScore :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) - => Key Test -> Key Variant -> ReaderT backend m (Maybe Double) -getScore testId variantId = do + => Maybe (Key Test) -> Key Variant -> ReaderT backend m (Maybe Double) +getScore Nothing _ = return Nothing +getScore (Just testId) variantId = do evaluations <- E.select $ E.from $ \(out, evaluation, variant, submission) -> do E.where_ (out ^. OutVariant E.==. E.val variantId E.&&. variant ^. VariantId E.==. E.val variantId diff --git a/messages/en.msg b/messages/en.msg index cf8f05d..144f170 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -105,3 +105,4 @@ YourTeams: your teams AsTeam: As team InviteToTeam: Invite to team (give the identifier/login of a user) Join: Join +NoTests: SOMETHING IS WRONG WITH THE CHALLENGE, THERE ARE NO TESTS DEFINED. MAYBE TEST DIRECTORY ARE MISSING OR THE CHALLENGE WAS CREATED/UPDATE IN THE INVALID MANNER diff --git a/templates/show-challenge.hamlet b/templates/show-challenge.hamlet index a5a4fe9..7d00292 100644 --- a/templates/show-challenge.hamlet +++ b/templates/show-challenge.hamlet @@ -25,17 +25,20 @@ $if (checkIfAdmin mUserEnt)

Leaderboard -^{Table.buildBootstrap (leaderboardTable mUserId (challengeName challenge) scheme challengeRepo tests) leaderboardWithRanks} +$if null tests +

_{MsgNoTests} +$else + ^{Table.buildBootstrap (leaderboardTable mUserId (challengeName challenge) scheme challengeRepo tests) leaderboardWithRanks} -$maybe altLeaderboardWithRanks <- mAltLeaderboardWithRanks - $maybe altTests <- mAltTests - ^{Table.buildBootstrap (altLeaderboardTable mUserId (challengeName challenge) scheme challengeRepo altTests) altLeaderboardWithRanks} + $maybe altLeaderboardWithRanks <- mAltLeaderboardWithRanks + $maybe altTests <- mAltTests + ^{Table.buildBootstrap (altLeaderboardTable mUserId (challengeName challenge) scheme challengeRepo altTests) altLeaderboardWithRanks} + $nothing $nothing -$nothing -

+
-