{-# LANGUAGE OverloadedStrings #-}
module Bilge.Request
( RequestId (..),
empty,
accept,
acceptJson,
acceptProtobuf,
body,
bytes,
lbytes,
lbytesChunkedIO,
lbytesRefChunked,
lbytesRefPopper,
json,
jsonChunkedIO,
content,
contentJson,
contentProtobuf,
header,
host,
path,
paths,
port,
query,
queryItem,
queryItem',
secure,
method,
showRequest,
noRedirect,
timeout,
expect2xx,
expect3xx,
expect4xx,
expectStatus,
checkStatus,
cookie,
cookieRaw,
requestId,
requestIdName,
extHost,
extPort,
Request,
Cookie (..),
CookieJar,
RequestBody (..),
Rq.parseRequest,
Rq.applyBasicAuth,
Rq.urlEncodedBody,
Rq.getUri,
)
where
import Control.Exception
import Control.Lens
import Data.Aeson (ToJSON, encode)
import Data.ByteString (intercalate)
import Data.ByteString.Char8 qualified as C
import Data.ByteString.Lazy qualified as Lazy
import Data.ByteString.Lazy.Char8 qualified as LC
import Data.CaseInsensitive (original)
import Data.Id (RequestId (..))
import Imports hiding (intercalate)
import Network.HTTP.Client (Cookie, GivesPopper, Request, RequestBody (..))
import Network.HTTP.Client qualified as Rq
import Network.HTTP.Client.Internal (CookieJar (..), brReadSome, throwHttp)
import Network.HTTP.Types
import Network.HTTP.Types qualified as HTTP
import URI.ByteString qualified as URI
empty :: Request
empty :: Request
empty = Request
Rq.defaultRequest
host :: ByteString -> Request -> Request
host :: ByteString -> Request -> Request
host ByteString
h Request
r = Request
r {Rq.host = h}
port :: Word16 -> Request -> Request
port :: Word16 -> Request -> Request
port Word16
p Request
r = Request
r {Rq.port = fromIntegral p}
method :: StdMethod -> Request -> Request
method :: StdMethod -> Request -> Request
method StdMethod
m Request
r = Request
r {Rq.method = C.pack (show m)}
path :: ByteString -> Request -> Request
path :: ByteString -> Request -> Request
path ByteString
p Request
r = Request
r {Rq.path = p}
paths :: [ByteString] -> Request -> Request
paths :: [ByteString] -> Request -> Request
paths = ByteString -> Request -> Request
path (ByteString -> Request -> Request)
-> ([ByteString] -> ByteString)
-> [ByteString]
-> Request
-> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString] -> ByteString
intercalate ByteString
"/"
secure :: Request -> Request
secure :: Request -> Request
secure Request
r = Request
r {Rq.secure = True}
header :: HeaderName -> ByteString -> Request -> Request
HeaderName
k ByteString
v Request
r = Request
r {Rq.requestHeaders = (k, v) : Rq.requestHeaders r}
query :: Query -> Request -> Request
query :: Query -> Request -> Request
query Query
q Request
r = Request
r {Rq.queryString = HTTP.renderQuery True q}
queryItem' :: ByteString -> Maybe ByteString -> Request -> Request
queryItem' :: ByteString -> Maybe ByteString -> Request -> Request
queryItem' ByteString
k Maybe ByteString
v Request
r
| ByteString -> Bool
C.null (Request -> ByteString
Rq.queryString Request
r) = Request
r {Rq.queryString = qstr True}
| Bool
otherwise = Request
r {Rq.queryString = Rq.queryString r <> "&" <> qstr False}
where
qstr :: Bool -> ByteString
qstr Bool
b = Bool -> Query -> ByteString
HTTP.renderQuery Bool
b [(ByteString
k, Maybe ByteString
v)]
queryItem :: ByteString -> ByteString -> Request -> Request
queryItem :: ByteString -> ByteString -> Request -> Request
queryItem ByteString
k ByteString
v = ByteString -> Maybe ByteString -> Request -> Request
queryItem' ByteString
k (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
v)
body :: RequestBody -> Request -> Request
body :: RequestBody -> Request -> Request
body RequestBody
b Request
r = Request
r {Rq.requestBody = b}
timeout :: Int -> Request -> Request
timeout :: Int -> Request -> Request
timeout Int
t Request
r = Request
r {Rq.responseTimeout = Rq.responseTimeoutMicro (t * 1000)}
noRedirect :: Request -> Request
noRedirect :: Request -> Request
noRedirect Request
r = Request
r {Rq.redirectCount = 0}
expect2xx :: Request -> Request
expect2xx :: Request -> Request
expect2xx = (Int -> Bool) -> Request -> Request
expectStatus ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) (Int -> Bool) -> (Int -> Int) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100))
expect3xx :: Request -> Request
expect3xx :: Request -> Request
expect3xx = (Int -> Bool) -> Request -> Request
expectStatus ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3) (Int -> Bool) -> (Int -> Int) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100))
expect4xx :: Request -> Request
expect4xx :: Request -> Request
expect4xx = (Int -> Bool) -> Request -> Request
expectStatus ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4) (Int -> Bool) -> (Int -> Int) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100))
expectStatus :: (Int -> Bool) -> Request -> Request
expectStatus :: (Int -> Bool) -> Request -> Request
expectStatus Int -> Bool
property Request
r = Request
r {Rq.checkResponse = check}
where
check :: Request -> Response BodyReader -> IO ()
check Request
_ Response BodyReader
res
| Int -> Bool
property (Status -> Int
HTTP.statusCode (Response BodyReader -> Status
forall body. Response body -> Status
Rq.responseStatus Response BodyReader
res)) = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| Bool
otherwise = do
ByteString
some <- ByteString -> ByteString
Lazy.toStrict (ByteString -> ByteString) -> IO ByteString -> BodyReader
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BodyReader -> Int -> IO ByteString
brReadSome (Response BodyReader -> BodyReader
forall body. Response body -> body
Rq.responseBody Response BodyReader
res) Int
1024
HttpExceptionContent -> IO ()
forall a. HttpExceptionContent -> IO a
throwHttp (HttpExceptionContent -> IO ()) -> HttpExceptionContent -> IO ()
forall a b. (a -> b) -> a -> b
$ Response () -> ByteString -> HttpExceptionContent
Rq.StatusCodeException (Response BodyReader -> Response ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Response BodyReader
res) ByteString
some
checkStatus :: (Status -> ResponseHeaders -> CookieJar -> Maybe SomeException) -> Request -> Request
checkStatus :: (Status -> [Header] -> CookieJar -> Maybe SomeException)
-> Request -> Request
checkStatus Status -> [Header] -> CookieJar -> Maybe SomeException
f Request
r = Request
r {Rq.checkResponse = check}
where
check :: Request -> Response BodyReader -> IO ()
check Request
_ Response BodyReader
res = Maybe SomeException -> (SomeException -> IO Any) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Response BodyReader -> Maybe SomeException
mayThrow Response BodyReader
res) SomeException -> IO Any
forall e a. Exception e => e -> IO a
throwIO
mayThrow :: Response BodyReader -> Maybe SomeException
mayThrow Response BodyReader
res =
Status -> [Header] -> CookieJar -> Maybe SomeException
f
(Response BodyReader -> Status
forall body. Response body -> Status
Rq.responseStatus Response BodyReader
res)
(Response BodyReader -> [Header]
forall body. Response body -> [Header]
Rq.responseHeaders Response BodyReader
res)
(Response BodyReader -> CookieJar
forall body. Response body -> CookieJar
Rq.responseCookieJar Response BodyReader
res)
cookieRaw :: ByteString -> ByteString -> Request -> Request
cookieRaw :: ByteString -> ByteString -> Request -> Request
cookieRaw ByteString
k ByteString
v = HeaderName -> ByteString -> Request -> Request
header HeaderName
"Cookie" (ByteString
k ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
v)
cookie :: Cookie -> Request -> Request
cookie :: Cookie -> Request -> Request
cookie Cookie
c Request
r =
case Request -> Maybe CookieJar
Rq.cookieJar Request
r of
Maybe CookieJar
Nothing -> Request
r {Rq.cookieJar = Just (CJ [c])}
Just (CJ [Cookie]
cc) -> Request
r {Rq.cookieJar = Just (CJ (c : cc))}
requestId :: RequestId -> Request -> Request
requestId :: RequestId -> Request -> Request
requestId (RequestId ByteString
rId) = HeaderName -> ByteString -> Request -> Request
header HeaderName
requestIdName ByteString
rId
requestIdName :: HeaderName
requestIdName :: HeaderName
requestIdName = HeaderName
"Request-Id"
bytes :: ByteString -> Request -> Request
bytes :: ByteString -> Request -> Request
bytes = RequestBody -> Request -> Request
body (RequestBody -> Request -> Request)
-> (ByteString -> RequestBody) -> ByteString -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> RequestBody
RequestBodyBS
lbytes :: Lazy.ByteString -> Request -> Request
lbytes :: ByteString -> Request -> Request
lbytes = RequestBody -> Request -> Request
body (RequestBody -> Request -> Request)
-> (ByteString -> RequestBody) -> ByteString -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> RequestBody
RequestBodyLBS
json :: (ToJSON a) => a -> Request -> Request
json :: forall a. ToJSON a => a -> Request -> Request
json a
a = Request -> Request
contentJson (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Request -> Request
lbytes (a -> ByteString
forall a. ToJSON a => a -> ByteString
encode a
a)
jsonChunkedIO :: (ToJSON a, MonadIO m) => a -> m (Request -> Request)
jsonChunkedIO :: forall a (m :: * -> *).
(ToJSON a, MonadIO m) =>
a -> m (Request -> Request)
jsonChunkedIO a
a = do
(Request -> Request
contentJson .) ((Request -> Request) -> Request -> Request)
-> m (Request -> Request) -> m (Request -> Request)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> m (Request -> Request)
forall (m :: * -> *).
MonadIO m =>
ByteString -> m (Request -> Request)
lbytesChunkedIO (a -> ByteString
forall a. ToJSON a => a -> ByteString
encode a
a)
lbytesChunkedIO :: (MonadIO m) => Lazy.ByteString -> m (Request -> Request)
lbytesChunkedIO :: forall (m :: * -> *).
MonadIO m =>
ByteString -> m (Request -> Request)
lbytesChunkedIO ByteString
bs = do
IORef [ByteString]
chunksRef <- [ByteString] -> m (IORef [ByteString])
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef ([ByteString] -> m (IORef [ByteString]))
-> [ByteString] -> m (IORef [ByteString])
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
Lazy.toChunks ByteString
bs
(Request -> Request) -> m (Request -> Request)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Request -> Request) -> m (Request -> Request))
-> (Request -> Request) -> m (Request -> Request)
forall a b. (a -> b) -> a -> b
$ IORef [ByteString] -> Request -> Request
lbytesRefChunked IORef [ByteString]
chunksRef
lbytesRefChunked :: IORef [ByteString] -> Request -> Request
lbytesRefChunked :: IORef [ByteString] -> Request -> Request
lbytesRefChunked IORef [ByteString]
chunksRef =
RequestBody -> Request -> Request
body (GivesPopper () -> RequestBody
RequestBodyStreamChunked (GivesPopper () -> RequestBody) -> GivesPopper () -> RequestBody
forall a b. (a -> b) -> a -> b
$ IORef [ByteString] -> GivesPopper ()
lbytesRefPopper IORef [ByteString]
chunksRef)
lbytesRefPopper :: IORef [ByteString] -> GivesPopper ()
lbytesRefPopper :: IORef [ByteString] -> GivesPopper ()
lbytesRefPopper IORef [ByteString]
chunksRef NeedsPopper ()
needsPopper = do
let popper :: BodyReader
popper = do
IORef [ByteString]
-> ([ByteString] -> ([ByteString], ByteString)) -> BodyReader
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef IORef [ByteString]
chunksRef (([ByteString] -> ([ByteString], ByteString)) -> BodyReader)
-> ([ByteString] -> ([ByteString], ByteString)) -> BodyReader
forall a b. (a -> b) -> a -> b
$ \case
[] -> ([], ByteString
forall a. Monoid a => a
mempty)
(ByteString
c : [ByteString]
cs) -> ([ByteString]
cs, ByteString
c)
NeedsPopper ()
needsPopper BodyReader
popper
accept :: ByteString -> Request -> Request
accept :: ByteString -> Request -> Request
accept = HeaderName -> ByteString -> Request -> Request
header HeaderName
hAccept
acceptJson :: Request -> Request
acceptJson :: Request -> Request
acceptJson = ByteString -> Request -> Request
accept ByteString
"application/json"
acceptProtobuf :: Request -> Request
acceptProtobuf :: Request -> Request
acceptProtobuf = ByteString -> Request -> Request
accept ByteString
"application/x-protobuf"
content :: ByteString -> Request -> Request
content :: ByteString -> Request -> Request
content = HeaderName -> ByteString -> Request -> Request
header HeaderName
hContentType
contentJson :: Request -> Request
contentJson :: Request -> Request
contentJson = ByteString -> Request -> Request
content ByteString
"application/json"
contentProtobuf :: Request -> Request
contentProtobuf :: Request -> Request
contentProtobuf = ByteString -> Request -> Request
content ByteString
"application/x-protobuf"
showRequest :: Request -> String
showRequest :: Request -> [Char]
showRequest Request
r =
[Char] -> ShowS
showString (ByteString -> [Char]
C.unpack (ByteString -> [Char])
-> (Request -> ByteString) -> Request -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> ByteString
Rq.method (Request -> [Char]) -> Request -> [Char]
forall a b. (a -> b) -> a -> b
$ Request
r)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString (ByteString -> [Char]
C.unpack (ByteString -> [Char])
-> (Request -> ByteString) -> Request -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> ByteString
Rq.path (Request -> [Char]) -> Request -> [Char]
forall a b. (a -> b) -> a -> b
$ Request
r)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString (if Request -> Bool
Rq.secure Request
r then [Char]
" HTTPS/1.1\n" else [Char]
" HTTP/1.1\n")
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showHeaders
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
"\n\n"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showBody
ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [Char]
""
where
showHeaders :: ShowS
showHeaders = (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ([Char] -> ShowS
showString [Char]
"") ((Header -> ShowS) -> [Header] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map Header -> ShowS
showHdr (Request -> [Header]
Rq.requestHeaders Request
r))
showHdr :: Header -> ShowS
showHdr (HeaderName
k, ByteString
v) = [Char] -> ShowS
showString ([Char] -> ShowS) -> (ByteString -> [Char]) -> ByteString -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
C.unpack (ByteString -> ShowS) -> ByteString -> ShowS
forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString
forall s. CI s -> s
original HeaderName
k ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
": " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
v ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n"
showBody :: ShowS
showBody = case Request -> RequestBody
Rq.requestBody Request
r of
RequestBodyLBS ByteString
lbs -> [Char] -> ShowS
showString (ByteString -> [Char]
LC.unpack ByteString
lbs)
RequestBodyBS ByteString
bs -> [Char] -> ShowS
showString (ByteString -> [Char]
C.unpack ByteString
bs)
RequestBodyBuilder Int64
l Builder
_ -> [Char] -> ShowS
showString ([Char]
"RequestBodyBuilder<" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int64 -> [Char]
forall a. Show a => a -> [Char]
show Int64
l [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
">")
RequestBodyStream Int64
l GivesPopper ()
_ -> [Char] -> ShowS
showString ([Char]
"RequestBodyStream<" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int64 -> [Char]
forall a. Show a => a -> [Char]
show Int64
l [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
">")
RequestBodyStreamChunked GivesPopper ()
_ -> [Char] -> ShowS
showString [Char]
"RequestBodyStreamChunked"
RequestBodyIO IO RequestBody
_ -> [Char] -> ShowS
showString [Char]
"RequestBodyIO"
extHost :: URI.URI -> Maybe ByteString
extHost :: URI -> Maybe ByteString
extHost URI
u = URI
u URI
-> Getting (Maybe Authority) URI (Maybe Authority)
-> Maybe Authority
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Authority) URI (Maybe Authority)
forall a (f :: * -> *).
Functor f =>
(Maybe Authority -> f (Maybe Authority))
-> URIRef a -> f (URIRef a)
URI.authorityL Maybe Authority -> (Authority -> ByteString) -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Getting ByteString Authority ByteString -> Authority -> ByteString
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Host -> Const ByteString Host)
-> Authority -> Const ByteString Authority
Lens' Authority Host
URI.authorityHostL ((Host -> Const ByteString Host)
-> Authority -> Const ByteString Authority)
-> ((ByteString -> Const ByteString ByteString)
-> Host -> Const ByteString Host)
-> Getting ByteString Authority ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Const ByteString ByteString)
-> Host -> Const ByteString Host
Lens' Host ByteString
URI.hostBSL)
extPort :: URI.URI -> Maybe Word16
extPort :: URI -> Maybe Word16
extPort URI
u = do
Authority
a <- URI
u URI
-> Getting (Maybe Authority) URI (Maybe Authority)
-> Maybe Authority
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Authority) URI (Maybe Authority)
forall a (f :: * -> *).
Functor f =>
(Maybe Authority -> f (Maybe Authority))
-> URIRef a -> f (URIRef a)
URI.authorityL
Port
p <- Authority
a Authority
-> Getting (Maybe Port) Authority (Maybe Port) -> Maybe Port
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Port) Authority (Maybe Port)
Lens' Authority (Maybe Port)
URI.authorityPortL
Word16 -> Maybe Word16
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Port
p Port -> Getting Int Port Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Port Int
Lens' Port Int
URI.portNumberL))