{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Provides the generation functions for the supported security schemes
module OpenAPI.Generate.SecurityScheme
  ( defineSupportedSecuritySchemes,
  )
where

import qualified Data.Bifunctor as BF
import qualified Data.Maybe as Maybe
import Data.Text (Text, unpack)
import Language.Haskell.TH
import Language.Haskell.TH.PprLib hiding ((<>))
import qualified Network.HTTP.Client as HC
import qualified Network.HTTP.Simple as HS
import qualified OpenAPI.Common as OC
import qualified OpenAPI.Generate.Doc as Doc
import qualified OpenAPI.Generate.Monad as OAM
import qualified OpenAPI.Generate.Types as OAT

-- | Defines the security schemes which are configured in the OpenAPI specification
--
-- Generates warnings if unsupported schemes are defined in the specification
defineSupportedSecuritySchemes :: Text -> [(Text, OAT.SecuritySchemeObject)] -> OAM.Generator (Q Doc)
defineSupportedSecuritySchemes :: Text -> [(Text, SecuritySchemeObject)] -> Generator (Q Doc)
defineSupportedSecuritySchemes Text
moduleName [(Text, SecuritySchemeObject)]
securitySchemes = Text -> Generator (Q Doc) -> Generator (Q Doc)
forall a. Text -> Generator a -> Generator a
OAM.nested Text
"securitySchemes" (Generator (Q Doc) -> Generator (Q Doc))
-> Generator (Q Doc) -> Generator (Q Doc)
forall a b. (a -> b) -> a -> b
$ do
  let securitySchemeDefinitions :: [(Text, Maybe (Q Doc))]
securitySchemeDefinitions = ((Text, SecuritySchemeObject) -> (Text, Maybe (Q Doc)))
-> [(Text, SecuritySchemeObject)] -> [(Text, Maybe (Q Doc))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SecuritySchemeObject -> Maybe (Q Doc))
-> (Text, SecuritySchemeObject) -> (Text, Maybe (Q Doc))
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
BF.second ((SecuritySchemeObject -> Maybe (Q Doc))
 -> (Text, SecuritySchemeObject) -> (Text, Maybe (Q Doc)))
-> (SecuritySchemeObject -> Maybe (Q Doc))
-> (Text, SecuritySchemeObject)
-> (Text, Maybe (Q Doc))
forall a b. (a -> b) -> a -> b
$ Text -> SecuritySchemeObject -> Maybe (Q Doc)
defineSecurityScheme Text
moduleName) [(Text, SecuritySchemeObject)]
securitySchemes
  ((Text, Maybe (Q Doc)) -> Generator ())
-> [(Text, Maybe (Q Doc))] -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
    ( \(Text
name, Maybe (Q Doc)
_) ->
        Text -> Generator () -> Generator ()
forall a. Text -> Generator a -> Generator a
OAM.nested Text
name (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
          Text -> Generator ()
OAM.logWarning (Text -> Generator ()) -> Text -> Generator ()
forall a b. (a -> b) -> a -> b
$
            Text
"The security scheme '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' is not supported (currently only http-basic and http-bearer are supported)."
    )
    ([(Text, Maybe (Q Doc))] -> Generator ())
-> [(Text, Maybe (Q Doc))] -> Generator ()
forall a b. (a -> b) -> a -> b
$ ((Text, Maybe (Q Doc)) -> Bool)
-> [(Text, Maybe (Q Doc))] -> [(Text, Maybe (Q Doc))]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe (Q Doc) -> Bool
forall a. Maybe a -> Bool
Maybe.isNothing (Maybe (Q Doc) -> Bool)
-> ((Text, Maybe (Q Doc)) -> Maybe (Q Doc))
-> (Text, Maybe (Q Doc))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Maybe (Q Doc)) -> Maybe (Q Doc)
forall a b. (a, b) -> b
snd) [(Text, Maybe (Q Doc))]
securitySchemeDefinitions
  Q Doc -> Generator (Q Doc)
