{-# LANGUAGE DatatypeContexts #-}
{-# LANGUAGE OverloadedStrings #-}

module Network.HTTP.Request
  ( Header
  , Headers
  , Method (..)
  , Request (..)
  , Response (..)
  , get
  , post
  , put
  , send
  ) where

import qualified Data.String               as S
import qualified Data.ByteString           as BS
import qualified Data.ByteString.Char8     as C
import qualified Data.ByteString.Lazy      as LBS
import qualified Data.CaseInsensitive      as CI
import qualified Data.List                 as List
import qualified Network.HTTP.Client       as LowLevelClient
import qualified Network.HTTP.Client.TLS   as LowLevelTLSClient
import qualified Network.HTTP.Types.Status as LowLevelStatus

type Header = (BS.ByteString, BS.ByteString)

type Headers = [Header]

data Method
  = DELETE
  | GET
  | HEAD
  | OPTIONS
  | PATCH
  | POST
  | PUT
  | TRACE
  | Method String

instance Show Method where
  show :: Method -> String
show Method
GET = String
"GET"
  show Method
HEAD = String
"HEAD"
  show Method
OPTIONS = String
"OPTIONS"
  show Method
PATCH = String
"PATCH"
  show Method
POST = String
"POST"
  show Method
PUT = String
"PUT"
  show Method
TRACE = String
"TRACE"
  show (Method String
method) = String
method

data (S.IsString a) => Request a = Request
  { Request a -> Method
requestMethod  :: Method
  , Request a -> String
requestUrl     :: String
  , Request a -> Headers
requestHeaders :: Headers
  , Request a -> Maybe a
requestBody    :: Maybe a
  } deriving (Int -> Request a -> ShowS
[Request a] -> ShowS
Request a -> String
(Int -> Request a -> ShowS)
-> (Request a -> String)
-> ([Request a] -> ShowS)
-> Show (Request a)
forall a. (IsString a, Show a) => Int -> Request a -> ShowS
forall a. (IsString a, Show a) => [Request a] -> ShowS
forall a. (IsString a, Show a) => Request a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Request a] -> ShowS
$cshowList :: forall a. (IsString a, Show a) => [Request a] -> ShowS
show :: Request a -> String
$cshow :: forall a. (IsString a, Show a) => Request a -> String
showsPrec :: Int -> Request a -> ShowS
$cshowsPrec :: forall a. (IsString a, Show a) => Int -> Request a -> ShowS
Show)

toLowlevelRequest :: (S.IsString a) => Request a -> IO LowLevelClient.Request
toLowlevelRequest :: Request a -> IO Request
toLowlevelRequest Request a
req = do
  Request
initReq <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
LowLevelClient.parseRequest (String -> IO Request) -> String -> IO Request
forall a b. (a -> b) -> a -> b
$ Request a -> String
forall a. IsString a => Request a -> String
requestUrl Request a
req
  Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> IO Request) -> Request -> IO Request
forall a b. (a -> b) -> a -> b
$ Request
initReq { method :: Method
LowLevelClient.method = String -> Method
C.pack (String -> Method) -> (Method -> String) -> Method -> Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> String
forall a. Show a => a -> String
show (Method -> Method) -> Method -> Method
forall a b. (a -> b) -> a -> b
$ Request a -> Method
forall a. IsString a => Request a -> Method
requestMethod Request a
req
                   , requestHeaders :: RequestHeaders
LowLevelClient.requestHeaders = ((Method, Method) -> (CI Method, Method))
-> Headers -> RequestHeaders
forall a b. (a -> b) -> [a] -> [b]
map (\(Method
k, Method
v) -> (Method -> CI Method
forall s. FoldCase s => s -> CI s
CI.mk Method
k, Method
v)) (Headers -> RequestHeaders) -> Headers -> RequestHeaders
forall a b. (a -> b) -> a -> b
$ Request a -> Headers
forall a. IsString a => Request a -> Headers
requestHeaders Request a
req
                   }

data Response = Response
  { Response -> Int
responseStatus  :: Int
  , Response -> Headers
responseHeaders :: Headers
  , Response -> Method
responseBody    :: BS.ByteString
  } deriving (Int -> Response -> ShowS
[Response] -> ShowS
Response -> String
(Int -> Response -> ShowS)
-> (Response -> String) -> ([Response] -> ShowS) -> Show Response
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Response] -> ShowS
$cshowList :: [Response] -> ShowS
show :: Response -> String
$cshow :: Response -> String
showsPrec :: Int -> Response -> ShowS
$cshowsPrec :: Int -> Response -> ShowS
Show)

