{-# 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.Foldable (toList)
import Data.List (sort)
import Data.Proxy (Proxy (..))
import Data.Sequence (fromList, (<|))
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
    { -- | Singing function that will sign all outgoing requests.
      HmacSettings -> SecretKey -> ByteString -> Signature
hmacSigner      :: SecretKey -> ByteString -> Signature

      -- | Secret key for signing function.
    , HmacSettings -> SecretKey
hmacSecretKey   :: SecretKey

      -- | Function to call for every request after this request is signed.
      -- Useful for debugging.
    , HmacSettings -> Maybe (Request -> ClientM ())
hmacRequestHook :: Maybe (Servant.Request -> ClientM ())
    }

{- | 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 :: (SecretKey -> ByteString -> Signature)
-> SecretKey -> Maybe (Request -> ClientM ()) -> HmacSettings
HmacSettings
    { hmacSigner :: SecretKey -> ByteString -> Signature
hmacSigner      = SecretKey -> ByteString -> Signature
signSHA256
    , hmacSecretKey :: SecretKey
hmacSecretKey   = SecretKey
sk
    , hmacRequestHook :: Maybe (Request -> ClientM ())
hmacRequestHook = Maybe (Request -> ClientM ())
forall a. Maybe a
Nothing
    }

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

hmacifyClient :: ClientM a -> HmacClientM a
hmacifyClient :: ClientM a -> HmacClientM a
hmacifyClient = ReaderT HmacSettings ClientM a -> HmacClientM a
forall a. ReaderT HmacSettings ClientM a -> HmacClientM a
HmacClientM (ReaderT HmacSettings ClientM a -> HmacClientM a)
-> (ClientM a -> ReaderT HmacSettings ClientM a)
-> ClientM a
-> HmacClientM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientM a -> ReaderT HmacSettings ClientM a
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 = ReaderT HmacSettings ClientM Request -> HmacClientM Request
forall a. ReaderT HmacSettings ClientM a -> HmacClientM a
HmacClientM (ReaderT HmacSettings ClientM Request -> HmacClientM Request)
-> ReaderT HmacSettings ClientM Request -> HmacClientM Request
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
..} <- ReaderT HmacSettings ClientM HmacSettings
forall r (m :: * -> *). MonadReader r m => m r
ask
    BaseUrl
url <- ClientM BaseUrl -> ReaderT HmacSettings ClientM BaseUrl
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ClientM BaseUrl -> ReaderT HmacSettings ClientM BaseUrl)
-> ClientM BaseUrl -> ReaderT HmacSettings ClientM BaseUrl
forall a b. (a -> b) -> a -> b
$ (ClientEnv -> BaseUrl) -> ClientM BaseUrl
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   -> () -> ReaderT HmacSettings ClientM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just Request -> ClientM ()
hook -> ClientM () -> ReaderT HmacSettings ClientM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ClientM () -> ReaderT HmacSettings ClientM ())
-> ClientM () -> ReaderT HmacSettings ClientM ()
forall a b. (a -> b) -> a -> b
$ Request -> ClientM ()
hook Request
signedRequest
    Request -> ReaderT HmacSettings ClientM Request
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 (Request -> HmacClientM Request)
-> (Request -> HmacClientM Response)
-> Request
-> HmacClientM Response
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ClientM Response -> HmacClientM Response
forall a. ClientM a -> HmacClientM a
hmacifyClient (ClientM Response -> HmacClientM Response)
-> (Request -> ClientM Response) -> Request -> HmacClientM Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [Status] -> Request -> ClientM Response
forall (m :: * -> *).
RunClient m =>
Maybe [Status] -> Request -> m Response
runRequestAcceptStatus Maybe [Status]
s

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

runHmacClient
    :: HmacSettings
    -> ClientEnv
    -> HmacClientM a
    -> IO (Either ClientError a)
