{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}

module CoinbasePro.Authenticated.Request
    ( CBAuthT (..)
    , runCbAuthT
    , runDefCbAuthT

    , CoinbaseProCredentials (..)
    , CBSecretKey (..)

    , AuthGet
    , AuthPost
    , AuthDelete

    , authRequest
    , mkCBAccessSign
    , mkCBAccessTimeStamp
    ) where

import           Control.Monad.Catch               (MonadCatch, MonadThrow, MonadMask)
import           Control.Monad.IO.Class            (MonadIO, liftIO)
import           Control.Monad.Trans.Class         (MonadTrans, lift)
import           Control.Monad.Trans.Reader        (ReaderT, asks, runReaderT)
import           Crypto.Hash.Algorithms            (SHA256)
import qualified Crypto.MAC.HMAC                   as HMAC
import           Data.ByteArray.Encoding           (Base (Base64),
                                                    convertFromBase,
                                                    convertToBase)
import           Data.ByteString                   (ByteString)
import qualified Data.ByteString.Char8             as C8
import           Data.Text                         (pack)
import           Data.Text.Encoding                (encodeUtf8)
import           Data.Time.Clock                   (getCurrentTime)
import           Data.Time.Format                  (defaultTimeLocale,
                                                    formatTime)
import           GHC.TypeLits                      (Symbol)
import           Network.HTTP.Types                (Method)
import           Servant.API                       (AuthProtect, Delete, Get,
                                                    JSON, Post, (:>))
import           Servant.Client                    (ClientM)
import           Servant.Client.Core               (AuthClientData,
                                                    AuthenticatedRequest,
                                                    addHeader,
                                                    mkAuthenticatedRequest)
import qualified Servant.Client.Core               as SCC

import           CoinbasePro.Authenticated.Headers (CBAccessKey (..),
                                                    CBAccessPassphrase (..),
                                                    CBAccessSign (..),
                                                    CBAccessTimeStamp (..))
import           CoinbasePro.Environment           (Environment)
import           CoinbasePro.Headers               (userAgent)
import           CoinbasePro.Request               (Body, RequestPath, Runner,
                                                    run)


newtype CBSecretKey = CBSecretKey String
    deriving (CBSecretKey -> CBSecretKey -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CBSecretKey -> CBSecretKey -> Bool
$c/= :: CBSecretKey -> CBSecretKey -> Bool
== :: CBSecretKey -> CBSecretKey -> Bool
$c== :: CBSecretKey -> CBSecretKey -> Bool
Eq)


data CoinbaseProCredentials = CoinbaseProCredentials
    { CoinbaseProCredentials -> CBAccessKey
cbAccessKey        :: CBAccessKey
    , CoinbaseProCredentials -> CBSecretKey
cbSecretKey        :: CBSecretKey
    , CoinbaseProCredentials -> CBAccessPassphrase
cbAccessPassphrase :: CBAccessPassphrase
    } deriving (CoinbaseProCredentials -> CoinbaseProCredentials -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CoinbaseProCredentials -> CoinbaseProCredentials -> Bool
$c/= :: CoinbaseProCredentials -> CoinbaseProCredentials -> Bool
== :: CoinbaseProCredentials -> CoinbaseProCredentials -> Bool
$c== :: CoinbaseProCredentials -> CoinbaseProCredentials -> Bool
Eq)


