{-# LANGUAGE DerivingVia #-}
{-# 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.Routes.Public
  ( -- * nginz combinators
    ZUser,
    ZClient,
    ZLocalUser,
    ZConn,
    ZOptUser,
    ZOptClient,
    ZOptConn,
    ZBot,
    ZConversation,
    ZProvider,
    ZAccess,
    DescriptionOAuthScope,
    ZHostOpt,
    ZHostValue,
    ZAuthServant,
  )
where

import Control.Lens ((%~), (<>~))
import Data.ByteString (toStrict)
import Data.ByteString.Conversion (toByteString)
import Data.Domain
import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
import Data.Id as Id
import Data.Kind
import Data.Metrics.Servant
import Data.OpenApi hiding (HasServer, Header, Server)
import Data.OpenApi qualified as S
import Data.Qualified
import Data.Text.Encoding
import Data.Text.Encoding.Error
import GHC.Base (Symbol)
import GHC.TypeLits (KnownSymbol)
import Imports hiding (All, head)
import Network.Wai qualified as Wai
import Servant hiding (Handler, JSON, addHeader, respond)
import Servant.API.Modifiers
import Servant.OpenApi (HasOpenApi (toOpenApi))
import Servant.Server.Internal.Delayed
import Servant.Server.Internal.DelayedIO
import Servant.Server.Internal.Router (Router)
import Wire.API.OAuth qualified as OAuth
import Wire.API.Routes.Version

mapRequestArgument ::
  forall mods a b.
  (SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)) =>
  (a -> b) ->
  RequestArgument mods a ->
  RequestArgument mods b
mapRequestArgument :: forall (mods :: [*]) a b.
(SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)) =>
(a -> b) -> RequestArgument mods a -> RequestArgument mods b
mapRequestArgument a -> b
f RequestArgument mods a
x =
  case (SBool (FoldRequired mods)
forall (b :: Bool). SBoolI b => SBool b
sbool :: SBool (FoldRequired mods), SBool (FoldLenient mods)
forall (b :: Bool). SBoolI b => SBool b
sbool :: SBool (FoldLenient mods)) of
    (SBool (FoldRequired mods)
STrue, SBool (FoldLenient mods)
STrue) -> (a -> b) -> Either Text a -> Either Text b
forall a b. (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Either Text a
RequestArgument mods a
x
    (SBool (FoldRequired mods)
STrue, SBool (FoldLenient mods)
SFalse) -> a -> b
f a
RequestArgument mods a
x
    (SBool (FoldRequired mods)
SFalse, SBool (FoldLenient mods)
STrue) -> ((Either Text a -> Either Text b)
-> Maybe (Either Text a) -> Maybe (Either Text b)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Either Text a -> Either Text b)
 -> Maybe (Either Text a) -> Maybe (Either Text b))
