--
-- HTTP types for use with io-streams and pipes
--
-- Copyright © 2012-2014 Operational Dynamics Consulting, Pty Ltd and Others
--
-- The code in this file, and the program it is a part of, is
-- made available to you by its authors as open source software:
-- you can redistribute it and/or modify it under the terms of
-- the BSD licence.
--

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

--
-- | The RequestBuilder monad allows you to abuse do-notation to
-- conveniently setup a 'Request' object.
--
newtype RequestBuilder α = RequestBuilder (State Request α)
  deriving ((forall a b. (a -> b) -> RequestBuilder a -> RequestBuilder b)
-> (forall a b. a -> RequestBuilder b -> RequestBuilder a)
-> Functor RequestBuilder
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
$cfmap :: forall a b. (a -> b) -> RequestBuilder a -> RequestBuilder b
fmap :: forall a b. (a -> b) -> RequestBuilder a -> RequestBuilder b
$c<$ :: forall a b. a -> RequestBuilder b -> RequestBuilder a
<$ :: forall a b. a -> RequestBuilder b -> RequestBuilder a
Functor, Functor RequestBuilder
Functor RequestBuilder =>
(forall a. a -> RequestBuilder a)
-> (forall a b.
    RequestBuilder (a -> b) -> RequestBuilder a -> RequestBuilder b)
-> (forall a b c.
    (a -> b -> c)
    -> RequestBuilder a -> RequestBuilder b -> RequestBuilder c)
-> (forall a b.
    RequestBuilder a -> RequestBuilder b -> RequestBuilder b)
-> (forall a b.
    RequestBuilder a -> RequestBuilder b -> RequestBuilder a)
-> Applicative 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
$cpure :: forall a. a -> RequestBuilder a
pure :: forall a. a -> RequestBuilder a
$c<*> :: forall a b.
RequestBuilder (a -> b) -> RequestBuilder a -> RequestBuilder b
<*> :: forall a b.
RequestBuilder (a -> b) -> RequestBuilder a -> RequestBuilder b
$cliftA2 :: forall a b c.
(a -> b -> c)
-> RequestBuilder a -> RequestBuilder b -> RequestBuilder c
liftA2 :: forall a b c.
(a -> b -> c)
-> RequestBuilder a -> RequestBuilder b -> RequestBuilder c
$c*> :: forall a b.
RequestBuilder a -> RequestBuilder b -> RequestBuilder b
*> :: forall a b.
RequestBuilder a -> RequestBuilder b -> RequestBuilder b
$c<* :: forall a b.
RequestBuilder a -> RequestBuilder b -> RequestBuilder a
<* :: forall a b.
RequestBuilder a -> RequestBuilder b -> RequestBuilder a
App.Applicative, Applicative RequestBuilder
Applicative RequestBuilder =>
(forall a b.
 RequestBuilder a -> (a -> RequestBuilder b) -> RequestBuilder b)
-> (forall a b.
    RequestBuilder a -> RequestBuilder b -> RequestBuilder b)
-> (forall a. a -> RequestBuilder a)
-> Monad 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
$c>>= :: forall a b.
RequestBuilder a -> (a -> RequestBuilder b) -> RequestBuilder b
>>= :: forall a b.
RequestBuilder a -> (a -> RequestBuilder b) -> RequestBuilder b
$c>> :: forall a b.
RequestBuilder a -> RequestBuilder b -> RequestBuilder b
>> :: forall a b.
RequestBuilder a -> RequestBuilder b -> RequestBuilder b
$creturn :: forall a. a -> RequestBuilder a
return :: forall a. a -> RequestBuilder a
Monad, MonadState Request)

--
-- | Run a RequestBuilder, yielding a Request object you can use on the
-- given connection.
--
-- >     let q = buildRequest1 $ do
-- >                 http POST "/api/v1/messages"
-- >                 setContentType "application/json"
-- >                 setHostname "clue.example.com" 80
-- >                 setAccept "text/html"
-- >                 setHeader "X-WhoDoneIt" "The Butler"
--
-- Obviously it's up to you to later actually /send/ JSON data.
--
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 = Maybe ByteString
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
    }
    State Request α -> Request -> Request
forall s a. State s a -> s -> s
execState State Request α
s Request
q

