From 98325e47b62c726c499d265abebca1b505ac8435 Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Fri, 5 Feb 2021 14:44:46 +0100 Subject: [PATCH] More swagger --- Handler/ShowChallenge.hs | 104 +++++++++++++++++++++++++++++++++++++++ Handler/Swagger.hs | 2 +- Handler/Tables.hs | 23 +++++++-- 3 files changed, 125 insertions(+), 4 deletions(-) diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 9e00cf5..67f79d9 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -815,6 +815,39 @@ getAddUserR = do return $ Bool True Nothing -> return $ Bool False +declareAllSubmissionsApi :: String -> String -> Declare (Definitions Schema) Swagger +declareAllSubmissionsApi q d = do + -- param schemas + let challengeNameSchema = toParamSchema (Proxy :: Proxy String) + + allSubmissionsResponse <- declareResponse (Proxy :: Proxy SubmissionsView) + + return $ mempty + & paths .~ + fromList [ ("/api/" ++ q ++ "/{challengeName}", + mempty & DS.get ?~ (mempty + & parameters .~ [ Inline $ mempty + & name .~ "challengeName" + & required ?~ True + & schema .~ ParamOther (mempty + & in_ .~ ParamPath + & paramSchema .~ challengeNameSchema) ] + & produces ?~ MimeList ["application/json"] + & description ?~ "d" + & at 200 ?~ Inline allSubmissionsResponse)) + ] + + +allSubmissionsApi :: Swagger +allSubmissionsApi = spec & definitions .~ defs + where + (defs, spec) = runDeclare (declareAllSubmissionsApi "challenge-all-submissions" "Returns all submissions for a challenge") mempty + +mySubmissionsApi :: Swagger +mySubmissionsApi = spec & definitions .~ defs + where + (defs, spec) = runDeclare (declareAllSubmissionsApi "challenge-my-submissions" "Returns all submissions for a challenge for the user") mempty + getChallengeAllSubmissionsJsonR :: Text -> Handler Value getChallengeAllSubmissionsJsonR challengeName = do v <- fetchAllSubmissionsView challengeName @@ -918,6 +951,21 @@ instance ToJSON EvaluationView where , "test" .= evaluationViewTest e ] +instance ToSchema EvaluationView where + declareNamedSchema _ = do + stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String) + doubleSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Double) + testRefSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy TestReference) + return $ NamedSchema (Just "Evaluation") $ mempty + & type_ .~ SwaggerObject + & properties .~ + fromList [ ("score", stringSchema) + , ("full-score", doubleSchema) + , ("test", testRefSchema) + ] + & required .~ [ "score", "full-score", "test" ] + + data TagView = TagView { tagViewName :: Text, tagViewDescription :: Maybe Text, @@ -930,6 +978,20 @@ instance ToJSON TagView where , "accepted" .= tagViewAccepted t ] +instance ToSchema TagView where + declareNamedSchema _ = do + stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String) + boolSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Bool) + return $ NamedSchema (Just "Tag") $ mempty + & type_ .~ SwaggerObject + & properties .~ + fromList [ ("name", stringSchema) + , ("description", stringSchema) + , ("accepted", boolSchema) + ] + & required .~ [ "name", "description" ] + + data SubmissionView = SubmissionView { submissionViewId :: Int64, submissionViewVariantId :: Int64, @@ -965,6 +1027,36 @@ instance ToJSON SubmissionView where , "isPublic" .= submissionViewIsPublic s ] +instance ToSchema SubmissionView where + declareNamedSchema _ = do + stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String) + boolSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Bool) + intSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Int) + intsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [Int]) + tagsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [TagView]) + evalsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [EvaluationView]) + return $ NamedSchema (Just "SubmissionView") $ mempty + & type_ .~ SwaggerObject + & properties .~ + fromList [ ("id", intSchema) + , ("variant", intSchema) + , ("rank", intSchema) + , ("submitter", stringSchema) + , ("when", stringSchema) + , ("version", intsSchema) + , ("description", stringSchema) + , ("tags", tagsSchema) + , ("hash", stringSchema) + , ("evaluations", evalsSchema) + , ("isOwner", boolSchema) + , ("isReevaluable", boolSchema) + , ("isVisible", boolSchema) + , ("isPublic", boolSchema) + ] + & required .~ [ "id", "variant", "rank", "submitter", "when", "version", + "description", "tags", "hash", "evaluations", + "isOwner", "isReevaluable", "isVisible", "isPublic" ] + data SubmissionsView = SubmissionsView { submissionsViewSubmissions :: [SubmissionView], submissionsViewTests :: [TestReference] @@ -976,6 +1068,18 @@ instance ToJSON SubmissionsView where "submissions" .= submissionsViewSubmissions ss ] +instance ToSchema SubmissionsView where + declareNamedSchema _ = do + submissionViewsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [SubmissionView]) + testRefsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [TestReference]) + return $ NamedSchema (Just "Tag") $ mempty + & type_ .~ SwaggerObject + & properties .~ + fromList [ ("tests", submissionViewsSchema) + , ("submissions", testRefsSchema) + ] + & required .~ [ "tests", "submission" ] + getChallengeSubmissions :: ((Entity Submission) -> Bool) -> Text -> Handler Html getChallengeSubmissions condition name = do Entity challengeId challenge <- runDB $ getBy404 $ UniqueName name diff --git a/Handler/Swagger.hs b/Handler/Swagger.hs index 5d8ee01..fa75447 100644 --- a/Handler/Swagger.hs +++ b/Handler/Swagger.hs @@ -12,7 +12,7 @@ getSwaggerR :: Handler Value getSwaggerR = return $ toJSON apiDescription apiDescription :: Swagger -apiDescription = generalApi <> listChallengesApi <> leaderboardApi +apiDescription = generalApi <> listChallengesApi <> leaderboardApi <> allSubmissionsApi <> mySubmissionsApi generalApi :: Swagger generalApi = (mempty :: Swagger) diff --git a/Handler/Tables.hs b/Handler/Tables.hs index 893fc66..74193f8 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -29,6 +29,13 @@ import GEval.EvaluationScheme import GEval.ParseParams (parseParamsFromFilePath, OutputFileParsed(..)) +import Data.Swagger hiding (get) +import qualified Data.Swagger as DS +import Data.Swagger.Declare +import Data.Proxy as DPR +import Control.Lens hiding ((.=), (^.)) +import Data.HashMap.Strict.InsOrd (fromList) + data TestReference = TestReference Text Text deriving (Show, Eq, Ord) @@ -38,6 +45,16 @@ instance ToJSON TestReference where "metric" .= metric ] +instance ToSchema TestReference where + declareNamedSchema _ = do + stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String) + return $ NamedSchema (Just "TestReference") $ mempty + & type_ .~ SwaggerObject + & properties .~ + Data.HashMap.Strict.InsOrd.fromList [ ("name", stringSchema) + , ("metric", stringSchema) + ] + & required .~ [ "name", "metric" ] getTestReference :: Entity Test -> TestReference getTestReference (Entity _ test) = TestReference (Data.Text.pack $ show $ testMetric test) (testName test) @@ -51,7 +68,7 @@ data LeaderboardEntry = LeaderboardEntry { leaderboardBestVariantId :: VariantId, leaderboardEvaluationMap :: Map TestReference Evaluation, leaderboardNumberOfSubmissions :: Int, - leaderboardTags :: [(Entity Tag, Entity SubmissionTag)], + leaderboardTags :: [(Entity Import.Tag, Entity SubmissionTag)], leaderboardParams :: [Parameter], leaderboardVersion :: (Int, Int, Int) } @@ -61,7 +78,7 @@ data TableEntry = TableEntry { tableEntryVariant :: Entity Variant, tableEntrySubmitter :: Entity User, tableEntryMapping :: Map TestReference Evaluation, - tableEntryTagsInfo :: [(Entity Tag, Entity SubmissionTag)], + tableEntryTagsInfo :: [(Entity Import.Tag, Entity SubmissionTag)], tableEntryParams :: [Entity Parameter], tableEntryRank :: Int, tableEntryVersion :: (Int, Int, Int) } @@ -456,7 +473,7 @@ getScore testId variantId = do data BasicSubmissionInfo = BasicSubmissionInfo { basicSubmissionInfoUser :: User, - basicSubmissionInfoTagEnts :: [(Entity Tag, Entity SubmissionTag)], + basicSubmissionInfoTagEnts :: [(Entity Import.Tag, Entity SubmissionTag)], basicSubmissionInfoVersion :: Version } getBasicSubmissionInfo :: (MonadIO m, PersistQueryRead backend,