src/Main.hs

   1 {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
   2 module Main where
   3
   4 -- base
   5 import Control.Applicative ((<$>))
   6 import Control.Monad ((<=<))
   7 import Data.Data (Data)
   8 import Data.Maybe (mapMaybe)
   9 import Data.Monoid (Monoid(..))
  10 import Data.String (IsString(..))
  11 import Data.Typeable (Typeable)
  12 import GHC.Generics (Generic)
  13 import System.IO (IOMode(ReadMode), withFile)
  14
  15 -- aeson
  16 import Data.Aeson (ToJSON(..), FromJSON(..))
  17
  18 -- base16-bytestring
  19 import qualified Data.ByteString.Base16 as B16
  20
  21 -- bytestring
  22 import Data.ByteString (ByteString)
  23 -- import qualified Data.ByteString as BS
  24 import Data.ByteString.Builder (toLazyByteString, intDec)
  25 import qualified Data.ByteString.Char8 as CS
  26 import Data.ByteString.Lazy (fromChunks, toStrict)
  27 import qualified Data.ByteString.Lazy.Char8 as LCS
  28
  29 -- case-insensitive
  30 import qualified Data.CaseInsensitive as CI
  31
  32 -- cryptohash
  33 import qualified Crypto.Hash.SHA512 as SHA512
  34 import Crypto.MAC.HMAC (hmac)
  35
  36 -- deepseq
  37 import Control.DeepSeq (NFData(..))
  38
  39 -- http-client
  40 import Network.HTTP.Client
  41         ( RequestBody(RequestBodyBS)
  42         , parseUrl, method, secure, requestHeaders, requestBody, cookieJar
  43         , withManager
  44         , withResponse, responseVersion, responseStatus, responseHeaders
  45         , responseCookieJar, responseBody, brConsume
  46         )
  47
  48 -- http-client-tls
  49 import Network.HTTP.Client.TLS (tlsManagerSettings)
  50
  51 -- http-types
  52 import Network.HTTP.Types (SimpleQuery, renderSimpleQuery)
  53 import Network.HTTP.Types.Method (methodPost)
  54
  55 -- pipes-aeson
  56 import Pipes.Aeson (DecodingError)
  57 import qualified Pipes.Aeson as PA
  58
  59 -- pipes-bytestring
  60 import Pipes.ByteString (fromHandle)
  61
  62 -- text
  63 import Data.Text (Text)
  64 import qualified Data.Text as T
  65 import Data.Text.Encoding (decodeLatin1)
  66
  67 -- time
  68 import Data.Time.Clock.POSIX (getPOSIXTime)
  69
  70 -- transformers
  71 import Control.Monad.Trans.State.Strict (evalStateT)
  72
  73 -- this package
  74 -- import Cryptsy.API.Public
  75
  76 url :: String
  77 url = "https://api.cryptsy.com/api"
  78
  79 apiKeyFilename :: FilePath
  80 apiKeyFilename = "apiKey.json"
  81
  82 cryptsyMethod :: String
  83 cryptsyMethod = "getinfo"
  84
  85 data Latin1String = Latin1 { toBytes :: ByteString } deriving (Eq, Ord, Data, Typeable)
  86
  87 instance Read Latin1String where
  88         readsPrec n = mapMaybe canDecode . readsPrec n
  89          where
  90                 canDecode (txt, r) = do
  91                         thext <- completeDecode txt
  92                         return (thext, r)
  93
  94 instance Show Latin1String where
  95         showsPrec n = showsPrec n . toBytes
  96         show = show . toBytes
  97
  98 instance IsString Latin1String where
  99         fromString str = case completeDecode $ fromString str of
 100                 Just thext -> thext
 101                 Nothing -> error "Incomplete decode"
 102
 103 instance Monoid Latin1String where
 104         mempty = Latin1 { toBytes = mempty }
 105         mappend l r = Latin1 { toBytes = toBytes l `mappend` toBytes r }
 106         mconcat ths = Latin1 { toBytes = mconcat $ map toBytes ths }
 107
 108 instance NFData Latin1String where
 109         rnf = rnf . toBytes
 110
 111 decode :: Text -> (Latin1String, Text)
 112 decode txt = (Latin1 . CS.pack $ T.unpack l1c, uc)
 113  where
 114         (l1c, uc) = T.span (< toEnum 256) txt
 115
 116 completeDecode :: Monad m => Text -> m Latin1String
 117 completeDecode txt = if T.null remainder
 118         then return thext
 119         else fail "Incomplete decode."
 120  where (thext, remainder) = decode txt
 121
 122 encode :: Latin1String -> Text
 123 encode = decodeLatin1 . toBytes
 124
 125 instance ToJSON Latin1String where
 126         toJSON = toJSON . encode
 127
 128 instance FromJSON Latin1String where
 129         parseJSON = completeDecode <=< parseJSON
 130
 131 data APIKey = APIKey { public :: Latin1String, private :: Latin1String }
 132         deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)
 133
 134 instance ToJSON APIKey where
 135
 136 instance FromJSON APIKey where
 137
 138 -- TODO: Error on incomplete parse
 139 fromJSONFile :: FromJSON a => FilePath -> IO (Either DecodingError a)
 140 fromJSONFile f = withFile f ReadMode $ evalStateT PA.decode . fromHandle
 141
 142 -- Seconds since POSIX epoch.
 143 mkNonce :: IO Int
 144 mkNonce = floor <$> getPOSIXTime
 145
 146 -- API Parameters
 147 query :: SimpleQuery
 148 query = [ ( CS.pack "method", CS.pack "getinfo" ) ]
 149
 150 -- Signing algorithm
 151 sha512_blocksize_bytes :: Int
 152 sha512_blocksize_bytes = 128
 153
 154 hmac_sha512 :: ByteString -> ByteString -> ByteString
 155 hmac_sha512 = hmac SHA512.hash sha512_blocksize_bytes
 156
 157 main :: IO ()
 158 main = do
 159         Right apiKey <- fromJSONFile apiKeyFilename
 160         plainReq <- parseUrl url
 161         nonce <- mkNonce
 162         let
 163                 postData = renderSimpleQuery False $ query ++ [ ( CS.pack "nonce", toStrict . toLazyByteString $ intDec nonce ) ]
 164                 req = plainReq
 165                         { method = methodPost
 166                         , secure = True
 167                         , requestHeaders =
 168                                 [ ( CI.mk $ CS.pack "Content-Type", CS.pack "application/x-www-form-urlencoded" )
 169                                 , ( CI.mk $ CS.pack "Key", toBytes $ public apiKey )
 170                                 , ( CI.mk $ CS.pack "Sign", B16.encode $ hmac_sha512 (toBytes $ private apiKey) postData )
 171                                 , ( CI.mk $ CS.pack "User-Agent", CS.pack "Network.HTTP.Client.TLS" )
 172                                 ]
 173                         , requestBody = RequestBodyBS postData
 174                         , cookieJar = Just mempty
 175                         }
 176         print req
 177         print postData
 178         withManager tlsManagerSettings $ \manager ->
 179                 withResponse req manager $ \response -> do
 180                         print $ responseStatus response
 181                         print $ responseVersion response
 182                         print $ responseHeaders response
 183                         brConsume (responseBody response) >>= putStrLn . LCS.unpack . fromChunks
 184                         print $ responseCookieJar response