More swagger

This commit is contained in:
Filip Gralinski 2021-02-05 14:44:46 +01:00
parent 301343e3a2
commit 98325e47b6
3 changed files with 125 additions and 4 deletions

View File

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

View File

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

View File

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