Add endpoint for querying by hash
This commit is contained in:
parent
4c7f7add98
commit
106e076bc8
@ -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
|
||||
|
||||
148
Handler/Query.hs
148
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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user