From 9b445d6e9c8577644890709e228ed148ad74d4d5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Filip=20Grali=C5=84ski?= Date: Fri, 6 Jul 2018 16:54:17 +0200 Subject: [PATCH] variants are used within within outs - transition completed --- Handler/Query.hs | 6 ++++-- Handler/ShowChallenge.hs | 3 +-- Handler/Tables.hs | 39 ++++++++++++++++++++++----------------- config/models | 2 -- fix-out.sql | 1 + 5 files changed, 28 insertions(+), 23 deletions(-) create mode 100644 fix-out.sql diff --git a/Handler/Query.hs b/Handler/Query.hs index 3d1a064..8dc8e5b 100644 --- a/Handler/Query.hs +++ b/Handler/Query.hs @@ -31,6 +31,7 @@ getApiTxtScoreR sha1Prefix = do [] -> return "NONE" _ -> return "AMBIGUOUS ARGUMENT" +doGetScore :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistUniqueRead (YesodPersistBackend site), BackendCompatible SqlBackend (YesodPersistBackend site), YesodPersist site, PersistQueryRead (YesodPersistBackend site)) => Entity Submission -> HandlerFor site Text doGetScore submission = do let challengeId = submissionChallenge $ entityVal submission tests <- runDB $ selectList [TestChallenge ==. challengeId] [] @@ -39,8 +40,9 @@ doGetScore submission = do let submissionId = entityKey submission evals <- runDB $ E.select - $ E.from $ \(out, evaluation) -> do - E.where_ (out ^. OutSubmission E.==. E.val submissionId + $ E.from $ \(out, evaluation, variant) -> do + E.where_ (variant ^. VariantSubmission E.==. E.val submissionId + E.&&. out ^. OutVariant E.==. variant ^. VariantId E.&&. out ^. OutTest E.==. E.val mainTestId E.&&. evaluation ^. EvaluationTest E.==. E.val mainTestId E.&&. out ^. OutChecksum E.==. evaluation ^. EvaluationChecksum) diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 419440a..ed40ad0 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -305,7 +305,6 @@ outForTest repoDir submissionId variantId (Entity testId test) = do (Just outF) <- liftIO $ findOutFile repoDir test checksum <- liftIO $ gatherSHA1ForCollectionOfFiles [outF] return Out { - outSubmission=submissionId, outVariant=variantId, outTest=testId, outChecksum=SHA1 checksum } @@ -319,7 +318,7 @@ getVariant submissionId name = runDB $ do checkOrInsertOut :: Out -> Handler () checkOrInsertOut out = do - maybeOut <- runDB $ getBy $ UniqueOutSubmissionTestChecksum (outSubmission out) (outTest out) (outChecksum out) + maybeOut <- runDB $ getBy $ UniqueOutVariantTestChecksum (outVariant out) (outTest out) (outChecksum out) case maybeOut of Just _ -> return () Nothing -> (runDB $ insert out) >> return () diff --git a/Handler/Tables.hs b/Handler/Tables.hs index 5cf4430..9ff8265 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -31,20 +31,20 @@ data LeaderboardEntry = LeaderboardEntry { leaderboardTags :: [(Entity Tag, Entity SubmissionTag)] } -submissionsTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App (Entity Submission, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)]) +submissionsTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App (Entity Submission, Entity Variant, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)]) submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty - ++ Table.text "submitter" (formatSubmitter . (\(_, Entity _ submitter, _, _) -> submitter)) - ++ timestampCell "when" (submissionStamp . (\(Entity _ s, _, _, _) -> s)) + ++ Table.text "submitter" (formatSubmitter . (\(_, _, Entity _ submitter, _, _) -> submitter)) + ++ timestampCell "when" (submissionStamp . (\(Entity _ s, _, _, _, _) -> s)) ++ descriptionCell ++ mconcat (map (\(Entity k t) -> resultCell t (extractScore k)) tests) - ++ statusCell challengeName repoScheme challengeRepo (\(Entity submissionId submission, Entity userId _, _, _) -> (submissionId, submission, userId, mauthId)) + ++ statusCell challengeName repoScheme challengeRepo (\(Entity submissionId submission, _, Entity userId _, _, _) -> (submissionId, submission, userId, mauthId)) -descriptionCell :: Foldable t => Table site (Entity Submission, b, c, t (Entity Tag, Entity SubmissionTag)) +descriptionCell :: Foldable t => Table site (Entity Submission, v, b, c, t (Entity Tag, Entity SubmissionTag)) descriptionCell = Table.widget "description" ( - \(Entity _ s, _, _ ,tagEnts) -> fragmentWithSubmissionTags (submissionDescription s) tagEnts) + \(Entity _ s, _, _, _ ,tagEnts) -> fragmentWithSubmissionTags (submissionDescription s) tagEnts) -extractScore :: Key Test -> (Entity Submission, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)]) -> Maybe Evaluation -extractScore k (_, _, m, _) = lookup k m +extractScore :: Key Test -> (Entity Submission, Entity Variant, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)]) -> Maybe Evaluation +extractScore k (_, _, _, m, _) = lookup k m leaderboardTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> Test -> Table App (Int, LeaderboardEntry) leaderboardTable mauthId challengeName repoScheme challengeRepo test = mempty @@ -99,9 +99,9 @@ getAuxSubmissions testId evaluationMaps = map processEvaluationMap evaluationMap Nothing -> [])) -getAuxSubmissionEnts :: Key Test -> [(Entity Submission, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])] -> [(Key User, (User, [((Entity Submission), Evaluation)]))] +getAuxSubmissionEnts :: Key Test -> [(Entity Submission, Entity Variant, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])] -> [(Key User, (User, [((Entity Submission), Evaluation)]))] getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluationMaps - where processEvaluationMap (s, (Entity ui u), m, _) = (ui, (u, case Map.lookup testId m of + where processEvaluationMap (s, v, (Entity ui u), m, _) = (ui, (u, case Map.lookup testId m of Just e -> [(s, e)] Nothing -> [])) @@ -150,20 +150,25 @@ compareFun :: MetricOrdering -> Double -> Double -> Ordering compareFun TheLowerTheBetter = flip compare compareFun TheHigherTheBetter = compare -getChallengeSubmissionInfos :: ((Entity Submission) -> Bool) -> Key Challenge -> Handler ([(Entity Submission, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])], [Entity Test]) +getChallengeSubmissionInfos :: ((Entity Submission) -> Bool) -> Key Challenge -> Handler ([(Entity Submission,Entity Variant, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])], [Entity Test]) getChallengeSubmissionInfos condition challengeId = do allSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId, SubmissionIsHidden !=. Just True] [Desc SubmissionStamp] let submissions = filter condition allSubmissions tests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] [] - evaluationMaps <- mapM getEvaluationMap submissions - return (evaluationMaps, tests) + evaluationMaps <- mapM getEvaluationMapForSubmission submissions + return (concat evaluationMaps, tests) -getEvaluationMap :: Entity Submission -> Handler (Entity Submission, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)]) -getEvaluationMap s@(Entity submissionId submission) = do - outs <- runDB $ selectList [OutSubmission ==. submissionId] [] +getEvaluationMapForSubmission :: Entity Submission -> Handler [(Entity Submission, Entity Variant, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])] +getEvaluationMapForSubmission s@(Entity submissionId submission)= do + variants <- runDB $ selectList [VariantSubmission ==. submissionId] [] + mapM (getEvaluationMap s) variants + +getEvaluationMap :: Entity Submission -> Entity Variant -> Handler (Entity Submission, Entity Variant, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)]) +getEvaluationMap s@(Entity submissionId submission) v@(Entity variantId variant) = do + outs <- runDB $ selectList [OutVariant ==. variantId] [] user <- runDB $ get404 $ submissionSubmitter submission maybeEvaluations <- runDB $ mapM (\(Entity _ o) -> getBy $ UniqueEvaluationTestChecksum (outTest o) (outChecksum o)) outs let evaluations = catMaybes maybeEvaluations let m = Map.fromList $ map (\(Entity _ e) -> (evaluationTest e, e)) evaluations tagEnts <- runDB $ getTags submissionId - return (s, Entity (submissionSubmitter submission) user, m, tagEnts) + return (s, v, Entity (submissionSubmitter submission) user, m, tagEnts) diff --git a/config/models b/config/models index a3eafad..ae57f1f 100644 --- a/config/models +++ b/config/models @@ -85,11 +85,9 @@ Comment posted UTCTime default=now() text Textarea Out - submission SubmissionId variant VariantId test TestId checksum SHA1 - UniqueOutSubmissionTestChecksum submission test checksum UniqueOutVariantTestChecksum variant test checksum Tag name Text diff --git a/fix-out.sql b/fix-out.sql new file mode 100644 index 0000000..5bdb7eb --- /dev/null +++ b/fix-out.sql @@ -0,0 +1 @@ +ALTER TABLE "out" DROP COLUMN "submission";