{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
module Network.Pusher.Internal.HTTP
( RequestParams(..)
, RequestQueryString
, RequestBody
, get
, post
) where
import Control.Arrow (second)
import Control.Exception (displayException)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except (ExceptT(ExceptT), throwE)
import qualified Data.Aeson as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Monoid ((<>))
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8')
import qualified Network.HTTP.Client as HTTP.Client
import Network.HTTP.Types.Header (hContentType)
import Network.HTTP.Types.Method (methodPost)
import Network.HTTP.Types.Status (statusCode, statusMessage)
import Network.Pusher.Error (PusherError(..))
data RequestParams = RequestParams
{ requestEndpoint :: T.Text
, requestQueryString :: RequestQueryString
} deriving (Show)
type RequestQueryString = [(B.ByteString, B.ByteString)]
type RequestBody = A.Value
get ::
A.FromJSON a
=> HTTP.Client.Manager
-> RequestParams
-> ExceptT PusherError IO a
get connManager (RequestParams ep qs) = do
req <- ExceptT $ return $ mkRequest ep qs
resp <- doRequest connManager req
either
(throwE . PusherInvalidResponseError . T.pack)
return
(A.eitherDecode resp)
post ::
A.ToJSON a
=> HTTP.Client.Manager
-> RequestParams
-> a
-> ExceptT PusherError IO ()
post connManager (RequestParams ep qs) body = do
req <- ExceptT $ return $ mkPost (A.encode body) <$> mkRequest ep qs
_ <- doRequest connManager req
return ()
mkRequest ::
T.Text -> RequestQueryString -> Either PusherError HTTP.Client.Request
mkRequest ep qs =
case parseRequest $ T.unpack ep of
Nothing -> Left $ PusherArgumentError $ "failed to parse url: " <> ep
Just req -> Right $ HTTP.Client.setQueryString (map (second Just) qs) req
where
#if MIN_VERSION_http_client(0,4,30)
parseRequest = HTTP.Client.parseRequest
#else
parseRequest = HTTP.Client.parseUrl
#endif
mkPost :: BL.ByteString -> HTTP.Client.Request -> HTTP.Client.Request
mkPost body req =
req
{ HTTP.Client.method = methodPost
, HTTP.Client.requestHeaders = [(hContentType, "application/json")]
, HTTP.Client.requestBody = HTTP.Client.RequestBodyLBS body
}
doRequest ::
HTTP.Client.Manager
-> HTTP.Client.Request
-> ExceptT PusherError IO BL.ByteString
doRequest connManager req = do
response <- liftIO $ HTTP.Client.httpLbs req connManager
let status = HTTP.Client.responseStatus response
code = statusCode status
bodyBs :: BL.ByteString
bodyBs = HTTP.Client.responseBody response
if code `elem` [200, 202]
then return bodyBs
else let decoded = decodeUtf8' $ statusMessage status
in throwE $
either
(PusherInvalidResponseError . T.pack . displayException)
PusherNon200ResponseError
decoded