{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module CoinbasePro.Authenticated.Request
( CBAuthT (..)
, runCbAuthT
, CoinbaseProCredentials (..)
, CBSecretKey (..)
, AuthGet
, AuthPost
, AuthDelete
, authRequest
, mkCBAccessSign
, mkCBAccessTimeStamp
) where
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.Headers (userAgent)
import CoinbasePro.Request (Body, RequestPath, Runner)
newtype CBSecretKey = CBSecretKey String
deriving (CBSecretKey -> CBSecretKey -> Bool
(CBSecretKey -> CBSecretKey -> Bool)
-> (CBSecretKey -> CBSecretKey -> Bool) -> Eq CBSecretKey
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
(CoinbaseProCredentials -> CoinbaseProCredentials -> Bool)
-> (CoinbaseProCredentials -> CoinbaseProCredentials -> Bool)
-> Eq CoinbaseProCredentials
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 { CBAuthT m a -> ReaderT CoinbaseProCredentials m a
unCbAuth :: ReaderT CoinbaseProCredentials m a }
deriving (a -> CBAuthT m b -> CBAuthT m a
(a -> b) -> CBAuthT m a -> CBAuthT m b
(forall a b. (a -> b) -> CBAuthT m a -> CBAuthT m b)
-> (forall a b. a -> CBAuthT m b -> CBAuthT m a)
-> Functor (CBAuthT m)
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
<$ :: a -> CBAuthT m b -> CBAuthT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> CBAuthT m b -> CBAuthT m a
fmap :: (a -> b) -> CBAuthT m a -> CBAuthT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> CBAuthT m a -> CBAuthT m b
Functor, Functor (CBAuthT m)
a -> CBAuthT m a
Functor (CBAuthT m)
-> (forall a. a -> CBAuthT m a)
-> (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 a b. CBAuthT m a -> CBAuthT m b -> CBAuthT m b)
-> (forall a b. CBAuthT m a -> CBAuthT m b -> CBAuthT m a)
-> Applicative (CBAuthT m)
CBAuthT m a -> CBAuthT m b -> CBAuthT m b
CBAuthT m a -> CBAuthT m b -> CBAuthT m a
CBAuthT m (a -> b) -> CBAuthT m a -> CBAuthT m b
(a -> b -> c) -> CBAuthT m a -> CBAuthT m b -> CBAuthT m c
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
<* :: 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
*> :: 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 :: (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
<*> :: 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 :: a -> CBAuthT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> CBAuthT m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (CBAuthT m)
Applicative, Applicative (CBAuthT m)
a -> CBAuthT m a
Applicative (CBAuthT m)
-> (forall a b. CBAuthT m a -> (a -> CBAuthT m b) -> CBAuthT m b)
-> (forall a b. CBAuthT m a -> CBAuthT m b -> CBAuthT m b)
-> (forall a. a -> CBAuthT m a)
-> Monad (CBAuthT m)
CBAuthT m a -> (a -> CBAuthT m b) -> CBAuthT m b
CBAuthT m a -> CBAuthT m b -> CBAuthT m b
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 :: a -> CBAuthT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> CBAuthT m a
>> :: 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
>>= :: 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
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (CBAuthT m)
Monad, Monad (CBAuthT m)
Monad (CBAuthT m)
-> (forall a. IO a -> CBAuthT m a) -> MonadIO (CBAuthT m)
IO a -> CBAuthT m a
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 :: IO a -> CBAuthT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> CBAuthT m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (CBAuthT m)
MonadIO, m a -> CBAuthT m a
(forall (m :: * -> *) a. Monad m => m a -> CBAuthT m a)
-> MonadTrans CBAuthT
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 :: m a -> CBAuthT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> CBAuthT m a
MonadTrans)
runCbAuthT :: Runner a -> CoinbaseProCredentials -> CBAuthT ClientM a -> IO a
runCbAuthT :: Runner a -> CoinbaseProCredentials -> CBAuthT ClientM a -> IO a
runCbAuthT Runner a
runEnv CoinbaseProCredentials
cpc = Runner a
runEnv Runner a
-> (CBAuthT ClientM a -> ClientM a) -> CBAuthT ClientM a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT CoinbaseProCredentials ClientM a
-> CoinbaseProCredentials -> ClientM a)
-> CoinbaseProCredentials
-> ReaderT CoinbaseProCredentials ClientM a
-> ClientM a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT CoinbaseProCredentials ClientM a
-> CoinbaseProCredentials -> ClientM a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT CoinbaseProCredentials
cpc (ReaderT CoinbaseProCredentials ClientM a -> ClientM a)
-> (CBAuthT ClientM a -> ReaderT CoinbaseProCredentials ClientM a)
-> CBAuthT ClientM a
-> ClientM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CBAuthT ClientM a -> ReaderT CoinbaseProCredentials ClientM a
forall (m :: * -> *) a.
CBAuthT m a -> ReaderT CoinbaseProCredentials m a
unCbAuth
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
(CBAccessKey
key, CBAccessSign
sig, CBAccessTimeStamp
timestamp, CBAccessPassphrase
pass) Request
req =
HeaderName -> CBAccessKey -> Request -> Request
forall a. ToHttpApiData a => HeaderName -> a -> Request -> Request
addHeader HeaderName
"CB-ACCESS-KEY" CBAccessKey
key
(Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ HeaderName -> CBAccessSign -> Request -> Request
forall a. ToHttpApiData a => HeaderName -> a -> Request -> Request
addHeader HeaderName
"CB-ACCESS-SIGN" CBAccessSign
sig
(Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ HeaderName -> CBAccessTimeStamp -> Request -> Request
forall a. ToHttpApiData a => HeaderName -> a -> Request -> Request
addHeader HeaderName
"CB-ACCESS-TIMESTAMP" CBAccessTimeStamp
timestamp
(Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ HeaderName -> CBAccessPassphrase -> Request -> Request
forall a. ToHttpApiData a => HeaderName -> a -> Request -> Request
addHeader HeaderName
"CB-ACCESS-PASSPHRASE" CBAccessPassphrase
pass
(Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ HeaderName -> UserAgent -> Request -> Request
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 :: Method
-> Method
-> Method
-> (AuthenticatedRequest (AuthProtect "CBAuth") -> ClientM b)
-> CBAuthT ClientM b
authRequest Method
method Method
requestPath Method
body AuthenticatedRequest (AuthProtect "CBAuth") -> ClientM b
f = do
CBAccessKey
ak <- ReaderT CoinbaseProCredentials ClientM CBAccessKey
-> CBAuthT ClientM CBAccessKey
forall (m :: * -> *) a.
ReaderT CoinbaseProCredentials m a -> CBAuthT m a
CBAuthT (ReaderT CoinbaseProCredentials ClientM CBAccessKey
-> CBAuthT ClientM CBAccessKey)
-> ReaderT CoinbaseProCredentials ClientM CBAccessKey
-> CBAuthT ClientM CBAccessKey
forall a b. (a -> b) -> a -> b
$ (CoinbaseProCredentials -> CBAccessKey)
-> ReaderT CoinbaseProCredentials ClientM CBAccessKey
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks CoinbaseProCredentials -> CBAccessKey
cbAccessKey
CBSecretKey
sk <- ReaderT CoinbaseProCredentials ClientM CBSecretKey
-> CBAuthT ClientM CBSecretKey
forall (m :: * -> *) a.
ReaderT CoinbaseProCredentials m a -> CBAuthT m a
CBAuthT (ReaderT CoinbaseProCredentials ClientM CBSecretKey
-> CBAuthT ClientM CBSecretKey)
-> ReaderT CoinbaseProCredentials ClientM CBSecretKey
-> CBAuthT ClientM CBSecretKey
forall a b. (a -> b) -> a -> b
$ (CoinbaseProCredentials -> CBSecretKey)
-> ReaderT CoinbaseProCredentials ClientM CBSecretKey
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks CoinbaseProCredentials -> CBSecretKey
cbSecretKey
CBAccessPassphrase
pp <- ReaderT CoinbaseProCredentials ClientM CBAccessPassphrase
-> CBAuthT ClientM CBAccessPassphrase
forall (m :: * -> *) a.
ReaderT CoinbaseProCredentials m a -> CBAuthT m a
CBAuthT (ReaderT CoinbaseProCredentials ClientM CBAccessPassphrase
-> CBAuthT ClientM CBAccessPassphrase)
-> ReaderT CoinbaseProCredentials ClientM CBAccessPassphrase
-> CBAuthT ClientM CBAccessPassphrase
forall a b. (a -> b) -> a -> b
$ (CoinbaseProCredentials -> CBAccessPassphrase)
-> ReaderT CoinbaseProCredentials ClientM CBAccessPassphrase
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks CoinbaseProCredentials -> CBAccessPassphrase
cbAccessPassphrase
CBAccessTimeStamp
ts <- IO CBAccessTimeStamp -> CBAuthT ClientM CBAccessTimeStamp
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO CBAccessTimeStamp
mkCBAccessTimeStamp
let cbs :: CBAccessSign
cbs = CBSecretKey
-> CBAccessTimeStamp -> Method -> Method -> Method -> CBAccessSign
mkCBAccessSign CBSecretKey
sk CBAccessTimeStamp
ts Method
method Method
requestPath Method
body
ClientM b -> CBAuthT ClientM b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ClientM b -> CBAuthT ClientM b)
-> (AuthenticatedRequest (AuthProtect "CBAuth") -> ClientM b)
-> AuthenticatedRequest (AuthProtect "CBAuth")
-> CBAuthT ClientM b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthenticatedRequest (AuthProtect "CBAuth") -> ClientM b
f (AuthenticatedRequest (AuthProtect "CBAuth") -> CBAuthT ClientM b)
-> AuthenticatedRequest (AuthProtect "CBAuth") -> CBAuthT ClientM b
forall a b. (a -> b) -> a -> b
$ AuthClientData (AuthProtect "CBAuth")
-> (AuthClientData (AuthProtect "CBAuth") -> Request -> Request)
-> AuthenticatedRequest (AuthProtect "CBAuth")
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
AuthClientData (AuthProtect "CBAuth") -> Request -> Request
addAuthHeaders
mkCBAccessTimeStamp :: IO CBAccessTimeStamp
mkCBAccessTimeStamp :: IO CBAccessTimeStamp
mkCBAccessTimeStamp = Text -> CBAccessTimeStamp
CBAccessTimeStamp (Text -> CBAccessTimeStamp)
-> (UTCTime -> Text) -> UTCTime -> CBAccessTimeStamp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Text) -> (UTCTime -> String) -> UTCTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%s%Q" (UTCTime -> CBAccessTimeStamp)
-> IO UTCTime -> IO CBAccessTimeStamp
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 -> Method -> Method -> Method -> CBAccessSign
mkCBAccessSign CBSecretKey
sk CBAccessTimeStamp
ts Method
method Method
requestPath Method
body = Method -> CBAccessSign
CBAccessSign (Method -> CBAccessSign) -> Method -> CBAccessSign
forall a b. (a -> b) -> a -> b
$ Base -> HMAC SHA256 -> Method
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64 HMAC SHA256
hmac
where
dak :: Method
dak = CBSecretKey -> Method
decodeApiKey CBSecretKey
sk
msg :: Method
msg = CBAccessTimeStamp -> Method -> Method -> Method -> Method
mkMsg CBAccessTimeStamp
ts Method
method Method
requestPath Method
body
hmac :: HMAC SHA256
hmac = Method -> Method -> HMAC SHA256
forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
HMAC.hmac Method
dak Method
msg :: HMAC.HMAC SHA256
mkMsg :: CBAccessTimeStamp -> Method -> RequestPath -> Body -> ByteString
mkMsg :: CBAccessTimeStamp -> Method -> Method -> Method -> Method
mkMsg (CBAccessTimeStamp Text
s) Method
m Method
rp Method
b = Text -> Method
encodeUtf8 Text
s Method -> Method -> Method
forall a. Semigroup a => a -> a -> a
<> Method
m Method -> Method -> Method
forall a. Semigroup a => a -> a -> a
<> Method
rp Method -> Method -> Method
forall a. Semigroup a => a -> a -> a
<> Method
b
decodeApiKey :: CBSecretKey -> ByteString
decodeApiKey :: CBSecretKey -> Method
decodeApiKey (CBSecretKey String
s) = (String -> Method)
-> (Method -> Method) -> Either String Method -> Method
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Method
forall a. HasCallStack => String -> a
error Method -> Method
forall a. a -> a
id (Either String Method -> Method)
-> (Method -> Either String Method) -> Method -> Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base -> Method -> Either String Method
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base64 (Method -> Method) -> Method -> Method
forall a b. (a -> b) -> a -> b
$ String -> Method
C8.pack String
s