forall a. a -> Generator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Q Doc -> Generator (Q Doc)) -> Q Doc -> Generator (Q Doc)
forall a b. (a -> b) -> a -> b
$ ([Doc] -> Doc) -> Q [Doc] -> Q Doc
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Doc] -> Doc
vcat (Q [Doc] -> Q Doc) -> Q [Doc] -> Q Doc
forall a b. (a -> b) -> a -> b
$ ((Text, Q Doc) -> Q Doc) -> [(Text, Q Doc)] -> Q [Doc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Doc -> Doc) -> Q Doc -> Q Doc
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Doc -> Doc -> Doc
$$ String -> Doc
text String
"") (Q Doc -> Q Doc)
-> ((Text, Q Doc) -> Q Doc) -> (Text, Q Doc) -> Q Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Q Doc) -> Q Doc
forall a b. (a, b) -> b
snd) ([(Text, Q Doc)] -> Q [Doc]) -> [(Text, Q Doc)] -> Q [Doc]
forall a b. (a -> b) -> a -> b
$ ((Text, Maybe (Q Doc)) -> Maybe (Text, Q Doc))
-> [(Text, Maybe (Q Doc))] -> [(Text, Q Doc)]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe (Text, Maybe (Q Doc)) -> Maybe (Text, Q Doc)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => (Text, m a) -> m (Text, a)
sequence [(Text, Maybe (Q Doc))]
securitySchemeDefinitions

-- | Defines the security scheme for one 'OAT.SecuritySchemeObject'
defineSecurityScheme :: Text -> OAT.SecuritySchemeObject -> Maybe (Q Doc)
defineSecurityScheme :: Text -> SecuritySchemeObject -> Maybe (Q Doc)
defineSecurityScheme Text
moduleName (OAT.HttpSecuritySchemeObject HttpSecurityScheme
scheme) =
  let description :: Text
