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
setMaximumRetries 6
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
letOrdersExecuteR :: Maybe WatchdogLogger-> CurlHandle-> MtGoxCredentials-> IO (Either String ())
letOrdersExecuteR mLogger curlHandle mtGoxCreds =
watchdog $ do
watchdogSettings
setLoggingAction silentLogger
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)
}
submitOrder :: Maybe WatchdogLogger-> CurlHandle -> MtGoxCredentials-> OrderType-> Integer-> IO (Either String OrderStats)
submitOrder mLogger curlHandle mtGoxCreds orderType amount = runEitherT $ do
EitherT $ letOrdersExecuteR mLogger curlHandle mtGoxCreds
order <- EitherT $ case orderType of
OrderTypeBuyBTC ->
submitBtcBuyOrder curlHandle mtGoxCreds amount
OrderTypeSellBTC ->
submitBtcSellOrder curlHandle mtGoxCreds amount
r <- liftIO $ letOrdersExecuteR mLogger curlHandle mtGoxCreds
case r of
Left errMsg -> left $ "Warning: After submitting order the call"
++ " to letOrdersExecuteR failed ("
++ errMsg ++ ")"
Right _ -> return ()
let orderID = oOrderID order
orderResult <- EitherT $ getOrderResultR mLogger curlHandle mtGoxCreds
orderType orderID
let tradeIDs = orTradeIDs orderResult
histories <- forM tradeIDs $ \tradeID -> EitherT (getWalletHistory tradeID)
return $ processWalletHistories histories
where
getWalletHistory = getWalletHistoryR mLogger curlHandle mtGoxCreds