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.3.0.0 +version: 0.4.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 @@ -28,20 +28,20 @@ other-modules: Coinbase.Exchange.Rest - build-depends: base ==4.* - , mtl >=2.2 + build-depends: base >= 4 && < 5 + , mtl , resourcet , transformers-base , conduit , conduit-extra , http-conduit - , aeson >=0.10.0 + , aeson , aeson-casing , http-types , text , bytestring , base64-bytestring - , time >=1.5 + , time , scientific , uuid , uuid-aeson @@ -63,13 +63,13 @@ hs-source-dirs: sbox default-language: Haskell2010 - build-depends: base ==4.* + build-depends: base >= 4 && < 5 , http-client , http-client-tls , uuid , text - , aeson >=0.10.0 + , aeson , bytestring , time , old-locale @@ -93,7 +93,11 @@ ghc-options: -threaded default-language: Haskell2010 - build-depends: base ==4.* + other-modules: Coinbase.Exchange.MarketData.Test + Coinbase.Exchange.Private.Test + Coinbase.Exchange.Socket.Test + + build-depends: base >= 4 && < 5 , tasty , tasty-th , tasty-quickcheck @@ -110,7 +114,7 @@ , scientific , async , websockets - , aeson >=0.10.0 + , aeson , unordered-containers , coinbase-exchange diff --git a/sbox/Main.hs b/sbox/Main.hs --- a/sbox/Main.hs +++ b/sbox/Main.hs @@ -38,19 +38,25 @@ withCoinbase :: Exchange a -> IO a withCoinbase act = do mgr <- newManager tlsManagerSettings - tKey <- liftM CBS.pack $ getEnv "COINBASE_KEY" - tSecret <- liftM CBS.pack $ getEnv "COINBASE_SECRET" - tPass <- liftM CBS.pack $ getEnv "COINBASE_PASSPHRASE" + tKey <- liftM CBS.pack $ getEnv "GDAX_KEY" + tSecret <- liftM CBS.pack $ getEnv "GDAX_SECRET" + tPass <- liftM CBS.pack $ getEnv "GDAX_PASSPHRASE" + sbox <- getEnv "GDAX_SANDBOX" + let apiType = case sbox of + "FALSE" -> Live + "TRUE" -> Sandbox + _ -> error "Coinbase sandbox option must be either: TRUE or FALSE (all caps)" + case mkToken tKey tSecret tPass of - Right tok -> do res <- runExchange (ExchangeConf mgr (Just tok) Live) act + Right tok -> do res <- runExchange (ExchangeConf mgr (Just tok) apiType) act case res of Right s -> return s Left f -> error $ show f Left er -> error $ show er printSocket :: IO () -printSocket = subscribe Live btc $ \conn -> do +printSocket = subscribe Live [btc] $ \conn -> do putStrLn "Connected." _ <- forkIO $ forever $ do ds <- WS.receiveData conn diff --git a/src/Coinbase/Exchange/Private.hs b/src/Coinbase/Exchange/Private.hs --- a/src/Coinbase/Exchange/Private.hs +++ b/src/Coinbase/Exchange/Private.hs @@ -10,13 +10,18 @@ , createOrder , cancelOrder + , cancelAllOrders , getOrderList , getOrder , getFills , createTransfer + , createCryptoWithdrawal + , createReport + , getReportStatus + , module Coinbase.Exchange.Types.Private ) where @@ -59,12 +64,18 @@ cancelOrder :: (MonadResource m, MonadReader ExchangeConf m, MonadError ExchangeFailure m) => OrderId -> m () -cancelOrder (OrderId o) = coinbaseDelete True ("/orders/" ++ toString o) voidBody +cancelOrder (OrderId o) = coinbaseDeleteDiscardBody True ("/orders/" ++ toString o) voidBody +cancelAllOrders :: (MonadResource m, MonadReader ExchangeConf m, MonadError ExchangeFailure m) + => Maybe ProductId -> m [OrderId] +cancelAllOrders prodId = coinbaseDelete True ("/orders" ++ opt prodId) voidBody + where opt Nothing = "" + opt (Just id) = "?product_id=" ++ T.unpack (unProductId id) + getOrderList :: (MonadResource m, MonadReader ExchangeConf m, MonadError ExchangeFailure m) => [OrderStatus] -> m [Order] getOrderList os = coinbaseGet True ("/orders?" ++ query os) voidBody - where query [] = "status=all" + where query [] = "status=open&status=pending&status=active" query xs = intercalate "&" $ map (\x -> "status=" ++ map toLower (show x)) xs getOrder :: (MonadResource m, MonadReader ExchangeConf m, MonadError ExchangeFailure m) @@ -84,5 +95,21 @@ -- Transfers createTransfer :: (MonadResource m, MonadReader ExchangeConf m, MonadError ExchangeFailure m) - => Transfer -> m () + => TransferToCoinbase -> m TransferToCoinbaseResponse createTransfer = coinbasePost True "/transfers" . Just + +createCryptoWithdrawal + :: (MonadResource m, MonadReader ExchangeConf m, MonadError ExchangeFailure m) + => CryptoWithdrawal + -> m CryptoWithdrawalResp +createCryptoWithdrawal = coinbasePost True "/withdrawals/crypto" . Just + +-- Reports + +createReport :: (MonadResource m, MonadReader ExchangeConf m, MonadError ExchangeFailure m) + => ReportRequest -> m ReportInfo +createReport = coinbasePost True "/reports" . Just + +getReportStatus :: (MonadResource m, MonadReader ExchangeConf m, MonadError ExchangeFailure m) + => ReportId -> m ReportInfo +getReportStatus (ReportId r) = coinbaseGet True ("/reports/" ++ toString r) voidBody 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 @@ -6,6 +6,7 @@ ( coinbaseGet , coinbasePost , coinbaseDelete + , coinbaseDeleteDiscardBody , voidBody ) where @@ -32,9 +33,10 @@ import Coinbase.Exchange.Types --- import Debug.Trace +import Debug.Trace type Signed = Bool +type IsForExchange = Bool voidBody :: Maybe () voidBody = Nothing @@ -45,7 +47,7 @@ , MonadReader ExchangeConf m , MonadError ExchangeFailure m ) => Signed -> Path -> Maybe a -> m b -coinbaseGet sgn p ma = coinbaseRequest "GET" sgn p ma >>= processResponse +coinbaseGet sgn p ma = coinbaseRequest "GET" sgn p ma >>= processResponse True coinbasePost :: ( ToJSON a , FromJSON b @@ -53,15 +55,23 @@ , MonadReader ExchangeConf m , MonadError ExchangeFailure m ) => Signed -> Path -> Maybe a -> m b -coinbasePost sgn p ma = coinbaseRequest "POST" sgn p ma >>= processResponse +coinbasePost sgn p ma = coinbaseRequest "POST" sgn p ma >>= processResponse True coinbaseDelete :: ( ToJSON a + , FromJSON b , MonadResource m , MonadReader ExchangeConf m , MonadError ExchangeFailure m ) - => Signed -> Path -> Maybe a -> m () -coinbaseDelete sgn p ma = coinbaseRequest "DELETE" sgn p ma >>= processEmpty + => Signed -> Path -> Maybe a -> m b +coinbaseDelete sgn p ma = coinbaseRequest "DELETE" sgn p ma >>= processResponse True +coinbaseDeleteDiscardBody :: ( ToJSON a + , MonadResource m + , MonadReader ExchangeConf m + , MonadError ExchangeFailure m ) + => Signed -> Path -> Maybe a -> m () +coinbaseDeleteDiscardBody sgn p ma = coinbaseRequest "DELETE" sgn p ma >>= processEmpty + coinbaseRequest :: ( ToJSON a , MonadResource m , MonadReader ExchangeConf m @@ -70,17 +80,37 @@ coinbaseRequest meth sgn p ma = do conf <- ask req <- case apiType conf of - Sandbox -> parseUrl $ sandboxRest ++ p - Live -> parseUrl $ liveRest ++ p + Sandbox -> parseUrlThrow $ sandboxRest ++ p + Live -> parseUrlThrow $ liveRest ++ p let req' = req { method = meth , requestHeaders = [ ("user-agent", "haskell") , ("accept", "application/json") ] } - flip http (manager conf) =<< signMessage sgn meth p + flip http (manager conf) =<< signMessage True sgn meth p =<< encodeBody ma req' +realCoinbaseRequest :: ( ToJSON a + , MonadResource m + , MonadReader ExchangeConf m + , MonadError ExchangeFailure m ) + => Method -> Signed -> Path -> Maybe a -> m (Response (ResumableSource m BS.ByteString)) +realCoinbaseRequest meth sgn p ma = do + conf <- ask + req <- case apiType conf of + Sandbox -> parseUrlThrow $ sandboxRealCoinbaseRest ++ p + Live -> parseUrlThrow $ liveRealCoinbaseRest ++ p + let req' = req { method = meth + , requestHeaders = [ ("user-agent", "haskell") + , ("accept", "application/json") + , ("content-type", "application/json") + ] + } + + flip http (manager conf) =<< signMessage False sgn meth p + =<< encodeBody ma req' + encodeBody :: (ToJSON a, Monad m) => Maybe a -> Request -> m Request encodeBody (Just a) req = return req @@ -91,29 +121,33 @@ encodeBody Nothing req = return req signMessage :: (MonadIO m, MonadReader ExchangeConf m, MonadError ExchangeFailure m) - => Signed -> Method -> Path -> Request -> m Request -signMessage True meth p req = do + => IsForExchange -> Signed -> Method -> Path -> Request -> m Request +signMessage isForExchange True meth p req = do conf <- ask case authToken conf of Just tok -> do time <- liftM (realToFrac . utcTimeToPOSIXSeconds) (liftIO getCurrentTime) >>= \t -> return . CBS.pack $ printf "%.0f" (t::Double) rBody <- pullBody $ requestBody req let presign = CBS.concat [time, meth, CBS.pack p, rBody] - sign = toBytes (hmac (secret tok) presign :: HMAC SHA256) + sign = if isForExchange + then Base64.encode $ toBytes (hmac (secret tok) presign :: HMAC SHA256) + else digestToHexByteString $ hmacGetDigest (hmac (Base64.encode $ secret tok) presign :: HMAC SHA256) + return req { requestBody = RequestBodyBS rBody , requestHeaders = requestHeaders req ++ [ ("cb-access-key", key tok) - , ("cb-access-sign", Base64.encode sign) + , ("cb-access-sign", sign ) , ("cb-access-timestamp", time) - , ("cb-access-passphrase", passphrase tok) - ] + ] ++ if isForExchange + then [("cb-access-passphrase", passphrase tok)] + else [("cb-version", "2016-05-11")] } Nothing -> throwError $ AuthenticationRequiredFailure $ T.pack p where pullBody (RequestBodyBS b) = return b pullBody (RequestBodyLBS b) = return $ LBS.toStrict b pullBody _ = throwError AuthenticationRequiresByteStrings -signMessage False _ _ req = return req +signMessage _ False _ _ req = return req -- @@ -121,15 +155,17 @@ , MonadResource m , MonadReader ExchangeConf m , MonadError ExchangeFailure m ) - => Response (ResumableSource m BS.ByteString) -> m b -processResponse res = + => IsForExchange -> Response (ResumableSource m BS.ByteString) -> m b +processResponse isForExchange res = case responseStatus res of - 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 - | otherwise -> do body <- responseBody res $$+- CB.sinkLbs - throwError $ ApiFailure $ T.decodeUtf8 $ LBS.toStrict body + s | s == status200 || (s == created201 && not isForExchange) -> + do body <- responseBody res $$+- sinkParser (fmap (\x -> {-trace (show x)-} fromJSON x) json) + case body of + Success b -> return b + Error er -> throwError $ ParseFailure $ T.pack er + + | otherwise -> do body <- responseBody res $$+- CB.sinkLbs + throwError $ ApiFailure $ T.decodeUtf8 $ LBS.toStrict body processEmpty :: ( MonadResource m , MonadReader ExchangeConf m 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 @@ -5,19 +5,29 @@ , module Coinbase.Exchange.Types.Socket ) where +------------------------------------------------------------------------------- import Data.Aeson import Network.Socket import qualified Network.WebSockets as WS import Wuss - +------------------------------------------------------------------------------- import Coinbase.Exchange.Types import Coinbase.Exchange.Types.Core import Coinbase.Exchange.Types.Socket +------------------------------------------------------------------------------- -subscribe :: ApiType -> ProductId -> WS.ClientApp a -> IO a -subscribe atype pid app = withSocketsDo $ + +------------------------------------------------------------------------------- +subscribe :: ApiType -> [ProductId] -> WS.ClientApp a -> IO a +subscribe atype pids app = withSocketsDo $ runSecureClient location 443 "/" $ \conn -> do - WS.sendBinaryData conn $ encode (Subscribe pid) + WS.sendTextData conn $ encode (Subscribe pids) app conn where location = case atype of Sandbox -> sandboxSocket Live -> liveSocket + + +------------------------------------------------------------------------------- +-- | Enable/disable heartbeat anytime you want in your 'ClientApp' +setHeartbeat :: Bool -> WS.ClientApp () +setHeartbeat b conn = WS.sendTextData conn (encode $ SetHeartbeat b) diff --git a/src/Coinbase/Exchange/Types.hs b/src/Coinbase/Exchange/Types.hs --- a/src/Coinbase/Exchange/Types.hs +++ b/src/Coinbase/Exchange/Types.hs @@ -17,6 +17,8 @@ , sandboxSocket , liveRest , liveSocket + , liveRealCoinbaseRest + , sandboxRealCoinbaseRest , Key , Secret @@ -32,6 +34,7 @@ , ExchangeFailure (..) , Exchange + , ExchangeT , ExceptT , runExchange , runExchangeT @@ -65,19 +68,27 @@ type Path = String website :: Endpoint -website = "https://public.sandbox.exchange.coinbase.com" +website = "https://public.sandbox.gdax.com" sandboxRest :: Endpoint -sandboxRest = "https://api-public.sandbox.exchange.coinbase.com" +sandboxRest = "https://api-public.sandbox.gdax.com" sandboxSocket :: Endpoint -sandboxSocket = "ws-feed-public.sandbox.exchange.coinbase.com" +sandboxSocket = "ws-feed-public.sandbox.gdax.com" liveRest :: Endpoint -liveRest = "https://api.exchange.coinbase.com" +liveRest = "https://api.gdax.com" liveSocket :: Endpoint -liveSocket = "ws-feed.exchange.coinbase.com" +liveSocket = "ws-feed.gdax.com" + +-- Coinbase needs to provide real BTC transfers through the exchange API soon, +-- making 2 API calls with 2 sets of authentication credentials is ridiculous. +liveRealCoinbaseRest :: Endpoint +liveRealCoinbaseRest = "https://api.coinbase.com" + +sandboxRealCoinbaseRest :: Endpoint +sandboxRealCoinbaseRest = "https://api.sandbox.coinbase.com" -- Monad Stack 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 @@ -30,13 +30,25 @@ deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, IsString, NFData, Hashable, FromJSON, ToJSON) newtype Price = Price { unPrice :: CoinScientific } - deriving (Eq, Ord, Num, Fractional, Real, RealFrac, Show, Read, Data, Typeable, Generic, NFData, Hashable, FromJSON, ToJSON) + deriving (Eq, Ord, Num, Fractional, Real, RealFrac, Read, Data, Typeable, Generic, NFData, Hashable, FromJSON) +instance ToJSON Price where + toJSON (Price (CoinScientific v)) = String . T.pack . formatScientific Fixed Nothing $ v +instance Show Price where + show (Price (CoinScientific v)) = formatScientific Fixed Nothing v newtype Size = Size { unSize :: CoinScientific } - deriving (Eq, Ord, Num, Fractional, Real, RealFrac, Show, Read, Data, Typeable, Generic, NFData, Hashable, FromJSON, ToJSON) + deriving (Eq, Ord, Num, Fractional, Real, RealFrac, Read, Data, Typeable, Generic, NFData, Hashable, FromJSON) +instance ToJSON Size where + toJSON (Size (CoinScientific v)) = String . T.pack . formatScientific Fixed Nothing $ v +instance Show Size where + show (Size (CoinScientific v)) = formatScientific Fixed Nothing v newtype Cost = Cost { unCost :: CoinScientific } - deriving (Eq, Ord, Num, Fractional, Real, RealFrac, Show, Read, Data, Typeable, Generic, NFData, Hashable, FromJSON, ToJSON) + deriving (Eq, Ord, Num, Fractional, Real, RealFrac, Read, Data, Typeable, Generic, NFData, Hashable, FromJSON) +instance ToJSON Cost where + toJSON (Cost (CoinScientific v)) = String . T.pack . formatScientific Fixed Nothing $ v +instance Show Cost where + show (Cost (CoinScientific v)) = formatScientific Fixed Nothing v newtype OrderId = OrderId { unOrderId :: UUID } deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, NFData, Hashable, FromJSON, ToJSON) @@ -45,7 +57,7 @@ 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) + deriving (Eq, Ord, Num, Enum, Show, Read, Data, Typeable, Generic, NFData, Hashable, FromJSON, ToJSON) -- @@ -80,7 +92,7 @@ instance FromJSON TradeId where parseJSON (String t) = pure $ TradeId $ read $ T.unpack t parseJSON (Number n) = pure $ TradeId $ floor n - parseJSON _ = mzero + parseJSON _ = mzero -- @@ -94,6 +106,7 @@ | Settled | Open | Pending + | Active deriving (Eq, Show, Read, Data, Typeable, Generic) instance NFData OrderStatus @@ -125,8 +138,9 @@ newtype CoinScientific = CoinScientific { unCoinScientific :: Scientific } deriving (Eq, Ord, Num, Fractional, Real, RealFrac, Show, Read, Data, Typeable, NFData, Hashable) +-- Shows 8 decimal places (needs to be adapted for prices and costs in USD) instance ToJSON CoinScientific where - toJSON (CoinScientific v) = String . T.pack . show $ v + toJSON (CoinScientific v) = String . T.pack . formatScientific Fixed (Just 8) $ v instance FromJSON CoinScientific where parseJSON = withText "CoinScientific" $ \t -> case readMaybe (T.unpack t) of 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 @@ -52,8 +52,8 @@ data Book a = Book { bookSequence :: Sequence - , bookBids :: [Bid a] - , bookAsks :: [Ask a] + , bookBids :: [BookItem a] + , bookAsks :: [BookItem a] } deriving (Show, Data, Typeable, Generic) @@ -63,22 +63,13 @@ instance (FromJSON a) => FromJSON (Book a) where parseJSON = genericParseJSON coinbaseAesonOptions -data Ask a = Ask Price Size a - deriving (Eq, Ord, Show, Read, Data, Typeable, Generic) - -instance (NFData a) => NFData (Ask a) -instance (ToJSON a) => ToJSON (Ask a) where - toJSON = genericToJSON defaultOptions -instance (FromJSON a) => FromJSON (Ask a) where - parseJSON = genericParseJSON defaultOptions - -data Bid a = Bid Price Size a +data BookItem a = BookItem Price Size a deriving (Eq, Ord, Show, Read, Data, Typeable, Generic) -instance (NFData a) => NFData (Bid a) -instance (ToJSON a) => ToJSON (Bid a) where +instance (NFData a) => NFData (BookItem a) +instance (ToJSON a) => ToJSON (BookItem a) where toJSON = genericToJSON defaultOptions -instance (FromJSON a) => FromJSON (Bid a) where +instance (FromJSON a) => FromJSON (BookItem a) where parseJSON = genericParseJSON defaultOptions -- Product Ticker 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 @@ -140,6 +140,7 @@ -- Orders data OrderContigency = GoodTillCanceled + | GoodTillTime | ImmediateOrCancel | FillOrKill deriving (Eq, Ord, Show, Read, Data, Typeable, Generic) @@ -149,14 +150,35 @@ instance ToJSON OrderContigency where toJSON GoodTillCanceled = String "GTC" + toJSON GoodTillTime = String "GTT" toJSON ImmediateOrCancel = String "IOC" toJSON FillOrKill = String "FOK" instance FromJSON OrderContigency where parseJSON (String "GTC") = return GoodTillCanceled + parseJSON (String "GTT") = return GoodTillTime parseJSON (String "IOC") = return ImmediateOrCancel parseJSON (String "FOK") = return FillOrKill parseJSON _ = mzero +data OrderCancelAfter + = Min + | Hour + | Day + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic) + +instance NFData OrderCancelAfter +instance Hashable OrderCancelAfter + +instance ToJSON OrderCancelAfter where + toJSON Min = String "min" + toJSON Hour = String "hour" + toJSON Day = String "day" +instance FromJSON OrderCancelAfter where + parseJSON (String "min") = return Min + parseJSON (String "hour") = return Hour + parseJSON (String "day") = return Day + parseJSON _ = mzero + data SelfTrade = DecrementAndCancel | CancelOldest @@ -188,6 +210,7 @@ , noPrice :: Price , noSize :: Size ,noTimeInForce:: OrderContigency + ,noCancelAfter:: Maybe OrderCancelAfter , noPostOnly :: Bool } | NewMarketOrder @@ -198,6 +221,15 @@ --- , noSizeAndOrFunds :: Either Size (Maybe Size, Cost) } + | NewStopOrder + { noProductId :: ProductId + , noSide :: Side + , noSelfTrade :: SelfTrade + , noClientOid :: Maybe ClientOrderId + --- + , noPrice :: Price + , noSizeAndOrFunds :: Either Size (Maybe Size, Cost) + } deriving (Show, Data, Typeable, Generic) instance NFData NewOrder @@ -211,11 +243,14 @@ , "size" .= noSize , "time_in_force" .= noTimeInForce , "post_only" .= noPostOnly - ] ++ clientID ) + ] ++ clientID ++ cancelAfter ) where clientID = case noClientOid of Just cid -> [ "client_oid" .= cid ] Nothing -> [] + cancelAfter = case noCancelAfter of + Just time -> [ "cancel_after" .= time ] + Nothing -> [] toJSON NewMarketOrder{..} = object ([ "type" .= ("market" :: Text) @@ -233,7 +268,24 @@ Nothing -> ( [] , ["funds" .= f] ) Just s' -> ( ["size" .= s'], ["funds" .= f] ) + toJSON NewStopOrder{..} = object + ([ "type" .= ("stop" :: Text) + , "product_id" .= noProductId + , "side" .= noSide + , "stp" .= noSelfTrade + , "price" .= noPrice + ] ++ 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 @@ -263,6 +315,7 @@ , orderPrice :: Price , orderSize :: Size , orderTimeInForce:: OrderContigency + , orderCancelAfter:: Maybe OrderCancelAfter , orderPostOnly :: Bool } | MarketOrder @@ -280,6 +333,22 @@ , orderSizeAndOrFunds :: Either Size (Maybe Size, Cost) } + | StopOrder + { 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 + + , orderPrice :: Price + , orderSizeAndOrFunds :: Either Size (Maybe Size, Cost) + } deriving (Show, Data, Typeable, Generic) instance NFData Order @@ -301,6 +370,7 @@ , "price" .= orderPrice , "size" .= orderSize , "time_in_force" .= orderTimeInForce + , "cancel_after" .= orderCancelAfter , "post_only" .= orderPostOnly ] toJSON MarketOrder{..} = object @@ -322,8 +392,29 @@ Right (ms,f) -> case ms of Nothing -> ( [] , ["funds" .= f] ) Just s' -> ( ["size" .= s'], ["funds" .= f] ) + toJSON StopOrder{..} = 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 + , "price" .= orderPrice + ] ++ 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) = do ordertype <- m .: "type" @@ -343,6 +434,7 @@ <*> m .: "price" <*> m .: "size" <*> m .:? "time_in_force" .!= GoodTillCanceled -- older orders don't seem to have this field + <*> m .:? "cancel_after" <*> m .: "post_only" "market" -> MarketOrder @@ -366,6 +458,29 @@ (Nothing, Just f ) -> return $ Right (Nothing, f) (Just s , Just f ) -> return $ Right (Just s , f) ) + + "stop" -> StopOrder + <$> 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" + <*> (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 @@ -438,19 +553,269 @@ newtype CoinbaseAccountId = CoinbaseAccountId { unCoinbaseAccountId :: UUID } deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, NFData, FromJSON, ToJSON) -data Transfer +data TransferToCoinbase = Deposit - { transAmount :: Size - , transCoinbaseAccount :: CoinbaseAccountId + { trAmount :: Size + , trCoinbaseAccountId :: CoinbaseAccountId } | Withdraw - { transAmount :: Size - , transCoinbaseAccount :: CoinbaseAccountId + { trAmount :: Size + , trCoinbaseAccountId :: CoinbaseAccountId } deriving (Show, Data, Typeable, Generic) -instance NFData Transfer -instance ToJSON Transfer where +instance NFData TransferToCoinbase +instance ToJSON TransferToCoinbase where toJSON = genericToJSON coinbaseAesonOptions -instance FromJSON Transfer where + +data CryptoWithdrawal + = Withdrawal + { wdAmount :: Size + , wdCurrency :: CurrencyId + , wdCryptoAddress :: CryptoWallet + } + deriving (Show, Data, Typeable, Generic) + +instance NFData CryptoWithdrawal +instance ToJSON CryptoWithdrawal where + toJSON = genericToJSON coinbaseAesonOptions +instance FromJSON CryptoWithdrawal where parseJSON = genericParseJSON coinbaseAesonOptions + +--------------------------- +data TransferToCoinbaseResponse + = TransferResponse + { trId :: TransferId + -- FIX ME! and other stuff I'm going to ignore. + } deriving (Eq, Show, Generic, Typeable) + +instance NFData TransferToCoinbaseResponse +instance FromJSON TransferToCoinbaseResponse where + parseJSON (Object m) = TransferResponse + <$> m .: "id" + parseJSON _ = mzero + +data CryptoWithdrawalResp + = WithdrawalResp + { wdrId :: TransferId + , wdrAmount :: Size + , wdrCurrency :: CurrencyId + } deriving (Eq, Show, Generic, Typeable) + +instance NFData CryptoWithdrawalResp +instance ToJSON CryptoWithdrawalResp where + toJSON = genericToJSON coinbaseAesonOptions +instance FromJSON CryptoWithdrawalResp where + parseJSON = genericParseJSON coinbaseAesonOptions + +--------------------------- +data CryptoWallet + = BTCWallet BitcoinWallet deriving (Show, Data, Typeable, Generic) +-- | To Do: add other... +-- | ... possibilities here later + +instance NFData CryptoWallet +instance ToJSON CryptoWallet where + toJSON = genericToJSON coinbaseAesonOptions +instance FromJSON CryptoWallet where + parseJSON = genericParseJSON coinbaseAesonOptions + + +newtype BitcoinWallet = FromBTCAddress { btcAddress :: String } + deriving (Show, Data, Typeable, Generic, ToJSON, FromJSON) +instance NFData BitcoinWallet + +data BTCTransferReq + = SendBitcoin + { sendAmount :: Size + , bitcoinWallet :: BitcoinWallet + } + deriving (Show, Data, Typeable, Generic) + +instance NFData BTCTransferReq +instance ToJSON BTCTransferReq where + toJSON SendBitcoin {..} = object + [ "type" .= ("send" :: Text) + , "currency" .= ("BTC" :: Text) + , "to" .= btcAddress bitcoinWallet + , "amount" .= sendAmount + ] + +--------------------------- +newtype BTCTransferId = BTCTransferId { getBtcTransferId :: UUID } + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, NFData, FromJSON, ToJSON) + +data BTCTransferResponse = BTCTransferResponse + { sendId :: BTCTransferId + -- FIX ME! and other stuff I'm going to ignore. + } deriving (Eq, Data, Show, Generic, Typeable) + +instance NFData BTCTransferResponse +instance FromJSON BTCTransferResponse where + parseJSON (Object m) = do + transferData <- m .:? "data" -- FIX ME! I should factor this out of all responses from Coinbase + case transferData of + Nothing -> mzero + Just da -> BTCTransferResponse <$> da .: "id" + parseJSON _ = mzero + +--------------------------- +data CoinbaseAccount = + CoinbaseAccount + { cbAccID :: CoinbaseAccountId + , resourcePath :: String + , primary :: Bool + , name :: String + , btcBalance :: Size + } + deriving (Show, Data, Typeable, Generic) + +instance FromJSON CoinbaseAccount where + parseJSON (Object m) = do + transferData <- m .:? "data" -- FIX ME! I should factor this out of all responses from Coinbase + case transferData of + Nothing -> mzero + Just da -> CoinbaseAccount + <$> da .: "id" + <*> da .: "resource_path" + <*> da .: "primary" + <*> da .: "name" + <*> (do + btcBalance <- da .: "balance" + case btcBalance of + Object b -> b .: "amount" + _ -> mzero + ) + + parseJSON _ = mzero + + -- Reports + +newtype ReportId = ReportId { unReportId :: UUID } + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, NFData, FromJSON, ToJSON) + +data ReportType + = FillsReport + | AccountReport + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic) + +instance NFData ReportType +instance Hashable ReportType + +instance ToJSON ReportType where + toJSON FillsReport = String "fills" + toJSON AccountReport = String "account" +instance FromJSON ReportType where + parseJSON (String "fills") = return FillsReport + parseJSON (String "account") = return AccountReport + parseJSON _ = mzero + +data ReportFormat + = PDF + | CSV + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic) + +instance NFData ReportFormat +instance Hashable ReportFormat + +instance ToJSON ReportFormat where + toJSON PDF = String "pdf" + toJSON CSV = String "csv" +instance FromJSON ReportFormat where + parseJSON (String "pdf") = return PDF + parseJSON (String "csv") = return CSV + parseJSON _ = mzero + +data ReportRequest -- analgous to Transfer or NewOrder + = ReportRequest + { rrqType :: ReportType + , rrqStartDate :: UTCTime + , rrqEndDate :: UTCTime + , rrqProductId :: ProductId + , rrqAccountId :: AccountId + , rrqFormat :: ReportFormat + , rrqEmail :: Maybe String + } + deriving (Show, Data, Typeable, Generic) + +instance NFData ReportRequest +instance ToJSON ReportRequest where + toJSON = genericToJSON coinbaseAesonOptions +instance FromJSON ReportRequest where + parseJSON = genericParseJSON coinbaseAesonOptions + +data ReportParams + = ReportParams + { reportStartDate :: UTCTime + , reportEndDate :: UTCTime + } + deriving (Show, Data, Typeable, Generic) + +instance NFData ReportParams +instance ToJSON ReportParams where + toJSON ReportParams{..} = object + ([ "start_date" .= reportStartDate + , "end_date" .= reportEndDate + ]) +instance FromJSON ReportParams where + parseJSON (Object m) = ReportParams + <$> m .: "start_date" + <*> m .: "end_date" + parseJSON _ = mzero + +data ReportStatus + = ReportPending + | ReportCreating + | ReportReady + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic) + +instance NFData ReportStatus +instance Hashable ReportStatus + +instance ToJSON ReportStatus where + toJSON ReportPending = String "pending" + toJSON ReportCreating = String "creating" + toJSON ReportReady = String "ready" +instance FromJSON ReportStatus where + parseJSON (String "pending") = return ReportPending + parseJSON (String "creating") = return ReportCreating + parseJSON (String "ready") = return ReportReady + parseJSON _ = mzero + +data ReportInfo + = ReportInfo + { reportId :: ReportId + , reportType :: ReportType + , reportStatus :: ReportStatus + , reportCreated :: Maybe UTCTime + , reportCompleted :: Maybe UTCTime + , reportExpires :: Maybe UTCTime + , reportUrl :: Maybe String + , reportParams :: Maybe ReportParams + } + deriving (Show, Data, Typeable, Generic) + +instance NFData ReportInfo +instance ToJSON ReportInfo where + toJSON ReportInfo{..} = object + ([ "id" .= reportId + , "type" .= reportType + , "status" .= reportStatus + , "created_at" .= reportCreated + , "completed_at" .= reportCompleted + , "expires_at" .= reportExpires + , "file_url" .= reportUrl + , "params" .= reportParams + ]) + +instance FromJSON ReportInfo where + parseJSON (Object m) = ReportInfo + <$> m .: "id" + <*> m .: "type" + <*> m .: "status" + <*> m .:? "created_at" + <*> m .:? "completed_at" + <*> m .:? "expires_at" + <*> m .:? "file_url" + <*> m .:? "params" + parseJSON _ = mzero 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 @@ -7,22 +7,43 @@ module Coinbase.Exchange.Types.Socket where +------------------------------------------------------------------------------- +import Control.Applicative import Control.DeepSeq import Control.Monad -import Data.Aeson.Types hiding (Error) +import Data.Aeson.Types hiding (Error) import Data.Data import Data.Hashable +import qualified Data.HashMap.Strict as H import Data.Text (Text) import Data.Time import Data.Word import GHC.Generics -import qualified Data.HashMap.Strict as H +------------------------------------------------------------------------------- +import Coinbase.Exchange.Types.Core hiding (OrderStatus (..)) +------------------------------------------------------------------------------- -import Coinbase.Exchange.Types.Core hiding (OrderStatus(..)) + +------------------------------------------------------------------------------- +-- | Messages we can send to the exchange +data SendExchangeMessage + = Subscribe [ProductId] + | SetHeartbeat Bool + deriving (Eq, Show, Read, Data, Typeable, Generic) + +instance NFData SendExchangeMessage + + + +------------------------------------------------------------------------------- +-- | Messages they send back to us data ExchangeMessage - = Subscribe - { msgProductId :: ProductId + = Heartbeat + { msgTime :: UTCTime + , msgProductId :: ProductId + , msgSequence :: Sequence + , msgLastTradeId :: TradeId } | ReceivedLimit { msgTime :: UTCTime @@ -36,12 +57,12 @@ , msgSize :: Size } | ReceivedMarket - { msgTime :: UTCTime - , msgProductId :: ProductId - , msgSequence :: Sequence - , msgOrderId :: OrderId - , msgSide :: Side - , msgClientOid :: Maybe ClientOrderId + { 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)) } @@ -65,35 +86,33 @@ , msgSize :: Size , msgPrice :: Price } - | 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 + | Done + { msgTime :: UTCTime + , msgProductId :: ProductId + , msgSequence :: Sequence + , msgOrderId :: OrderId + , msgSide :: Side + , msgReason :: Reason + -- It is possible for these next two fields to be Nothing separately + -- Filled market orders limited by funds will not have a price but may have remaining_size + -- Filled limit orders may have a price but not a remaining_size (assumed zero) + -- CURRENTLY ** `remaining_size` reported in Done messages is sometimes incorrect ** + -- This appears to be bug at GDAX. I've told them about it. + , msgMaybePrice :: Maybe Price + , msgMaybeRemSize :: Maybe Size } | ChangeLimit - { msgTime :: UTCTime - , msgProductId :: ProductId - , msgSequence :: Sequence - , msgOrderId :: OrderId - , msgSide :: Side - , msgPrice :: Price - , msgNewSize :: Size - , msgOldSize :: Size + { msgTime :: UTCTime + , msgProductId :: ProductId + , msgSequence :: Sequence + , msgOrderId :: OrderId + , msgSide :: Side + -- Observation has revealed Price is not always present in + -- change messages with old_size and new_size. This may be + -- self trade prevention or something of the sort. + , msgMaybePrice :: Maybe Price + , msgNewSize :: Size + , msgOldSize :: Size } | ChangeMarket { msgTime :: UTCTime @@ -101,7 +120,6 @@ , msgSequence :: Sequence , msgOrderId :: OrderId , msgSide :: Side - , msgPrice :: Price , msgNewFunds :: Cost , msgOldFunds :: Cost } @@ -116,7 +134,14 @@ instance FromJSON ExchangeMessage where parseJSON (Object m) = do msgtype <- m .: "type" + -- TO DO: `HeartbeatReq` and `Subscribe` message types are missing as those are + -- never received by the client. case (msgtype :: String) of + "hearbeat"-> Heartbeat + <$> m .: "time" + <*> m .: "product_id" + <*> m .: "sequence" + <*> m .: "last_trade_id" "open" -> Open <$> m .: "time" <*> m .: "product_id" @@ -125,27 +150,15 @@ <*> 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" + "done" -> Done + <$> m .: "time" + <*> m .: "product_id" + <*> m .: "sequence" + <*> m .: "order_id" + <*> m .: "side" + <*> m .: "reason" + <*> m .:? "price" + <*> m .:? "remaining_size" "match" -> Match <$> m .: "time" <*> m .: "product_id" @@ -157,18 +170,16 @@ <*> m .: "size" <*> m .: "price" "change" -> do - ms <- m .:? "new_size" - case (ms :: Maybe Size) of - Nothing -> ChangeMarket + ms <- m .:? "price" + let market = ChangeMarket <$> m .: "time" <*> m .: "product_id" <*> m .: "sequence" <*> m .: "order_id" <*> m .: "side" - <*> m .: "price" <*> m .: "new_funds" <*> m .: "old_funds" - Just _ -> ChangeLimit + limit = ChangeLimit <$> m .: "time" <*> m .: "product_id" <*> m .: "sequence" @@ -177,9 +188,12 @@ <*> m .: "price" <*> m .: "new_size" <*> m .: "old_size" + case (ms :: Maybe Price) of + Nothing -> market <|> limit + Just _ -> limit <|> market "received" -> do typ <- m .: "order_type" - mcid <- m .:? "client_id" + mcid <- m .:? "client_oid" case typ of Limit -> ReceivedLimit <$> m .: "time" @@ -208,6 +222,7 @@ (Nothing, Just f ) -> return $ Right (Nothing, f) (Just s , Just f ) -> return $ Right (Just s , f) ) + "error" -> error (show m) parseJSON _ = mzero @@ -221,13 +236,21 @@ then pure Nothing else obj .:? key ---------------------------- -instance ToJSON ExchangeMessage where - toJSON Subscribe{..} = object +------------------------------------------------------------------------------- +instance ToJSON SendExchangeMessage where + toJSON (Subscribe pids) = object [ "type" .= ("subscribe" :: Text) - , "product_id" .= msgProductId + , "product_ids" .= pids ] + toJSON (SetHeartbeat b) = object + [ "type" .= ("heartbeat" :: Text) + , "on" .= b] + + +------------------------------------------------------------------------------- +-- | Convenience/storage instance; never sent to exchange +instance ToJSON ExchangeMessage where toJSON Open{..} = object [ "type" .= ("open" :: Text) , "time" .= msgTime @@ -238,28 +261,22 @@ , "remaining_size" .= msgRemainingSize , "price" .= msgPrice ] - toJSON DoneLimit{..} = object - [ "type" .= ("done" :: Text) + toJSON Done{..} = 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 - ] + ++ case msgMaybePrice of + Nothing -> [] + Just p -> ["price" .= p] + ++ case msgMaybeRemSize of + Nothing -> [] + Just s -> ["remaining_size" .= s] + ) toJSON Match{..} = object [ "type" .= ("match" :: Text) , "time" .= msgTime @@ -276,7 +293,7 @@ [ "type" .= ("error" :: Text) , "message" .= msgMessage ] - toJSON ChangeLimit{..} = object + toJSON ChangeLimit{..} = object $ [ "type" .= ("change" :: Text) , "time" .= msgTime , "product_id" .= msgProductId @@ -285,8 +302,7 @@ , "side" .= msgSide , "new_size" .= msgNewSize , "old_size" .= msgOldSize - , "price" .= msgPrice - ] + ] ++ maybe [] (return . ("price" .= )) msgMaybePrice toJSON ChangeMarket{..} = object [ "type" .= ("change" :: Text) , "time" .= msgTime @@ -294,7 +310,6 @@ , "sequence" .= msgSequence , "order_id" .= msgOrderId , "side" .= msgSide - , "price" .= msgPrice , "new_funds" .= msgNewFunds , "old_funds" .= msgOldFunds ] @@ -313,7 +328,7 @@ where clientID = case msgClientOid of Nothing -> [] - Just ci -> ["client_id" .= msgClientOid ] + Just ci -> ["client_oid" .= msgClientOid ] toJSON ReceivedMarket{..} = object ( ["type" .= ("received" :: Text) @@ -327,7 +342,7 @@ where clientID = case msgClientOid of Nothing -> [] - Just ci -> ["client_id" .= msgClientOid ] + Just ci -> ["client_oid" .= msgClientOid ] (size,funds) = case msgMarketBounds of Left s -> (["size" .= s],[]) Right (ms,f) -> case ms of diff --git a/test/Coinbase/Exchange/MarketData/Test.hs b/test/Coinbase/Exchange/MarketData/Test.hs new file mode 100644 --- /dev/null +++ b/test/Coinbase/Exchange/MarketData/Test.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Coinbase.Exchange.MarketData.Test + ( tests + ) where + +import Control.Monad.IO.Class +import Data.Time +import Test.Tasty +import Test.Tasty.HUnit + +import Coinbase.Exchange.MarketData +import Coinbase.Exchange.Types +import Coinbase.Exchange.Types.Core + +-------------------------------- +-- NOTE: ["case_parse" test cases] +-- +-- The 'case_parse' function does NOT test that the API responses are parsed correctly +-- For example, the price can be $240 be parsed as $420 and the test will succeed. +-- The function only tests that the parser did not fail and returned *a value* +-- Whether the value returned is the correct one, that's a different matter, and +-- 'case-parse' is NOT testing that. +-- +-------------------------------- + +tests :: ExchangeConf -> TestTree +tests conf = testGroup "MarketData Parse" + [ case_parse conf "getProducts" $ getProducts + , case_parse conf "getTopOfBook" $ getTopOfBook defProduct + , case_parse conf "getTop50OfBook" $ getTop50OfBook defProduct + , case_parse conf "getOrderBook" $ getOrderBook defProduct + , case_parse conf "getProductTicker" $ getProductTicker defProduct + , case_parse conf "getTrades" $ getTrades defProduct + , case_parse conf "getHistory" $ getHistory defProduct defStart defEnd (Just 3600) + , case_parse conf "getCurrencies" $ getCurrencies + , case_parse conf "getExchangeTime" $ getExchangeTime + ] + +defProduct :: ProductId +defProduct = ProductId "BTC-USD" + +-- The date range below works well to provide data for the getHistory call in the sandboxed environment +-- The previous range yielded an empty list with no data when connected to the sandbox. +defStart :: Maybe UTCTime +defStart = Just $ parseTimeOrError True defaultTimeLocale "%FT%X%z" "2015-10-01T20:22:37+0000" + +defEnd :: Maybe UTCTime +defEnd = Just $ parseTimeOrError True defaultTimeLocale "%FT%X%z" "2015-10-07T21:22:37+0000" + +-- See NOTE: ["case_parse" test cases] +case_parse :: Show a => ExchangeConf -> String -> Exchange a -> TestTree +case_parse conf l fn = testCase l $ do + v <- liftIO $ runExchange conf fn + assertBool ("Failed to parse: " ++ show v) + (case v of + Left _ -> False + Right _ -> True) diff --git a/test/Coinbase/Exchange/Private/Test.hs b/test/Coinbase/Exchange/Private/Test.hs new file mode 100644 --- /dev/null +++ b/test/Coinbase/Exchange/Private/Test.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Coinbase.Exchange.Private.Test + ( tests + , giveAwayOrder + , run_placeOrder + ) where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Concurrent + +import Data.IORef +import Data.Maybe +import Data.List +import Data.Time +import Data.Scientific +import Data.UUID + +import System.Random + +import Test.Tasty +import Test.Tasty.HUnit + +import Coinbase.Exchange.Private +import Coinbase.Exchange.Types +import Coinbase.Exchange.Types.Core +import Coinbase.Exchange.Types.Private + +import Network.HTTP.Client.TLS +import Network.HTTP.Conduit +import System.Environment +import qualified Data.ByteString.Char8 as CBS + +deriving instance Eq Order + + +tests :: ExchangeConf -> TestTree +tests conf = testGroup "Private" + [ testCase "getAccountList" (do as <- run_getAccountList conf + case as of + [] -> error "Received empty list of accounts" + _ -> return () + ) + + , testCase "getUSDAccount" (do as <- run_getAccountList conf + let usdAccount = findUSDAccount as + ac <- run_getAccount conf (accId usdAccount) + assertEqual "accounts match" usdAccount ac + ) + + ,testCase "getUSDAccountLedger" (do as <- run_getAccountList conf + let usdAccount = findUSDAccount as + es <- run_getAccountLedger conf (accId usdAccount) + case es of + [] -> assertFailure "Received empty list of ledger entries" -- must not be empty to test parser + _ -> return () + ) + + , testCase "placeOrder" (do o <- creatNewLimitOrder + oid <- run_placeOrder conf o -- limit order + oid'<- run_placeOrder conf giveAwayOrder -- market order + return () + ) + + , testCase "getOrderList" (do run_getOrderList conf [Open, Pending] -- making sure this request is well formed + os <- run_getOrderList conf [] + case os of + [] -> assertFailure "Received empty order list" + _ -> return () + ) + + , testCase "getOrder" (do no <- creatNewLimitOrder + oid <- run_placeOrder conf no + threadDelay 1000000 -- 1 second delay + o <- run_getOrder conf oid + assertEqual "order price" (noPrice no) (orderPrice o) + assertEqual "order size" (noSize no) (orderSize o) + assertEqual "order side" (noSide no) (orderSide o) + assertEqual "order product" (noProductId no) (orderProductId o) + ) + , testCase "cancelOrder" (do no <- creatNewLimitOrder + threadDelay 4000000 -- 4 second delay, to run after other tests + oid <- run_placeOrder conf no + threadDelay 1000000 -- 1 second delay + os <- run_getOrderList conf [Open, Pending] + threadDelay 1000000 -- 1 second delay + run_cancelOrder conf oid + threadDelay 1000000 -- 1 second delay + os' <- run_getOrderList conf [Open, Pending] + case os \\ os' of + [o] -> do + assertEqual "order price" (noPrice no) (orderPrice o) + assertEqual "order size" (noSize no) (orderSize o) + assertEqual "order side" (noSide no) (orderSide o) + assertEqual "order product" (noProductId no) (orderProductId o) + + [] -> assertFailure "order not canceled" + _ -> assertFailure "more than one order canceled" + ) + + , testCase "getFills" (do oid <- run_placeOrder conf giveAwayOrder + threadDelay 1000000 -- 1 second delay + fs <- run_getFills conf (Just oid) Nothing + case fs of + [] -> assertFailure "No fills found for an order that should execute immediately" + _ -> return () + ) + + + -------------------------- BTC TRANSFER TESTS -------------------------- + -- CAREFULL ON LIVE ENVIRONMENT!!! TRANSFERS ARE IRREVERSIBLE!!! + + -- This test cause a "403 Forbiden" error when run in the Sanbox. I'm not sure that can be fixed on my end. + , testCase "Withdraw BTCs" $ + assertFailure "BTC withdrawal test Suspended for Safety" + -- (do + -- res <- run_withdrawBTC conf sampleTransfer + -- print res + -- return () + -- ) + + -------------------------------------------------------------------------------- + ] + +----------------------------------------------- +-- DO NOT USE!! CAREFUL!! THIS WILL TRY TO SEND YOUR BITCOINS TO THE SPECIFIED WALLET BELOW! +-- THIS MAY BE IRREVERSIBLE. +sampleTransfer :: CryptoWithdrawal +sampleTransfer = Withdrawal + { wdAmount = 0.02 + , wdCurrency = CurrencyId "BTC" + , wdCryptoAddress = BTCWallet (FromBTCAddress "INVALID-WALLET-INVALID-WALLET-INVA") + } + +giveAwayOrder :: NewOrder +giveAwayOrder = NewMarketOrder + -- CAREFUL CHANGING THESE VALUES IF YOU PERFORM TESTING IN THE LIVE ENVIRONMENT. YOU MAY LOSE MONEY. + { noProductId = "BTC-USD" + , noSide = Sell + , noSelfTrade = DecrementAndCancel + , noClientOid = Just $ ClientOrderId $ fromJust $ fromString "c2cc10e1-57d6-4b6f-9899-deadbeef2d8c" + , noSizeAndOrFunds = Right (Just 0.01, 5) -- at most 1 BTC cent or 5 dollars per test + } + +creatNewLimitOrder :: IO NewOrder +creatNewLimitOrder = do + -- can't be deterministic because exchange is stateful + -- running a test twice with same random input may produce different results + sz <- randomRIO (0,9999) + -- CAREFUL CHANGING THESE VALUES IF YOU PERFORM TESTING IN THE LIVE ENVIRONMENT. YOU MAY LOOSE MONEY. + return NewLimitOrder + { noSize = 0.01 + Size (CoinScientific $ fromInteger sz / 1000000 ) + , noPrice = 10.36 + , noProductId = "BTC-USD" + , noSide = Buy + , noSelfTrade = DecrementAndCancel + , noClientOid = Just $ ClientOrderId $ fromJust $ fromString "c2cc10e1-57d6-4b6f-9899-111122223d8c" + , noPostOnly = False + , noTimeInForce = GoodTillCanceled + , noCancelAfter = Nothing + } + + +findUSDAccount :: [Account] -> Account +findUSDAccount as = case filter (\a -> accCurrency a == CurrencyId "USD") as of + [a] -> a + [] -> error "no USD denominated account found" + _ -> error "more than one account denominated in USD found" + +----------------------------------------------- +onSuccess :: ExchangeConf -> Exchange a -> String -> IO a +onSuccess conf apicall errorstring = do + r <- liftIO $ runExchange conf apicall + case r of + Left e -> print e >> error errorstring + Right a -> return a + +run_getAccountList :: ExchangeConf -> IO [Account] +run_getAccountList conf = onSuccess conf getAccountList "Failed to get account list" + +run_getAccount :: ExchangeConf -> AccountId -> IO Account +run_getAccount conf acID = onSuccess conf (getAccount acID) "Failed to get account info" + +run_getAccountLedger :: ExchangeConf -> AccountId -> IO [Entry] +run_getAccountLedger conf acID = onSuccess conf (getAccountLedger acID) "Failed to get account ledger" + +run_placeOrder :: ExchangeConf -> NewOrder -> IO OrderId +run_placeOrder conf o = onSuccess conf (createOrder o) "Failed to create order" + +run_getOrder :: ExchangeConf -> OrderId -> IO Order +run_getOrder conf oid = onSuccess conf (getOrder oid) "Failed to get order info" + +run_getOrderList :: ExchangeConf -> [OrderStatus] -> IO [Order] +run_getOrderList conf ss = onSuccess conf (getOrderList ss) "Failed to get order list" + +run_cancelOrder :: ExchangeConf -> OrderId -> IO () +run_cancelOrder conf oid = onSuccess conf (cancelOrder oid) "Failed to cancel order" + +run_getFills :: ExchangeConf -> Maybe OrderId -> Maybe ProductId -> IO [Fill] +run_getFills conf moid mpid = onSuccess conf (getFills moid mpid) "Failed to get fills" + +run_withdrawBTC :: ExchangeConf -> CryptoWithdrawal -> IO CryptoWithdrawalResp +run_withdrawBTC conf w = onSuccess conf (createCryptoWithdrawal w) "Failed to create withdrawal" diff --git a/test/Coinbase/Exchange/Socket/Test.hs b/test/Coinbase/Exchange/Socket/Test.hs new file mode 100644 --- /dev/null +++ b/test/Coinbase/Exchange/Socket/Test.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Coinbase.Exchange.Socket.Test (tests) where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Monad +import Data.Aeson + +import Test.Tasty +import Test.Tasty.HUnit + +import qualified Network.WebSockets as WS + +import Coinbase.Exchange.Private +import Coinbase.Exchange.Socket +import Coinbase.Exchange.Types +import Coinbase.Exchange.Types.Core + +import qualified Coinbase.Exchange.Private.Test as P + +import Debug.Trace + +------------------------------------- +-- NOTE: [Connectivity Precondition] +-- +-- The parsing tests are time-based and assume we are receiving messages during the +-- time we are connected. However, those tests are NOT FAILSAFE. +-- +-- ** If no data is received, parsing succeeds and, therefore, the parsing tests succeed ** +-- +-- To ensure this unsafe behavior does not go unnoticed (we thinking we are +-- parsing correctly when, in fact, we are not parsing anything at all), +-- We first verify we can receive at least 20 messages (i.e. a fixed minimum number) +-- from the socket, before running the parsing tests. +------------------------------------- + +tests :: ExchangeConf -> ProductId -> TestTree +tests conf market= testGroup "Socket" + -- See NOTE: [Connectivity Precondition] + [ testCase "Do I receive messages?" (receiveSocket conf [market]) + , testCase "Parse Websocket Stream" (parseSocket conf [market] (threadDelay $ 1000000 * 20)) + , testCase "Decode Re-Encode Decode" (reencodeSocket conf [market]) + ] + +receiveSocket :: ExchangeConf -> [ProductId] -> IO () +receiveSocket conf market = subscribe (apiType conf) market $ \conn -> do + sequence_ $ replicate 20 (receiveAndDecode conn) + +-- Success: no parse errors found while running +-- Failure: a parse error is found while running +parseSocket :: ExchangeConf -> [ProductId] -> IO a -> IO () +parseSocket conf market challenge = subscribe (apiType conf) market $ \conn -> do + waitCancelThreads challenge (forever $ receiveAndDecode conn) + return () + +-- FIX ME! there's no guarantee we are hitting all order types. +-- a more thorough test would be better. +reencodeSocket :: ExchangeConf -> [ProductId] -> IO () +reencodeSocket conf market = subscribe (apiType conf) market $ \conn -> do + sequence_ $ replicate 1000 (decodeEncode conn) + +decodeEncode :: WS.Connection -> IO () +decodeEncode conn = do + ds <- WS.receiveData conn + let res = eitherDecode ds + case res :: Either String ExchangeMessage of + Left er -> assertFailure "Failure parsing data from exchange" >> print er + Right received -> do + let enc = encode received + dec = eitherDecode enc + if dec == res + then return () + else do + putStrLn $ "### original: " ++ show res + putStrLn $ "### obtained: " ++ show dec + assertFailure "decoded object is different from original" + + + +receiveAndDecode :: WS.Connection -> IO () +receiveAndDecode conn = do + ds <- WS.receiveData conn + let res = eitherDecode {- $ trace (show ds) -} ds + case res :: Either String ExchangeMessage of + Left er -> print er >> assertFailure "Parsing failure found" + Right v -> return () + +waitCancelThreads :: IO a -> IO b -> IO (Either a b) +waitCancelThreads action1 action2 = do + a <- async action1 + b <- async action2 + c <- waitEither a b + case c of + Left a -> cancel b + Right b -> cancel a + return c diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module Main where import Control.Monad @@ -8,6 +10,7 @@ import Test.Tasty import Coinbase.Exchange.Types +import Coinbase.Exchange.Types.Core import qualified Coinbase.Exchange.MarketData.Test as MarketData import qualified Coinbase.Exchange.Private.Test as Private @@ -16,17 +19,23 @@ main :: IO () main = do mgr <- newManager tlsManagerSettings - tKey <- liftM CBS.pack $ getEnv "COINBASE_KEY" - tSecret <- liftM CBS.pack $ getEnv "COINBASE_SECRET" - tPass <- liftM CBS.pack $ getEnv "COINBASE_PASSPHRASE" + tKey <- liftM CBS.pack $ getEnv "GDAX_KEY" + tSecret <- liftM CBS.pack $ getEnv "GDAX_SECRET" + tPass <- liftM CBS.pack $ getEnv "GDAX_PASSPHRASE" + sbox <- getEnv "GDAX_SANDBOX" + let apiType = case sbox of + "FALSE" -> Live + "TRUE" -> Sandbox + _ -> error "Coinbase sandbox option must be either: TRUE or FALSE (all caps)" + case mkToken tKey tSecret tPass of - Right tok -> defaultMain (tests $ ExchangeConf mgr (Just tok) Live) + Right tok -> defaultMain (tests $ ExchangeConf mgr (Just tok) apiType) Left er -> error $ show er tests :: ExchangeConf -> TestTree tests conf = testGroup "Tests" [ MarketData.tests conf , Private.tests conf - , Socket.tests conf + , Socket.tests conf (ProductId "ETH-BTC") ]