{-# LANGUAGE CPP                        #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
#if __GLASGOW_HASKELL__ == 800
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
#endif
module Servant.Auth.Client.Internal where

import qualified Data.ByteString    as BS
import           Data.Monoid
import           Data.Proxy         (Proxy (..))
import           Data.String        (IsString)
import           GHC.Exts           (Constraint)
import           GHC.Generics       (Generic)
import           Servant.API        ((:>))
import           Servant.Auth

import           Servant.Client.Core
import           Data.Sequence ((<|))

-- | A simple bearer token.
newtype Token = Token { Token -> ByteString
getToken :: BS.ByteString }
  deriving (Token -> Token -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c== :: Token -> Token -> Bool
Eq, Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show, ReadPrec [Token]
ReadPrec Token
Int -> ReadS Token
ReadS [Token]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Token]
$creadListPrec :: ReadPrec [Token]
readPrec :: ReadPrec Token
$creadPrec :: ReadPrec Token
readList :: ReadS [Token]
$creadList :: ReadS [Token]
readsPrec :: Int -> ReadS Token
$creadsPrec :: Int -> ReadS Token
Read, forall x. Rep Token x -> Token
forall x. Token -> Rep Token x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Token x -> Token
$cfrom :: forall x. Token -> Rep Token x
Generic, String -> Token
forall a. (String -> a) -> IsString a
fromString :: String -> Token
$cfromString :: String -> Token
IsString)

type family HasBearer xs :: Constraint where
  HasBearer (Bearer ': xs) = ()
  HasBearer (JWT ': xs) = ()
  HasBearer (x ': xs)   = HasBearer xs
  HasBearer '[]         = BearerAuthNotEnabled

class BearerAuthNotEnabled

-- | @'HasBearer' auths@ is nominally a redundant constraint, but ensures we're not
-- trying to send a token to an API that doesn't accept them.
instance (HasBearer auths, HasClient m api) => HasClient m (Auth auths a :> api) where
  type Client m (Auth auths a :> api) = Token -> Client m api

  clientWithRoute :: Proxy m
-> Proxy (Auth auths a :> api)
-> Request
-> Client m (Auth auths a :> api)
clientWithRoute Proxy m
m Proxy (Auth auths a :> api)
_ Request
req (Token ByteString
token)
    = forall (m :: * -> *) api.
HasClient m api =>
Proxy m -> Proxy api -> Request -> Client m api
clientWithRoute Proxy m
m (forall {k} (t :: k). Proxy t
Proxy :: Proxy api)
    forall a b. (a -> b) -> a -> b
$ Request
req { requestHeaders :: Seq Header
requestHeaders = (HeaderName
"Authorization", ByteString
headerVal) forall a. a -> Seq a -> Seq a
<| forall body path. RequestF body path -> Seq Header
requestHeaders Request
req  }
      where
        headerVal :: ByteString
headerVal = ByteString
"Bearer " forall a. Semigroup a => a -> a -> a
<> ByteString
token

#if MIN_VERSION_servant_client_core(0,14,0)
  hoistClientMonad :: forall (mon :: * -> *) (mon' :: * -> *).
Proxy m
-> Proxy (Auth auths a :> api)
-> (forall x. mon x -> mon' x)
-> Client mon (Auth auths a :> api)
-> Client mon' (Auth auths a :> api)
hoistClientMonad Proxy m
pm Proxy (Auth auths a :> api)
_ forall x. mon x -> mon' x
nt Client mon (Auth auths a :> api)
cl = forall (m :: * -> *) api (mon :: * -> *) (mon' :: * -> *).
HasClient m api =>
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
hoistClientMonad Proxy m
pm (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) forall x. mon x -> mon' x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. Client mon (Auth auths a :> api)
cl
#endif


-- * Authentication combinators

-- | A Bearer token in the Authorization header:
--
--    @Authorization: Bearer <token>@
--
-- This can be any token recognized by the server, for example,
-- a JSON Web Token (JWT).
--
-- Note that, since the exact way the token is validated is not specified,
-- this combinator can only be used in the client. The server would not know
-- how to validate it, while the client does not care.
-- If you want to implement Bearer authentication in your server, you have to
-- choose a specific combinator, such as 'JWT'.
data Bearer