diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 + + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Sandbox.hs b/app/Sandbox.hs new file mode 100644 --- /dev/null +++ b/app/Sandbox.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Concurrent +import Control.Monad +import Control.Monad.IO.Class +import Data.Aeson (Value) +import qualified Data.Aeson as Aeson +import Data.Aeson.Encode.Pretty +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Char8 as CBS +import qualified Data.ByteString.Lazy.Char8 as CLBS +import Network.GDAX.Explicit +import Network.GDAX.Types.Feed +import Network.WebSockets +import System.Environment +import Wuss + +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" + + g <- mkSandboxGdax gAccessKey gSecretKey gPassphrase + + f g + +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 new file mode 100644 --- /dev/null +++ b/gdax.cabal @@ -0,0 +1,111 @@ +name: gdax +version: 0.5.0.0 +synopsis: API Wrapping for Coinbase's GDAX exchange. +description: Please see README.md +homepage: https://github.com/AndrewRademacher/gdax +license: MIT +license-file: LICENSE +author: Andrew Rademacher +maintainer: Andrew Rademacher +copyright: 2017 Andrew Rademacher +category: Web +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: lib + default-language: Haskell2010 + + ghc-options: -Wall + + default-extensions: StrictData + + exposed-modules: Network.GDAX.Explicit.MarketData + Network.GDAX.Explicit.Private + Network.GDAX.Implicit.MarketData + Network.GDAX.Implicit.Private + Network.GDAX.Types.Feed + Network.GDAX.Types.MarketData + Network.GDAX.Core + Network.GDAX.Exceptions + Network.GDAX.Explicit + Network.GDAX.Feed + Network.GDAX.Implicit + Network.GDAX.Parsers + Network.GDAX + + build-depends: base >4 && < 6 + + , aeson + , aeson-casing + , base64-bytestring + , byteable + , bytestring + , cryptohash + , exceptions + , http-client + , http-client-tls + , lens + , lens-aeson + , mtl + , scientific + , text + , time + , uuid + , vector + , websockets + , wreq + , wuss + +executable sandbox + main-is: Sandbox.hs + hs-source-dirs: app + default-language: Haskell2010 + + ghc-options: -rtsopts -Wall + + build-depends: base >4 && < 6 + + , gdax + + , aeson + , aeson-pretty + , base64-bytestring + , bytestring + , text + , websockets + , wuss + +test-suite test-gdax + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: test + default-language: Haskell2010 + + ghc-options: -threaded -Wall + + other-modules: Network.GDAX.Test.Feed + Network.GDAX.Test.MarketData + Network.GDAX.Test.Types + + build-depends: base >4 && < 6 + + , gdax + + , aeson + , base64-bytestring + , bytestring + , containers + , exceptions + , lens + , lens-aeson + , mtl + , tasty + , tasty-th + , tasty-quickcheck + , tasty-hunit + , text + , time + , vector + , websockets + , wuss diff --git a/lib/Network/GDAX.hs b/lib/Network/GDAX.hs new file mode 100644 --- /dev/null +++ b/lib/Network/GDAX.hs @@ -0,0 +1,5 @@ +module Network.GDAX + ( module Explicit + ) where + +import Network.GDAX.Explicit as Explicit diff --git a/lib/Network/GDAX/Core.hs b/lib/Network/GDAX/Core.hs new file mode 100644 --- /dev/null +++ b/lib/Network/GDAX/Core.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Network.GDAX.Core + ( Endpoint + , AccessKey, SecretKey, Passphrase + , Path, Method + + , Gdax + + , HasGdax (..) + , HasNetworkManager (..) + , HasRestEndpoint (..) + , HasSocketEndpoint (..) + , HasAccessKey (..) + , HasSecretKey (..) + , HasPassphrase (..) + + , mkLiveGdax, mkSandboxGdax + , mkLiveUnsignedGdax, mkSandboxUnsignedGdax + + , gdaxGet + , gdaxGetWith + , gdaxSignedGet + , gdaxSignedPost + ) where + +import Control.Lens +import Control.Monad.Catch +import Control.Monad.IO.Class +import Crypto.Hash +import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.Aeson as Aeson +import Data.Byteable +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Char8 as CBS +import qualified Data.ByteString.Lazy.Char8 as CLBS +import Data.Monoid +import qualified Data.Text as T +import Data.Time +import Data.Time.Clock.POSIX +import Network.GDAX.Exceptions +import Network.HTTP.Client (Manager) +import Network.HTTP.Client.TLS (newTlsManager) +import Network.Wreq +import Text.Printf + +type Endpoint = String +type AccessKey = ByteString +type SecretKey = ByteString +type Passphrase = ByteString + +type Path = String +type Method = ByteString + +liveRest :: Endpoint +liveRest = "https://api.gdax.com" + +sandboxRest :: Endpoint +sandboxRest = "https://api-public.sandbox.gdax.com" + +liveSocket :: Endpoint +liveSocket = "ws-feed.gdax.com" + +sandboxSocket :: Endpoint +sandboxSocket = "ws-feed-public.sandbox.gdax.com" + +class HasNetworkManager a where + networkManager :: Lens' a Manager +class HasRestEndpoint a where + restEndpoint :: Lens' a Endpoint +class HasSocketEndpoint a where + socketEndpoint :: Lens' a Endpoint +class HasAccessKey a where + accessKey :: Lens' a AccessKey +class HasSecretKey a where + secretKey :: Lens' a SecretKey +class HasPassphrase a where + passphrase :: Lens' a Passphrase + +data Gdax + = Gdax + { _gdaxNetworkManager :: Manager + , _gdaxRestEndpoint :: Endpoint + , _gdaxSocketEndpoint :: Endpoint + , _gdaxAccessKey :: AccessKey + , _gdaxSecretKey :: SecretKey + , _gdaxPassphrase :: Passphrase + } + +$(makeClassy ''Gdax) + +instance HasNetworkManager Gdax where networkManager = gdaxNetworkManager +instance HasRestEndpoint Gdax where restEndpoint = gdaxRestEndpoint +instance HasSocketEndpoint Gdax where socketEndpoint = gdaxSocketEndpoint +instance HasAccessKey Gdax where accessKey = gdaxAccessKey +instance HasSecretKey Gdax where secretKey = gdaxSecretKey +instance HasPassphrase Gdax where passphrase = gdaxPassphrase + +mkLiveGdax :: (MonadIO m) => AccessKey -> SecretKey -> Passphrase -> m Gdax +mkLiveGdax a s p = do + m <- newTlsManager + return $ Gdax m liveRest liveSocket a s p + +mkSandboxGdax :: (MonadIO m) => AccessKey -> SecretKey -> Passphrase -> m Gdax +mkSandboxGdax a s p = do + m <- newTlsManager + return $ Gdax m sandboxRest sandboxSocket a s p + +mkLiveUnsignedGdax :: (MonadIO m) => m Gdax +mkLiveUnsignedGdax = do + m <- newTlsManager + return $ Gdax m liveRest liveSocket "" "" "" + +mkSandboxUnsignedGdax :: (MonadIO m) => m Gdax +mkSandboxUnsignedGdax = do + m <- newTlsManager + return $ Gdax m sandboxRest sandboxSocket "" "" "" + +gdaxGet :: (MonadIO m, MonadThrow m, FromJSON b) => Gdax -> Path -> m b +{-# INLINE gdaxGet #-} +gdaxGet g path = do + res <- liftIO $ getWith opts (g ^. restEndpoint <> path) + decodeResult res + where + opts = defaults & manager .~ Right (g ^. networkManager) + +gdaxGetWith :: (MonadIO m, MonadThrow m, FromJSON b) => Gdax -> Path -> Options -> m b +{-# INLINE gdaxGetWith #-} +gdaxGetWith g path opts' = do + res <- liftIO $ getWith opts (g ^. restEndpoint <> path) + decodeResult res + where + opts = opts' & manager .~ Right (g ^. networkManager) + +gdaxSignedGet :: (MonadIO m, MonadThrow m, FromJSON b) => Gdax -> Path -> m b +{-# INLINE gdaxSignedGet #-} +gdaxSignedGet g path = do + signedOpts <- signOptions g "GET" path Nothing opts + res <- liftIO $ getWith signedOpts (g ^. restEndpoint <> path) + decodeResult res + where + opts = defaults & manager .~ Right (g ^. networkManager) + +gdaxSignedPost :: (MonadIO m, MonadThrow m, ToJSON a, FromJSON b) => Gdax -> Path -> a -> m b +{-# INLINE gdaxSignedPost #-} +gdaxSignedPost g path 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) + bodyBS = CLBS.toStrict $ Aeson.encode body + +decodeResult :: (MonadThrow m, FromJSON a) => Response CLBS.ByteString -> m a +{-# INLINE decodeResult #-} +decodeResult res = + case Aeson.eitherDecode' (res ^. responseBody) of + Left err -> throwM $ MalformedGdaxResponse (T.pack err) + Right val -> return val + +signOptions :: (MonadIO m) => Gdax -> Method -> Path -> (Maybe ByteString) -> Options -> m Options +{-# INLINE signOptions #-} +signOptions g method path mBody opts = do + time <- liftIO $ getCurrentTime + let timestamp = CBS.pack $ printf "%.0f" (realToFrac (utcTimeToPOSIXSeconds time) :: Double) + sigString = timestamp <> method <> (CBS.pack path) <> maybe "" id mBody + sig = Base64.encode $ toBytes (hmac (g ^. secretKey) sigString :: HMAC SHA256) + + return $ opts + & header "CB-ACCESS-KEY" .~ [ (g ^. accessKey) ] + & header "CB-ACCESS-SIGN" .~ [ sig ] + & header "CB-ACCESS-TIMESTAMP" .~ [ timestamp ] + & header "CB-ACCESS-PASSPHRASE" .~ [ (g ^. passphrase) ] diff --git a/lib/Network/GDAX/Exceptions.hs b/lib/Network/GDAX/Exceptions.hs new file mode 100644 --- /dev/null +++ b/lib/Network/GDAX/Exceptions.hs @@ -0,0 +1,10 @@ +module Network.GDAX.Exceptions where + +import Control.Monad.Catch +import Data.Text (Text) + +data MalformedGdaxResponse + = MalformedGdaxResponse Text + deriving (Show) + +instance Exception MalformedGdaxResponse diff --git a/lib/Network/GDAX/Explicit.hs b/lib/Network/GDAX/Explicit.hs new file mode 100644 --- /dev/null +++ b/lib/Network/GDAX/Explicit.hs @@ -0,0 +1,15 @@ +module Network.GDAX.Explicit + ( module Core + , module Exceptions + , module MarketData + , module Private + ) where + +import Network.GDAX.Core as Core hiding (Method, Path, + gdaxGet, + gdaxSignedGet, + gdaxSignedPost) +import Network.GDAX.Exceptions as Exceptions +import Network.GDAX.Explicit.MarketData as MarketData +import Network.GDAX.Explicit.Private as Private +import Network.GDAX.Types.MarketData as MarketData diff --git a/lib/Network/GDAX/Explicit/MarketData.hs b/lib/Network/GDAX/Explicit/MarketData.hs new file mode 100644 --- /dev/null +++ b/lib/Network/GDAX/Explicit/MarketData.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.GDAX.Explicit.MarketData where + +import Control.Lens +import Control.Monad.Catch +import Control.Monad.IO.Class +import Data.Aeson +import Data.Aeson.Lens +import Data.Monoid ((<>)) +import qualified Data.Text as T +import Data.Time +import Data.Time.Clock.POSIX +import Data.Vector +import Network.GDAX.Core +import Network.GDAX.Exceptions +import Network.GDAX.Types.MarketData +import Network.Wreq + +getProducts :: (MonadIO m, MonadThrow m) => Gdax -> m (Vector Product) +getProducts g = gdaxGet g "/products" + +getProductTopOfBook :: (MonadIO m, MonadThrow m) => Gdax -> ProductId -> m AggrigateBook +getProductTopOfBook g pid = gdaxGet g ("/products/" <> T.unpack (unProductId pid) <> "/book") + +getProductTop50OfBook :: (MonadIO m, MonadThrow m) => Gdax -> ProductId -> m AggrigateBook +getProductTop50OfBook g pid = gdaxGet g ("/products/" <> T.unpack (unProductId pid) <> "/book?level=2") + +getProductOrderBook :: (MonadIO m, MonadThrow m) => Gdax -> ProductId -> m Book +getProductOrderBook g pid = gdaxGet g ("/products/" <> T.unpack (unProductId pid) <> "/book?level=3") + +getProductTicker :: (MonadIO m, MonadThrow m) => Gdax -> ProductId -> m Tick +getProductTicker g pid = gdaxGet g ("/products/" <> T.unpack (unProductId pid) <> "/ticker") + +getProductTrades :: (MonadIO m, MonadThrow m) => Gdax -> ProductId -> m (Vector Trade) +getProductTrades g pid = gdaxGet g ("/products/" <> T.unpack (unProductId pid) <> "/trades") + +getProductHistory :: (MonadIO m, MonadThrow m) => Gdax -> ProductId -> Maybe StartTime -> Maybe EndTime -> Maybe Granularity -> m (Vector Candle) +getProductHistory g pid mst met mg = gdaxGetWith g ("/products/" <> T.unpack (unProductId pid) <> "/candles") opts + where + opts = defaults + & param "start" .~ nothingToEmpty (fmt <$> mst) + & param "end" .~ nothingToEmpty (fmt <$> met) + & param "granularity" .~ nothingToEmpty (T.pack . show <$> mg) + nothingToEmpty (Just v) = [ v ] + nothingToEmpty Nothing = [] + fmt t = let t' = formatTime defaultTimeLocale "%FT%T." t + in T.pack $ t' <> Prelude.take 6 (formatTime defaultTimeLocale "%q" t) <> "Z" + +getProductStats :: (MonadIO m, MonadThrow m) => Gdax -> ProductId -> m Stats +getProductStats g pid = gdaxGet g ("/products/" <> T.unpack (unProductId pid) <> "/stats") + +getCurrencies :: (MonadIO m, MonadThrow m) => Gdax -> m (Vector Currency) +getCurrencies g = gdaxGet g "/currencies" + +getTime :: (MonadIO m, MonadThrow m) => Gdax -> m UTCTime +getTime g = do + res <- gdaxGet g "/time" + case (res :: Value) ^? key "epoch" . _Double of + Nothing -> throwM $ MalformedGdaxResponse "Epoch field was either missing or malformed in response from GET /time." + Just val -> return $ posixSecondsToUTCTime $ realToFrac val diff --git a/lib/Network/GDAX/Explicit/Private.hs b/lib/Network/GDAX/Explicit/Private.hs new file mode 100644 --- /dev/null +++ b/lib/Network/GDAX/Explicit/Private.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.GDAX.Explicit.Private where + +import Control.Monad.Catch +import Control.Monad.IO.Class +import Data.Aeson +import Data.Text +import Network.GDAX.Core + +placeOrder :: (MonadIO m, MonadThrow m) => Gdax -> m Value +placeOrder g = gdaxSignedPost g "/orders" body + where + body = object + [ "size" .= ("0.01" :: Text) + , "price" .= ("0.100" :: Text) + , "side" .= ("buy" :: Text) + , "product_id" .= ("BTC-USD" :: Text) + ] + +listAccounts :: (MonadIO m, MonadThrow m) => Gdax -> m Value +listAccounts g = + gdaxSignedGet g "/accounts" diff --git a/lib/Network/GDAX/Feed.hs b/lib/Network/GDAX/Feed.hs new file mode 100644 --- /dev/null +++ b/lib/Network/GDAX/Feed.hs @@ -0,0 +1,20 @@ +module Network.GDAX.Feed 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 Network.WebSockets + +defaultClient :: Subscriptions -> (GdaxMessage -> IO b) -> Connection -> IO b +defaultClient subs handler conn = do + sendTextData conn (Aeson.encode (Subscribe subs)) + loop + where + loop = do + res <- receiveData conn + let asSum = Aeson.eitherDecode res :: Either String GdaxMessage + case asSum of + Left er -> throwM $ MalformedGdaxResponse $ T.pack er + Right v -> handler v diff --git a/lib/Network/GDAX/Implicit.hs b/lib/Network/GDAX/Implicit.hs new file mode 100644 --- /dev/null +++ b/lib/Network/GDAX/Implicit.hs @@ -0,0 +1,15 @@ +module Network.GDAX.Implicit + ( module Core + , module Exceptions + , module MarketData + , module Private + ) where + +import Network.GDAX.Core as Core hiding (Method, Path, + gdaxGet, + gdaxSignedGet, + gdaxSignedPost) +import Network.GDAX.Exceptions as Exceptions +import Network.GDAX.Implicit.MarketData as MarketData +import Network.GDAX.Implicit.Private as Private +import Network.GDAX.Types.MarketData as MarketData diff --git a/lib/Network/GDAX/Implicit/MarketData.hs b/lib/Network/GDAX/Implicit/MarketData.hs new file mode 100644 --- /dev/null +++ b/lib/Network/GDAX/Implicit/MarketData.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.GDAX.Implicit.MarketData where + +import Control.Lens +import Control.Monad.Catch +import Control.Monad.IO.Class +import Control.Monad.Reader +import Data.Time +import Data.Vector +import Network.GDAX.Core +import qualified Network.GDAX.Explicit.MarketData as Explicit +import Network.GDAX.Types.MarketData + +getProducts :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => m (Vector Product) +getProducts = do + g <- (^. gdax) <$> ask + Explicit.getProducts g + +getProductTopOfBook :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => ProductId -> m AggrigateBook +getProductTopOfBook pid = do + g <- (^. gdax) <$> ask + Explicit.getProductTopOfBook g pid + +getProductTop50OfBook :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => ProductId -> m AggrigateBook +getProductTop50OfBook pid = do + g <- (^. gdax) <$> ask + Explicit.getProductTop50OfBook g pid + +getProductOrderBook :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => ProductId -> m Book +getProductOrderBook pid = do + g <- (^. gdax) <$> ask + Explicit.getProductOrderBook g pid + +getProductTicker :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => ProductId -> m Tick +getProductTicker pid = do + g <- (^. gdax) <$> ask + Explicit.getProductTicker g pid + +getProductTrades :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => ProductId -> m (Vector Trade) +getProductTrades pid = do + g <- (^. gdax) <$> ask + Explicit.getProductTrades g pid + +getProductHistory :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => ProductId -> Maybe StartTime -> Maybe EndTime -> Maybe Granularity -> m (Vector Candle) +getProductHistory pid mst met mg = do + g <- (^. gdax) <$> ask + Explicit.getProductHistory g pid mst met mg + +getProductStats :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => ProductId -> m Stats +getProductStats pid = do + g <- (^. gdax) <$> ask + Explicit.getProductStats g pid + +getCurrencies :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => m (Vector Currency) +getCurrencies = do + g <- (^. gdax) <$> ask + Explicit.getCurrencies g + +getTime :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => m UTCTime +getTime = do + g <- (^. gdax) <$> ask + Explicit.getTime g diff --git a/lib/Network/GDAX/Implicit/Private.hs b/lib/Network/GDAX/Implicit/Private.hs new file mode 100644 --- /dev/null +++ b/lib/Network/GDAX/Implicit/Private.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.GDAX.Implicit.Private where + +import Control.Lens hiding ((.=)) +import Control.Monad.Catch +import Control.Monad.IO.Class +import Control.Monad.Reader +import Data.Aeson +import Network.GDAX.Core +import qualified Network.GDAX.Explicit.Private as Explicit + +placeOrder' :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => m Value +placeOrder' = do + g <- (^. gdax) <$> ask + Explicit.placeOrder g + +listAccounts' :: (MonadIO m, MonadThrow m, MonadReader e m, HasGdax e) => m Value +listAccounts' = do + g <- (^. gdax) <$> ask + Explicit.listAccounts g diff --git a/lib/Network/GDAX/Parsers.hs b/lib/Network/GDAX/Parsers.hs new file mode 100644 --- /dev/null +++ b/lib/Network/GDAX/Parsers.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.GDAX.Parsers where + +import Data.Aeson.Types +import Data.Monoid +import Data.Scientific +import Data.Text (Text) +import qualified Data.Text as T +import Data.Vector (Vector) +import qualified Data.Vector.Generic as V +import Text.Read + +textScientific :: Value -> Parser Scientific +textScientific = withText "Text Scientific" $ \t -> + case readMaybe (T.unpack t) of + Just n -> pure n + Nothing -> fail "Could not parse string scientific." + +textDouble :: Value -> Parser Double +textDouble = withText "Text Double" $ \t -> + case readMaybe (T.unpack t) of + Just n -> pure n + Nothing -> fail "Could not parse string double." + +newtype StringDouble = StringDouble { unStringDouble :: Double } + +instance FromJSON StringDouble where + parseJSON = withText "Text Double" $ \t -> + case readMaybe (T.unpack t) of + Just n -> pure (StringDouble n) + Nothing -> fail "Could not parse string double." + +bookItem :: (FromJSON c) => String -> (Double -> Double -> c -> d) -> Value -> Parser d +bookItem name f = withArray name $ \a -> f + <$> (unStringDouble <$> parseJSON (a V.! 0)) + <*> (unStringDouble <$> parseJSON (a V.! 1)) + <*> parseJSON (a V.! 2) + +withObjectOfType :: String -> Text -> (Object -> Parser a) -> Value -> Parser a +withObjectOfType name type' fn = withObject name $ \o -> do + t <- o .: "type" + if t == type' + then fn o + else fail $ T.unpack $ "Expected type 'subscribe' got '" <> t <> "'." + +nothingToEmptyVector :: Maybe (Vector a) -> Vector a +nothingToEmptyVector (Just v) = v +nothingToEmptyVector Nothing = V.empty diff --git a/lib/Network/GDAX/Types/Feed.hs b/lib/Network/GDAX/Types/Feed.hs new file mode 100644 --- /dev/null +++ b/lib/Network/GDAX/Types/Feed.hs @@ -0,0 +1,577 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.GDAX.Types.Feed where + +import Data.Aeson +import Data.Monoid +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 GHC.Generics +import Network.GDAX.Parsers +import Network.GDAX.Types.MarketData hiding (Open) + +data Subscriptions + = Subscriptions + { _subProducts :: Vector ProductId + , _subChannels :: Vector ChannelSubscription + } + deriving (Show, Typeable, Generic) + +instance FromJSON Subscriptions where + parseJSON = withObjectOfType "Subscriptions" "subscriptions" $ \o -> Subscriptions + <$> (nothingToEmptyVector <$> o .:? "products") + <*> o .: "channels" + +newtype Subscribe = Subscribe { unSubscribe :: Subscriptions } + deriving (Show, Typeable, Generic) + +instance ToJSON Subscribe where + toJSON (Subscribe s) = object + [ "type" .= ("subscribe"::Text) + , "product_ids" .= _subProducts s + , "channels" .= _subChannels s + ] + +instance FromJSON Subscribe where + parseJSON = withObject "Subscribe" $ \o -> do + t <- o .: "type" + case t of + "subscribe" -> do + prod <- nothingToEmptyVector <$> o .:? "products" + chan <- o .: "channels" + return $ Subscribe $ Subscriptions prod chan + _ -> fail $ T.unpack $ "Expected type 'subscribe' got '" <> t <> "'." + +newtype UnSubscribe = UnSubscribe { unUnSubscribe :: Subscriptions } + deriving (Show, Typeable, Generic) + +instance ToJSON UnSubscribe where + toJSON (UnSubscribe s) = object + [ "type" .= ("unsubscribe"::Text) + , "product_ids" .= _subProducts s + , "channels" .= _subChannels s + ] + +instance FromJSON UnSubscribe where + parseJSON = withObject "UnSubscribe" $ \o -> do + t <- o .: "type" + case t of + "subscribe" -> do + prod <- nothingToEmptyVector <$> o .:? "products" + chan <- o .: "channels" + return $ UnSubscribe $ Subscriptions prod chan + _ -> fail $ T.unpack $ "Expected type 'subscribe' got '" <> t <> "'." + +data Channel + = ChannelHeartbeat + | ChannelTicker + | ChannelLevel2 + | ChannelUser + | ChannelMatches + | ChannelFull + deriving (Eq, Ord, Typeable, Generic) + +instance Show Channel where + show ChannelHeartbeat = "heartbeat" + show ChannelTicker = "ticker" + show ChannelLevel2 = "level2" + show ChannelUser = "user" + show ChannelMatches = "matches" + show ChannelFull = "full" + +instance ToJSON Channel where + toJSON = String . T.pack . show + +instance FromJSON Channel where + parseJSON = withText "Channel" $ \t -> + case t of + "heartbeat" -> pure ChannelHeartbeat + "ticker" -> pure ChannelTicker + "level2" -> pure ChannelLevel2 + "user" -> pure ChannelUser + "matches" -> pure ChannelMatches + "full" -> pure ChannelFull + u -> fail $ T.unpack $ "Received from unsupported channel '" <> u <> "'." + +data ChannelSubscription + = ChannelSubscription + { _csubChannel :: Channel + , _csubProducts :: Vector ProductId + } + deriving (Show, Typeable, Generic) + +instance ToJSON ChannelSubscription where + toJSON c | V.null (_csubProducts c) = toJSON (_csubChannel c) + | otherwise = object + [ "name" .= _csubChannel c + , "product_ids" .= _csubProducts c + ] + +instance FromJSON ChannelSubscription where + parseJSON s@String{} = ChannelSubscription + <$> parseJSON s + <*> pure V.empty + parseJSON (Object o) = ChannelSubscription + <$> o .: "name" + <*> o .: "product_ids" + parseJSON _ = fail "Channel subscription was not a String or Object." + +data FeedError + = FeedError + { _errMessage :: Text + , _errOriginal :: Value + } + deriving (Show, Typeable, Generic) + +instance FromJSON FeedError where + parseJSON = withObjectOfType "FeedError" "error" $ \o -> FeedError + <$> o .: "message" + <*> o .: "original" + +data Heartbeat + = Heartbeat + { _beatSequence :: Sequence + , _beatLastTradeId :: TradeId + , _beatProductId :: ProductId + , _beatTime :: UTCTime + } + deriving (Show, Typeable, Generic) + +instance FromJSON Heartbeat where + parseJSON = withObjectOfType "Heartbeat" "heartbeat" $ \o -> Heartbeat + <$> o .: "sequence" + <*> o .: "last_trade_id" + <*> o .: "product_id" + <*> o .: "time" + +data Ticker + = Ticker + { _tickerSequence :: Sequence + , _tickerProductId :: ProductId + , _tickerPrice :: Double + , _tickerOpen24Hours :: Double + , _tickerVolume24Hours :: Double + , _tickerLow24Hours :: Double + , _tickerHigh24Hours :: Double + , _tickerVolume30Days :: Double + , _tickerBestBid :: Double + , _tickerBestAsk :: Double + } + deriving (Show, Typeable, Generic) + +instance FromJSON Ticker where + 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) + +data Level2Snapshot + = Level2Snapshot + { _l2snapProductId :: ProductId + , _l2snapBids :: Vector Level2Item + , _l2snapAsks :: Vector Level2Item + } + deriving (Show, Typeable, Generic) + +instance FromJSON Level2Snapshot where + parseJSON = withObjectOfType "Level2Snapshot" "snapshot" $ \o -> Level2Snapshot + <$> o .: "product_id" + <*> o .: "bids" + <*> o .: "asks" + +data Level2Item + = Level2Item + { _l2itemPrice :: {-# UNPACK #-} Double + , _l2itemSize :: {-# UNPACK #-} Double + } + deriving (Show, Typeable, Generic) + +instance FromJSON Level2Item where + parseJSON = withArray "Level2Item" $ \a -> Level2Item + <$> (unStringDouble <$> parseJSON (a V.! 0)) + <*> (unStringDouble <$> parseJSON (a V.! 1)) + +data Level2Update + = Level2Update + { _l2updateProductId :: ProductId + , _l2updateChanges :: Vector Level2Change + } + deriving (Show, Typeable, Generic) + +instance FromJSON Level2Update where + parseJSON = withObjectOfType "Level2Update" "l2update" $ \o -> Level2Update + <$> o .: "product_id" + <*> o .: "changes" + +data Level2Change + = Level2Change + { _l2bidSide :: Side + , _l2bidPrice :: {-# UNPACK #-} Double + , _l2bidSize :: {-# UNPACK #-} Double + } + deriving (Show, Typeable, Generic) + +instance FromJSON Level2Change where + parseJSON = withArray "Level2Bid" $ \a -> Level2Change + <$> parseJSON (a V.! 0) + <*> (unStringDouble <$> parseJSON (a V.! 1)) + <*> (unStringDouble <$> parseJSON (a V.! 2)) + +data Match + = Match + { _matchTradeId :: TradeId + , _matchTime :: Maybe UTCTime + , _matchMakerOrderId :: UUID + , _matchTakerOrderId :: UUID + , _matchProductId :: ProductId + , _matchSequence :: Sequence + , _matchSide :: Side + , _matchSize :: Double + , _matchPrice :: Double + } + deriving (Show, Typeable, Generic) + +instance FromJSON Match where + parseJSON = withObject "Match" $ \o -> do + t <- o .: "type" + case t of + "last_match" -> process o + "match" -> process o + _ -> fail $ T.unpack $ "Expected type 'subscribe' got '" <> t <> "'." + where + process o = Match + <$> o .: "trade_id" + <*> o .:? "time" + <*> o .: "maker_order_id" + <*> o .: "taker_order_id" + <*> o .: "product_id" + <*> o .: "sequence" + <*> o .: "side" + <*> (o .: "size" >>= textDouble) + <*> (o .: "price" >>= textDouble) + +-- 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 + , _receivedProductId :: ProductId + , _receivedSequence :: Sequence + , _receivedOrderId :: OrderId + , _receivedSize :: Double + , _receivedPrice :: Double + , _receivedSide :: Side + } + | ReceivedMarket + { _receivedTime :: UTCTime + , _receivedProductId :: ProductId + , _receivedSequence :: Sequence + , _receivedOrderId :: OrderId + , _receivedFunds :: Double + , _receivedSide :: Side + } + deriving (Show, Typeable, Generic) + +instance FromJSON Received where + parseJSON = withObjectOfType "Received" "received" $ \o -> do + t <- o .: "order_type" + case t of + OrderLimit -> ReceivedLimit + <$> o .: "time" + <*> o .: "product_id" + <*> o .: "sequence" + <*> o .: "order_id" + <*> (o .: "size" >>= textDouble) + <*> (o .: "price" >>= textDouble) + <*> o .: "side" + OrderMarket -> ReceivedMarket + <$> o .: "time" + <*> o .: "product_id" + <*> o .: "sequence" + <*> o .: "order_id" + <*> (o .: "funds" >>= textDouble) + <*> o .: "side" + +data Reason + = ReasonFilled + | ReasonCanceled + deriving (Eq, Ord, Typeable, Generic) + +instance Show Reason where + show ReasonFilled = "filled" + show ReasonCanceled = "canceled" + +instance FromJSON Reason where + parseJSON = withText "Reason" $ \t -> + case t of + "filled" -> pure ReasonFilled + "canceled" -> pure ReasonCanceled + _ -> fail $ T.unpack $ "'" <> t <> "' is not a valid reason." + +data Open + = Open + { _openTime :: UTCTime + , _openProductId :: ProductId + , _openOrderId :: OrderId + , _openSequence :: Sequence + , _openPrice :: Double + , _openRemainingSize :: Double + , _openSide :: Side + } + deriving (Show, Typeable, Generic) + +instance FromJSON Open where + parseJSON = withObjectOfType "Open" "open" $ \o -> Open + <$> o .: "time" + <*> o .: "product_id" + <*> o .: "order_id" + <*> o .: "sequence" + <*> (o .: "price" >>= textDouble) + <*> (o .: "remaining_size" >>= textDouble) + <*> o .: "side" + +data Done + = Done + { _doneTime :: UTCTime + , _doneProductId :: ProductId + , _doneSequence :: Sequence + , _donePrice :: Double + , _doneOrderId :: OrderId + , _doneReason :: Reason + , _doneSide :: Side + , _doneRemainingSize :: Double + } + deriving (Show, Typeable, Generic) + +instance FromJSON Done where + parseJSON = withObjectOfType "Done" "done" $ \o -> Done + <$> o .: "time" + <*> o .: "product_id" + <*> o .: "sequence" + <*> (o .: "price" >>= textDouble) + <*> o .: "order_id" + <*> o .: "reason" + <*> o .: "side" + <*> (o .: "remaining_size" >>= textDouble) + +-- Match implemented previously + +data Change + = ChangeSize + { _changeTime :: UTCTime + , _changeSequence :: Sequence + , _changeOrderId :: OrderId + , _changeProductId :: ProductId + , _changeNewSize :: Double + , _changeOldSize :: Double + , _changePrice :: Double + , _changSide :: Side + } + | ChangeFunds + { _changeTime :: UTCTime + , _changeSequence :: Sequence + , _changeOrderId :: OrderId + , _changeProductId :: ProductId + , _changeNewFunds :: Double + , _changeOldFunds :: Double + , _changePrice :: Double + , _changSide :: Side + } + deriving (Show, Typeable, Generic) + +instance FromJSON Change where + parseJSON = withObjectOfType "Change" "change" $ \o -> do + fund <- o .:? "new_funds" + case (fund :: Maybe Double) of + Nothing -> ChangeSize + <$> o .: "time" + <*> o .: "sequence" + <*> o .: "order_id" + <*> o .: "product_id" + <*> o .: "new_size" + <*> o .: "old_size" + <*> o .: "price" + <*> o .: "side" + Just _ -> ChangeFunds + <$> o .: "time" + <*> o .: "sequence" + <*> o .: "order_id" + <*> o .: "product_id" + <*> o .: "new_funds" + <*> o .: "old_funds" + <*> o .: "price" + <*> o .: "side" + +data MarginProfileUpdate + = MarginProfileUpdate + { _mpuProductId :: ProductId + , _mpuTime :: UTCTime + , _mpuUserId :: UserId + , _mpuProfileId :: ProfileId + , _mpuNonce :: Int + , _mpuPosition :: Text + , _mpuPositionSize :: Double + , _mpuPositionCompliment :: Double + , _mpuPositionMaxSize :: Double + , _mpuCallSide :: Side + , _mpuCallPrice :: Double + , _mpuCallSize :: Double + , _mpuCallFunds :: Double + , _mpuCovered :: Bool + , _mpuNextExpireTime :: UTCTime + , _mpuBaseBalance :: Double + , _mpuBaseFunding :: Double + , _mpuQuoteBalance :: Double + , _mpuQuoteFunding :: Double + , _mpuPrivate :: Bool + } + deriving (Show, Typeable, Generic) + +instance FromJSON MarginProfileUpdate where + parseJSON = withObjectOfType "MarginProfileUpdate" "margin_profile_update" $ \o -> MarginProfileUpdate + <$> o .: "product_id" + <*> o .: "timestamp" + <*> o .: "user_id" + <*> o .: "profile_id" + <*> o .: "nonce" + <*> o .: "position" + <*> (o .: "position_size" >>= textDouble) + <*> (o .: "position_compliement" >>= textDouble) + <*> (o .: "position_max_size" >>= textDouble) + <*> o .: "call_side" + <*> (o .: "call_price" >>= textDouble) + <*> (o .: "call_size" >>= textDouble) + <*> (o .: "call_funds" >>= textDouble) + <*> o .: "covered" + <*> o .: "next_expire_time" + <*> (o .: "base_balance" >>= textDouble) + <*> (o .: "base_funding" >>= textDouble) + <*> (o .: "quote_balance" >>= textDouble) + <*> (o .: "quote_funding" >>= textDouble) + <*> 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 + , _activateTime :: UTCTime + , _activateUserId :: UserId + , _activateProfileId :: ProfileId + , _activateOrderId :: OrderId + , _activateStopType :: StopType + , _activateSide :: Side + , _activateStopPrice :: Double + , _activateSize :: Double + , _activateFunds :: Double + , _activateTakerFeeRate :: Double + , _activatePrivate :: Bool + } + deriving (Show, Typeable, Generic) + +instance FromJSON Activate where + parseJSON = withObjectOfType "Activate" "activate" $ \o -> Activate + <$> o .: "product_id" + <*> o .: "time" + <*> o .: "user_id" + <*> o .: "profile_id" + <*> o .: "order_id" + <*> o .: "stop_type" + <*> o .: "side" + <*> (o .: "stop_price" >>= textDouble) + <*> (o .: "size" >>= textDouble) + <*> (o .: "funds" >>= textDouble) + <*> (o .: "taker_fee_rate" >>= textDouble) + <*> o .: "private" + +-- Sum Type + +data GdaxMessage + = GdaxSubscriptions Subscriptions + | GdaxHeartbeat Heartbeat + | GdaxTicker Ticker + | GdaxLevel2Snapshot Level2Snapshot + | GdaxLevel2Update Level2Update + | GdaxMatch Match + | GdaxReceived Received + | GdaxOpen Open + | GdaxDone Done + | GdaxChange Change + | GdaxMarginProfileUpdate MarginProfileUpdate + | GdaxActivate Activate + | GdaxFeedError FeedError + deriving (Show, Typeable, Generic) + +instance FromJSON GdaxMessage where + parseJSON = withObject "GdaxMessage" $ \o -> do + t <- o .: "type" + case t of + "subscriptions" -> GdaxSubscriptions <$> parseJSON (Object o) + "heartbeat" -> GdaxHeartbeat <$> parseJSON (Object o) + "ticker" -> GdaxTicker <$> parseJSON (Object o) + "snapshot" -> GdaxLevel2Snapshot <$> parseJSON (Object o) + "l2update" -> GdaxLevel2Update <$> parseJSON (Object o) + "last_match" -> GdaxMatch <$> parseJSON (Object o) + "match" -> GdaxMatch <$> parseJSON (Object o) + "received" -> GdaxReceived <$> parseJSON (Object o) + "open" -> GdaxOpen <$> parseJSON (Object o) + "done" -> GdaxDone <$> parseJSON (Object o) + "change" -> GdaxChange <$> parseJSON (Object o) + "margin_profile_update" -> GdaxMarginProfileUpdate <$> parseJSON (Object o) + "activate" -> GdaxActivate <$> parseJSON (Object o) + "error" -> GdaxFeedError <$> parseJSON (Object o) + _ -> fail $ T.unpack $ "Message of unsupported type '" <> t <> "'." diff --git a/lib/Network/GDAX/Types/MarketData.hs b/lib/Network/GDAX/Types/MarketData.hs new file mode 100644 --- /dev/null +++ b/lib/Network/GDAX/Types/MarketData.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.GDAX.Types.MarketData where + + +import Data.Aeson +import Data.Aeson.Types +import Data.Int +import Data.String +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 GHC.Generics +import Network.GDAX.Parsers + +-- 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 + , _prodBaseCurrency :: CurrencyId + , _prodQuoteCurrency :: CurrencyId + , _prodBaseMinSize :: Double + , _prodBaseMaxSize :: Double + , _prodQuoteIncrement :: Double + , _prodDisplayName :: Text + , _prodMarginEnabled :: Bool + } + deriving (Show, Typeable, Generic) + +instance FromJSON Product where + parseJSON = withObject "Product" $ \o -> Product + <$> o .: "id" + <*> o .: "base_currency" + <*> o .: "quote_currency" + <*> (o .: "base_min_size" >>= textDouble) + <*> (o .: "base_max_size" >>= textDouble) + <*> (o .: "quote_increment" >>= textDouble) + <*> 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 + , _aggbidSize :: {-# UNPACK #-} Double + , _aggbidOrderCount :: {-# UNPACK #-} Int64 + } + deriving (Show, Typeable, Generic) + +instance FromJSON AggrigateBid where + parseJSON = bookItem "AggrigateBid" AggrigateBid + +data AggrigateAsk + = AggrigateAsk + { _aggaskPrice :: {-# UNPACK #-} Double + , _aggaskSize :: {-# UNPACK #-} Double + , _aggaskOrderCount :: {-# UNPACK #-} Int64 + } + deriving (Show, Typeable, Generic) + +instance FromJSON AggrigateAsk where + parseJSON = bookItem "AggrigateAsk" AggrigateAsk + +data Bid + = Bid + { _bidPrice :: {-# UNPACK #-} Double + , _bidSize :: {-# UNPACK #-} Double + , _bidId :: {-# UNPACK #-} UUID + } + deriving (Show, Typeable, Generic) + +instance FromJSON Bid where + parseJSON = bookItem "Bid" Bid + +data Ask + = Ask + { _askPrice :: {-# UNPACK #-} Double + , _askSize :: {-# UNPACK #-} Double + , _askId :: {-# UNPACK #-} UUID + } + deriving (Show, Typeable, Generic) + +instance FromJSON Ask where + parseJSON = bookItem "Ask" Ask + +data AggrigateBook + = AggrigateBook + { _aggbookBids :: Vector AggrigateBid + , _aggbookAsks :: Vector AggrigateAsk + , _aggbookSequence :: Sequence + } + deriving (Show, Typeable, Generic) + +instance FromJSON AggrigateBook where + parseJSON = withObject "AggrigateBook" $ \o -> AggrigateBook + <$> o .: "bids" + <*> o .: "asks" + <*> o .: "sequence" + +data Book + = Book + { _bookBids :: Vector Bid + , _bookAsks :: Vector Ask + , _bookSequence :: Sequence + } + deriving (Show, Typeable, Generic) + +instance FromJSON Book where + parseJSON = withObject "Book" $ \o -> Book + <$> o .: "bids" + <*> o .: "asks" + <*> o .: "sequence" + +-- Ticker + +data Tick + = Tick + { _tickTradeId :: TradeId + , _tickPrice :: Double + , _tickSize :: Double + , _tickBid :: Double + , _tickAsk :: Double + , _tickVolume :: Double + , _tickTime :: UTCTime + } + deriving (Show, Typeable, Generic) + +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 .: "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 + , _tradeTime :: UTCTime + , _tradePrice :: Double + , _tradeSize :: Double + , _tradeSide :: Side + } + deriving (Show, Typeable, Generic) + +instance FromJSON Trade where + parseJSON = withObject "Trade" $ \o -> Trade + <$> o .: "trade_id" + <*> o .: "time" + <*> (o .: "price" >>= textDouble) + <*> (o .: "size" >>= textDouble) + <*> o .: "side" + +-- Candles + +type StartTime = UTCTime +type EndTime = UTCTime +type Granularity = Int + +type Low = Double +type High = Double +type Open = Double +type Close = Double +type Volume = Double + +data Candle = Candle UTCTime Low High Open Close Volume + deriving (Show, Typeable, Generic) + +instance FromJSON Candle where + parseJSON = withArray "Candle" $ \v -> + case V.length v of + 6 -> Candle <$> ((posixSecondsToUTCTime . fromIntegral) <$> (parseJSON (v V.! 0) :: Parser Int64)) + <*> parseJSON (v V.! 1) + <*> parseJSON (v V.! 2) + <*> parseJSON (v V.! 3) + <*> parseJSON (v V.! 4) + <*> parseJSON (v V.! 5) + _ -> fail "Candle array was not 6 elements wide." + +-- Stats + +data Stats + = Stats + { _statsOpen :: Open + , _statsHigh :: High + , _statsLow :: Low + , _statsVolume :: Volume + , _statsVolume30Day :: Volume + } + deriving (Show, Typeable, Generic) + +instance FromJSON Stats where + parseJSON = withObject "Stats" $ \o -> Stats + <$> o .: "open" + <*> o .: "high" + <*> o .: "low" + <*> o .: "volume" + <*> o .: "volume_30day" + +-- 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 + , _currName :: Text + , _currMinSize :: Double + } + deriving (Show, Typeable, Generic) + +instance FromJSON Currency where + parseJSON = withObject "Currency" $ \o -> Currency + <$> o .: "id" + <*> o .: "name" + <*> (o .: "min_size" >>= textDouble) diff --git a/test/Network/GDAX/Test/Feed.hs b/test/Network/GDAX/Test/Feed.hs new file mode 100644 --- /dev/null +++ b/test/Network/GDAX/Test/Feed.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.GDAX.Test.Feed + ( tests + ) where + +import Control.Lens +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 Data.Proxy +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import Data.Vector (Vector) +import Network.GDAX.Test.Types +import Network.GDAX.Types.Feed +import Network.GDAX.Types.MarketData (ProductId) +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) + + -- This one cannot run independently, since you only receive them if you + -- trade against yourself. + -- , parseTestClient (mkBTCSub [ChannelFull]) "change" (Proxy :: Proxy Change) + + -- This one cannot run independently, since you have to be authenticated with + -- a margin profile. + -- , parseTestClient (mkBTCSub [ChannelFull]) "margin_profile_update" (Proxy :: Proxy MarginProfileUpdate) + + -- This one cannot run independently, they occur very infrequently. + -- , parseTestClient (mkBTCSub [ChannelFull]) "activate" (Proxy :: Proxy Activate) + + , case_sum e + ] + +mkBTCSub :: Vector Channel -> Subscriptions +mkBTCSub = mkSubscriptions "BTC-USD" + +mkSubscriptions :: ProductId -> Vector Channel -> Subscriptions +mkSubscriptions pid cs = Subscriptions [] $ fmap fn cs + 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 + 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 + in return () + + sendTextData conn (Aeson.encode testUnSub) + where + testSub = Subscribe subs + testUnSub = UnSubscribe subs + +case_sum :: Env -> TestTree +case_sum _ = testCase "sum" $ + runSecureClient "ws-feed.gdax.com" 443 "/" client + where + client :: ClientApp () + client conn = do + sendTextData conn (Aeson.encode testSub) + + ms <- sequence $ take 100 $ repeat (receiveNotSubs conn) + + sendTextData conn (Aeson.encode testUnSub) + + let res = fmap Aeson.eitherDecode ms + + mapM_ assertRight (res :: [Either String GdaxMessage]) + + testSub = Subscribe $ Subscriptions [] subs + testUnSub = UnSubscribe $ Subscriptions [] subs + subs = + [ ChannelSubscription ChannelHeartbeat ["BTC-USD"] + , ChannelSubscription ChannelTicker ["BTC-USD"] + , ChannelSubscription ChannelLevel2 ["BTC-USD"] + , ChannelSubscription ChannelMatches ["BTC-USD"] + ] + +receiveOfType :: Connection -> Text -> IO LBS.ByteString +receiveOfType conn t = receiveOfTypes conn [t] + +receiveOfTypes :: Connection -> [Text] -> IO LBS.ByteString +receiveOfTypes conn ts = loop + where + tset = Set.fromList ts + loop = do + res <- receiveData conn + let asValue = Aeson.eitherDecode res :: Either String Value + case asValue of + Left er -> fail (show er) + Right v -> + case v ^? key "type" . _String of + Nothing -> loop + Just t -> + if Set.member t tset + then return res + else loop + +receiveNotSubs :: Connection -> IO LBS.ByteString +receiveNotSubs conn = loop + where + loop = do + res <- receiveData conn + let asValue = Aeson.eitherDecode res :: Either String Value + case asValue of + Left er -> fail (show er) + Right v -> + if (v ^? key "type") == (Just (String "subscriptions")) + then loop + else return res + +assertRight :: (Show e) => Either e a -> IO () +assertRight (Right _) = return () +assertRight (Left er) = fail (show er) diff --git a/test/Network/GDAX/Test/MarketData.hs b/test/Network/GDAX/Test/MarketData.hs new file mode 100644 --- /dev/null +++ b/test/Network/GDAX/Test/MarketData.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Network.GDAX.Test.MarketData + ( tests + ) where + +import Control.Lens +import Control.Monad.Reader +import Data.Time +import Network.GDAX.Implicit +import Network.GDAX.Test.Types +import Test.Tasty +import Test.Tasty.HUnit + +data LocalEnv + = LocalEnv + { _localGdax :: Gdax + } + +$(makeClassy ''LocalEnv) + +instance HasGdax LocalEnv where gdax = localGdax + +-------------------------------- +-- 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 :: 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 + ] + where + l = e ^. liveUnsigned + +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) => Gdax -> String -> ReaderT LocalEnv IO a -> TestTree +case_parse g l fn = testCase l $ runReaderT (void fn) (LocalEnv g) diff --git a/test/Network/GDAX/Test/Types.hs b/test/Network/GDAX/Test/Types.hs new file mode 100644 --- /dev/null +++ b/test/Network/GDAX/Test/Types.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Network.GDAX.Test.Types where + +import Control.Lens +import Network.GDAX.Implicit + +class HasSandbox a where + sandbox :: Lens' a Gdax + +class HasLiveUnsigned a where + liveUnsigned :: Lens' a Gdax + +data Env + = Env + { _envSandboxGdax :: Gdax + , _envLiveUnsignedGdax :: Gdax + } + +$(makeClassy ''Env) + +instance HasSandbox Env where sandbox = envSandboxGdax +instance HasLiveUnsigned Env where liveUnsigned = envLiveUnsignedGdax diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Char8 as CBS +import Network.GDAX.Implicit +import qualified Network.GDAX.Test.Feed as Feed +import qualified Network.GDAX.Test.MarketData as MarketData +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" + + sbox <- mkSandboxGdax gAccessKey gSecretKey gPassphrase + live <- mkLiveUnsignedGdax + defaultMain $ tests (Env sbox live) + +tests :: Env -> TestTree +tests e = testGroup "Tests" + [ MarketData.tests e + , Feed.tests e + ]