newtype CBAuthT m a = CBAuthT { forall (m :: * -> *) a.
CBAuthT m a -> ReaderT CoinbaseProCredentials m a
unCbAuth :: ReaderT CoinbaseProCredentials m a }
    deriving (forall a b. a -> CBAuthT m b -> CBAuthT m a
forall a b. (a -> b) -> CBAuthT m a -> CBAuthT m b
forall (m :: * -> *) a b.
Functor m =>
a -> CBAuthT m b -> CBAuthT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> CBAuthT m a -> CBAuthT m 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 -> CBAuthT m b -> CBAuthT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> CBAuthT m b -> CBAuthT m a
fmap :: forall a b. (a -> b) -> CBAuthT m a -> CBAuthT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> CBAuthT m a -> CBAuthT m b
Functor, forall a. a -> CBAuthT m a
forall a b. CBAuthT m a -> CBAuthT m b -> CBAuthT m a
forall a b. CBAuthT m a -> CBAuthT m b -> CBAuthT m b
forall a b. CBAuthT m (a -> b) -> CBAuthT m a -> CBAuthT m b
forall a b c.
(a -> b -> c) -> CBAuthT m a -> CBAuthT m b -> CBAuthT m 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 {m :: * -> *}. Applicative m => Functor (CBAuthT m)
forall (m :: * -> *) a. Applicative m => a -> CBAuthT m a
forall (m :: * -> *) a b.
Applicative m =>
CBAuthT m a -> CBAuthT m b -> CBAuthT m a
forall (m :: * -> *) a b.
Applicative m =>
CBAuthT m a -> CBAuthT m b -> CBAuthT m b
forall (m :: * -> *) a b.
Applicative m =>
CBAuthT m (a -> b) -> CBAuthT m a -> CBAuthT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> CBAuthT m a -> CBAuthT m b -> CBAuthT m c
<* :: forall a b. CBAuthT m a -> CBAuthT m b -> CBAuthT m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
CBAuthT m a -> CBAuthT m b -> CBAuthT m a
*> :: forall a b. CBAuthT m a -> CBAuthT m b -> CBAuthT m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
CBAuthT m a -> CBAuthT m b -> CBAuthT m b
liftA2 :: forall a b c.
(a -> b -> c) -> CBAuthT m a -> CBAuthT m b -> CBAuthT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> CBAuthT m a -> CBAuthT m b -> CBAuthT m c
<*> :: forall a b. CBAuthT m (a -> b) -> CBAuthT m a -> CBAuthT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
CBAuthT m (a -> b) -> CBAuthT m a -> CBAuthT m b
pure :: forall a. a -> CBAuthT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> CBAuthT m a
Applicative, forall a. a -> CBAuthT m a
forall a b. CBAuthT m a -> CBAuthT m b -> CBAuthT m b
forall a b. CBAuthT m a -> (a -> CBAuthT m b) -> CBAuthT m b
forall {m :: * -> *}. Monad m => Applicative (CBAuthT m)
forall (m :: * -> *) a. Monad m => a -> CBAuthT m a
forall (m :: * -> *) a b.
Monad m =>
CBAuthT m a -> CBAuthT m b -> CBAuthT m b
forall (m :: * -> *) a b.
Monad m =>
CBAuthT m a -> (a -> CBAuthT m b) -> CBAuthT m 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 -> CBAuthT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> CBAuthT m a
>> :: forall a b. CBAuthT m a -> CBAuthT m b -> CBAuthT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
CBAuthT m a -> CBAuthT m b -> CBAuthT m b
>>= :: forall a b. CBAuthT m a -> (a -> CBAuthT m b) -> CBAuthT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
CBAuthT m a -> (a -> CBAuthT m b) -> CBAuthT m b
Monad, forall a. IO a -> CBAuthT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (CBAuthT m)
forall (m :: * -> *) a. MonadIO m => IO a -> CBAuthT m a
liftIO :: forall a. IO a -> CBAuthT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> CBAuthT m a
MonadIO, forall (m :: * -> *) a. Monad m => m a -> CBAuthT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: forall (m :: * -> *) a. Monad m => m a -> CBAuthT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> CBAuthT m a
MonadTrans, forall e a. Exception e => e -> CBAuthT m a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
forall {m :: * -> *}. MonadThrow m => Monad (CBAuthT m)
forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> CBAuthT m a
throwM :: forall e a. Exception e => e -> CBAuthT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> CBAuthT m a
MonadThrow, forall e a.
Exception e =>
CBAuthT m a -> (e -> CBAuthT m a) -> CBAuthT m a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
forall {m :: * -> *}. MonadCatch m => MonadThrow (CBAuthT m)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
CBAuthT m a -> (e -> CBAuthT m a) -> CBAuthT m a
catch :: forall e a.
Exception e =>
CBAuthT m a -> (e -> CBAuthT m a) -> CBAuthT m a
$ccatch :: forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
CBAuthT m a -> (e -> CBAuthT m a) -> CBAuthT m a
MonadCatch, forall b.
((forall a. CBAuthT m a -> CBAuthT m a) -> CBAuthT m b)
-> CBAuthT m b
forall a b c.
CBAuthT m a
-> (a -> ExitCase b -> CBAuthT m c)
-> (a -> CBAuthT m b)
-> CBAuthT m (b, c)
forall {m :: * -> *}. MonadMask m => MonadCatch (CBAuthT m)
forall (m :: * -> *) b.
MonadMask m =>
((forall a. CBAuthT m a -> CBAuthT m a) -> CBAuthT m b)
-> CBAuthT m b
forall (m :: * -> *) a b c.
MonadMask m =>
CBAuthT m a
-> (a -> ExitCase b -> CBAuthT m c)
-> (a -> CBAuthT m b)
-> CBAuthT m (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: forall a b c.
CBAuthT m a
-> (a -> ExitCase b -> CBAuthT m c)
-> (a -> CBAuthT m b)
-> CBAuthT m (b, c)
$cgeneralBracket :: forall (m :: * -> *) a b c.
MonadMask m =>
CBAuthT m a
-> (a -> ExitCase b -> CBAuthT m c)
-> (a -> CBAuthT m b)
-> CBAuthT m (b, c)
uninterruptibleMask :: forall b.
((forall a. CBAuthT m a -> CBAuthT m a) -> CBAuthT m b)
-> CBAuthT m b
$cuninterruptibleMask :: forall (m :: * -> *) b.
MonadMask m =>
((forall a. CBAuthT m a -> CBAuthT m a) -> CBAuthT m b)
-> CBAuthT m b
mask :: forall b.
((forall a. CBAuthT m a -> CBAuthT m a) -> CBAuthT m b)
-> CBAuthT m b
$cmask :: forall (m :: * -> *) b.
MonadMask m =>
((forall a. CBAuthT m a -> CBAuthT m a) -> CBAuthT m b)
-> CBAuthT m b
MonadMask)


-- | Sequences `ClientM` actions using the same auth credentials
--
-- This allows for custom `Runner`s to be used.
runCbAuthT :: Runner a -> CoinbaseProCredentials -> CBAuthT ClientM a -> IO a
runCbAuthT :: forall a.
Runner a -> CoinbaseProCredentials -> CBAuthT ClientM a -> IO a
runCbAuthT Runner a
runEnv CoinbaseProCredentials
cpc = Runner a
runEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT CoinbaseProCredentials
cpc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
CBAuthT m a -> ReaderT CoinbaseProCredentials m a
unCbAuth


-- | Sequences `ClientM` actions using the same auth credentials
--
-- Should be used over `runCbAuthT` unless a bespoke `Runner` needs to be used.
runDefCbAuthT :: Environment -> CoinbaseProCredentials -> CBAuthT ClientM a -> IO a
runDefCbAuthT :: forall a.
Environment -> CoinbaseProCredentials -> CBAuthT ClientM a -> IO a
runDefCbAuthT Environment
env = forall a.
Runner a -> CoinbaseProCredentials -> CBAuthT ClientM a -> IO a
runCbAuthT (forall a. Environment -> Runner a
run Environment
env)


type instance AuthClientData (AuthProtect "CBAuth") = (CBAccessKey, CBAccessSign, CBAccessTimeStamp, CBAccessPassphrase)


type CBAuthAPI (auth :: Symbol) method a = AuthProtect auth :> method '[JSON] a


type AuthGet a    = CBAuthAPI "CBAuth" Get a
type AuthPost a   = CBAuthAPI "CBAuth" Post a
type AuthDelete a = CBAuthAPI "CBAuth" Delete a


addAuthHeaders :: (CBAccessKey, CBAccessSign, CBAccessTimeStamp, CBAccessPassphrase) -> SCC.Request -> SCC.Request
addAuthHeaders :: (CBAccessKey, CBAccessSign, CBAccessTimeStamp, CBAccessPassphrase)
-> Request -> Request
addAuthHeaders (CBAccessKey
key, CBAccessSign
sig, CBAccessTimeStamp
timestamp, CBAccessPassphrase
pass) Request
req =
      forall a. ToHttpApiData a => HeaderName -> a -> Request -> Request
addHeader HeaderName
"CB-ACCESS-KEY" CBAccessKey
key
    forall a b. (a -> b) -> a -> b
$ forall a. ToHttpApiData a => HeaderName -> a -> Request -> Request
addHeader HeaderName
"CB-ACCESS-SIGN" CBAccessSign
sig
    forall a b. (a -> b) -> a -> b
$ forall a. ToHttpApiData a => HeaderName -> a -> Request -> Request
addHeader HeaderName
"CB-ACCESS-TIMESTAMP" CBAccessTimeStamp
timestamp
    forall a b. (a -> b) -> a -> b
$ forall a. ToHttpApiData a => HeaderName -> a -> Request -> Request
addHeader HeaderName
"CB-ACCESS-PASSPHRASE" CBAccessPassphrase
pass
    forall a b. (a -> b) -> a -> b
$ forall a. ToHttpApiData a => HeaderName -> a -> Request -> Request
addHeader HeaderName
"User-Agent" UserAgent
userAgent Request
req


authRequest :: Method -> RequestPath -> Body
            -> (AuthenticatedRequest (AuthProtect "CBAuth") -> ClientM b)
            -> CBAuthT ClientM b
authRequest :: forall b.
ByteString
-> ByteString
-> ByteString
-> (AuthenticatedRequest (AuthProtect "CBAuth") -> ClientM b)
-> CBAuthT ClientM b
authRequest ByteString
method ByteString
requestPath ByteString
body AuthenticatedRequest (AuthProtect "CBAuth") -> ClientM b
f = do
    CBAccessKey
ak <- forall (m :: * -> *) a.
ReaderT CoinbaseProCredentials m a -> CBAuthT m a
CBAuthT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks CoinbaseProCredentials -> CBAccessKey
cbAccessKey
    CBSecretKey
sk <- forall (m :: * -> *) a.
ReaderT CoinbaseProCredentials m a -> CBAuthT m a
CBAuthT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks CoinbaseProCredentials -> CBSecretKey
cbSecretKey
    CBAccessPassphrase
pp <- forall (m :: * -> *) a.
ReaderT CoinbaseProCredentials m a -> CBAuthT m a
CBAuthT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks CoinbaseProCredentials -> CBAccessPassphrase
cbAccessPassphrase

    CBAccessTimeStamp
ts <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO CBAccessTimeStamp
mkCBAccessTimeStamp
    let cbs :: CBAccessSign
cbs = CBSecretKey
-> CBAccessTimeStamp
-> ByteString
-> ByteString
-> ByteString
-> CBAccessSign
mkCBAccessSign CBSecretKey
sk CBAccessTimeStamp
ts ByteString
method ByteString
requestPath ByteString
body
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthenticatedRequest (AuthProtect "CBAuth") -> ClientM b
f forall a b. (a -> b) -> a -> b
$ forall a.
AuthClientData a
-> (AuthClientData a -> Request -> Request)
-> AuthenticatedRequest a
mkAuthenticatedRequest (CBAccessKey
ak, CBAccessSign
cbs, CBAccessTimeStamp
ts, CBAccessPassphrase
pp) (CBAccessKey, CBAccessSign, CBAccessTimeStamp, CBAccessPassphrase)
-> Request -> Request
addAuthHeaders


mkCBAccessTimeStamp :: IO CBAccessTimeStamp
mkCBAccessTimeStamp :: IO CBAccessTimeStamp
mkCBAccessTimeStamp = Text -> CBAccessTimeStamp
CBAccessTimeStamp forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%s%Q" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime


mkCBAccessSign :: CBSecretKey -> CBAccessTimeStamp -> Method -> RequestPath -> Body -> CBAccessSign
mkCBAccessSign :: CBSecretKey
-> CBAccessTimeStamp
-> ByteString
-> ByteString
-> ByteString
-> CBAccessSign
mkCBAccessSign CBSecretKey
sk CBAccessTimeStamp
ts ByteString
method ByteString
requestPath ByteString
body = ByteString -> CBAccessSign
CBAccessSign forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64 HMAC SHA256
hmac
  where
    dak :: ByteString
dak  = CBSecretKey -> ByteString
decodeApiKey CBSecretKey
sk
    msg :: ByteString
msg  = CBAccessTimeStamp
-> ByteString -> ByteString -> ByteString -> ByteString
mkMsg CBAccessTimeStamp
ts ByteString
method ByteString
requestPath ByteString
body
    hmac :: HMAC SHA256
hmac = forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
HMAC.hmac ByteString
dak ByteString
msg :: HMAC.HMAC SHA256

    mkMsg :: CBAccessTimeStamp -> Method -> RequestPath -> Body -> ByteString
    mkMsg :: CBAccessTimeStamp
-> ByteString -> ByteString -> ByteString -> ByteString
mkMsg (CBAccessTimeStamp Text
s) ByteString
m ByteString
rp ByteString
b = Text -> ByteString
encodeUtf8 Text
s forall a. Semigroup a => a -> a -> a
<> ByteString
m forall a. Semigroup a => a -> a -> a
<> ByteString
rp forall a. Semigroup a => a -> a -> a
<> ByteString
b


decodeApiKey :: CBSecretKey -> ByteString
decodeApiKey :: CBSecretKey -> ByteString
decodeApiKey (CBSecretKey String
s) = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => String -> a
error forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base64 forall a b. (a -> b) -> a -> b
$ String -> ByteString
C8.pack String
s