API for returning scores

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
 

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

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,
+import qualified Database.Esqueleto      as E
-                              withSmallInput)
+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")
 

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

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

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