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 import Data.Functor ((<$))
   8
   9 -- aeson
  10 import Data.Aeson (Value(Object), withObject, json')
  11 import Data.Aeson.Types (Parser, parseEither)
  12
  13 -- either
  14 import Control.Monad.Trans.Either (EitherT(..), hoistEither)
  15 import Data.Either.Combinators (mapLeft)
  16
  17 -- http-client
  18 import Network.HTTP.Client
  19         ( cookieJar, parseUrl, responseBody, responseCookieJar
  20         )
  21
  22 -- pipes-attoparsec
  23 import Pipes.Attoparsec (parse)
  24
  25 -- pipes-http
  26 import Pipes.HTTP (withHTTP)
  27
  28 -- text
  29 import Data.Text (Text, pack)
  30
  31 -- transformers
  32 import Control.Monad.Trans.Reader (ReaderT(..))
  33 import Control.Monad.Trans.State (StateT(..))
  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 = ReaderT $ \manager -> do
  66         reqSansCookies <- hoistEither . mapLeft (BadURL apiurl) $ parseUrl apiurl
  67         parseResult <- EitherT . StateT $ \beforeCookies -> do
  68                 let req = reqSansCookies { cookieJar = beforeCookies }
  69                 thttp <- try . withHTTP req manager $ \resp -> do
  70                         tpr <- try . evalStateT (parse json') $ responseBody resp -- discard lo
  71                         return (tpr, responseCookieJar resp <$ beforeCookies)
  72                 return $ case thttp of
  73                  Left he -> (Left $ FailReadResponse req he, beforeCookies)
  74                  Right (Left he, nc) -> (Left $ FailReadResponse req he, nc)
  75                  Right (Right pr, nc) -> (Right pr, nc)
  76         hoistEither $ do
  77                 value <- mapLeft FailParseResponse parseResult
  78                 dat <- case value of
  79                  Object (HM.lookup dataKey -> Just d) -> Right d
  80                  Object (HM.lookup errMsgKey -> Just errMsg) ->
  81                         Left $ ErrorResponse errMsg
  82                  _ -> Left $ UnsuccessfulResponse value
  83                 mapLeft (FailParseReturn dat) $ parseEither parser dat
  84 {-# INLINABLE pubCryptsy #-}
  85
  86 -- |unpacked 'marketsKey'
  87 marketsStr :: String
  88 marketsStr = "markets"
  89
  90 -- |failure message when 'marketsKey' is missing
  91 missingMsg :: String
  92 missingMsg = "Missing '" ++ marketsStr ++ "' key."
  93
  94 -- |key in JSON object for market data
  95 marketsKey :: Text
  96 marketsKey = pack marketsStr
  97
  98 -- |Apply a parser on the 'marketsKey' of an object.  If not an object or the
  99 -- key is missing, fail.
 100 onMarkets :: (Value -> Parser a) -> Value -> Parser a
 101 onMarkets parser = withObject marketsStr $
 102         maybe (fail missingMsg) parser . HM.lookup marketsKey
 103 {-# INLINABLE onMarkets #-}