{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK hide #-}
module Network.Http.RequestBuilder (
RequestBuilder,
buildRequest,
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.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 (mconcat)
import Network.Http.Internal
newtype RequestBuilder α = RequestBuilder (State Request α)
deriving (Monad, MonadState Request)
buildRequest :: RequestBuilder α -> IO Request
buildRequest mm = do
let (RequestBuilder s) = (mm)
let q = Request {
qHost = Nothing,
qMethod = GET,
qPath = "/",
qBody = Empty,
qExpect = Normal,
qHeaders = emptyHeaders
}
return $ execState s q
http :: Method -> ByteString -> RequestBuilder ()
http m p' = do
q <- get
let h1 = qHeaders q
let h2 = updateHeader h1 "Accept-Encoding" "gzip"
let e = case m of
PUT -> Chunking
POST -> Chunking
_ -> Empty
let h3 = case e of
Chunking -> updateHeader h2 "Transfer-Encoding" "chunked"
_ -> h2
put q {
qMethod = m,
qPath = p',
qBody = e,
qHeaders = h3
}
setHostname :: Hostname -> Port -> RequestBuilder ()
setHostname h' p = do
q <- get
put q {
qHost = Just v'
}
where
v' :: ByteString
v' = if p == 80
then h'
else Builder.toByteString $ mconcat
[Builder.fromByteString h',
Builder.fromString ":",
Builder.fromShow p]
setHeader :: ByteString -> ByteString -> RequestBuilder ()
setHeader k' v' = do
q <- get
let h0 = qHeaders q
let h1 = updateHeader h0 k' v'
put q {
qHeaders = h1
}
deleteHeader :: ByteString -> RequestBuilder ()
deleteHeader k' = do
q <- get
let h0 = qHeaders q
let h1 = removeHeader h0 k'
put q {
qHeaders = h1
}
{-# INLINE setEntityBody #-}
setEntityBody :: EntityBody -> RequestBuilder ()
setEntityBody e = do
q <- get
put q {
qBody = e
}
{-# INLINE setExpectMode #-}
setExpectMode :: ExpectMode -> RequestBuilder ()
setExpectMode e = do
q <- get
put q {
qExpect = e
}
setAccept :: ByteString -> RequestBuilder ()
setAccept v' = do
setHeader "Accept" v'
setAccept' :: [(ByteString,Float)] -> RequestBuilder ()
setAccept' tqs = do
setHeader "Accept" v'
where
v' = Builder.toByteString v
v = mconcat $ intersperse (Builder.fromString ", ") $ map format tqs
format :: (ByteString,Float) -> Builder
format (t',q) =
mconcat
[Builder.fromByteString t',
Builder.fromString "; q=",
Builder.fromShow q]
setAuthorizationBasic :: ByteString -> ByteString -> RequestBuilder ()
setAuthorizationBasic user' passwd' = do
setHeader "Authorization" v'
where
v' = S.concat ["Basic ", msg']
msg' = BS64.encode str'
str' = S.concat [user', ":", passwd']
type ContentType = ByteString
setContentType :: ContentType -> RequestBuilder ()
setContentType v' = do
setHeader "Content-Type" v'
setContentLength :: Int64 -> RequestBuilder ()
setContentLength n = do
deleteHeader "Transfer-Encoding"
setHeader "Content-Length" (S.pack $ show n)
setEntityBody $ Static n
setTransferEncoding :: RequestBuilder ()
setTransferEncoding = do
deleteHeader "Content-Length"
setEntityBody Chunking
setHeader "Transfer-Encoding" "chunked"
setExpectContinue :: RequestBuilder ()
setExpectContinue = do
setHeader "Expect" "100-continue"
setExpectMode Continue