{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK hide #-}
module Network.Http.RequestBuilder (
RequestBuilder,
buildRequest,
buildRequest1,
http,
setHostname,
setAccept,
setAccept',
setAuthorizationBasic,
ContentType,
setContentType,
setContentLength,
setExpectContinue,
setTransferEncoding,
setHeader
) where
import Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder as Builder (fromByteString,
toByteString)
import qualified Blaze.ByteString.Builder.Char8 as Builder (fromShow,
fromString)
import Control.Applicative as App
import Control.Monad.State
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base64 as BS64
import Data.ByteString.Char8 ()
import qualified Data.ByteString.Char8 as S
import Data.Int (Int64)
import Data.List (intersperse)
import Data.Monoid as Mon (mconcat)
import Network.Http.Internal
newtype RequestBuilder α = RequestBuilder (State Request α)
deriving (forall a b. a -> RequestBuilder b -> RequestBuilder a
forall a b. (a -> b) -> RequestBuilder a -> RequestBuilder b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> RequestBuilder b -> RequestBuilder a
$c<$ :: forall a b. a -> RequestBuilder b -> RequestBuilder a
fmap :: forall a b. (a -> b) -> RequestBuilder a -> RequestBuilder b
$cfmap :: forall a b. (a -> b) -> RequestBuilder a -> RequestBuilder b
Functor, Functor RequestBuilder
forall a. a -> RequestBuilder a
forall a b.
RequestBuilder a -> RequestBuilder b -> RequestBuilder a
forall a b.
RequestBuilder a -> RequestBuilder b -> RequestBuilder b
forall a b.
RequestBuilder (a -> b) -> RequestBuilder a -> RequestBuilder b
forall a b c.
(a -> b -> c)
-> RequestBuilder a -> RequestBuilder b -> RequestBuilder c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b.
RequestBuilder a -> RequestBuilder b -> RequestBuilder a
$c<* :: forall a b.
RequestBuilder a -> RequestBuilder b -> RequestBuilder a
*> :: forall a b.
RequestBuilder a -> RequestBuilder b -> RequestBuilder b
$c*> :: forall a b.
RequestBuilder a -> RequestBuilder b -> RequestBuilder b
liftA2 :: forall a b c.
(a -> b -> c)
-> RequestBuilder a -> RequestBuilder b -> RequestBuilder c
$cliftA2 :: forall a b c.
(a -> b -> c)
-> RequestBuilder a -> RequestBuilder b -> RequestBuilder c
<*> :: forall a b.
RequestBuilder (a -> b) -> RequestBuilder a -> RequestBuilder b
$c<*> :: forall a b.
RequestBuilder (a -> b) -> RequestBuilder a -> RequestBuilder b
pure :: forall a. a -> RequestBuilder a
$cpure :: forall a. a -> RequestBuilder a
App.Applicative, Applicative RequestBuilder
forall a. a -> RequestBuilder a
forall a b.
RequestBuilder a -> RequestBuilder b -> RequestBuilder b
forall a b.
RequestBuilder a -> (a -> RequestBuilder b) -> RequestBuilder b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> RequestBuilder a
$creturn :: forall a. a -> RequestBuilder a
>> :: forall a b.
RequestBuilder a -> RequestBuilder b -> RequestBuilder b
$c>> :: forall a b.
RequestBuilder a -> RequestBuilder b -> RequestBuilder b
>>= :: forall a b.
RequestBuilder a -> (a -> RequestBuilder b) -> RequestBuilder b
$c>>= :: forall a b.
RequestBuilder a -> (a -> RequestBuilder b) -> RequestBuilder b
Monad, MonadState Request)
buildRequest1 :: RequestBuilder α -> Request
buildRequest1 :: forall α. RequestBuilder α -> Request
buildRequest1 RequestBuilder α
mm = do
let (RequestBuilder State Request α
s) = (RequestBuilder α
mm)
let q :: Request
q = Request {
qHost :: Maybe ByteString
qHost = forall a. Maybe a
Nothing,
qMethod :: Method
qMethod = Method
GET,
qPath :: ByteString
qPath = ByteString
"/",
qBody :: EntityBody
qBody = EntityBody
Empty,
qExpect :: ExpectMode
qExpect = ExpectMode
Normal,
qHeaders :: Headers
qHeaders = Headers
emptyHeaders
}
forall s a. State s a -> s -> s
execState State Request α
s Request
q
buildRequest :: Monad ν => RequestBuilder α -> ν Request
buildRequest :: forall (ν :: * -> *) α. Monad ν => RequestBuilder α -> ν Request
buildRequest = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall α. RequestBuilder α -> Request
buildRequest1
{-# INLINE buildRequest #-}
http :: Method -> ByteString -> RequestBuilder ()
http :: Method -> ByteString -> RequestBuilder ()
http Method
m ByteString
p' = do
Request
q <- forall s (m :: * -> *). MonadState s m => m s
get
let h1 :: Headers
h1 = Request -> Headers
qHeaders Request
q
let h2 :: Headers
h2 = Headers -> ByteString -> ByteString -> Headers
updateHeader Headers
h1 ByteString
"Accept-Encoding" forall a b. (a -> b) -> a -> b
$ if Bool
hasBrotli then ByteString
"br, gzip"
else ByteString
"gzip"
let e :: EntityBody
e = case Method
m of
Method
PUT -> EntityBody
Chunking
Method
POST -> EntityBody
Chunking
Method
_ -> EntityBody
Empty
let h3 :: Headers
h3 = case EntityBody
e of
EntityBody
Chunking -> Headers -> ByteString -> ByteString -> Headers
updateHeader Headers
h2 ByteString
"Transfer-Encoding" ByteString
"chunked"
EntityBody
_ -> Headers
h2
forall s (m :: * -> *). MonadState s m => s -> m ()
put Request
q {
qMethod :: Method
qMethod = Method
m,
qPath :: ByteString
qPath = ByteString
p',
qBody :: EntityBody
qBody = EntityBody
e,
qHeaders :: Headers
qHeaders = Headers
h3
}
setHostname :: Hostname -> Port -> RequestBuilder ()
setHostname :: ByteString -> Port -> RequestBuilder ()
setHostname ByteString
h' Port
p = do
Request
q <- forall s (m :: * -> *). MonadState s m => m s
get
forall s (m :: * -> *). MonadState s m => s -> m ()
put Request
q {
qHost :: Maybe ByteString
qHost = forall a. a -> Maybe a
Just ByteString
v'
}
where
v' :: ByteString
v' :: ByteString
v' = if Port
p forall a. Eq a => a -> a -> Bool
== Port
80
then ByteString
h'
else Builder -> ByteString
Builder.toByteString forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
Mon.mconcat
[ByteString -> Builder
Builder.fromByteString ByteString
h',
String -> Builder
Builder.fromString String
":",
forall a. Show a => a -> Builder
Builder.fromShow Port
p]
setHeader :: ByteString -> ByteString -> RequestBuilder ()
ByteString
k' ByteString
v' = do
Request
q <- forall s (m :: * -> *). MonadState s m => m s
get
let h0 :: Headers
h0 = Request -> Headers
qHeaders Request
q
let h1 :: Headers
h1 = Headers -> ByteString -> ByteString -> Headers
updateHeader Headers
h0 ByteString
k' ByteString
v'
forall s (m :: * -> *). MonadState s m => s -> m ()
put Request
q {
qHeaders :: Headers
qHeaders = Headers
h1
}
deleteHeader :: ByteString -> RequestBuilder ()
ByteString
k' = do
Request
q <- forall s (m :: * -> *). MonadState s m => m s
get
let h0 :: Headers
h0 = Request -> Headers
qHeaders Request
q
let h1 :: Headers
h1 = Headers -> ByteString -> Headers
removeHeader Headers
h0 ByteString
k'
forall s (m :: * -> *). MonadState s m => s -> m ()
put Request
q {
qHeaders :: Headers
qHeaders = Headers
h1
}
{-# INLINE setEntityBody #-}
setEntityBody :: EntityBody -> RequestBuilder ()
setEntityBody :: EntityBody -> RequestBuilder ()
setEntityBody EntityBody
e = do
Request
q <- forall s (m :: * -> *). MonadState s m => m s
get
forall s (m :: * -> *). MonadState s m => s -> m ()
put Request
q {
qBody :: EntityBody
qBody = EntityBody
e
}
{-# INLINE setExpectMode #-}
setExpectMode :: ExpectMode -> RequestBuilder ()
setExpectMode :: ExpectMode -> RequestBuilder ()
setExpectMode ExpectMode
e = do
Request
q <- forall s (m :: * -> *). MonadState s m => m s
get
forall s (m :: * -> *). MonadState s m => s -> m ()
put Request
q {
qExpect :: ExpectMode
qExpect = ExpectMode
e
}
setAccept :: ByteString -> RequestBuilder ()
setAccept :: ByteString -> RequestBuilder ()
setAccept ByteString
v' = do
ByteString -> ByteString -> RequestBuilder ()
setHeader ByteString
"Accept" ByteString
v'
setAccept' :: [(ByteString,Float)] -> RequestBuilder ()
setAccept' :: [(ByteString, Float)] -> RequestBuilder ()
setAccept' [(ByteString, Float)]
tqs = do
ByteString -> ByteString -> RequestBuilder ()
setHeader ByteString
"Accept" ByteString
v'
where
v' :: ByteString
v' = Builder -> ByteString
Builder.toByteString Builder
v
v :: Builder
v = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse (String -> Builder
Builder.fromString String
", ") forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Float) -> Builder
format [(ByteString, Float)]
tqs
format :: (ByteString,Float) -> Builder
format :: (ByteString, Float) -> Builder
format (ByteString
t',Float
q) =
forall a. Monoid a => [a] -> a
mconcat
[ByteString -> Builder
Builder.fromByteString ByteString
t',
String -> Builder
Builder.fromString String
"; q=",
forall a. Show a => a -> Builder
Builder.fromShow Float
q]
setAuthorizationBasic :: ByteString -> ByteString -> RequestBuilder ()
setAuthorizationBasic :: ByteString -> ByteString -> RequestBuilder ()
setAuthorizationBasic ByteString
user' ByteString
passwd' = do
ByteString -> ByteString -> RequestBuilder ()
setHeader ByteString
"Authorization" ByteString
v'
where
v' :: ByteString
v' = [ByteString] -> ByteString
S.concat [ByteString
"Basic ", ByteString
msg']
msg' :: ByteString
msg' = ByteString -> ByteString
BS64.encode ByteString
str'
str' :: ByteString
str' = [ByteString] -> ByteString
S.concat [ByteString
user', ByteString
":", ByteString
passwd']
type ContentType = ByteString
setContentType :: ContentType -> RequestBuilder ()
setContentType :: ByteString -> RequestBuilder ()
setContentType ByteString
v' = do
ByteString -> ByteString -> RequestBuilder ()
setHeader ByteString
"Content-Type" ByteString
v'
setContentLength :: Int64 -> RequestBuilder ()
setContentLength :: Int64 -> RequestBuilder ()
setContentLength Int64
n = do
ByteString -> RequestBuilder ()
deleteHeader ByteString
"Transfer-Encoding"
ByteString -> ByteString -> RequestBuilder ()
setHeader ByteString
"Content-Length" (String -> ByteString
S.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int64
n)
EntityBody -> RequestBuilder ()
setEntityBody forall a b. (a -> b) -> a -> b
$ Int64 -> EntityBody
Static Int64
n
setTransferEncoding :: RequestBuilder ()
setTransferEncoding :: RequestBuilder ()
setTransferEncoding = do
ByteString -> RequestBuilder ()
deleteHeader ByteString
"Content-Length"
EntityBody -> RequestBuilder ()
setEntityBody EntityBody
Chunking
ByteString -> ByteString -> RequestBuilder ()
setHeader ByteString
"Transfer-Encoding" ByteString
"chunked"
setExpectContinue :: RequestBuilder ()
setExpectContinue :: RequestBuilder ()
setExpectContinue = do
ByteString -> ByteString -> RequestBuilder ()
setHeader ByteString
"Expect" ByteString
"100-continue"
ExpectMode -> RequestBuilder ()
setExpectMode ExpectMode
Continue