More swagger

2021-02-05 14:44:46 +01:00 · 2021-02-05 14:44:46 +01:00 · 98325e47b6
commit 98325e47b6
parent 301343e3a2
3 changed files with 125 additions and 4 deletions
--- 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
--- 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)
--- 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,