diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Network/MtGoxAPI.hs b/Network/MtGoxAPI.hs new file mode 100644 --- /dev/null +++ b/Network/MtGoxAPI.hs @@ -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) diff --git a/Network/MtGoxAPI/Credentials.hs b/Network/MtGoxAPI/Credentials.hs new file mode 100644 --- /dev/null +++ b/Network/MtGoxAPI/Credentials.hs @@ -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 + } diff --git a/Network/MtGoxAPI/CurlWrapper.hs b/Network/MtGoxAPI/CurlWrapper.hs new file mode 100644 --- /dev/null +++ b/Network/MtGoxAPI/CurlWrapper.hs @@ -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 diff --git a/Network/MtGoxAPI/DepthStore.hs b/Network/MtGoxAPI/DepthStore.hs new file mode 100644 --- /dev/null +++ b/Network/MtGoxAPI/DepthStore.hs @@ -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 diff --git a/Network/MtGoxAPI/DepthStore/Adapter.hs b/Network/MtGoxAPI/DepthStore/Adapter.hs new file mode 100644 --- /dev/null +++ b/Network/MtGoxAPI/DepthStore/Adapter.hs @@ -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 diff --git a/Network/MtGoxAPI/Handles.hs b/Network/MtGoxAPI/Handles.hs new file mode 100644 --- /dev/null +++ b/Network/MtGoxAPI/Handles.hs @@ -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 + } diff --git a/Network/MtGoxAPI/HttpAPI.hs b/Network/MtGoxAPI/HttpAPI.hs new file mode 100644 --- /dev/null +++ b/Network/MtGoxAPI/HttpAPI.hs @@ -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 diff --git a/Network/MtGoxAPI/StreamAuthCommands.hs b/Network/MtGoxAPI/StreamAuthCommands.hs new file mode 100644 --- /dev/null +++ b/Network/MtGoxAPI/StreamAuthCommands.hs @@ -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": +-- "call": base64-encoded string +-- +-- +-- +-- "call": +-- "nonce": +-- "params": +-- "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 diff --git a/Network/MtGoxAPI/StreamCommands.hs b/Network/MtGoxAPI/StreamCommands.hs new file mode 100644 --- /dev/null +++ b/Network/MtGoxAPI/StreamCommands.hs @@ -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 diff --git a/Network/MtGoxAPI/StreamConnection.hs b/Network/MtGoxAPI/StreamConnection.hs new file mode 100644 --- /dev/null +++ b/Network/MtGoxAPI/StreamConnection.hs @@ -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 diff --git a/Network/MtGoxAPI/TickerMonitor.hs b/Network/MtGoxAPI/TickerMonitor.hs new file mode 100644 --- /dev/null +++ b/Network/MtGoxAPI/TickerMonitor.hs @@ -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 diff --git a/Network/MtGoxAPI/Types.hs b/Network/MtGoxAPI/Types.hs new file mode 100644 --- /dev/null +++ b/Network/MtGoxAPI/Types.hs @@ -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 diff --git a/Network/MtGoxAPI/WalletNotifier.hs b/Network/MtGoxAPI/WalletNotifier.hs new file mode 100644 --- /dev/null +++ b/Network/MtGoxAPI/WalletNotifier.hs @@ -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) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/TestSuite.hs b/TestSuite.hs new file mode 100644 --- /dev/null +++ b/TestSuite.hs @@ -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 diff --git a/mtgoxapi.cabal b/mtgoxapi.cabal new file mode 100644 --- /dev/null +++ b/mtgoxapi.cabal @@ -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 +copyright: (c) 2012 - 2014 Jan Vornberger +maintainer: Jan Vornberger +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