Make a start on using OpenAPI3

OpenAPI3 will allow us to properly pass the Bearer Auth to the servant
swagger UI.

gargantext.cabal

@@ -467,6 +467,8 @@ library
       Gargantext.Database.Schema.NodeNode
       Gargantext.Database.Schema.Prelude
       Gargantext.Database.Types
+      Gargantext.Orphans
+      Gargantext.Orphans.OpenAPI
       Gargantext.Utils.Aeson
       Gargantext.Utils.Servant
       Gargantext.Utils.UTCTime
@@ -562,6 +564,7 @@ library
     , opaleye ^>= 0.9.6.1
     , opaleye-textsearch >= 0.2.0.0
     , openalex
+    , openapi3 >= 3.2.3
     , parallel ^>= 3.2.2.0
     , parsec ^>= 3.1.16.1
     , patches-class ^>= 0.1.0.1
@@ -588,6 +591,7 @@ library
     , servant-client-core >= 0.20 && < 0.21
     , servant-ekg ^>= 0.3.1
     , servant-routes < 0.2
+    , servant-openapi3 >= 2.0.1.6
     , servant-server >= 0.18.3 && < 0.21
     , servant-swagger ^>= 1.2
     , servant-swagger-ui ^>= 0.3.5.3.5.0

src/Gargantext/API/Auth/PolicyCheck.hs

@@ -64,6 +64,7 @@ import Servant (HasServer(..), ServerT)
 import Servant.Server.Internal.Delayed (addParameterCheck)
 import Servant.Server.Internal.DelayedIO (DelayedIO(..))
 import Servant.Swagger qualified as Swagger
+import Servant.OpenApi qualified as OpenAPI
 
 -------------------------------------------------------------------------------
 -- Types
@@ -299,6 +300,9 @@ instance AddSetCookies ('S n) old new => AddSetCookies ('S n) (AccessPolicyManag
 instance Swagger.HasSwagger sub => Swagger.HasSwagger (PolicyChecked sub) where
     toSwagger _ = Swagger.toSwagger (Proxy :: Proxy sub)
 
+instance OpenAPI.HasOpenApi sub => OpenAPI.HasOpenApi (PolicyChecked sub) where
+    toOpenApi _ = OpenAPI.toOpenApi (Proxy :: Proxy sub)
+
 instance HasEndpoint sub => HasEndpoint (PolicyChecked sub) where
   getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
   enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)

src/Gargantext/API/Server/Named.hs

@@ -20,7 +20,7 @@ import Gargantext.API.GraphQL as GraphQL
 import Gargantext.API.Prelude (GargM)
 import Gargantext.API.Routes.Named
 import Gargantext.API.Server.Named.Public (serverPublicGargAPI)
-import Gargantext.API.Swagger (swaggerDoc)
+import Gargantext.API.Swagger (openApiDoc)
 import Gargantext.API.ThrowAll (serverPrivateGargAPI)
 import Gargantext.Core.Notifications.Dispatcher.WebSocket qualified as Dispatcher
 import Gargantext.Core.Config (gc_frontend_config, hasConfig)
@@ -50,7 +50,7 @@ serverGargAPI env
 server :: Env -> API AsServer
 server env =
   API $ \errScheme -> NamedAPI
