From a8ca5c135c83da38fa55f55f204287035281425d Mon Sep 17 00:00:00 2001 From: Boyd Stephen Smith Jr Date: Sat, 26 Oct 2013 02:28:38 -0500 Subject: [PATCH] Summarize a single market. --- Main.hs | 283 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 268 insertions(+), 15 deletions(-) diff --git a/Main.hs b/Main.hs index 4ea0944..6a44826 100644 --- a/Main.hs +++ b/Main.hs @@ -1,14 +1,36 @@ +{-# LANGUAGE ViewPatterns, NoMonomorphismRestriction #-} module Main ( main ) where -- base -import Control.Monad ((<=<)) -import Data.Monoid (mconcat) +import Control.Applicative (pure, (<*>), (<|>)) +import Control.Monad (Monad, fail, return, (<=<), (>>=)) +import Data.Bool (Bool(False, True)) +import Data.Either (Either(Left, Right)) +import Data.Foldable (foldMap) +import Data.Function (on) +import Data.Functor (fmap, (<$>)) +import Data.List (minimum, maximum) +import Data.Maybe (Maybe(Nothing, Just), catMaybes) +import Data.Monoid (Monoid(..), Sum(..), (<>)) +import Data.Ord (Ord(..), min, max) +import Data.Ratio (Rational) +import Data.Traversable (mapM) +import Data.Tuple (curry, uncurry) +import Numeric (readSigned, readFloat) +import Prelude + ( Num, Show + , Integer, String, IO + , print, putStr, putStrLn, read, show, take, undefined + , (.), ($) + ) -- bytestring +import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Char8 as CS -- network @@ -35,6 +57,42 @@ import Network.Browser , setMaxAuthAttempts, setProxy, setUserAgent ) +-- aeson +import Data.Aeson + ( FromJSON(..) + , Value(..), Result(..) + , fromJSON, json, withArray, withObject + , (.:) + ) +import Data.Aeson.Types (Parser, parseEither) + +-- attoparsec +import Data.Attoparsec.ByteString (parseOnly) +import Data.Attoparsec.ByteString.Lazy (parse, eitherResult) + +-- either +import Control.Monad.Trans.Either (EitherT, eitherT, hoistEither, left, right) + +-- errors +import Control.Error.Util (note) + +-- text +import qualified Data.Text as T +import Data.Text (Text) + +-- time +import Data.Time (LocalTime) + +-- transformers +import Control.Monad.Trans.Class (lift) + +-- unordered-containers +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM (lookup) + +-- vector +import Data.Vector (Vector) + url :: String url = "https://www.cryptsy.com/api" @@ -61,7 +119,7 @@ sha512_hm = HashMethod } hexdump :: [Octet] -> String -hexdump = mconcat . map show2Hex +hexdump = mconcat . fmap show2Hex where show2Hex = undefined @@ -105,24 +163,219 @@ initBrowser = do setMaxPoolSize $ Just 2 setMaxAuthAttempts $ Just 0 setProxy NoProxy - setUserAgent $ "Network.Browser/" ++ httpPackageVersion + setUserAgent $ "Network.Browser/" <> httpPackageVersion marketdatav2_url :: String marketdatav2_url = "http://pubapi.cryptsy.com/api.php?method=marketdatav2" +parseResponseBody :: LBS.ByteString -> Either String Value +parseResponseBody = eitherResult . parse json + +dataKey :: Text +dataKey = T.pack "return" + +extractData :: Value -> Maybe Value +extractData (Object (HM.lookup dataKey -> v@(Just dat))) = v +extractData _ = fail "Missing 'return' key." + +newtype GGeneralMarketData p q dt t = + GeneralMarketData (HashMap Text (GSingleGeneralMarketData p q dt t)) + deriving Show +type GeneralMarketData = GGeneralMarketData Rational Rational LocalTime Rational + +instance (FromJSON p, FromJSON q, FromJSON dt, FromJSON t) => + FromJSON (GGeneralMarketData p q dt t) + where + parseJSON = genGMD_parseJSON parseJSON parseJSON parseJSON parseJSON + +genGMD_parseJSON :: (Value -> Parser p) -> (Value -> Parser q) -> (Value -> Parser dt) -> (Value -> Parser t) -> Value -> Parser (GGeneralMarketData p q dt t) +genGMD_parseJSON parsePrice parseQuantity parseDatetime parseTotal = + withObject "markets" (fmap GeneralMarketData <$> mapM parseMarket) + where + parseMarket = genSGMD_parseJSON parsePrice parseQuantity parseDatetime parseTotal + +data GSingleGeneralMarketData p q dt t = SingleGeneralMarketData + { marketid :: Text + , label :: Text + , lasttradeprice :: p + , volume :: q + , lasttradetime :: dt + , primaryname :: Text + , primarycode :: Text + , secondaryname :: Text + , secondarycode :: Text + , recenttrades :: Vector (GGeneralMarketDataTrade dt p q t) + , sellorders :: Vector (GGeneralMarketDataOrder p q t) + , buyorders :: Vector (GGeneralMarketDataOrder p q t) + } deriving Show +type SingleGeneralMarketData = GSingleGeneralMarketData Rational Rational LocalTime Rational + +instance (FromJSON p, FromJSON q, FromJSON dt, FromJSON t) => + FromJSON (GSingleGeneralMarketData p q dt t) + where + parseJSON = genSGMD_parseJSON parseJSON parseJSON parseJSON parseJSON + +genSGMD_parseJSON :: (Value -> Parser p) -> (Value -> Parser q) -> (Value -> Parser dt) -> (Value -> Parser t) -> Value -> Parser (GSingleGeneralMarketData p q dt t) +genSGMD_parseJSON parsePrice parseQuantity parseDatetime parseTotal (Object o) = + SingleGeneralMarketData <$> + o .: T.pack "marketid" <*> + o .: T.pack "label" <*> + (o .: T.pack "lasttradeprice" >>= parsePrice) <*> + (o .: T.pack "volume" >>= parseQuantity) <*> + (o .: T.pack "lasttradetime" >>= parseDatetime) <*> + o .: T.pack "primaryname" <*> + o .: T.pack "primarycode" <*> + o .: T.pack "secondaryname" <*> + o .: T.pack "secondarycode" <*> + (o .: T.pack "recenttrades" >>= parseTrades) <*> + (o .: T.pack "sellorders" >>= parseOrders) <*> + (o .: T.pack "buyorders" >>= parseOrders) + where + parseTrades = withArray "trades" . mapM $ genGMDT_parseJSON parseDatetime parsePrice parseQuantity parseTotal + parseOrders = withArray "orders" . mapM $ genGMDO_parseJSON parsePrice parseQuantity parseTotal +genSGMD_parseJSON _ _ _ _ _ = + fail "Data for a single market is a JSON object." + +data GGeneralMarketDataTrade dt p q t = GeneralMarketDataTrade + { tId :: Text + , time :: dt + , tPrice :: p + , tQuantity :: q + , tTotal :: t + } deriving Show +type GeneralMarketDataTrade = GGeneralMarketDataTrade LocalTime Rational Rational Rational + +instance (FromJSON dt, FromJSON p, FromJSON q, FromJSON t) => + FromJSON (GGeneralMarketDataTrade dt p q t) + where + parseJSON = genGMDT_parseJSON parseJSON parseJSON parseJSON parseJSON + +genGMDT_parseJSON :: (Value -> Parser dt) -> (Value -> Parser p) -> (Value -> Parser q) -> (Value -> Parser t) -> Value -> Parser (GGeneralMarketDataTrade dt p q t) +genGMDT_parseJSON parseDatetime parsePrice parseQuantity parseTotal (Object o) = + GeneralMarketDataTrade <$> + o .: T.pack "id" <*> + (o .: T.pack "time" >>= parseDatetime) <*> + (o .: T.pack "price" >>= parsePrice) <*> + (o .: T.pack "quantity" >>= parseQuantity) <*> + (o .: T.pack "total" >>= parseTotal) +genGMDT_parseJSON _ _ _ _ _ = + fail "A trade is a JSON object." + +data GGeneralMarketDataOrder p q t = GeneralMarketDataOrder + { oPrice :: p + , oQuantity :: q + , oTotal :: t + } deriving Show +type GeneralMarketDataOrder = GGeneralMarketDataOrder Rational Rational Rational + +instance (FromJSON p, FromJSON q, FromJSON t) => + FromJSON (GGeneralMarketDataOrder p q t) + where + parseJSON = genGMDO_parseJSON parseJSON parseJSON parseJSON + +genGMDO_parseJSON :: (Value -> Parser p) -> (Value -> Parser q) -> (Value -> Parser t) -> Value -> Parser (GGeneralMarketDataOrder p q t) +genGMDO_parseJSON parsePrice parseQuantity parseTotal (Object o) = + GeneralMarketDataOrder <$> + (o .: T.pack "price" >>= parsePrice) <*> + (o .: T.pack "quantity" >>= parseQuantity) <*> + (o .: T.pack "total" >>= parseTotal) +genGMDO_parseJSON _ _ _ _ = + fail "An order is a JSON object." + +extractMarkets :: Value -> Either String Value +extractMarkets (Object (HM.lookup (T.pack "markets") -> Just m)) = Right m +extractMarkets _ = Left "Missing 'markets' key." + +hoistResult :: Monad m => Result a -> EitherT String m a +hoistResult (Error s) = left s +hoistResult (Success a) = right a + +parseRational :: Value -> Parser Rational +parseRational v = parseJSON v <|> parseRatString + where + parseRatString = do + str <- parseJSON v + case readSigned readFloat str of + [] -> fail "No parse." + [(r, "")] -> return r + _ -> fail "Ambiguous parse." + +newtype Min n = Min { getMin :: Maybe n } deriving Show +instance Ord n => Monoid (Min n) where + mempty = Min Nothing + mappend (Min Nothing) m = m + mappend m (Min Nothing) = m + mappend (Min (Just m)) (Min (Just n)) = Min . Just $ min m n + mconcat [] = Min Nothing + mconcat mins = Min . Just . minimum . catMaybes $ fmap getMin mins + +newtype Max n = Max { getMax :: Maybe n } deriving Show +instance Ord n => Monoid (Max n) where + mempty = Max Nothing + mappend (Max Nothing) m = m + mappend m (Max Nothing) = m + mappend (Max (Just m)) (Max (Just n)) = Max . Just $ max m n + mconcat [] = Max Nothing + mconcat maxs = Max . Just . maximum . catMaybes $ fmap getMax maxs + +data MarketSummary p q t = MarketSummary + { minPrice :: Min p + , maxPrice :: Max p + , count :: Sum Integer + , primaryVolume :: Sum q + , secondaryVolume :: Sum t + } deriving Show +instance (Ord p, Num q, Num t) => Monoid (MarketSummary p q t) where + mempty = MarketSummary + mempty + mempty + mempty + mempty + mempty + mappend = curry $ MarketSummary <$> + uncurry (mappend `on` minPrice) <*> + uncurry (mappend `on` maxPrice) <*> + uncurry (mappend `on` count) <*> + uncurry (mappend `on` primaryVolume) <*> + uncurry (mappend `on` secondaryVolume) + mconcat = MarketSummary <$> + (mconcat . fmap minPrice) <*> + (mconcat . fmap maxPrice) <*> + (mconcat . fmap count) <*> + (mconcat . fmap primaryVolume) <*> + (mconcat . fmap secondaryVolume) + +tradeSummary :: GGeneralMarketDataTrade dt p q t -> MarketSummary p q t +tradeSummary trade = MarketSummary + { minPrice = Min . Just $ tPrice trade + , maxPrice = Max . Just $ tPrice trade + , count = Sum 1 + , primaryVolume = Sum $ tQuantity trade + , secondaryVolume = Sum $ tTotal trade + } + main :: IO () main = case parseAbsoluteURI marketdatav2_url of Nothing -> do putStr marketdatav2_url putStrLn " could not be parsed as an absolute URI." - Just uri -> putStrLn <=< browse $ do - initBrowser - let - req = Request - { rqURI = uri - , rqMethod = GET - , rqHeaders = [] - , rqBody = "" - } - (_, resp) <- Browser.request req - return $ rspBody resp + Just uri -> eitherT putStrLn print $ do + body <- lift $ browse $ do + initBrowser + let + req = Request + { rqURI = uri + , rqMethod = GET + , rqHeaders = [] + , rqBody = LBS.empty + } + (_, resp) <- Browser.request req + return $ rspBody resp + markets <- hoistEither $ do + val <- parseResponseBody body + dat <- note "No 'return'" $ extractData val + jsonMkts <- extractMarkets dat + GeneralMarketData mkts <- parseEither (genGMD_parseJSON parseRational parseRational pure parseRational) jsonMkts + return mkts + mkt <- hoistEither . note "No 'LTC/BTC' market." $ HM.lookup (T.pack "LTC/BTC") markets + return . foldMap tradeSummary $ recenttrades mkt -- 2.11.4.GIT