{-# 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
{
RequestParams -> Bool
requestSecure :: Bool,
RequestParams -> ByteString
requestHost :: B.ByteString,
RequestParams -> Word16
requestPort :: Word16,
RequestParams -> ByteString
requestPath :: B.ByteString,
RequestParams -> Query
requestQueryString :: Query
}
deriving (Int -> RequestParams -> ShowS
[RequestParams] -> ShowS
RequestParams -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RequestParams] -> ShowS
$cshowList :: [RequestParams] -> ShowS
show :: RequestParams -> String
$cshow :: RequestParams -> String
showsPrec :: Int -> RequestParams -> ShowS
$cshowsPrec :: Int -> RequestParams -> ShowS
Show)
get ::
A.FromJSON a =>
HTTP.Client.Manager ->
RequestParams ->
IO (Either PusherError a)
get :: forall a.
FromJSON a =>
Manager -> RequestParams -> IO (Either PusherError a)
get Manager
connManager (RequestParams Bool
secure ByteString
host Word16
port ByteString
path Query
query) = do
let req :: Request
req = Bool -> ByteString -> Word16 -> ByteString -> Query -> Request
mkRequest Bool
secure ByteString
host Word16
port ByteString
path Query
query
Either PusherError ByteString
eitherBody <- Manager -> Request -> IO (Either PusherError ByteString)
doRequest Manager
connManager Request
req
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either PusherError ByteString
eitherBody of
Left PusherError
requestError -> forall a b. a -> Either a b
Left PusherError
requestError
Right ByteString
body ->
case forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode ByteString
body of
Left String
decodeError ->
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> PusherError
InvalidResponse forall a b. (a -> b) -> a -> b
$
let bodyText :: Either UnicodeException Text
bodyText = ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
body
in case Either UnicodeException Text
bodyText of
Left UnicodeException
e ->
Text
"Failed to decode body as UTF-8: "
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall e. Exception e => e -> String
displayException UnicodeException
e)
Right Text
b ->
Text
"Failed to decode response as JSON: "
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
decodeError
forall a. Semigroup a => a -> a -> a
<> Text
". Body: "
forall a. Semigroup a => a -> a -> a
<> Text -> Text
TL.toStrict Text
b
Right a
decodedBody -> forall a b. b -> Either a b
Right a
decodedBody
post ::
A.ToJSON a =>
HTTP.Client.Manager ->
RequestParams ->
a ->
IO (Either PusherError ())
post :: forall a.
ToJSON a =>
Manager -> RequestParams -> a -> IO (Either PusherError ())
post Manager
connManager (RequestParams Bool
secure ByteString
host Word16
port ByteString
path Query
query) a
body = do
let req :: Request
req = ByteString -> Request -> Request
mkPost (forall a. ToJSON a => a -> ByteString
A.encode a
body) (Bool -> ByteString -> Word16 -> ByteString -> Query -> Request
mkRequest Bool
secure ByteString
host Word16
port ByteString
path Query
query)
Either PusherError ByteString
eitherBody <- Manager -> Request -> IO (Either PusherError ByteString)
doRequest Manager
connManager Request
req
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (forall a b. b -> Either a b
Right ()) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either PusherError ByteString
eitherBody
mkRequest ::
Bool ->
B.ByteString ->
Word16 ->
B.ByteString ->
Query ->
HTTP.Client.Request
mkRequest :: Bool -> ByteString -> Word16 -> ByteString -> Query -> Request
mkRequest Bool
secure ByteString
host Word16
port ByteString
path Query
query =
Query -> Request -> Request
HTTP.Client.setQueryString Query
query forall a b. (a -> b) -> a -> b
$
Request
HTTP.Client.defaultRequest
{ secure :: Bool
HTTP.Client.secure = Bool
secure,
host :: ByteString
HTTP.Client.host = ByteString
host,
port :: Int
HTTP.Client.port = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
port,
path :: ByteString
HTTP.Client.path = ByteString
path
}
mkPost :: BL.ByteString -> HTTP.Client.Request -> HTTP.Client.Request
mkPost :: ByteString -> Request -> Request
mkPost ByteString
body Request
req =
Request
req
{ method :: ByteString
HTTP.Client.method = ByteString
methodPost,
requestHeaders :: RequestHeaders
HTTP.Client.requestHeaders = [(HeaderName
hContentType, ByteString
"application/json")],
requestBody :: RequestBody
HTTP.Client.requestBody = ByteString -> RequestBody
HTTP.Client.RequestBodyLBS ByteString
body
}
doRequest ::
HTTP.Client.Manager ->
HTTP.Client.Request ->
IO (Either PusherError BL.ByteString)
doRequest :: Manager -> Request -> IO (Either PusherError ByteString)
doRequest Manager
connManager Request
req = do
Response ByteString
response <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
HTTP.Client.httpLbs Request
req Manager
connManager
let status :: Status
status = forall body. Response body -> Status
HTTP.Client.responseStatus Response ByteString
response
let body :: ByteString
body = forall body. Response body -> body
HTTP.Client.responseBody Response ByteString
response
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
if Status -> Int
statusCode Status
status forall a. Eq a => a -> a -> Bool
== Int
200
then forall a b. b -> Either a b
Right ByteString
body
else
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
let bodyText :: Either UnicodeException Text
bodyText = ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
body
in case Either UnicodeException Text
bodyText of
Left UnicodeException
e ->
Text -> PusherError
InvalidResponse forall a b. (a -> b) -> a -> b
$
Text
"Failed to decode body as UTF-8: "
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall e. Exception e => e -> String
displayException UnicodeException
e)
Right Text
b ->
Word16 -> Text -> PusherError
Non200Response
(forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Status -> Int
statusCode Status
status)
(Text -> Text
TL.toStrict Text
b)