--
-- | Run a RequestBuilder from within a monadic action.
--
-- Older versions of this library had 'buildRequest' in IO; there's
-- no longer a need for that, but this code path will continue to
-- work for existing users.
--
-- >     q <- buildRequest $ do
-- >              http GET "/"
--
buildRequest :: Monad ν => RequestBuilder α -> ν Request
buildRequest :: forall (ν :: * -> *) α. Monad ν => RequestBuilder α -> ν Request
buildRequest = Request -> ν Request
forall a. a -> ν a
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> ν Request)
-> (RequestBuilder α -> Request) -> RequestBuilder α -> ν Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestBuilder α -> Request
forall α. RequestBuilder α -> Request
buildRequest1
{-# INLINE buildRequest #-}

--
-- | Begin constructing a Request, starting with the request line.
--
http :: Method -> ByteString -> RequestBuilder ()
http :: Method -> ByteString -> RequestBuilder ()
http Method
m ByteString
p' = do
    Request
q <- RequestBuilder Request
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" (ByteString -> Headers) -> ByteString -> Headers
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

    Request -> RequestBuilder ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Request
q {
        qMethod = m,
        qPath = p',
        qBody = e,
        qHeaders = h3
    }

--
-- | Set the [virtual] hostname for the request. In ordinary conditions
-- you won't need to call this, as the @Host:@ header is a required
-- header in HTTP 1.1 and is set directly from the name of the server
-- you connected to when calling 'Network.Http.Connection.openConnection'.
--
setHostname :: Hostname -> Port -> RequestBuilder ()
setHostname :: ByteString -> Port -> RequestBuilder ()
setHostname ByteString
h' Port
p = do
    Request
q <- RequestBuilder Request
forall s (m :: * -> *). MonadState s m => m s
get
    Request -> RequestBuilder ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Request
q {
        qHost = Just v'
    }
  where
    v' :: ByteString
    v' :: ByteString
v' = if Port
p Port -> Port -> Bool
forall a. Eq a => a -> a -> Bool
== Port
80
        then ByteString
h'
        else Builder -> ByteString
Builder.toByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
Mon.mconcat
           [ByteString -> Builder
Builder.fromByteString ByteString
h',
            String -> Builder
Builder.fromString String
":",
            Port -> Builder
forall a. Show a => a -> Builder
Builder.fromShow Port
p]

--
-- | Set a generic header to be sent in the HTTP request. The other
-- methods in the RequestBuilder API are expressed in terms of this
-- function, but we recommend you use them where offered for their
-- stronger types.
--
setHeader :: ByteString -> ByteString -> RequestBuilder ()
setHeader :: ByteString -> ByteString -> RequestBuilder ()
setHeader ByteString
k' ByteString
v' = do
    Request
q <- RequestBuilder Request
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'
    Request -> RequestBuilder ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Request
q {
        qHeaders = h1
    }

deleteHeader :: ByteString -> RequestBuilder ()
deleteHeader :: ByteString -> RequestBuilder ()
deleteHeader ByteString
k' = do
    Request
q <- RequestBuilder Request
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'
    Request -> RequestBuilder ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Request
q {
        qHeaders = h1
    }

{-# INLINE setEntityBody #-}
setEntityBody :: EntityBody -> RequestBuilder ()
setEntityBody :: EntityBody -> RequestBuilder ()
setEntityBody EntityBody
e = do
    Request
q <- RequestBuilder Request
forall s (m :: * -> *). MonadState s m => m s
get
    Request -> RequestBuilder ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Request
q {
        qBody = e
    }

{-# INLINE setExpectMode #-}
setExpectMode :: ExpectMode -> RequestBuilder ()
setExpectMode :: ExpectMode -> RequestBuilder ()
setExpectMode ExpectMode
e = do
    Request
q <- RequestBuilder Request
forall s (m :: * -> *). MonadState s m => m s
get
    Request -> RequestBuilder ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Request
q {
        qExpect = e
    }

--
-- | Indicate the content type you are willing to receive in a reply
-- from the server. For more complex @Accept:@ headers, use
-- 'setAccept''.
--
setAccept :: ByteString -> RequestBuilder ()
setAccept :: ByteString -> RequestBuilder ()
setAccept ByteString
v' = do
    ByteString -> ByteString -> RequestBuilder ()
setHeader ByteString
"Accept" ByteString
v'

--
-- | Indicate the content types you are willing to receive in a reply
-- from the server in order of preference. A call of the form:
--
-- >         setAccept' [("text/html", 1.0),
-- >                     ("application/xml", 0.8),
-- >                     ("*/*", 0)]
--
-- will result in an @Accept:@ header value of
-- @text\/html; q=1.0, application\/xml; q=0.8, \*\/\*; q=0.0@ as you
-- would expect.
--
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  = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse (String -> Builder
Builder.fromString String
", ") ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$ ((ByteString, Float) -> Builder)
-> [(ByteString, Float)] -> [Builder]
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) =
        [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
           [ByteString -> Builder
Builder.fromByteString ByteString
t',
            String -> Builder
Builder.fromString String
"; q=",
            Float -> Builder
forall a. Show a => a -> Builder
Builder.fromShow Float
q]


--
-- | Set username and password credentials per the HTTP basic
-- authentication method.
--
-- >         setAuthorizationBasic "Aladdin" "open sesame"
--
-- will result in an @Authorization:@ header value of
-- @Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==@.
--
-- Basic authentication does /not/ use a message digest function to
-- encipher the password; the above string is only base-64 encoded and
-- is thus plain-text visible to any observer on the wire and all
-- caches and servers at the other end, making basic authentication
-- completely insecure. A number of web services, however, use SSL to
-- encrypt the connection that then use HTTP basic authentication to
-- validate requests. Keep in mind in these cases the secret is still
-- sent to the servers on the other side and passes in clear through
-- all layers after the SSL termination. Do /not/ use basic
-- authentication to protect secure or user-originated privacy-sensitve
-- information.
--
{-
    This would be better using Builder, right?
-}
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


--
-- | Set the MIME type corresponding to the body of the request you are
-- sending. Defaults to @\"text\/plain\"@, so usually you need to set
-- this if 'PUT'ting.
--
setContentType :: ContentType -> RequestBuilder ()
setContentType :: ByteString -> RequestBuilder ()
setContentType ByteString
v' = do
    ByteString -> ByteString -> RequestBuilder ()
setHeader ByteString
"Content-Type" ByteString
v'

--
-- | Specify the length of the request body, in bytes.
--
-- RFC 2616 requires that we either send a @Content-Length@ header or
-- use @Transfer-Encoding: chunked@. If you know the exact size ahead
-- of time, then call this function; the body content will still be
-- streamed out by @io-streams@ in more-or-less constant space.
--
-- This function is special: in a PUT or POST request, @http-streams@
-- will assume chunked transfer-encoding /unless/ you specify a content
-- length here, in which case you need to ensure your body function
-- writes precisely that many bytes.
--
--
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 (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int64 -> String
forall a. Show a => a -> String
show Int64
n)
    EntityBody -> RequestBuilder ()
setEntityBody (EntityBody -> RequestBuilder ())
-> EntityBody -> RequestBuilder ()
forall a b. (a -> b) -> a -> b
$ Int64 -> EntityBody
Static Int64
n

--
-- | Override the default setting about how the entity body will be sent.
--
-- This function is special: this explicitly sets the @Transfer-Encoding:@
-- header to @chunked@ and will instruct the library to actually tranfer the
-- body as a stream ("chunked transfer encoding"). See 'setContentLength' for
-- forcing the opposite. You /really/ won't need this in normal operation, but
-- some people are control freaks.
--
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"


--
-- | Specify that this request should set the expectation that the
-- server needs to approve the request before you send it.
--
-- This function is special: in a PUT or POST request, @http-streams@
-- will wait for the server to reply with an HTTP/1.1 100 Continue
-- status before sending the entity body. This is handled internally;
-- you will get the real response (be it successful 2xx, client error,
-- 4xx, or server error 5xx) in 'receiveResponse'. In theory, it
-- should be 417 if the expectation failed.
--
-- Only bother with this if you know the service you're talking to
-- requires clients to send an @Expect: 100-continue@ header and will
-- handle it properly. Most servers don't do any precondition checking,
-- automatically send an intermediate 100 response, and then just read
-- the body regardless, making this a bit of a no-op in most cases.
--
setExpectContinue :: RequestBuilder ()
setExpectContinue :: RequestBuilder ()
setExpectContinue = do
    ByteString -> ByteString -> RequestBuilder ()
setHeader ByteString
"Expect" ByteString
"100-continue"
    ExpectMode -> RequestBuilder ()
setExpectMode ExpectMode
Continue