{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Wire.API.User.Orphans where

import Control.Lens
import Data.Aeson qualified as A
import Data.Char
import Data.Currency qualified as Currency
import Data.ISO3166_CountryCodes
import Data.LanguageCodes
import Data.OpenApi
import Data.Proxy
import Data.UUID
import Data.X509 as X509
import Imports
import SAML2.WebSSO qualified as SAML
import SAML2.WebSSO.Types.TH (deriveJSONOptions)
import Servant.API ((:>))
import Servant.Multipart qualified as SM
import Servant.OpenApi
import URI.ByteString

deriving instance Generic ISO639_1

-- Swagger instances

instance ToSchema ISO639_1

instance ToSchema CountryCode

-- FUTUREWORK: push orphans upstream to saml2-web-sso, servant-multipart
-- FUTUREWORK: maybe avoid orphans altogether by defining schema instances manually

-- TODO: steal from https://github.com/haskell-servant/servant-swagger/blob/master/example/src/Todo.hs

-- | The options to use for schema generation. Must match the options used
-- for 'ToJSON' instances elsewhere.
--
-- FUTUREWORK: This should be removed once the saml2-web-sso types are updated to remove their prefixes.
-- FUTUREWORK: Ticket for these changes https://wearezeta.atlassian.net/browse/WPB-3972
-- Preserve the old prefix semantics for types that are coming from outside of this repo.
samlSchemaOptions :: SchemaOptions
samlSchemaOptions :: SchemaOptions
samlSchemaOptions =
  Options -> SchemaOptions
fromAesonOptions (Options -> SchemaOptions) -> Options -> SchemaOptions
forall a b. (a -> b) -> a -> b
$
    Options
deriveJSONOptions
      { A.fieldLabelModifier = fieldMod . dropPrefix
      }
  where
    fieldMod :: String -> String
fieldMod = Options -> String -> String
A.fieldLabelModifier Options
deriveJSONOptions
    dropPrefix :: String -> String
dropPrefix = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isUpper)

-- This type comes from a seperate repo, so we're keeping the prefix dropping
-- for the moment.
instance ToSchema SAML.XmlText where
  declareNamedSchema :: Proxy XmlText -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = SchemaOptions
-> Proxy XmlText -> Declare (Definitions Schema) NamedSchema
forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema SchemaOptions
samlSchemaOptions

instance ToParamSchema SAML.IdPId where
  toParamSchema :: Proxy IdPId -> Schema
toParamSchema Proxy IdPId
_ = Proxy UUID -> Schema
forall a. ToParamSchema a => Proxy a -> Schema
toParamSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @UUID)

instance ToSchema SAML.AuthnRequest where
  declareNamedSchema :: Proxy AuthnRequest -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = SchemaOptions
-> Proxy AuthnRequest -> Declare (Definitions Schema) NamedSchema
forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema SchemaOptions
samlSchemaOptions

instance ToSchema SAML.NameIdPolicy where
  declareNamedSchema :: Proxy NameIdPolicy -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = SchemaOptions
-> Proxy NameIdPolicy -> Declare (Definitions Schema) NamedSchema
forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema SchemaOptions
samlSchemaOptions

instance ToSchema SAML.NameIDFormat where
  declareNamedSchema :: Proxy NameIDFormat -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = SchemaOptions
-> Proxy NameIDFormat -> Declare (Definitions Schema) NamedSchema
forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema SchemaOptions
samlSchemaOptions

-- The generic schema breaks on this type, so we define it by hand.
--
-- The reason is that genericDeclareNamedSchema tries to define the schema for
-- this type as a heterogeneous array (i.e. tuple) with Swagger types String
-- and AuthnRequest. However, Swagger does not support heterogeneous arrays,
-- and this results in an array whose underlying type which is at the same time
-- marked as a string, and referring to the schema for AuthnRequest, which is of
-- course invalid.
instance ToSchema (SAML.FormRedirect SAML.AuthnRequest) where
  declareNamedSchema :: Proxy (FormRedirect AuthnRequest)
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (FormRedirect AuthnRequest)
_ = do
    Referenced Schema
authnReqSchema <- Proxy AuthnRequest
-> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @SAML.AuthnRequest)
    NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$
      Maybe ST -> Schema -> NamedSchema
