mtgoxapi (empty) → 0.5
raw patch · 17 files changed
+2022/−0 lines, 17 filesdep +HTTPdep +HUnitdep +QuickChecksetup-changed
Dependencies added: HTTP, HUnit, QuickCheck, SHA, aeson, attoparsec, base, base16-bytestring, base64-bytestring, bytestring, curl, either, errors, hashable, ixset, network, test-framework, test-framework-hunit, test-framework-quickcheck2, text, time, transformers, unordered-containers, vector, watchdog
Files
- LICENSE +29/−0
- Network/MtGoxAPI.hs +142/−0
- Network/MtGoxAPI/Credentials.hs +45/−0
- Network/MtGoxAPI/CurlWrapper.hs +57/−0
- Network/MtGoxAPI/DepthStore.hs +268/−0
- Network/MtGoxAPI/DepthStore/Adapter.hs +28/−0
- Network/MtGoxAPI/Handles.hs +20/−0
- Network/MtGoxAPI/HttpAPI.hs +280/−0
- Network/MtGoxAPI/StreamAuthCommands.hs +107/−0
- Network/MtGoxAPI/StreamCommands.hs +55/−0
- Network/MtGoxAPI/StreamConnection.hs +194/−0
- Network/MtGoxAPI/TickerMonitor.hs +85/−0
- Network/MtGoxAPI/Types.hs +401/−0
- Network/MtGoxAPI/WalletNotifier.hs +31/−0
- Setup.hs +2/−0
- TestSuite.hs +156/−0
- mtgoxapi.cabal +122/−0
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2012 - 2014, Jan Vornberger+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Network/MtGoxAPI.hs view
@@ -0,0 +1,142 @@+-- |+-- This library offers a wrapper around the Mt.Gox API. It focuses, above all,+-- on reliability, in that many actions - if they are idempotent - are+-- automatically retried for some time in case of errors (using+-- 'Control.Watchdog').+--+-- The library is able to maintain a copy of the current Mt.Gox order book by+-- subscribing to real-time updates via the Mt.Gox websocket API. Based on this+-- data the cost of hypothetical orders can then be calculated (e.g.+-- 'simulateBTCBuy'). For this feature to work, it is necessary to run an+-- instance of the MtGoxCachingProxy (+-- https://github.com/javgh/MtGoxCachingProxy ) to which the library will+-- connect (using port 10508 on localhost).+--+-- Example usage:+--+-- > import Network.MtGoxAPI+-- >+-- > import qualified Data.ByteString.Char8 as B8+-- >+-- > main :: IO ()+-- > main = do+-- > putStrLn "Please provide your API key: "+-- > authKey <- getLine+-- > putStrLn "Please provide your API secret: "+-- > authSecret <- getLine+-- > let credentials = initMtGoxCredentials (B8.pack authKey)+-- > (B8.pack authSecret)+-- > streamSettings = MtGoxStreamSettings DisableWalletNotifications+-- > SkipFullDepth+-- > apiHandles <- initMtGoxAPI Nothing credentials streamSettings+-- > getPrivateInfoR apiHandles >>= print+--+-- Example output:+--+-- @+-- Please provide your API key:+-- ...+-- Please provide your API secret:+-- ...+-- Right (PrivateInfo {piBtcBalance = 1000000, piUsdBalance = 846450,+-- piBtcOperations = 441, piUsdOperations = 6, piFee = 0.45})+-- @+--++module Network.MtGoxAPI+ ( initMtGoxAPI+ , getTickerStatus+ , simulateBTCSell+ , simulateBTCBuy+ , simulateUSDSell+ , simulateUSDBuy+ , waitForBTCDeposit+ , getOrderCountR+ , getPrivateInfoR+ , getBitcoinDepositAddressR+ , withdrawBitcoins+ , submitOrder+ , submitBtcBuyOrder+ , submitBtcSellOrder+ , module Network.MtGoxAPI.Credentials+ , module Network.MtGoxAPI.Handles+ , module Control.Watchdog+ , TickerStatus(..)+ , DepthStoreAnswer(..)+ , H.OrderStats(..)+ , module Network.MtGoxAPI.Types+ ) where++import Control.Watchdog++import Network.MtGoxAPI.Credentials+import Network.MtGoxAPI.CurlWrapper+import Network.MtGoxAPI.DepthStore+import Network.MtGoxAPI.Handles+import Network.MtGoxAPI.StreamConnection+import Network.MtGoxAPI.TickerMonitor+import Network.MtGoxAPI.Types+import Network.MtGoxAPI.WalletNotifier++import qualified Network.MtGoxAPI.HttpAPI as H++-- | Rolls all the individual init functions into one. Namely+-- 'initTickerMonitor', 'initDepthStore', 'initCurlWrapper',+-- 'initWalletNotifier' and finally 'initMtGoxStream'. All handles are returned+-- in one package and can then be used in combination with the various functions+-- from the submodules which are re-exported here for convenience.+initMtGoxAPI :: Maybe WatchdogLogger-> MtGoxCredentials -> MtGoxStreamSettings -> IO MtGoxAPIHandles+initMtGoxAPI mLogger mtgoxCreds mtgoxStreamSettings = do+ tickerMonitorHandle <- initTickerMonitor+ depthStoreHandle <- initDepthStore+ curlHandle <- initCurlWrapper+ walletNotifierHandle <- initWalletNotifier+ let mtgoxAPIHandles = MtGoxAPIHandles+ { mtgoxCredentials = mtgoxCreds+ , mtgoxLogger = mLogger+ , mtgoxCurlHandle = curlHandle+ , mtgoxTickerMonitorHandle = tickerMonitorHandle+ , mtgoxDepthStoreHandle = depthStoreHandle+ , mtgoxWalletNotifierHandle = walletNotifierHandle+ }+ _ <- initMtGoxStream mtgoxCreds mtgoxStreamSettings mtgoxAPIHandles+ return mtgoxAPIHandles++-- | Wrapper around 'H.getOrderCountR'+getOrderCountR :: MtGoxAPIHandles -> IO (Either String OpenOrderCount)+getOrderCountR apiData = callHTTPApi apiData H.getOrderCountR++-- | Wrapper around 'H.getPrivateInfoR'+getPrivateInfoR :: MtGoxAPIHandles -> IO (Either String PrivateInfo)+getPrivateInfoR apiData = callHTTPApi apiData H.getPrivateInfoR++-- | Wrapper around 'H.getBitcoinDepositAddressR'+getBitcoinDepositAddressR :: MtGoxAPIHandles -> IO (Either String BitcoinDepositAddress)+getBitcoinDepositAddressR apiData = callHTTPApi apiData H.getBitcoinDepositAddressR++-- | Wrapper around 'H.withdrawBitcoins'+withdrawBitcoins :: MtGoxAPIHandles-> BitcoinAddress -> Integer -> IO (Either String WithdrawResult)+withdrawBitcoins apiData = callHTTPApi' apiData H.withdrawBitcoins++-- | Wrapper around 'H.submitOrder'+submitOrder :: MtGoxAPIHandles-> OrderType -> Integer -> IO (Either String H.OrderStats)+submitOrder apiData = callHTTPApi apiData H.submitOrder++-- | Wrapper around 'H.submitBtcBuyOrder'+submitBtcBuyOrder :: MtGoxAPIHandles -> Integer -> IO (Either String Order)+submitBtcBuyOrder apiData = callHTTPApi' apiData H.submitBtcBuyOrder++-- | Wrapper around 'H.submitBtcSellOrder'+submitBtcSellOrder :: MtGoxAPIHandles -> Integer -> IO (Either String Order)+submitBtcSellOrder apiData = callHTTPApi' apiData H.submitBtcSellOrder++-- | Helper function to call functions from 'Network.MtGoxAPI.HttpAPI'.+callHTTPApi :: MtGoxAPIHandles-> (Maybe WatchdogLogger -> CurlHandle -> MtGoxCredentials -> t)-> t+callHTTPApi apiData f =+ f (mtgoxLogger apiData) (mtgoxCurlHandle apiData) (mtgoxCredentials apiData)++-- | Helper function to call functions from 'Network.MtGoxAPI.HttpAPI' that do+-- not use a logger.+callHTTPApi' :: MtGoxAPIHandles -> (CurlHandle -> MtGoxCredentials -> t) -> t+callHTTPApi' apiData f =+ f (mtgoxCurlHandle apiData) (mtgoxCredentials apiData)
+ Network/MtGoxAPI/Credentials.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.MtGoxAPI.Credentials+ ( initMtGoxCredentials+ , MtGoxCredentials(..)+ ) where++import Data.Word++import qualified Data.ByteString as B+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Base64 as B64++data MtGoxCredentials = MtGoxCredentials { mgcAuthKey :: B.ByteString+ , mgcAuthKeyDecoded :: B.ByteString+ , mgcAuthSecret :: B.ByteString+ , mgcAuthSecretDecoded :: B.ByteString+ }+ deriving (Show)++dash :: Word8+dash = B.head "-"++fromRight :: String -> Either t t1 -> t1+fromRight msg (Left _) = error msg+fromRight _ (Right a) = a++fromFst :: String -> (B.ByteString, B.ByteString) -> B.ByteString+fromFst msg (a, b)+ | B.null b = a+ | otherwise = error msg++initMtGoxCredentials :: B.ByteString -> B.ByteString -> MtGoxCredentials+initMtGoxCredentials authKey authSecret =+ let errMsg arg base = arg ++ " needs to be encoded in base " ++ base+ authKeyFiltered = B.filter (/= dash) authKey+ authKeyDecoded = fromFst (errMsg "authKey" "16")+ . B16.decode $ authKeyFiltered+ authSecretDecoded = fromRight (errMsg "authSecret" "64")+ . B64.decode $ authSecret+ in MtGoxCredentials { mgcAuthKey = authKey+ , mgcAuthKeyDecoded = authKeyDecoded+ , mgcAuthSecret = authSecret+ , mgcAuthSecretDecoded = authSecretDecoded+ }
+ Network/MtGoxAPI/CurlWrapper.hs view
@@ -0,0 +1,57 @@+module Network.MtGoxAPI.CurlWrapper+ ( initCurlWrapper+ , performCurlRequest+ , CurlHandle+ ) where++import Control.Applicative+import Control.Concurrent+import Data.IORef+import Network.Curl++data CurlData = CurlData { cdUrl :: URLString+ , cdOpts :: [CurlOption]+ , cdAnswerChan :: Chan (CurlCode, String)+ }++newtype CurlHandle = CurlHandle { unCH :: Chan CurlData }++-- | Will start a thread which will execute cURL requests that are passed to it+-- using 'performCurlRequest'. Internally only a single cURL handle is opened,+-- which means that keep-alive connections are automatically reused.+initCurlWrapper :: IO CurlHandle+initCurlWrapper = do+ chan <- newChan :: IO (Chan CurlData)+ _ <- forkIO $ curlThread chan+ return $ CurlHandle chan++curlThread :: Chan CurlData -> IO ()+curlThread requestChan = withCurlDo $ do+ handle <- initialize+ _ <- setopt handle (CurlVerbose False)+ _ <- setopt handle (CurlUserAgent "libcurl")+ _ <- setopt handle (CurlFailOnError True)+ _ <- setopt handle (CurlSSLVerifyPeer False)+ _ <- setopt handle (CurlSSLVerifyHost 0)+ go handle+ where+ go h = do+ CurlData url opts answerChan <- readChan requestChan+ ref <- newIORef []+ _ <- setopt h (CurlURL url)+ _ <- setopt h (CurlWriteFunction (gatherOutput ref))+ mapM_ (setopt h) opts+ rc <- perform h+ body <- concat . reverse <$> readIORef ref+ writeChan answerChan (rc, body)+ go h++performCurlRequest :: CurlHandle -> URLString -> [CurlOption] -> IO (CurlCode, String)+performCurlRequest curlHandle url opts = do+ answerChan <- newChan+ let cd = CurlData { cdUrl = url+ , cdOpts = opts+ , cdAnswerChan = answerChan+ }+ writeChan (unCH curlHandle) cd+ readChan answerChan
+ Network/MtGoxAPI/DepthStore.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE BangPatterns, DeriveDataTypeable, CPP #-}++module Network.MtGoxAPI.DepthStore+ ( initDepthStore+ , updateDepthStore+ , setHasFullDepth+ , simulateBTCSell+ , simulateBTCBuy+ , simulateUSDSell+ , simulateUSDBuy+ , DepthStoreHandle+ , DepthStoreType(..)+ , DepthStoreAnswer(..)+#if !PRODUCTION+ , simulateBTC+ , simulateUSD+ , DepthStoreEntry (..)+#endif+ ) where++import Control.Applicative+import Control.Concurrent+import Control.Watchdog+import Data.IxSet((@<), (@>), (@>=), (@<=))+import Data.Time.Clock+import Data.Typeable++import qualified Data.IxSet as I++staleInterval :: NominalDiffTime+staleInterval = -1 * 60 * 60 * 24 -- remove entries older than one day++intervalToRemove :: NominalDiffTime+intervalToRemove = -1 * 60 -- remove in blocks of these, so we do+ -- not have to do it as often++noActivityDetectionInterval :: NominalDiffTime+noActivityDetectionInterval = 180 -- declare Depth store out of date,+ -- if we do not see activity for these+ -- number of seconds++watchdogSettings :: WatchdogAction ()+watchdogSettings = do+ setLoggingAction silentLogger+ setInitialDelay 250000 -- 250 ms+ setMaximumRetries 6+ -- will fail after:+ -- 0.25 + 0.5 + 1 + 2 + 4 + 8 seconds = 15.75 seconds++data DepthStoreEntry = DepthStoreEntry { dseAmount :: Integer+ , dsePrice :: Integer+ , dseTimestamp :: UTCTime+ }+ deriving (Eq, Ord, Show, Typeable)++instance I.Indexable DepthStoreEntry+ where+ empty = I.ixSet [ I.ixFun $ \e -> [ dsePrice e ]+ , I.ixFun $ \e -> [ dseTimestamp e ]+ ]++data DepthStoreAnswer = DepthStoreAnswer Integer+ | NotEnoughDepth+ | DepthStoreUnavailable+ deriving (Show)++data DepthStoreType = DepthStoreAsk | DepthStoreBid+ deriving (Show)++data DepthStoreData = DepthStoreData { dsdAskStore :: I.IxSet DepthStoreEntry+ , dsdBidStore :: I.IxSet DepthStoreEntry+ , dsdHasFullDepth :: Bool+ , dsdLastUpdate :: Maybe UTCTime+ }+ deriving (Show)++data DepthStoreHandle = DepthStoreHandle+ { _unDSH :: MVar DepthStoreData }++initDepthStore :: IO DepthStoreHandle+initDepthStore = do+ let dsd = DepthStoreData { dsdAskStore = I.empty+ , dsdBidStore = I.empty+ , dsdHasFullDepth = False+ , dsdLastUpdate = Nothing+ }+ DepthStoreHandle <$> newMVar dsd++setHasFullDepth :: DepthStoreHandle -> IO ()+setHasFullDepth (DepthStoreHandle dsdMVar) = do+ dsd <- takeMVar dsdMVar+ putMVar dsdMVar dsd { dsdHasFullDepth = True }+ return ()++updateDepthStore :: DepthStoreHandle -> DepthStoreType -> Integer -> Integer -> IO ()+updateDepthStore (DepthStoreHandle dsdMVar) t amount price = do+ dsd <- readMVar dsdMVar -- Read and put it back, so that we+ -- do not block other readers while we+ -- are doing the update. It is no problem if+ -- they receive slightly outdated data and it is+ -- safe, since we are the only producer.+ timestamp <- getCurrentTime+ askStore' <- removeStaleEntries $ dsdAskStore dsd+ bidStore' <- removeStaleEntries $ dsdBidStore dsd+ let (askStore'', bidStore'') =+ case t of+ DepthStoreAsk ->+ (askStore', removeConflictingBidEntries bidStore' price)+ DepthStoreBid ->+ (removeConflictingAskEntries askStore' price, bidStore')+ let (askStore''', bidStore''') =+ case t of+ DepthStoreAsk ->+ (updateStore askStore'' amount price timestamp, bidStore'')+ DepthStoreBid ->+ (askStore'', updateStore bidStore'' amount price timestamp)+ _ <- swapMVar dsdMVar dsd { dsdAskStore = askStore'''+ , dsdBidStore = bidStore'''+ , dsdLastUpdate = Just timestamp+ }+ return ()++isDataFresh :: DepthStoreHandle -> IO (Either String ())+isDataFresh (DepthStoreHandle dsdMVar) = do+ dsd <- readMVar dsdMVar+ now <- getCurrentTime+ return $ decide (dsdHasFullDepth dsd) (dsdLastUpdate dsd) now+ where+ decide False _ _ = Left "Full depth not yet available."+ decide True Nothing _ = Left "Depth store is still empty."+ decide True (Just timestamp) now =+ let age = diffUTCTime now timestamp+ in if age > noActivityDetectionInterval+ then Left "Depth store data is stale"+ else Right ()++repeatSimulation :: DepthStoreHandle -> IO (Maybe Integer) -> IO DepthStoreAnswer+repeatSimulation handle simulationAction = do+ let task = do+ isFresh <- isDataFresh handle+ case isFresh of+ Left msg -> return $ Left msg+ Right _ -> Right <$> simulationAction+ result <- watchdog $ do+ watchdogSettings+ watchImpatiently task+ return $ case result of+ Left _ -> DepthStoreUnavailable+ Right v -> case v of+ Just v' -> DepthStoreAnswer v'+ Nothing -> NotEnoughDepth++-- | Simulate how much USD can be earned by selling the specified amount of BTC.+-- The function will return 'NotEnoughDepth' in case there is not enough depth+-- to cover the full amount. If no recent data is available, it will return+-- 'DepthStoreUnavailable'. In the latter case it will have retried a few times+-- before giving up. The function will not block for longer than about 20+-- seconds.+simulateBTCSell :: DepthStoreHandle -> Integer -> IO DepthStoreAnswer+simulateBTCSell handle@(DepthStoreHandle dsdMVar) amount =+ repeatSimulation handle simulation+ where+ simulation = do+ dsd <- readMVar dsdMVar+ let bids = I.toDescList (I.Proxy :: I.Proxy Integer) $ dsdBidStore dsd+ return $ simulateBTC amount bids++-- | Simulate how much USD will be needed to buy the specified amount of BTC.+-- See 'simulateBTCSell' for more details.+simulateBTCBuy :: DepthStoreHandle -> Integer -> IO DepthStoreAnswer+simulateBTCBuy handle@(DepthStoreHandle dsdMVar) amount =+ repeatSimulation handle simulation+ where+ simulation = do+ dsd <- readMVar dsdMVar+ let asks = I.toAscList (I.Proxy :: I.Proxy Integer) $ dsdAskStore dsd+ return $ simulateBTC amount asks++-- | Simulate how much BTC can be earned by selling the specified amount of USD.+-- See 'simulateBTCSell' for more details.+simulateUSDSell :: DepthStoreHandle -> Integer -> IO DepthStoreAnswer+simulateUSDSell handle@(DepthStoreHandle dsdMVar) usdAmount =+ repeatSimulation handle simulation+ where+ simulation = do+ dsd <- readMVar dsdMVar+ let asks = I.toAscList (I.Proxy :: I.Proxy Integer) $ dsdAskStore dsd+ return $ simulateUSD usdAmount asks++-- | Simulate how much BTC will be needed to buy the specified amount of USD.+-- See 'simulateBTCSell' for more details.+simulateUSDBuy :: DepthStoreHandle -> Integer -> IO DepthStoreAnswer+simulateUSDBuy handle@(DepthStoreHandle dsdMVar) usdAmount =+ repeatSimulation handle simulation+ where+ simulation = do+ dsd <- readMVar dsdMVar+ let bids = I.toDescList (I.Proxy :: I.Proxy Integer) $ dsdBidStore dsd+ return $ simulateUSD usdAmount bids++updateStore :: I.IxSet DepthStoreEntry-> Integer -> Integer -> UTCTime -> I.IxSet DepthStoreEntry+updateStore !store amount price timestamp =+ let entry = DepthStoreEntry { dseAmount = amount+ , dsePrice = price+ , dseTimestamp = timestamp+ }+ in I.updateIx price entry store++removeStaleEntries :: (I.Indexable a, Typeable a, Ord a) => I.IxSet a -> IO (I.IxSet a)+removeStaleEntries !store = do+ now <- getCurrentTime+ let cutoff = addUTCTime staleInterval now+ -- We will do a fast check first, to avoid constantly moving stuff+ -- around in memory. In addition, we go a little further into the past,+ -- so that when the check fires, we have a bunch of stuff to remove at+ -- once.+ fastCutoffCheck = addUTCTime intervalToRemove cutoff+ if I.null (store @< fastCutoffCheck)+ then return store+ else return $ store @>= cutoff+++-- | Keep internal consistency, by removing bids that a higher than+-- the new ask, which means they must have already been filled.+removeConflictingBidEntries :: (Ord a, Typeable k, Typeable a, I.Indexable a) =>I.IxSet a -> k -> I.IxSet a+removeConflictingBidEntries !bidStore askPrice =+ if I.null (bidStore @>= askPrice)+ then bidStore+ else bidStore @< askPrice++-- | Keep internal consistency, by removing asks that a lower than+-- the new bid, which means they must have already been filled.+removeConflictingAskEntries :: (Ord a, Typeable k, Typeable a, I.Indexable a) =>I.IxSet a -> k -> I.IxSet a+removeConflictingAskEntries !askStore bidPrice =+ if I.null (askStore @<= bidPrice)+ then askStore+ else askStore @> bidPrice++simulateBTC :: Integer -> [DepthStoreEntry] -> Maybe Integer+simulateBTC 0 _ = Just 0+simulateBTC _ [] = Nothing+simulateBTC remainingAmount ((dse@DepthStoreEntry {}):entries) =+ let amount = dseAmount dse+ price = dsePrice dse+ in if remainingAmount <= amount+ then Just (adjustZeros (remainingAmount * price))+ else let x = adjustZeros (amount * price)+ y = simulateBTC (remainingAmount - amount) entries+ in (+) x <$> y+ where+ adjustZeros = round . (/ (10 ^ (8 :: Integer) :: Double)) . fromIntegral++simulateUSD :: Integer -> [DepthStoreEntry] -> Maybe Integer+simulateUSD 0 _ = Just 0+simulateUSD _ [] = Nothing+simulateUSD remainingUsdAmount ((dse@DepthStoreEntry {}):entries) =+ let amount = dseAmount dse+ price = dsePrice dse+ totalCost = adjustZeros(amount * price)+ in if remainingUsdAmount <= totalCost+ then Just (adjustedDevide remainingUsdAmount price)+ else let x = amount+ y = simulateUSD (remainingUsdAmount - totalCost) entries+ in (+) x <$> y+ where+ adjustZeros = round . (/ (10 ^ (8 :: Integer) :: Double)) . fromIntegral+ adjustedDevide a b = round . (/ (fromIntegral b :: Double))+ . fromIntegral . (* 10 ^ (8 :: Integer)) $ a
+ Network/MtGoxAPI/DepthStore/Adapter.hs view
@@ -0,0 +1,28 @@+module Network.MtGoxAPI.DepthStore.Adapter+ ( updateDepthStoreFromMessage+ , updateDepthStoreFromFullDepth+ , skipFullDepthRequest+ ) where++import Network.MtGoxAPI.Types+import Network.MtGoxAPI.DepthStore++updateDepthStoreFromMessage :: DepthStoreHandle -> StreamMessage -> IO ()+updateDepthStoreFromMessage handle (du@DepthUpdateUSD {}) = do+ let t = case duType du of+ Ask -> DepthStoreAsk+ Bid -> DepthStoreBid+ updateDepthStore handle t (duVolume du) (duPrice du)+updateDepthStoreFromMessage _ _ = return ()++updateDepthStoreFromFullDepth :: DepthStoreHandle -> FullDepth -> IO ()+updateDepthStoreFromFullDepth handle depth = do+ mapM_ (updateCmd DepthStoreAsk) (fdAsks depth)+ mapM_ (updateCmd DepthStoreBid) (fdBids depth)+ setHasFullDepth handle+ where+ updateCmd t (DepthEntry { deAmount = amount, dePrice = price }) =+ updateDepthStore handle t amount price++skipFullDepthRequest :: DepthStoreHandle -> IO ()+skipFullDepthRequest = setHasFullDepth
+ Network/MtGoxAPI/Handles.hs view
@@ -0,0 +1,20 @@+module Network.MtGoxAPI.Handles+ ( MtGoxAPIHandles(..)+ ) where++import Control.Watchdog++import Network.MtGoxAPI.Credentials+import Network.MtGoxAPI.CurlWrapper+import Network.MtGoxAPI.DepthStore+import Network.MtGoxAPI.TickerMonitor+import Network.MtGoxAPI.WalletNotifier++data MtGoxAPIHandles = MtGoxAPIHandles+ { mtgoxCredentials :: MtGoxCredentials+ , mtgoxLogger :: Maybe WatchdogLogger+ , mtgoxCurlHandle :: CurlHandle+ , mtgoxTickerMonitorHandle :: TickerMonitorHandle+ , mtgoxDepthStoreHandle :: DepthStoreHandle+ , mtgoxWalletNotifierHandle :: WalletNotifierHandle+ }
+ Network/MtGoxAPI/HttpAPI.hs view
@@ -0,0 +1,280 @@+-- |+-- Functions that are marked with the suffix 'R' retry automatically in case of+-- failure up to a certain number of times. However, they will return after+-- about 20 seconds in the worst case. Exceptions: 'letOrdersExecuteR' and+-- 'submitOrder'.++{-# LANGUAGE OverloadedStrings #-}++module Network.MtGoxAPI.HttpAPI+ ( getOrderCountR+ , submitBtcBuyOrder+ , submitBtcSellOrder+ , getOrderResultR+ , getWalletHistoryR+ , getPrivateInfoR+ , getBitcoinDepositAddressR+ , withdrawBitcoins+ , letOrdersExecuteR+ , submitOrder+ , OrderStats(..)+ ) where++import Control.Error+import Control.Monad+import Control.Monad.IO.Class+import Control.Watchdog+import Data.Aeson+import Data.Digest.Pure.SHA+import Network.Curl+import Network.HTTP.Base (urlEncodeVars)++import qualified Control.Arrow as A+import qualified Data.Attoparsec as AP+import qualified Data.ByteString as B+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BL8+import qualified Data.HashMap.Strict as H+import qualified Data.Text as T++import Network.MtGoxAPI.Credentials+import Network.MtGoxAPI.CurlWrapper+import Network.MtGoxAPI.StreamAuthCommands+import Network.MtGoxAPI.Types++data HttpApiResult = HttpApiSuccess Value+ | HttpApiFailure+ deriving (Show)++data OrderStats = OrderStats { usdEarned :: Integer+ , usdSpent :: Integer+ , usdFee :: Integer+ }+ deriving (Show)++instance FromJSON HttpApiResult where+ parseJSON (Object o) = case H.lookup "result" o of+ Just "success" -> case H.lookup "return" o of+ Just v -> return $ HttpApiSuccess v+ Nothing -> return HttpApiFailure+ Just _ -> return HttpApiFailure+ Nothing -> return HttpApiFailure+ parseJSON _ = return HttpApiFailure++mtGoxApi :: String+mtGoxApi = "https://mtgox.com/api/"++watchdogSettings :: WatchdogAction ()+watchdogSettings = do+ setInitialDelay 250000 -- 250 ms+ setMaximumRetries 6+ -- will fail after:+ -- 0.25 + 0.5 + 1 + 2 + 4 + 8 seconds = 15.75 seconds++parseReply :: FromJSON a => String -> Value -> a+parseReply method v =+ case fromJSON v of+ Success r -> r+ Error _ -> error ("Unexpected result when calling method " ++ method)++robustApiCall :: Maybe WatchdogLogger-> IO (Either String b) -> IO (Either String b)+robustApiCall mLogger f = watchdog $ do+ watchdogSettings+ case mLogger of+ Just logger -> setLoggingAction logger+ Nothing -> return ()+ watchImpatiently f++callApi :: CurlHandle -> MtGoxCredentials-> URLString-> [(String, String)]-> IO (Either String HttpApiResult)+callApi curlHandle mtGoxCred uri parameters = do+ nonce <- getNonce+ let parameters' = ("nonce", T.unpack nonce) : parameters+ (headers, body) = compileRequest mtGoxCred parameters'+ (status, payload) <- performCurlRequest curlHandle uri+ [ CurlHttpHeaders headers+ , CurlPostFields [body]+ ]+ return $ case status of+ CurlOK -> case AP.parseOnly json (B8.pack payload) of+ Left err' -> Left $ "JSON parse error: " ++ err'+ Right jsonV -> case fromJSON jsonV of+ (Error err'') -> Left $ "API parse error: " ++ err''+ (Success v) -> Right v :: Either String HttpApiResult+ errMsg -> Left $ "Curl error: " ++ show errMsg++compileRequest :: MtGoxCredentials -> [(String, String)] -> ([String], String)+compileRequest credentials parameters =+ let authSecretDecoded = mgcAuthSecretDecoded credentials+ authKey = mgcAuthKey credentials+ body = urlEncodeVars parameters+ hmac = hmacSha512 (BL.fromChunks [authSecretDecoded]) (BL8.pack body)+ hmacFormatted = B64.encode . foldl1 B.append+ . BL.toChunks . bytestringDigest $ hmac+ headers = [ "Rest-Key: " ++ B8.unpack authKey+ , "Rest-Sign: " ++ B8.unpack hmacFormatted+ ]+ in (headers, body)++getOrderCountR :: Maybe WatchdogLogger -> CurlHandle -> MtGoxCredentials -> IO (Either String OpenOrderCount)+getOrderCountR mLogger curlHandle mtGoxCreds = do+ let uri = mtGoxApi ++ "1/generic/private/orders"+ v <- robustApiCall mLogger $ callApi curlHandle mtGoxCreds uri []+ return $ case v of+ Left errMsg -> Left errMsg+ Right HttpApiFailure -> Left "HttpApiFailure when doing getOrderCountR"+ Right (HttpApiSuccess v') ->+ Right (parseReply "getOrderCountR" v') :: Either String OpenOrderCount++submitBtcBuyOrder :: CurlHandle -> MtGoxCredentials -> Integer -> IO (Either String Order)+submitBtcBuyOrder curlHandle mtGoxCreds amount = do+ let uri = mtGoxApi ++ "1/BTCEUR/private/order/add"+ parameters = [ ("type", "bid")+ , ("amount_int", show amount)+ , ("prefer_fiat_fee", "1")+ ]+ v <- callApi curlHandle mtGoxCreds uri parameters+ return $ case v of+ Left errMsg -> Left errMsg+ Right HttpApiFailure -> Left "HttpApiFailure when doing submitBtcBuyOrder"+ Right (HttpApiSuccess v') ->+ Right (parseReply "submitBtcBuyOrder" v') :: Either String Order++submitBtcSellOrder :: CurlHandle -> MtGoxCredentials -> Integer -> IO (Either String Order)+submitBtcSellOrder curlHandle mtGoxCreds amount = do+ let uri = mtGoxApi ++ "1/BTCEUR/private/order/add"+ parameters = [ ("type", "ask")+ , ("amount_int", show amount)+ , ("prefer_fiat_fee", "1")+ ]+ v <- callApi curlHandle mtGoxCreds uri parameters+ return $ case v of+ Left errMsg -> Left errMsg+ Right HttpApiFailure -> Left "HttpApiFailure when doing submitBtcSellOrder"+ Right (HttpApiSuccess v') ->+ Right (parseReply "submitBtcSellOrder" v') :: Either String Order++getOrderResultR :: Maybe WatchdogLogger-> CurlHandle -> MtGoxCredentials-> OrderType-> OrderID-> IO (Either String OrderResult)+getOrderResultR mLogger curlHandle mtGoxCreds orderType orderID = do+ let uri = mtGoxApi ++ "1/generic/private/order/result"+ parameters = [ ("type", case orderType of+ OrderTypeBuyBTC -> "bid"+ OrderTypeSellBTC -> "ask")+ , ("order", T.unpack (oid orderID))+ ]+ v <- robustApiCall mLogger $ callApi curlHandle mtGoxCreds uri parameters+ return $ case v of+ Left errMsg -> Left errMsg+ Right HttpApiFailure -> Left "HttpApiFailure when doing getOrderResultR"+ Right (HttpApiSuccess v') ->+ Right (parseReply "getOrderResultR" v') :: Either String OrderResult++getWalletHistoryR :: Maybe WatchdogLogger-> CurlHandle -> MtGoxCredentials-> TradeID-> IO (Either String WalletHistory)+getWalletHistoryR mLogger curlHandle mtGoxCreds tradeID = do+ let uri = mtGoxApi ++ "1/generic/private/wallet/history"+ parameters = [ ("currency", "EUR")+ , ("trade_id", T.unpack (tid tradeID))+ ]+ v <- robustApiCall mLogger $ callApi curlHandle mtGoxCreds uri parameters+ return $ case v of+ Left errMsg -> Left errMsg+ Right HttpApiFailure -> Left "HttpApiFailure when doing getWalletHistoryR"+ Right (HttpApiSuccess v') ->+ Right (parseReply "getWalletHistoryR" v') :: Either String WalletHistory++getPrivateInfoR :: Maybe WatchdogLogger-> CurlHandle -> MtGoxCredentials -> IO (Either String PrivateInfo)+getPrivateInfoR mLogger curlHandle mtGoxCreds = do+ let uri = mtGoxApi ++ "1/generic/private/info"+ v <- robustApiCall mLogger $ callApi curlHandle mtGoxCreds uri []+ return $ case v of+ Left errMsg -> Left errMsg+ Right HttpApiFailure -> Left "HttpApiFailure when doing getPrivateInfoR"+ Right (HttpApiSuccess v') -> + Right (parseReply "getPrivateInfoR" v') :: Either String PrivateInfo++getBitcoinDepositAddressR :: Maybe WatchdogLogger-> CurlHandle-> MtGoxCredentials-> IO (Either String BitcoinDepositAddress)+getBitcoinDepositAddressR mLogger curlHandle mtGoxCreds = do+ let uri = mtGoxApi ++ "1/generic/bitcoin/address"+ v <- robustApiCall mLogger $ callApi curlHandle mtGoxCreds uri []+ return $ case v of+ Left errMsg -> Left errMsg+ Right HttpApiFailure -> Left "HttpApiFailure when doing getBitcoinDepositAddressR"+ Right (HttpApiSuccess v') ->+ Right (parseReply "getBitcoinDepositAddressR" v') :: Either String BitcoinDepositAddress++withdrawBitcoins :: CurlHandle -> MtGoxCredentials-> BitcoinAddress-> Integer-> IO (Either String WithdrawResult)+withdrawBitcoins curlHandle mtGoxCreds (BitcoinAddress addr) amount = do+ let uri = mtGoxApi ++ "1/generic/bitcoin/send_simple"+ parameters = [ ("address", T.unpack addr)+ , ("amount_int", show amount)+ ]+ v <- callApi curlHandle mtGoxCreds uri parameters+ return $ case v of+ Left errMsg -> Left errMsg+ Right HttpApiFailure -> Left "HttpApiFailure when doing withdrawBitcoins"+ Right (HttpApiSuccess v') ->+ Right (parseReply "withdrawBitcoins" v') :: Either String WithdrawResult++-- | Will not return until all orders have been executed. It will give up after+-- about 3 minutes, if there are persistent errors or still open orders.+letOrdersExecuteR :: Maybe WatchdogLogger-> CurlHandle-> MtGoxCredentials-> IO (Either String ())+letOrdersExecuteR mLogger curlHandle mtGoxCreds =+ watchdog $ do+ watchdogSettings+ setLoggingAction silentLogger {- no logging -}+ watchImpatiently task+ where+ task = do+ orderCount <- getOrderCountR mLogger curlHandle mtGoxCreds+ return $ case orderCount of+ Left errMsg -> Left errMsg+ Right (OpenOrderCount count) ->+ if count > 0+ then Left "still outstanding orders"+ else Right ()++processWalletHistories :: [WalletHistory] -> OrderStats+processWalletHistories histories =+ let entries = concatMap whEntries histories+ amounts = map (weType A.&&& weAmount) entries+ usdEarnedL = filter ((USDEarned ==) . fst) amounts+ usdSpentL = filter ((USDSpent ==) . fst) amounts+ usdFeeL = filter ((USDFee ==) . fst) amounts+ in OrderStats { usdEarned = sum (map snd usdEarnedL)+ , usdSpent = sum (map snd usdSpentL)+ , usdFee = sum (map snd usdFeeL)+ }++-- | Submit an order and return 'OrderStats'. In case of some non-critical+-- errors things are re-tried automatically, but if API errors happen or network+-- errors occur during critical phases (like placing the order) a 'Left' with+-- the error is returned. Should not block longer than about 3 minutes.+submitOrder :: Maybe WatchdogLogger-> CurlHandle -> MtGoxCredentials-> OrderType-> Integer-> IO (Either String OrderStats)+submitOrder mLogger curlHandle mtGoxCreds orderType amount = runEitherT $ do+ -- step 1: make sure network connection is present+ -- and no orders are pending+ EitherT $ letOrdersExecuteR mLogger curlHandle mtGoxCreds+ -- step 2: submit order+ order <- EitherT $ case orderType of+ OrderTypeBuyBTC ->+ submitBtcBuyOrder curlHandle mtGoxCreds amount+ OrderTypeSellBTC ->+ submitBtcSellOrder curlHandle mtGoxCreds amount+ -- step 3: wait for order to complete+ r <- liftIO $ letOrdersExecuteR mLogger curlHandle mtGoxCreds+ case r of+ Left errMsg -> left $ "Warning: After submitting order the call"+ ++ " to letOrdersExecuteR failed ("+ ++ errMsg ++ ")"+ Right _ -> return ()+ -- step 4: get trade ids+ let orderID = oOrderID order+ orderResult <- EitherT $ getOrderResultR mLogger curlHandle mtGoxCreds+ orderType orderID+ let tradeIDs = orTradeIDs orderResult+ -- step 5: collect wallet entries for all trade ids+ histories <- forM tradeIDs $ \tradeID -> EitherT (getWalletHistory tradeID)+ return $ processWalletHistories histories+ where+ getWalletHistory = getWalletHistoryR mLogger curlHandle mtGoxCreds
+ Network/MtGoxAPI/StreamAuthCommands.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.MtGoxAPI.StreamAuthCommands+ ( StreamAuthCommandData(..)+ , prepareAuthCommand+ , getNonce+ , parseIDKeyCallResult+ , parseFullDepthCallResult+ ) where++-- Structure of an authenticated command send over the streaming API:+-- {+-- "op":"call"+-- "id": <nonce>+-- "call": base64-encoded string+-- <api key already decoded (remove dashes first)>+-- <hmac-signed copy of the following string>+-- <json array+-- {+-- "id": <nonce>+-- "call": <for example private/info>+-- "nonce": <nonce>+-- "params": <array with parameters>+-- "item": BTC ?+-- "currency": USD ?+-- }+-- >+-- "context":"mtgox.com"+-- }++import Data.Aeson+import Data.Digest.Pure.SHA+import Data.Time.Clock.POSIX++import qualified Data.ByteString as B+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T++import Network.MtGoxAPI.Credentials+import Network.MtGoxAPI.Types++data StreamAuthCommandData = StreamAuthCommandData+ { sacdCall :: T.Text+ , sacdParameters :: [(T.Text, T.Text)]+ , sacdSetBTCUSD :: Bool+ , sacdNonce :: T.Text+ }+ deriving (Show)++getNonce :: IO T.Text+getNonce = do+ now <- getPOSIXTime+ let nonce = round $ now * 1000000 :: Integer+ return $ (T.pack . show) nonce++prepareCallPayload :: StreamAuthCommandData -> BL.ByteString+prepareCallPayload (StreamAuthCommandData { sacdCall = call+ , sacdParameters = parameters+ , sacdSetBTCUSD = setBTCUSD+ , sacdNonce = nonce+ }) =+ let alwaysPresent = [ "id" .= nonce+ , "call" .= call+ , "nonce" .= nonce+ , "params" .= toMap parameters+ ]+ optionalAddon = if setBTCUSD+ then [ "item" .= ("BTC" :: T.Text)+ , "currency" .= ("EUR" :: T.Text)+ ]+ else []+ in encode $ object (alwaysPresent ++ optionalAddon)+ where+ toMap :: ToJSON b => [(T.Text, b)] -> Value+ toMap = object . map (uncurry (.=))++createSignedCall :: MtGoxCredentials -> StreamAuthCommandData -> B.ByteString+createSignedCall creds authCmd =+ let authKeyDecoded = BL.fromChunks [mgcAuthKeyDecoded creds]+ authSecretDecoded = BL.fromChunks [mgcAuthSecretDecoded creds]+ call = prepareCallPayload authCmd+ hmac = bytestringDigest $ hmacSha512 authSecretDecoded call+ payload = authKeyDecoded `BL.append` hmac `BL.append` call+ in B64.encode . foldl1 B.append $ BL.toChunks payload++prepareAuthCommand :: MtGoxCredentials -> StreamAuthCommandData -> Value+prepareAuthCommand creds authCmd =+ let signedCall = createSignedCall creds authCmd+ in object [ "op" .= ("call" :: T.Text)+ , "id" .= sacdNonce authCmd+ , "call" .= signedCall+ , "context" .= ("mtgox.com" :: T.Text)+ ]++parseIDKeyCallResult :: StreamMessage -> Maybe IDKey+parseIDKeyCallResult CallResult { crResult = v } =+ case fromJSON v of+ Success p -> Just p+ Error _ -> Nothing+parseIDKeyCallResult _ = Nothing++parseFullDepthCallResult :: StreamMessage -> Maybe FullDepth+parseFullDepthCallResult CallResult { crResult = v } =+ case fromJSON v of+ Success p -> Just p+ Error _ -> Nothing+parseFullDepthCallResult _ = Nothing
+ Network/MtGoxAPI/StreamCommands.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.MtGoxAPI.StreamCommands+ ( encodeStreamCommand+ , StreamCommand (..)+ , module Network.MtGoxAPI.StreamAuthCommands+ ) where++import Data.Aeson++import qualified Data.ByteString.Lazy as L+import qualified Data.Text as T++import Network.MtGoxAPI.Credentials+import Network.MtGoxAPI.StreamAuthCommands++data StreamCommand = UnsubscribeCmd { scChannel :: T.Text }+ | SubscribeCmd { scChannel :: T.Text }+ | PrivateSubscribeCmd { scKey :: T.Text }+ | IDKeyCmd+ | FullDepthCmd+ deriving (Show)++encodeStreamCommand :: StreamCommand -> MtGoxCredentials -> IO L.ByteString+encodeStreamCommand cmd creds = do+ nonce <- getNonce+ let v = case cmd of+ UnsubscribeCmd { scChannel = channel} ->+ object [ "op" .= ("unsubscribe" :: T.Text)+ , "channel" .= channel+ ]+ SubscribeCmd { scChannel = channel} ->+ object [ "op" .= ("mtgox.subscribe" :: T.Text)+ , "channel" .= channel+ ]+ PrivateSubscribeCmd { scKey = key } ->+ object [ "op" .= ("mtgox.subscribe" :: T.Text)+ , "key" .= key+ ]+ IDKeyCmd ->+ let idKeyCmd =+ StreamAuthCommandData { sacdCall = "private/idkey"+ , sacdParameters = []+ , sacdSetBTCUSD = False+ , sacdNonce = nonce+ }+ in prepareAuthCommand creds idKeyCmd+ FullDepthCmd ->+ let fullDepthCmd =+ StreamAuthCommandData { sacdCall = "public/fulldepth"+ , sacdParameters = []+ , sacdSetBTCUSD = True+ , sacdNonce = nonce+ }+ in prepareAuthCommand creds fullDepthCmd+ return $ encode v
+ Network/MtGoxAPI/StreamConnection.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.MtGoxAPI.StreamConnection+ ( initMtGoxStream+ , mtGoxTickerChannelUSD+ , mtGoxDepthChannelUSD+ , mtGoxTickerChannelNameEUR+ , mtGoxDepthChannelNameEUR+ , mtGoxTradeChannel+ , MtGoxStreamSettings(..)+ , WalletNotifierSetting(..)+ , FullDepthSetting(..)+ ) where++import Control.Applicative+import Control.Concurrent+import Control.Exception+import Control.Monad+import Control.Watchdog+import GHC.IO.Handle+import Network+import System.Timeout++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified System.IO as IO++import Network.MtGoxAPI.Credentials+import Network.MtGoxAPI.DepthStore.Adapter+import Network.MtGoxAPI.Handles+import Network.MtGoxAPI.StreamCommands+import Network.MtGoxAPI.TickerMonitor+import Network.MtGoxAPI.Types+import Network.MtGoxAPI.WalletNotifier++mtGoxStreamHost :: HostName+mtGoxStreamHost = "127.0.0.1"++mtGoxStreamPort :: PortID+mtGoxStreamPort = PortNumber 10508++mtGoxTradeChannel :: T.Text+mtGoxTradeChannel = "dbf1dee9-4f2e-4a08-8cb7-748919a71b21"++mtGoxTickerChannelUSD :: T.Text+mtGoxTickerChannelUSD = "d5f06780-30a8-4a48-a2f8-7ed181b4a13f"++mtGoxDepthChannelUSD :: T.Text+mtGoxDepthChannelUSD = "24e67e0d-1cad-4cc0-9e7a-f8523ef460fe"++mtGoxTickerChannelNameEUR :: T.Text+mtGoxTickerChannelNameEUR = "ticker.BTCEUR"++mtGoxDepthChannelNameEUR :: T.Text+mtGoxDepthChannelNameEUR = "depth.BTCEUR"++mtGoxTimeout :: Int+mtGoxTimeout = 2 * 60 * 10 ^ (6 :: Integer)++wrapInTimeout :: Handle -> String -> IO a -> IO a+wrapInTimeout h errMsg action = do+ resultM <- timeout mtGoxTimeout action+ case resultM of+ Just result -> return result+ Nothing -> do+ hClose h+ throw $ userError errMsg++readNextStreamMessageWithTimeout :: Handle -> IO StreamMessage+readNextStreamMessageWithTimeout h =+ parseStreamLine <$>+ wrapInTimeout h "MtGox did not send data for a while." (B.hGetLine h)++sendStreamCommand :: Handle -> MtGoxCredentials -> StreamCommand -> IO ()+sendStreamCommand h creds cmd = do+ encodedCmd <- encodeStreamCommand cmd creds+ BL.hPutStr h encodedCmd >> B.hPutStr h "\n"++openConnection :: HostName-> PortID-> MtGoxCredentials-> MtGoxStreamSettings-> MtGoxAPIHandles-> IO (Either String ())+openConnection host port creds streamSettings apiHandles = do+ status <- try go :: IO (Either IOException (Either String ()))+ case status of+ Right result -> return result+ Left ex -> return $ Left (show ex)+ where+ go = withSocketsDo $ do+ -- open connection+ h <- connectTo host port+ IO.hSetBuffering h IO.NoBuffering++ -- unsubscribe from default channels and subscribe to+ -- EUR channels+ mapM_ (sendStreamCommand h creds)+ [ UnsubscribeCmd mtGoxTradeChannel+ , UnsubscribeCmd mtGoxTickerChannelUSD+ , UnsubscribeCmd mtGoxDepthChannelUSD+ , SubscribeCmd mtGoxTickerChannelNameEUR+ , SubscribeCmd mtGoxDepthChannelNameEUR+ ]++ -- wait for healthy activity to appear before proceeding+ _ <- waitForActivityWithTimeout h++ -- prepare handles+ let tickerMonitorHandle = mtgoxTickerMonitorHandle apiHandles+ depthStoreHandle = mtgoxDepthStoreHandle apiHandles+ walletNotifierHandle = mtgoxWalletNotifierHandle apiHandles++ -- extract extra settings+ let (MtGoxStreamSettings walletNotifierSetting fullDepthSetting) =+ streamSettings++ -- wallet notifier step+ when (walletNotifierSetting == EnableWalletNotifications) $ do+ -- get idkey and subscribe to wallet operations channel+ sendStreamCommand h creds IDKeyCmd+ (buffer1, idKey) <- waitForCallResultWithTimeout h parseIDKeyCallResult+ sendStreamCommand h creds $ PrivateSubscribeCmd (idkKey idKey)++ -- rewind buffer+ forM_ buffer1 $ \streamMessage -> do+ updateTickerStatus tickerMonitorHandle streamMessage+ updateDepthStoreFromMessage depthStoreHandle streamMessage+ updateWalletNotifier walletNotifierHandle streamMessage++ -- full depth step+ case fullDepthSetting of+ RequestFullDepth -> do+ -- get full depth+ sendStreamCommand h creds FullDepthCmd+ (buffer2, fullDepth) <- waitForCallResultWithTimeout h parseFullDepthCallResult+ updateDepthStoreFromFullDepth depthStoreHandle fullDepth++ -- rewind buffer+ forM_ buffer2 $ \streamMessage -> do+ updateTickerStatus tickerMonitorHandle streamMessage+ updateDepthStoreFromMessage depthStoreHandle streamMessage+ updateWalletNotifier walletNotifierHandle streamMessage+ SkipFullDepth -> skipFullDepthRequest depthStoreHandle++ -- enter main loop and process incoming messages+ forever $ do+ streamMessage <- readNextStreamMessageWithTimeout h+ updateTickerStatus tickerMonitorHandle streamMessage+ updateDepthStoreFromMessage depthStoreHandle streamMessage+ updateWalletNotifier walletNotifierHandle streamMessage++waitForCallResultWithTimeout :: Handle -> (StreamMessage -> Maybe a) -> IO ([StreamMessage], a)+waitForCallResultWithTimeout h parser =+ wrapInTimeout h "Call result was not returned in time." (go [])+ where+ go buffer = do+ msg <- readNextStreamMessageWithTimeout h+ case msg of+ CallResult {} ->+ case parser msg of+ Just result -> return (reverse buffer, result)+ Nothing ->+ throw $ userError "Unexpected call result was returned."+ other -> go (other:buffer)++waitForActivityWithTimeout :: Handle -> IO [StreamMessage]+waitForActivityWithTimeout h =+ wrapInTimeout h "Healthy activity did not appear in time." $ go []+ where+ go msgs = do+ msg <- readNextStreamMessageWithTimeout h+ let msgs' = msg : msgs+ checks = [ any isTickerUpdate msgs'+ , any isDepthUpdate msgs'+ ]+ if and checks+ then return $ reverse msgs'+ else go msgs'+ isTickerUpdate TickerUpdateUSD {} = True+ isTickerUpdate _ = False+ isDepthUpdate DepthUpdateUSD {} = True+ isDepthUpdate _ = False++-- | Starts a thread that will connect to the data stream+-- from Mt. Gox and supply the received data to the handles that are+-- are passed in. A watchdog maintains the connection.+initMtGoxStream :: MtGoxCredentials-> MtGoxStreamSettings -> MtGoxAPIHandles -> IO ThreadId+initMtGoxStream mtgoxCreds streamSettings mtgoxAPIHandles =+ let task = openConnection mtGoxStreamHost mtGoxStreamPort+ mtgoxCreds streamSettings+ mtgoxAPIHandles+ watchdogConf = do+ setResetDuration $ 90 * 10 ^ (6 :: Integer)+ case mtgoxLogger mtgoxAPIHandles of+ Just logger -> setLoggingAction logger+ Nothing -> return ()+ watch task+ in forkIO $ watchdog watchdogConf
+ Network/MtGoxAPI/TickerMonitor.hs view
@@ -0,0 +1,85 @@+module Network.MtGoxAPI.TickerMonitor+ ( initTickerMonitor+ , getTickerStatus+ , updateTickerStatus+ , TickerStatus(..)+ , TickerMonitorHandle+ ) where++import Control.Applicative+import Control.Concurrent+import Control.Watchdog+import Data.Time.Clock++import Network.MtGoxAPI.Types++newtype TickerMonitorHandle = TickerMonitorHandle+ { unTMH :: MVar (Maybe TickerStatus) }++data TickerStatus = TickerStatus { tsTimestamp :: UTCTime+ , tsBid :: Integer+ , tsAsk :: Integer+ , tsLast :: Integer+ , tsPrecision :: Integer+ }+ | TickerUnavailable+ deriving (Show)++expectedPrecision :: Integer+expectedPrecision = 5++maximumAgeInSeconds :: NominalDiffTime+maximumAgeInSeconds = 300++watchdogSettings :: WatchdogAction ()+watchdogSettings = do+ setLoggingAction silentLogger+ setInitialDelay 250000 -- 250 ms+ setMaximumRetries 6+ -- will fail after:+ -- 0.25 + 0.5 + 1 + 2 + 4 + 8 seconds = 15.75 seconds++-- | Access latest ticker status in a safe way. It will be checked, whether+-- fresh data is available (never older than 300 seconds) and if not, re-try a+-- few times before giving up. The function will not block for longer than+-- about 20 seconds.+getTickerStatus :: TickerMonitorHandle -> IO TickerStatus+getTickerStatus TickerMonitorHandle { unTMH = store } = do+ let task = getTickerStatus' store+ result <- watchdog $ do+ watchdogSettings+ watchImpatiently task+ return $ case result of+ Left _ -> TickerUnavailable+ Right status -> status++getTickerStatus' :: MVar (Maybe TickerStatus) -> IO (Either String TickerStatus)+getTickerStatus' store = do+ tickerStatusM <- readMVar store+ case tickerStatusM of+ Nothing -> return $ Left "No ticker data present"+ Just tickerStatus -> do+ now <- getCurrentTime+ let age = diffUTCTime now (tsTimestamp tickerStatus)+ return $ if age < maximumAgeInSeconds+ then Right tickerStatus+ else Left "Data stale"++-- | Update ticker with new data.+updateTickerStatus :: TickerMonitorHandle -> StreamMessage -> IO ()+updateTickerStatus TickerMonitorHandle { unTMH = tickerStore }+ (update@TickerUpdateUSD {}) = do+ now <- getCurrentTime+ let tickerStatus = TickerStatus { tsTimestamp = now+ , tsBid = tuBid update+ , tsAsk = tuAsk update+ , tsLast = tuLast update+ , tsPrecision = expectedPrecision+ }+ _ <- swapMVar tickerStore (Just tickerStatus)+ return ()+updateTickerStatus _ _ = return ()++-- | Initializes ticker monitor and returns a handle for it.+initTickerMonitor :: IO TickerMonitorHandle+initTickerMonitor = TickerMonitorHandle <$> newMVar Nothing
+ Network/MtGoxAPI/Types.hs view
@@ -0,0 +1,401 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.MtGoxAPI.Types+ ( parseStreamLine+ , StreamMessage(..)+ , MtGoxStreamSettings(..)+ , WalletNotifierSetting(..)+ , FullDepthSetting(..)+ , DepthType(..)+ , WalletOperationType(..)+ , IDKey(..)+ , FullDepth(..)+ , DepthEntry(..)+ , OpenOrderCount(..)+ , Order(..)+ , OrderType(..)+ , OrderID(..)+ , OrderResult(..)+ , TradeID(..)+ , WalletHistory(..)+ , PrivateInfo(..)+ , BitcoinDepositAddress(..)+ , BitcoinAddress(..)+ , WithdrawResult(..)+ , WalletEntry(..)+ ) where++import Control.Applicative+import Control.Monad+import Data.Aeson+import Data.Aeson.Types+import Data.Hashable+import Data.String++import qualified Data.Attoparsec as AP+import qualified Data.ByteString as B+import qualified Data.HashMap.Strict as H+import qualified Data.Text as T+import qualified Data.Vector as V++data DepthType = Ask | Bid+ deriving (Eq, Show)++data WalletOperationType = BTCDeposit+ | BTCWithdraw+ | USDEarned+ | USDSpent+ | BTCIn+ | BTCOut+ | USDFee+ deriving (Eq, Show)++data MtGoxStreamSettings = MtGoxStreamSettings WalletNotifierSetting+ FullDepthSetting+ deriving (Show)++data WalletNotifierSetting = EnableWalletNotifications+ | DisableWalletNotifications+ deriving (Eq, Show)++data FullDepthSetting = RequestFullDepth+ | SkipFullDepth+ deriving (Show)++data StreamMessage = TickerUpdateUSD { tuBid :: Integer+ , tuAsk :: Integer+ , tuLast :: Integer+ }+ | DepthUpdateUSD { duPrice :: Integer+ , duVolume :: Integer+ , duType :: DepthType+ }+ | WalletOperation { woType :: WalletOperationType+ , woAmount :: Integer+ }+ | Subscribed { sChannel :: T.Text }+ | Unsubscribed { usChannel :: T.Text }+ | CallResult { crID :: T.Text+ , crResult :: Value+ }+ | OtherMessage+ deriving (Eq, Show)++data PrivateInfo = PrivateInfo { piBtcBalance :: Integer+ , piUsdBalance :: Integer+ , piBtcOperations :: Integer+ , piUsdOperations :: Integer+ , piFee :: Double+ }+ deriving (Show)++data IDKey = IDKey { idkKey :: T.Text }+ deriving (Show)++data DepthEntry = DepthEntry { deAmount :: Integer+ , dePrice :: Integer+ , deStamp :: T.Text+ }+ deriving (Show, Read)++data FullDepth = FullDepth { fdAsks :: [DepthEntry]+ , fdBids :: [DepthEntry]+ }+ deriving (Show, Read)++data OrderID = OrderID { oid :: T.Text }+ deriving (Show)++data TradeID = TradeID { tid :: T.Text }+ deriving (Show)++data Order = Order { oOrderID :: OrderID }+ deriving (Show)++data OrderResult = OrderResult { orTradeIDs :: [TradeID] }+ deriving (Show)++data OpenOrderCount = OpenOrderCount { oocCount :: Integer }+ deriving (Show)++data OrderType = OrderTypeBuyBTC | OrderTypeSellBTC+ deriving (Show)++data WalletEntry = WalletEntry { weDate :: Integer+ , weType :: WalletOperationType+ , weAmount :: Integer+ , weBalance :: Integer+ , weInfo :: T.Text+ }+ deriving (Show)++data WalletHistory = WalletHistory { whEntries :: [WalletEntry] }+ deriving (Show)++data BitcoinAddress = BitcoinAddress { baAddress :: T.Text }+ deriving (Show)++data BitcoinDepositAddress = BitcoinDepositAddress { bdaAddr :: BitcoinAddress }+ deriving (Show)++data WithdrawResult = WithdrawResult { wsTxID :: T.Text }+ deriving (Show)++instance FromJSON StreamMessage+ where+ parseJSON (Object o) = case getOperation o of+ Just ("subscribe", subscribe) ->+ Subscribed <$> subscribe .: "channel"+ Just ("unsubscribe", unsubscribe) ->+ Unsubscribed <$> unsubscribe .: "channel"+ Just ("result", result) ->+ CallResult <$> result .: "id" <*> result .: "result"+ Just ("ticker", ticker) -> parseTicker ticker+ Just ("depth", depth) -> parseDepth depth+ Just ("wallet", wallet) -> parseWallet wallet+ Just _ -> return OtherMessage+ Nothing -> return OtherMessage+ parseJSON _ = mzero++getOperation :: H.HashMap T.Text Value -> Maybe (T.Text, Object)+getOperation o = do+ op' <- H.lookup "op" o >>= extractText+ case op' of+ "private" -> do+ op <- H.lookup "private" o >>= extractText+ payload <- H.lookup op o >>= extractObject+ return (op, payload)+ "subscribe" -> return (op', o)+ "unsubscribe" -> return (op', o)+ "result" -> return (op', o)+ _ -> fail "unknown operation"++parseWallet :: Object -> Parser StreamMessage+parseWallet wallet = do+ op <- wallet .: "op" :: Parser String+ case op of+ "deposit" -> go BTCDeposit "BTC"+ "withdraw" -> go BTCWithdraw "BTC"+ "earned" -> go USDEarned "EUR"+ "spent" -> go USDSpent "EUR"+ "in" -> go BTCIn "BTC"+ "out" -> go BTCOut "BTC"+ "fee" -> go USDFee "EUR"+ _ -> return OtherMessage+ where+ go checkedOp expCurrency = do+ amountDetails <- wallet .: "amount"+ amount <- coerceFromString $ amountDetails .: "value_int"+ currency <- amountDetails .: "currency" :: Parser String+ if currency == expCurrency+ then return WalletOperation { woType = checkedOp+ , woAmount = amount+ }+ else mzero++parseDepth :: (Eq k, IsString k, Hashable k) =>H.HashMap k Value -> Parser StreamMessage+parseDepth depth = case extractDepthData depth of+ Just (price, volume, depthType) ->+ DepthUpdateUSD <$> coerceFromString (parseJSON price)+ <*> coerceFromString (parseJSON volume)+ <*> pure depthType+ Nothing -> mzero++extractDepthData :: (Eq k, IsString k, Hashable k) =>H.HashMap k Value -> Maybe (Value, Value, DepthType)+extractDepthData o = do+ currency <- H.lookup "currency" o+ guard (currency == expectedCurrency)+ price <- H.lookup "price_int" o+ volume <- H.lookup "total_volume_int" o+ depthType <- H.lookup "type_str" o >>= convertTypeStr+ return (price, volume, depthType)++convertTypeStr :: Value -> Maybe DepthType+convertTypeStr (String "ask") = Just Ask+convertTypeStr (String "bid") = Just Bid+convertTypeStr _ = Nothing++parseTicker :: (Eq k, IsString k, Hashable k) =>H.HashMap k Value -> Parser StreamMessage+parseTicker ticker = case extractTickerData ticker of+ Just (buy, sell, lst) ->+ TickerUpdateUSD <$> coerceFromString (parseJSON buy)+ <*> coerceFromString (parseJSON sell)+ <*> coerceFromString (parseJSON lst)+ Nothing -> mzero++coerceFromString :: Parser String -> Parser Integer+coerceFromString = fmap read++extractTickerData :: (Eq k, IsString k, Hashable k) =>H.HashMap k Value -> Maybe (Value, Value, Value)+extractTickerData o = do+ buyPrice <- lookupInTicker "buy" o+ sellPrice <- lookupInTicker "sell" o+ lastPrice <- lookupInTicker "last" o+ return (buyPrice, sellPrice, lastPrice)++lookupInTicker :: (Eq k, Hashable k) => k -> H.HashMap k Value -> Maybe Value+lookupInTicker field o = do+ tickerField <- H.lookup field o+ >>= extractObject+ currency <- H.lookup "currency" tickerField+ guard (currency == expectedCurrency)+ H.lookup "value_int" tickerField++extractObject :: Value -> Maybe Object+extractObject (Object o) = Just o+extractObject _ = Nothing++extractText :: Value -> Maybe T.Text+extractText (String s) = Just s+extractText _ = Nothing++expectedCurrency :: Value+expectedCurrency = "EUR"++parseLine :: B.ByteString -> Either String StreamMessage+parseLine = collapseErrors . parseStreamMessage+ where+ parseStreamMessage :: B.ByteString -> Either String (Result StreamMessage)+ parseStreamMessage = AP.parseOnly (fromJSON <$> json)++collapseErrors :: Either String (Result b) -> Either String b+collapseErrors (Left err) = Left err+collapseErrors (Right (Error err)) = Left err+collapseErrors (Right (Success payload)) = Right payload++parseStreamLine :: B.ByteString -> StreamMessage+parseStreamLine line = case parseLine line of+ Right msg -> msg+ Left _ -> OtherMessage++instance FromJSON PrivateInfo+ where+ parseJSON (Object o) = case extractBalancesAndOps o of+ Just (btcV, usdV, btcOps, usdOps) -> do+ btcS <- parseJSON btcV :: Parser String+ usdS <- parseJSON usdV :: Parser String+ btcOpsI <- parseJSON btcOps+ usdOpsI <- parseJSON usdOps+ fee <- o .: "Trade_Fee"+ return PrivateInfo { piBtcBalance = read btcS+ , piUsdBalance = read usdS+ , piBtcOperations = btcOpsI+ , piUsdOperations = usdOpsI+ , piFee = fee+ }+ Nothing -> mzero+ parseJSON _ = mzero++extractBalancesAndOps :: (Eq k, IsString k, Hashable k) =>H.HashMap k Value -> Maybe (Value, Value, Value, Value)+extractBalancesAndOps o = do+ btc <- extractBalance "BTC" o+ usd <- extractBalance "EUR" o+ btcOps <- extractOperations "BTC" o+ usdOps <- extractOperations "EUR" o+ return (btc, usd, btcOps, usdOps)++extractOperations :: (Eq k, IsString k, Hashable k) =>T.Text -> H.HashMap k Value -> Maybe Value+extractOperations currency o =+ H.lookup "Wallets" o+ >>= extractObject+ >>= H.lookup currency+ >>= extractObject+ >>= H.lookup "Operations"++extractBalance :: (Eq k, IsString k, Hashable k) =>T.Text -> H.HashMap k Value -> Maybe Value+extractBalance currency o = do+ balance <- H.lookup "Wallets" o+ >>= extractObject+ >>= H.lookup currency+ >>= extractObject+ >>= H.lookup "Balance"+ >>= extractObject+ H.lookup "value_int" balance++instance FromJSON DepthEntry+ where+ parseJSON (Object o) =+ DepthEntry <$> coerceFromString (o .: "amount_int")+ <*> coerceFromString (o .: "price_int")+ <*> o .: "stamp"+ parseJSON _ = mzero++instance FromJSON FullDepth+ where+ parseJSON (Object o) =+ FullDepth <$> o .: "asks"+ <*> o .: "bids"+ parseJSON _ = mzero++instance FromJSON Order+ where+ parseJSON (String guid) = return $ Order (OrderID guid)+ parseJSON _ = mzero++instance FromJSON IDKey+ where+ parseJSON (String key) = return $ IDKey key+ parseJSON _ = mzero++instance FromJSON OpenOrderCount+ where+ parseJSON (Array orders) =+ return $ OpenOrderCount (fromIntegral . V.length $ orders)+ parseJSON _ = mzero++instance FromJSON OrderResult+ where+ parseJSON (Object o) = case H.lookup "trades" o of+ Just (Array trades) -> do+ ids <- mapM extractTradeID (V.toList trades)+ return $ OrderResult ids+ Just _ -> mzero+ Nothing -> mzero+ parseJSON _ = mzero++extractTradeID :: MonadPlus m => Value -> m TradeID+extractTradeID (Object o) = case H.lookup "trade_id" o of+ Just (String tradeID) -> return $ TradeID tradeID+ Just _ -> mzero+ Nothing -> mzero+extractTradeID _ = mzero++instance FromJSON WalletEntry+ where+ parseJSON (Object o) = do+ date <- o .: "Date"+ typeString <- o .: "Type" :: Parser T.Text+ entryType <- case typeString of+ "fee" -> return USDFee+ "earned" -> return USDEarned+ "spent" -> return USDSpent+ _ -> mzero+ amount <- coerceFromString (o .: "Value" >>=+ \v -> v .: "value_int")+ balance <- coerceFromString (o .: "Balance" >>=+ \v -> v .: "value_int")+ info <- o .: "Info"+ return $ WalletEntry date entryType amount balance info+ parseJSON _ = mzero++instance FromJSON WalletHistory+ where+ parseJSON (Object o) = case H.lookup "result" o of+ Just results -> do+ entries <- parseJSON results :: Parser [WalletEntry]+ return $ WalletHistory entries+ Nothing -> mzero+ parseJSON _ = mzero++instance FromJSON BitcoinAddress+ where+ parseJSON v = BitcoinAddress <$> parseJSON v++instance FromJSON BitcoinDepositAddress+ where+ parseJSON (Object o) = BitcoinDepositAddress <$> o .: "addr"+ parseJSON _ = mzero++instance FromJSON WithdrawResult+ where+ parseJSON (Object o) = WithdrawResult <$> o .: "trx"+ parseJSON _ = mzero
+ Network/MtGoxAPI/WalletNotifier.hs view
@@ -0,0 +1,31 @@+module Network.MtGoxAPI.WalletNotifier+ ( initWalletNotifier+ , updateWalletNotifier+ , waitForBTCDeposit+ , WalletNotifierHandle+ ) where++import Control.Applicative+import Control.Concurrent+import Control.Monad++import Network.MtGoxAPI.Types++newtype WalletNotifierHandle = WalletNotifierHandle { unWNH :: MVar () }++initWalletNotifier :: IO WalletNotifierHandle+initWalletNotifier = WalletNotifierHandle <$> newEmptyMVar++updateWalletNotifier :: WalletNotifierHandle -> StreamMessage -> IO ()+updateWalletNotifier handle (wo@WalletOperation {}) =+ case woType wo of+ BTCDeposit -> void $ tryPutMVar (unWNH handle) ()+ -- write to MVar, if not already full+ _ -> return ()+updateWalletNotifier _ _ = return ()++-- | Will block until a BTC deposit happens. Note: This might sometimes be a+-- little unreliable, when the streaming connection is under load from a lot of+-- depth channel updates.+waitForBTCDeposit :: WalletNotifierHandle -> IO ()+waitForBTCDeposit handle = void $ takeMVar (unWNH handle)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ TestSuite.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.Applicative+import Control.Error+import Control.Monad.IO.Class+import System.Environment+import System.Exit+import System.FilePath+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test)++import qualified Data.ByteString.Char8 as B8++import Network.MtGoxAPI+import Network.MtGoxAPI.DepthStore.Tests++cent :: Integer+cent = 1000000++test1 :: MtGoxAPIHandles -> Test+test1 apiData = testCase "getOrderCountR returns data" $ do+ r <- getOrderCountR apiData+ case r of+ Right _ -> return ()+ Left _ -> assertFailure "getOrderCountR did not return data."++test2 :: MtGoxAPIHandles -> Test+test2 apiData = testCase "getPrivateInfoR returns data" $ do+ r <- getPrivateInfoR apiData+ case r of+ Right _ -> return ()+ Left _ -> assertFailure "getPrivateInfoR did not return data."++test3 :: MtGoxAPIHandles -> Test+test3 apiData = testCase "getBitcoinDepositAddressR returns data" $ do+ r <- getBitcoinDepositAddressR apiData+ case r of+ Right _ -> return ()+ Left _ -> assertFailure "getBitcoinDepositAddressR did not return data."++test4 :: MtGoxAPIHandles -> Test+test4 apiData = testCase "ticker is available" $ do+ r <- getTickerStatus (mtgoxTickerMonitorHandle apiData)+ case r of+ TickerStatus{} -> return ()+ TickerUnavailable -> assertFailure "Ticker is not available."++test5 :: MtGoxAPIHandles -> Test+test5 apiData = testCase "simulateBTCSell returns non-zero amount" $ do+ r <- simulateBTCSell (mtgoxDepthStoreHandle apiData) 1000000+ case r of+ DepthStoreAnswer v -> assertBool "value is zero" (v /= 0)+ _ -> assertFailure "Simulation did not return any data."++test6 :: MtGoxAPIHandles -> Test+test6 apiData = testCase "simulateBTCBuy returns non-zero amount" $ do+ r <- simulateBTCBuy (mtgoxDepthStoreHandle apiData) 1000000+ case r of+ DepthStoreAnswer v -> assertBool "value is zero" (v /= 0)+ _ -> assertFailure "Simulation did not return any data."++test7 :: MtGoxAPIHandles -> Test+test7 apiData = testCase "simulateUSDSell returns non-zero amount" $ do+ r <- simulateUSDSell (mtgoxDepthStoreHandle apiData) 1000+ case r of+ DepthStoreAnswer v -> assertBool "value is zero" (v /= 0)+ _ -> assertFailure "Simulation did not return any data."++test8 :: MtGoxAPIHandles -> Test+test8 apiData = testCase "simulateUSDBuy returns non-zero amount" $ do+ r <- simulateUSDBuy (mtgoxDepthStoreHandle apiData) 1000+ case r of+ DepthStoreAnswer v -> assertBool "value is zero" (v /= 0)+ _ -> assertFailure "Simulation did not return any data."++test9 :: MtGoxAPIHandles -> Test+test9 apiData = testCase "two simulations mostly match" $ do+ let startValue = 1000000+ m <- runMaybeT $ do+ usdValue <- MaybeT $ toMaybe <$> simulateBTCBuy+ (mtgoxDepthStoreHandle apiData) startValue+ btcValue <- MaybeT $ toMaybe <$> simulateUSDSell+ (mtgoxDepthStoreHandle apiData) usdValue+ let diff = abs (startValue - btcValue)+ liftIO $ assertBool "values differ more than 0.0001 BTC"+ (diff <= 10000)+ case m of+ Nothing -> assertFailure "Simulation did not return any data."+ Just _ -> return ()+ where+ toMaybe (DepthStoreAnswer v) = Just v+ toMaybe _ = Nothing++test10 :: MtGoxAPIHandles -> Test+test10 apiData = testCase "another two simulations mostly match" $ do+ let startValue = 1000000+ m <- runMaybeT $ do+ usdValue <- MaybeT $ toMaybe <$> simulateBTCSell+ (mtgoxDepthStoreHandle apiData) startValue+ btcValue <- MaybeT $ toMaybe <$> simulateUSDBuy+ (mtgoxDepthStoreHandle apiData) usdValue+ let diff = abs (startValue - btcValue)+ liftIO $ assertBool "values differ more than 0.0001 BTC"+ (diff <= 10000)+ case m of+ Nothing -> assertFailure "Simulation did not return any data."+ Just _ -> return ()+ where+ toMaybe (DepthStoreAnswer v) = Just v+ toMaybe _ = Nothing++mtgoxAPITests :: [MtGoxAPIHandles -> Test]+mtgoxAPITests = [ test1, test2, test3, test4, test5+ , test6, test7, test8, test9, test10]++tests :: [Test]+tests = depthStoreTests++getConfFile :: FilePath -> FilePath+getConfFile home = home </> ".mtgoxapi-testsuite"++loadCredentials :: IO MtGoxCredentials+loadCredentials = do+ confFile <- getConfFile <$> getEnv "HOME"+ keys <- lines <$> readFile confFile+ case keys of+ (authKey:authSecret:_) ->+ return $ initMtGoxCredentials (B8.pack authKey)+ (B8.pack authSecret)+ _ -> do+ putStrLn "Configuration file seems to be in wrong format.\+ \ At least two lines are expected, containing the key\+ \ and the secret."+ exitFailure++prepareAPI :: MtGoxCredentials -> IO MtGoxAPIHandles+prepareAPI credentials =+ let streamSettings =+ MtGoxStreamSettings DisableWalletNotifications SkipFullDepth+ in initMtGoxAPI (Just silentLogger) credentials streamSettings++main :: IO ()+main = do+ credentials <- loadCredentials+ apiData <- prepareAPI credentials+ let apiTests = map ($ apiData) mtgoxAPITests+ defaultMain $ apiTests ++ tests++manualSubmitOrderTest :: IO ()+manualSubmitOrderTest = do+ credentials <- loadCredentials+ apiData <- prepareAPI credentials+ submitOrder apiData OrderTypeSellBTC cent >>= print+ submitOrder apiData OrderTypeBuyBTC cent >>= print
+ mtgoxapi.cabal view
@@ -0,0 +1,122 @@+name: mtgoxapi+version: 0.5+synopsis: Library to communicate with Mt.Gox+description: See Network.MtGoxAPI for documentation.+category: Network+author: Jan Vornberger <jan@uos.de>+copyright: (c) 2012 - 2014 Jan Vornberger+maintainer: Jan Vornberger <jan@uos.de>+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.8+bug-reports: https://github.com/javgh/mtgoxapi/issues++source-repository head+ type: git+ location: https://github.com/javgh/mtgoxapi++library+ build-depends: base == 4.*+ -- Wheezy: 4.5.0.0 (ghc)+ , time == 1.4.*+ -- Wheezy: 1.4 (ghc)+ , bytestring == 0.9.*+ -- Wheezy: 0.9.2.1 (ghc)+ , vector == 0.9.*+ -- Wheezy: 0.9.1 (libghc-vector-dev)+ , text == 0.11.*+ -- Wheezy: 0.11.2.0 (libghc-text-dev)+ , unordered-containers == 0.2.*+ -- Wheezy: 0.2.1.0 (libghc-unordered-containers-dev)+ , attoparsec == 0.10.*+ -- Wheezy: 0.10.1.1 (libghc-attoparsec-dev)+ , network == 2.3.*+ -- Wheezy: 2.3.0.13 (libghc-network-dev)+ , hashable == 1.1.*+ -- Wheezy: 1.1.2.3 (libghc-hashable-dev)+ , aeson == 0.6.*+ -- Wheezy: 0.6.0.2 (libghc-aeson-dev)+ , base64-bytestring == 0.1.*+ -- Wheezy: 0.1.1.1 (libghc-base64-bytestring-dev)+ , base16-bytestring == 0.1.*+ -- Wheezy: 0.1.1.4 (libghc-base16-bytestring-dev)+ , SHA == 1.5.*+ -- Wheezy: 1.5.0.1 (libghc-sha-dev)+ , ixset == 1.0.*+ -- Wheezy: 1.0.3 (libghc-ixset-dev)+ , curl == 1.3.*+ -- Wheezy: 1.3.7 (libghc-curl-dev)+ , HTTP == 4000.2.*+ -- Wheezy: 4000.2.3 (libghc-http-dev)+ , transformers == 0.3.*+ -- Wheezy: 0.3.0.0 (libghc-transformers-dev)+ , either == 3.2.*+ -- later versions of either seem to cause problems+ , errors == 1.4.*+ , watchdog >= 0.2.2 && < 0.3+ exposed-modules: Network.MtGoxAPI+ , Network.MtGoxAPI.Credentials+ , Network.MtGoxAPI.CurlWrapper+ , Network.MtGoxAPI.DepthStore+ , Network.MtGoxAPI.DepthStore.Adapter+ , Network.MtGoxAPI.Handles+ , Network.MtGoxAPI.HttpAPI+ , Network.MtGoxAPI.StreamAuthCommands+ , Network.MtGoxAPI.StreamCommands+ , Network.MtGoxAPI.StreamConnection+ , Network.MtGoxAPI.TickerMonitor+ , Network.MtGoxAPI.Types+ , Network.MtGoxAPI.WalletNotifier+ ghc-options: -Wall++test-suite testsuite+ type: exitcode-stdio-1.0+ main-is: TestSuite.hs+ build-depends: base == 4.*+ -- Wheezy: 4.5.0.0 (ghc)+ , time == 1.4.*+ -- Wheezy: 1.4 (ghc)+ , bytestring == 0.9.*+ -- Wheezy: 0.9.2.1 (ghc)+ , vector == 0.9.*+ -- Wheezy: 0.9.1 (libghc-vector-dev)+ , text == 0.11.*+ -- Wheezy: 0.11.2.0 (libghc-text-dev)+ , unordered-containers == 0.2.*+ -- Wheezy: 0.2.1.0 (libghc-unordered-containers-dev)+ , attoparsec == 0.10.*+ -- Wheezy: 0.10.1.1 (libghc-attoparsec-dev)+ , network == 2.3.*+ -- Wheezy: 2.3.0.13 (libghc-network-dev)+ , hashable == 1.1.*+ -- Wheezy: 1.1.2.3 (libghc-hashable-dev)+ , aeson == 0.6.*+ -- Wheezy: 0.6.0.2 (libghc-aeson-dev)+ , base64-bytestring == 0.1.*+ -- Wheezy: 0.1.1.1 (libghc-base64-bytestring-dev)+ , base16-bytestring == 0.1.*+ -- Wheezy: 0.1.1.4 (libghc-base16-bytestring-dev)+ , SHA == 1.5.*+ -- Wheezy: 1.5.0.1 (libghc-sha-dev)+ , ixset == 1.0.*+ -- Wheezy: 1.0.3 (libghc-ixset-dev)+ , curl == 1.3.*+ -- Wheezy: 1.3.7 (libghc-curl-dev)+ , HTTP == 4000.2.*+ -- Wheezy: 4000.2.3 (libghc-http-dev)+ , transformers == 0.3.*+ -- Wheezy: 0.3.0.0 (libghc-transformers-dev)+ , errors == 1.3.*+ , watchdog >= 0.2.2 && < 0.3+ , HUnit == 1.2.*+ -- Wheezy: 1.2.4.2 (libghc-hunit-dev)+ , QuickCheck == 2.4.*+ -- Wheezy: 2.4.2 (libghc-quickcheck2-dev)+ , test-framework == 0.6.*+ -- Wheezy: 0.6 (libghc-test-framework-dev)+ , test-framework-hunit == 0.2.*+ -- Wheezy: 0.2.7 (libghc-test-framework-hunit-dev)+ , test-framework-quickcheck2 == 0.2.*+ -- Wheezy: 0.2.12.1 (libghc-test-framework-quickcheck2-dev)+ ghc-options: -Wall