description = Text -> Text
Doc.escapeText (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
Maybe.fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ HttpSecurityScheme -> Maybe Text
OAT.httpSecuritySchemeDescription HttpSecurityScheme
scheme
   in case HttpSecurityScheme -> Text
OAT.httpSecuritySchemeScheme HttpSecurityScheme
scheme of
        Text
"basic" -> Q Doc -> Maybe (Q Doc)
forall a. a -> Maybe a
Just (Q Doc -> Maybe (Q Doc)) -> Q Doc -> Maybe (Q Doc)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Q Doc
basicAuthenticationScheme Text
moduleName Text
description
        Text
"bearer" -> Q Doc -> Maybe (Q Doc)
forall a. a -> Maybe a
Just (Q Doc -> Maybe (Q Doc)) -> Q Doc -> Maybe (Q Doc)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Q Doc
bearerAuthenticationScheme Text
moduleName Text
description
        Text
_ -> Maybe (Q Doc)
forall a. Maybe a
Nothing
defineSecurityScheme Text
moduleName (OAT.ApiKeySecuritySchemeObject ApiKeySecurityScheme
scheme) =
  let description :: Text
description = Text -> Text
Doc.escapeText (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
Maybe.fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ ApiKeySecurityScheme -> Maybe Text
OAT.apiKeySecuritySchemeDescription ApiKeySecurityScheme
scheme
      name :: Text
name = ApiKeySecurityScheme -> Text
OAT.apiKeySecuritySchemeName ApiKeySecurityScheme
scheme
   in case ApiKeySecurityScheme -> ApiKeySecuritySchemeLocation
OAT.apiKeySecuritySchemeIn ApiKeySecurityScheme
scheme of
        ApiKeySecuritySchemeLocation
OAT.HeaderApiKeySecuritySchemeLocation -> Q Doc -> Maybe (Q Doc)
forall a. a -> Maybe a
Just (Q Doc -> Maybe (Q Doc)) -> Q Doc -> Maybe (Q Doc)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Q Doc
apiKeyInHeaderAuthenticationScheme Text
name Text
moduleName Text
description
        ApiKeySecuritySchemeLocation
_ -> Maybe (Q Doc)
forall a. Maybe a
Nothing
defineSecurityScheme Text
_ SecuritySchemeObject
_ = Maybe (Q Doc)
forall a. Maybe a
Nothing

-- | BasicAuthentication scheme with simple username and password
basicAuthenticationScheme :: Text -> Text -> Q Doc
basicAuthenticationScheme :: Text -> Text -> Q Doc
basicAuthenticationScheme Text
moduleName Text
description =
  let dataName :: Name
dataName = String -> Name
mkName String
"BasicAuthenticationData"
      usernameName :: Name
usernameName = String -> Name
mkName String
"basicAuthenticationDataUsername"
      passwordName :: Name
passwordName = String -> Name
mkName String
"basicAuthenticationDataPassword"
      dataDefinition :: Q Dec
dataDefinition =
        Q Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Kind
-> [Q Con]
-> [Q DerivClause]
-> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Kind
-> [m Con]
-> [m DerivClause]
-> m Dec
dataD
          ([Q Kind] -> Q Cxt
forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt [])
          Name
dataName
          []
          Maybe Kind
forall a. Maybe a
Nothing
          [ Name -> [Q VarBangType] -> Q Con
forall (m :: * -> *). Quote m => Name -> [m VarBangType] -> m Con
recC
              Name
dataName
              [ Name -> Q BangType -> Q VarBangType
forall (m :: * -> *).
Quote m =>
Name -> m BangType -> m VarBangType
varBangType Name
usernameName (Q BangType -> Q VarBangType) -> Q BangType -> Q VarBangType
forall a b. (a -> b) -> a -> b
$ Q Bang -> Q Kind -> Q BangType
forall (m :: * -> *). Quote m => m Bang -> m Kind -> m BangType
bangType (Q SourceUnpackedness -> Q SourceStrictness -> Q Bang
forall (m :: * -> *).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Bang
bang Q SourceUnpackedness
forall (m :: * -> *). Quote m => m SourceUnpackedness
noSourceUnpackedness Q SourceStrictness
forall (m :: * -> *). Quote m => m SourceStrictness
noSourceStrictness) (Q Kind -> Q BangType) -> Q Kind -> Q BangType
forall a b. (a -> b) -> a -> b
$ Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''Text,
                Name -> Q BangType -> Q VarBangType
forall (m :: * -> *).
Quote m =>
Name -> m BangType -> m VarBangType
varBangType Name
passwordName (Q BangType -> Q VarBangType) -> Q BangType -> Q VarBangType
forall a b. (a -> b) -> a -> b
$ Q Bang -> Q Kind -> Q BangType
forall (m :: * -> *). Quote m => m Bang -> m Kind -> m BangType
bangType (Q SourceUnpackedness -> Q SourceStrictness -> Q Bang
forall (m :: * -> *).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Bang
bang Q SourceUnpackedness
forall (m :: * -> *). Quote m => m SourceUnpackedness
noSourceUnpackedness Q SourceStrictness
forall (m :: * -> *). Quote m => m SourceStrictness
noSourceStrictness) (Q Kind -> Q BangType) -> Q Kind -> Q BangType
forall a b. (a -> b) -> a -> b
$ Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''Text
              ]
          ]
          [Maybe DerivStrategy -> [Q Kind] -> Q DerivClause
forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> [m Kind] -> m DerivClause
derivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''Show, Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''Ord, Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''Eq]]
      fnName :: Name
fnName = String -> Name
mkName String
"basicAuthenticationSecurityScheme"
      functionType :: Q Dec
functionType = Name -> Q Kind -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
sigD Name
fnName [t|$(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT Name
dataName) -> OC.SecurityScheme|]
      functionBody :: Q Decs
functionBody =
        [d|
          $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
fnName) = \basicAuth ->
            HC.applyBasicAuth
              (OC.textToByte $ $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
usernameName) basicAuth)
              (OC.textToByte $ $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
passwordName) basicAuth)
          |]
   in [Doc] -> Doc
vcat
        ([Doc] -> Doc) -> Q [Doc] -> Q Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Doc] -> Q [Doc]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
          [ (Doc -> Doc -> Doc
$$ String -> Doc
text String
"")
              (Doc -> Doc) -> (Dec -> Doc) -> Dec -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( [Text] -> Doc
Doc.generateHaddockComment
                    [ Text
"Used to pass the authentication information for BasicAuthentication to 'basicAuthenticationSecurityScheme'."
                    ]
                    Doc -> Doc -> Doc
$$
                )
              (Doc -> Doc) -> (Dec -> Doc) -> Dec -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dec -> Doc
forall a. Ppr a => a -> Doc
ppr
              (Dec -> Doc) -> Q Dec -> Q Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Dec
dataDefinition,
            ( [Text] -> Doc
Doc.generateHaddockComment
                [ Text
"Use this security scheme to use basic authentication for a request. Should be used in a 'OpenAPI.Common.Configuration'.",
                  Text
"",
                  Text
description,
                  Text
"",
                  Text
"@",
                  Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
moduleName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".Configuration.defaultConfiguration'",
                  Text
"  { configSecurityScheme =",
                  Text
"      'basicAuthenticationSecurityScheme' 'BasicAuthenticationData'",
                  Text
"        { 'basicAuthenticationDataUsername' = \"user\",",
                  Text
"          'basicAuthenticationDataPassword' = \"pw\"",
                  Text
"        }",
                  Text
"  }",
                  Text
"@"
                ]
                Doc -> Doc -> Doc
$$
            )
              (Doc -> Doc) -> (Dec -> Doc) -> Dec -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dec -> Doc
forall a. Ppr a => a -> Doc
ppr
              (Dec -> Doc) -> Q Dec -> Q Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Dec
functionType,
            Decs -> Doc
forall a. Ppr a => a -> Doc
ppr (Decs -> Doc) -> Q Decs -> Q Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Decs
functionBody
          ]

