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.Fixed (HasResolution(..), Fixed)
  12 import Data.Foldable (foldMap)
  13 import Data.Function (const, id, on)
  14 import Data.Functor (fmap, (<$>))
  15 import Data.List (minimum, maximum)
  16 import Data.Maybe (Maybe(Nothing, Just), catMaybes, mapMaybe)
  17 import Data.Monoid (Monoid(..), Sum(..), (<>))
  18 import Data.Ord (Ord(..), min, max)
  19 import Data.Tuple (curry, uncurry)
  20 import Numeric (readFloat)
  21 import Prelude
  22         ( Num, Show(show), Fractional(fromRational)
  23         , Integer, String, IO
  24         , print, putStr, putStrLn, read, take, undefined
  25         , (.), ($)
  26         ,
  27         )
  28
  29 -- bytestring
  30 import qualified Data.ByteString       as BS
  31 import qualified Data.ByteString.Char8 as CS
  32
  33 -- network
  34 import Network.URI (URI, parseAbsoluteURI)
  35
  36 -- Crypto
  37 import Codec.Utils (Octet)
  38 import Data.HMAC (HashMethod(..), hmac)
  39 import qualified Data.Digest.SHA512 as SHA512 (hash)
  40
  41 -- HTTP
  42 import Network.HTTP.Base
  43         ( Request(..), Response(..), RequestMethod(..)
  44         , urlEncodeVars, httpPackageVersion
  45         )
  46
  47 import Network.HTTP.Headers (Header(Header), HeaderName(HdrCustom))
  48
  49 import qualified Network.Browser as Browser (request)
  50 import           Network.Browser
  51         ( Proxy(NoProxy), BrowserAction
  52         , browse, setAllowRedirects, setMaxRedirects, setAuthorities
  53         , setAllowBasicAuth, setMaxErrorRetries, setMaxPoolSize
  54         , setMaxAuthAttempts, setProxy, setUserAgent
  55         )
  56
  57 -- either
  58 import Control.Monad.Trans.Either
  59         ( EitherT(..), bimapEitherT, eitherT, runEitherT, hoistEither
  60         )
  61
  62 -- errors
  63 import Control.Error.Util (note)
  64
  65 -- text
  66 import qualified Data.Text as T
  67
  68 -- unordered-containers
  69 import qualified Data.HashMap.Strict as HM (lookup)
  70
  71 -- this package
  72 import Cryptsy.API.Public.MarketData.New
  73 import qualified Cryptsy.API.Public.Market as Market (withText)
  74 import qualified Cryptsy.API.Public.Trade as Trade
  75         ( price, quantity, total )
  76
  77 url :: String
  78 url = "https://www.cryptsy.com/api"
  79
  80 mUri :: Maybe URI
  81 mUri = parseAbsoluteURI url
  82
  83 apiPubkey :: String
  84 apiPubkey = "5a8808b25e3f59d8818d3fbc0ce993fbb82dcf90"
  85
  86 apiPrivkey :: String
  87 apiPrivkey = ""
  88
  89 get_nonce :: IO Integer
  90 get_nonce = do
  91         return 1
  92
  93 method :: String
  94 method = "getinfo"
  95
  96 sha512_hm :: HashMethod
  97 sha512_hm = HashMethod
  98         { digest = SHA512.hash
  99         , input_blocksize = 1024
 100         }
 101
 102 hexdump :: [Octet] -> String
 103 hexdump = mconcat . fmap show2Hex
 104  where
 105         show2Hex = undefined
 106
 107 readHex :: String -> Maybe [Octet]
 108 readHex = undefined
 109
 110 oldMain :: IO ()
 111 oldMain = case (readHex apiPrivkey, mUri) of
 112         (_, Nothing) -> do
 113                 putStr url
 114                 putStrLn " could not be parsed as an absolute URI."
 115         (Nothing, _) ->
 116                 putStrLn "<apiPrivkey> could not be parsed as hex."
 117         (Just pk, Just uri) -> do
 118                 nonce <- get_nonce
 119                 let
 120                         postString = urlEncodeVars [ ("nonce", show nonce) ]
 121                         postSig = hexdump . hmac sha512_hm pk . BS.unpack $ CS.pack postString
 122                         request = Request
 123                                 { rqURI = uri
 124                                 , rqMethod = POST
 125                                 , rqHeaders =
 126                                         [ Header (HdrCustom "Key" ) apiPubkey
 127                                         , Header (HdrCustom "Sign") postSig
 128                                         ]
 129                                 , rqBody = postString
 130                                 }
 131                 body <- browse $ do
 132                         initBrowser
 133                         (_, response) <- Browser.request request
 134                         return $ rspBody response
 135                 putStrLn body
 136
 137 initBrowser :: BrowserAction t ()
 138 initBrowser = do
 139         setAllowRedirects True
 140         setMaxRedirects $ Just 10
 141         setAuthorities []
 142         setAllowBasicAuth False
 143         setMaxErrorRetries $ Just 0
 144         setMaxPoolSize $ Just 2
 145         setMaxAuthAttempts $ Just 0
 146         setProxy NoProxy
 147         setUserAgent $ "Network.Browser/" <> httpPackageVersion
 148
 149 data E8
 150
 151 instance HasResolution E8 where
 152         resolution = const 100000000
 153
 154 type CryptsyNum = Fixed E8
 155
 156 parseCryptsyNum :: Text -> Parser CryptsyNum
 157 parseCryptsyNum (readFloat . T.unpack -> reads) = case reads of
 158         []        -> fail "No parse."
 159         [(r, "")] -> return r
 160         [(_, _ )] -> fail "Incomplete parse."
 161         _         -> fail "Ambiguous parse."
 162
 163 newtype Min n = Min { getMin :: Maybe n } deriving Show
 164 instance Ord n => Monoid (Min n) where
 165         mempty = Min Nothing
 166         mappend (Min  Nothing)  m             = m
 167         mappend  m             (Min  Nothing) = m
 168         mappend (Min (Just m)) (Min (Just n)) = Min . Just $ min m n
 169         mconcat []   = Min Nothing
 170         mconcat mins = Min . Just . minimum . catMaybes $ fmap getMin mins
 171
 172 newtype Max n = Max { getMax :: Maybe n } deriving Show
 173 instance Ord n => Monoid (Max n) where
 174         mempty = Max Nothing
 175         mappend (Max  Nothing)  m             = m
 176         mappend  m             (Max  Nothing) = m
 177         mappend (Max (Just m)) (Max (Just n)) = Max . Just $ max m n
 178         mconcat []   = Max Nothing
 179         mconcat maxs = Max . Just . maximum $ mapMaybe getMax maxs
 180
 181 data MarketSummary p q t = MarketSummary
 182         { minPrice :: Min p
 183         , maxPrice :: Max p
 184         , count :: Sum Integer
 185         , primaryVolume :: Sum q
 186         , secondaryVolume :: Sum t
 187         } deriving Show
 188 instance (Ord p, Num q, Num t) => Monoid (MarketSummary p q t) where
 189         mempty  = MarketSummary
 190                   mempty
 191                   mempty
 192                   mempty
 193                   mempty
 194                   mempty
 195         mappend = curry $ MarketSummary <$>
 196                   uncurry (mappend `on` minPrice) <*>
 197                   uncurry (mappend `on` maxPrice) <*>
 198                   uncurry (mappend `on` count) <*>
 199                   uncurry (mappend `on` primaryVolume) <*>
 200                   uncurry (mappend `on` secondaryVolume)
 201         mconcat = MarketSummary <$>
 202                   (mconcat . fmap minPrice) <*>
 203                   (mconcat . fmap maxPrice) <*>
 204                   (mconcat . fmap count) <*>
 205                   (mconcat . fmap primaryVolume) <*>
 206                   (mconcat . fmap secondaryVolume)
 207
 208 tradeSummary :: GTrade dt p q t -> MarketSummary p q t
 209 tradeSummary trade = MarketSummary
 210         { minPrice = Min . Just $ Trade.price trade
 211         , maxPrice = Max . Just $ Trade.price trade
 212         , count = Sum 1
 213         , primaryVolume = Sum $ Trade.quantity trade
 214         , secondaryVolume = Sum $ Trade.total trade
 215         }
 216
 217 main :: IO ()
 218 main = eitherT putStrLn print $ do
 219         MarketData mkts <- bimapEitherT show id . EitherT . browse $ do
 220                 initBrowser
 221                 runEitherT $ marketData parseMarkets
 222         mkt <- hoistEither . note "No 'LTC/BTC' market."
 223              $ HM.lookup (T.pack "LTC/BTC") mkts
 224         return . foldMap tradeSummary $ recenttrades mkt
 225  where
 226         parseMarkets = withMarket parseMarket
 227         parseMarket = Market.withText
 228                       parseCryptsyNum
 229                       parseCryptsyNum
 230                       pure
 231                       parseCryptsyNum