Internal.hs

{-# LANGUAGE ViewPatterns #-}
-- |Implementations shared across two or more modules.
module Cryptsy.API.Public.Internal where

-- base
import Control.Exception (try)
import Data.Functor ((<$))

-- aeson
import Data.Aeson (Value(Object), withObject, json')
import Data.Aeson.Types (Parser, parseEither)

-- either
import Control.Monad.Trans.Either (EitherT(..), hoistEither)
import Data.Either.Combinators (mapLeft)

-- http-client
import Network.HTTP.Client
	( cookieJar, parseUrl, responseBody, responseCookieJar
	)

-- pipes-attoparsec
import Pipes.Attoparsec (parse)

-- pipes-http
import Pipes.HTTP (withHTTP)

-- text
import Data.Text (Text, pack)

-- transformers
import Control.Monad.Trans.Reader (ReaderT(..))
import Control.Monad.Trans.State (StateT(..))
import Control.Monad.Trans.State.Strict (evalStateT)

-- unordered-containers
import qualified Data.HashMap.Strict as HM (lookup)

-- this package
import Cryptsy.API.Public.Types.Error
import Cryptsy.API.Public.Types.Monad

-- |generates public API URL
pubURL :: String -- ^ method value
       -> String -- ^ complete URL
pubURL = ("http://pubapi.cryptsy.com/api.php?method=" ++)
{-# INLINABLE pubURL #-}

-- |unpacked dataKey
dataStr :: String
dataStr = "return"

-- |key in JSON object for return data
dataKey :: Text
dataKey = pack dataStr

-- |key in JSON object for error message
errMsgKey :: Text
errMsgKey = pack "error"

-- |common request implementation
pubCryptsy :: String -- ^ URL
           -> (Value -> Parser a)
           -> PubCryptsy a
pubCryptsy apiurl parser = ReaderT $ \manager -> do
	reqSansCookies <- hoistEither . mapLeft (BadURL apiurl) $ parseUrl apiurl
	parseResult <- EitherT . StateT $ \beforeCookies -> do
		let req = reqSansCookies { cookieJar = beforeCookies }
		thttp <- try . withHTTP req manager $ \resp -> do
			tpr <- try . evalStateT (parse json') $ responseBody resp -- discard lo
			return (tpr, responseCookieJar resp <$ beforeCookies)
		return $ case thttp of
		 Left he -> (Left $ FailReadResponse req he, beforeCookies)
		 Right (Left he, nc) -> (Left $ FailReadResponse req he, nc)
		 Right (Right pr, nc) -> (Right pr, nc)
	hoistEither $ do
		value <- mapLeft FailParseResponse parseResult
		dat <- case value of
		 Object (HM.lookup dataKey -> Just d) -> Right d
		 Object (HM.lookup errMsgKey -> Just errMsg) ->
			Left $ ErrorResponse errMsg
		 _ -> Left $ UnsuccessfulResponse value
		mapLeft (FailParseReturn dat) $ parseEither parser dat
{-# INLINABLE pubCryptsy #-}

-- |unpacked 'marketsKey'
marketsStr :: String
marketsStr = "markets"

-- |failure message when 'marketsKey' is missing
missingMsg :: String
missingMsg = "Missing '" ++ marketsStr ++ "' key."

-- |key in JSON object for market data
marketsKey :: Text
marketsKey = pack marketsStr

-- |Apply a parser on the 'marketsKey' of an object.  If not an object or the
-- key is missing, fail.
onMarkets :: (Value -> Parser a) -> Value -> Parser a
onMarkets parser = withObject marketsStr $
	maybe (fail missingMsg) parser . HM.lookup marketsKey
{-# INLINABLE onMarkets #-}