{-# 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
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
/= :: Token -> Token -> Bool
Eq, Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Token -> ShowS
showsPrec :: Int -> Token -> ShowS
$cshow :: Token -> String
show :: Token -> String
$cshowList :: [Token] -> ShowS
showList :: [Token] -> ShowS
Show, ReadPrec [Token]
ReadPrec Token
Int -> ReadS Token
ReadS [Token]
(Int -> ReadS Token)
-> ReadS [Token]
-> ReadPrec Token
-> ReadPrec [Token]
-> Read Token
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Token
readsPrec :: Int -> ReadS Token
$creadList :: ReadS [Token]
readList :: ReadS [Token]
$creadPrec :: ReadPrec Token
readPrec :: ReadPrec Token
$creadListPrec :: ReadPrec [Token]
readListPrec :: ReadPrec [Token]
Read, (forall x. Token -> Rep Token x)
-> (forall x. Rep Token x -> Token) -> Generic Token
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
$cfrom :: forall x. Token -> Rep Token x
from :: forall x. Token -> Rep Token x
$cto :: forall x. Rep Token x -> Token
to :: forall x. Rep Token x -> Token
Generic, String -> Token
(String -> Token) -> IsString Token
forall a. (String -> a) -> IsString a
$cfromString :: String -> Token
fromString :: 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)
    = Proxy m -> Proxy api -> Request -> Client m api
forall (m :: * -> *) api.
HasClient m api =>
Proxy m -> Proxy api -> Request -> Client m api
clientWithRoute Proxy m
m (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api)
    (Request -> Client m api) -> Request -> Client m api
forall a b. (a -> b) -> a -> b
$ Request
req { requestHeaders = ("Authorization", headerVal) <| requestHeaders req  }
      where
        headerVal :: ByteString
headerVal = ByteString
"Bearer " ByteString -> ByteString -> ByteString
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 = Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
forall (m :: * -> *) api (mon :: * -> *) (mon' :: * -> *).
HasClient m api =>
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
forall (mon :: * -> *) (mon' :: * -> *).
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
hoistClientMonad Proxy m
pm (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) mon x -> mon' x
forall x. mon x -> mon' x
nt (Client mon api -> Client mon' api)
-> (Token -> Client mon api) -> Token -> Client mon' api
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Client mon (Auth auths a :> api)
Token -> Client mon 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