API for returning scores
This commit is contained in:
parent
3a90144858
commit
d38e14c07a
@ -148,6 +148,8 @@ instance Yesod App where
|
||||
|
||||
isAuthorized (ChallengeImageR _) _ = return Authorized
|
||||
|
||||
isAuthorized (ApiTxtScoreR _) _ = return Authorized
|
||||
|
||||
-- Default to Authorized for now.
|
||||
isAuthorized _ _ = isTrustedAuthorized
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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")
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user