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