gdax (empty) → 0.5.0.0
raw patch · 21 files changed
+1760/−0 lines, 21 filesdep +aesondep +aeson-casingdep +aeson-prettysetup-changed
Dependencies added: aeson, aeson-casing, aeson-pretty, base, base64-bytestring, byteable, bytestring, containers, cryptohash, exceptions, gdax, http-client, http-client-tls, lens, lens-aeson, mtl, scientific, tasty, tasty-hunit, tasty-quickcheck, tasty-th, text, time, uuid, vector, websockets, wreq, wuss
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- app/Sandbox.hs +68/−0
- gdax.cabal +111/−0
- lib/Network/GDAX.hs +5/−0
- lib/Network/GDAX/Core.hs +177/−0
- lib/Network/GDAX/Exceptions.hs +10/−0
- lib/Network/GDAX/Explicit.hs +15/−0
- lib/Network/GDAX/Explicit/MarketData.hs +65/−0
- lib/Network/GDAX/Explicit/Private.hs +24/−0
- lib/Network/GDAX/Feed.hs +20/−0
- lib/Network/GDAX/Implicit.hs +15/−0
- lib/Network/GDAX/Implicit/MarketData.hs +64/−0
- lib/Network/GDAX/Implicit/Private.hs +22/−0
- lib/Network/GDAX/Parsers.hs +49/−0
- lib/Network/GDAX/Types/Feed.hs +577/−0
- lib/Network/GDAX/Types/MarketData.hs +263/−0
- test/Network/GDAX/Test/Feed.hs +138/−0
- test/Network/GDAX/Test/MarketData.hs +64/−0
- test/Network/GDAX/Test/Types.hs +23/−0
- test/Test.hs +28/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Sandbox.hs view
@@ -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..."
+ gdax.cabal view
@@ -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 <andrewrademacher@icloud.com>+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
+ lib/Network/GDAX.hs view
@@ -0,0 +1,5 @@+module Network.GDAX+ ( module Explicit+ ) where++import Network.GDAX.Explicit as Explicit
+ lib/Network/GDAX/Core.hs view
@@ -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) ]
+ lib/Network/GDAX/Exceptions.hs view
@@ -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
+ lib/Network/GDAX/Explicit.hs view
@@ -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
+ lib/Network/GDAX/Explicit/MarketData.hs view
@@ -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
+ lib/Network/GDAX/Explicit/Private.hs view
@@ -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"
+ lib/Network/GDAX/Feed.hs view
@@ -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
+ lib/Network/GDAX/Implicit.hs view
@@ -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
+ lib/Network/GDAX/Implicit/MarketData.hs view
@@ -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
+ lib/Network/GDAX/Implicit/Private.hs view
@@ -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
+ lib/Network/GDAX/Parsers.hs view
@@ -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
+ lib/Network/GDAX/Types/Feed.hs view
@@ -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 <> "'."
+ lib/Network/GDAX/Types/MarketData.hs view
@@ -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)
+ test/Network/GDAX/Test/Feed.hs view
@@ -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)
+ test/Network/GDAX/Test/MarketData.hs view
@@ -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)
+ test/Network/GDAX/Test/Types.hs view
@@ -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
+ test/Test.hs view
@@ -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+ ]