runHmacClient :: HmacSettings
-> ClientEnv -> HmacClientM a -> IO (Either ClientError a)
runHmacClient HmacSettings
settings ClientEnv
env HmacClientM a
client =
    ClientM a -> ClientEnv -> IO (Either ClientError a)
forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM (ReaderT HmacSettings ClientM a -> HmacSettings -> ClientM a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (HmacClientM a -> ReaderT HmacSettings ClientM a
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 :: Client HmacClientM api
hmacClient = Proxy api
forall k (t :: k). Proxy t
Proxy @api Proxy api -> Proxy HmacClientM -> Client HmacClientM api
forall (m :: * -> *) api.
HasClient m api =>
Proxy api -> Proxy m -> Client m api
`clientIn` Proxy HmacClientM
forall k (t :: k). Proxy t
Proxy @HmacClientM

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

servantRequestToPayload :: BaseUrl -> Servant.Request -> RequestPayload
servantRequestToPayload :: BaseUrl -> Request -> RequestPayload
servantRequestToPayload BaseUrl
url Request
sreq = RequestPayload :: ByteString
-> ByteString -> RequestHeaders -> ByteString -> RequestPayload
RequestPayload
    { rpMethod :: ByteString
rpMethod  = Request -> ByteString
Client.method Request
req
    , rpContent :: ByteString
rpContent = ByteString
"" -- toBsBody $ Client.requestBody req
    , rpHeaders :: RequestHeaders
rpHeaders = RequestHeaders -> RequestHeaders
keepWhitelistedHeaders
                (RequestHeaders -> RequestHeaders)
-> RequestHeaders -> RequestHeaders
forall a b. (a -> b) -> a -> b
$ (HeaderName
"Host", ByteString
host)
                (HeaderName, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
: (HeaderName
"Accept-Encoding", ByteString
"gzip")
                (HeaderName, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
: Request -> RequestHeaders
Client.requestHeaders Request
req

    , rpRawUrl :: ByteString
rpRawUrl  = ByteString
host ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
Client.path Request
req ByteString -> ByteString -> ByteString
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 =
             [QueryItem] -> Seq QueryItem
forall a. [a] -> Seq a
fromList ([QueryItem] -> Seq QueryItem) -> [QueryItem] -> Seq QueryItem
forall a b. (a -> b) -> a -> b
$ [QueryItem] -> [QueryItem]
forall a. Ord a => [a] -> [a]
sort ([QueryItem] -> [QueryItem]) -> [QueryItem] -> [QueryItem]
forall a b. (a -> b) -> a -> b
$ Seq QueryItem -> [QueryItem]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq QueryItem -> [QueryItem]) -> Seq QueryItem -> [QueryItem]
forall a b. (a -> b) -> a -> b
$ Request -> Seq QueryItem
forall body path. RequestF body path -> Seq QueryItem
Servant.requestQueryString Request
sreq
        }

    host :: ByteString
    host :: ByteString
host = Request -> ByteString
Client.host Request
req

--    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
    :: (SecretKey -> ByteString -> Signature)  -- ^ Signing function
    -> SecretKey  -- ^ Secret key that was used for signing 'Request'
    -> BaseUrl  -- ^ Base url for servant request
    -> Servant.Request  -- ^ Original request
    -> Servant.Request  -- ^ Signed 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 :: (HeaderName, ByteString)
authHead = (HeaderName
authHeaderName, ByteString
"HMAC " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Signature -> ByteString
unSignature Signature
signature)
    Request
req { requestHeaders :: Seq (HeaderName, ByteString)
Servant.requestHeaders = (HeaderName, ByteString)
authHead (HeaderName, ByteString)
-> Seq (HeaderName, ByteString) -> Seq (HeaderName, ByteString)
forall a. a -> Seq a -> Seq a
<| Request -> Seq (HeaderName, ByteString)
forall body path.
RequestF body path -> Seq (HeaderName, ByteString)
Servant.requestHeaders Request
req }