Add endpoint for querying by hash

Foundation.hs

@@ -1,3 +1,4 @@
+
 {-# LANGUAGE InstanceSigs #-}
 
 module Foundation where
@@ -175,6 +176,7 @@ instance Yesod App where
     isAuthorized UserInfoR _ = return Authorized
     isAuthorized (ChallengeSubmissionJsonR _) _ = return Authorized
     isAuthorized (ChallengeReadmeInMarkdownR _) _ = regularAuthorization
+    isAuthorized (QueryJsonR _) _ = return Authorized
 
     isAuthorized (ChallengeGraphDataR _) _ = regularAuthorization
     isAuthorized (ChallengeDiscussionR _) _ = regularAuthorization

Handler/Query.hs

@@ -2,7 +2,7 @@
 
 module Handler.Query where
 
-import Import
+import Import hiding (fromList, Proxy)
 
 import Handler.SubmissionView
 import Handler.Shared
@@ -43,6 +43,90 @@ import System.Directory (makeAbsolute)
 
 import Data.SplitIntoCrossTabs
 
+import Data.Swagger hiding (get)
+import qualified Data.Swagger as DS
+
+import Data.Swagger.Declare
+import Control.Lens hiding ((.=), (^.), (<.>))
+import Data.Proxy as DPR
+import Data.HashMap.Strict.InsOrd (fromList)
+
+import Handler.ShowChallenge
+
+
+data VariantView = VariantView {
+  variantViewId :: Int64,
+  variantViewName :: Text,
+  variantViewEvaluations :: [EvaluationView],
+  variantViewParams :: [Parameter]
+}
+
+instance ToJSON Parameter where
+  toJSON entry = object
+        [ "name" .= parameterName entry,
+          "value" .= parameterValue entry
+        ]
+
+instance ToSchema Parameter where
+  declareNamedSchema _ = do
+    stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
+    return $ NamedSchema (Just "SubmissionInfo") $ mempty
+        & type_ .~ SwaggerObject
+        & properties .~
+           fromList [  ("name", stringSchema),
+                       ("value", stringSchema)
+                    ]
+        & required .~ [ "name", "value" ]
+
+instance ToJSON VariantView where
+  toJSON entry = object
+        [ "id" .= variantViewId entry,
+          "name" .= variantViewName entry,
+          "evaluations" .= variantViewEvaluations entry,
+          "params" .= variantViewParams entry
+        ]
+
+instance ToSchema VariantView where
+  declareNamedSchema _ = do
+    intSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [Int64])
+    stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [String])
+    evaluationsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [EvaluationView])
+    paramsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [Parameter])
+    return $ NamedSchema (Just "SubmissionInfo") $ mempty
+        & type_ .~ SwaggerObject
+        & properties .~
+           fromList [  ("id", intSchema),
+                       ("name", stringSchema),
+                       ("evaluations", evaluationsSchema),
+                       ("params", paramsSchema)
+                    ]
+        & required .~ [ "evaluations" ]
+
+data QueryResultView = QueryResultView {
+  queryResultViewSubmissionInfo :: FullSubmissionInfo,
+  queryResultViewVariants :: [VariantView]
+}
+
+instance ToJSON QueryResultView where
+    toJSON entry = object
+        [ "submissionInfo" .= queryResultViewSubmissionInfo entry,
+          "variants" .= queryResultViewVariants entry
+        ]
+
+instance ToSchema QueryResultView where
+  declareNamedSchema _ = do
+    submissionInfoSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy FullSubmissionInfo)
+    variantViewsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [VariantView])
+    return $ NamedSchema (Just "SubmissionInfo") $ mempty
+        & type_ .~ SwaggerObject
+        & properties .~
+           fromList [  ("submissionInfo", submissionInfoSchema),
+                       ("variants", variantViewsSchema)
+                    ]
+        & required .~ [ "submissionInfo", "variants" ]
+
+
+
 rawCommitQuery :: (MonadIO m, RawSql a) => Text -> ReaderT SqlBackend m [a]
 rawCommitQuery sha1Prefix =
   rawSql "SELECT ?? FROM submission WHERE cast(commit as text) like ?" [PersistText $ "\\\\x" ++ sha1Prefix ++ "%"]
@@ -191,6 +275,68 @@ processQuery query = do
     setTitle "query results"
     $(widgetFile "query-results")
 
