src/Cryptsy/API/Public/Internal.hs

   1 {-# LANGUAGE ViewPatterns #-}
   2 -- |Implementations shared across two or more modules.
   3 module Cryptsy.API.Public.Internal where
   4
   5 -- base
   6 import Control.Exception (try)
   7
   8 -- aeson
   9 import Data.Aeson (Value(Object), withObject, json')
  10 import Data.Aeson.Types (Parser, parseEither)
  11
  12 -- either
  13 import Control.Monad.Trans.Either (EitherT(..), hoistEither, left, right)
  14 import Data.Either.Combinators (mapLeft)
  15
  16 -- http-client
  17 import Network.HTTP.Client
  18         ( parseUrl, responseBody, responseCookieJar, withManager
  19         )
  20
  21 -- http-client-tls
  22 import Network.HTTP.Client.TLS (tlsManagerSettings)
  23
  24 -- pipes-attoparsec
  25 import Pipes.Attoparsec (parse)
  26
  27 -- pipes-http
  28 import Pipes.HTTP (withHTTP)
  29
  30 -- text
  31 import Data.Text (Text, pack)
  32
  33 -- transformers
  34 import Control.Monad.Trans.State.Strict (evalStateT)
  35
  36 -- unordered-containers
  37 import qualified Data.HashMap.Strict as HM (lookup)
  38
  39 -- this package
  40 import Cryptsy.API.Public.Types.Error
  41 import Cryptsy.API.Public.Types.Monad
  42
  43 -- |generates public API URL
  44 pubURL :: String -- ^ method value
  45        -> String -- ^ complete URL
  46 pubURL = ("http://pubapi.cryptsy.com/api.php?method=" ++)
  47 {-# INLINABLE pubURL #-}
  48
  49 -- |unpacked dataKey
  50 dataStr :: String
  51 dataStr = "return"
  52
  53 -- |key in JSON object for return data
  54 dataKey :: Text
  55 dataKey = pack dataStr
  56
  57 -- |key in JSON object for error message
  58 errMsgKey :: Text
  59 errMsgKey = pack "error"
  60
  61 -- |common request implementation
  62 pubCryptsy :: String -- ^ URL
  63            -> (Value -> Parser a)
  64            -> PubCryptsy a
  65 pubCryptsy apiurl parser = EitherT . withManager tlsManagerSettings
  66                          $ \manager -> runEitherT $ do
  67         req <- hoistEither . mapLeft (BadURL apiurl) $ parseUrl apiurl
  68         (parseResult, _cookieJar) <- EitherT
  69                                   . fmap (mapLeft (FailReadResponse req))
  70                                   . try $ withHTTP req manager $ \resp -> do
  71                 pr <- evalStateT (parse json') $ responseBody resp -- discard lo
  72                 return (pr, responseCookieJar resp)
  73         value <- case parseResult of
  74          Left pe -> left $ FailParseResponse pe
  75          Right v -> right v
  76         dat <- case value of
  77          Object (HM.lookup dataKey -> Just d) -> right d
  78          Object (HM.lookup errMsgKey -> Just errMsg) ->
  79                 left $ ErrorResponse errMsg
  80          _ -> left $ UnsuccessfulResponse value
  81         hoistEither . mapLeft (FailParseReturn dat) $ parseEither parser dat
  82 {-# INLINABLE pubCryptsy #-}
  83
  84 -- |unpacked 'marketsKey'
  85 marketsStr :: String
  86 marketsStr = "markets"
  87
  88 -- |failure message when 'marketsKey' is missing
  89 missingMsg :: String
  90 missingMsg = "Missing '" ++ marketsStr ++ "' key."
  91
  92 -- |key in JSON object for market data
  93 marketsKey :: Text
  94 marketsKey = pack marketsStr
  95
  96 -- |Apply a parser on the 'marketsKey' of an object.  If not an object or the
  97 -- key is missing, fail.
  98 onMarkets :: (Value -> Parser a) -> Value -> Parser a
  99 onMarkets parser = withObject marketsStr $
 100         maybe (fail missingMsg) parser . HM.lookup marketsKey
 101 {-# INLINABLE onMarkets #-}