-> ((a -> b) -> Either Text a -> Either Text b)
-> (a -> b)
-> Maybe (Either Text a)
-> Maybe (Either Text b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> Either Text a -> Either Text b
forall a b. (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) a -> b
f Maybe (Either Text a)
RequestArgument mods a
x
    (SBool (FoldRequired mods)
SFalse, SBool (FoldLenient mods)
SFalse) -> (a -> b) -> Maybe a -> Maybe b
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Maybe a
RequestArgument mods a
x

-- This type exists for the special 'HasSwagger' and 'HasServer' instances. It
-- shows the "Authorization" header in the swagger docs, but expects the
-- "Z-Auth" header in the server. This helps keep the swagger docs usable
-- through nginz.
data ZType
  = -- | Get a 'UserID' from the Z-Auth header
    ZAuthUser
  | -- | Same as 'ZAuthUser', but return a 'Local UserId' using the domain in the context
    ZLocalAuthUser
  | ZAuthClient
  | -- | Get a 'ConnId' from the Z-Conn header
    ZAuthConn
  | ZAuthBot
  | ZAuthConv
  | ZAuthProvider
  | -- | (Typically short-lived) access token.
    ZAuthAccess

class HasTokenType (ztype :: ZType) where
  -- | The expected value of the "Z-Type" header.
  tokenType :: Maybe ByteString
  tokenType = Maybe ByteString
forall a. Maybe a
Nothing

class
  ( KnownSymbol (ZHeader ztype),
    FromHttpApiData (ZParam ztype),
    HasTokenType ztype
  ) =>
  IsZType (ztype :: ZType) ctx
  where
  type ZHeader ztype :: Symbol
  type ZParam ztype :: Type
  type ZQualifiedParam ztype :: Type

  qualifyZParam :: Context ctx -> ZParam ztype -> ZQualifiedParam ztype

instance HasTokenType 'ZLocalAuthUser

instance (HasContextEntry ctx Domain) => IsZType 'ZLocalAuthUser ctx where
  type ZHeader 'ZLocalAuthUser = "Z-User"
  type ZParam 'ZLocalAuthUser = UserId
  type ZQualifiedParam 'ZLocalAuthUser = Local UserId

  qualifyZParam :: Context ctx
-> ZParam 'ZLocalAuthUser -> ZQualifiedParam 'ZLocalAuthUser
qualifyZParam Context ctx
ctx = Domain -> UserId -> Local UserId
forall a. Domain -> a -> Local a
toLocalUnsafe (Context ctx -> Domain
forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry Context ctx
ctx)

instance HasTokenType 'ZAuthUser

instance IsZType 'ZAuthUser ctx where
  type ZHeader 'ZAuthUser = "Z-User"
  type ZParam 'ZAuthUser = UserId
  type ZQualifiedParam 'ZAuthUser = UserId

  qualifyZParam :: Context ctx -> ZParam 'ZAuthUser -> ZQualifiedParam 'ZAuthUser
qualifyZParam Context ctx
_ = UserId -> UserId
ZParam 'ZAuthUser -> ZQualifiedParam 'ZAuthUser
forall a. a -> a
id

instance HasTokenType 'ZAuthClient

instance IsZType 'ZAuthClient ctx where
  type ZHeader 'ZAuthClient = "Z-Client"
  type ZParam 'ZAuthClient = ClientId
  type ZQualifiedParam 'ZAuthClient = ClientId

  qualifyZParam :: Context ctx -> ZParam 'ZAuthClient -> ZQualifiedParam 'ZAuthClient
qualifyZParam Context ctx
_ = ClientId -> ClientId
ZParam 'ZAuthClient -> ZQualifiedParam 'ZAuthClient
forall a. a -> a
id

instance HasTokenType 'ZAuthConn

instance IsZType 'ZAuthConn ctx where
  type ZHeader 'ZAuthConn = "Z-Connection"
  type ZParam 'ZAuthConn = ConnId
  type ZQualifiedParam 'ZAuthConn = ConnId

  qualifyZParam :: Context ctx -> ZParam 'ZAuthConn -> ZQualifiedParam 'ZAuthConn
qualifyZParam Context ctx
_ = ConnId -> ConnId
ZParam 'ZAuthConn -> ZQualifiedParam 'ZAuthConn
forall a. a -> a
id

instance HasTokenType 'ZAuthBot where
  tokenType :: Maybe ByteString
tokenType = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"bot"

instance IsZType 'ZAuthBot ctx where
  type ZHeader 'ZAuthBot = "Z-Bot"
  type ZParam 'ZAuthBot = BotId
  type ZQualifiedParam 'ZAuthBot = BotId

  qualifyZParam :: Context ctx -> ZParam 'ZAuthBot -> ZQualifiedParam 'ZAuthBot
qualifyZParam Context ctx
_ = BotId -> BotId
ZParam 'ZAuthBot -> ZQualifiedParam 'ZAuthBot
forall a. a -> a
id

instance HasTokenType 'ZAuthConv

instance IsZType 'ZAuthConv ctx where
  type ZHeader 'ZAuthConv = "Z-Conversation"
  type ZParam 'ZAuthConv = ConvId
  type ZQualifiedParam 'ZAuthConv = ConvId

  qualifyZParam :: Context ctx -> ZParam 'ZAuthConv -> ZQualifiedParam 'ZAuthConv
qualifyZParam Context ctx
_ = ConvId -> ConvId
ZParam 'ZAuthConv -> ZQualifiedParam 'ZAuthConv
forall a. a -> a
id

instance HasTokenType 'ZAuthProvider where
  tokenType :: Maybe ByteString
tokenType = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"provider"

instance IsZType 'ZAuthProvider ctx where
  type ZHeader 'ZAuthProvider = "Z-Provider"
  type ZParam 'ZAuthProvider = ProviderId
  type ZQualifiedParam 'ZAuthProvider = ProviderId

  qualifyZParam :: Context ctx
-> ZParam 'ZAuthProvider -> ZQualifiedParam 'ZAuthProvider
qualifyZParam Context ctx
_ = ProviderId -> ProviderId
ZParam 'ZAuthProvider -> ZQualifiedParam 'ZAuthProvider
forall a. a -> a
id

instance HasTokenType 'ZAuthAccess where
  tokenType :: Maybe ByteString
tokenType = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"access"

instance IsZType 'ZAuthAccess ctx where
  type ZHeader 'ZAuthAccess = "Z-User"
  type ZParam 'ZAuthAccess = UserId
  type ZQualifiedParam 'ZAuthAccess = UserId

  qualifyZParam :: Context ctx -> ZParam 'ZAuthAccess -> ZQualifiedParam 'ZAuthAccess
qualifyZParam Context ctx
_ = UserId -> UserId
ZParam 'ZAuthAccess -> ZQualifiedParam 'ZAuthAccess
forall a. a -> a
id

data ZAuthServant (ztype :: ZType) (opts :: [Type])

type InternalAuthDefOpts = '[Servant.Required, Servant.Strict]

type InternalAuth ztype opts =
  Header'
    opts
    (ZHeader ztype)
    (ZParam ztype)

type ZLocalUser = ZAuthServant 'ZLocalAuthUser InternalAuthDefOpts

type ZUser = ZAuthServant 'ZAuthUser InternalAuthDefOpts

type ZClient = ZAuthServant 'ZAuthClient InternalAuthDefOpts

type ZConn = ZAuthServant 'ZAuthConn InternalAuthDefOpts

type ZBot = ZAuthServant 'ZAuthBot InternalAuthDefOpts

type ZConversation = ZAuthServant 'ZAuthConv InternalAuthDefOpts

type ZProvider = ZAuthServant 'ZAuthProvider InternalAuthDefOpts

type ZAccess = ZAuthServant 'ZAuthAccess InternalAuthDefOpts

type ZOptUser = ZAuthServant 'ZAuthUser '[Servant.Optional, Servant.Strict]

type ZOptClient = ZAuthServant 'ZAuthClient '[Servant.Optional, Servant.Strict]

type ZOptConn = ZAuthServant 'ZAuthConn '[Servant.Optional, Servant.Strict]

-- | Optional @Z-Host@ header (added by @nginz@)
data ZHostOpt

type ZHostValue = Text

type ZOptHostHeader =
  Header' '[Servant.Optional, Strict] "Z-Host" ZHostValue

instance (HasOpenApi api) => HasOpenApi (ZHostOpt :> api) where
  toOpenApi :: Proxy (ZHostOpt :> api) -> OpenApi
toOpenApi Proxy (ZHostOpt :> api)
_ = Proxy api -> OpenApi
forall {k} (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api)

type instance SpecialiseToVersion v (ZHostOpt :> api) = ZHostOpt :> SpecialiseToVersion v api

addZAuthSwagger :: OpenApi -> OpenApi
addZAuthSwagger :: OpenApi -> OpenApi
addZAuthSwagger OpenApi
s =
  OpenApi
s
    OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& (Components -> Identity Components) -> OpenApi -> Identity OpenApi
forall s a. HasComponents s a => Lens' s a
Lens' OpenApi Components
S.components ((Components -> Identity Components)
 -> OpenApi -> Identity OpenApi)
-> ((SecurityDefinitions -> Identity SecurityDefinitions)
    -> Components -> Identity Components)
-> (SecurityDefinitions -> Identity SecurityDefinitions)
-> OpenApi
-> Identity OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SecurityDefinitions -> Identity SecurityDefinitions)
-> Components -> Identity Components
forall s a. HasSecuritySchemes s a => Lens' s a
Lens' Components SecurityDefinitions
S.securitySchemes ((SecurityDefinitions -> Identity SecurityDefinitions)
 -> OpenApi -> Identity OpenApi)
