{-# LANGUAGE FlexibleContexts #-}
module Network.Pusher.Internal.HTTP
( RequestParams (..),
get,
post,
)
where
import Control.Exception (displayException)
import Control.Monad.IO.Class (liftIO)
import qualified Data.Aeson as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Encoding (decodeUtf8')
import Data.Word (Word16)
import qualified Network.HTTP.Client as HTTP.Client
import Network.HTTP.Types (Query)
import Network.HTTP.Types.Header (hContentType)
import Network.HTTP.Types.Method (methodPost)
import Network.HTTP.Types.Status (statusCode)
import Network.Pusher.Error (PusherError (..))
data RequestParams
= RequestParams
{
requestSecure :: Bool,
requestHost :: B.ByteString,
requestPort :: Word16,
requestPath :: B.ByteString,
requestQueryString :: Query
}
deriving (Show)
get ::
A.FromJSON a =>
HTTP.Client.Manager ->
RequestParams ->
IO (Either PusherError a)
get connManager (RequestParams secure host port path query) = do
let req = mkRequest secure host port path query
eitherBody <- doRequest connManager req
return $ case eitherBody of
Left requestError -> Left requestError
Right body ->
case A.eitherDecode body of
Left decodeError ->
Left $ InvalidResponse $
let bodyText = decodeUtf8' body
in case bodyText of
Left e ->
"Failed to decode body as UTF-8: "
<> T.pack (displayException e)
Right b ->
"Failed to decode response as JSON: "
<> T.pack decodeError
<> ". Body: "
<> TL.toStrict b
Right decodedBody -> Right decodedBody
post ::
A.ToJSON a =>
HTTP.Client.Manager ->
RequestParams ->
a ->
IO (Either PusherError ())
post connManager (RequestParams secure host port path query) body = do
let req = mkPost (A.encode body) (mkRequest secure host port path query)
eitherBody <- doRequest connManager req
return $ either Left (const $ Right ()) eitherBody
mkRequest ::
Bool ->
B.ByteString ->
Word16 ->
B.ByteString ->
Query ->
HTTP.Client.Request
mkRequest secure host port path query =
HTTP.Client.setQueryString query $
HTTP.Client.defaultRequest
{ HTTP.Client.secure = secure,
HTTP.Client.host = host,
HTTP.Client.port = fromIntegral port,
HTTP.Client.path = path
}
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 ->
IO (Either PusherError BL.ByteString)
doRequest connManager req = do
response <- liftIO $ HTTP.Client.httpLbs req connManager
let status = HTTP.Client.responseStatus response
let body = HTTP.Client.responseBody response
return $
if statusCode status == 200
then Right body
else
Left $
let bodyText = decodeUtf8' body
in case bodyText of
Left e ->
InvalidResponse $
"Failed to decode body as UTF-8: "
<> T.pack (displayException e)
Right b ->
Non200Response
(fromIntegral $ statusCode status)
(TL.toStrict b)