NamedSchema (ST -> Maybe ST
forall a. a -> Maybe a
Just ST
"FormRedirect") (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$
        Schema
forall a. Monoid a => a
mempty
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiObject
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap ST (Referenced Schema)
 -> Identity (InsOrdHashMap ST (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap ST (Referenced Schema))
properties ((InsOrdHashMap ST (Referenced Schema)
  -> Identity (InsOrdHashMap ST (Referenced Schema)))
 -> Schema -> Identity Schema)
-> ((Maybe (IxValue (InsOrdHashMap ST (Referenced Schema)))
     -> Identity (Maybe (Referenced Schema)))
    -> InsOrdHashMap ST (Referenced Schema)
    -> Identity (InsOrdHashMap ST (Referenced Schema)))
-> (Maybe (IxValue (InsOrdHashMap ST (Referenced Schema)))
    -> Identity (Maybe (Referenced Schema)))
-> Schema
-> Identity Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashMap ST (Referenced Schema))
-> Lens'
     (InsOrdHashMap ST (Referenced Schema))
     (Maybe (IxValue (InsOrdHashMap ST (Referenced Schema))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (InsOrdHashMap ST (Referenced Schema))
"uri" ((Maybe (IxValue (InsOrdHashMap ST (Referenced Schema)))
  -> Identity (Maybe (Referenced Schema)))
 -> Schema -> Identity Schema)
-> Referenced Schema -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Proxy ST -> Schema
forall a. ToSchema a => Proxy a -> Schema
toSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Text))
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap ST (Referenced Schema)
 -> Identity (InsOrdHashMap ST (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap ST (Referenced Schema))
properties ((InsOrdHashMap ST (Referenced Schema)
  -> Identity (InsOrdHashMap ST (Referenced Schema)))
 -> Schema -> Identity Schema)
-> ((Maybe (IxValue (InsOrdHashMap ST (Referenced Schema)))
     -> Identity (Maybe (Referenced Schema)))
    -> InsOrdHashMap ST (Referenced Schema)
    -> Identity (InsOrdHashMap ST (Referenced Schema)))
-> (Maybe (IxValue (InsOrdHashMap ST (Referenced Schema)))
    -> Identity (Maybe (Referenced Schema)))
-> Schema
-> Identity Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashMap ST (Referenced Schema))
-> Lens'
     (InsOrdHashMap ST (Referenced Schema))
     (Maybe (IxValue (InsOrdHashMap ST (Referenced Schema))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (InsOrdHashMap ST (Referenced Schema))
"xml" ((Maybe (IxValue (InsOrdHashMap ST (Referenced Schema)))
  -> Identity (Maybe (Referenced Schema)))
 -> Schema -> Identity Schema)
-> Referenced Schema -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema
authnReqSchema

instance ToSchema (SAML.ID SAML.AuthnRequest) where
  declareNamedSchema :: Proxy (ID AuthnRequest) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = SchemaOptions
-> Proxy (ID AuthnRequest)
-> Declare (Definitions Schema) NamedSchema
forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema SchemaOptions
samlSchemaOptions

instance ToSchema SAML.Time where
  declareNamedSchema :: Proxy Time -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = SchemaOptions
-> Proxy Time -> Declare (Definitions Schema) NamedSchema
forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema SchemaOptions
samlSchemaOptions

instance ToSchema SAML.SPMetadata where
  declareNamedSchema :: Proxy SPMetadata -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy SPMetadata
_ = Proxy String -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @String)

instance ToSchema Void where
  declareNamedSchema :: Proxy Void -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy Void
_ = Proxy String -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @String)

instance (HasOpenApi route) => HasOpenApi (SM.MultipartForm SM.Mem resp :> route) where
  toOpenApi :: Proxy (MultipartForm Mem resp :> route) -> OpenApi
toOpenApi Proxy (MultipartForm Mem resp :> route)
_proxy = Proxy route -> OpenApi
forall {k} (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @route)

instance ToSchema SAML.IdPId where
  declareNamedSchema :: Proxy IdPId -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy IdPId
_ = Proxy UUID -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @UUID)

instance (ToSchema a) => ToSchema (SAML.IdPConfig a) where
  declareNamedSchema :: Proxy (IdPConfig a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = SchemaOptions
-> Proxy (IdPConfig a) -> Declare (Definitions Schema) NamedSchema
forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema SchemaOptions
samlSchemaOptions

instance ToSchema SAML.Issuer where
  declareNamedSchema :: Proxy Issuer -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy Issuer
_ = Proxy String -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @String)

instance ToSchema URI where
  declareNamedSchema :: Proxy URI -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy URI
_ = Proxy String -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @String)

instance ToParamSchema URI where
  toParamSchema :: Proxy URI -> Schema
toParamSchema Proxy URI
_ = Proxy String -> Schema
forall a. ToParamSchema a => Proxy a -> Schema
toParamSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @String)

instance ToSchema X509.SignedCertificate where
  declareNamedSchema :: Proxy SignedCertificate -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy SignedCertificate
_ = Proxy String -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @String)

instance ToSchema SAML.IdPMetadata where
  declareNamedSchema :: Proxy IdPMetadata -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = SchemaOptions
-> Proxy IdPMetadata -> Declare (Definitions Schema) NamedSchema
forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema SchemaOptions
samlSchemaOptions

instance ToSchema Currency.Alpha where
  declareNamedSchema :: Proxy Alpha -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = SchemaOptions
-> Proxy Alpha -> Declare (Definitions Schema) NamedSchema
forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema SchemaOptions
defaultSchemaOptions