{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
module Gargantext.Orphans.OpenAPI where

import Conduit qualified as C
import Control.Lens
import Data.HashMap.Strict.InsOrd qualified as HM
import Data.OpenApi as OpenAPI hiding (Header, Server)
import Data.OpenApi.Declare
import Data.Swagger.Declare qualified as SwaggerDeclare
import Data.Swagger.Internal qualified as Swagger
import Data.Swagger qualified as Swagger
import Data.Text qualified as T
import Data.Typeable
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 []) :)

-- Working with the compat shim a bit more pleasant

class SwaggerConvertible a b where
  swagConv :: Iso' a b

--
-- Instances
--

instance Typeable b => ToSchema (C.ConduitT () b IO ()) where
  declareNamedSchema _ = pure $ NamedSchema Nothing binarySchema

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 = view (from swagConv) <$> view Swagger.type_ ps
  , OpenAPI._schemaFormat = view Swagger.format ps
  , OpenAPI._schemaNullable = Nothing
  , OpenAPI._schemaEnum = view Swagger.enum_ ps
  , OpenAPI._schemaMaximum = view Swagger.maximum_ 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 = view Swagger.uniqueItems ps
  , OpenAPI._schemaMaxProperties = Nothing
  , OpenAPI._schemaMinProperties = Nothing
  , OpenAPI._schemaAdditionalProperties = Nothing
  , OpenAPI._schemaItems = convertItems <$> view Swagger.items 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 = view Swagger.multipleOf ps
  }


convertItems :: Swagger.SwaggerItems 'Swagger.SwaggerKindSchema -> OpenAPI.OpenApiItems
convertItems (Swagger.SwaggerItemsPrimitive _collectionFormat paramSchema) =
  OpenAPI.OpenApiItemsObject $ OpenAPI.Inline $ fromParamSchema paramSchema
convertItems (Swagger.SwaggerItemsObject referencedSchema) =
  OpenAPI.OpenApiItemsObject $ view (from swagConv) $ referencedSchema
convertItems (Swagger.SwaggerItemsArray referencedSchemas) =
  OpenAPI.OpenApiItemsArray $ map (view (from swagConv)) $ referencedSchemas

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
  { OpenAPI._schemaTitle = view Swagger.title swaggerSchema
  , OpenAPI._schemaDescription = view Swagger.description swaggerSchema
  , OpenAPI._schemaDefault = view Swagger.default_ swaggerSchema
  , OpenAPI._schemaExample = view Swagger.example 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 = swaggerSchema ^. Swagger.paramSchema . Swagger.exclusiveMaximum
  , OpenAPI._schemaMinimum = view Swagger.minimum_ swaggerSchema
  , 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 = view (from swagConv) <$> view Swagger.additionalProperties swaggerSchema
  , OpenAPI._schemaItems = convertItems <$> view Swagger.items swaggerSchema
  , OpenAPI._schemaProperties = HM.map (view (from swagConv)) $ view Swagger.properties swaggerSchema
  , OpenAPI._schemaRequired = view Swagger.required swaggerSchema
  , OpenAPI._schemaAllOf = map (view (from swagConv)) <$> view Swagger.allOf swaggerSchema
  , OpenAPI._schemaOneOf = Nothing
  , OpenAPI._schemaNot = Nothing
  , OpenAPI._schemaAnyOf = Nothing
  , OpenAPI._schemaDiscriminator = view (from swagConv) <$> view Swagger.discriminator swaggerSchema
  , OpenAPI._schemaReadOnly = view Swagger.readOnly swaggerSchema
  , OpenAPI._schemaWriteOnly = Nothing
  , 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.

instance {-# OVERLAPS #-} (Typeable a, Swagger.ToParamSchema a) => ToParamSchema a where
  toParamSchema p = fromParamSchema $ Swagger.toParamSchema p

instance {-# OVERLAPS #-} (Typeable a, Swagger.ToSchema a) => ToSchema a where
  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
      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
