Main.hs

   1 {-# LANGUAGE ViewPatterns, NoMonomorphismRestriction #-}
   2 module Main
   3 ( main
   4 )
   5 where
   6
   7 -- base
   8 import Control.Applicative (pure, (<*>), (<|>))
   9 import Control.Monad (Monad, fail, return, (<=<), (>>=))
  10 import Data.Bool (Bool(False, True))
  11 import Data.Either (Either(Left, Right))
  12 import Data.Foldable (foldMap)
  13 import Data.Function (on)
  14 import Data.Functor (fmap, (<$>))
  15 import Data.List (minimum, maximum)
  16 import Data.Maybe (Maybe(Nothing, Just), catMaybes)
  17 import Data.Monoid (Monoid(..), Sum(..), (<>))
  18 import Data.Ord (Ord(..), min, max)
  19 import Data.Ratio (Rational)
  20 import Data.Traversable (mapM)
  21 import Data.Tuple (curry, uncurry)
  22 import Numeric (readSigned, readFloat)
  23 import Prelude
  24         ( Num, Show
  25         , Integer, String, IO
  26         , print, putStr, putStrLn, read, show, take, undefined
  27         , (.), ($)
  28         )
  29
  30 -- bytestring
  31 import           Data.ByteString (ByteString)
  32 import qualified Data.ByteString       as BS
  33 import qualified Data.ByteString.Lazy  as LBS
  34 import qualified Data.ByteString.Char8 as CS
  35
  36 -- network
  37 import Network.URI (URI, parseAbsoluteURI)
  38
  39 -- Crypto
  40 import Codec.Utils (Octet)
  41 import Data.HMAC (HashMethod(..), hmac)
  42 import qualified Data.Digest.SHA512 as SHA512 (hash)
  43
  44 -- HTTP
  45 import Network.HTTP.Base
  46         ( Request(..), Response(..), RequestMethod(..)
  47         , urlEncodeVars, httpPackageVersion
  48         )
  49
  50 import Network.HTTP.Headers (Header(Header), HeaderName(HdrCustom))
  51
  52 import qualified Network.Browser as Browser (request)
  53 import           Network.Browser
  54         ( Proxy(NoProxy), BrowserAction
  55         , browse, setAllowRedirects, setMaxRedirects, setAuthorities
  56         , setAllowBasicAuth, setMaxErrorRetries, setMaxPoolSize
  57         , setMaxAuthAttempts, setProxy, setUserAgent
  58         )
  59
  60 -- aeson
  61 import Data.Aeson
  62         ( FromJSON(..)
  63         , Value(..), Result(..)
  64         , fromJSON, json, withArray, withObject
  65         , (.:)
  66         )
  67 import Data.Aeson.Types (Parser, parseEither)
  68
  69 -- attoparsec
  70 import Data.Attoparsec.ByteString (parseOnly)
  71 import Data.Attoparsec.ByteString.Lazy (parse, eitherResult)
  72
  73 -- either
  74 import Control.Monad.Trans.Either (EitherT, eitherT, hoistEither, left, right)
  75
  76 -- errors
  77 import Control.Error.Util (note)
  78
  79 -- text
  80 import qualified Data.Text as T
  81 import           Data.Text (Text)
  82
  83 -- time
  84 import Data.Time (LocalTime)
  85
  86 -- transformers
  87 import Control.Monad.Trans.Class (lift)
  88
  89 -- unordered-containers
  90 import           Data.HashMap.Strict (HashMap)
  91 import qualified Data.HashMap.Strict as HM (lookup)
  92
  93 -- vector
  94 import Data.Vector (Vector)
  95
  96 url :: String
  97 url = "https://www.cryptsy.com/api"
  98
  99 mUri :: Maybe URI
 100 mUri = parseAbsoluteURI url
 101
 102 apiPubkey :: String
 103 apiPubkey = "5a8808b25e3f59d8818d3fbc0ce993fbb82dcf90"
 104
 105 apiPrivkey :: String
 106 apiPrivkey = ""
 107
 108 get_nonce :: IO Integer
 109 get_nonce = do
 110         return 1
 111
 112 method :: String
 113 method = "getinfo"
 114
 115 sha512_hm :: HashMethod
 116 sha512_hm = HashMethod
 117         { digest = SHA512.hash
 118         , input_blocksize = 1024
 119         }
 120
 121 hexdump :: [Octet] -> String
 122 hexdump = mconcat . fmap show2Hex
 123  where
 124         show2Hex = undefined
 125
 126 readHex :: String -> Maybe [Octet]
 127 readHex = undefined
 128
 129 oldMain :: IO ()
 130 oldMain = case (readHex apiPrivkey, mUri) of
 131         (_, Nothing) -> do
 132                 putStr url
 133                 putStrLn " could not be parsed as an absolute URI."
 134         (Nothing, _) -> do
 135                 putStrLn "<apiPrivkey> could not be parsed as hex."
 136         (Just pk, Just uri) -> do
 137                 nonce <- get_nonce
 138                 let
 139                         postString = urlEncodeVars [ ("nonce", show nonce) ]
 140                         postSig = hexdump . hmac sha512_hm pk . BS.unpack $ CS.pack postString
 141                         request = Request
 142                                 { rqURI = uri
 143                                 , rqMethod = POST
 144                                 , rqHeaders =
 145                                         [ Header (HdrCustom "Key" ) apiPubkey
 146                                         , Header (HdrCustom "Sign") postSig
 147                                         ]
 148                                 , rqBody = postString
 149                                 }
 150                 body <- browse $ do
 151                         initBrowser
 152                         (_, response) <- Browser.request request
 153                         return $ rspBody response
 154                 putStrLn body
 155
 156 initBrowser :: BrowserAction t ()
 157 initBrowser = do
 158         setAllowRedirects True
 159         setMaxRedirects $ Just 10
 160         setAuthorities []
 161         setAllowBasicAuth False
 162         setMaxErrorRetries $ Just 0
 163         setMaxPoolSize $ Just 2
 164         setMaxAuthAttempts $ Just 0
 165         setProxy NoProxy
 166         setUserAgent $ "Network.Browser/" <> httpPackageVersion
 167
 168 marketdatav2_url :: String
 169 marketdatav2_url = "http://pubapi.cryptsy.com/api.php?method=marketdatav2"
 170
 171 parseResponseBody :: LBS.ByteString -> Either String Value
 172 parseResponseBody = eitherResult . parse json
 173
 174 dataKey :: Text
 175 dataKey = T.pack "return"
 176
 177 extractData :: Value -> Maybe Value
 178 extractData (Object (HM.lookup dataKey -> v@(Just dat))) = v
 179 extractData  _                                           = fail "Missing 'return' key."
 180
 181 newtype GGeneralMarketData p q dt t =
 182         GeneralMarketData (HashMap Text (GSingleGeneralMarketData p q dt t))
 183         deriving Show
 184 type GeneralMarketData = GGeneralMarketData Rational Rational LocalTime Rational
 185
 186 instance (FromJSON p, FromJSON q, FromJSON dt, FromJSON t) =>
 187         FromJSON (GGeneralMarketData p q dt t)
 188  where
 189         parseJSON = genGMD_parseJSON parseJSON parseJSON parseJSON parseJSON
 190
 191 genGMD_parseJSON :: (Value -> Parser p) -> (Value -> Parser q) -> (Value -> Parser dt) -> (Value -> Parser t) -> Value -> Parser (GGeneralMarketData p q dt t)
 192 genGMD_parseJSON parsePrice parseQuantity parseDatetime parseTotal =
 193         withObject "markets" (fmap GeneralMarketData <$> mapM parseMarket)
 194  where
 195         parseMarket = genSGMD_parseJSON parsePrice parseQuantity parseDatetime parseTotal
 196
 197 data GSingleGeneralMarketData p q dt t = SingleGeneralMarketData
 198         { marketid :: Text
 199         , label :: Text
 200         , lasttradeprice :: p
 201         , volume :: q
 202         , lasttradetime :: dt
 203         , primaryname :: Text
 204         , primarycode :: Text
 205         , secondaryname :: Text
 206         , secondarycode :: Text
 207         , recenttrades :: Vector (GGeneralMarketDataTrade dt p q t)
 208         , sellorders :: Vector (GGeneralMarketDataOrder p q t)
 209         , buyorders :: Vector (GGeneralMarketDataOrder p q t)
 210         } deriving Show
 211 type SingleGeneralMarketData = GSingleGeneralMarketData Rational Rational LocalTime Rational
 212
 213 instance (FromJSON p, FromJSON q, FromJSON dt, FromJSON t) =>
 214         FromJSON (GSingleGeneralMarketData p q dt t)
 215  where
 216         parseJSON = genSGMD_parseJSON parseJSON parseJSON parseJSON parseJSON
 217
 218 genSGMD_parseJSON :: (Value -> Parser p) -> (Value -> Parser q) -> (Value -> Parser dt) -> (Value -> Parser t) -> Value -> Parser (GSingleGeneralMarketData p q dt t)
 219 genSGMD_parseJSON parsePrice parseQuantity parseDatetime parseTotal (Object o) =
 220         SingleGeneralMarketData <$>
 221         o .: T.pack "marketid" <*>
 222         o .: T.pack "label" <*>
 223         (o .: T.pack "lasttradeprice" >>= parsePrice) <*>
 224         (o .: T.pack "volume" >>= parseQuantity) <*>
 225         (o .: T.pack "lasttradetime" >>= parseDatetime) <*>
 226         o .: T.pack "primaryname" <*>
 227         o .: T.pack "primarycode" <*>
 228         o .: T.pack "secondaryname" <*>
 229         o .: T.pack "secondarycode" <*>
 230         (o .: T.pack "recenttrades" >>= parseTrades) <*>
 231         (o .: T.pack "sellorders" >>= parseOrders) <*>
 232         (o .: T.pack "buyorders" >>= parseOrders)
 233  where
 234         parseTrades = withArray "trades" . mapM $ genGMDT_parseJSON parseDatetime parsePrice parseQuantity parseTotal
 235         parseOrders = withArray "orders" . mapM $ genGMDO_parseJSON parsePrice parseQuantity parseTotal
 236 genSGMD_parseJSON _ _ _ _ _ =
 237         fail "Data for a single market is a JSON object."
 238
 239 data GGeneralMarketDataTrade dt p q t = GeneralMarketDataTrade
 240         { tId :: Text
 241         , time :: dt
 242         , tPrice :: p
 243         , tQuantity :: q
 244         , tTotal :: t
 245         } deriving Show
 246 type GeneralMarketDataTrade = GGeneralMarketDataTrade LocalTime Rational Rational Rational
 247
 248 instance (FromJSON dt, FromJSON p, FromJSON q, FromJSON t) =>
 249         FromJSON (GGeneralMarketDataTrade dt p q t)
 250  where
 251         parseJSON = genGMDT_parseJSON parseJSON parseJSON parseJSON parseJSON
 252
 253 genGMDT_parseJSON :: (Value -> Parser dt) -> (Value -> Parser p) -> (Value -> Parser q) -> (Value -> Parser t) -> Value -> Parser (GGeneralMarketDataTrade dt p q t)
 254 genGMDT_parseJSON parseDatetime parsePrice parseQuantity parseTotal (Object o) =
 255         GeneralMarketDataTrade <$>
 256         o .: T.pack "id" <*>
 257         (o .: T.pack "time" >>= parseDatetime) <*>
 258         (o .: T.pack "price" >>= parsePrice) <*>
 259         (o .: T.pack "quantity" >>= parseQuantity) <*>
 260         (o .: T.pack "total" >>= parseTotal)
 261 genGMDT_parseJSON _ _ _ _ _ =
 262         fail "A trade is a JSON object."
 263
 264 data GGeneralMarketDataOrder p q t = GeneralMarketDataOrder
 265         { oPrice :: p
 266         , oQuantity :: q
 267         , oTotal :: t
 268         } deriving Show
 269 type GeneralMarketDataOrder = GGeneralMarketDataOrder Rational Rational Rational
 270
 271 instance (FromJSON p, FromJSON q, FromJSON t) =>
 272         FromJSON (GGeneralMarketDataOrder p q t)
 273  where
 274         parseJSON = genGMDO_parseJSON parseJSON parseJSON parseJSON
 275
 276 genGMDO_parseJSON :: (Value -> Parser p) -> (Value -> Parser q) -> (Value -> Parser t) -> Value -> Parser (GGeneralMarketDataOrder p q t)
 277 genGMDO_parseJSON parsePrice parseQuantity parseTotal (Object o) =
 278         GeneralMarketDataOrder <$>
 279         (o .: T.pack "price" >>= parsePrice) <*>
 280         (o .: T.pack "quantity" >>= parseQuantity) <*>
 281         (o .: T.pack "total" >>= parseTotal)
 282 genGMDO_parseJSON _ _ _ _ =
 283         fail "An order is a JSON object."
 284
 285 extractMarkets :: Value -> Either String Value
 286 extractMarkets (Object (HM.lookup (T.pack "markets") -> Just m)) = Right m
 287 extractMarkets  _                                                = Left "Missing 'markets' key."
 288
 289 hoistResult :: Monad m => Result a -> EitherT String m a
 290 hoistResult (Error   s) = left  s
 291 hoistResult (Success a) = right a
 292
 293 parseRational :: Value -> Parser Rational
 294 parseRational v = parseJSON v <|> parseRatString
 295  where
 296         parseRatString = do
 297                 str <- parseJSON v
 298                 case readSigned readFloat str of
 299                         []        -> fail "No parse."
 300                         [(r, "")] -> return r
 301                         _         -> fail "Ambiguous parse."
 302
 303 newtype Min n = Min { getMin :: Maybe n } deriving Show
 304 instance Ord n => Monoid (Min n) where
 305         mempty = Min Nothing
 306         mappend (Min  Nothing)  m             = m
 307         mappend  m             (Min  Nothing) = m
 308         mappend (Min (Just m)) (Min (Just n)) = Min . Just $ min m n
 309         mconcat []   = Min Nothing
 310         mconcat mins = Min . Just . minimum . catMaybes $ fmap getMin mins
 311
 312 newtype Max n = Max { getMax :: Maybe n } deriving Show
 313 instance Ord n => Monoid (Max n) where
 314         mempty = Max Nothing
 315         mappend (Max  Nothing)  m             = m
 316         mappend  m             (Max  Nothing) = m
 317         mappend (Max (Just m)) (Max (Just n)) = Max . Just $ max m n
 318         mconcat []   = Max Nothing
 319         mconcat maxs = Max . Just . maximum . catMaybes $ fmap getMax maxs
 320
 321 data MarketSummary p q t = MarketSummary
 322         { minPrice :: Min p
 323         , maxPrice :: Max p
 324         , count :: Sum Integer
 325         , primaryVolume :: Sum q
 326         , secondaryVolume :: Sum t
 327         } deriving Show
 328 instance (Ord p, Num q, Num t) => Monoid (MarketSummary p q t) where
 329         mempty  = MarketSummary
 330                   mempty
 331                   mempty
 332                   mempty
 333                   mempty
 334                   mempty
 335         mappend = curry $ MarketSummary <$>
 336                   uncurry (mappend `on` minPrice) <*>
 337                   uncurry (mappend `on` maxPrice) <*>
 338                   uncurry (mappend `on` count) <*>
 339                   uncurry (mappend `on` primaryVolume) <*>
 340                   uncurry (mappend `on` secondaryVolume)
 341         mconcat = MarketSummary <$>
 342                   (mconcat . fmap minPrice) <*>
 343                   (mconcat . fmap maxPrice) <*>
 344                   (mconcat . fmap count) <*>
 345                   (mconcat . fmap primaryVolume) <*>
 346                   (mconcat . fmap secondaryVolume)
 347
 348 tradeSummary :: GGeneralMarketDataTrade dt p q t -> MarketSummary p q t
 349 tradeSummary trade = MarketSummary
 350         { minPrice = Min . Just $ tPrice trade
 351         , maxPrice = Max . Just $ tPrice trade
 352         , count = Sum 1
 353         , primaryVolume = Sum $ tQuantity trade
 354         , secondaryVolume = Sum $ tTotal trade
 355         }
 356
 357 main :: IO ()
 358 main = case parseAbsoluteURI marketdatav2_url of
 359         Nothing -> do
 360                 putStr marketdatav2_url
 361                 putStrLn " could not be parsed as an absolute URI."
 362         Just uri -> eitherT putStrLn print $ do
 363                 body <- lift $ browse $ do
 364                         initBrowser
 365                         let
 366                                 req = Request
 367                                         { rqURI = uri
 368                                         , rqMethod = GET
 369                                         , rqHeaders = []
 370                                         , rqBody = LBS.empty
 371                                         }
 372                         (_, resp) <- Browser.request req
 373                         return $ rspBody resp
 374                 markets <- hoistEither $ do
 375                         val <- parseResponseBody body
 376                         dat <- note "No 'return'" $ extractData val
 377                         jsonMkts <- extractMarkets dat
 378                         GeneralMarketData mkts <- parseEither (genGMD_parseJSON parseRational parseRational pure parseRational) jsonMkts
 379                         return mkts
 380                 mkt <- hoistEither . note "No 'LTC/BTC' market." $ HM.lookup (T.pack "LTC/BTC") markets
 381                 return . foldMap tradeSummary $ recenttrades mkt