fromLowLevelRequest :: LowLevelClient.Response LBS.ByteString -> Response
fromLowLevelRequest :: Response ByteString -> Response
fromLowLevelRequest Response ByteString
res =
  let status :: Int
status = Status -> Int
LowLevelStatus.statusCode (Status -> Int)
-> (Response ByteString -> Status) -> Response ByteString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response ByteString -> Status
forall body. Response body -> Status
LowLevelClient.responseStatus (Response ByteString -> Int) -> Response ByteString -> Int
forall a b. (a -> b) -> a -> b
$ Response ByteString
res
      body :: Method
body = ByteString -> Method
LBS.toStrict (ByteString -> Method) -> ByteString -> Method
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
LowLevelClient.responseBody Response ByteString
res
      headers :: RequestHeaders
headers = Response ByteString -> RequestHeaders
forall body. Response body -> RequestHeaders
LowLevelClient.responseHeaders Response ByteString
res
  in
  Int -> Headers -> Method -> Response
Response Int
status (((CI Method, Method) -> (Method, Method))
-> RequestHeaders -> Headers
forall a b. (a -> b) -> [a] -> [b]
map (\(CI Method
k,Method
v) ->
                         let hk :: Method
hk = CI Method -> Method
forall s. CI s -> s
CI.original CI Method
k
                         in
                         (Method
hk, Method
v)) RequestHeaders
headers) Method
body

getManagerForUrl :: String -> IO LowLevelClient.Manager
getManagerForUrl :: String -> IO Manager
getManagerForUrl String
url =
    if String
"https" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isPrefixOf` String
url then ManagerSettings -> IO Manager
LowLevelClient.newManager ManagerSettings
LowLevelTLSClient.tlsManagerSettings
                                     else ManagerSettings -> IO Manager
LowLevelClient.newManager ManagerSettings
LowLevelClient.defaultManagerSettings

send :: (S.IsString a) => Request a -> IO Response
send :: Request a -> IO Response
send Request a
req = do
  Manager
manager <- String -> IO Manager
getManagerForUrl (String -> IO Manager) -> String -> IO Manager
forall a b. (a -> b) -> a -> b
$ Request a -> String
forall a. IsString a => Request a -> String
requestUrl Request a
req
  Request
llreq <- Request a -> IO Request
forall a. IsString a => Request a -> IO Request
toLowlevelRequest Request a
req
  Response ByteString
llres <- Request -> Manager -> IO (Response ByteString)
LowLevelClient.httpLbs Request
llreq Manager
manager
  Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Response ByteString -> Response
fromLowLevelRequest Response ByteString
llres

get :: String -> IO Response
get :: String -> IO Response
get String
url =
  Request String -> IO Response
forall a. IsString a => Request a -> IO Response
send (Request String -> IO Response) -> Request String -> IO Response
forall a b. (a -> b) -> a -> b
$ Method -> String -> Headers -> Maybe String -> Request String
forall a. Method -> String -> Headers -> Maybe a -> Request a
Request Method
GET String
url [] Maybe String
forall a. Maybe a
Nothing

delete :: String -> IO Response
delete :: String -> IO Response
delete String
url =
  Request String -> IO Response
forall a. IsString a => Request a -> IO Response
send (Request String -> IO Response) -> Request String -> IO Response
forall a b. (a -> b) -> a -> b
$ Method -> String -> Headers -> Maybe String -> Request String
forall a. Method -> String -> Headers -> Maybe a -> Request a
Request Method
DELETE String
url [] Maybe String
forall a. Maybe a
Nothing

post :: (String, Maybe BS.ByteString) -> IO Response
post :: (String, Maybe Method) -> IO Response
post (String
url, Maybe Method
body) =
  Request Method -> IO Response
forall a. IsString a => Request a -> IO Response
send (Request Method -> IO Response) -> Request Method -> IO Response
forall a b. (a -> b) -> a -> b
$ Method -> String -> Headers -> Maybe Method -> Request Method
forall a. Method -> String -> Headers -> Maybe a -> Request a
Request Method
POST String
url [] Maybe Method
body

put :: (String, Maybe BS.ByteString) -> IO Response
put :: (String, Maybe Method) -> IO Response
put (String
url, Maybe Method
body) =
  Request Method -> IO Response
forall a. IsString a => Request a -> IO Response
send (Request Method -> IO Response) -> Request Method -> IO Response
forall a b. (a -> b) -> a -> b
$ Method -> String -> Headers -> Maybe Method -> Request Method
forall a. Method -> String -> Headers -> Maybe a -> Request a
Request Method
PUT String
url [] Maybe Method
body