-> SecurityDefinitions -> OpenApi -> OpenApi
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ Definitions SecurityScheme -> SecurityDefinitions
SecurityDefinitions (Text -> SecurityScheme -> Definitions SecurityScheme
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
InsOrdHashMap.singleton Text
"ZAuth" SecurityScheme
secScheme)
    OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& ([SecurityRequirement] -> Identity [SecurityRequirement])
-> OpenApi -> Identity OpenApi
forall s a. HasSecurity s a => Lens' s a
Lens' OpenApi [SecurityRequirement]
security (([SecurityRequirement] -> Identity [SecurityRequirement])
 -> OpenApi -> Identity OpenApi)
-> [SecurityRequirement] -> OpenApi -> OpenApi
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ [InsOrdHashMap Text [Text] -> SecurityRequirement
SecurityRequirement (InsOrdHashMap Text [Text] -> SecurityRequirement)
-> InsOrdHashMap Text [Text] -> SecurityRequirement
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> InsOrdHashMap Text [Text]
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
InsOrdHashMap.singleton Text
"ZAuth" []]
  where
    secScheme :: SecurityScheme
secScheme =
      SecurityScheme
        { _securitySchemeType :: SecuritySchemeType
_securitySchemeType = ApiKeyParams -> SecuritySchemeType
SecuritySchemeApiKey (Text -> ApiKeyLocation -> ApiKeyParams
ApiKeyParams Text
"Authorization" ApiKeyLocation
ApiKeyHeader),
          _securitySchemeDescription :: Maybe Text
_securitySchemeDescription = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Must be a token retrieved by calling 'POST /login' or 'POST /access'. It must be presented in this format: 'Bearer \\<token\\>'."
        }

