{-# 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
(Int -> RequestParams -> ShowS)
-> (RequestParams -> String)
-> ([RequestParams] -> ShowS)
-> Show RequestParams
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 :: 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
Either PusherError a -> IO (Either PusherError a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PusherError a -> IO (Either PusherError a))
-> Either PusherError a -> IO (Either PusherError a)
forall a b. (a -> b) -> a -> b
$ case Either PusherError ByteString
eitherBody of
Left PusherError
requestError -> PusherError -> Either PusherError a
forall a b. a -> Either a b
Left PusherError
requestError
Right ByteString
body ->
case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode ByteString
body of
Left String
decodeError ->
PusherError -> Either PusherError a
forall a b. a -> Either a b
Left (PusherError -> Either PusherError a)
-> PusherError -> Either PusherError a
forall a b. (a -> b) -> a -> b
$ Text -> PusherError
InvalidResponse (Text -> PusherError) -> Text -> PusherError
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: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (UnicodeException -> String
forall e. Exception e => e -> String
displayException UnicodeException
e)
Right Text
b ->
Text
"Failed to decode response as JSON: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
decodeError
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Body: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
TL.toStrict Text
b
Right a
decodedBody -> a -> Either PusherError a
forall a b. b -> Either a b
Right a
decodedBody
post ::
A.ToJSON a =>
HTTP.Client.Manager ->
RequestParams ->
a ->
IO (Either PusherError ())
post :: 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 (a -> ByteString
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
Either PusherError () -> IO (Either PusherError ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PusherError () -> IO (Either PusherError ()))
-> Either PusherError () -> IO (Either PusherError ())
forall a b. (a -> b) -> a -> b
$ (PusherError -> Either PusherError ())
-> (ByteString -> Either PusherError ())
-> Either PusherError ByteString
-> Either PusherError ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either PusherError -> Either PusherError ()
forall a b. a -> Either a b
Left (Either PusherError () -> ByteString -> Either PusherError ()
forall a b. a -> b -> a
const (Either PusherError () -> ByteString -> Either PusherError ())
-> Either PusherError () -> ByteString -> Either PusherError ()
forall a b. (a -> b) -> a -> b
$ () -> Either PusherError ()
forall a b. b -> Either a b
Right ()) 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 (Request -> Request) -> Request -> Request
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 = Word16 -> Int
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 <- IO (Response ByteString) -> IO (Response ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> IO (Response ByteString))
-> IO (Response ByteString) -> IO (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
HTTP.Client.httpLbs Request
req Manager
connManager
let status :: Status
status = Response ByteString -> Status
forall body. Response body -> Status
HTTP.Client.responseStatus Response ByteString
response
let body :: ByteString
body = Response ByteString -> ByteString
forall body. Response body -> body
HTTP.Client.responseBody Response ByteString
response
Either PusherError ByteString -> IO (Either PusherError ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PusherError ByteString
-> IO (Either PusherError ByteString))
-> Either PusherError ByteString
-> IO (Either PusherError ByteString)
forall a b. (a -> b) -> a -> b
$
if Status -> Int
statusCode Status
status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
200
then ByteString -> Either PusherError ByteString
forall a b. b -> Either a b
Right ByteString
body
else
PusherError -> Either PusherError ByteString
forall a b. a -> Either a b
Left (PusherError -> Either PusherError ByteString)
-> PusherError -> Either PusherError ByteString
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 (Text -> PusherError) -> Text -> PusherError
forall a b. (a -> b) -> a -> b
$
Text
"Failed to decode body as UTF-8: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (UnicodeException -> String
forall e. Exception e => e -> String
displayException UnicodeException
e)
Right Text
b ->
Word16 -> Text -> PusherError
Non200Response
(Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ Status -> Int
statusCode Status
status)
(Text -> Text
TL.toStrict Text
b)