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