+toQueryResultView :: FullSubmissionInfo -> Handler QueryResultView
+toQueryResultView fsi = do
+  let submissionId = fsiSubmissionId fsi
+  let submission = fsiSubmission fsi
+  (tableEntries, tests) <- runDB
+                          $ getChallengeSubmissionInfos 2
+                                                        (\s -> entityKey s == submissionId)
+                                                        (const True)
+                                                        id
+                                                        (submissionChallenge submission)
+
+
+  let evaluations = map (\entry ->
+                           VariantView {
+                            variantViewId = fromSqlKey $ entityKey $ tableEntryVariant entry,
+                            variantViewName = variantName $ entityVal $ tableEntryVariant entry,
+                            variantViewEvaluations =  catMaybes $ Import.map (convertEvaluationToView $ tableEntryMapping entry) tests,
+                            variantViewParams = Import.map entityVal $ tableEntryParams entry
+
+                            }) tableEntries
+
+  return $ QueryResultView {
+    queryResultViewSubmissionInfo = fsi,
+    queryResultViewVariants = evaluations }
+
+getQueryJsonR :: Text -> Handler Value
+getQueryJsonR query = do
+  submissions' <- findSubmissions query
+  let submissions = map fst submissions'
+
+  qrvs <- mapM toQueryResultView submissions
+  return $ array qrvs
+
+declareQuerySwagger :: Declare (Definitions Schema) Swagger
+declareQuerySwagger = do
+  -- param schemas
+  let querySchema = toParamSchema (Proxy :: Proxy String)
+
+  queryResponse      <- declareResponse (Proxy :: Proxy [QueryResultView])
+
+  return $ mempty
+    & paths .~
+        fromList [ ("/api/query/{query}",
+                    mempty & DS.get ?~ (mempty
+                                        & parameters .~ [ Inline $ mempty
+                                                          & name .~ "query"
+                                                          & required ?~ True
+                                                          & schema .~ ParamOther (mempty
+                                                                                  & in_ .~ ParamPath
+                                                                                  & paramSchema .~ querySchema) ]
+                                        & produces ?~ MimeList ["application/json"]
+                                        & description ?~ "For a SHA1 hash prefix returns all the submissions matching"
+                                        & at 200 ?~ Inline queryResponse))
+                 ]
+
+
+queryApi :: Swagger
+queryApi = spec & definitions .~ defs
+  where
+    (defs, spec) = runDeclare declareLeaderboardSwagger mempty
+
+
 priorityLimitForViewVariant :: Int
 priorityLimitForViewVariant = 4
 

Handler/SubmissionView.hs

@@ -1,10 +1,18 @@
 module Handler.SubmissionView where
 
-import Import
+import Import hiding (fromList)
 
 import qualified Database.Esqueleto      as E
 import           Database.Esqueleto      ((^.))
 
+import Handler.Shared
+import PersistSHA1
+
+import Data.Swagger hiding (get)
+import Control.Lens hiding ((.=), (^.))
+import Data.Proxy as DPR
+import Data.HashMap.Strict.InsOrd (fromList)
+
 data FullSubmissionInfo = FullSubmissionInfo {
   fsiSubmissionId :: SubmissionId,
   fsiSubmission :: Submission,
@@ -13,10 +21,31 @@ data FullSubmissionInfo = FullSubmissionInfo {
   fsiChallenge :: Challenge,
   fsiChallengeRepo :: Repo,
   fsiScheme :: RepoScheme,
-  fsiTags :: [(Entity Tag, Entity SubmissionTag)],
+  fsiTags :: [(Entity Import.Tag, Entity SubmissionTag)],
   fsiExternalLinks :: [Entity ExternalLink],
   fsiSuperSubmissions :: [FullSubmissionInfo] }
 
+instance ToJSON FullSubmissionInfo where
+  toJSON entry = object
+        [ "hash" .= (fromSHA1ToText $ submissionCommit $ fsiSubmission entry),
+          "submitter" .= (formatSubmitter $ fsiUser entry),
+          "challenge" .= (challengeName $ fsiChallenge entry)
+        ]
+
+instance ToSchema FullSubmissionInfo where
+  declareNamedSchema _ = do
+    stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
+    return $ NamedSchema (Just "SubmissionInfo") $ mempty
+        & type_ .~ SwaggerObject
+        & properties .~
+           fromList [  ("hash", stringSchema)
+                     , ("submitter", stringSchema)
+                     , ("challenge", stringSchema)
+                    ]
+        & required .~ [ "hash", "submitter", "challenge" ]
+
+
+
 getFullInfo :: Entity Submission -> Handler FullSubmissionInfo
 getFullInfo (Entity submissionId submission) = do
   repo <- runDB $ get404 $ submissionRepo submission
@@ -50,7 +79,7 @@ getFullInfo (Entity submissionId submission) = do
     fsiExternalLinks = links,
     fsiSuperSubmissions = superSubmissionFsis }
 
-getTags :: (BaseBackend backend ~ SqlBackend, MonadIO m, PersistQueryRead backend) => Key Submission -> ReaderT backend m [(Entity Tag, Entity SubmissionTag)]
+getTags :: (BaseBackend backend ~ SqlBackend, MonadIO m, PersistQueryRead backend) => Key Submission -> ReaderT backend m [(Entity Import.Tag, Entity SubmissionTag)]
 getTags submissionId = do
   sts <- selectList [SubmissionTagSubmission ==. submissionId] []
   let tagIds = Import.map (submissionTagTag . entityVal) sts

config/routes

@@ -20,6 +20,7 @@
 /api/challenge-submission/#Text ChallengeSubmissionJsonR POST
 /api/challenge-readme/#Text/markdown ChallengeReadmeInMarkdownR GET
 /api/challenge-image/#ChallengeId ChallengeImageR GET
+/api/query/#Text QueryJsonR GET
 /list-archived-challenges ListArchivedChallengesR GET
 
 /challenge/#Text ShowChallengeR GET