diff --git a/Foundation.hs b/Foundation.hs index c991de8..3d69250 100644 --- a/Foundation.hs +++ b/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 diff --git a/Handler/Query.hs b/Handler/Query.hs index d87f43c..59d717e 100644 --- a/Handler/Query.hs +++ b/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 diff --git a/Handler/SubmissionView.hs b/Handler/SubmissionView.hs index bfcc5da..b6388b7 100644 --- a/Handler/SubmissionView.hs +++ b/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 diff --git a/config/routes b/config/routes index 1ff9f76..05d7fca 100644 --- a/config/routes +++ b/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