{-# 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
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 :: 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

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