From e9707e2d1dc66ef1f1aba9220a04a6c35b1226c6 Mon Sep 17 00:00:00 2001 From: Boyd Stephen Smith Jr Date: Sat, 15 Mar 2014 09:24:19 -0500 Subject: [PATCH] Proof-of-concept for using authenticated API. --- src/Main.hs | 249 ++++++++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 184 insertions(+), 65 deletions(-) rewrite src/Main.hs (93%) diff --git a/src/Main.hs b/src/Main.hs dissimilarity index 93% index cdceeb3..8983e03 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,65 +1,184 @@ -module Main where - --- base -import Control.Monad ((<=<)) - --- HTTP -import Network.HTTP.Base (httpPackageVersion) - -import Network.Browser - ( Proxy(NoProxy), BrowserAction - , browse, setAllowRedirects, setMaxRedirects, setAuthorities - , setAllowBasicAuth, setMaxErrorRetries, setMaxPoolSize - , setMaxAuthAttempts, setProxy, setOutHandler, setUserAgent - ) - --- either -import Control.Monad.Trans.Either (runEitherT) - --- text -import Data.Text (pack) - --- transformers -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Class (lift) - --- unordered-containers -import qualified Data.HashMap.Strict as HM - --- vector -import qualified Data.Vector as V - --- this package -import Cryptsy.API.Public - -initBrowser :: BrowserAction t () -initBrowser = do - setAllowRedirects True - setMaxRedirects $ Just 10 - setAuthorities [] - setAllowBasicAuth False - setMaxErrorRetries $ Just 0 - setMaxPoolSize $ Just 2 - setMaxAuthAttempts $ Just 0 - setProxy NoProxy - setOutHandler . const $ return () - setUserAgent $ "Network.Browser/" ++ httpPackageVersion - -main :: IO () -main = either print return <=< browse . runEitherT $ do - lift initBrowser - books <- orderData - liftIO . print . HM.size $ orderBooks (books :: OrderData) - omkts <- oldMarketData - liftIO . print . HM.size $ markets (omkts :: MarketData) - mkts <- marketData - liftIO . print . HM.size $ markets (mkts :: MarketData) - book <- singleOrderBook $ pack "113" - liftIO . print $ ( V.length $ obBuyOrders (book :: OrderBook) - , V.length $ obSellOrders book - ) - market <- singleMarket $ pack "113" - liftIO . print $ ( V.length $ mktRecentTrades (market :: Market) - , V.length $ mktBuyOrders market - , V.length $ mktSellOrders market - ) +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} +module Main where + +-- base +import Control.Applicative ((<$>)) +import Control.Monad ((<=<)) +import Data.Data (Data) +import Data.Maybe (mapMaybe) +import Data.Monoid (Monoid(..)) +import Data.String (IsString(..)) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import System.IO (IOMode(ReadMode), withFile) + +-- aeson +import Data.Aeson (ToJSON(..), FromJSON(..)) + +-- base16-bytestring +import qualified Data.ByteString.Base16 as B16 + +-- bytestring +import Data.ByteString (ByteString) +-- import qualified Data.ByteString as BS +import Data.ByteString.Builder (toLazyByteString, intDec) +import qualified Data.ByteString.Char8 as CS +import Data.ByteString.Lazy (fromChunks, toStrict) +import qualified Data.ByteString.Lazy.Char8 as LCS + +-- case-insensitive +import qualified Data.CaseInsensitive as CI + +-- cryptohash +import qualified Crypto.Hash.SHA512 as SHA512 +import Crypto.MAC.HMAC (hmac) + +-- deepseq +import Control.DeepSeq (NFData(..)) + +-- http-client +import Network.HTTP.Client + ( RequestBody(RequestBodyBS) + , parseUrl, method, secure, requestHeaders, requestBody, cookieJar + , withManager + , withResponse, responseVersion, responseStatus, responseHeaders + , responseCookieJar, responseBody, brConsume + ) + +-- http-client-tls +import Network.HTTP.Client.TLS (tlsManagerSettings) + +-- http-types +import Network.HTTP.Types (SimpleQuery, renderSimpleQuery) +import Network.HTTP.Types.Method (methodPost) + +-- pipes-aeson +import Pipes.Aeson (DecodingError) +import qualified Pipes.Aeson as PA + +-- pipes-bytestring +import Pipes.ByteString (fromHandle) + +-- text +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeLatin1) + +-- time +import Data.Time.Clock.POSIX (getPOSIXTime) + +-- transformers +import Control.Monad.Trans.State.Strict (evalStateT) + +-- this package +-- import Cryptsy.API.Public + +url :: String +url = "https://api.cryptsy.com/api" + +apiKeyFilename :: FilePath +apiKeyFilename = "apiKey.json" + +cryptsyMethod :: String +cryptsyMethod = "getinfo" + +data Latin1String = Latin1 { toBytes :: ByteString } deriving (Eq, Ord, Data, Typeable) + +instance Read Latin1String where + readsPrec n = mapMaybe canDecode . readsPrec n + where + canDecode (txt, r) = do + thext <- completeDecode txt + return (thext, r) + +instance Show Latin1String where + showsPrec n = showsPrec n . toBytes + show = show . toBytes + +instance IsString Latin1String where + fromString str = case completeDecode $ fromString str of + Just thext -> thext + Nothing -> error "Incomplete decode" + +instance Monoid Latin1String where + mempty = Latin1 { toBytes = mempty } + mappend l r = Latin1 { toBytes = toBytes l `mappend` toBytes r } + mconcat ths = Latin1 { toBytes = mconcat $ map toBytes ths } + +instance NFData Latin1String where + rnf = rnf . toBytes + +decode :: Text -> (Latin1String, Text) +decode txt = (Latin1 . CS.pack $ T.unpack l1c, uc) + where + (l1c, uc) = T.span (< toEnum 256) txt + +completeDecode :: Monad m => Text -> m Latin1String +completeDecode txt = if T.null remainder + then return thext + else fail "Incomplete decode." + where (thext, remainder) = decode txt + +encode :: Latin1String -> Text +encode = decodeLatin1 . toBytes + +instance ToJSON Latin1String where + toJSON = toJSON . encode + +instance FromJSON Latin1String where + parseJSON = completeDecode <=< parseJSON + +data APIKey = APIKey { public :: Latin1String, private :: Latin1String } + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic) + +instance ToJSON APIKey where + +instance FromJSON APIKey where + +-- TODO: Error on incomplete parse +fromJSONFile :: FromJSON a => FilePath -> IO (Either DecodingError a) +fromJSONFile f = withFile f ReadMode $ evalStateT PA.decode . fromHandle + +-- Seconds since POSIX epoch. +mkNonce :: IO Int +mkNonce = floor <$> getPOSIXTime + +-- API Parameters +query :: SimpleQuery +query = [ ( CS.pack "method", CS.pack "getinfo" ) ] + +-- Signing algorithm +sha512_blocksize_bytes :: Int +sha512_blocksize_bytes = 128 + +hmac_sha512 :: ByteString -> ByteString -> ByteString +hmac_sha512 = hmac SHA512.hash sha512_blocksize_bytes + +main :: IO () +main = do + Right apiKey <- fromJSONFile apiKeyFilename + plainReq <- parseUrl url + nonce <- mkNonce + let + postData = renderSimpleQuery False $ query ++ [ ( CS.pack "nonce", toStrict . toLazyByteString $ intDec nonce ) ] + req = plainReq + { method = methodPost + , secure = True + , requestHeaders = + [ ( CI.mk $ CS.pack "Content-Type", CS.pack "application/x-www-form-urlencoded" ) + , ( CI.mk $ CS.pack "Key", toBytes $ public apiKey ) + , ( CI.mk $ CS.pack "Sign", B16.encode $ hmac_sha512 (toBytes $ private apiKey) postData ) + , ( CI.mk $ CS.pack "User-Agent", CS.pack "Network.HTTP.Client.TLS" ) + ] + , requestBody = RequestBodyBS postData + , cookieJar = Just mempty + } + print req + print postData + withManager tlsManagerSettings $ \manager -> + withResponse req manager $ \response -> do + print $ responseStatus response + print $ responseVersion response + print $ responseHeaders response + brConsume (responseBody response) >>= putStrLn . LCS.unpack . fromChunks + print $ responseCookieJar response -- 2.11.4.GIT