Cryptsy/API/Public.hs

   1 {-# LANGUAGE ViewPatterns #-}
   2 module Cryptsy.API.Public
   3         ( CryptsyError(..), PubCryptsy
   4         , pubCryptsy
   5         )
   6 where
   7
   8 -- HTTP
   9 import Network.Browser (BrowserAction, defaultGETRequest_, request)
  10 import Network.HTTP.Base (Response(..))
  11 import Network.TCP (HandleStream)
  12
  13 -- aeson
  14 import Data.Aeson (Value(Object), json)
  15
  16 -- attoparsec
  17 import Data.Attoparsec.ByteString.Lazy (eitherResult, parse)
  18
  19 -- bytestring
  20 import qualified Data.ByteString.Lazy  as L (ByteString)
  21
  22 -- either
  23 import Control.Monad.Trans.Either (EitherT, left, right)
  24
  25 -- network
  26 import Network.URI (parseAbsoluteURI)
  27
  28 -- text
  29 import Data.Text (Text, pack)
  30
  31 -- transformers
  32 import Control.Monad.Trans (lift)
  33
  34 -- unordered-containers
  35 import qualified Data.HashMap.Strict as HM (lookup)
  36
  37 data CryptsyError = BadUrl { url :: String }
  38                   | BadResponse { response :: Response L.ByteString }
  39                   | FailParseResponse { body :: L.ByteString, message :: String }
  40                   | ErrorResponse { error :: Value }
  41                   | UnsuccessfulResponse { jsonResponse :: Value }
  42                   | FailParseReturn { value :: Value, message :: String }
  43                   deriving Show
  44
  45 type PubCryptsy = EitherT CryptsyError (BrowserAction (HandleStream L.ByteString))
  46
  47 dataKey :: Text
  48 dataKey = pack "return"
  49
  50 errMsgKey :: Text
  51 errMsgKey = pack "error"
  52
  53 pubCryptsy :: String -> PubCryptsy Value
  54 pubCryptsy apiurl = do
  55         uri <- maybe (left $ BadUrl apiurl) right $ parseAbsoluteURI apiurl
  56         let req = defaultGETRequest_ uri
  57         (_, resp) <- lift $ request req
  58         bodyBytes <- case rspCode resp of
  59                 (2, 0, 0) -> right $ rspBody resp
  60                 _         -> left $ BadResponse resp
  61         valueJSON <- either (left . FailParseResponse bodyBytes) right
  62                . eitherResult $ parse json bodyBytes
  63         case valueJSON of
  64                 Object (HM.lookup dataKey -> Just dat) -> right dat
  65                 Object (HM.lookup errMsgKey -> Just errMsg) ->
  66                         left $ ErrorResponse errMsg
  67                 _ -> left $ UnsuccessfulResponse valueJSON