-     { swaggerAPI = swaggerSchemaUIServer swaggerDoc
+     { swaggerAPI = swaggerSchemaUIServer openApiDoc
      , backendAPI = hoistServerWithContext
                       (Proxy :: Proxy (NamedRoutes BackEndAPI))
                       (Proxy :: Proxy AuthContext)

src/Gargantext/API/Swagger.hs

@@ -12,23 +12,37 @@ Portability : POSIX
 -}
 
 ---------------------------------------------------------------------
-module Gargantext.API.Swagger where
+module Gargantext.API.Swagger (
+    backendApiProxy
+  , openApiDoc
+  ) where
+
 ---------------------------------------------------------------------
 import Control.Lens ((?~))
+import Data.OpenApi (OpenApi)
 import Data.Swagger
 import Data.Version (showVersion)
 import Gargantext.API.Routes.Named qualified as Named
+import Gargantext.Orphans () -- instance HasOpenApi
+import Gargantext.Prelude
 import Gargantext.Prelude
-import Paths_gargantext qualified as PG -- cabal magic build module
+import qualified Paths_gargantext as PG -- cabal magic build module
 import Servant
-import Servant.Swagger (toSwagger, subOperations)
+import Servant.OpenApi (toOpenApi)
+import Servant.Swagger
 
 backendApiProxy :: Proxy (ToServantApi Named.BackEndAPI)
 backendApiProxy = Proxy
 
+-- | OpenAPI Specification. It supports programmatically adding the `Bearer` to the `Authorization`
+-- header, which makes the Swagger UI actually useable, unlike the 'swaggerDoc' counterpart which
+-- is stuck on version 2.x of the OpenAPI spec.
+openApiDoc :: OpenApi
+openApiDoc = toOpenApi backendApiProxy
+
 -- | Swagger Specifications
-swaggerDoc :: Swagger
-swaggerDoc = toSwagger backendApiProxy
+_swaggerDoc :: Swagger
+_swaggerDoc = toSwagger backendApiProxy
   & info.title       .~ "GarganText"
   & info.version     .~ (cs $ showVersion PG.version)
   -- & info.base_url     ?~ (URL "http://gargantext.org/")

src/Gargantext/Orphans.hs

+module Gargantext.Orphans (
+  module Gargantext.Orphans.OpenAPI
+  ) where
+
+import Gargantext.Orphans.OpenAPI

src/Gargantext/Orphans/OpenAPI.hs

+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE TypeApplications     #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+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.Swagger qualified as Swagger
+import Data.Swagger.Internal.Schema qualified as Swagger
+import Data.Text qualified as T
+import Prelude
+import Servant.API
+import Servant.Auth
+import Servant.OpenApi
+
+-- Auth instances
+
+instance (HasOpenApi api) => HasOpenApi (Servant.Auth.Auth '[] a :> api) where
+  toOpenApi Proxy = toOpenApi $ Proxy @api
+
+instance (HasOpenApi (Servant.Auth.Auth auths a :> api)) => HasOpenApi (Servant.Auth.Auth (Servant.Auth.BasicAuth : auths) a :> api) where
+  toOpenApi Proxy = addSecurity $ toOpenApi $ Proxy @(Servant.Auth.Auth auths a :> api)
+   where
+    addSecurity = addSecurityRequirement identifier . addSecurityScheme identifier securityScheme
+    identifier :: T.Text = "BasicAuth"
+    securityScheme =
+      SecurityScheme
+        { _securitySchemeType = SecuritySchemeHttp HttpSchemeBasic
+        , _securitySchemeDescription = Just "Basic Authentication"
+        }
+
+instance (HasOpenApi (Servant.Auth.Auth auths a :> api)) => HasOpenApi (Servant.Auth.Auth (Servant.Auth.JWT : auths) a :> api) where
+  toOpenApi Proxy = addSecurity $ toOpenApi $ Proxy @(Servant.Auth.Auth auths a :> api)
+   where
+    addSecurity = addSecurityRequirement identifier . addSecurityScheme identifier securityScheme
+    identifier :: T.Text = "JWT"
+    securityScheme =
+      SecurityScheme
+        { _securitySchemeType = SecuritySchemeHttp $ HttpSchemeBearer $ Just "JWT"
+        , _securitySchemeDescription = Just "Bearer Authentication"
+        }
+
+instance (HasOpenApi (Servant.Auth.Auth auths a :> api)) => HasOpenApi (Servant.Auth.Auth (Servant.Auth.Cookie : auths) a :> api) where
+  toOpenApi Proxy = addSecurity $ toOpenApi $ Proxy @(Servant.Auth.Auth auths a :> api)
+   where
+    addSecurity = addSecurityRequirement identifier . addSecurityScheme identifier securityScheme
+    identifier :: T.Text = "Cookie"
+    securityScheme =
+      SecurityScheme
+        { _securitySchemeType = SecuritySchemeHttp $ HttpSchemeBearer $ Just "JWT"
+        , _securitySchemeDescription = Just "Cookie Authentication"
+        }
+
+addSecurityScheme :: T.Text -> SecurityScheme -> OpenApi -> OpenApi
+addSecurityScheme securityIdentifier securityScheme openApi =
+  openApi
+    { _openApiComponents =
+        (_openApiComponents openApi)
+          { _componentsSecuritySchemes =
+              _componentsSecuritySchemes (_openApiComponents openApi)
+                <> SecurityDefinitions (HM.singleton securityIdentifier securityScheme)
+          }
+    }
+
+addSecurityRequirement :: T.Text -> OpenApi -> OpenApi
+addSecurityRequirement securityRequirement =
+  allOperations
+    . security
+    %~ ((SecurityRequirement $ HM.singleton securityRequirement []) :)
+
+fromParamSchema :: Swagger.ParamSchema t -> Schema
+fromParamSchema ps = OpenAPI.Schema
+  { OpenAPI._schemaTitle = Nothing
+  , OpenAPI._schemaDescription = Nothing
+  , OpenAPI._schemaDefault = Swagger._paramSchemaDefault ps
+  , OpenAPI._schemaExample = Nothing
+  , OpenAPI._schemaType = convertType <$> Swagger._paramSchemaType ps
+  , OpenAPI._schemaFormat = Swagger._paramSchemaFormat ps
+  , OpenAPI._schemaNullable = Nothing
+  , OpenAPI._schemaEnum = Swagger._paramSchemaEnum ps
+  , OpenAPI._schemaMaximum = Swagger._paramSchemaMaximum ps
+  , OpenAPI._schemaExclusiveMaximum = Swagger._paramSchemaExclusiveMaximum ps
+  , OpenAPI._schemaMinimum = Swagger._paramSchemaMinimum ps
+  , OpenAPI._schemaExclusiveMinimum = Swagger._paramSchemaExclusiveMinimum ps
+  , OpenAPI._schemaMaxLength = Swagger._paramSchemaMaxLength ps
+  , OpenAPI._schemaMinLength = Swagger._paramSchemaMinLength ps
+  , OpenAPI._schemaPattern = Swagger._paramSchemaPattern ps
+  , OpenAPI._schemaMaxItems = Swagger._paramSchemaMaxItems ps
+  , OpenAPI._schemaMinItems = Swagger._paramSchemaMinItems ps
+  , OpenAPI._schemaUniqueItems = Swagger._paramSchemaUniqueItems ps
+  , OpenAPI._schemaMaxProperties = Nothing
+  , OpenAPI._schemaMinProperties = Nothing
+  , OpenAPI._schemaAdditionalProperties = Nothing
+  , OpenAPI._schemaItems = convertItems <$> Swagger._paramSchemaItems ps
+  , OpenAPI._schemaProperties = mempty
+  , OpenAPI._schemaRequired = mempty
+  , OpenAPI._schemaAllOf = Nothing
+  , OpenAPI._schemaOneOf = Nothing
+  , OpenAPI._schemaNot = Nothing
+  , OpenAPI._schemaAnyOf = Nothing
+  , OpenAPI._schemaDiscriminator = Nothing
+  , OpenAPI._schemaReadOnly = Nothing
+  , OpenAPI._schemaWriteOnly = Nothing
+  , OpenAPI._schemaXml = Nothing
+  , OpenAPI._schemaExternalDocs = Nothing
+  , OpenAPI._schemaDeprecated = Nothing
+  , OpenAPI._schemaMultipleOf = Swagger._paramSchemaMultipleOf 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.SwaggerItemsPrimitive _collectionFormat paramSchema) =
+  OpenAPI.OpenApiItemsObject $ OpenAPI.Inline $ fromParamSchema paramSchema
+convertItems (Swagger.SwaggerItemsObject referencedSchema) =
+  OpenAPI.OpenApiItemsObject $ convertRef 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
+    }
+
+convertDiscriminator :: T.Text -> OpenAPI.Discriminator
+convertDiscriminator t = OpenAPI.Discriminator t mempty
+
+fromSwaggerSchema :: Swagger.Schema -> OpenAPI.Schema
+fromSwaggerSchema swaggerSchema = OpenAPI.Schema
+  { OpenAPI._schemaTitle = Swagger._schemaTitle swaggerSchema
+  , OpenAPI._schemaDescription = Swagger._schemaDescription swaggerSchema
+  , OpenAPI._schemaDefault = Nothing
+  , OpenAPI._schemaExample = Swagger._schemaExample swaggerSchema
+  , OpenAPI._schemaType = Nothing
+  , OpenAPI._schemaFormat = Nothing
+  , OpenAPI._schemaNullable = Nothing
+  , OpenAPI._schemaEnum = Nothing
+  , OpenAPI._schemaMaximum = Nothing
+  , OpenAPI._schemaExclusiveMaximum = Nothing
+  , OpenAPI._schemaMinimum = Nothing
+  , OpenAPI._schemaExclusiveMinimum = Nothing
+  , OpenAPI._schemaMaxLength = Nothing
+  , OpenAPI._schemaMinLength = Nothing
+  , OpenAPI._schemaPattern = Nothing
+  , OpenAPI._schemaMaxItems = Nothing
+  , OpenAPI._schemaMinItems = Nothing
+  , OpenAPI._schemaUniqueItems = Nothing
+  , OpenAPI._schemaMaxProperties = Swagger._schemaMaxProperties swaggerSchema
+  , OpenAPI._schemaMinProperties = Swagger._schemaMinProperties swaggerSchema
+  , OpenAPI._schemaAdditionalProperties = convertAdditionalProps <$> Swagger._schemaAdditionalProperties swaggerSchema
+  , OpenAPI._schemaItems = Nothing
+  , OpenAPI._schemaProperties = HM.map convertRef $ Swagger._schemaProperties swaggerSchema
+  , OpenAPI._schemaRequired = Swagger._schemaRequired swaggerSchema
+  , OpenAPI._schemaAllOf = map convertRef <$> Swagger._schemaAllOf swaggerSchema
+  , OpenAPI._schemaOneOf = Nothing
+  , OpenAPI._schemaNot = Nothing
+  , OpenAPI._schemaAnyOf = Nothing
+  , OpenAPI._schemaDiscriminator = convertDiscriminator <$> Swagger._schemaDiscriminator swaggerSchema
+  , OpenAPI._schemaReadOnly = Swagger._schemaReadOnly swaggerSchema
+  , OpenAPI._schemaWriteOnly = Nothing
+  , OpenAPI._schemaXml = convertXml <$> Swagger._schemaXml swaggerSchema
+  , OpenAPI._schemaExternalDocs = convertDocs <$> Swagger._schemaExternalDocs swaggerSchema
+  , OpenAPI._schemaDeprecated = Nothing
+  , OpenAPI._schemaMultipleOf = Nothing
+  }
+
+-- little compat-shim to avoid re-implementing 'ToSchema' and 'ToParamSchema' for each
+-- and every type, while we transition away from swagger.
+
+instance {-# OVERLAPPABLE #-} Swagger.ToParamSchema a => ToParamSchema a where
+  toParamSchema p = fromParamSchema $ Swagger.toParamSchema p
+
+instance {-# OVERLAPPABLE #-} (Typeable a, Swagger.ToSchema a) => ToSchema a where
+  declareNamedSchema _ = pure $ OpenAPI.NamedSchema swaggerName openApiSchema
+    where
+      Swagger.NamedSchema swaggerName swaggerSchema = Swagger.toNamedSchema (Proxy :: Proxy a)
+      openApiSchema = fromSwaggerSchema swaggerSchema