type instance
  SpecialiseToVersion v (ZAuthServant t opts :> api) =
    ZAuthServant t opts :> SpecialiseToVersion v api

instance (HasOpenApi api) => HasOpenApi (ZAuthServant 'ZAuthUser _opts :> api) where
  toOpenApi :: Proxy (ZAuthServant 'ZAuthUser _opts :> api) -> OpenApi
toOpenApi Proxy (ZAuthServant 'ZAuthUser _opts :> api)
_ = OpenApi -> OpenApi
addZAuthSwagger (Proxy api -> OpenApi
forall {k} (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api))

instance (HasOpenApi api) => HasOpenApi (ZAuthServant 'ZLocalAuthUser opts :> api) where
  toOpenApi :: Proxy (ZAuthServant 'ZLocalAuthUser opts :> api) -> OpenApi
toOpenApi Proxy (ZAuthServant 'ZLocalAuthUser opts :> api)
_ = OpenApi -> OpenApi
addZAuthSwagger (Proxy api -> OpenApi
forall {k} (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api))

instance (HasLink endpoint) => HasLink (ZAuthServant usr opts :> endpoint) where
  type MkLink (ZAuthServant _ _ :> endpoint) a = MkLink endpoint a
  toLink :: forall a.
(Link -> a)
-> Proxy (ZAuthServant usr opts :> endpoint)
-> Link
-> MkLink (ZAuthServant usr opts :> endpoint) a
toLink Link -> a
toA Proxy (ZAuthServant usr opts :> endpoint)
_ = (Link -> a) -> Proxy endpoint -> Link -> MkLink endpoint a
forall a.
(Link -> a) -> Proxy endpoint -> Link -> MkLink endpoint a
forall {k} (endpoint :: k) a.
HasLink endpoint =>
(Link -> a) -> Proxy endpoint -> Link -> MkLink endpoint a
toLink Link -> a
toA (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @endpoint)

instance
  {-# OVERLAPPABLE #-}
  (HasOpenApi api) =>
  HasOpenApi (ZAuthServant ztype _opts :> api)
  where
  toOpenApi :: Proxy (ZAuthServant ztype _opts :> api) -> OpenApi
toOpenApi Proxy (ZAuthServant ztype _opts :> api)
_ = Proxy api -> OpenApi
forall {k} (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api)

instance
  ( HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters,
    HasServer api ctx
  ) =>
  HasServer (ZHostOpt :> api) ctx
  where
  type ServerT (ZHostOpt :> api) m = Maybe Text -> ServerT api m
  route ::
    Proxy (ZHostOpt :> api) ->
    Context ctx ->
    Delayed env (Server (ZHostOpt :> api)) ->
    Router env
  route :: forall env.
Proxy (ZHostOpt :> api)
-> Context ctx
-> Delayed env (Server (ZHostOpt :> api))
-> Router env
route Proxy (ZHostOpt :> api)
_ = Proxy (ZOptHostHeader :> api)
-> Context ctx
-> Delayed env (Server (ZOptHostHeader :> api))
-> Router' env RoutingApplication
forall env.
Proxy (ZOptHostHeader :> api)
-> Context ctx
-> Delayed env (Server (ZOptHostHeader :> api))
-> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ZOptHostHeader :> api))
  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (ZHostOpt :> api)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (ZHostOpt :> api) m
-> ServerT (ZHostOpt :> api) n
hoistServerWithContext Proxy (ZHostOpt :> api)
_ Proxy ctx
pc forall x. m x -> n x
nt ServerT (ZHostOpt :> api) m
s = Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: * -> *) (n :: * -> *).
Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy ctx
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (Maybe Text -> ServerT api m) -> Maybe Text -> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (ZHostOpt :> api) m
Maybe Text -> ServerT api m
s

instance
  ( IsZType ztype ctx,
    HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters,
    SBoolI (FoldLenient opts),
    SBoolI (FoldRequired opts),
    HasServer api ctx
  ) =>
  HasServer (ZAuthServant ztype opts :> api) ctx
  where
  type
    ServerT (ZAuthServant ztype opts :> api) m =
      RequestArgument opts (ZQualifiedParam ztype) -> ServerT api m

  route :: forall env.
Proxy (ZAuthServant ztype opts :> api)
-> Context ctx
-> Delayed env (Server (ZAuthServant ztype opts :> api))
-> Router env
route Proxy (ZAuthServant ztype opts :> api)
_ Context ctx
ctx Delayed env (Server (ZAuthServant ztype opts :> api))
subserver = do
    Proxy (Header' opts (ZHeader ztype) (ZParam ztype) :> api)
-> Context ctx
-> Delayed
     env (Server (Header' opts (ZHeader ztype) (ZParam ztype) :> api))
-> Router env
forall env.
Proxy (Header' opts (ZHeader ztype) (ZParam ztype) :> api)
-> Context ctx
-> Delayed
     env (Server (Header' opts (ZHeader ztype) (ZParam ztype) :> api))
-> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
Servant.route
      (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(InternalAuth ztype opts :> api))
      Context ctx
ctx
      ( ((If
    (FoldRequired opts)
    (If
       (FoldLenient opts)
       (Either Text (ZQualifiedParam ztype))
       (ZQualifiedParam ztype))
    (Maybe
       (If
          (FoldLenient opts)
          (Either Text (ZQualifiedParam ztype))
          (ZQualifiedParam ztype)))
  -> ServerT api Handler)
 -> If
      (FoldRequired opts)
      (If (FoldLenient opts) (Either Text (ZParam ztype)) (ZParam ztype))
      (Maybe
         (If
            (FoldLenient opts) (Either Text (ZParam ztype)) (ZParam ztype)))
 -> ServerT api Handler)
-> Delayed
     env
     (If
        (FoldRequired opts)
        (If
           (FoldLenient opts)
           (Either Text (ZQualifiedParam ztype))
           (ZQualifiedParam ztype))
        (Maybe
           (If
              (FoldLenient opts)
              (Either Text (ZQualifiedParam ztype))
              (ZQualifiedParam ztype)))
      -> ServerT api Handler)
-> Delayed
     env
     (If
        (FoldRequired opts)
        (If (FoldLenient opts) (Either Text (ZParam ztype)) (ZParam ztype))
        (Maybe
           (If
              (FoldLenient opts) (Either Text (ZParam ztype)) (ZParam ztype)))
      -> ServerT api Handler)
forall a b. (a -> b) -> Delayed env a -> Delayed env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
          ((If
   (FoldRequired opts)
   (If
      (FoldLenient opts)
      (Either Text (ZQualifiedParam ztype))
      (ZQualifiedParam ztype))
   (Maybe
      (If
         (FoldLenient opts)
         (Either Text (ZQualifiedParam ztype))
         (ZQualifiedParam ztype)))
 -> ServerT api Handler)
-> (If
      (FoldRequired opts)
      (If (FoldLenient opts) (Either Text (ZParam ztype)) (ZParam ztype))
      (Maybe
         (If
            (FoldLenient opts) (Either Text (ZParam ztype)) (ZParam ztype)))
    -> If
         (FoldRequired opts)
         (If
            (FoldLenient opts)
            (Either Text (ZQualifiedParam ztype))
            (ZQualifiedParam ztype))
         (Maybe
            (If
               (FoldLenient opts)
               (Either Text (ZQualifiedParam ztype))
               (ZQualifiedParam ztype))))
-> If
     (FoldRequired opts)
     (If (FoldLenient opts) (Either Text (ZParam ztype)) (ZParam ztype))
     (Maybe
        (If
           (FoldLenient opts) (Either Text (ZParam ztype)) (ZParam ztype)))
-> ServerT api Handler
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (mods :: [*]) a b.
(SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)) =>
(a -> b) -> RequestArgument mods a -> RequestArgument mods b
mapRequestArgument @opts (forall (ztype :: ZType) (ctx :: [*]).
IsZType ztype ctx =>
Context ctx -> ZParam ztype -> ZQualifiedParam ztype
qualifyZParam @ztype Context ctx
ctx))
          (Delayed
  env
  (If
     (FoldRequired opts)
     (If
        (FoldLenient opts)
        (Either Text (ZQualifiedParam ztype))
        (ZQualifiedParam ztype))
     (Maybe
        (If
           (FoldLenient opts)
           (Either Text (ZQualifiedParam ztype))
           (ZQualifiedParam ztype)))
   -> ServerT api Handler)
-> DelayedIO ()
-> Delayed
     env
     (If
        (FoldRequired opts)
        (If
           (FoldLenient opts)
           (Either Text (ZQualifiedParam ztype))
           (ZQualifiedParam ztype))
        (Maybe
           (If
              (FoldLenient opts)
              (Either Text (ZQualifiedParam ztype))
              (ZQualifiedParam ztype)))
      -> ServerT api Handler)
forall env a. Delayed env a -> DelayedIO () -> Delayed env a
addAcceptCheck Delayed env (Server (ZAuthServant ztype opts :> api))
Delayed
  env
  (If
     (FoldRequired opts)
     (If
        (FoldLenient opts)
        (Either Text (ZQualifiedParam ztype))
        (ZQualifiedParam ztype))
     (Maybe
        (If
           (FoldLenient opts)
           (Either Text (ZQualifiedParam ztype))
           (ZQualifiedParam ztype)))
   -> ServerT api Handler)
subserver ((Request -> DelayedIO ()) -> DelayedIO ()
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest (Maybe ByteString -> Request -> DelayedIO ()
checkType (forall (ztype :: ZType). HasTokenType ztype => Maybe ByteString
tokenType @ztype))))
      )
    where
      checkType :: Maybe ByteString -> Wai.Request -> DelayedIO ()
      checkType :: Maybe ByteString -> Request -> DelayedIO ()
checkType Maybe ByteString
token Request
req =
        case (Maybe ByteString
token, HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Z-Type" (Request -> [(HeaderName, ByteString)]
Wai.requestHeaders Request
req)) of
          (Just ByteString
t, Maybe ByteString
v)
            | Maybe ByteString
v Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
t ->
                ServerError -> DelayedIO ()
forall a. ServerError -> DelayedIO a
delayedFail
                  ServerError
                    { errHTTPCode :: Int
errHTTPCode = Int
403,
                      errReasonPhrase :: String
errReasonPhrase = String
"Access denied",
                      errBody :: ByteString
errBody = ByteString
"",
                      errHeaders :: [(HeaderName, ByteString)]
errHeaders = []
                    }
          (Maybe ByteString, Maybe ByteString)
_ -> () -> DelayedIO ()
forall a. a -> DelayedIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (ZAuthServant ztype opts :> api)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (ZAuthServant ztype opts :> api) m
-> ServerT (ZAuthServant ztype opts :> api) n
hoistServerWithContext Proxy (ZAuthServant ztype opts :> api)
_ Proxy ctx
pc forall x. m x -> n x
nt ServerT (ZAuthServant ztype opts :> api) m
s = Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: * -> *) (n :: * -> *).
Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy ctx
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (If
      (FoldRequired opts)
      (If
         (FoldLenient opts)
         (Either Text (ZQualifiedParam ztype))
         (ZQualifiedParam ztype))
      (Maybe
         (If
            (FoldLenient opts)
            (Either Text (ZQualifiedParam ztype))
            (ZQualifiedParam ztype)))
    -> ServerT api m)
-> If
     (FoldRequired opts)
     (If
        (FoldLenient opts)
        (Either Text (ZQualifiedParam ztype))
        (ZQualifiedParam ztype))
     (Maybe
        (If
           (FoldLenient opts)
           (Either Text (ZQualifiedParam ztype))
           (ZQualifiedParam ztype)))
-> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (ZAuthServant ztype opts :> api) m
If
  (FoldRequired opts)
  (If
     (FoldLenient opts)
     (Either Text (ZQualifiedParam ztype))
     (ZQualifiedParam ztype))
  (Maybe
     (If
        (FoldLenient opts)
        (Either Text (ZQualifiedParam ztype))
        (ZQualifiedParam ztype)))
-> ServerT api m
s

instance (RoutesToPaths api) => RoutesToPaths (ZAuthServant ztype opts :> api) where
  getRoutes :: Forest PathSegment
getRoutes = forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @api

instance (RoutesToPaths api) => RoutesToPaths (ZHostOpt :> api) where
  getRoutes :: Forest PathSegment
getRoutes = forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @api

-- FUTUREWORK: Make a PR to the servant-swagger package with this instance
instance (Typeable ls, ToSchema a) => ToSchema (Headers ls a) where
  declareNamedSchema :: Proxy (Headers ls a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Headers ls a)
_ = Proxy a -> 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 @a)

data DescriptionOAuthScope (scope :: OAuth.OAuthScope)

type instance
  SpecialiseToVersion v (DescriptionOAuthScope scope :> api) =
    DescriptionOAuthScope scope :> SpecialiseToVersion v api

instance
  (HasOpenApi api, OAuth.IsOAuthScope scope) =>
  HasOpenApi (DescriptionOAuthScope scope :> api)
  where
  toOpenApi :: Proxy (DescriptionOAuthScope scope :> api) -> OpenApi
toOpenApi Proxy (DescriptionOAuthScope scope :> api)
_ = forall {k} (scope :: k). IsOAuthScope scope => OpenApi -> OpenApi
forall (scope :: OAuthScope).
IsOAuthScope scope =>
OpenApi -> OpenApi
addScopeDescription @scope (Proxy api -> OpenApi
forall {k} (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api))

addScopeDescription :: forall scope. (OAuth.IsOAuthScope scope) => OpenApi -> OpenApi
addScopeDescription :: forall {k} (scope :: k). IsOAuthScope scope => OpenApi -> OpenApi
addScopeDescription =
  (Operation -> Identity Operation) -> OpenApi -> Identity OpenApi
Traversal' OpenApi Operation
allOperations
    ((Operation -> Identity Operation) -> OpenApi -> Identity OpenApi)
-> ((Maybe Text -> Identity (Maybe Text))
    -> Operation -> Identity Operation)
-> (Maybe Text -> Identity (Maybe Text))
-> OpenApi
-> Identity OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Text -> Identity (Maybe Text))
-> Operation -> Identity Operation
forall s a. HasDescription s a => Lens' s a
Lens' Operation (Maybe Text)
description
    ((Maybe Text -> Identity (Maybe Text))
 -> OpenApi -> Identity OpenApi)
-> (Maybe Text -> Maybe Text) -> OpenApi -> OpenApi
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Text -> Maybe Text
forall a. a -> Maybe a
Just
      (Text -> Maybe Text)
-> (Maybe Text -> Text) -> Maybe Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            Text
"\nOAuth scope: `"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ( OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text)
-> (OAuthScope -> ByteString) -> OAuthScope -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict (ByteString -> ByteString)
-> (OAuthScope -> ByteString) -> OAuthScope -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OAuthScope -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString (OAuthScope -> Text) -> OAuthScope -> Text
forall a b. (a -> b) -> a -> b
$
                     forall (scope :: k). IsOAuthScope scope => OAuthScope
forall {k} (scope :: k). IsOAuthScope scope => OAuthScope
OAuth.toOAuthScope @scope
                 )
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"
        )
      (Text -> Text) -> (Maybe Text -> Text) -> Maybe Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Text
forall m. Monoid m => Maybe m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold

instance (HasServer api ctx) => HasServer (DescriptionOAuthScope scope :> api) ctx where
  type ServerT (DescriptionOAuthScope scope :> api) m = ServerT api m

  route :: forall env.
Proxy (DescriptionOAuthScope scope :> api)
-> Context ctx
-> Delayed env (Server (DescriptionOAuthScope scope :> api))
-> Router env
route Proxy (DescriptionOAuthScope scope :> api)
_ = Proxy api
-> Context ctx
-> Delayed env (Server api)
-> Router' env RoutingApplication
forall env.
Proxy api -> Context ctx -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api)
  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (DescriptionOAuthScope scope :> api)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (DescriptionOAuthScope scope :> api) m
-> ServerT (DescriptionOAuthScope scope :> api) n
hoistServerWithContext Proxy (DescriptionOAuthScope scope :> api)
_ = Proxy api
-> Proxy ctx
-> (forall {x}. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: * -> *) (n :: * -> *).
Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api)

instance (RoutesToPaths api) => RoutesToPaths (DescriptionOAuthScope scope :> api) where
  getRoutes :: Forest PathSegment
getRoutes = forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @api