{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE InstanceSigs #-}

-- | Servant client authentication.
module Servant.Auth.Hmac.Client (
    -- * HMAC client settings
    HmacSettings (..),
    defaultHmacSettings,

    -- * HMAC servant client
    HmacClientM (..),
    runHmacClient,
    hmacClient,
) where

import Control.Monad ((>=>))
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Reader (MonadReader (..), ReaderT, asks, runReaderT)
import Control.Monad.Trans.Class (lift)
import Data.ByteString (ByteString)
import Data.CaseInsensitive (mk)
import Data.Foldable (toList)
import Data.List (sort)
import Data.Proxy (Proxy (..))
import Data.Sequence (fromList, (<|))
import Data.String (fromString)
import Servant.Client (
    BaseUrl,
    Client,
    ClientEnv (baseUrl),
    ClientError,
    ClientM,
    HasClient,
    runClientM,
 )
import Servant.Client.Core (RunClient (..), clientIn)
import Servant.Client.Internal.HttpClient (defaultMakeClientRequest)

import Servant.Auth.Hmac.Crypto (
    RequestPayload (..),
    SecretKey,
    Signature (..),
    authHeaderName,
    keepWhitelistedHeaders,
    requestSignature,
    signSHA256,
 )

import qualified Network.HTTP.Client as Client
import qualified Servant.Client.Core as Servant

-- | Environment for 'HmacClientM'. Contains all required settings for hmac client.
data HmacSettings = HmacSettings
    { HmacSettings -> SecretKey -> ByteString -> Signature
hmacSigner :: SecretKey -> ByteString -> Signature
    -- ^ Singing function that will sign all outgoing requests.
    , HmacSettings -> SecretKey
hmacSecretKey :: SecretKey
    -- ^ Secret key for signing function.
    , HmacSettings -> Maybe (Request -> ClientM ())
hmacRequestHook :: Maybe (Servant.Request -> ClientM ())
    -- ^ Function to call for every request after this request is signed.
    -- Useful for debugging.
    }

{- | Default 'HmacSettings' with the following configuration:

1. Signing function is 'signSHA256'.
2. Secret key is provided.
3. 'hmacRequestHook' is 'Nothing'.
-}
defaultHmacSettings :: SecretKey -> HmacSettings
defaultHmacSettings :: SecretKey -> HmacSettings
defaultHmacSettings SecretKey
sk =
    HmacSettings
        { hmacSigner :: SecretKey -> ByteString -> Signature
hmacSigner = SecretKey -> ByteString -> Signature
signSHA256
        , hmacSecretKey :: SecretKey
hmacSecretKey = SecretKey
sk
        , hmacRequestHook :: Maybe (Request -> ClientM ())
hmacRequestHook = forall a. Maybe a
Nothing
        }

{- | @newtype@ wrapper over 'ClientM' that signs all outgoing requests
automatically.
-}
newtype HmacClientM a = HmacClientM
    { forall a. HmacClientM a -> ReaderT HmacSettings ClientM a
runHmacClientM :: ReaderT HmacSettings ClientM a
    }
    deriving (forall a b. a -> HmacClientM b -> HmacClientM a
forall a b. (a -> b) -> HmacClientM a -> HmacClientM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> HmacClientM b -> HmacClientM a
$c<$ :: forall a b. a -> HmacClientM b -> HmacClientM a
fmap :: forall a b. (a -> b) -> HmacClientM a -> HmacClientM b
$cfmap :: forall a b. (a -> b) -> HmacClientM a -> HmacClientM b
Functor, Functor HmacClientM
forall a. a -> HmacClientM a
forall a b. HmacClientM a -> HmacClientM b -> HmacClientM a
forall a b. HmacClientM a -> HmacClientM b -> HmacClientM b
forall a b. HmacClientM (a -> b) -> HmacClientM a -> HmacClientM b
forall a b c.
(a -> b -> c) -> HmacClientM a -> HmacClientM b -> HmacClientM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. HmacClientM a -> HmacClientM b -> HmacClientM a
$c<* :: forall a b. HmacClientM a -> HmacClientM b -> HmacClientM a
*> :: forall a b. HmacClientM a -> HmacClientM b -> HmacClientM b
$c*> :: forall a b. HmacClientM a -> HmacClientM b -> HmacClientM b
liftA2 :: forall a b c.
(a -> b -> c) -> HmacClientM a -> HmacClientM b -> HmacClientM c
$cliftA2 :: forall a b c.
(a -> b -> c) -> HmacClientM a -> HmacClientM b -> HmacClientM c
<*> :: forall a b. HmacClientM (a -> b) -> HmacClientM a -> HmacClientM b
$c<*> :: forall a b. HmacClientM (a -> b) -> HmacClientM a -> HmacClientM b
pure :: forall a. a -> HmacClientM a
$cpure :: forall a. a -> HmacClientM a
Applicative, Applicative HmacClientM
forall a. a -> HmacClientM a
forall a b. HmacClientM a -> HmacClientM b -> HmacClientM b
forall a b. HmacClientM a -> (a -> HmacClientM b) -> HmacClientM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> HmacClientM a
$creturn :: forall a. a -> HmacClientM a
>> :: forall a b. HmacClientM a -> HmacClientM b -> HmacClientM b
$c>> :: forall a b. HmacClientM a -> HmacClientM b -> HmacClientM b
>>= :: forall a b. HmacClientM a -> (a -> HmacClientM b) -> HmacClientM b
$c>>= :: forall a b. HmacClientM a -> (a -> HmacClientM b) -> HmacClientM b
Monad, Monad HmacClientM
forall a. IO a -> HmacClientM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> HmacClientM a
$cliftIO :: forall a. IO a -> HmacClientM a
MonadIO, MonadReader HmacSettings)

hmacifyClient :: ClientM a -> HmacClientM a
hmacifyClient :: forall a. ClientM a -> HmacClientM a
hmacifyClient = forall a. ReaderT HmacSettings ClientM a -> HmacClientM a
HmacClientM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

hmacClientSign :: Servant.Request -> HmacClientM Servant.Request
hmacClientSign :: Request -> HmacClientM Request
hmacClientSign Request
req = forall a. ReaderT HmacSettings ClientM a -> HmacClientM a
HmacClientM forall a b. (a -> b) -> a -> b
$ do
    HmacSettings{Maybe (Request -> ClientM ())
SecretKey
SecretKey -> ByteString -> Signature
hmacRequestHook :: Maybe (Request -> ClientM ())
hmacSecretKey :: SecretKey
hmacSigner :: SecretKey -> ByteString -> Signature
hmacRequestHook :: HmacSettings -> Maybe (Request -> ClientM ())
hmacSecretKey :: HmacSettings -> SecretKey
hmacSigner :: HmacSettings -> SecretKey -> ByteString -> Signature
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    BaseUrl
url <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ClientEnv -> BaseUrl
baseUrl
    let signedRequest :: Request
signedRequest = (SecretKey -> ByteString -> Signature)
-> SecretKey -> BaseUrl -> Request -> Request
signRequestHmac SecretKey -> ByteString -> Signature
hmacSigner SecretKey
hmacSecretKey BaseUrl
url Request
req
    case Maybe (Request -> ClientM ())
hmacRequestHook of
        Maybe (Request -> ClientM ())
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just Request -> ClientM ()
hook -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Request -> ClientM ()
hook Request
signedRequest
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
signedRequest

instance RunClient HmacClientM where
    runRequestAcceptStatus :: Maybe [Status] -> Request -> HmacClientM Response
runRequestAcceptStatus Maybe [Status]
s = Request -> HmacClientM Request
hmacClientSign forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall a. ClientM a -> HmacClientM a
hmacifyClient forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
RunClient m =>
Maybe [Status] -> Request -> m Response
runRequestAcceptStatus Maybe [Status]
s

    throwClientError :: ClientError -> HmacClientM a
    throwClientError :: forall a. ClientError -> HmacClientM a
throwClientError = forall a. ClientM a -> HmacClientM a
hmacifyClient forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. RunClient m => ClientError -> m a
throwClientError

runHmacClient ::
    HmacSettings ->
    ClientEnv ->
    HmacClientM a ->
    IO (Either ClientError a)
runHmacClient :: forall a.
HmacSettings
-> ClientEnv -> HmacClientM a -> IO (Either ClientError a)
runHmacClient HmacSettings
settings ClientEnv
env HmacClientM a
client =
    forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. HmacClientM a -> ReaderT HmacSettings ClientM a
runHmacClientM HmacClientM a
client) HmacSettings
settings) ClientEnv
env

-- | Generates a set of client functions for an API.
hmacClient :: forall api. HasClient HmacClientM api => Client HmacClientM api
hmacClient :: forall api. HasClient HmacClientM api => Client HmacClientM api
hmacClient = forall {k} (t :: k). Proxy t
Proxy @api forall (m :: * -> *) api.
HasClient m api =>
Proxy api -> Proxy m -> Client m api
`clientIn` forall {k} (t :: k). Proxy t
Proxy @HmacClientM

----------------------------------------------------------------------------
-- Internals
----------------------------------------------------------------------------

servantRequestToPayload :: BaseUrl -> Servant.Request -> RequestPayload
servantRequestToPayload :: BaseUrl -> Request -> RequestPayload
servantRequestToPayload BaseUrl
url Request
sreq =
    RequestPayload
        { rpMethod :: ByteString
rpMethod = Request -> ByteString
Client.method Request
req
        , rpContent :: ByteString
rpContent = ByteString
"" -- toBsBody $ Client.requestBody req
        , rpHeaders :: RequestHeaders
rpHeaders =
            RequestHeaders -> RequestHeaders
keepWhitelistedHeaders forall a b. (a -> b) -> a -> b
$
                (CI ByteString
"Host", ByteString
hostAndPort) forall a. a -> [a] -> [a]
:
                (CI ByteString
"Accept-Encoding", ByteString
"gzip") forall a. a -> [a] -> [a]
:
                Request -> RequestHeaders
Client.requestHeaders Request
req
        , rpRawUrl :: ByteString
rpRawUrl = ByteString
hostAndPort forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
Client.path Request
req forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
Client.queryString Request
req
        }
  where
    req :: Client.Request
    req :: Request
req =
        BaseUrl -> Request -> Request
defaultMakeClientRequest
            BaseUrl
url
            Request
sreq
                { requestQueryString :: Seq QueryItem
Servant.requestQueryString =
                    forall a. [a] -> Seq a
fromList forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall body path. RequestF body path -> Seq QueryItem
Servant.requestQueryString Request
sreq
                }

    hostAndPort :: ByteString
    hostAndPort :: ByteString
hostAndPort = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (forall s. FoldCase s => s -> CI s
mk ByteString
"Host") (Request -> RequestHeaders
Client.requestHeaders Request
req) of
        Just ByteString
hp -> ByteString
hp
        Maybe ByteString
Nothing ->
            case (Request -> Bool
Client.secure Request
req, Request -> Int
Client.port Request
req) of
                (Bool
True, Int
443) -> Request -> ByteString
Client.host Request
req
                (Bool
False, Int
80) -> Request -> ByteString
Client.host Request
req
                (Bool
_, Int
p) -> Request -> ByteString
Client.host Request
req forall a. Semigroup a => a -> a -> a
<> ByteString
":" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall a. Show a => a -> String
show Int
p)

--    toBsBody :: RequestBody -> ByteString
--    toBsBody (RequestBodyBS bs)       = bs
--    toBsBody (RequestBodyLBS bs)      = LBS.toStrict bs
--    toBsBody (RequestBodyBuilder _ b) = LBS.toStrict $ toLazyByteString b
--    toBsBody _                        = ""  -- heh

{- | Adds signed header to the request.

@
Authentication: HMAC <signature>
@
-}
signRequestHmac ::
    -- | Signing function
    (SecretKey -> ByteString -> Signature) ->
    -- | Secret key that was used for signing 'Request'
    SecretKey ->
    -- | Base url for servant request
    BaseUrl ->
    -- | Original request
    Servant.Request ->
    -- | Signed request
    Servant.Request
signRequestHmac :: (SecretKey -> ByteString -> Signature)
-> SecretKey -> BaseUrl -> Request -> Request
signRequestHmac SecretKey -> ByteString -> Signature
signer SecretKey
sk BaseUrl
url Request
req = do
    let payload :: RequestPayload
payload = BaseUrl -> Request -> RequestPayload
servantRequestToPayload BaseUrl
url Request
req
    let signature :: Signature
signature = (SecretKey -> ByteString -> Signature)
-> SecretKey -> RequestPayload -> Signature
requestSignature SecretKey -> ByteString -> Signature
signer SecretKey
sk RequestPayload
payload
    let authHead :: (CI ByteString, ByteString)
authHead = (CI ByteString
authHeaderName, ByteString
"HMAC " forall a. Semigroup a => a -> a -> a
<> Signature -> ByteString
unSignature Signature
signature)
    Request
req{requestHeaders :: Seq (CI ByteString, ByteString)
Servant.requestHeaders = (CI ByteString, ByteString)
authHead forall a. a -> Seq a -> Seq a
<| forall body path.
RequestF body path -> Seq (CI ByteString, ByteString)
Servant.requestHeaders Request
req}