{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds #-}
module BitMEX.Core where
import BitMEX.MimeTypes
import BitMEX.Logging
import qualified Control.Arrow as P (left)
import qualified Control.DeepSeq as NF
import qualified Control.Exception.Safe as E
import qualified Data.Aeson as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64.Lazy as BL64
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BCL
import qualified Data.CaseInsensitive as CI
import qualified Data.Data as P (Data, Typeable, TypeRep, typeRep)
import qualified Data.Foldable as P
import qualified Data.Ix as P
import qualified Data.Maybe as P
import qualified Data.Proxy as P (Proxy(..))
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Time as TI
import qualified Data.Time.ISO8601 as TI
import qualified GHC.Base as P (Alternative)
import qualified Lens.Micro as L
import qualified Network.HTTP.Client.MultipartFormData as NH
import qualified Network.HTTP.Types as NH
import qualified Prelude as P
import qualified Web.FormUrlEncoded as WH
import qualified Web.HttpApiData as WH
import qualified Text.Printf as T
import Control.Applicative ((<|>))
import Control.Applicative (Alternative)
import Data.Function ((&))
import Data.Foldable(foldlM)
import Data.Monoid ((<>))
import Data.Text (Text)
import Prelude (($), (.), (<$>), (<*>), Maybe(..), Bool(..), Char, String, fmap, mempty, pure, return, show, IO, Monad, Functor)
data BitMEXConfig = BitMEXConfig
{ configHost :: BCL.ByteString
, configUserAgent :: Text
, configLogExecWithContext :: LogExecWithContext
, configLogContext :: LogContext
, configAuthMethods :: [AnyAuthMethod]
, configValidateAuthMethods :: Bool
}
instance P.Show BitMEXConfig where
show c =
T.printf
"{ configHost = %v, configUserAgent = %v, ..}"
(show (configHost c))
(show (configUserAgent c))
newConfig :: IO BitMEXConfig
newConfig = do
logCxt <- initLogContext
return $ BitMEXConfig
{ configHost = "https://localhost/api/v1"
, configUserAgent = "swagger-haskell-http-client/1.0.0"
, configLogExecWithContext = runDefaultLogExecWithContext
, configLogContext = logCxt
, configAuthMethods = []
, configValidateAuthMethods = True
}
addAuthMethod :: AuthMethod auth => BitMEXConfig -> auth -> BitMEXConfig
addAuthMethod config@BitMEXConfig {configAuthMethods = as} a =
config { configAuthMethods = AnyAuthMethod a : as}
withStdoutLogging :: BitMEXConfig -> IO BitMEXConfig
withStdoutLogging p = do
logCxt <- stdoutLoggingContext (configLogContext p)
return $ p { configLogExecWithContext = stdoutLoggingExec, configLogContext = logCxt }
withStderrLogging :: BitMEXConfig -> IO BitMEXConfig
withStderrLogging p = do
logCxt <- stderrLoggingContext (configLogContext p)
return $ p { configLogExecWithContext = stderrLoggingExec, configLogContext = logCxt }
withNoLogging :: BitMEXConfig -> BitMEXConfig
withNoLogging p = p { configLogExecWithContext = runNullLogExec}
data BitMEXRequest req contentType res accept = BitMEXRequest
{ rMethod :: NH.Method
, rUrlPath :: [BCL.ByteString]
, rParams :: Params
, rAuthTypes :: [P.TypeRep]
}
deriving (P.Show)
rMethodL :: Lens_' (BitMEXRequest req contentType res accept) NH.Method
rMethodL f BitMEXRequest{..} = (\rMethod -> BitMEXRequest { rMethod, ..} ) <$> f rMethod
{-# INLINE rMethodL #-}
rUrlPathL :: Lens_' (BitMEXRequest req contentType res accept) [BCL.ByteString]
rUrlPathL f BitMEXRequest{..} = (\rUrlPath -> BitMEXRequest { rUrlPath, ..} ) <$> f rUrlPath
{-# INLINE rUrlPathL #-}
rParamsL :: Lens_' (BitMEXRequest req contentType res accept) Params
rParamsL f BitMEXRequest{..} = (\rParams -> BitMEXRequest { rParams, ..} ) <$> f rParams
{-# INLINE rParamsL #-}
rAuthTypesL :: Lens_' (BitMEXRequest req contentType res accept) [P.TypeRep]
rAuthTypesL f BitMEXRequest{..} = (\rAuthTypes -> BitMEXRequest { rAuthTypes, ..} ) <$> f rAuthTypes
{-# INLINE rAuthTypesL #-}
class HasBodyParam req param where
setBodyParam :: forall contentType res accept. (Consumes req contentType, MimeRender contentType param) => BitMEXRequest req contentType res accept -> param -> BitMEXRequest req contentType res accept
setBodyParam req xs =
req `_setBodyLBS` mimeRender (P.Proxy :: P.Proxy contentType) xs & _setContentTypeHeader
class HasOptionalParam req param where
{-# MINIMAL applyOptionalParam | (-&-) #-}
applyOptionalParam :: BitMEXRequest req contentType res accept -> param -> BitMEXRequest req contentType res accept
applyOptionalParam = (-&-)
{-# INLINE applyOptionalParam #-}
(-&-) :: BitMEXRequest req contentType res accept -> param -> BitMEXRequest req contentType res accept
(-&-) = applyOptionalParam
{-# INLINE (-&-) #-}
infixl 2 -&-
data Params = Params
{ paramsQuery :: NH.Query
, paramsHeaders :: NH.RequestHeaders
, paramsBody :: ParamBody
}
deriving (P.Show)
paramsQueryL :: Lens_' Params NH.Query
paramsQueryL f Params{..} = (\paramsQuery -> Params { paramsQuery, ..} ) <$> f paramsQuery
{-# INLINE paramsQueryL #-}
paramsHeadersL :: Lens_' Params NH.RequestHeaders
paramsHeadersL f Params{..} = (\paramsHeaders -> Params { paramsHeaders, ..} ) <$> f paramsHeaders
{-# INLINE paramsHeadersL #-}
paramsBodyL :: Lens_' Params ParamBody
paramsBodyL f Params{..} = (\paramsBody -> Params { paramsBody, ..} ) <$> f paramsBody
{-# INLINE paramsBodyL #-}
data ParamBody
= ParamBodyNone
| ParamBodyB B.ByteString
| ParamBodyBL BL.ByteString
| ParamBodyFormUrlEncoded WH.Form
| ParamBodyMultipartFormData [NH.Part]
deriving (P.Show)
_mkRequest :: NH.Method
-> [BCL.ByteString]
-> BitMEXRequest req contentType res accept
_mkRequest m u = BitMEXRequest m u _mkParams []
_mkParams :: Params
_mkParams = Params [] [] ParamBodyNone
setHeader :: BitMEXRequest req contentType res accept -> [NH.Header] -> BitMEXRequest req contentType res accept
setHeader req header =
req `removeHeader` P.fmap P.fst header &
L.over (rParamsL . paramsHeadersL) (header P.++)
removeHeader :: BitMEXRequest req contentType res accept -> [NH.HeaderName] -> BitMEXRequest req contentType res accept
removeHeader req header =
req &
L.over
(rParamsL . paramsHeadersL)
(P.filter (\h -> cifst h `P.notElem` P.fmap CI.mk header))
where
cifst = CI.mk . P.fst
_setContentTypeHeader :: forall req contentType res accept. MimeType contentType => BitMEXRequest req contentType res accept -> BitMEXRequest req contentType res accept
_setContentTypeHeader req =
case mimeType (P.Proxy :: P.Proxy contentType) of
Just m -> req `setHeader` [("content-type", BC.pack $ P.show m)]
Nothing -> req `removeHeader` ["content-type"]
_setAcceptHeader :: forall req contentType res accept. MimeType accept => BitMEXRequest req contentType res accept -> BitMEXRequest req contentType res accept
_setAcceptHeader req =
case mimeType (P.Proxy :: P.Proxy accept) of
Just m -> req `setHeader` [("accept", BC.pack $ P.show m)]
Nothing -> req `removeHeader` ["accept"]
setQuery :: BitMEXRequest req contentType res accept -> [NH.QueryItem] -> BitMEXRequest req contentType res accept
setQuery req query =
req &
L.over
(rParamsL . paramsQueryL)
((query P.++) . P.filter (\q -> cifst q `P.notElem` P.fmap cifst query))
where
cifst = CI.mk . P.fst
addForm :: BitMEXRequest req contentType res accept -> WH.Form -> BitMEXRequest req contentType res accept
addForm req newform =
let form = case paramsBody (rParams req) of
ParamBodyFormUrlEncoded _form -> _form
_ -> mempty
in req & L.set (rParamsL . paramsBodyL) (ParamBodyFormUrlEncoded (newform <> form))
_addMultiFormPart :: BitMEXRequest req contentType res accept -> NH.Part -> BitMEXRequest req contentType res accept
_addMultiFormPart req newpart =
let parts = case paramsBody (rParams req) of
ParamBodyMultipartFormData _parts -> _parts
_ -> []
in req & L.set (rParamsL . paramsBodyL) (ParamBodyMultipartFormData (newpart : parts))
_setBodyBS :: BitMEXRequest req contentType res accept -> B.ByteString -> BitMEXRequest req contentType res accept
_setBodyBS req body =
req & L.set (rParamsL . paramsBodyL) (ParamBodyB body)
_setBodyLBS :: BitMEXRequest req contentType res accept -> BL.ByteString -> BitMEXRequest req contentType res accept
_setBodyLBS req body =
req & L.set (rParamsL . paramsBodyL) (ParamBodyBL body)
_hasAuthType :: AuthMethod authMethod => BitMEXRequest req contentType res accept -> P.Proxy authMethod -> BitMEXRequest req contentType res accept
_hasAuthType req proxy =
req & L.over rAuthTypesL (P.typeRep proxy :)
toPath
:: WH.ToHttpApiData a
=> a -> BCL.ByteString
toPath = BB.toLazyByteString . WH.toEncodedUrlPiece
toHeader :: WH.ToHttpApiData a => (NH.HeaderName, a) -> [NH.Header]
toHeader x = [fmap WH.toHeader x]
toForm :: WH.ToHttpApiData v => (BC.ByteString, v) -> WH.Form
toForm (k,v) = WH.toForm [(BC.unpack k,v)]
toQuery :: WH.ToHttpApiData a => (BC.ByteString, Maybe a) -> [NH.QueryItem]
toQuery x = [(fmap . fmap) toQueryParam x]
where toQueryParam = T.encodeUtf8 . WH.toQueryParam
data CollectionFormat
= CommaSeparated
| SpaceSeparated
| TabSeparated
| PipeSeparated
| MultiParamArray
toHeaderColl :: WH.ToHttpApiData a => CollectionFormat -> (NH.HeaderName, [a]) -> [NH.Header]
toHeaderColl c xs = _toColl c toHeader xs
toFormColl :: WH.ToHttpApiData v => CollectionFormat -> (BC.ByteString, [v]) -> WH.Form
toFormColl c xs = WH.toForm $ fmap unpack $ _toColl c toHeader $ pack xs
where
pack (k,v) = (CI.mk k, v)
unpack (k,v) = (BC.unpack (CI.original k), BC.unpack v)
toQueryColl :: WH.ToHttpApiData a => CollectionFormat -> (BC.ByteString, Maybe [a]) -> NH.Query
toQueryColl c xs = _toCollA c toQuery xs
_toColl :: P.Traversable f => CollectionFormat -> (f a -> [(b, BC.ByteString)]) -> f [a] -> [(b, BC.ByteString)]
_toColl c encode xs = fmap (fmap P.fromJust) (_toCollA' c fencode BC.singleton (fmap Just xs))
where fencode = fmap (fmap Just) . encode . fmap P.fromJust
{-# INLINE fencode #-}
_toCollA :: (P.Traversable f, P.Traversable t, P.Alternative t) => CollectionFormat -> (f (t a) -> [(b, t BC.ByteString)]) -> f (t [a]) -> [(b, t BC.ByteString)]
_toCollA c encode xs = _toCollA' c encode BC.singleton xs
_toCollA' :: (P.Monoid c, P.Traversable f, P.Traversable t, P.Alternative t) => CollectionFormat -> (f (t a) -> [(b, t c)]) -> (Char -> c) -> f (t [a]) -> [(b, t c)]
_toCollA' c encode one xs = case c of
CommaSeparated -> go (one ',')
SpaceSeparated -> go (one ' ')
TabSeparated -> go (one '\t')
PipeSeparated -> go (one '|')
MultiParamArray -> expandList
where
go sep =
[P.foldl1 (\(sk, sv) (_, v) -> (sk, (combine sep <$> sv <*> v) <|> sv <|> v)) expandList]
combine sep x y = x <> sep <> y
expandList = (P.concatMap encode . (P.traverse . P.traverse) P.toList) xs
{-# INLINE go #-}
{-# INLINE expandList #-}
{-# INLINE combine #-}
class P.Typeable a =>
AuthMethod a where
applyAuthMethod
:: BitMEXConfig
-> a
-> BitMEXRequest req contentType res accept
-> IO (BitMEXRequest req contentType res accept)
data AnyAuthMethod = forall a. AuthMethod a => AnyAuthMethod a deriving (P.Typeable)
instance AuthMethod AnyAuthMethod where applyAuthMethod config (AnyAuthMethod a) req = applyAuthMethod config a req
data AuthMethodException = AuthMethodException String deriving (P.Show, P.Typeable)
instance E.Exception AuthMethodException
_applyAuthMethods
:: BitMEXRequest req contentType res accept
-> BitMEXConfig
-> IO (BitMEXRequest req contentType res accept)
_applyAuthMethods req config@(BitMEXConfig {configAuthMethods = as}) =
foldlM go req as
where
go r (AnyAuthMethod a) = applyAuthMethod config a r
_omitNulls :: [(Text, A.Value)] -> A.Value
_omitNulls = A.object . P.filter notNull
where
notNull (_, A.Null) = False
notNull _ = True
_toFormItem :: (WH.ToHttpApiData a, Functor f) => t -> f a -> f (t, [Text])
_toFormItem name x = (name,) . (:[]) . WH.toQueryParam <$> x
_emptyToNothing :: Maybe String -> Maybe String
_emptyToNothing (Just "") = Nothing
_emptyToNothing x = x
{-# INLINE _emptyToNothing #-}
_memptyToNothing :: (P.Monoid a, P.Eq a) => Maybe a -> Maybe a
_memptyToNothing (Just x) | x P.== P.mempty = Nothing
_memptyToNothing x = x
{-# INLINE _memptyToNothing #-}
newtype DateTime = DateTime { unDateTime :: TI.UTCTime }
deriving (P.Eq,P.Data,P.Ord,P.Typeable,NF.NFData,TI.ParseTime,TI.FormatTime)
instance A.FromJSON DateTime where
parseJSON = A.withText "DateTime" (_readDateTime . T.unpack)
instance A.ToJSON DateTime where
toJSON (DateTime t) = A.toJSON (_showDateTime t)
instance WH.FromHttpApiData DateTime where
parseUrlPiece = P.left T.pack . _readDateTime . T.unpack
instance WH.ToHttpApiData DateTime where
toUrlPiece (DateTime t) = T.pack (_showDateTime t)
instance P.Show DateTime where
show (DateTime t) = _showDateTime t
instance MimeRender MimeMultipartFormData DateTime where
mimeRender _ = mimeRenderDefaultMultipartFormData
_readDateTime :: (TI.ParseTime t, Monad m, Alternative m) => String -> m t
_readDateTime =
_parseISO8601
{-# INLINE _readDateTime #-}
_showDateTime :: (t ~ TI.UTCTime, TI.FormatTime t) => t -> String
_showDateTime =
TI.formatISO8601Millis
{-# INLINE _showDateTime #-}
_parseISO8601 :: (TI.ParseTime t, Monad m, Alternative m) => String -> m t
_parseISO8601 t =
P.asum $
P.flip (TI.parseTimeM True TI.defaultTimeLocale) t <$>
["%FT%T%QZ", "%FT%T%Q%z", "%FT%T%Q%Z"]
{-# INLINE _parseISO8601 #-}
newtype Date = Date { unDate :: TI.Day }
deriving (P.Enum,P.Eq,P.Data,P.Ord,P.Ix,NF.NFData,TI.ParseTime,TI.FormatTime)
instance A.FromJSON Date where
parseJSON = A.withText "Date" (_readDate . T.unpack)
instance A.ToJSON Date where
toJSON (Date t) = A.toJSON (_showDate t)
instance WH.FromHttpApiData Date where
parseUrlPiece = P.left T.pack . _readDate . T.unpack
instance WH.ToHttpApiData Date where
toUrlPiece (Date t) = T.pack (_showDate t)
instance P.Show Date where
show (Date t) = _showDate t
instance MimeRender MimeMultipartFormData Date where
mimeRender _ = mimeRenderDefaultMultipartFormData
_readDate :: (TI.ParseTime t, Monad m) => String -> m t
_readDate =
TI.parseTimeM True TI.defaultTimeLocale "%Y-%m-%d"
{-# INLINE _readDate #-}
_showDate :: TI.FormatTime t => t -> String
_showDate =
TI.formatTime TI.defaultTimeLocale "%Y-%m-%d"
{-# INLINE _showDate #-}
newtype ByteArray = ByteArray { unByteArray :: BL.ByteString }
deriving (P.Eq,P.Data,P.Ord,P.Typeable,NF.NFData)
instance A.FromJSON ByteArray where
parseJSON = A.withText "ByteArray" _readByteArray
instance A.ToJSON ByteArray where
toJSON = A.toJSON . _showByteArray
instance WH.FromHttpApiData ByteArray where
parseUrlPiece = P.left T.pack . _readByteArray
instance WH.ToHttpApiData ByteArray where
toUrlPiece = _showByteArray
instance P.Show ByteArray where
show = T.unpack . _showByteArray
instance MimeRender MimeMultipartFormData ByteArray where
mimeRender _ = mimeRenderDefaultMultipartFormData
_readByteArray :: Monad m => Text -> m ByteArray
_readByteArray = P.either P.fail (pure . ByteArray) . BL64.decode . BL.fromStrict . T.encodeUtf8
{-# INLINE _readByteArray #-}
_showByteArray :: ByteArray -> Text
_showByteArray = T.decodeUtf8 . BL.toStrict . BL64.encode . unByteArray
{-# INLINE _showByteArray #-}
newtype Binary = Binary { unBinary :: BL.ByteString }
deriving (P.Eq,P.Data,P.Ord,P.Typeable,NF.NFData)
instance A.FromJSON Binary where
parseJSON = A.withText "Binary" _readBinaryBase64
instance A.ToJSON Binary where
toJSON = A.toJSON . _showBinaryBase64
instance WH.FromHttpApiData Binary where
parseUrlPiece = P.left T.pack . _readBinaryBase64
instance WH.ToHttpApiData Binary where
toUrlPiece = _showBinaryBase64
instance P.Show Binary where
show = T.unpack . _showBinaryBase64
instance MimeRender MimeMultipartFormData Binary where
mimeRender _ = unBinary
_readBinaryBase64 :: Monad m => Text -> m Binary
_readBinaryBase64 = P.either P.fail (pure . Binary) . BL64.decode . BL.fromStrict . T.encodeUtf8
{-# INLINE _readBinaryBase64 #-}
_showBinaryBase64 :: Binary -> Text
_showBinaryBase64 = T.decodeUtf8 . BL.toStrict . BL64.encode . unBinary
{-# INLINE _showBinaryBase64 #-}
type Lens_' s a = Lens_ s s a a
type Lens_ s t a b = forall (f :: * -> *). Functor f => (a -> f b) -> s -> f t