Cryptsy/API/Public/Internal.hs

   1 {-# LANGUAGE ViewPatterns #-}
   2 module Cryptsy.API.Public.Internal where
   3
   4 -- HTTP
   5 import Network.Browser (request)
   6 import Network.HTTP.Base (defaultGETRequest_, rspBody, rspCode)
   7
   8 -- aeson
   9 import Data.Aeson (Value(Object), eitherDecode, withObject)
  10 import Data.Aeson.Types (Parser, parseEither)
  11
  12 -- either
  13 import Control.Monad.Trans.Either (hoistEither, left, right)
  14 import Data.Either.Combinators (mapLeft)
  15
  16 -- errors
  17 import Control.Error.Util ((??))
  18
  19 -- network
  20 import Network.URI (parseAbsoluteURI)
  21
  22 -- text
  23 import Data.Text (Text, pack)
  24
  25 -- transformers
  26 import Control.Monad.Trans.Class (lift)
  27
  28 -- unordered-containers
  29 import qualified Data.HashMap.Strict as HM (lookup)
  30
  31 -- this package
  32 import Cryptsy.API.Public.Types.Error
  33 import Cryptsy.API.Public.Types.Monad
  34
  35 -- |generates public API URL
  36 pubURL :: String -- ^ method value
  37        -> String -- ^ complete URL
  38 pubURL = ("http://pubapi.cryptsy.com/api.php?method=" ++)
  39 {-# INLINABLE pubURL #-}
  40
  41 -- |unpacked dataKey
  42 dataStr :: String
  43 dataStr = "return"
  44 {-# INLINABLE dataStr #-}
  45
  46 -- |key in JSON object for return data
  47 dataKey :: Text
  48 dataKey = pack dataStr
  49 {-# INLINABLE dataKey #-}
  50
  51 -- |key in JSON object for error message
  52 errMsgKey :: Text
  53 errMsgKey = pack "error"
  54
  55 -- |common request implementation
  56 pubCryptsy :: String -- ^ URL
  57            -> (Value -> Parser a)
  58            -> PubCryptsy a
  59 pubCryptsy apiurl parser = do
  60         uri <- parseAbsoluteURI apiurl ?? BadURL apiurl
  61         let req = defaultGETRequest_ uri
  62         (_, resp) <- lift $ request req
  63         bodyBytes <- case rspCode resp of
  64                 (2, 0, 0) -> right $ rspBody resp
  65                 _         -> left $ BadResponse resp
  66         valueJSON <- hoistEither . mapLeft (FailParseResponse bodyBytes)
  67                    $ eitherDecode bodyBytes
  68         returnData <- case valueJSON of
  69                 Object (HM.lookup dataKey -> Just dat) -> right dat
  70                 Object (HM.lookup errMsgKey -> Just errMsg) ->
  71                         left $ ErrorResponse errMsg
  72                 _ -> left $ UnsuccessfulResponse valueJSON
  73         hoistEither . mapLeft (FailParseReturn returnData)
  74                     $ parseEither parser returnData
  75 {-# INLINABLE pubCryptsy #-}
  76
  77 -- |unpacked 'marketsKey'
  78 marketsStr :: String
  79 marketsStr = "markets"
  80 {-# INLINABLE marketsStr #-}
  81
  82 -- |failure message when 'marketsKey' is missing
  83 missingMsg :: String
  84 missingMsg = "Missing '" ++ marketsStr ++ "' key."
  85 {-# INLINABLE missingMsg #-}
  86
  87 -- |key in JSON object for market data
  88 marketsKey :: Text
  89 marketsKey = pack marketsStr
  90 {-# INLINABLE marketsKey #-}
  91
  92 -- |Apply a parser on the 'marketsKey' of an object.  If not an object or the
  93 -- key is missing, fail.
  94 onMarkets :: (Value -> Parser a) -> Value -> Parser a
  95 onMarkets parser = withObject marketsStr $
  96         maybe (fail missingMsg) parser . HM.lookup marketsKey
  97 {-# INLINABLE onMarkets #-}