Main.hs

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