s464900/gonito
1
0
Fork 0
forked from filipg/gonito
Code Issues Pull Requests Projects Releases Wiki Activity

API for scores handles alternative metrics

Browse Source
This commit is contained in:
Filip Gralinski 2019-11-30 11:56:07 +01:00
parent 1d2c2ca78f
commit 7b4b8b101d
4 changed files with 53 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Foundation.hs
View File

@ -201,7 +201,8 @@ instance Yesod App where
isAuthorized (ChallengeImageR _) _ = return Authorized isAuthorized (ChallengeImageR _) _ = return Authorized
isAuthorized (ApiTxtScoreR _) _ = return Authorized isAuthorized (ApiTxtScoreMainMetricR _) _ = return Authorized
isAuthorized (ApiTxtScoreWithMetricR _ _) _ = return Authorized
isAuthorized (ChallengeParamGraphDataR _ _ _) _ = return Authorized isAuthorized (ChallengeParamGraphDataR _ _ _) _ = return Authorized
isAuthorized (IndicatorGraphDataR _) _ = return Authorized isAuthorized (IndicatorGraphDataR _) _ = return Authorized

51
Handler/Query.hs
View File

@ -34,34 +34,45 @@ findSubmissions sha1Prefix = do
Nothing -> rawCommitQuery sha1Prefix Nothing -> rawCommitQuery sha1Prefix
mapM getFullInfo submissions mapM getFullInfo submissions
getApiTxtScoreR :: Text -> Handler Text getApiTxtScoreMainMetricR :: Text -> Handler Text
getApiTxtScoreR sha1Prefix = do 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 submissions <- runDB $ rawCommitQuery sha1Prefix
case submissions of case submissions of
[submission] -> doGetScore submission [submission] -> doGetScore mMetricName submission
[] -> return "NONE" [] -> return "NONE"
_ -> return "AMBIGUOUS ARGUMENT" _ -> 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 :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistUniqueRead (YesodPersistBackend site), BackendCompatible SqlBackend (YesodPersistBackend site), YesodPersist site, PersistQueryRead (YesodPersistBackend site)) => Maybe Text -> Entity Submission -> HandlerFor site Text
doGetScore submission = do doGetScore mMetricName submission = do
let challengeId = submissionChallenge $ entityVal submission let challengeId = submissionChallenge $ entityVal submission
mainTest <- runDB $ fetchMainTest challengeId
let mainTestId = entityKey mainTest
let submissionId = entityKey submission
evals <- runDB $ E.select mTestEnt <- runDB $ fetchTestByName mMetricName challengeId
$ E.from $ \(out, evaluation, variant) -> do case mTestEnt of
E.where_ (variant ^. VariantSubmission E.==. E.val submissionId Just testEnt -> do
E.&&. out ^. OutVariant E.==. variant ^. VariantId let theTestId = entityKey testEnt
E.&&. out ^. OutTest E.==. E.val mainTestId
E.&&. evaluation ^. EvaluationTest E.==. E.val mainTestId
E.&&. out ^. OutChecksum E.==. evaluation ^. EvaluationChecksum)
E.orderBy []
return (evaluation)
case evals of let submissionId = entityKey submission
[eval] -> return $ formatTruncatedScore (testPrecision $ entityVal mainTest) (Just $ entityVal eval)
_ -> return "NONE" 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 :: Handler Html
getQueryFormR = do getQueryFormR = do

20
Handler/Shared.hs
View File

@ -367,11 +367,27 @@ fetchMainTest challengeId = do
challenge <- get404 challengeId challenge <- get404 challengeId
activeTests <- selectList [TestChallenge ==. challengeId, activeTests <- selectList [TestChallenge ==. challengeId,
TestActive ==. True, TestActive ==. True,
TestCommit ==. challengeVersion challenge] [] TestCommit ==. challengeVersion challenge] []
return $ getMainTest activeTests 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 -- get the test with the highest priority
getMainTest :: [Entity Test] -> Entity Test getMainTest :: [Entity Test] -> Entity Test
getMainTest tests = DL.maximumBy testComparator tests getMainTest tests = DL.maximumBy testComparator tests

3
config/routes
View File

@ -34,7 +34,8 @@
/view-variant/#VariantId ViewVariantR GET /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 /make-public/#SubmissionId MakePublicR GET
/hide-submission/#SubmissionId HideSubmissionR GET /hide-submission/#SubmissionId HideSubmissionR GET