-- | BearerAuthentication scheme with a bearer token
bearerAuthenticationScheme :: Text -> Text -> Q Doc
bearerAuthenticationScheme :: Text -> Text -> Q Doc
bearerAuthenticationScheme Text
moduleName Text
description =
  let fnName :: Name
fnName = String -> Name
mkName String
"bearerAuthenticationSecurityScheme"
      functionType :: Q Dec
functionType = Name -> Q Kind -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
sigD Name
fnName [t|Text -> OC.SecurityScheme|]
      functionBody :: Q Decs
functionBody = [d|$(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
fnName) = \token -> HS.addRequestHeader "Authorization" $ OC.textToByte $ "Bearer " <> token|]
   in [Doc] -> Doc
vcat
        ([Doc] -> Doc) -> Q [Doc] -> Q Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Doc] -> Q [Doc]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
          [ ( [Text] -> Doc
Doc.generateHaddockComment
                [ Text
"Use this security scheme to use bearer authentication for a request. Should be used in a 'OpenAPI.Common.Configuration'.",
                  Text
"",
                  Text
description,
                  Text
"",
                  Text
"@",
                  Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
moduleName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".Configuration.defaultConfiguration'",
                  Text
"  { configSecurityScheme = 'bearerAuthenticationSecurityScheme' \"token\"",
                  Text
"  }",
                  Text
"@"
                ]
                Doc -> Doc -> Doc
$$
            )
              (Doc -> Doc) -> (Dec -> Doc) -> Dec -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dec -> Doc
forall a. Ppr a => a -> Doc
ppr
              (Dec -> Doc) -> Q Dec -> Q Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Dec
functionType,
            Decs -> Doc
forall a. Ppr a => a -> Doc
ppr (Decs -> Doc) -> Q Decs -> Q Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Decs
functionBody
          ]

-- | ApiKeyAuthentication scheme with a bearer token
apiKeyInHeaderAuthenticationScheme :: Text -> Text -> Text -> Q Doc
apiKeyInHeaderAuthenticationScheme :: Text -> Text -> Text -> Q Doc
apiKeyInHeaderAuthenticationScheme Text
headerName Text
moduleName Text
description =
  let fnName :: Name
fnName = String -> Name
mkName String
"apiKeyInHeaderAuthenticationSecurityScheme"
      functionType :: Q Dec
functionType = Name -> Q Kind -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
sigD Name
fnName [t|Text -> OC.SecurityScheme|]
      headerName' :: Q Exp
headerName' = String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Text -> String
Data.Text.unpack Text
headerName
      functionBody :: Q Decs
functionBody = [d|$(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
fnName) = HS.addRequestHeader $(Q Exp
headerName') . OC.textToByte|]
   in [Doc] -> Doc
vcat
        ([Doc] -> Doc) -> Q [Doc] -> Q Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Doc] -> Q [Doc]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
          [ ( [Text] -> Doc
Doc.generateHaddockComment
                [ Text
"Use this security scheme to use token in HTTP header for authentication. Should be used in a 'OpenAPI.Common.Configuration'.",
                  Text
"",
                  Text
description,
                  Text
"",
                  Text
"@",
                  Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
moduleName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".Configuration.defaultConfiguration'",
                  Text
"  { configSecurityScheme = 'apiKeyInHeaderAuthenticationSecurityScheme' \"token\"",
                  Text
"  }",
                  Text
"@"
                ]
                Doc -> Doc -> Doc
$$
            )
              (Doc -> Doc) -> (Dec -> Doc) -> Dec -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dec -> Doc
forall a. Ppr a => a -> Doc
ppr
              (Dec -> Doc) -> Q Dec -> Q Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Dec
functionType,
            Decs -> Doc
forall a. Ppr a => a -> Doc
ppr (Decs -> Doc) -> Q Decs -> Q Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Decs
functionBody
          ]