[#114] Fix swagger structural error

Problem: list of tuples - [(EntryPath, EntryPath)] - used in the WebAPI for `copy` and `rename` causes errors in Swagger docs. See #115 (comment) Solution: introduce type `PairObject` just to fix this error.
serokell · Jul 25, 2022 · fa353ce · fa353ce
1 parent 93c62d6
commit fa353ce
Show file tree

Hide file tree

Showing 4 changed files with 43 additions and 32 deletions.
diff --git a/docs/swagger.json b/docs/swagger.json
@@ -10,6 +10,21 @@
     },
     "components": {
         "schemas": {
+            "PairObject_EntryPath": {
+                "type": "object",
+                "required": [
+                    "first",
+                    "second"
+                ],
+                "properties": {
+                    "second": {
+                        "$ref": "#/components/schemas/EntryPath"
+                    },
+                    "first": {
+                        "$ref": "#/components/schemas/EntryPath"
+                    }
+                }
+            },
             "EntryPath": {
                 "type": "string",
                 "pattern": "(/[abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_]*)+"
@@ -353,17 +368,7 @@
                             "application/json;charset=utf-8": {
                                 "schema": {
                                     "items": {
-                                        "items": [
-                                            {
-                                                "$ref": "#/components/schemas/EntryPath"
-                                            },
-                                            {
-                                                "$ref": "#/components/schemas/EntryPath"
-                                            }
-                                        ],
-                                        "type": "array",
-                                        "maxItems": 2,
-                                        "minItems": 2
+                                        "$ref": "#/components/schemas/PairObject_EntryPath"
                                     },
                                     "type": "array"
                                 }
@@ -425,17 +430,7 @@
                             "application/json;charset=utf-8": {
                                 "schema": {
                                     "items": {
-                                        "items": [
-                                            {
-                                                "$ref": "#/components/schemas/EntryPath"
-                                            },
-                                            {
-                                                "$ref": "#/components/schemas/EntryPath"
-                                            }
-                                        ],
-                                        "type": "array",
-                                        "maxItems": 2,
-                                        "minItems": 2
+                                        "$ref": "#/components/schemas/PairObject_EntryPath"
                                     },
                                     "type": "array"
                                 }

diff --git a/lib/Web/API.hs b/lib/Web/API.hs
@@ -12,7 +12,7 @@ import Data.Text (Text)
 import Entry
 import GHC.Generics (Generic)
 import Servant.API
-import Web.Types (NewEntry)
+import Web.Types (NewEntry, PairObject)
 
 type API
   = Header' [Required, Strict] "token" VaultToken
@@ -54,14 +54,14 @@ type API
       :> RequiredParam "old-path" (QualifiedPath Path)
       :> RequiredParam "new-path" (QualifiedPath Path)
       :> QueryFlag     "force"
-      :> Post '[JSON] [(EntryPath, EntryPath)]
+      :> Post '[JSON] [PairObject EntryPath]
 
     :<|> "copy"
       :> QueryFlag     "dry-run"
       :> RequiredParam "old-path" (QualifiedPath Path)
       :> RequiredParam "new-path" (QualifiedPath Path)
       :> QueryFlag     "force"
-      :> Post '[JSON] [(EntryPath, EntryPath)]
+      :> Post '[JSON] [PairObject EntryPath]
 
     :<|> "delete"
       :> QueryFlag     "dry-run"

diff --git a/lib/Web/Server.hs b/lib/Web/Server.hs
@@ -38,7 +38,7 @@ import Fmt (Builder, pretty, unlinesF)
 import GHC.Generics (Generic)
 import Servant.API
 import Servant.Server
-import Web.Types (NewEntry(NewEntry), NewField(NewField))
+import Web.Types (NewEntry(NewEntry), NewField(NewField), mkPair, PairObject)
 
 data CofferServerError = CofferServerError
   { cseError :: Text
@@ -71,9 +71,9 @@ handleSetFieldResult = \case
   where
     pretty = resultToText buildSetFieldResult
 
-handleCopyOrRenameResult :: Bool -> CopyResult -> Handler [(EntryPath, EntryPath)]
+handleCopyOrRenameResult :: Bool -> CopyResult -> Handler [PairObject EntryPath]
 handleCopyOrRenameResult rename = \case
-  CPRSuccess _ paths -> pure (paths <&> bimap qpPath qpPath)
+  CPRSuccess _ paths -> pure (paths <&> (mkPair . bimap qpPath qpPath))
   res@CPRPathNotFound{} ->
     throwCofferServerError err404 500 (prettySingleMessage res)
   res@CPRMissingEntryName{} ->
@@ -97,10 +97,10 @@ handleCopyOrRenameResult rename = \case
       CEDestinationIsDirectory{} -> 504
       CEEntryAlreadyExists{} -> 505
 
-handleCopyResult :: CopyResult -> Handler [(EntryPath, EntryPath)]
+handleCopyResult :: CopyResult -> Handler [PairObject EntryPath]
 handleCopyResult = handleCopyOrRenameResult False
 
-handleRenameResult :: RenameResult -> Handler [(EntryPath, EntryPath)]
+handleRenameResult :: RenameResult -> Handler [PairObject EntryPath]
 handleRenameResult = handleCopyOrRenameResult True
 
 runBackendIO' :: Sem '[BackendEffect, Error CofferError, Embed IO, Final IO] a -> IO (Either CofferError a)
@@ -286,7 +286,7 @@ rename
   -> QualifiedPath Path
   -> QualifiedPath Path
   -> Bool
-  -> Handler [(EntryPath, EntryPath)]
+  -> Handler [PairObject EntryPath]
 rename run token roDryRun roQOldPath roQNewPath roForce =
   run token (CmdRename RenameOptions
     { roDryRun
@@ -302,7 +302,7 @@ copy'
   -> QualifiedPath Path
   -> QualifiedPath Path
   -> Bool
-  -> Handler [(EntryPath, EntryPath)]
+  -> Handler [PairObject EntryPath]
 copy' run token cpoDryRun cpoQOldPath cpoQNewPath cpoForce =
   run token (CmdCopy CopyOptions
     { cpoDryRun

diff --git a/lib/Web/Types.hs b/lib/Web/Types.hs
@@ -4,6 +4,7 @@
 
 module Web.Types where
 
+import Data.Aeson qualified as A
 import Data.Aeson.Casing (aesonPrefix, camelCase)
 import Data.Aeson.TH (deriveJSON)
 import Data.HashMap.Strict (HashMap)
@@ -30,3 +31,18 @@ deriveJSON (aesonPrefix camelCase) ''NewEntry
 
 instance ToSchema NewEntry where
   declareNamedSchema = genericDeclareNamedSchema $ fromAesonOptions (aesonPrefix camelCase)
+
+-- | Datatype that serves as a workaround for this issue:
+-- https://github.com/biocad/openapi3/issues/31
+data PairObject a = PairObject
+  { poFirst :: a
+  , poSecond :: a
+   }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (A.ToJSON, A.FromJSON)
+
+mkPair :: (a, a) -> PairObject a
+mkPair (a, b) = PairObject a b
+
+instance ToSchema a =>  ToSchema (PairObject a) where
+  declareNamedSchema = genericDeclareNamedSchema $ fromAesonOptions (aesonPrefix camelCase)