{-# 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)
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
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
(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