coinbase-exchange 0.3.0.0 → 0.4.0.0

raw patch · 14 files changed

+1023/−175 lines, 14 filesdep ~aesondep ~mtldep ~timePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, mtl, time

API changes (from Hackage documentation)

Files

• coinbase-exchange.cabal +13/−9
• sbox/Main.hs +11/−5
• src/Coinbase/Exchange/Private.hs +30/−3
• src/Coinbase/Exchange/Rest.hs +59/−23
• src/Coinbase/Exchange/Socket.hs +14/−4
• src/Coinbase/Exchange/Types.hs +16/−5
• src/Coinbase/Exchange/Types/Core.hs +20/−6
• src/Coinbase/Exchange/Types/MarketData.hs +6/−15
• src/Coinbase/Exchange/Types/Private.hs +374/−9
• src/Coinbase/Exchange/Types/Socket.hs +106/−91
• test/Coinbase/Exchange/MarketData/Test.hs +58/−0
• test/Coinbase/Exchange/Private/Test.hs +205/−0
• test/Coinbase/Exchange/Socket/Test.hs +97/−0
• test/Main.hs +14/−5

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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"

@@ -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

@@ -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")          ]