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