diff --git a/Foundation.hs b/Foundation.hs index 7847d75..a5fa166 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -201,7 +201,8 @@ instance Yesod App where isAuthorized (ChallengeImageR _) _ = return Authorized - isAuthorized (ApiTxtScoreR _) _ = return Authorized + isAuthorized (ApiTxtScoreMainMetricR _) _ = return Authorized + isAuthorized (ApiTxtScoreWithMetricR _ _) _ = return Authorized isAuthorized (ChallengeParamGraphDataR _ _ _) _ = return Authorized isAuthorized (IndicatorGraphDataR _) _ = return Authorized diff --git a/Handler/Query.hs b/Handler/Query.hs index dfb8df2..3259a6c 100644 --- a/Handler/Query.hs +++ b/Handler/Query.hs @@ -34,34 +34,45 @@ findSubmissions sha1Prefix = do Nothing -> rawCommitQuery sha1Prefix mapM getFullInfo submissions -getApiTxtScoreR :: Text -> Handler Text -getApiTxtScoreR sha1Prefix = do +getApiTxtScoreMainMetricR :: Text -> Handler Text +getApiTxtScoreMainMetricR sha1Prefix = getApiTxtScore Nothing sha1Prefix + +getApiTxtScoreWithMetricR :: Text -> Text -> Handler Text +getApiTxtScoreWithMetricR sha1Prefix metricName = getApiTxtScore (Just metricName) sha1Prefix + +getApiTxtScore :: Maybe Text -> Text -> Handler Text +getApiTxtScore mMetricName sha1Prefix = do submissions <- runDB $ rawCommitQuery sha1Prefix case submissions of - [submission] -> doGetScore submission + [submission] -> doGetScore mMetricName submission [] -> 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 +doGetScore :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistUniqueRead (YesodPersistBackend site), BackendCompatible SqlBackend (YesodPersistBackend site), YesodPersist site, PersistQueryRead (YesodPersistBackend site)) => Maybe Text -> Entity Submission -> HandlerFor site Text +doGetScore mMetricName submission = do let challengeId = submissionChallenge $ entityVal submission - mainTest <- runDB $ fetchMainTest challengeId - let mainTestId = entityKey mainTest - let submissionId = entityKey submission - evals <- runDB $ E.select - $ 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) - E.orderBy [] - return (evaluation) + mTestEnt <- runDB $ fetchTestByName mMetricName challengeId + case mTestEnt of + Just testEnt -> do + let theTestId = entityKey testEnt - case evals of - [eval] -> return $ formatTruncatedScore (testPrecision $ entityVal mainTest) (Just $ entityVal eval) - _ -> return "NONE" + let submissionId = entityKey submission + + evals <- runDB $ E.select + $ 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 theTestId + E.&&. evaluation ^. EvaluationTest E.==. E.val theTestId + E.&&. out ^. OutChecksum E.==. evaluation ^. EvaluationChecksum) + E.orderBy [] + return (evaluation) + + case evals of + [eval] -> return $ formatTruncatedScore (testPrecision $ entityVal testEnt) (Just $ entityVal eval) + _ -> return "NONE" + Nothing -> return "NONE" getQueryFormR :: Handler Html getQueryFormR = do diff --git a/Handler/Shared.hs b/Handler/Shared.hs index 963d6ac..d68c11a 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -367,11 +367,27 @@ fetchMainTest challengeId = do challenge <- get404 challengeId activeTests <- selectList [TestChallenge ==. challengeId, - TestActive ==. True, - TestCommit ==. challengeVersion challenge] [] + TestActive ==. True, + TestCommit ==. challengeVersion challenge] [] return $ getMainTest activeTests + +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 (Just tName) challengeId = do + challenge <- get404 challengeId + + tests' <- selectList [TestChallenge ==. challengeId, + TestCommit ==. challengeVersion challenge] [] + + let tests = sortBy (flip testComparator) tests' + + return $ find (\t -> formatTestEvaluationScheme (entityVal t) == tName) tests + + -- get the test with the highest priority getMainTest :: [Entity Test] -> Entity Test getMainTest tests = DL.maximumBy testComparator tests diff --git a/config/routes b/config/routes index f2ed0bc..bdb98b7 100644 --- a/config/routes +++ b/config/routes @@ -34,7 +34,8 @@ /view-variant/#VariantId ViewVariantR GET -/api/txt/score/#Text ApiTxtScoreR GET +/api/txt/score/#Text ApiTxtScoreMainMetricR GET +/api/txt/score/#Text/#Text ApiTxtScoreWithMetricR GET /make-public/#SubmissionId MakePublicR GET /hide-submission/#SubmissionId HideSubmissionR GET