Internal.hs

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

-- HTTP
import Network.Browser (request)
import Network.HTTP.Base (defaultGETRequest_, rspBody, rspCode)

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

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

-- errors
import Control.Error.Util ((??))

-- network
import Network.URI (parseAbsoluteURI)

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

-- transformers
import Control.Monad.Trans.Class (lift)

-- 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 = do
	uri <- parseAbsoluteURI apiurl ?? BadURL apiurl
	let req = defaultGETRequest_ uri
	(_, resp) <- lift $ request req
	bodyBytes <- case rspCode resp of
		(2, 0, 0) -> right $ rspBody resp
		_         -> left $ BadResponse resp
	valueJSON <- hoistEither . mapLeft (FailParseResponse bodyBytes)
	           $ eitherDecode bodyBytes
	returnData <- case valueJSON of
		Object (HM.lookup dataKey -> Just dat) -> right dat
		Object (HM.lookup errMsgKey -> Just errMsg) ->
			left $ ErrorResponse errMsg
		_ -> left $ UnsuccessfulResponse valueJSON
	hoistEither . mapLeft (FailParseReturn returnData)
	            $ parseEither parser returnData
{-# 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 #-}