diff --git a/coinbase-exchange.cabal b/coinbase-exchange.cabal --- a/coinbase-exchange.cabal +++ b/coinbase-exchange.cabal @@ -1,5 +1,5 @@ name: coinbase-exchange -version: 0.2.0.2 +version: 0.3.0.0 synopsis: Connector library for the coinbase exchange. description: Access library for the coinbase exchange. Allows the use of both the public market data API as well as the private @@ -11,7 +11,7 @@ maintainer: andrewrademacher@gmail.com category: Web build-type: Simple -cabal-version: >=1.10 +cabal-version: >=1.20 library hs-source-dirs: src @@ -29,19 +29,19 @@ other-modules: Coinbase.Exchange.Rest build-depends: base ==4.* - , mtl + , mtl >=2.2 , resourcet , transformers-base , conduit , conduit-extra , http-conduit - , aeson + , aeson >=0.10.0 , aeson-casing , http-types , text , bytestring , base64-bytestring - , time + , time >=1.5 , scientific , uuid , uuid-aeson @@ -54,6 +54,7 @@ , cryptohash , byteable , exceptions + , unordered-containers , old-locale @@ -68,7 +69,7 @@ , uuid , text - , aeson + , aeson >=0.10.0 , bytestring , time , old-locale @@ -81,6 +82,7 @@ , network , wuss , scientific + , unordered-containers , coinbase-exchange @@ -88,6 +90,7 @@ type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: test + ghc-options: -threaded default-language: Haskell2010 build-depends: base ==4.* @@ -103,5 +106,11 @@ , http-client-tls , http-conduit , transformers + , random + , scientific + , async + , websockets + , aeson >=0.10.0 + , unordered-containers , coinbase-exchange diff --git a/sbox/Main.hs b/sbox/Main.hs --- a/sbox/Main.hs +++ b/sbox/Main.hs @@ -24,10 +24,7 @@ import Coinbase.Exchange.Types.Socket main :: IO () -main = putStrLn "Use GHCi." - -testCoinbaseTime :: String -testCoinbaseTime = "2015-05-06 21:58:22.84227+0000" +main = printSocket -- putStrLn "Use GHCi." btc :: ProductId btc = "BTC-USD" @@ -38,9 +35,6 @@ end :: Maybe UTCTime end = Just $ parseTimeOrError True defaultTimeLocale "%FT%X%z" "2015-04-23T20:22:37+0000" -accountId :: AccountId -accountId = AccountId $ fromJust $ fromString "52072cbb-4e76-496f-a479-166cb4d177fa" - withCoinbase :: Exchange a -> IO a withCoinbase act = do mgr <- newManager tlsManagerSettings @@ -49,7 +43,7 @@ tPass <- liftM CBS.pack $ getEnv "COINBASE_PASSPHRASE" case mkToken tKey tSecret tPass of - Right tok -> do res <- runExchange (ExchangeConf mgr (Just tok) Sandbox) act + Right tok -> do res <- runExchange (ExchangeConf mgr (Just tok) Live) act case res of Right s -> return s Left f -> error $ show f diff --git a/src/Coinbase/Exchange/Rest.hs b/src/Coinbase/Exchange/Rest.hs --- a/src/Coinbase/Exchange/Rest.hs +++ b/src/Coinbase/Exchange/Rest.hs @@ -32,6 +32,8 @@ import Coinbase.Exchange.Types +-- import Debug.Trace + type Signed = Bool voidBody :: Maybe () @@ -122,7 +124,7 @@ => Response (ResumableSource m BS.ByteString) -> m b processResponse res = case responseStatus res of - s | s == status200 -> do body <- responseBody res $$+- sinkParser (fmap fromJSON json) + s | s == status200 -> do body <- responseBody res $$+- sinkParser (fmap {-(\x -> trace (show x) fromJSON x)-} fromJSON json) case body of Success b -> return b Error er -> throwError $ ParseFailure $ T.pack er diff --git a/src/Coinbase/Exchange/Socket.hs b/src/Coinbase/Exchange/Socket.hs --- a/src/Coinbase/Exchange/Socket.hs +++ b/src/Coinbase/Exchange/Socket.hs @@ -14,7 +14,7 @@ import Coinbase.Exchange.Types.Core import Coinbase.Exchange.Types.Socket -subscribe :: ApiType -> ProductId -> WS.ClientApp () -> IO () +subscribe :: ApiType -> ProductId -> WS.ClientApp a -> IO a subscribe atype pid app = withSocketsDo $ runSecureClient location 443 "/" $ \conn -> do WS.sendBinaryData conn $ encode (Subscribe pid) diff --git a/src/Coinbase/Exchange/Types/Core.hs b/src/Coinbase/Exchange/Types/Core.hs --- a/src/Coinbase/Exchange/Types/Core.hs +++ b/src/Coinbase/Exchange/Types/Core.hs @@ -23,6 +23,7 @@ import Data.UUID.Aeson () import Data.Word import GHC.Generics +import Text.Read (readMaybe) newtype ProductId = ProductId { unProductId :: Text } @@ -34,12 +35,18 @@ newtype Size = Size { unSize :: CoinScientific } deriving (Eq, Ord, Num, Fractional, Real, RealFrac, Show, Read, Data, Typeable, Generic, NFData, Hashable, FromJSON, ToJSON) +newtype Cost = Cost { unCost :: CoinScientific } + deriving (Eq, Ord, Num, Fractional, Real, RealFrac, Show, Read, Data, Typeable, Generic, NFData, Hashable, FromJSON, ToJSON) + newtype OrderId = OrderId { unOrderId :: UUID } deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, NFData, Hashable, FromJSON, ToJSON) newtype Aggregate = Aggregate { unAggregate :: Int64 } deriving (Eq, Ord, Show, Read, Num, Data, Typeable, Generic, NFData, Hashable, FromJSON, ToJSON) +newtype Sequence = Sequence { unSequence :: Word64 } + deriving (Eq, Ord, Num, Show, Read, Data, Typeable, Generic, NFData, Hashable, FromJSON, ToJSON) + -- data Side = Buy | Sell @@ -53,7 +60,18 @@ parseJSON = genericParseJSON coinbaseAesonOptions -- +data OrderType = Limit | Market + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic) +instance NFData OrderType +instance Hashable OrderType +instance ToJSON OrderType where + toJSON = genericToJSON coinbaseAesonOptions +instance FromJSON OrderType where + parseJSON = genericParseJSON coinbaseAesonOptions + +-- + newtype TradeId = TradeId { unTradeId :: Word64 } deriving (Eq, Ord, Num, Show, Read, Data, Typeable, Generic, NFData, Hashable) @@ -111,29 +129,9 @@ toJSON (CoinScientific v) = String . T.pack . show $ v instance FromJSON CoinScientific where parseJSON = withText "CoinScientific" $ \t -> - case maybeRead (T.unpack t) of + case readMaybe (T.unpack t) of Just n -> pure $ CoinScientific n Nothing -> fail "Could not parse string scientific." - -maybeRead :: (Read a) => String -> Maybe a -maybeRead = fmap fst . listToMaybe . reads - ----- - -newtype CoinbaseTime = CoinbaseTime { unCoinbaseTime :: UTCTime } - deriving (Eq, Ord, Show, Read, Data, Typeable, NFData) - -instance ToJSON CoinbaseTime where - toJSON (CoinbaseTime t) = String $ T.pack $ - formatTime defaultTimeLocale coinbaseTimeFormat t ++ "00" -instance FromJSON CoinbaseTime where - parseJSON = withText "Coinbase Time" $ \t -> - case parseTimeM True defaultTimeLocale coinbaseTimeFormat (T.unpack t ++ "00") of - Just d -> pure $ CoinbaseTime d - _ -> fail "could not parse coinbase time format." - -coinbaseTimeFormat :: String -coinbaseTimeFormat = "%F %T%Q%z" ---- diff --git a/src/Coinbase/Exchange/Types/MarketData.hs b/src/Coinbase/Exchange/Types/MarketData.hs --- a/src/Coinbase/Exchange/Types/MarketData.hs +++ b/src/Coinbase/Exchange/Types/MarketData.hs @@ -16,7 +16,6 @@ import Data.Data import Data.Hashable import Data.Int -import Data.Scientific import Data.String import Data.Text (Text) import Data.Time @@ -35,9 +34,9 @@ { prodId :: ProductId , prodBaseCurrency :: CurrencyId , prodQuoteCurrency :: CurrencyId - , prodBaseMinSize :: Scientific - , prodBaseMaxSize :: Scientific - , prodQuoteIncrement :: Scientific + , prodBaseMinSize :: CoinScientific + , prodBaseMaxSize :: CoinScientific + , prodQuoteIncrement :: CoinScientific , prodDisplayName :: Text } deriving (Show, Data, Typeable, Generic) @@ -52,7 +51,7 @@ data Book a = Book - { bookSequence :: Word64 + { bookSequence :: Sequence , bookBids :: [Bid a] , bookAsks :: [Ask a] } @@ -113,14 +112,14 @@ instance NFData Trade instance ToJSON Trade where - toJSON Trade{..} = object [ "time" .= CoinbaseTime tradeTime + toJSON Trade{..} = object [ "time" .= tradeTime , "trade_id" .= tradeTradeId , "price" .= tradePrice , "size" .= tradeSize , "side" .= tradeSide ] instance FromJSON Trade where - parseJSON (Object m) = Trade <$> liftM unCoinbaseTime (m .: "time") + parseJSON (Object m) = Trade <$> m .: "time" <*> m .: "trade_id" <*> m .: "price" <*> m .: "size" diff --git a/src/Coinbase/Exchange/Types/Private.hs b/src/Coinbase/Exchange/Types/Private.hs --- a/src/Coinbase/Exchange/Types/Private.hs +++ b/src/Coinbase/Exchange/Types/Private.hs @@ -37,7 +37,7 @@ , accAvailable :: CoinScientific , accCurrency :: CurrencyId } - deriving (Show, Data, Typeable, Generic) + deriving (Show, Eq, Data, Typeable, Generic) instance NFData Account instance ToJSON Account where @@ -64,7 +64,7 @@ instance NFData Entry instance ToJSON Entry where toJSON Entry{..} = object [ "id" .= entryId - , "created_at" .= CoinbaseTime entryCreatedAt + , "created_at" .= entryCreatedAt , "amount" .= entryAmount , "balance" .= entryBalance , "type" .= entryType @@ -73,7 +73,7 @@ instance FromJSON Entry where parseJSON (Object m) = Entry <$> m .: "id" - <*> liftM unCoinbaseTime (m .: "created_at") + <*> m .: "created_at" <*> m .: "amount" <*> m .: "balance" <*> m .: "type" @@ -138,7 +138,25 @@ parseJSON = genericParseJSON coinbaseAesonOptions -- Orders +data OrderContigency + = GoodTillCanceled + | ImmediateOrCancel + | FillOrKill + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic) +instance NFData OrderContigency +instance Hashable OrderContigency + +instance ToJSON OrderContigency where + toJSON GoodTillCanceled = String "GTC" + toJSON ImmediateOrCancel = String "IOC" + toJSON FillOrKill = String "FOK" +instance FromJSON OrderContigency where + parseJSON (String "GTC") = return GoodTillCanceled + parseJSON (String "IOC") = return ImmediateOrCancel + parseJSON (String "FOK") = return FillOrKill + parseJSON _ = mzero + data SelfTrade = DecrementAndCancel | CancelOldest @@ -161,22 +179,61 @@ parseJSON _ = mzero data NewOrder - = NewOrder - { noSize :: Size + = NewLimitOrder + { noProductId :: ProductId + , noSide :: Side + , noSelfTrade :: SelfTrade + , noClientOid :: Maybe ClientOrderId + --- , noPrice :: Price + , noSize :: Size + ,noTimeInForce:: OrderContigency + , noPostOnly :: Bool + } + | NewMarketOrder + { noProductId :: ProductId , noSide :: Side - , noProductId :: ProductId + , noSelfTrade :: SelfTrade , noClientOid :: Maybe ClientOrderId - , noSelfTrade :: Maybe SelfTrade + --- + , noSizeAndOrFunds :: Either Size (Maybe Size, Cost) } deriving (Show, Data, Typeable, Generic) instance NFData NewOrder instance ToJSON NewOrder where - toJSON = genericToJSON coinbaseAesonOptions -instance FromJSON NewOrder where - parseJSON = genericParseJSON coinbaseAesonOptions + toJSON NewLimitOrder{..} = object + ([ "type" .= ("limit" :: Text) + , "product_id" .= noProductId + , "side" .= noSide + , "stp" .= noSelfTrade + , "price" .= noPrice + , "size" .= noSize + , "time_in_force" .= noTimeInForce + , "post_only" .= noPostOnly + ] ++ clientID ) + where + clientID = case noClientOid of + Just cid -> [ "client_oid" .= cid ] + Nothing -> [] + toJSON NewMarketOrder{..} = object + ([ "type" .= ("market" :: Text) + , "product_id" .= noProductId + , "side" .= noSide + , "stp" .= noSelfTrade + ] ++ clientID ++ size ++ funds ) + where + clientID = case noClientOid of + Just cid -> [ "client_oid" .= cid ] + Nothing -> [] + (size,funds) = case noSizeAndOrFunds of + Left s -> (["size" .= s],[]) + Right (ms,f) -> case ms of + Nothing -> ( [] , ["funds" .= f] ) + Just s' -> ( ["size" .= s'], ["funds" .= f] ) + + data OrderConfirmation = OrderConfirmation { ocId :: OrderId @@ -190,52 +247,127 @@ parseJSON = genericParseJSON coinbaseAesonOptions data Order - = Order + = LimitOrder { orderId :: OrderId - , orderSize :: Size - , orderPrice :: Price , orderProductId :: ProductId , orderStatus :: OrderStatus + , orderSelfTrade :: SelfTrade + , orderSettled :: Bool + , orderSide :: Side + , orderCreatedAt :: UTCTime , orderFilledSize :: Maybe Size , orderFilledFees :: Maybe Price + , orderDoneAt :: Maybe UTCTime + , orderDoneReason :: Maybe Reason + + , orderPrice :: Price + , orderSize :: Size + , orderTimeInForce:: OrderContigency + , orderPostOnly :: Bool + } + | MarketOrder + { orderId :: OrderId + , orderProductId :: ProductId + , orderStatus :: OrderStatus + , orderSelfTrade :: SelfTrade , orderSettled :: Bool , orderSide :: Side , orderCreatedAt :: UTCTime + , orderFilledSize :: Maybe Size + , orderFilledFees :: Maybe Price , orderDoneAt :: Maybe UTCTime , orderDoneReason :: Maybe Reason + + , orderSizeAndOrFunds :: Either Size (Maybe Size, Cost) } deriving (Show, Data, Typeable, Generic) instance NFData Order instance ToJSON Order where - toJSON Order{..} = object - [ "id" .= orderId - , "size" .= orderSize - , "price" .= orderPrice - , "product_id" .= orderProductId - , "status" .= orderStatus - , "filled_size" .= orderFilledSize - , "filled_fees" .= orderFilledFees - , "settled" .= orderSettled - , "side" .= orderSide - , "created_at" .= CoinbaseTime orderCreatedAt - , "done_at" .= liftM CoinbaseTime orderDoneAt - , "done_reason" .= orderDoneReason + toJSON LimitOrder{..} = object + [ "type" .= ("limit" :: Text) + , "id" .= orderId + , "product_id" .= orderProductId + , "status" .= orderStatus + , "stp" .= orderSelfTrade + , "settled" .= orderSettled + , "side" .= orderSide + , "created_at" .= orderCreatedAt + , "filled_size" .= orderFilledSize + , "filled_fees" .= orderFilledFees + , "done_at" .= orderDoneAt + , "done_reason" .= orderDoneReason + + , "price" .= orderPrice + , "size" .= orderSize + , "time_in_force" .= orderTimeInForce + , "post_only" .= orderPostOnly ] + toJSON MarketOrder{..} = object + ([ "type" .= ("market" :: Text) + , "id" .= orderId + , "product_id" .= orderProductId + , "status" .= orderStatus + , "stp" .= orderSelfTrade + , "settled" .= orderSettled + , "side" .= orderSide + , "created_at" .= orderCreatedAt + , "filled_size" .= orderFilledSize + , "filled_fees" .= orderFilledFees + , "done_at" .= orderDoneAt + , "done_reason" .= orderDoneReason + ] ++ size ++ funds ) + where (size,funds) = case orderSizeAndOrFunds of + Left s -> (["size" .= s],[]) + Right (ms,f) -> case ms of + Nothing -> ( [] , ["funds" .= f] ) + Just s' -> ( ["size" .= s'], ["funds" .= f] ) + + instance FromJSON Order where - parseJSON (Object m) = Order - <$> m .: "id" - <*> m .: "size" - <*> m .: "price" - <*> m .: "product_id" - <*> m .: "status" - <*> m .:? "filled_size" - <*> m .:? "filled_fees" - <*> m .: "settled" - <*> m .: "side" - <*> liftM unCoinbaseTime (m .: "created_at") - <*> liftM (liftM unCoinbaseTime) (m .:? "done_at") - <*> m .:? "done_reason" + parseJSON (Object m) = do + ordertype <- m .: "type" + case (ordertype :: String) of + "limit" -> LimitOrder + <$> m .: "id" + <*> m .: "product_id" + <*> m .: "status" + <*> m .: "stp" + <*> m .: "settled" + <*> m .: "side" + <*> m .: "created_at" + <*> m .:? "filled_size" + <*> m .:? "filled_fees" + <*> m .:? "done_at" + <*> m .:? "done_reason" + <*> m .: "price" + <*> m .: "size" + <*> m .:? "time_in_force" .!= GoodTillCanceled -- older orders don't seem to have this field + <*> m .: "post_only" + + "market" -> MarketOrder + <$> m .: "id" + <*> m .: "product_id" + <*> m .: "status" + <*> m .: "stp" + <*> m .: "settled" + <*> m .: "side" + <*> m .: "created_at" + <*> m .:? "filled_size" + <*> m .:? "filled_fees" + <*> m .:? "done_at" + <*> m .:? "done_reason" + <*> (do + ms <- m .:? "size" + mf <- m .:? "funds" + case (ms,mf) of + (Nothing, Nothing) -> mzero + (Just s , Nothing) -> return $ Left s + (Nothing, Just f ) -> return $ Right (Nothing, f) + (Just s , Just f ) -> return $ Right (Just s , f) + ) + _ -> mzero + parseJSON _ = mzero -- Fills @@ -278,7 +410,7 @@ , "price" .= fillPrice , "size" .= fillSize , "order_id" .= fillOrderId - , "created_at" .= CoinbaseTime fillCreatedAt + , "created_at" .= fillCreatedAt , "liquidity" .= fillLiquidity , "fee" .= fillFee , "settled" .= fillSettled @@ -291,7 +423,7 @@ <*> m .: "price" <*> m .: "size" <*> m .: "order_id" - <*> liftM unCoinbaseTime (m .: "created_at") + <*> m .: "created_at" <*> m .: "liquidity" <*> m .: "fee" <*> m .: "settled" diff --git a/src/Coinbase/Exchange/Types/Socket.hs b/src/Coinbase/Exchange/Types/Socket.hs --- a/src/Coinbase/Exchange/Types/Socket.hs +++ b/src/Coinbase/Exchange/Types/Socket.hs @@ -2,75 +2,108 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + module Coinbase.Exchange.Types.Socket where import Control.DeepSeq -import Data.Aeson.Types +import Control.Monad +import Data.Aeson.Types hiding (Error) import Data.Data import Data.Hashable import Data.Text (Text) import Data.Time import Data.Word import GHC.Generics - -import Coinbase.Exchange.Types.Core +import qualified Data.HashMap.Strict as H -newtype Sequence = Sequence { unSequence :: Word64 } - deriving (Eq, Ord, Num, Show, Read, Data, Typeable, Generic, NFData, Hashable, FromJSON, ToJSON) +import Coinbase.Exchange.Types.Core hiding (OrderStatus(..)) data ExchangeMessage = Subscribe { msgProductId :: ProductId } - | Received + | ReceivedLimit { msgTime :: UTCTime , msgProductId :: ProductId , msgSequence :: Sequence , msgOrderId :: OrderId - , msgSize :: Size + , msgSide :: Side + , msgClientOid :: Maybe ClientOrderId + -- , msgPrice :: Price + , msgSize :: Size + } + | ReceivedMarket + { msgTime :: UTCTime + , msgProductId :: ProductId + , msgSequence :: Sequence + , msgOrderId :: OrderId , msgSide :: Side , msgClientOid :: Maybe ClientOrderId + -- market orders have no price and are bounded by either size, funds or both + , msgMarketBounds :: (Either Size (Maybe Size, Cost)) } | Open { msgTime :: UTCTime , msgProductId :: ProductId , msgSequence :: Sequence , msgOrderId :: OrderId - , msgPrice :: Price - , msgRemainingSize :: Size , msgSide :: Side - } - | Done - { msgTime :: UTCTime - , msgProductId :: ProductId - , msgSequence :: Sequence - , msgPrice :: Price - , msgOrderId :: OrderId - , msgReason :: Reason - , msgSide :: Side + , msgRemainingSize :: Size + , msgPrice :: Price } | Match - { msgTradeId :: TradeId + { msgTime :: UTCTime + , msgProductId :: ProductId , msgSequence :: Sequence + , msgSide :: Side + , msgTradeId :: TradeId , msgMakerOrderId :: OrderId , msgTakerOrderId :: OrderId - , msgTime :: UTCTime - , msgProductId :: ProductId , msgSize :: Size , msgPrice :: Price - , msgSide :: Side } - | Change + | DoneLimit { msgTime :: UTCTime + , msgProductId :: ProductId , msgSequence :: Sequence , msgOrderId :: OrderId + , msgSide :: Side + , msgRemainingSize :: Size + , msgPrice :: Price + , msgReason :: Reason + , msgOrderType :: OrderType + } + | DoneMarket + { msgTime :: UTCTime , msgProductId :: ProductId + , msgSequence :: Sequence + , msgOrderId :: OrderId + , msgSide :: Side + , msgReason :: Reason + , msgOrderType :: OrderType + } + | ChangeLimit + { msgTime :: UTCTime + , msgProductId :: ProductId + , msgSequence :: Sequence + , msgOrderId :: OrderId + , msgSide :: Side + , msgPrice :: Price , msgNewSize :: Size , msgOldSize :: Size - , msgPrice :: Price + } + | ChangeMarket + { msgTime :: UTCTime + , msgProductId :: ProductId + , msgSequence :: Sequence + , msgOrderId :: OrderId , msgSide :: Side + , msgPrice :: Price + , msgNewFunds :: Cost + , msgOldFunds :: Cost } | Error { msgMessage :: Text @@ -78,7 +111,225 @@ deriving (Eq, Show, Read, Data, Typeable, Generic) instance NFData ExchangeMessage -instance ToJSON ExchangeMessage where - toJSON = genericToJSON coinbaseAesonOptions + +----------------------------- instance FromJSON ExchangeMessage where - parseJSON = genericParseJSON coinbaseAesonOptions + parseJSON (Object m) = do + msgtype <- m .: "type" + case (msgtype :: String) of + "open" -> Open + <$> m .: "time" + <*> m .: "product_id" + <*> m .: "sequence" + <*> m .: "order_id" + <*> m .: "side" + <*> m .: "remaining_size" + <*> m .: "price" + "done" -> do + typ <- m .: "order_type" + case typ of + Limit -> DoneLimit + <$> m .: "time" + <*> m .: "product_id" + <*> m .: "sequence" + <*> m .: "order_id" + <*> m .: "side" + <*> m .: "remaining_size" + <*> m .: "price" + <*> m .: "reason" + <*> m .: "order_type" + Market -> DoneMarket + <$> m .: "time" + <*> m .: "product_id" + <*> m .: "sequence" + <*> m .: "order_id" + <*> m .: "side" + <*> m .: "reason" + <*> m .: "order_type" + "match" -> Match + <$> m .: "time" + <*> m .: "product_id" + <*> m .: "sequence" + <*> m .: "side" + <*> m .: "trade_id" + <*> m .: "maker_order_id" + <*> m .: "taker_order_id" + <*> m .: "size" + <*> m .: "price" + "change" -> do + ms <- m .:? "new_size" + case (ms :: Maybe Size) of + Nothing -> ChangeMarket + <$> m .: "time" + <*> m .: "product_id" + <*> m .: "sequence" + <*> m .: "order_id" + <*> m .: "side" + <*> m .: "price" + <*> m .: "new_funds" + <*> m .: "old_funds" + Just _ -> ChangeLimit + <$> m .: "time" + <*> m .: "product_id" + <*> m .: "sequence" + <*> m .: "order_id" + <*> m .: "side" + <*> m .: "price" + <*> m .: "new_size" + <*> m .: "old_size" + "received" -> do + typ <- m .: "order_type" + mcid <- m .:? "client_id" + case typ of + Limit -> ReceivedLimit + <$> m .: "time" + <*> m .: "product_id" + <*> m .: "sequence" + <*> m .: "order_id" + <*> m .: "side" + <*> pure (mcid :: Maybe ClientOrderId) + <*> m .: "price" + <*> m .: "size" + Market -> ReceivedMarket + <$> m .: "time" + <*> m .: "product_id" + <*> m .: "sequence" + <*> m .: "order_id" + <*> m .: "side" + <*> pure mcid + <*> (do + -- I can't try to parse "size" or "funds" with (.:?) here, their type is CoinScientific + -- but the fields may be "size":null and that will fail the (m .:? "size") parser. + ms <- m .:?? "size" + mf <- m .:?? "funds" + case (ms,mf) of + (Nothing, Nothing) -> mzero + (Just s , Nothing) -> return $ Left s + (Nothing, Just f ) -> return $ Right (Nothing, f) + (Just s , Just f ) -> return $ Right (Just s , f) + ) + + parseJSON _ = mzero + +--------------------------- +-- This is based on the code for Aeson's (.:?) operator. Except, we're more +-- lax than (.:?) and also return 'Nothing' when the field is (JSON) null. +(.:??) :: (FromJSON a) => Object -> Text -> Parser (Maybe a) +obj .:?? key = case H.lookup key obj of + Nothing -> pure Nothing + Just v -> if v == Null + then pure Nothing + else obj .:? key + +--------------------------- + +instance ToJSON ExchangeMessage where + toJSON Subscribe{..} = object + [ "type" .= ("subscribe" :: Text) + , "product_id" .= msgProductId + ] + toJSON Open{..} = object + [ "type" .= ("open" :: Text) + , "time" .= msgTime + , "product_id" .= msgProductId + , "sequence" .= msgSequence + , "order_id" .= msgOrderId + , "side" .= msgSide + , "remaining_size" .= msgRemainingSize + , "price" .= msgPrice + ] + toJSON DoneLimit{..} = object + [ "type" .= ("done" :: Text) + , "time" .= msgTime + , "product_id" .= msgProductId + , "sequence" .= msgSequence + , "order_id" .= msgOrderId + , "side" .= msgSide + , "remaining_size" .= msgRemainingSize + , "price" .= msgPrice + , "reason" .= msgReason + , "order_type" .= Limit + ] + toJSON DoneMarket{..} = object + [ "type" .= ("done" :: Text) + , "time" .= msgTime + , "product_id" .= msgProductId + , "sequence" .= msgSequence + , "order_id" .= msgOrderId + , "side" .= msgSide + , "reason" .= msgReason + , "order_type" .= Market + ] + toJSON Match{..} = object + [ "type" .= ("match" :: Text) + , "time" .= msgTime + , "product_id" .= msgProductId + , "sequence" .= msgSequence + , "side" .= msgSide + , "trade_id" .= msgTradeId + , "maker_order_id" .= msgMakerOrderId + , "taker_order_id" .= msgTakerOrderId + , "size" .= msgSize + , "price" .= msgPrice + ] + toJSON Error{..} = object + [ "type" .= ("error" :: Text) + , "message" .= msgMessage + ] + toJSON ChangeLimit{..} = object + [ "type" .= ("change" :: Text) + , "time" .= msgTime + , "product_id" .= msgProductId + , "sequence" .= msgSequence + , "order_id" .= msgOrderId + , "side" .= msgSide + , "new_size" .= msgNewSize + , "old_size" .= msgOldSize + , "price" .= msgPrice + ] + toJSON ChangeMarket{..} = object + [ "type" .= ("change" :: Text) + , "time" .= msgTime + , "product_id" .= msgProductId + , "sequence" .= msgSequence + , "order_id" .= msgOrderId + , "side" .= msgSide + , "price" .= msgPrice + , "new_funds" .= msgNewFunds + , "old_funds" .= msgOldFunds + ] + + toJSON ReceivedLimit{..} = object ( + [ "type" .= ("received" :: Text) + , "time" .= msgTime + , "product_id" .= msgProductId + , "sequence" .= msgSequence + , "order_id" .= msgOrderId + , "side" .= msgSide + , "size" .= msgSize + , "price" .= msgPrice + , "order_type" .= Limit + ] ++ clientID) + where + clientID = case msgClientOid of + Nothing -> [] + Just ci -> ["client_id" .= msgClientOid ] + + toJSON ReceivedMarket{..} = object ( + ["type" .= ("received" :: Text) + , "time" .= msgTime + , "product_id" .= msgProductId + , "sequence" .= msgSequence + , "order_id" .= msgOrderId + , "side" .= msgSide + , "order_type" .= Market + ] ++ clientID ++ size ++ funds) + where + clientID = case msgClientOid of + Nothing -> [] + Just ci -> ["client_id" .= msgClientOid ] + (size,funds) = case msgMarketBounds of + Left s -> (["size" .= s],[]) + Right (ms,f) -> case ms of + Nothing -> ( [] , ["funds" .= f] ) + Just s' -> ( ["size" .= s'], ["funds" .= f] ) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -11,6 +11,8 @@ import qualified Coinbase.Exchange.MarketData.Test as MarketData import qualified Coinbase.Exchange.Private.Test as Private +import qualified Coinbase.Exchange.Socket.Test as Socket + main :: IO () main = do mgr <- newManager tlsManagerSettings @@ -19,11 +21,12 @@ tPass <- liftM CBS.pack $ getEnv "COINBASE_PASSPHRASE" case mkToken tKey tSecret tPass of - Right tok -> defaultMain (tests $ ExchangeConf mgr (Just tok) Sandbox) + Right tok -> defaultMain (tests $ ExchangeConf mgr (Just tok) Live) Left er -> error $ show er tests :: ExchangeConf -> TestTree tests conf = testGroup "Tests" [ MarketData.tests conf - , Private.tests conf + , Private.tests conf + , Socket.tests conf ]