diff --git a/app/Sandbox.hs b/app/Sandbox.hs --- a/app/Sandbox.hs +++ b/app/Sandbox.hs @@ -12,6 +12,7 @@ import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as CBS import qualified Data.ByteString.Lazy.Char8 as CLBS +import qualified Data.Vector as V import Network.GDAX.Explicit import Network.GDAX.Types.Feed import Network.WebSockets @@ -21,11 +22,11 @@ main :: IO () main = putStrLn "For use with GHCi." -withGdax :: (MonadIO m) => (Gdax -> m a) -> m a -withGdax f = do - gAccessKey <- liftIO $ CBS.pack <$> getEnv "GDAX_KEY" - gSecretKey <- liftIO $ Base64.decodeLenient . CBS.pack <$> getEnv "GDAX_SECRET" - gPassphrase <- liftIO $ CBS.pack <$> getEnv "GDAX_PASSPHRASE" +withSandboxGdax :: (MonadIO m) => (Gdax -> m a) -> m a +withSandboxGdax f = do + gAccessKey <- liftIO $ CBS.pack <$> getEnv "GDAX_SANDBOX_KEY" + gSecretKey <- liftIO $ Base64.decodeLenient . CBS.pack <$> getEnv "GDAX_SANDBOX_SECRET" + gPassphrase <- liftIO $ CBS.pack <$> getEnv "GDAX_SANDBOX_PASSPHRASE" g <- mkSandboxGdax gAccessKey gSecretKey gPassphrase @@ -33,36 +34,3 @@ printPrettyLn :: (MonadIO m) => Value -> m () printPrettyLn = liftIO . CLBS.putStrLn . encodePretty - -subscribeSocket :: IO () -subscribeSocket = runSecureClient "ws-feed.gdax.com" 443 "/" client - -testSub :: Subscribe -testSub = Subscribe $ Subscriptions [] [ChannelSubscription ChannelHeartbeat ["BTC-USD"]] - -testUnSub :: UnSubscribe -testUnSub = UnSubscribe $ Subscriptions [] [ChannelSubscription ChannelHeartbeat ["BTC-USD"]] - -client :: ClientApp () -client conn = do - putStrLn "Connection opened.." - - sendTextData conn (Aeson.encode testSub) - void . forkIO . forever $ do - msg <- receiveData conn - let hbeat = Aeson.decode msg :: Maybe Heartbeat - case hbeat of - Nothing -> - let subs = Aeson.decode msg :: Maybe Subscriptions - in case subs of - Nothing -> print ("not sub"::String) >> print msg - Just v -> print v - Just v -> print v - - threadDelay 1000000 - - putStrLn "Unsubscribing..." - sendTextData conn (Aeson.encode testUnSub) - - threadDelay 1000000 - putStrLn "Closing..." diff --git a/gdax.cabal b/gdax.cabal --- a/gdax.cabal +++ b/gdax.cabal @@ -1,5 +1,5 @@ name: gdax -version: 0.5.0.1 +version: 0.6.0.0 synopsis: API Wrapping for Coinbase's GDAX exchange. description: Please see README.md homepage: https://github.com/AndrewRademacher/gdax @@ -26,6 +26,8 @@ Network.GDAX.Implicit.Private Network.GDAX.Types.Feed Network.GDAX.Types.MarketData + Network.GDAX.Types.Private + Network.GDAX.Types.Shared Network.GDAX.Core Network.GDAX.Exceptions Network.GDAX.Explicit @@ -41,16 +43,21 @@ , base64-bytestring , byteable , bytestring + , containers , cryptohash , exceptions + , hashable , http-client , http-client-tls , lens , lens-aeson , mtl + , regex-tdfa + , regex-tdfa-text , scientific , text , time + , unordered-containers , uuid , vector , websockets @@ -62,7 +69,7 @@ hs-source-dirs: app default-language: Haskell2010 - ghc-options: -rtsopts -Wall + ghc-options: -rtsopts build-depends: base >4 && < 6 @@ -73,6 +80,7 @@ , base64-bytestring , bytestring , text + , vector , websockets , wuss @@ -86,6 +94,7 @@ other-modules: Network.GDAX.Test.Feed Network.GDAX.Test.MarketData + Network.GDAX.Test.Private Network.GDAX.Test.Types build-depends: base >4 && < 6 @@ -93,6 +102,7 @@ , gdax , aeson + , aeson-pretty , base64-bytestring , bytestring , containers @@ -106,6 +116,7 @@ , tasty-hunit , text , time + , unordered-containers , vector , websockets , wuss diff --git a/lib/Network/GDAX/Core.hs b/lib/Network/GDAX/Core.hs --- a/lib/Network/GDAX/Core.hs +++ b/lib/Network/GDAX/Core.hs @@ -24,6 +24,7 @@ , gdaxGetWith , gdaxSignedGet , gdaxSignedPost + , gdaxSignedDelete ) where import Control.Lens @@ -38,6 +39,7 @@ import qualified Data.ByteString.Char8 as CBS import qualified Data.ByteString.Lazy.Char8 as CLBS import Data.Monoid +import Data.Text (Text) import qualified Data.Text as T import Data.Time import Data.Time.Clock.POSIX @@ -54,6 +56,7 @@ type Path = String type Method = ByteString +type Params = [(Text, Text)] liveRest :: Endpoint liveRest = "https://api.gdax.com" @@ -135,25 +138,37 @@ where opts = opts' & manager .~ Right (g ^. networkManager) -gdaxSignedGet :: (MonadIO m, MonadThrow m, FromJSON b) => Gdax -> Path -> m b +gdaxSignedGet :: (MonadIO m, MonadThrow m, FromJSON b) => Gdax -> Path -> Params -> m b {-# INLINE gdaxSignedGet #-} -gdaxSignedGet g path = do +gdaxSignedGet g path par = do signedOpts <- signOptions g "GET" path Nothing opts res <- liftIO $ getWith signedOpts (g ^. restEndpoint <> path) decodeResult res where opts = defaults & manager .~ Right (g ^. networkManager) + & params .~ par -gdaxSignedPost :: (MonadIO m, MonadThrow m, ToJSON a, FromJSON b) => Gdax -> Path -> a -> m b +gdaxSignedPost :: (MonadIO m, MonadThrow m, ToJSON a, FromJSON b) => Gdax -> Path -> Params -> a -> m b {-# INLINE gdaxSignedPost #-} -gdaxSignedPost g path body = do +gdaxSignedPost g path par body = do signedOpts <- signOptions g "POST" path (Just bodyBS) opts res <- liftIO $ postWith signedOpts (g ^. restEndpoint <> path) bodyBS decodeResult res where opts = defaults & header "Content-Type" .~ [ "application/json" ] & manager .~ Right (g ^. networkManager) + & params .~ par bodyBS = CLBS.toStrict $ Aeson.encode body + +gdaxSignedDelete :: (MonadIO m, MonadThrow m, FromJSON b) => Gdax -> Path -> Params -> m b +{-# INLINE gdaxSignedDelete #-} +gdaxSignedDelete g path par = do + signedOpts <- signOptions g "DELETE" path Nothing opts + res <- liftIO $ deleteWith signedOpts (g ^. restEndpoint <> path) + decodeResult res + where + opts = defaults & manager .~ Right (g ^. networkManager) + & params .~ par decodeResult :: (MonadThrow m, FromJSON a) => Response CLBS.ByteString -> m a {-# INLINE decodeResult #-} diff --git a/lib/Network/GDAX/Explicit.hs b/lib/Network/GDAX/Explicit.hs --- a/lib/Network/GDAX/Explicit.hs +++ b/lib/Network/GDAX/Explicit.hs @@ -3,6 +3,7 @@ , module Exceptions , module MarketData , module Private + , module Shared ) where import Network.GDAX.Core as Core hiding (Method, Path, @@ -13,3 +14,5 @@ import Network.GDAX.Explicit.MarketData as MarketData import Network.GDAX.Explicit.Private as Private import Network.GDAX.Types.MarketData as MarketData +import Network.GDAX.Types.Private as Private +import Network.GDAX.Types.Shared as Shared diff --git a/lib/Network/GDAX/Explicit/MarketData.hs b/lib/Network/GDAX/Explicit/MarketData.hs --- a/lib/Network/GDAX/Explicit/MarketData.hs +++ b/lib/Network/GDAX/Explicit/MarketData.hs @@ -19,6 +19,7 @@ import Network.GDAX.Core import Network.GDAX.Exceptions import Network.GDAX.Types.MarketData +import Network.GDAX.Types.Shared import Network.Wreq getProducts :: (MonadIO m, MonadThrow m) => Gdax -> m (Vector Product) diff --git a/lib/Network/GDAX/Explicit/Private.hs b/lib/Network/GDAX/Explicit/Private.hs --- a/lib/Network/GDAX/Explicit/Private.hs +++ b/lib/Network/GDAX/Explicit/Private.hs @@ -5,20 +5,109 @@ import Control.Monad.Catch import Control.Monad.IO.Class -import Data.Aeson -import Data.Text +import Data.Monoid +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Vector (Vector) import Network.GDAX.Core +import Network.GDAX.Types.Private +import Network.GDAX.Types.Shared -placeOrder :: (MonadIO m, MonadThrow m) => Gdax -> m Value -placeOrder g = gdaxSignedPost g "/orders" body +listAccounts :: (MonadIO m, MonadThrow m) => Gdax -> m (Vector Account) +listAccounts g = gdaxSignedGet g "/accounts" [] + +getAccount :: (MonadIO m, MonadThrow m) => Gdax -> AccountId -> m Account +getAccount g aid = gdaxSignedGet g ("/accounts/" <> show aid) [] + +getAccountHistory :: (MonadIO m, MonadThrow m) => Gdax -> AccountId -> m (Vector Entry) +getAccountHistory g aid = gdaxSignedGet g ("/accounts/" <> show aid <> "/ledger") [] + +getAccountHolds :: (MonadIO m, MonadThrow m) => Gdax -> AccountId -> m (Vector Hold) +getAccountHolds g aid = gdaxSignedGet g ("/accounts/" <> show aid <> "/holds") [] + +placeOrder :: (MonadIO m, MonadThrow m) => Gdax -> NewOrder -> m NewOrderConfirmation +placeOrder g no = gdaxSignedPost g "/orders" [] no + +placeLimitOrder :: (MonadIO m, MonadThrow m) => Gdax -> NewLimitOrder -> m NewOrderConfirmation +placeLimitOrder g no = gdaxSignedPost g "/orders" [] no + +placeMarketOrder :: (MonadIO m, MonadThrow m) => Gdax -> NewMarketOrder -> m NewOrderConfirmation +placeMarketOrder g no = gdaxSignedPost g "/orders" [] no + +placeStopOrder :: (MonadIO m, MonadThrow m) => Gdax -> NewStopOrder -> m NewOrderConfirmation +placeStopOrder g no = gdaxSignedPost g "/orders" [] no + +cancelOrder :: (MonadIO m, MonadThrow m) => Gdax -> OrderId -> m () +cancelOrder g oid = gdaxSignedDelete g ("/orders/" <> show oid) [] + +cancelAllOrders :: (MonadIO m, MonadThrow m) => Gdax -> ProductId -> m (Vector OrderId) +cancelAllOrders g pid = gdaxSignedDelete g ("/orders") [("product_id", T.pack (show pid))] + +listOrders :: (MonadIO m, MonadThrow m) => Gdax -> Set ProductId -> Set OrderStatus -> m (Vector Order) +listOrders g pids oss = gdaxSignedGet g "/orders" params where - body = object - [ "size" .= ("0.01" :: Text) - , "price" .= ("0.100" :: Text) - , "side" .= ("buy" :: Text) - , "product_id" .= ("BTC-USD" :: Text) - ] + params = fmap (\p -> ("product_id", T.pack (show p))) (Set.toList pids) + <> fmap (\s -> ("status", T.pack (show s))) (Set.toList oss) -listAccounts :: (MonadIO m, MonadThrow m) => Gdax -> m Value -listAccounts g = - gdaxSignedGet g "/accounts" +getOrder :: (MonadIO m, MonadThrow m) => Gdax -> OrderId -> m Order +getOrder g oid = gdaxSignedGet g ("/orders/" <> show oid) [] + +listFills :: (MonadIO m, MonadThrow m) => Gdax -> Set OrderId -> Set ProductId -> m (Vector Fill) +listFills g oids pids = gdaxSignedGet g "/fills" params + where + params = fmap (\p -> ("product_id", T.pack (show p))) (Set.toList pids) + <> fmap (\o -> ("order_id", T.pack (show o))) (Set.toList oids) + +listFundings :: (MonadIO m, MonadThrow m) => Gdax -> Set FundingStatus -> m (Vector Funding) +listFundings g fs = gdaxSignedGet g "/fundings" (fmap (\f -> ("status", T.pack (show f))) (Set.toList fs)) + +repayFunding :: (MonadIO m, MonadThrow m) => Gdax -> CurrencyId -> Double -> m () +repayFunding g c a = gdaxSignedPost g "/funding/repay" params () + where + params = [ ("currency", T.pack (show c)) + , ("amount", T.pack (show a)) + ] + +createMarginTransfer :: (MonadIO m, MonadThrow m) => Gdax -> NewMarginTransfer -> m MarginTransfer +createMarginTransfer g nmt = gdaxSignedPost g "/profiles/margin-transfer" [] nmt + +getPosition :: (MonadIO m, MonadThrow m) => Gdax -> m Position +getPosition g = gdaxSignedGet g "/position" [] + +type RepayOnly = Bool + +closePosition :: (MonadIO m, MonadThrow m) => Gdax -> RepayOnly -> m () +closePosition g r = gdaxSignedPost g "/position/close" [("repay_only", str)] () + where + str = if r then "true" else "false" + +deposit :: (MonadIO m, MonadThrow m) => Gdax -> Deposit -> m DepositReceipt +deposit g d = gdaxSignedPost g "/deposits/payment-method" [] d + +depositCoinbase :: (MonadIO m, MonadThrow m) => Gdax -> CoinbaseDeposit -> m CoinbaseDepositReceipt +depositCoinbase g d = gdaxSignedPost g "/deposits/coinbase-account" [] d + +withdraw :: (MonadIO m, MonadThrow m) => Gdax -> Withdraw -> m WithdrawReceipt +withdraw g w = gdaxSignedPost g "/withdrawals/payment-method" [] w + +withdrawCoinbase :: (MonadIO m, MonadThrow m) => Gdax -> CoinbaseWithdraw -> m CoinbaseWithdrawReceipt +withdrawCoinbase g w = gdaxSignedPost g "/withdrawals/coinbase-account" [] w + +withdrawCrypto :: (MonadIO m, MonadThrow m) => Gdax -> CryptoWithdraw -> m CryptoWithdrawReceipt +withdrawCrypto g w = gdaxSignedPost g "/withdrawals/crypto" [] w + +listPaymentMethods :: (MonadIO m, MonadThrow m) => Gdax -> m (Vector PaymentMethod) +listPaymentMethods g = gdaxSignedGet g "/payment-methods" [] + +listCoinbaseAccounts :: (MonadIO m, MonadThrow m) => Gdax -> m (Vector CoinbaseAccount) +listCoinbaseAccounts g = gdaxSignedGet g "/coinbase-accounts" [] + +createReport :: (MonadIO m, MonadThrow m) => Gdax -> NewReport -> m Report +createReport g nr = gdaxSignedPost g "/reports" [] nr + +getReport :: (MonadIO m, MonadThrow m) => Gdax -> ReportId -> m Report +getReport g rid = gdaxSignedGet g ("/reports/" <> show rid) [] + +listTrailingVolume :: (MonadIO m, MonadThrow m) => Gdax -> m (Vector TrailingVolume) +listTrailingVolume g = gdaxSignedGet g "/users/self/trailing-volume" [] diff --git a/lib/Network/GDAX/Feed.hs b/lib/Network/GDAX/Feed.hs --- a/lib/Network/GDAX/Feed.hs +++ b/lib/Network/GDAX/Feed.hs @@ -1,10 +1,19 @@ -module Network.GDAX.Feed where +module Network.GDAX.Feed + ( module Core + , module Exceptions + , module Feed + , module Shared + , defaultClient + ) where + import Control.Monad.Catch -import qualified Data.Aeson as Aeson -import qualified Data.Text as T -import Network.GDAX.Exceptions -import Network.GDAX.Types.Feed +import qualified Data.Aeson as Aeson +import qualified Data.Text as T +import Network.GDAX.Core as Core +import Network.GDAX.Exceptions as Exceptions +import Network.GDAX.Types.Feed as Feed +import Network.GDAX.Types.Shared as Shared import Network.WebSockets defaultClient :: Subscriptions -> (GdaxMessage -> IO b) -> Connection -> IO b @@ -17,4 +26,4 @@ let asSum = Aeson.eitherDecode res :: Either String GdaxMessage case asSum of Left er -> throwM $ MalformedGdaxResponse $ T.pack er - Right v -> handler v + Right v -> handler v >> loop diff --git a/lib/Network/GDAX/Implicit.hs b/lib/Network/GDAX/Implicit.hs --- a/lib/Network/GDAX/Implicit.hs +++ b/lib/Network/GDAX/Implicit.hs @@ -3,6 +3,7 @@ , module Exceptions , module MarketData , module Private + , module Shared ) where import Network.GDAX.Core as Core hiding (Method, Path, @@ -13,3 +14,5 @@ import Network.GDAX.Implicit.MarketData as MarketData import Network.GDAX.Implicit.Private as Private import Network.GDAX.Types.MarketData as MarketData +import Network.GDAX.Types.Private as Private +import Network.GDAX.Types.Shared as Shared diff --git a/lib/Network/GDAX/Implicit/MarketData.hs b/lib/Network/GDAX/Implicit/MarketData.hs --- a/lib/Network/GDAX/Implicit/MarketData.hs +++ b/lib/Network/GDAX/Implicit/MarketData.hs @@ -12,6 +12,7 @@ import Network.GDAX.Core import qualified Network.GDAX.Explicit.MarketData as Explicit import Network.GDAX.Types.MarketData +import Network.GDAX.Types.Shared getProducts :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => m (Vector Product) getProducts = do diff --git a/lib/Network/GDAX/Implicit/Private.hs b/lib/Network/GDAX/Implicit/Private.hs --- a/lib/Network/GDAX/Implicit/Private.hs +++ b/lib/Network/GDAX/Implicit/Private.hs @@ -7,16 +7,149 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Reader -import Data.Aeson +import Data.Set (Set) +import Data.Vector (Vector) import Network.GDAX.Core import qualified Network.GDAX.Explicit.Private as Explicit +import Network.GDAX.Types.Private +import Network.GDAX.Types.Shared -placeOrder' :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => m Value -placeOrder' = do +listAccounts :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => m (Vector Account) +listAccounts = do g <- (^. gdax) <$> ask - Explicit.placeOrder g + Explicit.listAccounts g -listAccounts' :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => m Value -listAccounts' = do +getAccount :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => AccountId -> m Account +getAccount aid = do g <- (^. gdax) <$> ask - Explicit.listAccounts g + Explicit.getAccount g aid + +getAccountHistory :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => AccountId -> m (Vector Entry) +getAccountHistory aid = do + g <- (^. gdax) <$> ask + Explicit.getAccountHistory g aid + +getAccountHolds :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => AccountId -> m (Vector Hold) +getAccountHolds aid = do + g <- (^. gdax) <$> ask + Explicit.getAccountHolds g aid + +placeOrder :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => NewOrder -> m NewOrderConfirmation +placeOrder no = do + g <- (^. gdax) <$> ask + Explicit.placeOrder g no + +placeLimitOrder :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => NewLimitOrder -> m NewOrderConfirmation +placeLimitOrder no = do + g <- (^. gdax) <$> ask + Explicit.placeLimitOrder g no + +placeMarketOrder :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => NewMarketOrder -> m NewOrderConfirmation +placeMarketOrder no = do + g <- (^. gdax) <$> ask + Explicit.placeMarketOrder g no + +placeStopOrder :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => NewStopOrder -> m NewOrderConfirmation +placeStopOrder no = do + g <- (^. gdax) <$> ask + Explicit.placeStopOrder g no + +cancelOrder :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => OrderId -> m () +cancelOrder oid = do + g <- (^. gdax) <$> ask + Explicit.cancelOrder g oid + +cancelAllOrders :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => ProductId -> m (Vector OrderId) +cancelAllOrders pid = do + g <- (^. gdax) <$> ask + Explicit.cancelAllOrders g pid + +listOrders :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => Set ProductId -> Set OrderStatus -> m (Vector Order) +listOrders pids oss = do + g <- (^. gdax) <$> ask + Explicit.listOrders g pids oss + +getOrder :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => OrderId -> m Order +getOrder oid = do + g <- (^. gdax) <$> ask + Explicit.getOrder g oid + +listFills :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => Set OrderId -> Set ProductId -> m (Vector Fill) +listFills oids pids = do + g <- (^. gdax) <$> ask + Explicit.listFills g oids pids + +listFundings :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => Set FundingStatus -> m (Vector Funding) +listFundings fs = do + g <- (^. gdax) <$> ask + Explicit.listFundings g fs + +repayFunding :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => CurrencyId -> Double -> m () +repayFunding c a = do + g <- (^. gdax) <$> ask + Explicit.repayFunding g c a + +createMarginTransfer :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => NewMarginTransfer -> m MarginTransfer +createMarginTransfer nmt = do + g <- (^. gdax) <$> ask + Explicit.createMarginTransfer g nmt + +getPosition :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => m Position +getPosition = do + g <- (^. gdax) <$> ask + Explicit.getPosition g + +closePosition :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => Explicit.RepayOnly -> m () +closePosition r = do + g <- (^. gdax) <$> ask + Explicit.closePosition g r + +deposit :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => Deposit -> m DepositReceipt +deposit d = do + g <- (^. gdax) <$> ask + Explicit.deposit g d + +depositCoinbase :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => CoinbaseDeposit -> m CoinbaseDepositReceipt +depositCoinbase d = do + g <- (^. gdax) <$> ask + Explicit.depositCoinbase g d + +withdraw :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => Withdraw -> m WithdrawReceipt +withdraw w = do + g <- (^. gdax) <$> ask + Explicit.withdraw g w + +withdrawCoinbase :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => CoinbaseWithdraw -> m CoinbaseWithdrawReceipt +withdrawCoinbase w = do + g <- (^. gdax) <$> ask + Explicit.withdrawCoinbase g w + +withdrawCrypto :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => CryptoWithdraw -> m CryptoWithdrawReceipt +withdrawCrypto w = do + g <- (^. gdax) <$> ask + Explicit.withdrawCrypto g w + +listPaymentMethods :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => m (Vector PaymentMethod) +listPaymentMethods = do + g <- (^. gdax) <$> ask + Explicit.listPaymentMethods g + +listCoinbaseAccounts :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => m (Vector CoinbaseAccount) +listCoinbaseAccounts = do + g <- (^. gdax) <$> ask + Explicit.listCoinbaseAccounts g + +createReport :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => NewReport -> m Report +createReport nr = do + g <- (^. gdax) <$> ask + Explicit.createReport g nr + +getReport :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => ReportId -> m Report +getReport rid = do + g <- (^. gdax) <$> ask + Explicit.getReport g rid + +listTrailingVolume :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => m (Vector TrailingVolume) +listTrailingVolume = do + g <- (^. gdax) <$> ask + Explicit.listTrailingVolume g diff --git a/lib/Network/GDAX/Parsers.hs b/lib/Network/GDAX/Parsers.hs --- a/lib/Network/GDAX/Parsers.hs +++ b/lib/Network/GDAX/Parsers.hs @@ -17,11 +17,15 @@ Just n -> pure n Nothing -> fail "Could not parse string scientific." -textDouble :: Value -> Parser Double -textDouble = withText "Text Double" $ \t -> +textMaybeDouble :: Maybe Value -> Parser (Maybe Double) +textMaybeDouble Nothing = return Nothing +textMaybeDouble (Just v) = Just <$> textRead v + +textRead :: (Read a) => Value -> Parser a +textRead = withText "Text Read" $ \t -> case readMaybe (T.unpack t) of Just n -> pure n - Nothing -> fail "Could not parse string double." + Nothing -> fail "Could not read value from string." newtype StringDouble = StringDouble { unStringDouble :: Double } diff --git a/lib/Network/GDAX/Types/Feed.hs b/lib/Network/GDAX/Types/Feed.hs --- a/lib/Network/GDAX/Types/Feed.hs +++ b/lib/Network/GDAX/Types/Feed.hs @@ -7,16 +7,16 @@ import Data.Aeson import Data.Monoid -import Data.Text (Text) -import qualified Data.Text as T +import Data.Text (Text) +import qualified Data.Text as T import Data.Time import Data.Typeable import Data.UUID import Data.Vector -import qualified Data.Vector.Generic as V +import qualified Data.Vector.Generic as V import GHC.Generics import Network.GDAX.Parsers -import Network.GDAX.Types.MarketData hiding (Open) +import Network.GDAX.Types.Shared data Subscriptions = Subscriptions @@ -171,14 +171,14 @@ parseJSON = withObjectOfType "Ticker" "ticker" $ \o -> Ticker <$> o .: "sequence" <*> o .: "product_id" - <*> (o .: "price" >>= textDouble) - <*> (o .: "open_24h" >>= textDouble) - <*> (o .: "volume_24h" >>= textDouble) - <*> (o .: "low_24h" >>= textDouble) - <*> (o .: "high_24h" >>= textDouble) - <*> (o .: "volume_30d" >>= textDouble) - <*> (o .: "best_bid" >>= textDouble) - <*> (o .: "best_ask" >>= textDouble) + <*> (o .: "price" >>= textRead) + <*> (o .: "open_24h" >>= textRead) + <*> (o .: "volume_24h" >>= textRead) + <*> (o .: "low_24h" >>= textRead) + <*> (o .: "high_24h" >>= textRead) + <*> (o .: "volume_30d" >>= textRead) + <*> (o .: "best_bid" >>= textRead) + <*> (o .: "best_ask" >>= textRead) data Level2Snapshot = Level2Snapshot @@ -262,46 +262,11 @@ <*> o .: "product_id" <*> o .: "sequence" <*> o .: "side" - <*> (o .: "size" >>= textDouble) - <*> (o .: "price" >>= textDouble) + <*> (o .: "size" >>= textRead) + <*> (o .: "price" >>= textRead) -- Full Book Messages -newtype UserId = UserId { unUserId :: Text } - deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON) - -instance Show UserId where - show = show . unUserId - -newtype ProfileId = ProfileId { unProfileId :: UUID } - deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON) - -instance Show ProfileId where - show = show . unProfileId - - -newtype OrderId = OrderId { unOrderId :: UUID } - deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON) - -instance Show OrderId where - show = show . unOrderId - -data OrderType - = OrderLimit - | OrderMarket - deriving (Typeable, Generic) - -instance Show OrderType where - show OrderLimit = "limit" - show OrderMarket = "market" - -instance FromJSON OrderType where - parseJSON = withText "OrderType" $ \t -> - case t of - "limit" -> pure OrderLimit - "market" -> pure OrderMarket - _ -> fail $ T.unpack $ "'" <> t <> "' is not a valid order type." - data Received = ReceivedLimit { _receivedTime :: UTCTime @@ -331,15 +296,15 @@ <*> o .: "product_id" <*> o .: "sequence" <*> o .: "order_id" - <*> (o .: "size" >>= textDouble) - <*> (o .: "price" >>= textDouble) + <*> (o .: "size" >>= textRead) + <*> (o .: "price" >>= textRead) <*> o .: "side" OrderMarket -> ReceivedMarket <$> o .: "time" <*> o .: "product_id" <*> o .: "sequence" <*> o .: "order_id" - <*> (o .: "funds" >>= textDouble) + <*> (o .: "funds" >>= textRead) <*> o .: "side" data Reason @@ -376,8 +341,8 @@ <*> o .: "product_id" <*> o .: "order_id" <*> o .: "sequence" - <*> (o .: "price" >>= textDouble) - <*> (o .: "remaining_size" >>= textDouble) + <*> (o .: "price" >>= textRead) + <*> (o .: "remaining_size" >>= textRead) <*> o .: "side" data Done @@ -385,7 +350,7 @@ { _doneTime :: UTCTime , _doneProductId :: ProductId , _doneSequence :: Sequence - , _donePrice :: Double + , _donePrice :: Maybe Double , _doneOrderId :: OrderId , _doneReason :: Reason , _doneSide :: Side @@ -398,11 +363,11 @@ <$> o .: "time" <*> o .: "product_id" <*> o .: "sequence" - <*> (o .: "price" >>= textDouble) + <*> (o .:? "price" >>= textMaybeDouble) <*> o .: "order_id" <*> o .: "reason" <*> o .: "side" - <*> (o .: "remaining_size" >>= textDouble) + <*> (o .: "remaining_size" >>= textRead) -- Match implemented previously @@ -485,27 +450,21 @@ <*> o .: "profile_id" <*> o .: "nonce" <*> o .: "position" - <*> (o .: "position_size" >>= textDouble) - <*> (o .: "position_compliement" >>= textDouble) - <*> (o .: "position_max_size" >>= textDouble) + <*> (o .: "position_size" >>= textRead) + <*> (o .: "position_compliement" >>= textRead) + <*> (o .: "position_max_size" >>= textRead) <*> o .: "call_side" - <*> (o .: "call_price" >>= textDouble) - <*> (o .: "call_size" >>= textDouble) - <*> (o .: "call_funds" >>= textDouble) + <*> (o .: "call_price" >>= textRead) + <*> (o .: "call_size" >>= textRead) + <*> (o .: "call_funds" >>= textRead) <*> o .: "covered" <*> o .: "next_expire_time" - <*> (o .: "base_balance" >>= textDouble) - <*> (o .: "base_funding" >>= textDouble) - <*> (o .: "quote_balance" >>= textDouble) - <*> (o .: "quote_funding" >>= textDouble) + <*> (o .: "base_balance" >>= textRead) + <*> (o .: "base_funding" >>= textRead) + <*> (o .: "quote_balance" >>= textRead) + <*> (o .: "quote_funding" >>= textRead) <*> o .: "private" -newtype StopType = StopType { unStopType :: Text } - deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON) - -instance Show StopType where - show = show . unStopType - data Activate = Activate { _activateProductId :: ProductId @@ -532,10 +491,10 @@ <*> o .: "order_id" <*> o .: "stop_type" <*> o .: "side" - <*> (o .: "stop_price" >>= textDouble) - <*> (o .: "size" >>= textDouble) - <*> (o .: "funds" >>= textDouble) - <*> (o .: "taker_fee_rate" >>= textDouble) + <*> (o .: "stop_price" >>= textRead) + <*> (o .: "size" >>= textRead) + <*> (o .: "funds" >>= textRead) + <*> (o .: "taker_fee_rate" >>= textRead) <*> o .: "private" -- Sum Type diff --git a/lib/Network/GDAX/Types/MarketData.hs b/lib/Network/GDAX/Types/MarketData.hs --- a/lib/Network/GDAX/Types/MarketData.hs +++ b/lib/Network/GDAX/Types/MarketData.hs @@ -9,25 +9,19 @@ import Data.Aeson import Data.Aeson.Types import Data.Int -import Data.String -import Data.Text (Text) +import Data.Text (Text) import Data.Time import Data.Time.Clock.POSIX import Data.Typeable import Data.UUID -import Data.Vector (Vector) -import qualified Data.Vector.Generic as V +import Data.Vector (Vector) +import qualified Data.Vector.Generic as V import GHC.Generics import Network.GDAX.Parsers +import Network.GDAX.Types.Shared -- Product -newtype ProductId = ProductId { unProductId :: Text } - deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON, IsString) - -instance Show ProductId where - show = show . unProductId - data Product = Product { _prodId :: ProductId @@ -46,20 +40,14 @@ <$> o .: "id" <*> o .: "base_currency" <*> o .: "quote_currency" - <*> (o .: "base_min_size" >>= textDouble) - <*> (o .: "base_max_size" >>= textDouble) - <*> (o .: "quote_increment" >>= textDouble) + <*> (o .: "base_min_size" >>= textRead) + <*> (o .: "base_max_size" >>= textRead) + <*> (o .: "quote_increment" >>= textRead) <*> o .: "display_name" <*> o .: "margin_enabled" -- Book -newtype Sequence = Sequence { unSequence :: Int64 } - deriving (Eq, Ord, Enum, Typeable, Generic, ToJSON, FromJSON) - -instance Show Sequence where - show = show . unSequence - data AggrigateBid = AggrigateBid { _aggbidPrice :: {-# UNPACK #-} Double @@ -149,33 +137,15 @@ instance FromJSON Tick where parseJSON = withObject "Tick" $ \o -> Tick <$> o .: "trade_id" - <*> (o .: "price" >>= textDouble) - <*> (o .: "size" >>= textDouble) - <*> (o .: "bid" >>= textDouble) - <*> (o .: "ask" >>= textDouble) - <*> (o .: "volume" >>= textDouble) + <*> (o .: "price" >>= textRead) + <*> (o .: "size" >>= textRead) + <*> (o .: "bid" >>= textRead) + <*> (o .: "ask" >>= textRead) + <*> (o .: "volume" >>= textRead) <*> o .: "time" -- Trade -newtype TradeId = TradeId { unTradeId :: Int64 } - deriving (Eq, Ord, Enum, Typeable, Generic, ToJSON, FromJSON) - -instance Show TradeId where - show = show . unTradeId - -data Side - = Buy - | Sell - deriving (Show, Typeable, Generic) - -instance FromJSON Side where - parseJSON = withText "Side" $ \t -> - case t of - "buy" -> pure Buy - "sell" -> pure Sell - _ -> fail "Side was not either buy or sell." - data Trade = Trade { _tradeId :: TradeId @@ -190,8 +160,8 @@ parseJSON = withObject "Trade" $ \o -> Trade <$> o .: "trade_id" <*> o .: "time" - <*> (o .: "price" >>= textDouble) - <*> (o .: "size" >>= textDouble) + <*> (o .: "price" >>= textRead) + <*> (o .: "size" >>= textRead) <*> o .: "side" -- Candles @@ -242,12 +212,6 @@ -- Currency -newtype CurrencyId = CurrencyId { unCurrencyId :: Text } - deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON) - -instance Show CurrencyId where - show = show . unCurrencyId - data Currency = Currency { _currId :: CurrencyId @@ -260,4 +224,4 @@ parseJSON = withObject "Currency" $ \o -> Currency <$> o .: "id" <*> o .: "name" - <*> (o .: "min_size" >>= textDouble) + <*> (o .: "min_size" >>= textRead) diff --git a/lib/Network/GDAX/Types/Private.hs b/lib/Network/GDAX/Types/Private.hs new file mode 100644 --- /dev/null +++ b/lib/Network/GDAX/Types/Private.hs @@ -0,0 +1,938 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.GDAX.Types.Private where + +import Data.Aeson +import Data.HashMap.Strict (HashMap) +import Data.Int +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time +import Data.Typeable +import Data.Vector (Vector) +import GHC.Generics +import Network.GDAX.Parsers +import Network.GDAX.Types.Shared +import Text.Read (readMaybe) +import Text.Regex.TDFA +import Text.Regex.TDFA.Text () + +data Account + = Account + { _accountId :: AccountId + , _accountProfileId :: ProfileId + , _accountCurrency :: CurrencyId + , _accountBalance :: Double + , _accountAvailable :: Double + , _accountHold :: Double + , _accountMargin :: Maybe MarginAccount + } + deriving (Show, Typeable, Generic) + +data MarginAccount + = MarginAccount + { _maccountFundedAmount :: Double + , _maccountDefaultAmount :: Double + } + deriving (Show, Typeable, Generic) + +instance FromJSON Account where + parseJSON = withObject "Account" $ \o -> do Account + <$> o .: "id" + <*> o .: "profile_id" + <*> o .: "currency" + <*> (o .: "balance" >>= textRead) + <*> (o .: "available" >>= textRead) + <*> (o .: "hold" >>= textRead) + <*> do enabled <- o .:? "margin_enabled" + if enabled == (Just True) + then (\a b -> Just $ MarginAccount a b) + <$> (o .: "funded_amount" >>= textRead) + <*> (o .: "default_amount" >>= textRead) + else return Nothing + +data Entry + = Entry + { _entryId :: EntryId + , _entryType :: EntryType + , _entryCreatedAt :: UTCTime + , _entryAmount :: Double + , _entryBalance :: Double + , _entryDetails :: EntryDetails + } + deriving (Show, Typeable, Generic) + +instance FromJSON Entry where + parseJSON = withObject "Entry" $ \o -> Entry + <$> o .: "id" + <*> o .: "type" + <*> o .: "created_at" + <*> (o .: "amount" >>= textRead) + <*> (o .: "balance" >>= textRead) + <*> o .: "details" + +data EntryDetails + = EntryDetails + { _edetailsOrderId :: Maybe OrderId + , _edetailsTradeId :: Maybe TradeId + , _edetailsProductId :: Maybe ProductId + } + deriving (Show, Typeable, Generic) + +instance FromJSON EntryDetails where + parseJSON = withObject "EntryDetails" $ \o -> EntryDetails + <$> o .:? "order_id" + <*> o .:? "trade_id" + <*> o .:? "product_id" + +data Hold + = Hold + { _holdId :: HoldId + , _holdAccountId :: AccountId + , _holdCreatedAt :: UTCTime + , _holdUpdatedAt :: UTCTime + , _holdAmount :: Double + , _holdReference :: HoldReference + } + deriving (Show, Typeable, Generic) + +data HoldReference + = HoldOrder OrderId + | HoldTransfer TransferId + deriving (Show, Typeable, Generic) + +instance FromJSON Hold where + parseJSON = withObject "Hold" $ \o -> Hold + <$> o .: "id" + <*> o .: "account_id" + <*> o .: "created_at" + <*> o .: "updated_at" + <*> o .: "amount" + <*> parseRef o + where + parseRef o = do + t <- o .: "type" + case t of + "order" -> HoldOrder <$> o .: "ref" + "transfer" -> HoldTransfer <$> o .: "ref" + _ -> fail $ T.unpack $ "'" <> t <> "' is not a valid type for hold orders." + +data NewOrder + = NewOrderLimit NewLimitOrder + | NewOrderMarket NewMarketOrder + | NewOrderStop NewStopOrder + deriving (Show, Typeable, Generic) + +instance ToJSON NewOrder where + toJSON (NewOrderLimit o) = toJSON o + toJSON (NewOrderMarket o) = toJSON o + toJSON (NewOrderStop o) = toJSON o + +data NewLimitOrder + = NewLimitOrder + { _nloClientOrderId :: Maybe ClientOrderId + , _nloSide :: Side + , _nloProductId :: ProductId + , _nloSelfTradePrevention :: SelfTradePolicy + + , _nloPrice :: Double + , _nloSize :: Double + , _nloTimeInForce :: Maybe TimeInForce + , _nloCancelAfter :: Maybe CancelAfterPolicy + , _nloPostOnly :: Maybe Bool + } + deriving (Show, Typeable, Generic) + +instance ToJSON NewLimitOrder where + toJSON NewLimitOrder{..} = object + [ "client_oid" .= _nloClientOrderId + , "type" .= ("limit"::Text) + , "side" .= _nloSide + , "product_id" .= _nloProductId + , "stp" .= _nloSelfTradePrevention + , "price" .= _nloPrice + , "size" .= _nloSize + , "time_in_force" .= _nloTimeInForce + , "cancel_after" .= _nloCancelAfter + , "post_only" .= _nloPostOnly + ] + +data NewMarketOrder + = NewMarketOrder + { _nmoClientOrderId :: Maybe ClientOrderId + , _nmoSide :: Side + , _nmoProductId :: ProductId + , _nmoSelfTradePrevention :: SelfTradePolicy + + , _nmoMarketDesire :: MarketDesire + } + deriving (Show, Typeable, Generic) + +instance ToJSON NewMarketOrder where + toJSON NewMarketOrder{..} = object $ + [ "client_oid" .= _nmoClientOrderId + , "type" .= ("market"::Text) + , "side" .= _nmoSide + , "product_id" .= _nmoProductId + , "stp" .= _nmoSelfTradePrevention + ] <> case _nmoMarketDesire of + (DesireSize s) -> [ "size" .= s ] + (DesireFunds f) -> [ "funds" .= f ] + +data NewStopOrder + = NewStopOrder + { _nsoClientOrderId :: Maybe ClientOrderId + , _nsoSide :: Side + , _nsoProductId :: ProductId + , _nsoSelfTradePrevention :: SelfTradePolicy + + , _nsoPrice :: Double + , _nsoMarketDesire :: MarketDesire + } + deriving (Show, Typeable, Generic) + +instance ToJSON NewStopOrder where + toJSON NewStopOrder{..} = object $ + [ "client_oid" .= _nsoClientOrderId + , "type" .= ("stop"::Text) + , "side" .= _nsoSide + , "product_id" .= _nsoProductId + , "stp" .= _nsoSelfTradePrevention + , "price" .= _nsoPrice + ] <> case _nsoMarketDesire of + (DesireSize s) -> [ "size" .= s ] + (DesireFunds f) -> [ "funds" .= f ] + +data MarketDesire + = DesireSize Double -- ^ Desired amount in commodity (e.g. BTC) + | DesireFunds Double -- ^ Desired amount in quote currency (e.g. USD) + deriving (Show, Typeable, Generic) + +data TimeInForce + = GoodTillCanceled + | GoodTillTime + | ImmediateOrCancel + | FillOrKill + deriving (Eq, Ord, Typeable, Generic) + +instance Show TimeInForce where + show GoodTillCanceled = "GTC" + show GoodTillTime = "GTT" + show ImmediateOrCancel = "IOC" + show FillOrKill = "FOK" + +instance ToJSON TimeInForce where + toJSON = String . T.pack . show + +instance FromJSON TimeInForce where + parseJSON = withText "TimeInForce" $ \t -> + case t of + "GTC" -> pure GoodTillCanceled + "GTT" -> pure GoodTillTime + "IOC" -> pure ImmediateOrCancel + "FOK" -> pure FillOrKill + _ -> fail $ T.unpack $ "'" <> t <> "' is not a valid time in force." + +data SelfTradePolicy + = DecreaseOrCancel + | CancelOldest + | CancelNewest + | CancelBoth + deriving (Eq, Ord, Typeable, Generic) + +instance Show SelfTradePolicy where + show DecreaseOrCancel = "dc" + show CancelOldest = "co" + show CancelNewest = "cn" + show CancelBoth = "cb" + +instance ToJSON SelfTradePolicy where + toJSON = String . T.pack . show + +instance FromJSON SelfTradePolicy where + parseJSON = withText "SelfTradePolicy" $ \t -> + case t of + "dc" -> pure DecreaseOrCancel + "co" -> pure CancelOldest + "cn" -> pure CancelNewest + "cb" -> pure CancelBoth + _ -> fail $ T.unpack $ "'" <> t <> "' is not a valid self trade policy." + +data CancelAfterPolicy + = CancelAfterMinutes Word + | CancelAfterHours Word + | CancelAfterDays Word + deriving (Typeable, Generic) + +instance Show CancelAfterPolicy where + show (CancelAfterMinutes w) = show w <> " mintes" + show (CancelAfterHours w) = show w <> " hours" + show (CancelAfterDays w) = show w <> " days" + +instance ToJSON CancelAfterPolicy where + toJSON = String . T.pack . show + +instance FromJSON CancelAfterPolicy where + parseJSON = withText "CancelAfterPolicy" $ \t -> + case t =~ ("([0-9]+) (days|minutes|hours)"::Text) of + ((_, _, _, [mv, mtag]) :: (Text, Text, Text, [Text])) -> + case readMaybe $ T.unpack mv of + Just v -> + case mtag of + "minutes" -> pure $ CancelAfterMinutes v + "hours" -> pure $ CancelAfterHours v + "days" -> pure $ CancelAfterDays v + _ -> fail $ T.unpack $ "'" <> mtag <> "' was not 'minutes', 'hours', or 'days'." + Nothing -> fail $ T.unpack $ "'" <> mv <> "' could not be parsed as a word." + _ -> fail $ T.unpack $ "'" <> t <> "' did not match regex validation." + +-- data NewMarginOrder -- Implement with the rest of margin accounts. +-- = NewMarginOrder +-- { +-- } +-- deriving (Show, Typeable, Generic) + +data NewOrderConfirmation + = NewOrderConfirmation + { _nocOrderId :: OrderId + } + deriving (Show, Typeable, Generic) + +instance FromJSON NewOrderConfirmation where + parseJSON = withObject "NewOrderConfirmation" $ \o -> NewOrderConfirmation + <$> o .: "id" + +data Order + = Order + { _orderId :: OrderId + , _orderPrice :: Double + , _orderSize :: Double + , _orderProductId :: ProductId + , _orderSide :: Side + , _orderSelfTradePrevention :: SelfTradePolicy + , _orderType :: OrderType + , _orderTimeInForce :: TimeInForce + , _orderPostOnly :: Bool + , _orderCreatedAt :: UTCTime + , _orderFillFees :: Double + , _orderFilledSize :: Double + , _orderExecutedValue :: Double + , _orderStatus :: OrderStatus + , _orderSettled :: Bool + } + deriving (Show, Typeable, Generic) + +instance FromJSON Order where + parseJSON = withObject "Order" $ \o -> Order + <$> o .: "id" + <*> o .: "price" + <*> o .: "size" + <*> o .: "product_id" + <*> o .: "side" + <*> o .: "stp" + <*> o .: "type" + <*> o .: "time_in_force" + <*> o .: "post_only" + <*> o .: "created_at" + <*> o .: "fill_fees" + <*> o .: "filled_size" + <*> o .: "executed_value" + <*> o .: "status" + <*> o .: "settled" + +data Fill + = Fill + { _fillTradeId :: TradeId + , _fillProductId :: ProductId + , _fillPrice :: Double + , _fillSize :: Double + , _fillOrderId :: OrderId + , _fillCreatedAt :: UTCTime + , _fillLiquidity :: Liquidity + , _fillFee :: Double + , _fillSettled :: Bool + , _fillSide :: Side + } + deriving (Show, Typeable, Generic) + +instance FromJSON Fill where + parseJSON = withObject "Fill" $ \o -> Fill + <$> o .: "trade_id" + <*> o .: "product_id" + <*> o .: "price" + <*> o .: "size" + <*> o .: "order_id" + <*> o .: "created_at" + <*> o .: "liquidity" + <*> o .: "fee" + <*> o .: "settled" + <*> o .: "side" + +data Funding + = Funding + { _fundingId :: FundingId + , _fundingOrderId :: OrderId + , _fundingProfileId :: ProfileId + , _fundingAmount :: Double + , _fundingStatus :: FundingStatus + , _fundingCreatedAt :: UTCTime + , _fundingCurrency :: CurrencyId + , _fundingRepaidAmount :: Double + , _fundingDefaultAmount :: Double + , _fundingRepaidDefault :: Bool + } + deriving (Show, Typeable, Generic) + +instance FromJSON Funding where + parseJSON = withObject "Funding" $ \o -> Funding + <$> o .: "id" + <*> o .: "order_id" + <*> o .: "profile_id" + <*> o .: "amount" + <*> o .: "status" + <*> o .: "created_at" + <*> o .: "currency" + <*> o .: "repaid_amount" + <*> o .: "default_amount" + <*> o .: "repaid_default" + +data NewMarginTransfer + = NewMarginTransfer + { _nmtMarginProfileId :: ProfileId + , _nmtType :: MarginType + , _nmtCurrency :: CurrencyId + , _nmtAmount :: Double + } + deriving (Show, Typeable, Generic) + +instance ToJSON NewMarginTransfer where + toJSON NewMarginTransfer{..} = object + [ "margin_profile_id" .= _nmtMarginProfileId + , "type" .= _nmtType + , "currency" .= _nmtCurrency + , "amount" .= _nmtAmount + ] + +data MarginTransfer + = MarginTransfer + { _mtCreatedAt :: UTCTime + , _mtId :: MarginTransferId + , _mtUserId :: UserId + , _mtProfileId :: ProfileId + , _mtMarginProfileId :: ProfileId + , _mtType :: MarginType + , _mtAmount :: Double + , _mtCurrency :: CurrencyId + , _mtAccountId :: AccountId + , _mtMarginAccountId :: AccountId + , _mtMarginProductId :: ProductId + , _mtStatus :: MarginStatus + , _mtNonce :: Int64 + } + deriving (Show, Typeable, Generic) + +instance FromJSON MarginTransfer where + parseJSON = withObject "MarginTransfer" $ \o -> MarginTransfer + <$> o .: "created_at" + <*> o .: "id" + <*> o .: "user_id" + <*> o .: "profile_id" + <*> o .: "margin_profile_id" + <*> o .: "type" + <*> o .: "amount" + <*> o .: "currency" + <*> o .: "accountId" + <*> o .: "margin_account_id" + <*> o .: "margin_product_id" + <*> o .: "status" + <*> o .: "nonce" + +data Position + = Position + { _posStatus :: PositionStatus + , _posFunding :: PositionFunding + , _posAccounts :: HashMap Text PositionAccount -- ^ Text should be CurrencyId, but it will have to be fixed later. + , _posMarginCall :: MarginCall + , _posUserId :: UserId + , _posProfileId :: ProfileId + , _posPositionInfo :: PositionInfo + , _posProductId :: ProductId + } + deriving (Show, Typeable, Generic) + +instance FromJSON Position where + parseJSON = withObject "Position" $ \o -> Position + <$> o .: "status" + <*> o .: "funding" + <*> o .: "accounts" + <*> o .: "margin_call" + <*> o .: "user_id" + <*> o .: "profile_id" + <*> o .: "position" + <*> o .: "product_id" + +data PositionFunding + = PositionFunding + { _posfunMaxFundingValue :: Double + , _posfunFundingValue :: Double + , _posfunOldestOutstanding :: OutstandingFunding + } + deriving (Show, Typeable, Generic) + +instance FromJSON PositionFunding where + parseJSON = withObject "PositionFunding" $ \o -> PositionFunding + <$> o .: "max_funding_value" + <*> o .: "funding_value" + <*> o .: "oldest_outstanding" + +data OutstandingFunding + = OutstandingFunding + { _ofunId :: FundingId + , _ofunOrderId :: OrderId + , _ofunCreatedAt :: UTCTime + , _ofunCurrency :: CurrencyId + , _ofunAccountId :: AccountId + , _ofunAmount :: Double + } + deriving (Show, Typeable, Generic) + +instance FromJSON OutstandingFunding where + parseJSON = withObject "OutstandingFunding" $ \o -> OutstandingFunding + <$> o .: "id" + <*> o .: "order_id" + <*> o .: "created_at" + <*> o .: "currency" + <*> o .: "account_id" + <*> o .: "amount" + +data PositionAccount + = PositionAccount + { _paccountId :: AccountId + , _paccountBalance :: Double + , _paccountHold :: Double + , _paccountFundedAmount :: Double + , _paccountDefaultAmount :: Double + } + deriving (Show, Typeable, Generic) + +instance FromJSON PositionAccount where + parseJSON = withObject "PositionAccount" $ \o -> PositionAccount + <$> o .: "id" + <*> o .: "balance" + <*> o .: "hold" + <*> o .: "funded_amount" + <*> o .: "default_amount" + +data MarginCall + = MarginCall + { _mcallActive :: Bool + , _mcallPrice :: Double + , _mcallSide :: Side + , _mcallSize :: Double + , _mcallFunds :: Double + } + deriving (Show, Typeable, Generic) + +instance FromJSON MarginCall where + parseJSON = withObject "MarginCall" $ \o -> MarginCall + <$> o .: "active" + <*> o .: "price" + <*> o .: "side" + <*> o .: "size" + <*> o .: "funds" + +data PositionInfo + = PositionInfo + { _pinfoType :: PositionType + , _pinfoSize :: Double + , _pinfoComplement :: Double + , _pinfoMaxSize :: Double + } + deriving (Show, Typeable, Generic) + +instance FromJSON PositionInfo where + parseJSON = withObject "PositionInfo" $ \o -> PositionInfo + <$> o .: "type" + <*> o .: "size" + <*> o .: "complement" + <*> o .: "max_size" + +data Deposit + = Deposit + { _depositAmount :: Double + , _depositCurrency :: CurrencyId + , _depositPaymentMethod :: PaymentMethodId + } + deriving (Show, Typeable, Generic) + +instance ToJSON Deposit where + toJSON Deposit{..} = object + [ "amount" .= _depositAmount + , "currency" .= _depositCurrency + , "payment_method_id" .= _depositPaymentMethod + ] + +data DepositReceipt + = DepositReceipt + { _dreceiptId :: DepositId + , _dreceiptAmount :: Double + , _dreceiptCurrency :: CurrencyId + , _dreceiptPayoutAt :: UTCTime + } + deriving (Show, Typeable, Generic) + +instance FromJSON DepositReceipt where + parseJSON = withObject "DepositReceipt" $ \o -> DepositReceipt + <$> o .: "id" + <*> (o .: "amount" >>= textRead) + <*> o .: "currency" + <*> o .: "payput_at" + +data CoinbaseDeposit + = CoinbaseDeposit + { _cdepositAmount :: Double + , _cdepositCurrency :: CurrencyId + , _cdepositCoinbaseAccount :: AccountId + } + deriving (Show, Typeable, Generic) + +instance ToJSON CoinbaseDeposit where + toJSON CoinbaseDeposit{..} = object + [ "amount" .= _cdepositAmount + , "currency" .= _cdepositCurrency + , "coinbase_account_id" .= _cdepositCoinbaseAccount + ] + +data CoinbaseDepositReceipt + = CoinbaseDepositReceipt + { _cdreceiptId :: DepositId + , _cdreceiptAmount :: Double + , _cdreceiptCurrency :: CurrencyId + } + deriving (Show, Typeable, Generic) + +instance FromJSON CoinbaseDepositReceipt where + parseJSON = withObject "CoinbaseDepositReceipt" $ \o -> CoinbaseDepositReceipt + <$> o .: "id" + <*> (o .: "amount" >>= textRead) + <*> o .: "currency" + +data Withdraw + = Withdraw + { _withdrawAmount :: Double + , _withdrawCurrency :: CurrencyId + , _withdrawPaymentMethod :: PaymentMethodId + } + deriving (Show, Typeable, Generic) + +instance ToJSON Withdraw where + toJSON Withdraw{..} = object + [ "amount" .= _withdrawAmount + , "currency" .= _withdrawCurrency + , "payment_method_id" .= _withdrawPaymentMethod + ] + +data WithdrawReceipt + = WithdrawReceipt + { _wreceiptId :: WithdrawId + , _wreceiptAmount :: Double + , _wreceiptCurrency :: CurrencyId + , _wreceiptPayoutAt :: UTCTime + } + deriving (Show, Typeable, Generic) + +instance FromJSON WithdrawReceipt where + parseJSON = withObject "WithdrawReceipt" $ \o -> WithdrawReceipt + <$> o .: "id" + <*> (o .: "amount" >>= textRead) + <*> o .: "currency" + <*> o .: "payout_at" + +data CoinbaseWithdraw + = CoinbaseWithdraw + { _cwithdrawAmount :: Double + , _cwithdrawCurrency :: CurrencyId + , _cwithdrawCoinbaseAccount :: AccountId + } + deriving (Show, Typeable, Generic) + +instance ToJSON CoinbaseWithdraw where + toJSON CoinbaseWithdraw{..} = object + [ "amount" .= _cwithdrawAmount + , "currency" .= _cwithdrawCurrency + , "coinbase_account_id" .= _cwithdrawCoinbaseAccount + ] + +data CoinbaseWithdrawReceipt + = CoinbaseWithdrawReceipt + { _cwreceiptId :: WithdrawId + , _cwreceiptAmount :: Double + , _cwreceiptCurrency :: CurrencyId + } + deriving (Show, Typeable, Generic) + +instance FromJSON CoinbaseWithdrawReceipt where + parseJSON = withObject "CoinbaseWithdrawReceipt" $ \o -> CoinbaseWithdrawReceipt + <$> o .: "id" + <*> (o .: "amount" >>= textRead) + <*> o .: "currency" + +data CryptoWithdraw + = CryptoWithdraw + { _crwithdrawAmount :: Double + , _crwithdrawCurrency :: CurrencyId + , _crwithdrawCoinbaseAccount :: AccountId + } + deriving (Show, Typeable, Generic) + +instance ToJSON CryptoWithdraw where + toJSON CryptoWithdraw{..} = object + [ "amount" .= _crwithdrawAmount + , "currency" .= _crwithdrawCurrency + , "payment_method_id" .= _crwithdrawCoinbaseAccount + ] + +data CryptoWithdrawReceipt + = CryptoWithdrawReceipt + { _crwreceiptId :: WithdrawId + , _crwreceiptAmount :: Double + , _crwreceiptCurrency :: CurrencyId + } + deriving (Show, Typeable, Generic) + +instance FromJSON CryptoWithdrawReceipt where + parseJSON = withObject "CryptoWithdrawReceipt" $ \o -> CryptoWithdrawReceipt + <$> o .: "id" + <*> (o .: "amount" >>= textRead) + <*> o .: "currency" + +data PaymentMethod + = PaymentMethod + { _pmethId :: PaymentMethodId + , _pmethType :: PaymentMethodType + , _pmethName :: Text + , _pmethCurrency :: CurrencyId + , _pmethPrimaryBuy :: Bool + , _pmethPrimarySell :: Bool + , _pmethAllowBuy :: Bool + , _pmethAllowSell :: Bool + , _pmethAllowDeposit :: Bool + , _pmethAllowWithdraw :: Bool + , _pmethLimits :: Limits + } + deriving (Show, Typeable, Generic) + +instance FromJSON PaymentMethod where + parseJSON = withObject "PaymentMethod" $ \o -> PaymentMethod + <$> o .: "id" + <*> o .: "type" + <*> o .: "name" + <*> o .: "currency" + <*> o .: "primary_buy" + <*> o .: "primary_sell" + <*> o .: "allow_buy" + <*> o .: "allow_sell" + <*> o .: "allow_deposit" + <*> o .: "allow_withdraw" + <*> o .: "limits" + +data Limits + = Limits + { _limitsBuy :: Vector Limit + , _limitsInstantBuy :: Vector Limit + , _limitsSell :: Vector Limit + , _limitsDeposit :: Vector Limit + } + deriving (Show, Typeable, Generic) + +instance FromJSON Limits where + parseJSON = withObject "Limits" $ \o -> Limits + <$> (nothingToEmptyVector <$> o .:? "buy") + <*> (nothingToEmptyVector <$> o .:? "instant_buy") + <*> (nothingToEmptyVector <$> o .:? "sell") + <*> (nothingToEmptyVector <$> o .:? "deposit") + +data Limit + = Limit + { _limitPeriodInDays :: Word + , _limitTotal :: LimitValue + , _limitRemaining :: LimitValue + } + deriving (Show, Typeable, Generic) + +instance FromJSON Limit where + parseJSON = withObject "Limit" $ \o -> Limit + <$> o .: "period_in_days" + <*> o .: "total" + <*> o .: "remaining" + +data LimitValue + = LimitValue + { _lvalAmount :: Double + , _lvalCurrency :: CurrencyId + } + deriving (Show, Typeable, Generic) + +instance FromJSON LimitValue where + parseJSON = withObject "LimitValue" $ \o -> LimitValue + <$> (o .: "amount" >>= textRead) + <*> o .: "currency" + +data CoinbaseAccount + = CoinbaseAccount + { _cbaccountId :: AccountId + , _cbaccountName :: Text + , _cbaccountBalance :: Double + , _cbaccountCurrency :: CurrencyId + , _cbaccountType :: CoinbaseAccountType + , _cbaccountPrimary :: Bool + , _cbaccountActive :: Bool + , _cbaccountWireDepositInfo :: Maybe WireDepositInfo + , _cbaccountSepaDepositInfo :: Maybe SepaDepositInfo + } + deriving (Show, Typeable, Generic) + +instance FromJSON CoinbaseAccount where + parseJSON = withObject "CoinbaseAccount" $ \o -> CoinbaseAccount + <$> o .: "id" + <*> o .: "name" + <*> (o .: "balance" >>= textRead) + <*> o .: "currency" + <*> o .: "type" + <*> o .: "primary" + <*> o .: "active" + <*> o .:? "wire_deposit_information" + <*> o .:? "sepa_deposit_information" + +data WireDepositInfo + = WireDepositInfo + { _wdiAccountNumber :: Integer + , _wdiRoutingNumber :: Integer + , _wdiBankName :: Text + , _wdiBankAddress :: Text + , _wdiBankCountry :: Country + , _wdiAccountName :: Text + , _wdiAccountAddress :: Text + , _wdiReference :: Text + } + deriving (Show, Typeable, Generic) + +instance FromJSON WireDepositInfo where + parseJSON = withObject "WireDepositInfo" $ \o -> WireDepositInfo + <$> (o .: "account_number" >>= textRead) + <*> (o .: "routing_number" >>= textRead) + <*> o .: "bank_name" + <*> o .: "bank_address" + <*> o .: "bank_country" + <*> o .: "account_name" + <*> o .: "account_address" + <*> o .: "reference" + +data Country + = Country + { _countryCode :: Text + , _countryName :: Text + } + deriving (Show, Typeable, Generic) + +instance FromJSON Country where + parseJSON = withObject "Country" $ \o -> Country + <$> o .: "code" + <*> o .: "name" + +data SepaDepositInfo + = SepaDepositInfo + { _sepaIban :: Text + , _sepaSwift :: Text + , _sepaBankName :: Text + , _sepaBankAddress :: Text + , _sepaBankCountryName :: Text + , _sepaAccountName :: Text + , _sepaAccountAddress :: Text + , _sepaReference :: Text + } + deriving (Show, Typeable, Generic) + +instance FromJSON SepaDepositInfo where + parseJSON = withObject "SepaDepositInfo" $ \o -> SepaDepositInfo + <$> o .: "iban" + <*> o .: "swift" + <*> o .: "bank_name" + <*> o .: "bank_address" + <*> o .: "bank_country_name" + <*> o .: "account_name" + <*> o .: "account_address" + <*> o .: "reference" + +data NewReport + = NewReport + { _nreportType :: ReportType + , _nreportStartDate :: UTCTime + , _nreportEndDate :: UTCTime + } + deriving (Show, Typeable, Generic) + +instance ToJSON NewReport where + toJSON NewReport{..} = object + [ "type" .= _nreportType + , "start_date" .= _nreportStartDate + , "end_date" .= _nreportEndDate + ] + +data Report + = Report + { _reportId :: ReportId + , _reportType :: ReportType + , _reportStatus :: ReportStatus + , _reportCreatedAt :: UTCTime + , _reportCompletedAt :: Maybe UTCTime + , _reportExpiresAt :: UTCTime + , _reportFileUrl :: Maybe Text + , _reportParams :: ReportParams + } + deriving (Show, Typeable, Generic) + +instance FromJSON Report where + parseJSON = withObject "Report" $ \o -> Report + <$> o .: "id" + <*> o .: "type" + <*> o .: "status" + <*> o .: "created_at" + <*> o .: "completed_at" + <*> o .: "expires_at" + <*> o .: "file_url" + <*> o .: "params" + +data ReportParams + = ReportParams + { _rparamStartDate :: UTCTime + , _rparamEndDate :: UTCTime + } + deriving (Show, Typeable, Generic) + +instance FromJSON ReportParams where + parseJSON = withObject "ReportParmas" $ \o -> ReportParams + <$> o .: "start_date" + <*> o .: "end_date" + +data TrailingVolume + = TrailingVolume + { _tvProductId :: ProductId + , _tvExchangeVolume :: Double + , _tvVolume :: Double + , _tvRecorededAt :: UTCTime + } + deriving (Show, Typeable, Generic) + +instance FromJSON TrailingVolume where + parseJSON = withObject "TrailingVolume" $ \o -> TrailingVolume + <$> o .: "product_id" + <*> o .: "exchange_volume" + <*> o .: "volume" + <*> o .: "recorded_at" diff --git a/lib/Network/GDAX/Types/Shared.hs b/lib/Network/GDAX/Types/Shared.hs new file mode 100644 --- /dev/null +++ b/lib/Network/GDAX/Types/Shared.hs @@ -0,0 +1,456 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.GDAX.Types.Shared where + +import Data.Aeson +import Data.Hashable +import Data.Int +import Data.Monoid +import Data.Scientific +import Data.String +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable +import Data.UUID +import GHC.Generics +import Text.Read (readMaybe) + +newtype AccountId = AccountId { unAccountId :: UUID } + deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON, Hashable) + +instance Show AccountId where + show = show . unAccountId + +newtype UserId = UserId { unUserId :: Text } + deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON, IsString, Hashable) + +instance Show UserId where + show = T.unpack . unUserId + +newtype ProfileId = ProfileId { unProfileId :: UUID } + deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON, Hashable) + +instance Show ProfileId where + show = show . unProfileId + +newtype OrderId = OrderId { unOrderId :: UUID } + deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON, Hashable) + +instance Show OrderId where + show = show . unOrderId + + +data OrderType + = OrderLimit + | OrderMarket + deriving (Typeable, Generic) + +instance Hashable OrderType + +instance Show OrderType where + show OrderLimit = "limit" + show OrderMarket = "market" + +instance FromJSON OrderType where + parseJSON = withText "OrderType" $ \t -> + case t of + "limit" -> pure OrderLimit + "market" -> pure OrderMarket + _ -> fail $ T.unpack $ "'" <> t <> "' is not a valid order type." + +newtype StopType = StopType { unStopType :: Text } + deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON, IsString, Hashable) + +instance Show StopType where + show = T.unpack . unStopType + +newtype ProductId = ProductId { unProductId :: Text } + deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON, IsString, Hashable) + +instance Show ProductId where + show = T.unpack . unProductId + +newtype Sequence = Sequence { unSequence :: Int64 } + deriving (Eq, Ord, Enum, Typeable, Generic, ToJSON, FromJSON, Hashable) + +instance Show Sequence where + show = show . unSequence + +newtype TradeId = TradeId { unTradeId :: Int64 } + deriving (Eq, Ord, Enum, Typeable, Generic, Hashable) + +instance Show TradeId where + show = show . unTradeId + +instance FromJSON TradeId where + parseJSON (String s) = case readMaybe $ T.unpack s of + Nothing -> fail "TradeId string could not be read as integer." + Just v -> pure $ TradeId v + parseJSON (Number n) = case toBoundedInteger n of + Nothing -> fail "TradeId scientific could not be converted into an integer." + Just v -> pure $ TradeId v + parseJSON _ = fail "TradeId can only accept a number or string." + +data Side + = Buy + | Sell + deriving (Typeable, Generic) + +instance Hashable Side + +instance Show Side where + show Buy = "buy" + show Sell = "sell" + +instance ToJSON Side where + toJSON = String . T.pack . show + +instance FromJSON Side where + parseJSON = withText "Side" $ \t -> + case t of + "buy" -> pure Buy + "sell" -> pure Sell + _ -> fail "Side was not either buy or sell." + +newtype CurrencyId = CurrencyId { unCurrencyId :: Text } + deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON, IsString, Hashable) + +instance Show CurrencyId where + show = T.unpack . unCurrencyId + +newtype EntryId = EntryId { unEntryId :: Int64 } + deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON, Hashable) + +instance Show EntryId where + show = show . unEntryId + +data EntryType + = EntryMatch + | EntryFee + | EntryTransfer + deriving (Eq, Typeable, Generic) + +instance Hashable EntryType + +instance Show EntryType where + show EntryMatch = "match" + show EntryFee = "fee" + show EntryTransfer = "transfer" + +instance FromJSON EntryType where + parseJSON = withText "EntryType" $ \t -> + case t of + "match" -> pure EntryMatch + "fee" -> pure EntryFee + "transfer" -> pure EntryTransfer + _ -> fail $ T.unpack $ "'" <> t <> "' is not a valid entry type." + +newtype TransferId = TransferId { unTransferId :: UUID } + deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON, Hashable) + +instance Show TransferId where + show = show . unTransferId + +newtype HoldId = HoldId { unHoldId :: UUID } + deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON, Hashable) + +instance Show HoldId where + show = show . unHoldId + +newtype ClientOrderId = ClientOrderId { unClientOrderId :: UUID } + deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON, Hashable) + +instance Show ClientOrderId where + show = show . unClientOrderId + +data OrderStatus + = OrderOpen + | OrderPending + | OrderActive + | OrderDone + | OrderSettled + deriving (Typeable, Generic) + +instance Hashable OrderStatus + +instance Show OrderStatus where + show OrderOpen = "open" + show OrderPending = "pending" + show OrderActive = "active" + show OrderDone = "done" + show OrderSettled = "settled" + +instance ToJSON OrderStatus where + toJSON = String . T.pack . show + +instance FromJSON OrderStatus where + parseJSON = withText "OrderStatus" $ \s -> + case s of + "open" -> pure OrderOpen + "pending" -> pure OrderPending + "active" -> pure OrderActive + "done" -> pure OrderDone + "settled" -> pure OrderSettled + _ -> fail $ T.unpack $ "'" <> s <> "' is not a valid order status." + +data Liquidity + = LiquidityMaker + | LiquidityTaker + deriving (Typeable, Generic) + +instance Hashable Liquidity + +instance Show Liquidity where + show LiquidityMaker = "M" + show LiquidityTaker = "T" + +instance ToJSON Liquidity where + toJSON = String . T.pack . show + +instance FromJSON Liquidity where + parseJSON = withText "Liquidity" $ \t -> + case t of + "M" -> pure LiquidityMaker + "T" -> pure LiquidityTaker + _ -> fail $ T.unpack $ "'" <> t <> "' is not a valid liquidity." + +newtype FundingId = FundingId { unFundingId :: UUID } + deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON, Hashable) + +instance Show FundingId where + show = show . unFundingId + +data FundingStatus + = FundingOutstanding + | FundingSettled + | FundingRejected + deriving (Typeable, Generic) + +instance Hashable FundingStatus + +instance Show FundingStatus where + show FundingOutstanding = "outstanding" + show FundingSettled = "settled" + show FundingRejected = "rejected" + +instance ToJSON FundingStatus where + toJSON = String . T.pack . show + +instance FromJSON FundingStatus where + parseJSON = withText "FundingStatus" $ \t -> + case t of + "outstanding" -> pure FundingOutstanding + "settled" -> pure FundingSettled + "rejected" -> pure FundingRejected + _ -> fail $ T.unpack $ "'" <> t <> "' is not a valid funding status." + +data MarginType + = MarginDeposit + | MarginWithdraw + deriving (Typeable, Generic) + +instance Hashable MarginType + +instance Show MarginType where + show MarginDeposit = "deposit" + show MarginWithdraw = "withdraw" + +instance ToJSON MarginType where + toJSON = String . T.pack . show + +instance FromJSON MarginType where + parseJSON = withText "MarginType" $ \t -> + case t of + "deposit" -> pure MarginDeposit + "withdraw" -> pure MarginWithdraw + _ -> fail $ T.unpack $ "'" <> t <> "' is not a valid margin type." + +newtype MarginTransferId = MarginTransferId { unMarginTransferId :: UUID } + deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON, Hashable) + +instance Show MarginTransferId where + show = show . unMarginTransferId + +data MarginStatus + = MarginCompleted + deriving (Typeable, Generic) + +instance Hashable MarginStatus + +instance Show MarginStatus where + show MarginCompleted = "completed" + +instance ToJSON MarginStatus where + toJSON = String . T.pack . show + +instance FromJSON MarginStatus where + parseJSON = withText "MarginStatus" $ \t -> + case t of + "completed" -> pure MarginCompleted + _ -> fail $ T.unpack $ "'" <> t <> "' is not a valid margin status." + +data PositionStatus + = PositionActive + | PositionPending + | PositionLocked + | PositionDefault + deriving (Typeable, Generic) + +instance Hashable PositionStatus + +instance Show PositionStatus where + show PositionActive = "active" + show PositionPending = "pending" + show PositionLocked = "locked" + show PositionDefault = "default" + +instance ToJSON PositionStatus where + toJSON = String . T.pack . show + +instance FromJSON PositionStatus where + parseJSON = withText "PositionStatus" $ \t -> + case t of + "active" -> pure PositionActive + "pending" -> pure PositionPending + "locked" -> pure PositionLocked + "default" -> pure PositionDefault + _ -> fail $ T.unpack $ "'" <> t <> "' is not a valid margin status." + +data PositionType + = PositionLong + | PositionShort + deriving (Typeable, Generic) + +instance Hashable PositionType + +instance Show PositionType where + show PositionLong = "long" + show PositionShort = "short" + +instance ToJSON PositionType where + toJSON = String . T.pack . show + +instance FromJSON PositionType where + parseJSON = withText "PositionType" $ \t -> + case t of + "long" -> pure PositionLong + "short" -> pure PositionShort + _ -> fail $ T.unpack $ "'" <> t <> "' is not a valid margin status." + +newtype PaymentMethodId = PaymentMethodId { unPaymentMethodId :: UUID } + deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON, Hashable) + +instance Show PaymentMethodId where + show = show . unPaymentMethodId + +newtype DepositId = DepositId { unDepositId :: UUID } + deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON, Hashable) + +instance Show DepositId where + show = show . unDepositId + +newtype WithdrawId = WithdrawId { unWithdrawId :: UUID } + deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON, Hashable) + +instance Show WithdrawId where + show = show . unWithdrawId + +data PaymentMethodType + = MethodFiatAccount + | MethodBankWire + | MethodACHBankAccount + deriving (Eq, Ord, Typeable, Generic) + +instance Hashable PaymentMethodType + +instance Show PaymentMethodType where + show MethodFiatAccount = "fiat_account" + show MethodBankWire = "bank_wire" + show MethodACHBankAccount = "ach_bank_account" + +instance ToJSON PaymentMethodType where + toJSON = String . T.pack . show + +instance FromJSON PaymentMethodType where + parseJSON = withText "PaymentMethodType" $ \t -> + case t of + "fiat_account" -> pure MethodFiatAccount + "bank_wire" -> pure MethodBankWire + "ach_bank_account" -> pure MethodACHBankAccount + _ -> fail $ T.unpack $ "'" <> t <> "' is not a valid payment method type." + +data CoinbaseAccountType + = CBTypeWallet + | CBTypeFiat + deriving (Typeable, Generic) + +instance Hashable CoinbaseAccountType + +instance Show CoinbaseAccountType where + show CBTypeWallet = "wallet" + show CBTypeFiat = "fiat" + +instance ToJSON CoinbaseAccountType where + toJSON = String . T.pack . show + +instance FromJSON CoinbaseAccountType where + parseJSON = withText "CoinbaseAccountType" $ \t -> + case t of + "wallet" -> pure CBTypeWallet + "fiat" -> pure CBTypeFiat + _ -> fail $ T.unpack $ "'" <> t <> "' is not a valid coinbase account type." + +newtype ReportId = ReportId { unReportId :: UUID } + deriving (Eq, Ord, Typeable, Generic, ToJSON, FromJSON, Hashable) + +instance Show ReportId where + show = show . unReportId + +data ReportType + = ReportFills + | ReportAccount + deriving (Typeable, Generic) + +instance Hashable ReportType + +instance Show ReportType where + show ReportFills = "fills" + show ReportAccount = "account" + +instance ToJSON ReportType where + toJSON = String . T.pack . show + +instance FromJSON ReportType where + parseJSON = withText "ReportType" $ \t -> + case t of + "fills" -> pure ReportFills + "account" -> pure ReportAccount + _ -> fail $ T.unpack $ "'" <> t <> "' is not a valid report type." + +data ReportStatus + = ReportPending + | ReportCreating + | ReportReady + deriving (Typeable, Generic) + +instance Hashable ReportStatus + +instance Show ReportStatus where + show ReportPending = "pending" + show ReportCreating = "creating" + show ReportReady = "ready" + +instance ToJSON ReportStatus where + toJSON = String . T.pack . show + +instance FromJSON ReportStatus where + parseJSON = withText "ReportStatus" $ \t -> + case t of + "pending" -> pure ReportPending + "creating" -> pure ReportCreating + "ready" -> pure ReportReady + _ -> fail $ T.unpack $ "'" <> t <> "' is not a valid report status." + diff --git a/test/Network/GDAX/Test/Feed.hs b/test/Network/GDAX/Test/Feed.hs --- a/test/Network/GDAX/Test/Feed.hs +++ b/test/Network/GDAX/Test/Feed.hs @@ -6,36 +6,37 @@ ) where import Control.Lens -import Data.Aeson (FromJSON (..)) -import Data.Aeson (Value (..)) -import qualified Data.Aeson as Aeson +import Data.Aeson (FromJSON (..)) +import Data.Aeson (Value (..)) +import qualified Data.Aeson as Aeson import Data.Aeson.Lens -import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy as LBS import Data.Proxy -import qualified Data.Set as Set -import Data.Text (Text) -import qualified Data.Text as T -import Data.Vector (Vector) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import Data.Vector (Vector) +import Network.GDAX.Core import Network.GDAX.Test.Types import Network.GDAX.Types.Feed -import Network.GDAX.Types.MarketData (ProductId) +import Network.GDAX.Types.Shared import Network.WebSockets import Test.Tasty import Test.Tasty.HUnit import Wuss tests :: Env -> TestTree -tests e = testGroup "Feed Parse" - [ parseTestClient (mkBTCSub [ChannelHeartbeat]) "heartbeat" (Proxy :: Proxy Heartbeat) - , parseTestClient (mkBTCSub [ChannelTicker]) "ticker" (Proxy :: Proxy Ticker) - , parseTestClient (mkBTCSub [ChannelLevel2]) "snapshot" (Proxy :: Proxy Level2Snapshot) - , parseTestClient (mkBTCSub [ChannelLevel2]) "l2update" (Proxy :: Proxy Level2Update) - , parseTestClient (mkBTCSub [ChannelMatches]) "last_match" (Proxy :: Proxy Match) - , parseTestClient (mkBTCSub [ChannelMatches]) "match" (Proxy :: Proxy Match) - , parseTestClient (mkBTCSub [ChannelFull]) "received" (Proxy :: Proxy Received) - , parseTestClient (mkBTCSub [ChannelFull]) "open" (Proxy :: Proxy Open) - , parseTestClient (mkBTCSub [ChannelFull]) "done" (Proxy :: Proxy Done) - , parseTestClient (mkBTCSub [ChannelFull]) "match" (Proxy :: Proxy Match) +tests e = testGroup "feed" + [ parseTestClient e (mkBTCSub [ChannelHeartbeat]) "heartbeat" (Proxy :: Proxy Heartbeat) + , parseTestClient e (mkBTCSub [ChannelTicker]) "ticker" (Proxy :: Proxy Ticker) + , parseTestClient e (mkBTCSub [ChannelLevel2]) "snapshot" (Proxy :: Proxy Level2Snapshot) + , parseTestClient e (mkBTCSub [ChannelLevel2]) "l2update" (Proxy :: Proxy Level2Update) + , parseTestClient e (mkBTCSub [ChannelMatches]) "last_match" (Proxy :: Proxy Match) + , parseTestClient e (mkBTCSub [ChannelMatches]) "match" (Proxy :: Proxy Match) + , parseTestClient e (mkBTCSub [ChannelFull]) "received" (Proxy :: Proxy Received) + , parseTestClient e (mkBTCSub [ChannelFull]) "open" (Proxy :: Proxy Open) + , parseTestClient e (mkBTCSub [ChannelFull]) "done" (Proxy :: Proxy Done) + , parseTestClient e (mkBTCSub [ChannelFull]) "match" (Proxy :: Proxy Match) -- This one cannot run independently, since you only receive them if you -- trade against yourself. @@ -59,15 +60,15 @@ where fn c = ChannelSubscription c [pid] -parseTestClient :: (FromJSON a) => Subscriptions -> Text -> Proxy a -> TestTree -parseTestClient subs t pt = testCase (T.unpack t) $ runSecureClient "ws-feed.gdax.com" 443 "/" $ \conn -> do +parseTestClient :: (FromJSON a) => Env -> Subscriptions -> Text -> Proxy a -> TestTree +parseTestClient e subs t pt = testCase (T.unpack t) $ runSecureClient (e ^. liveUnsigned . socketEndpoint) 443 "/" $ \conn -> do sendTextData conn (Aeson.encode testSub) m1 <- receiveOfType conn t let res = Aeson.eitherDecode m1 case res of Left er -> fail (show er) Right v -> - let final = asProxyTypeOf v pt + let _final = asProxyTypeOf v pt in return () sendTextData conn (Aeson.encode testUnSub) diff --git a/test/Network/GDAX/Test/MarketData.hs b/test/Network/GDAX/Test/MarketData.hs --- a/test/Network/GDAX/Test/MarketData.hs +++ b/test/Network/GDAX/Test/MarketData.hs @@ -34,16 +34,16 @@ -------------------------------- tests :: Env -> TestTree -tests e = testGroup "MarketData Parse" - [ case_parse l "getProducts" $ getProducts - , case_parse l "getProductTopOfBook" $ getProductTopOfBook defProduct - , case_parse l "getProductTop50OfBook" $ getProductTop50OfBook defProduct - , case_parse l "getProductOrderBook" $ getProductOrderBook defProduct - , case_parse l "getProductTicker" $ getProductTicker defProduct - , case_parse l "getProductTrades" $ getProductTrades defProduct - , case_parse l "getProductHistory" $ getProductHistory defProduct defStart defEnd (Just 3600) - , case_parse l "getCurrencies" $ getCurrencies - , case_parse l "getExchangeTime" $ getTime +tests e = testGroup "market_data" + [ case_parse l "get_products" $ getProducts + , case_parse l "get_product_top_of_book" $ getProductTopOfBook defProduct + , case_parse l "get_product_top_50_of_book" $ getProductTop50OfBook defProduct + , case_parse l "get_product_order_book" $ getProductOrderBook defProduct + , case_parse l "get_product_ticker" $ getProductTicker defProduct + , case_parse l "get_product_trades" $ getProductTrades defProduct + , case_parse l "get_product_history" $ getProductHistory defProduct defStart defEnd (Just 3600) + , case_parse l "get_currencies" $ getCurrencies + , case_parse l "get_exchange_time" $ getTime ] where l = e ^. liveUnsigned diff --git a/test/Network/GDAX/Test/Private.hs b/test/Network/GDAX/Test/Private.hs new file mode 100644 --- /dev/null +++ b/test/Network/GDAX/Test/Private.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Network.GDAX.Test.Private + ( tests + ) where + +import Control.Lens +import qualified Data.HashMap.Strict as Map +import qualified Data.Vector.Generic as V +import Network.GDAX.Explicit +import Network.GDAX.Test.Types +import Test.Tasty +import Test.Tasty.HUnit + +tests :: Env -> TestTree +tests e = testGroup "private" + [ case_viewAccounts e + , case_listPaymentMethods e + , case_listCoinbaseAccounts e + , case_useCoinbaseAccount e + ] + +case_viewAccounts :: Env -> TestTree +case_viewAccounts e = testCaseSteps "view_account" $ \step -> do + step "listAccounts" + accounts <- listAccounts (e ^. sandbox) + + step "getAccounts (indavidually for each)" + _singles <- mapM (getAccount (e ^. sandbox) . _accountId) accounts + + step "getAccountHistory (indavidually for each)" + _histories <- mapM (getAccountHistory (e ^. sandbox) . _accountId) accounts + + return () + +case_listPaymentMethods :: Env -> TestTree +case_listPaymentMethods e = testCase "list_payment_methods" $ do + _methods <- listPaymentMethods (e ^. sandbox) + return () + +case_listCoinbaseAccounts :: Env -> TestTree +case_listCoinbaseAccounts e = testCase "list_coinbase_accounts" $ do + _cbaseAccounts <- listCoinbaseAccounts (e ^. sandbox) + return () + +case_useCoinbaseAccount :: Env -> TestTree +case_useCoinbaseAccount e = testCaseSteps "use_coinbase_account" $ \step -> do + step "Get account list." + accountMap <- getAccountMap + let (Just usd) = Map.lookup "USD Wallet" accountMap + (Just btc) = Map.lookup "Fake" accountMap + + step "Make USD deposit." + _rDepositUSD <- depositCoinbase gdax (CoinbaseDeposit 10000 "USD" (_cbaccountId usd)) + + step "Make BTC deposit." + _rDepositBTC <- depositCoinbase gdax (CoinbaseDeposit 10 "BTC" (_cbaccountId btc)) + + step "Make USD withdraw." + _rWithdrawUSD <- withdrawCoinbase gdax (CoinbaseWithdraw 10000 "USD" (_cbaccountId usd)) + + step "Make BTC withdraw." + _rWithdrawBTC <- withdrawCoinbase gdax (CoinbaseWithdraw 10 "BTC" (_cbaccountId btc)) + + return () + where + gdax = e ^. sandbox + getAccountMap = Map.fromList . V.toList . fmap (\a -> (_cbaccountName a, a)) <$> listCoinbaseAccounts gdax diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -7,22 +7,24 @@ import Network.GDAX.Implicit import qualified Network.GDAX.Test.Feed as Feed import qualified Network.GDAX.Test.MarketData as MarketData +import qualified Network.GDAX.Test.Private as Private import Network.GDAX.Test.Types import System.Environment import Test.Tasty main :: IO () main = do - gAccessKey <- CBS.pack <$> getEnv "GDAX_KEY" - gSecretKey <- Base64.decodeLenient . CBS.pack <$> getEnv "GDAX_SECRET" - gPassphrase <- CBS.pack <$> getEnv "GDAX_PASSPHRASE" + gAccessKey <- CBS.pack <$> getEnv "GDAX_SANDBOX_KEY" + gSecretKey <- Base64.decodeLenient . CBS.pack <$> getEnv "GDAX_SANDBOX_SECRET" + gPassphrase <- CBS.pack <$> getEnv "GDAX_SANDBOX_PASSPHRASE" sbox <- mkSandboxGdax gAccessKey gSecretKey gPassphrase live <- mkLiveUnsignedGdax defaultMain $ tests (Env sbox live) tests :: Env -> TestTree -tests e = testGroup "Tests" +tests e = testGroup "tests" [ MarketData.tests e + , Private.tests e , Feed.tests e ]