Accumulate declarations in OpenAPI.ToSchema compat shim

src/Gargantext/Orphans/OpenAPI.hs

@@ -3,16 +3,20 @@
 {-# LANGUAGE TypeApplications     #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
 module Gargantext.Orphans.OpenAPI where
 
 import Control.Lens
-import Data.Typeable
 import Data.HashMap.Strict.InsOrd qualified as HM
 import Data.OpenApi as OpenAPI hiding (Header, Server)
+import Data.OpenApi.Declare
+import Data.Swagger.Internal qualified as Swagger
 import Data.Swagger qualified as Swagger
-import Data.Swagger.Internal.Schema qualified as Swagger
 import Data.Text qualified as T
+import Data.Typeable
 import Prelude
+import qualified Data.Swagger.Declare as SwaggerDeclare
 import Servant.API
 import Servant.Auth
 import Servant.OpenApi
@@ -72,13 +76,141 @@ addSecurityRequirement securityRequirement =
     . security
     %~ ((SecurityRequirement $ HM.singleton securityRequirement []) :)
 
-fromParamSchema :: Swagger.ParamSchema t -> Schema
+-- Working with the compat shim a bit more pleasant
+
+class SwaggerConvertible a b where
+  swagConv :: Iso' a b
+
+--
+-- Instances
+--
+
+instance SwaggerConvertible OpenAPI.Discriminator T.Text where
+  swagConv = iso OpenAPI._discriminatorPropertyName convertDiscriminator
+    where
+      convertDiscriminator :: T.Text -> OpenAPI.Discriminator
+      convertDiscriminator t = OpenAPI.Discriminator t mempty
+
+instance SwaggerConvertible OpenAPI.OpenApiType (Swagger.SwaggerType 'Swagger.SwaggerKindSchema) where
+  swagConv = iso fromOpenAPI toOpenAPI
+    where
+      toOpenAPI :: Swagger.SwaggerType t -> OpenAPI.OpenApiType
+      toOpenAPI Swagger.SwaggerString = OpenAPI.OpenApiString
+      toOpenAPI Swagger.SwaggerNumber = OpenAPI.OpenApiNumber
+      toOpenAPI Swagger.SwaggerInteger = OpenAPI.OpenApiInteger
+      toOpenAPI Swagger.SwaggerBoolean = OpenAPI.OpenApiBoolean
+      toOpenAPI Swagger.SwaggerArray = OpenAPI.OpenApiArray
+      toOpenAPI Swagger.SwaggerFile = OpenAPI.OpenApiString -- OpenAPI lacks file type, fallback to string
+      toOpenAPI Swagger.SwaggerNull = OpenAPI.OpenApiNull
+      toOpenAPI Swagger.SwaggerObject = OpenAPI.OpenApiObject
+
+      fromOpenAPI OpenAPI.OpenApiString  =  Swagger.SwaggerString
+      fromOpenAPI OpenAPI.OpenApiNumber  =  Swagger.SwaggerNumber
+      fromOpenAPI OpenAPI.OpenApiInteger = Swagger.SwaggerInteger
+      fromOpenAPI OpenAPI.OpenApiBoolean = Swagger.SwaggerBoolean
+      fromOpenAPI OpenAPI.OpenApiArray   = Swagger.SwaggerArray
+      fromOpenAPI OpenAPI.OpenApiNull    = Swagger.SwaggerNull
+      fromOpenAPI OpenAPI.OpenApiObject  = Swagger.SwaggerObject
+
+instance SwaggerConvertible OpenAPI.Xml (Swagger.Xml) where
+  swagConv = iso fromOpenAPI toOpenAPI
+   where
+     fromOpenAPI :: Xml -> Swagger.Xml
+     fromOpenAPI OpenAPI.Xml
+        { OpenAPI._xmlName = xname
+        , OpenAPI._xmlNamespace = xnamespace
+        , OpenAPI._xmlPrefix = xprefix
+        , OpenAPI._xmlAttribute = xattribute
+        , OpenAPI._xmlWrapped = xwrapped
+        } = Swagger.Xml { Swagger._xmlName = xname
+                       , Swagger._xmlNamespace = xnamespace
+                       , Swagger._xmlPrefix = xprefix
+                       , Swagger._xmlAttribute = xattribute
+                       , Swagger._xmlWrapped = xwrapped }
+
+     toOpenAPI :: Swagger.Xml -> Xml
+     toOpenAPI Swagger.Xml { Swagger._xmlName = xname
+                       , Swagger._xmlNamespace = xnamespace
+                       , Swagger._xmlPrefix = xprefix
+                       , Swagger._xmlAttribute = xattribute
+                       , Swagger._xmlWrapped = xwrapped } =
+      OpenAPI.Xml
+        { OpenAPI._xmlName = xname
+        , OpenAPI._xmlNamespace = xnamespace
+        , OpenAPI._xmlPrefix = xprefix
+        , OpenAPI._xmlAttribute = xattribute
+        , OpenAPI._xmlWrapped = xwrapped
+        }
+
+instance SwaggerConvertible OpenAPI.URL (Swagger.URL) where
+  swagConv = iso fromOpenAPI toOpenAPI
+    where
+      fromOpenAPI :: URL -> Swagger.URL
+      fromOpenAPI (URL u) = Swagger.URL u
+
+      toOpenAPI :: Swagger.URL -> URL
+      toOpenAPI = OpenAPI.URL . Swagger.getUrl
+
+instance SwaggerConvertible ExternalDocs Swagger.ExternalDocs where
+  swagConv = iso fromOpenAPI toOpenAPI
+    where
+     toOpenAPI :: Swagger.ExternalDocs -> ExternalDocs
+     toOpenAPI Swagger.ExternalDocs { Swagger._externalDocsDescription = desc
+                                    , Swagger._externalDocsUrl = docurl } =
+       OpenAPI.ExternalDocs
+         { OpenAPI._externalDocsDescription = desc
+         , OpenAPI._externalDocsUrl = view (from swagConv) $ docurl
+         }
+
+     fromOpenAPI :: ExternalDocs -> Swagger.ExternalDocs
+     fromOpenAPI OpenAPI.ExternalDocs
+         { OpenAPI._externalDocsDescription = desc
+         , OpenAPI._externalDocsUrl = docurl
+         } = Swagger.ExternalDocs { Swagger._externalDocsDescription = desc
+                                  , Swagger._externalDocsUrl = view swagConv docurl
+                                  }
+
+instance SwaggerConvertible a b => SwaggerConvertible (Referenced a) (Swagger.Referenced b) where
+  swagConv = iso fromOpenAPI toOpenAPI
+   where
+     fromOpenAPI :: Referenced a -> Swagger.Referenced b
+     fromOpenAPI (OpenAPI.Ref (OpenAPI.Reference ref)) = Swagger.Ref (Swagger.Reference ref)
+     fromOpenAPI (OpenAPI.Inline s) = Swagger.Inline (view swagConv s)
+
+     toOpenAPI :: Swagger.Referenced b -> OpenAPI.Referenced a
+     toOpenAPI (Swagger.Ref ref) = OpenAPI.Ref $ OpenAPI.Reference (Swagger.getReference ref)
+     toOpenAPI (Swagger.Inline s) = OpenAPI.Inline $ view (from swagConv) s
+
+instance SwaggerConvertible Schema Swagger.Schema where
+  swagConv = iso toSwaggerSchema fromSwaggerSchema
+
+instance SwaggerConvertible AdditionalProperties Swagger.AdditionalProperties where
+  swagConv = iso fromOpenAPI toOpenAPI
+    where
+      fromOpenAPI :: AdditionalProperties -> Swagger.AdditionalProperties
+      fromOpenAPI (OpenAPI.AdditionalPropertiesAllowed allowed) =
+        Swagger.AdditionalPropertiesAllowed allowed
+      fromOpenAPI (OpenAPI.AdditionalPropertiesSchema ref) =
+        Swagger.AdditionalPropertiesSchema (view swagConv ref)
+
+      toOpenAPI :: Swagger.AdditionalProperties -> AdditionalProperties
+      toOpenAPI (Swagger.AdditionalPropertiesAllowed allowed) =
+        OpenAPI.AdditionalPropertiesAllowed allowed
+      toOpenAPI (Swagger.AdditionalPropertiesSchema ref) =
+        OpenAPI.AdditionalPropertiesSchema (view (from swagConv) ref)
+
+
+--
+-- Putting everything together
+--
+
+fromParamSchema :: Swagger.ParamSchema 'Swagger.SwaggerKindSchema -> Schema
 fromParamSchema ps = OpenAPI.Schema
   { OpenAPI._schemaTitle = Nothing
   , OpenAPI._schemaDescription = Nothing
   , OpenAPI._schemaDefault = view Swagger.default_ ps
   , OpenAPI._schemaExample = Nothing
-  , OpenAPI._schemaType = convertType <$> view Swagger.type_ ps
+  , OpenAPI._schemaType = view (from swagConv) <$> view Swagger.type_ ps
   , OpenAPI._schemaFormat = view Swagger.format ps
   , OpenAPI._schemaNullable = Nothing
   , OpenAPI._schemaEnum = view Swagger.enum_ ps
@@ -111,61 +243,19 @@ fromParamSchema ps = OpenAPI.Schema
   , OpenAPI._schemaMultipleOf = view Swagger.multipleOf ps
   }
 
-convertType :: Swagger.SwaggerType t -> OpenAPI.OpenApiType
-convertType Swagger.SwaggerString = OpenAPI.OpenApiString
-convertType Swagger.SwaggerNumber = OpenAPI.OpenApiNumber
-convertType Swagger.SwaggerInteger = OpenAPI.OpenApiInteger
-convertType Swagger.SwaggerBoolean = OpenAPI.OpenApiBoolean
-convertType Swagger.SwaggerArray = OpenAPI.OpenApiArray
-convertType Swagger.SwaggerFile = OpenAPI.OpenApiString -- OpenAPI lacks file type, fallback to string
-convertType Swagger.SwaggerNull = OpenAPI.OpenApiNull
-convertType Swagger.SwaggerObject = OpenAPI.OpenApiObject
-
-convertItems :: Swagger.SwaggerItems t -> OpenAPI.OpenApiItems
+
+convertItems :: Swagger.SwaggerItems 'Swagger.SwaggerKindSchema -> OpenAPI.OpenApiItems
 convertItems (Swagger.SwaggerItemsPrimitive _collectionFormat paramSchema) =
   OpenAPI.OpenApiItemsObject $ OpenAPI.Inline $ fromParamSchema paramSchema
 convertItems (Swagger.SwaggerItemsObject referencedSchema) =
-  OpenAPI.OpenApiItemsObject $ convertRef referencedSchema
+  OpenAPI.OpenApiItemsObject $ view (from swagConv) $ referencedSchema
 convertItems (Swagger.SwaggerItemsArray referencedSchemas) =
-  OpenAPI.OpenApiItemsArray $ map convertRef referencedSchemas
-
-convertRef :: Swagger.Referenced Swagger.Schema -> OpenAPI.Referenced OpenAPI.Schema
-convertRef (Swagger.Ref ref) = OpenAPI.Ref $ OpenAPI.Reference (Swagger.getReference ref)
-convertRef (Swagger.Inline s) = OpenAPI.Inline $ fromSwaggerSchema s
-
-convertAdditionalProps :: Swagger.AdditionalProperties -> OpenAPI.AdditionalProperties
-convertAdditionalProps (Swagger.AdditionalPropertiesAllowed allowed) =
-  OpenAPI.AdditionalPropertiesAllowed allowed
-convertAdditionalProps (Swagger.AdditionalPropertiesSchema ref) =
-  OpenAPI.AdditionalPropertiesSchema (convertRef ref)
-
-convertDocs :: Swagger.ExternalDocs -> OpenAPI.ExternalDocs
-convertDocs Swagger.ExternalDocs { Swagger._externalDocsDescription = desc
-                                 , Swagger._externalDocsUrl = docurl } =
-  OpenAPI.ExternalDocs
-    { OpenAPI._externalDocsDescription = desc
-    , OpenAPI._externalDocsUrl = convertURL docurl
-    }
-
-convertURL :: Swagger.URL -> OpenAPI.URL
-convertURL = OpenAPI.URL . Swagger.getUrl
-
-convertXml :: Swagger.Xml -> OpenAPI.Xml
-convertXml Swagger.Xml { Swagger._xmlName = xname
-                       , Swagger._xmlNamespace = xnamespace
-                       , Swagger._xmlPrefix = xprefix
-                       , Swagger._xmlAttribute = xattribute
-                       , Swagger._xmlWrapped = xwrapped } =
-  OpenAPI.Xml
-    { OpenAPI._xmlName = xname
-    , OpenAPI._xmlNamespace = xnamespace
-    , OpenAPI._xmlPrefix = xprefix
-    , OpenAPI._xmlAttribute = xattribute
-    , OpenAPI._xmlWrapped = xwrapped
-    }
+  OpenAPI.OpenApiItemsArray $ map (view (from swagConv)) $ referencedSchemas
 
-convertDiscriminator :: T.Text -> OpenAPI.Discriminator
-convertDiscriminator t = OpenAPI.Discriminator t mempty
+convertItems' :: OpenApiItems -> Swagger.SwaggerItems 'Swagger.SwaggerKindSchema
+convertItems' = \case
+  OpenAPI.OpenApiItemsObject s -> Swagger.SwaggerItemsObject (view swagConv s)
+  OpenAPI.OpenApiItemsArray xs -> Swagger.SwaggerItemsArray $ map (view swagConv) xs
 
 fromSwaggerSchema :: Swagger.Schema -> OpenAPI.Schema
 fromSwaggerSchema swaggerSchema = OpenAPI.Schema
@@ -173,39 +263,74 @@ fromSwaggerSchema swaggerSchema = OpenAPI.Schema
   , OpenAPI._schemaDescription = view Swagger.description swaggerSchema
   , OpenAPI._schemaDefault = view Swagger.default_ swaggerSchema
   , OpenAPI._schemaExample = view Swagger.example swaggerSchema
-  , OpenAPI._schemaType = convertType <$> view Swagger.type_ swaggerSchema
+  , OpenAPI._schemaType = view (from swagConv) <$> view Swagger.type_ swaggerSchema
   , OpenAPI._schemaFormat = view Swagger.format swaggerSchema
   , OpenAPI._schemaNullable = Nothing
   , OpenAPI._schemaEnum = view Swagger.enum_ swaggerSchema
   , OpenAPI._schemaMaximum = view Swagger.maximum_ swaggerSchema
-  , OpenAPI._schemaExclusiveMaximum = Nothing
+  , OpenAPI._schemaExclusiveMaximum = swaggerSchema ^. Swagger.paramSchema . Swagger.exclusiveMaximum
   , OpenAPI._schemaMinimum = view Swagger.minimum_ swaggerSchema
-  , OpenAPI._schemaExclusiveMinimum = Nothing
-  , OpenAPI._schemaMaxLength = Nothing
-  , OpenAPI._schemaMinLength = Nothing
-  , OpenAPI._schemaPattern = Nothing
-  , OpenAPI._schemaMaxItems = Nothing
-  , OpenAPI._schemaMinItems = Nothing
+  , OpenAPI._schemaExclusiveMinimum = swaggerSchema ^. Swagger.paramSchema . Swagger.exclusiveMinimum
+  , OpenAPI._schemaMaxLength = swaggerSchema ^. Swagger.paramSchema . Swagger.maxLength
+  , OpenAPI._schemaMinLength = swaggerSchema ^. Swagger.paramSchema . Swagger.minLength
+  , OpenAPI._schemaPattern = swaggerSchema ^. Swagger.paramSchema . Swagger.pattern
+  , OpenAPI._schemaMaxItems = swaggerSchema ^. Swagger.paramSchema . Swagger.maxItems
+  , OpenAPI._schemaMinItems = swaggerSchema ^. Swagger.paramSchema . Swagger.minItems
   , OpenAPI._schemaUniqueItems = view Swagger.uniqueItems swaggerSchema
   , OpenAPI._schemaMaxProperties = view Swagger.maxProperties swaggerSchema
   , OpenAPI._schemaMinProperties = view Swagger.minProperties swaggerSchema
-  , OpenAPI._schemaAdditionalProperties = convertAdditionalProps <$> view Swagger.additionalProperties swaggerSchema
+  , OpenAPI._schemaAdditionalProperties = view (from swagConv) <$> view Swagger.additionalProperties swaggerSchema
   , OpenAPI._schemaItems = convertItems <$> view Swagger.items swaggerSchema
-  , OpenAPI._schemaProperties = HM.map convertRef $ view Swagger.properties swaggerSchema
+  , OpenAPI._schemaProperties = HM.map (view (from swagConv)) $ view Swagger.properties swaggerSchema
   , OpenAPI._schemaRequired = view Swagger.required swaggerSchema
-  , OpenAPI._schemaAllOf = map convertRef <$> view Swagger.allOf swaggerSchema
+  , OpenAPI._schemaAllOf = map (view (from swagConv)) <$> view Swagger.allOf swaggerSchema
   , OpenAPI._schemaOneOf = Nothing
   , OpenAPI._schemaNot = Nothing
   , OpenAPI._schemaAnyOf = Nothing
-  , OpenAPI._schemaDiscriminator = convertDiscriminator <$> view Swagger.discriminator swaggerSchema
+  , OpenAPI._schemaDiscriminator = view (from swagConv) <$> view Swagger.discriminator swaggerSchema
   , OpenAPI._schemaReadOnly = view Swagger.readOnly swaggerSchema
   , OpenAPI._schemaWriteOnly = Nothing
-  , OpenAPI._schemaXml = convertXml <$> view Swagger.xml swaggerSchema
-  , OpenAPI._schemaExternalDocs = convertDocs <$> view Swagger.externalDocs swaggerSchema
+  , OpenAPI._schemaXml = view (from swagConv) <$> view Swagger.xml swaggerSchema
+  , OpenAPI._schemaExternalDocs = view (from swagConv) <$> view Swagger.externalDocs swaggerSchema
   , OpenAPI._schemaDeprecated = Nothing
   , OpenAPI._schemaMultipleOf = view Swagger.multipleOf swaggerSchema
   }
 
+toSwaggerSchema :: Schema -> Swagger.Schema
+toSwaggerSchema s@Schema{..} = Swagger.Schema
+  { Swagger._schemaTitle = view title s
+  , Swagger._schemaDescription = view description s
+  , Swagger._schemaRequired = _schemaRequired
+  , Swagger._schemaAllOf = map (view swagConv) <$> _schemaAllOf
+  , Swagger._schemaProperties = HM.map (view swagConv) $ _schemaProperties
+  , Swagger._schemaAdditionalProperties = view swagConv <$> _schemaAdditionalProperties
+  , Swagger._schemaDiscriminator = view swagConv <$> view discriminator s
+  , Swagger._schemaReadOnly = view readOnly s
+  , Swagger._schemaXml = view swagConv <$> _schemaXml
+  , Swagger._schemaExternalDocs = view swagConv <$> _schemaExternalDocs
+  , Swagger._schemaExample = view example s
+  , Swagger._schemaMaxProperties = view maxProperties s
+  , Swagger._schemaMinProperties = view minProperties s
+  , Swagger._schemaParamSchema = Swagger.ParamSchema {
+       _paramSchemaDefault = _schemaDefault
+     , _paramSchemaType = view swagConv <$> _schemaType
+     , _paramSchemaFormat = _schemaFormat
+     , _paramSchemaItems = convertItems' <$> _schemaItems
+     , _paramSchemaMaximum = _schemaMaximum
+     , _paramSchemaExclusiveMaximum = _schemaExclusiveMaximum
+     , _paramSchemaMinimum = _schemaMinimum
+     , _paramSchemaExclusiveMinimum = _schemaExclusiveMinimum
+     , _paramSchemaMaxLength = _schemaMaxLength
+     , _paramSchemaMinLength = _schemaMinLength
+     , _paramSchemaPattern = _schemaPattern
+     , _paramSchemaMaxItems = _schemaMaxItems
+     , _paramSchemaMinItems = _schemaMinItems
+     , _paramSchemaUniqueItems = _schemaUniqueItems
+     , _paramSchemaEnum = _schemaEnum
+     , _paramSchemaMultipleOf = _schemaMultipleOf
+     }
+  }
+
 -- little compat-shim to avoid re-implementing 'ToSchema' and 'ToParamSchema' for each
 -- and every type, while we transition away from swagger.
 
@@ -213,8 +338,15 @@ instance {-# OVERLAPS #-} (Typeable a, Swagger.ToParamSchema a) => ToParamSchema
   toParamSchema p = fromParamSchema $ Swagger.toParamSchema p
 
 instance {-# OVERLAPS #-} (Typeable a, Swagger.ToSchema a) => ToSchema a where
-  declareNamedSchema _ =
-    pure $ OpenAPI.NamedSchema swaggerName openApiSchema
+  declareNamedSchema p = DeclareT $ \d -> do
+    let (toRegister, Swagger.NamedSchema swaggerName swaggerSchema) =
+          flip SwaggerDeclare.runDeclare (lowerD d) (Swagger.declareNamedSchema p)
+    pure $ (convertDefinitions toRegister, OpenAPI.NamedSchema swaggerName (openApiSchema swaggerSchema))
     where
-      Swagger.NamedSchema swaggerName swaggerSchema = Swagger.toNamedSchema (Proxy :: Proxy a)
-      openApiSchema = fromSwaggerSchema swaggerSchema
+      openApiSchema s = fromSwaggerSchema s
+
+convertDefinitions :: Swagger.Definitions Swagger.Schema -> Definitions Schema
+convertDefinitions = HM.map fromSwaggerSchema
+
+lowerD :: Definitions Schema -> Swagger.Definitions Swagger.Schema
+lowerD = HM.map toSwaggerSchema