{-# LANGUAGE FlexibleContexts #-}

-- |
-- Module      : Network.Pusher.Internal.HTTP
-- Description : Functions for issuing HTTP requests
-- Copyright   : (c) Will Sewell, 2016
-- Licence     : MIT
-- Maintainer  : me@willsewell.com
-- Stability   : stable
--
-- A layer on top of the HTTP functions in the http-client library which lifts
-- the return values to the typeclasses we are using in this library. Non 200
-- responses are converted into MonadError errors.
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
      { -- | The API endpoint, for example http://api.pusherapp.com/apps/123/events.
        RequestParams -> Bool
requestSecure :: Bool,
        RequestParams -> ByteString
requestHost :: B.ByteString,
        RequestParams -> Word16
requestPort :: Word16,
        RequestParams -> ByteString
requestPath :: B.ByteString,
        -- | List of query string parameters as key-value tuples.
        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)

-- | Issue an HTTP GET request. On a 200 response, the response body is returned.
--  On failure, an error will be thrown into the MonadError instance.
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

-- | Issue an HTTP POST request.
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)