From d38e14c07a2bcaa49e47bb5c1f693a0b6cbcfc07 Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Thu, 25 Jan 2018 16:34:05 +0100 Subject: [PATCH] API for returning scores --- Foundation.hs | 2 ++ Handler/Graph.hs | 1 + Handler/Query.hs | 47 ++++++++++++++++++++++++++++++++++++----------- Handler/Shared.hs | 16 ++++++++++++++++ Handler/Tables.hs | 19 ++----------------- config/routes | 2 ++ 6 files changed, 59 insertions(+), 28 deletions(-) diff --git a/Foundation.hs b/Foundation.hs index c5488ee..fd391e0 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -148,6 +148,8 @@ instance Yesod App where isAuthorized (ChallengeImageR _) _ = return Authorized + isAuthorized (ApiTxtScoreR _) _ = return Authorized + -- Default to Authorized for now. isAuthorized _ _ = isTrustedAuthorized diff --git a/Handler/Graph.hs b/Handler/Graph.hs index 1b6076e..010b706 100644 --- a/Handler/Graph.hs +++ b/Handler/Graph.hs @@ -3,6 +3,7 @@ module Handler.Graph where import Import import Handler.Tables +import Handler.Shared import Data.Maybe import Data.List ((!!)) import Database.Persist.Sql diff --git a/Handler/Query.hs b/Handler/Query.hs index 859eb2d..3d1a064 100644 --- a/Handler/Query.hs +++ b/Handler/Query.hs @@ -2,43 +2,68 @@ module Handler.Query where import Import -import Handler.Shared import Handler.SubmissionView -import PersistSHA1 +import Handler.Shared import Database.Persist.Sql -import Data.Text as T(pack) -import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, - withSmallInput) +import qualified Database.Esqueleto as E +import Database.Esqueleto ((^.)) +import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3) + +rawCommitQuery :: (MonadIO m, RawSql a) => Text -> ReaderT SqlBackend m [a] +rawCommitQuery sha1Prefix = rawSql "SELECT ?? FROM submission WHERE is_public AND cast(commit as text) like ?" [PersistText $ "\\\\x" ++ sha1Prefix ++ "%"] findSubmissions :: Text -> Handler [FullSubmissionInfo] findSubmissions sha1Prefix = do mauthId <- maybeAuth submissions <- runDB $ case mauthId of Just (Entity authId _) -> rawSql "SELECT ?? FROM submission WHERE (is_public OR submitter = ?) AND cast(commit as text) like ?" [toPersistValue authId, PersistText $ "\\\\x" ++ sha1Prefix ++ "%"] - Nothing -> rawSql "SELECT ?? FROM submission WHERE is_public AND cast(commit as text) like ?" [PersistText $ "\\\\x" ++ sha1Prefix ++ "%"] + Nothing -> rawCommitQuery sha1Prefix mapM getFullInfo submissions +getApiTxtScoreR :: Text -> Handler Text +getApiTxtScoreR sha1Prefix = do + submissions <- runDB $ rawCommitQuery sha1Prefix + case submissions of + [submission] -> doGetScore submission + [] -> return "NONE" + _ -> return "AMBIGUOUS ARGUMENT" + +doGetScore submission = do + let challengeId = submissionChallenge $ entityVal submission + tests <- runDB $ selectList [TestChallenge ==. challengeId] [] + let mainTest = getMainTest tests + let mainTestId = entityKey mainTest + let submissionId = entityKey submission + + evals <- runDB $ E.select + $ E.from $ \(out, evaluation) -> do + E.where_ (out ^. OutSubmission E.==. E.val submissionId + 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 + [eval] -> return $ formatTruncatedScore (testPrecision $ entityVal mainTest) (Just $ entityVal eval) + _ -> return "NONE" + getQueryFormR :: Handler Html getQueryFormR = do (formWidget, formEnctype) <- generateFormPost queryForm - let submission = Nothing :: Maybe Text - handlerName = "getQueryFormR" :: Text defaultLayout $ do - aDomId <- newIdent setTitle "Searching for submissions" $(widgetFile "query-form") postQueryFormR :: Handler Html postQueryFormR = do ((result, formWidget), formEnctype) <- runFormPost queryForm - let handlerName = "postQueryFormR" :: Text case result of FormSuccess query -> processQuery query _ -> defaultLayout $ do - aDomId <- newIdent setTitle "Searching for submissions" $(widgetFile "query-form") diff --git a/Handler/Shared.hs b/Handler/Shared.hs index c18ed05..de091b1 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -17,6 +17,8 @@ import Control.Concurrent.Lifted (fork, threadDelay) import qualified Crypto.Hash.SHA1 as CHS +import qualified Data.List as DL + import System.Process import System.Exit import System.Random @@ -362,3 +364,17 @@ enableTriggerToken _ (Just _) = return () enableTriggerToken userId Nothing = do token <- newToken runDB $ update userId [UserTriggerToken =. Just token] + +getMainTest :: [Entity Test] -> Entity Test +getMainTest tests = DL.maximumBy (\(Entity _ a) (Entity _ b) -> ((testName a) `compare` (testName b))) tests + +formatFullScore :: Maybe Evaluation -> Text +formatFullScore (Just evaluation) = fromMaybe "???" (T.pack <$> show <$> evaluationScore evaluation) +formatFullScore Nothing = "N/A" + +formatTruncatedScore :: Maybe Int -> Maybe Evaluation -> Text +formatTruncatedScore Nothing e = formatFullScore e +formatTruncatedScore _ Nothing = formatFullScore Nothing +formatTruncatedScore (Just precision) (Just evaluation) = case evaluationScore evaluation of + Just score -> T.pack $ printf "%0.*f" precision score + Nothing -> formatFullScore Nothing diff --git a/Handler/Tables.hs b/Handler/Tables.hs index bb61631..8a7ef36 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -12,12 +12,12 @@ import Yesod.Table (Table) import qualified Data.Map as Map -import qualified Data.List as DL - import Data.Text (pack) import PersistSHA1 +import qualified Data.List as DL + import GEval.Core import Text.Printf @@ -78,18 +78,6 @@ statusCell challengeName fun = Table.widget "" (statusCellWidget challengeName . resultCell :: Test -> (a -> Maybe Evaluation) -> Table App a resultCell test fun = hoverTextCell ((testName test) ++ "/" ++ (Data.Text.pack $ show $ testMetric test)) (formatTruncatedScore (testPrecision test) . fun) (formatFullScore . fun) -formatFullScore :: Maybe Evaluation -> Text -formatFullScore (Just evaluation) = fromMaybe "???" (Data.Text.pack <$> show <$> evaluationScore evaluation) -formatFullScore Nothing = "N/A" - -formatTruncatedScore :: Maybe Int -> Maybe Evaluation -> Text -formatTruncatedScore Nothing e = formatFullScore e -formatTruncatedScore _ Nothing = formatFullScore Nothing -formatTruncatedScore (Just precision) (Just evaluation) = case evaluationScore evaluation of - Just score -> Data.Text.pack $ printf "%0.*f" precision score - Nothing -> formatFullScore Nothing - - statusCellWidget challengeName (submissionId, submission, userId, mauthId) = $(widgetFile "submission-status") where commitHash = fromSHA1ToText $ submissionCommit submission isPublic = submissionIsPublic submission @@ -102,9 +90,6 @@ statusCellWidget challengeName (submissionId, submission, userId, mauthId) = $(w else Nothing -getMainTest :: [Entity Test] -> Entity Test -getMainTest tests = DL.maximumBy (\(Entity _ a) (Entity _ b) -> ((testName a) `compare` (testName b))) tests - getAuxSubmissions :: Key Test -> [(Entity Submission, Entity User, Map (Key Test) Evaluation)] -> [(Key User, (User, [(Submission, Evaluation)]))] getAuxSubmissions testId evaluationMaps = map (processEvaluationMap testId) evaluationMaps where processEvaluationMap testId ((Entity _ s), (Entity ui u), m) = (ui, (u, case Map.lookup testId m of diff --git a/config/routes b/config/routes index 964c48e..71379ff 100644 --- a/config/routes +++ b/config/routes @@ -27,6 +27,8 @@ /q QueryFormR GET POST /q/#Text QueryResultsR GET +/api/txt/score/#Text ApiTxtScoreR GET + /make-public/#SubmissionId MakePublicR GET /account YourAccountR GET POST