Add endpoint for querying by hash

This commit is contained in:
Filip Gralinski 2021-02-15 12:51:24 +01:00
parent 4c7f7add98
commit 106e076bc8
4 changed files with 182 additions and 4 deletions

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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