{- Temporary workaround for https://ghc.haskell.org/trac/ghc/ticket/9127 -}
{-# OPTIONS_GHC -fno-warn-unused-binds  #-}

{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE Rank2Types                 #-}

module Snap.Internal.Test.RequestBuilder
  ( RequestBuilder
  , MultipartParams
  , MultipartParam(..)
  , FileData      (..)
  , RequestType   (..)
  , addHeader
  , buildRequest
  , delete
  , evalHandler
  , evalHandlerM
  , get
  , head
  , postMultipart
  , postRaw
  , postUrlEncoded
  , put
  , requestToString
  , responseToString
  , runHandler
  , runHandlerM
  , setContentType
  , setHeader
  , addCookies
  , setHttpVersion
  , setQueryString
  , setQueryStringRaw
  , setRequestPath
  , setRequestType
  , setSecure
  ) where

------------------------------------------------------------------------------
import           Control.Monad              (liftM, replicateM, void)
import           Control.Monad.State.Strict (MonadIO (..), MonadState, MonadTrans, StateT, execStateT, modify)
import qualified Control.Monad.State.Strict as State
import           Data.Bits                  (Bits ((.&.), unsafeShiftR))
import qualified Data.ByteString            as S8
import           Data.ByteString.Builder    (Builder, byteString, char8, stringUtf8, toLazyByteString, word8)
import           Data.ByteString.Char8      (ByteString)
import qualified Data.ByteString.Char8      as S
import qualified Data.ByteString.Lazy.Char8 as L
import           Data.CaseInsensitive       (CI, original)
import qualified Data.Map                   as Map
import qualified Data.Vector                as V
import           Data.Word                  (Word8)
import           Prelude                    hiding (head)
import           Snap.Core                  (Cookie (Cookie), Method (DELETE, GET, HEAD, POST, PUT), MonadSnap, Params, Request (rqContentLength, rqContextPath, rqCookies, rqHeaders, rqHostName, rqIsSecure, rqMethod, rqParams, rqPathInfo, rqPostParams, rqQueryParams, rqQueryString, rqURI, rqVersion), Response, Snap, deleteHeader, formatHttpTime, getHeader, parseUrlEncoded, printUrlEncoded, runSnap)
import           Snap.Internal.Core         (evalSnap, fixupResponse)
import           Snap.Internal.Http.Types   (Request (Request, rqBody), Response (rspBody, rspContentLength), rspBodyToEnum)
import qualified Snap.Internal.Http.Types   as H
import qualified Snap.Types.Headers         as H
import qualified System.IO.Streams          as Streams
import           System.PosixCompat.Time    (epochTime)
import           System.Random              (randomIO)
import           Text.Printf                (printf)
#if !MIN_VERSION_base(4,8,0)
import           Control.Applicative        (Applicative)
import           Data.Monoid                (Monoid (mappend, mconcat, mempty))
#endif
------------------------------------------------------------------------------


------------------------------------------------------------------------------
-- | RequestBuilder is a monad transformer that allows you to conveniently
-- build a snap 'Request' for testing.
newtype RequestBuilder m a = RequestBuilder (StateT Request m a)
  deriving ( forall a. a -> RequestBuilder m a
forall a b.
RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m a
forall a b.
RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m b
forall a b.
RequestBuilder m (a -> b)
-> RequestBuilder m a -> RequestBuilder m b
forall a b c.
(a -> b -> c)
-> RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m c
forall {m :: * -> *}. Monad m => Functor (RequestBuilder m)
forall (m :: * -> *) a. Monad m => a -> RequestBuilder m a
forall (m :: * -> *) a b.
Monad m =>
RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m a
forall (m :: * -> *) a b.
Monad m =>
RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m b
forall (m :: * -> *) a b.
Monad m =>
RequestBuilder m (a -> b)
-> RequestBuilder m a -> RequestBuilder m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m 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 m a -> RequestBuilder m b -> RequestBuilder m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m a
*> :: forall a b.
RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m b
liftA2 :: forall a b c.
(a -> b -> c)
-> RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m c
<*> :: forall a b.
RequestBuilder m (a -> b)
-> RequestBuilder m a -> RequestBuilder m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
RequestBuilder m (a -> b)
-> RequestBuilder m a -> RequestBuilder m b
pure :: forall a. a -> RequestBuilder m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> RequestBuilder m a
Applicative
           , forall a b. a -> RequestBuilder m b -> RequestBuilder m a
forall a b. (a -> b) -> RequestBuilder m a -> RequestBuilder m b
forall (m :: * -> *) a b.
Functor m =>
a -> RequestBuilder m b -> RequestBuilder m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> RequestBuilder m a -> RequestBuilder m 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 m b -> RequestBuilder m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> RequestBuilder m b -> RequestBuilder m a
fmap :: forall a b. (a -> b) -> RequestBuilder m a -> RequestBuilder m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> RequestBuilder m a -> RequestBuilder m b
Functor
           , forall a. a -> RequestBuilder m a
forall a b.
RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m b
forall a b.
RequestBuilder m a
-> (a -> RequestBuilder m b) -> RequestBuilder m b
forall (m :: * -> *). Monad m => Applicative (RequestBuilder m)
forall (m :: * -> *) a. Monad m => a -> RequestBuilder m a
forall (m :: * -> *) a b.
Monad m =>
RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m b
forall (m :: * -> *) a b.
Monad m =>
RequestBuilder m a
-> (a -> RequestBuilder m b) -> RequestBuilder m 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 m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> RequestBuilder m a
>> :: forall a b.
RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m b
>>= :: forall a b.
RequestBuilder m a
-> (a -> RequestBuilder m b) -> RequestBuilder m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
RequestBuilder m a
-> (a -> RequestBuilder m b) -> RequestBuilder m b
Monad
#if MIN_VERSION_base(4,13,0)
           , forall a. String -> RequestBuilder m a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
forall {m :: * -> *}. MonadFail m => Monad (RequestBuilder m)
forall (m :: * -> *) a. MonadFail m => String -> RequestBuilder m a
fail :: forall a. String -> RequestBuilder m a
$cfail :: forall (m :: * -> *) a. MonadFail m => String -> RequestBuilder m a
MonadFail
#endif
           , forall a. IO a -> RequestBuilder m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (RequestBuilder m)
forall (m :: * -> *) a. MonadIO m => IO a -> RequestBuilder m a
liftIO :: forall a. IO a -> RequestBuilder m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> RequestBuilder m a
MonadIO
           , MonadState Request
           , forall (m :: * -> *) a. Monad m => m a -> RequestBuilder m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: forall (m :: * -> *) a. Monad m => m a -> RequestBuilder m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> RequestBuilder m a
MonadTrans
           )


------------------------------------------------------------------------------
mkDefaultRequest :: IO Request
mkDefaultRequest :: IO Request
mkDefaultRequest = do
    InputStream ByteString
b <- forall c. [c] -> IO (InputStream c)
Streams.fromList forall a b. (a -> b) -> a -> b
$! []
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString
-> ByteString
-> Int
-> ByteString
-> Int
-> ByteString
-> Bool
-> Headers
-> InputStream ByteString
-> Maybe Word64
-> Method
-> HttpVersion
-> [Cookie]
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> Params
-> Params
-> Params
-> Request
Request ByteString
"localhost"
                     ByteString
"127.0.0.1"
                     Int
60000
                     ByteString
"127.0.0.1"
                     Int
8080
                     ByteString
"localhost"
                     Bool
False
                     Headers
H.empty
                     InputStream ByteString
b
                     forall a. Maybe a
Nothing
                     Method
GET
                     (Int
1,Int
1)
                     []
                     ByteString
""
                     ByteString
"/"
                     ByteString
"/"
                     ByteString
""
                     forall k a. Map k a
Map.empty
                     forall k a. Map k a
Map.empty
                     forall k a. Map k a
Map.empty


------------------------------------------------------------------------------
-- | Runs a 'RequestBuilder', producing the desired 'Request'.
--
-- N.B. /please/ don't use the request you get here in a real Snap application;
-- things will probably break. Don't say you weren't warned :-)
--
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> 'buildRequest' $ 'get' \"\/foo\/bar\" M.empty
-- GET \/foo\/bar HTTP\/1.1
-- host: localhost
--
-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a
-- @
buildRequest :: MonadIO m => RequestBuilder m () -> m Request
buildRequest :: forall (m :: * -> *). MonadIO m => RequestBuilder m () -> m Request
buildRequest RequestBuilder m ()
mm = do
    let (RequestBuilder StateT Request m ()
m) = (RequestBuilder m ()
mm forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RequestBuilder m ()
fixup)
    Request
rq0 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Request
mkDefaultRequest
    forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT StateT Request m ()
m Request
rq0

  where
    fixup :: RequestBuilder m ()
fixup = do
        forall (m :: * -> *). Monad m => RequestBuilder m ()
fixupURI
        RequestBuilder m ()
fixupMethod
        RequestBuilder m ()
fixupCL
        RequestBuilder m ()
fixupParams
        RequestBuilder m ()
fixupHost

    fixupMethod :: RequestBuilder m ()
fixupMethod = do
        Request
rq <- forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
        if (Request -> Method
rqMethod Request
rq forall a. Eq a => a -> a -> Bool
== Method
GET Bool -> Bool -> Bool
|| Request -> Method
rqMethod Request
rq forall a. Eq a => a -> a -> Bool
== Method
DELETE Bool -> Bool -> Bool
||
            Request -> Method
rqMethod Request
rq forall a. Eq a => a -> a -> Bool
== Method
HEAD)
          then do
              -- drain the old request body and replace it with a new one
              ![ByteString]
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. InputStream a -> IO [a]
Streams.toList forall a b. (a -> b) -> a -> b
$ Request -> InputStream ByteString
rqBody Request
rq
              !InputStream ByteString
b <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall c. [c] -> IO (InputStream c)
Streams.fromList forall a b. (a -> b) -> a -> b
$! []
              -- These requests are not permitted to have bodies
              let rq' :: Request
rq' = forall a. HasHeaders a => CI ByteString -> a -> a
deleteHeader CI ByteString
"Content-Type" forall a b. (a -> b) -> a -> b
$
                        Request
rq { rqBody :: InputStream ByteString
rqBody = InputStream ByteString
b }
              forall (m :: * -> *). Monad m => Request -> RequestBuilder m ()
rPut forall a b. (a -> b) -> a -> b
$ Request
rq' { rqContentLength :: Maybe Word64
rqContentLength = forall a. Maybe a
Nothing }
          else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ()

    fixupCL :: RequestBuilder m ()
fixupCL = do
        Request
rq <- forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *). Monad m => Request -> RequestBuilder m ()
rPut forall a b. (a -> b) -> a -> b
$ forall a. HasHeaders a => CI ByteString -> a -> a
deleteHeader CI ByteString
"Content-Length" Request
rq)
              (\Word64
cl -> forall (m :: * -> *). Monad m => Request -> RequestBuilder m ()
rPut forall a b. (a -> b) -> a -> b
$ forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
H.setHeader CI ByteString
"Content-Length"
                                         (String -> ByteString
S.pack (forall a. Show a => a -> String
show Word64
cl)) Request
rq)
              (Request -> Maybe Word64
rqContentLength Request
rq)

    fixupParams :: RequestBuilder m ()
fixupParams = do
        Request
rq <- forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
        let !query :: ByteString
query       = Request -> ByteString
rqQueryString Request
rq
        -- force the stuff from mkDefaultRequest that we just overwrite
        let !Params
_           = Request -> Params
rqPostParams Request
rq
        let !Params
_           = Request -> Params
rqParams Request
rq
        let !Params
_           = Request -> Params
rqQueryParams Request
rq
        let !queryParams :: Params
queryParams = ByteString -> Params
parseUrlEncoded ByteString
query
        let !mbCT :: Maybe ByteString
mbCT        = forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader CI ByteString
"Content-Type" Request
rq

        (!Params
postParams, Request
rq') <-
            if Maybe ByteString
mbCT forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ByteString
"application/x-www-form-urlencoded"
              then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                  ![ByteString]
l <- forall a. InputStream a -> IO [a]
Streams.toList forall a b. (a -> b) -> a -> b
$ Request -> InputStream ByteString
rqBody Request
rq
                  -- snap-server regurgitates the parsed form body
                  !InputStream ByteString
b <- forall c. [c] -> IO (InputStream c)
Streams.fromList [ByteString]
l
                  forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Params
parseUrlEncoded ([ByteString] -> ByteString
S.concat [ByteString]
l), Request
rq { rqBody :: InputStream ByteString
rqBody = InputStream ByteString
b })
              else forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Map k a
Map.empty, Request
rq)
        let !newParams :: Params
newParams = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. [a] -> [a] -> [a]
(++)) Params
queryParams Params
postParams

        forall (m :: * -> *). Monad m => Request -> RequestBuilder m ()
rPut forall a b. (a -> b) -> a -> b
$ Request
rq' { rqParams :: Params
rqParams      = Params
newParams
                   , rqPostParams :: Params
rqPostParams  = Params
postParams
                   , rqQueryParams :: Params
rqQueryParams = Params
queryParams }

    fixupHost :: RequestBuilder m ()
fixupHost = do
        Request
rq <- forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
        case forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
H.getHeader CI ByteString
"Host" Request
rq of
          Maybe ByteString
Nothing -> do
            let !hn :: ByteString
hn = Request -> ByteString
rqHostName Request
rq
            forall (m :: * -> *). Monad m => Request -> RequestBuilder m ()
rPut forall a b. (a -> b) -> a -> b
$ forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
H.setHeader CI ByteString
"Host" ByteString
hn Request
rq
          Just ByteString
hn ->
            forall (m :: * -> *). Monad m => Request -> RequestBuilder m ()
rPut forall a b. (a -> b) -> a -> b
$ Request
rq { rqHostName :: ByteString
rqHostName = ByteString
hn }


------------------------------------------------------------------------------
-- | A request body of type \"@multipart/form-data@\" consists of a set of
-- named form parameters, each of which can by either a list of regular form
-- values or a set of file uploads.
type MultipartParams = [(ByteString, MultipartParam)]


------------------------------------------------------------------------------
-- | A single \"@multipart/form-data@\" form parameter: either a list of regular
-- form values or a set of file uploads.
data MultipartParam =
    FormData [ByteString]
        -- ^ a form variable consisting of the given 'ByteString' values.
  | Files [FileData]
        -- ^ a file upload consisting of the given 'FileData' values.
  deriving (Int -> MultipartParam -> ShowS
[MultipartParam] -> ShowS
MultipartParam -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MultipartParam] -> ShowS
$cshowList :: [MultipartParam] -> ShowS
show :: MultipartParam -> String
$cshow :: MultipartParam -> String
showsPrec :: Int -> MultipartParam -> ShowS
$cshowsPrec :: Int -> MultipartParam -> ShowS
Show)


------------------------------------------------------------------------------
-- | Represents a single file upload for the 'MultipartParam'.
data FileData = FileData {
      FileData -> ByteString
fdFileName    :: ByteString  -- ^ the file's name
    , FileData -> ByteString
fdContentType :: ByteString  -- ^ the file's content-type
    , FileData -> ByteString
fdContents    :: ByteString  -- ^ the file contents
    }
  deriving (Int -> FileData -> ShowS
[FileData] -> ShowS
FileData -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FileData] -> ShowS
$cshowList :: [FileData] -> ShowS
show :: FileData -> String
$cshow :: FileData -> String
showsPrec :: Int -> FileData -> ShowS
$cshowsPrec :: Int -> FileData -> ShowS
Show)


------------------------------------------------------------------------------
-- | The 'RequestType' datatype enumerates the different kinds of HTTP
-- requests you can generate using the testing interface. Most users will
-- prefer to use the 'get', 'postUrlEncoded', 'postMultipart', 'put', and
-- 'delete' convenience functions.
data RequestType
    = GetRequest
    | RequestWithRawBody Method ByteString
    | MultipartPostRequest MultipartParams
    | UrlEncodedPostRequest Params
    | DeleteRequest
    deriving (Int -> RequestType -> ShowS
[RequestType] -> ShowS
RequestType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RequestType] -> ShowS
$cshowList :: [RequestType] -> ShowS
show :: RequestType -> String
$cshow :: RequestType -> String
showsPrec :: Int -> RequestType -> ShowS
$cshowsPrec :: Int -> RequestType -> ShowS
Show)


------------------------------------------------------------------------------
-- | Sets the type of the 'Request' being built.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> 'buildRequest' $ 'delete' \"\/foo\/bar\" M.empty >> 'setRequestType' GetRequest
-- GET \/foo\/bar HTTP\/1.1
-- host: localhost
--
-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a
-- @
setRequestType :: MonadIO m => RequestType -> RequestBuilder m ()
setRequestType :: forall (m :: * -> *).
MonadIO m =>
RequestType -> RequestBuilder m ()
setRequestType RequestType
GetRequest = do
    Request
rq   <- forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
    InputStream ByteString
body <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall c. [c] -> IO (InputStream c)
Streams.fromList forall a b. (a -> b) -> a -> b
$! []

    forall (m :: * -> *). Monad m => Request -> RequestBuilder m ()
rPut forall a b. (a -> b) -> a -> b
$ Request
rq { rqMethod :: Method
rqMethod        = Method
GET
              , rqContentLength :: Maybe Word64
rqContentLength = forall a. Maybe a
Nothing
              , rqBody :: InputStream ByteString
rqBody          = InputStream ByteString
body
              }

setRequestType RequestType
DeleteRequest = do
    Request
rq   <- forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
    InputStream ByteString
body <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall c. [c] -> IO (InputStream c)
Streams.fromList forall a b. (a -> b) -> a -> b
$! []

    forall (m :: * -> *). Monad m => Request -> RequestBuilder m ()
rPut forall a b. (a -> b) -> a -> b
$ Request
rq { rqMethod :: Method
rqMethod        = Method
DELETE
              , rqContentLength :: Maybe Word64
rqContentLength = forall a. Maybe a
Nothing
              , rqBody :: InputStream ByteString
rqBody          = InputStream ByteString
body
              }

setRequestType (RequestWithRawBody Method
m ByteString
b) = do
    Request
rq <- forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
    InputStream ByteString
body <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall c. [c] -> IO (InputStream c)
Streams.fromList forall a b. (a -> b) -> a -> b
$! [ ByteString
b ]
    forall (m :: * -> *). Monad m => Request -> RequestBuilder m ()
rPut forall a b. (a -> b) -> a -> b
$ Request
rq { rqMethod :: Method
rqMethod        = Method
m
              , rqContentLength :: Maybe Word64
rqContentLength = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
S.length ByteString
b
              , rqBody :: InputStream ByteString
rqBody          = InputStream ByteString
body
              }

setRequestType (MultipartPostRequest MultipartParams
fp) = forall (m :: * -> *).
MonadIO m =>
MultipartParams -> RequestBuilder m ()
encodeMultipart MultipartParams
fp

setRequestType (UrlEncodedPostRequest Params
fp) = do
    Request
rq <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
H.setHeader CI ByteString
"Content-Type"
                             ByteString
"application/x-www-form-urlencoded") forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
    let b :: ByteString
b = Params -> ByteString
printUrlEncoded Params
fp
    InputStream ByteString
body <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall c. [c] -> IO (InputStream c)
Streams.fromList forall a b. (a -> b) -> a -> b
$! [ByteString
b]

    forall (m :: * -> *). Monad m => Request -> RequestBuilder m ()
rPut forall a b. (a -> b) -> a -> b
$ Request
rq { rqMethod :: Method
rqMethod        = Method
POST
              , rqContentLength :: Maybe Word64
rqContentLength = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$!  forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
S.length ByteString
b
              , rqBody :: InputStream ByteString
rqBody          = InputStream ByteString
body
              }


------------------------------------------------------------------------------
makeBoundary :: MonadIO m => m ByteString
makeBoundary :: forall (m :: * -> *). MonadIO m => m ByteString
makeBoundary = do
    [Word8]
xs  <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
16 IO Word8
randomWord8
    let x :: ByteString
x = String -> ByteString
S.pack forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum) [Word8]
xs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S.concat [ ByteString
"snap-boundary-", ByteString -> ByteString
encode ByteString
x ]

  where
    randomWord8 :: IO Word8
    randomWord8 :: IO Word8
randomWord8 = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\Int
c -> forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ Int
c forall a. Bits a => a -> a -> a
.&. Int
0xff) forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO

    table :: Vector Char
table = forall a. [a] -> Vector a
V.fromList [ Char
'0', Char
'1', Char
'2', Char
'3', Char
'4', Char
'5', Char
'6', Char
'7', Char
'8', Char
'9'
                       , Char
'a', Char
'b', Char
'c', Char
'd', Char
'e', Char
'f' ]

    encode :: ByteString -> ByteString
encode = Builder -> ByteString
toByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Word8 -> a) -> a -> ByteString -> a
S8.foldl' Builder -> Word8 -> Builder
f forall a. Monoid a => a
mempty

#if MIN_VERSION_base(4,5,0)
    shR :: Word8 -> Int -> Word8
shR = forall a. Bits a => a -> Int -> a
unsafeShiftR
#else
    shR = shiftR
#endif

    f :: Builder -> Word8 -> Builder
f Builder
m Word8
c = let low :: Word8
low = Word8
c forall a. Bits a => a -> a -> a
.&. Word8
0xf
                hi :: Word8
hi  = (Word8
c forall a. Bits a => a -> a -> a
.&. Word8
0xf0) Word8 -> Int -> Word8
`shR` Int
4
                k :: Word8 -> Builder
k   = \Word8
i -> Word8 -> Builder
word8 forall a b. (a -> b) -> a -> b
$! forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$! forall a. Enum a => a -> Int
fromEnum forall a b. (a -> b) -> a -> b
$!
                            forall a. Vector a -> Int -> a
V.unsafeIndex Vector Char
table (forall a. Enum a => a -> Int
fromEnum Word8
i)
            in Builder
m forall a. Monoid a => a -> a -> a
`mappend` Word8 -> Builder
k Word8
hi forall a. Monoid a => a -> a -> a
`mappend` Word8 -> Builder
k Word8
low


------------------------------------------------------------------------------
multipartHeader :: ByteString -> ByteString -> Builder
multipartHeader :: ByteString -> ByteString -> Builder
multipartHeader ByteString
boundary ByteString
name =
    forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Builder
byteString ByteString
boundary
            , ByteString -> Builder
byteString ByteString
"\r\ncontent-disposition: form-data"
            , ByteString -> Builder
byteString ByteString
"; name=\""
            , ByteString -> Builder
byteString ByteString
name
            , ByteString -> Builder
byteString ByteString
"\"\r\n" ]


------------------------------------------------------------------------------
-- Assume initial or preceding "--" just before this
encodeFormData :: ByteString -> ByteString -> [ByteString] -> IO Builder
encodeFormData :: ByteString -> ByteString -> [ByteString] -> IO Builder
encodeFormData ByteString
boundary ByteString
name [ByteString]
vals =
    case [ByteString]
vals of
      []  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
      [ByteString
v] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [ Builder
hdr
                              , Builder
cr
                              , ByteString -> Builder
byteString ByteString
v
                              , ByteString -> Builder
byteString ByteString
"\r\n--" ]
      [ByteString]
_   -> IO Builder
multi

  where
    hdr :: Builder
hdr = ByteString -> ByteString -> Builder
multipartHeader ByteString
boundary ByteString
name
    cr :: Builder
cr = ByteString -> Builder
byteString ByteString
"\r\n"

    oneVal :: ByteString -> ByteString -> Builder
oneVal ByteString
b ByteString
v = forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Builder
byteString ByteString
b
                         , Builder
cr
                         , Builder
cr
                         , ByteString -> Builder
byteString ByteString
v
                         , ByteString -> Builder
byteString ByteString
"\r\n--" ]

    multi :: IO Builder
multi = do
        ByteString
b <- forall (m :: * -> *). MonadIO m => m ByteString
makeBoundary
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [ Builder
hdr
                         , ByteString -> Builder
multipartMixed ByteString
b
                         , Builder
cr
                         , ByteString -> Builder
byteString ByteString
"--"
                         , forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> ByteString -> Builder
oneVal ByteString
b) [ByteString]
vals)
                         , ByteString -> Builder
byteString ByteString
b
                         , ByteString -> Builder
byteString ByteString
"--\r\n--" ]


------------------------------------------------------------------------------
multipartMixed :: ByteString -> Builder
multipartMixed :: ByteString -> Builder
multipartMixed ByteString
b = forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Builder
byteString ByteString
"Content-Type: multipart/mixed"
                           , ByteString -> Builder
byteString ByteString
"; boundary="
                           , ByteString -> Builder
byteString ByteString
b
                           , ByteString -> Builder
byteString ByteString
"\r\n" ]


------------------------------------------------------------------------------
encodeFiles :: ByteString -> ByteString -> [FileData] -> IO Builder
encodeFiles :: ByteString -> ByteString -> [FileData] -> IO Builder
encodeFiles ByteString
boundary ByteString
name [FileData]
files =
    case [FileData]
files of
      [] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
      [FileData]
_  -> do
          ByteString
b <- forall (m :: * -> *). MonadIO m => m ByteString
makeBoundary
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [ Builder
hdr
                           , ByteString -> Builder
multipartMixed ByteString
b
                           , Builder
cr
                           , ByteString -> Builder
byteString ByteString
"--"
                           , forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> FileData -> Builder
oneVal ByteString
b) [FileData]
files)
                           , ByteString -> Builder
byteString ByteString
b
                           , ByteString -> Builder
byteString ByteString
"--\r\n--"
                           ]

  where
    --------------------------------------------------------------------------
    contentDisposition :: ByteString -> Builder
contentDisposition ByteString
fn = forall a. Monoid a => [a] -> a
mconcat [
                              ByteString -> Builder
byteString ByteString
"Content-Disposition: attachment"
                            , ByteString -> Builder
byteString ByteString
"; filename=\""
                            , ByteString -> Builder
byteString ByteString
fn
                            , ByteString -> Builder
byteString ByteString
"\"\r\n"
                            ]

    --------------------------------------------------------------------------
    contentType :: ByteString -> Builder
contentType ByteString
ct = forall a. Monoid a => [a] -> a
mconcat [
                       ByteString -> Builder
byteString ByteString
"Content-Type: "
                     , ByteString -> Builder
byteString ByteString
ct
                     , Builder
cr
                     ]

    --------------------------------------------------------------------------
    oneVal :: ByteString -> FileData -> Builder
oneVal ByteString
b FileData
fd =
        forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Builder
byteString ByteString
b
                , Builder
cr
                , ByteString -> Builder
contentType ByteString
ct
                , ByteString -> Builder
contentDisposition ByteString
fileName
                , ByteString -> Builder
byteString ByteString
"Content-Transfer-Encoding: binary\r\n"
                , Builder
cr
                , ByteString -> Builder
byteString ByteString
contents
                , ByteString -> Builder
byteString ByteString
"\r\n--"
                ]
      where
        fileName :: ByteString
fileName = FileData -> ByteString
fdFileName FileData
fd
        ct :: ByteString
ct       = FileData -> ByteString
fdContentType FileData
fd
        contents :: ByteString
contents = FileData -> ByteString
fdContents FileData
fd

    --------------------------------------------------------------------------
    hdr :: Builder
hdr = ByteString -> ByteString -> Builder
multipartHeader ByteString
boundary ByteString
name
    cr :: Builder
cr  = ByteString -> Builder
byteString ByteString
"\r\n"


------------------------------------------------------------------------------
encodeMultipart :: MonadIO m => MultipartParams -> RequestBuilder m ()
encodeMultipart :: forall (m :: * -> *).
MonadIO m =>
MultipartParams -> RequestBuilder m ()
encodeMultipart MultipartParams
kvps = do
    ByteString
boundary <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => m ByteString
makeBoundary
    [Builder]
builders <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ByteString -> (ByteString, MultipartParam) -> IO Builder
handleOne ByteString
boundary) MultipartParams
kvps

    let b :: ByteString
b = Builder -> ByteString
toByteString forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat (ByteString -> Builder
byteString ByteString
"--" forall a. a -> [a] -> [a]
: [Builder]
builders)
                             forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
finalBoundary ByteString
boundary

    Request
rq0 <- forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet

    InputStream ByteString
body <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall c. [c] -> IO (InputStream c)
Streams.fromList [ByteString
b]

    let rq :: Request
rq = forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
H.setHeader CI ByteString
"Content-Type"
               (ByteString -> ByteString -> ByteString
S.append ByteString
"multipart/form-data; boundary=" ByteString
boundary)
               Request
rq0

    forall (m :: * -> *). Monad m => Request -> RequestBuilder m ()
rPut forall a b. (a -> b) -> a -> b
$ Request
rq { rqMethod :: Method
rqMethod        = Method
POST
              , rqContentLength :: Maybe Word64
rqContentLength = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
S.length ByteString
b
              , rqBody :: InputStream ByteString
rqBody          = InputStream ByteString
body
              }


  where
    finalBoundary :: ByteString -> Builder
finalBoundary ByteString
b = forall a. Monoid a => [a] -> a
mconcat [ByteString -> Builder
byteString ByteString
b, ByteString -> Builder
byteString ByteString
"--\r\n"]

    handleOne :: ByteString -> (ByteString, MultipartParam) -> IO Builder
handleOne ByteString
boundary (ByteString
name, MultipartParam
mp) =
        case MultipartParam
mp of
          (FormData [ByteString]
vals) -> ByteString -> ByteString -> [ByteString] -> IO Builder
encodeFormData ByteString
boundary ByteString
name [ByteString]
vals
          (Files [FileData]
fs)      -> ByteString -> ByteString -> [FileData] -> IO Builder
encodeFiles ByteString
boundary ByteString
name [FileData]
fs


------------------------------------------------------------------------------
fixupURI :: Monad m => RequestBuilder m ()
fixupURI :: forall (m :: * -> *). Monad m => RequestBuilder m ()
fixupURI = do
    Request
rq <- forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
    forall {m :: * -> *}.
Monad m =>
Request -> ByteString -> RequestBuilder m ()
upd Request
rq forall a b. (a -> b) -> a -> b
$! [ByteString] -> ByteString
S.concat [ Request -> ByteString
rqContextPath Request
rq
                       , Request -> ByteString
rqPathInfo Request
rq
                       , let q :: ByteString
q = Request -> ByteString
rqQueryString Request
rq
                         in if ByteString -> Bool
S.null ByteString
q
                              then ByteString
""
                              else ByteString -> ByteString -> ByteString
S.append ByteString
"?" ByteString
q
                       ]
  where
    upd :: Request -> ByteString -> RequestBuilder m ()
upd Request
rq !ByteString
u = let !ByteString
_ = Request -> ByteString
rqURI Request
rq
                in forall (m :: * -> *). Monad m => Request -> RequestBuilder m ()
rPut forall a b. (a -> b) -> a -> b
$ Request
rq { rqURI :: ByteString
rqURI = ByteString
u }


------------------------------------------------------------------------------
-- | Sets the request's query string to be the raw bytestring provided,
-- without any escaping or other interpretation. Most users should instead
-- choose the 'setQueryString' function, which takes a parameter mapping.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> 'buildRequest' $ 'get' \"\/foo\/bar\" M.empty >> 'setQueryStringRaw' "param0=baz&param1=qux"
-- GET \/foo\/bar?param0=baz&param1=qux HTTP\/1.1
-- host: localhost
--
-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a
-- params: param0: ["baz"], param1: ["qux"]
-- @
setQueryStringRaw :: Monad m => ByteString -> RequestBuilder m ()
setQueryStringRaw :: forall (m :: * -> *). Monad m => ByteString -> RequestBuilder m ()
setQueryStringRaw ByteString
r = do
    Request
rq <- forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
    forall (m :: * -> *). Monad m => Request -> RequestBuilder m ()
rPut forall a b. (a -> b) -> a -> b
$ Request
rq { rqQueryString :: ByteString
rqQueryString = ByteString
r }
    forall (m :: * -> *). Monad m => RequestBuilder m ()
fixupURI


------------------------------------------------------------------------------
-- | Escapes the given parameter mapping and sets it as the request's query
-- string.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> 'buildRequest' $ 'get' \"\/foo\/bar\" M.empty >> 'setQueryString' (M.fromList [("param0", ["baz"]), ("param1", ["qux"])])
-- GET \/foo\/bar?param0=baz&param1=qux HTTP\/1.1
-- host: localhost
--
-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a
-- params: param0: ["baz"], param1: ["qux"]
-- @
setQueryString :: Monad m => Params -> RequestBuilder m ()
setQueryString :: forall (m :: * -> *). Monad m => Params -> RequestBuilder m ()
setQueryString Params
p = forall (m :: * -> *). Monad m => ByteString -> RequestBuilder m ()
setQueryStringRaw forall a b. (a -> b) -> a -> b
$ Params -> ByteString
printUrlEncoded Params
p


------------------------------------------------------------------------------
-- | Sets the given header in the request being built, overwriting any header
-- with the same name already present.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> :{
-- ghci| 'buildRequest' $ do get \"\/foo\/bar\" M.empty
-- ghci|                   'setHeader' \"Accept\" "text\/html"
-- ghci|                   'setHeader' \"Accept\" "text\/plain"
-- ghci| :}
-- GET \/foo\/bar HTTP\/1.1
-- accept: text\/plain
-- host: localhost
--
-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a
-- @
setHeader :: (Monad m) => CI ByteString -> ByteString -> RequestBuilder m ()
setHeader :: forall (m :: * -> *).
Monad m =>
CI ByteString -> ByteString -> RequestBuilder m ()
setHeader CI ByteString
k ByteString
v = forall (m :: * -> *).
Monad m =>
(Request -> Request) -> RequestBuilder m ()
rModify (forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
H.setHeader CI ByteString
k ByteString
v)


------------------------------------------------------------------------------
-- | Adds the given header to the request being built.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> :{
-- ghci| 'buildRequest' $ do 'get' \"\/foo\/bar\" M.empty
-- ghci|                   'addHeader' \"Accept\" "text\/html"
-- ghci|                   'addHeader' \"Accept\" "text\/plain"
-- ghci| :}
-- GET \/foo\/bar HTTP\/1.1
-- accept: text\/html,text\/plain
-- host: localhost
--
-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a
-- @
addHeader :: (Monad m) => CI ByteString -> ByteString -> RequestBuilder m ()
addHeader :: forall (m :: * -> *).
Monad m =>
CI ByteString -> ByteString -> RequestBuilder m ()
addHeader CI ByteString
k ByteString
v = forall (m :: * -> *).
Monad m =>
(Request -> Request) -> RequestBuilder m ()
rModify (forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
H.addHeader CI ByteString
k ByteString
v)

------------------------------------------------------------------------------
-- | Adds the given cookies to the request being built.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import "Snap.Core"
-- ghci> let cookie = 'Snap.Core.Cookie' "name" "value" Nothing Nothing Nothing False False
-- ghci> 'buildRequest' $ 'get' \"\/foo\/bar\" M.empty >> 'addCookies' [cookie]
-- GET \/foo\/bar HTTP\/1.1
-- cookie: name=value
-- host: localhost
--
-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a
-- cookies: Cookie {cookieName = "name", cookieValue = "value", ...}
-- @
addCookies :: (Monad m) => [Cookie] -> RequestBuilder m ()
addCookies :: forall (m :: * -> *). Monad m => [Cookie] -> RequestBuilder m ()
addCookies [Cookie]
cookies = do
    forall (m :: * -> *).
Monad m =>
(Request -> Request) -> RequestBuilder m ()
rModify forall a b. (a -> b) -> a -> b
$ \Request
rq -> Request
rq { rqCookies :: [Cookie]
rqCookies = Request -> [Cookie]
rqCookies Request
rq forall a. [a] -> [a] -> [a]
++ [Cookie]
cookies }
    [Cookie]
allCookies <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Request -> [Cookie]
rqCookies forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
    let cstr :: [ByteString]
cstr = forall a b. (a -> b) -> [a] -> [b]
map Cookie -> ByteString
cookieToBS [Cookie]
allCookies
    forall (m :: * -> *).
Monad m =>
CI ByteString -> ByteString -> RequestBuilder m ()
setHeader CI ByteString
"Cookie" forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString] -> ByteString
S.intercalate ByteString
"; " [ByteString]
cstr


------------------------------------------------------------------------------
-- | Convert 'Cookie' into 'ByteString' for output.
cookieToBS :: Cookie -> ByteString
cookieToBS :: Cookie -> ByteString
cookieToBS (Cookie ByteString
k ByteString
v !Maybe UTCTime
_ !Maybe ByteString
_ !Maybe ByteString
_ !Bool
_ !Bool
_) = ByteString
cookie
  where
    cookie :: ByteString
cookie  = [ByteString] -> ByteString
S.concat [ByteString
k, ByteString
"=", ByteString
v]


------------------------------------------------------------------------------
-- | Sets the request's @content-type@ to the given MIME type.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> 'buildRequest' $ 'put' \"\/foo\/bar\" "text\/html" "some text" >> 'setContentType' "text\/plain"
-- PUT \/foo\/bar HTTP\/1.1
-- content-type: text\/plain
-- content-length: 9
-- host: localhost
--
-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=9
-- @
setContentType :: Monad m => ByteString -> RequestBuilder m ()
setContentType :: forall (m :: * -> *). Monad m => ByteString -> RequestBuilder m ()
setContentType ByteString
c = forall (m :: * -> *).
Monad m =>
(Request -> Request) -> RequestBuilder m ()
rModify (forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
H.setHeader CI ByteString
"Content-Type" ByteString
c)


------------------------------------------------------------------------------
-- | Controls whether the test request being generated appears to be an https
-- request or not.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> 'buildRequest' $ 'delete' \"\/foo\/bar\" M.empty >> 'setSecure' True
-- DELETE \/foo\/bar HTTP\/1.1
-- host: localhost
--
-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a secure
-- @
setSecure :: Monad m => Bool -> RequestBuilder m ()
setSecure :: forall (m :: * -> *). Monad m => Bool -> RequestBuilder m ()
setSecure Bool
b = forall (m :: * -> *).
Monad m =>
(Request -> Request) -> RequestBuilder m ()
rModify forall a b. (a -> b) -> a -> b
$ \Request
rq -> Request
rq { rqIsSecure :: Bool
rqIsSecure = Bool
b }


------------------------------------------------------------------------------
-- | Sets the test request's http version
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> 'buildRequest' $ 'delete' \"\/foo\/bar\" M.empty >> 'setHttpVersion' (1,0)
-- DELETE \/foo\/bar HTTP\/1.0
-- host: localhost
--
-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a
-- @
setHttpVersion :: Monad m => (Int,Int) -> RequestBuilder m ()
setHttpVersion :: forall (m :: * -> *). Monad m => HttpVersion -> RequestBuilder m ()
setHttpVersion HttpVersion
v = forall (m :: * -> *).
Monad m =>
(Request -> Request) -> RequestBuilder m ()
rModify forall a b. (a -> b) -> a -> b
$ \Request
rq -> Request
rq { rqVersion :: HttpVersion
rqVersion = HttpVersion
v }


------------------------------------------------------------------------------
-- | Sets the request's path. The path provided must begin with a \"@/@\" and
-- must /not/ contain a query string; if you want to provide a query string
-- in your test request, you must use 'setQueryString' or 'setQueryStringRaw'.
-- Note that 'rqContextPath' is never set by any 'RequestBuilder' function.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> 'buildRequest' $ 'get' \"\/foo\/bar\" M.empty >> 'setRequestPath' "\/bar\/foo"
-- GET \/bar\/foo HTTP\/1.1
-- host: localhost
--
-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a
-- @
setRequestPath :: Monad m => ByteString -> RequestBuilder m ()
setRequestPath :: forall (m :: * -> *). Monad m => ByteString -> RequestBuilder m ()
setRequestPath ByteString
p0 = do
    forall (m :: * -> *).
Monad m =>
(Request -> Request) -> RequestBuilder m ()
rModify forall a b. (a -> b) -> a -> b
$ \Request
rq -> Request
rq { rqContextPath :: ByteString
rqContextPath = ByteString
"/"
                        , rqPathInfo :: ByteString
rqPathInfo    = ByteString
p }
    forall (m :: * -> *). Monad m => RequestBuilder m ()
fixupURI

  where
    p :: ByteString
p = if ByteString -> ByteString -> Bool
S.isPrefixOf ByteString
"/" ByteString
p0 then Int -> ByteString -> ByteString
S.drop Int
1 ByteString
p0 else ByteString
p0


------------------------------------------------------------------------------
-- | Builds an HTTP \"GET\" request with the given query parameters.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> 'buildRequest' $ 'get' \"\/foo\/bar\" (M.fromList [("param0", ["baz", "quux"])])
-- GET \/foo\/bar?param0=baz&param0=quux HTTP\/1.1
-- host: localhost
--
-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a
-- params: param0: ["baz","quux"]
-- @
get :: MonadIO m =>
       ByteString               -- ^ request path
    -> Params                   -- ^ request's form parameters
    -> RequestBuilder m ()
get :: forall (m :: * -> *).
MonadIO m =>
ByteString -> Params -> RequestBuilder m ()
get ByteString
uri Params
params = do
    forall (m :: * -> *).
MonadIO m =>
RequestType -> RequestBuilder m ()
setRequestType RequestType
GetRequest
    forall (m :: * -> *). Monad m => Params -> RequestBuilder m ()
setQueryString Params
params
    forall (m :: * -> *). Monad m => ByteString -> RequestBuilder m ()
setRequestPath ByteString
uri

------------------------------------------------------------------------------
-- | Builds an HTTP \"HEAD\" request with the given query parameters.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> 'buildRequest' $ 'head' \"\/foo\/bar\" (M.fromList ("param0", ["baz", "quux"])])
-- HEAD \/foo\/bar?param0=baz&param0=quux HTTP\/1.1
-- host: localhost
--
-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a
-- params: param0: ["baz","quux"]
-- @
-- @since 1.0.4.3 
head :: MonadIO m =>
        ByteString              -- ^ request path
     -> Params                  -- ^ request's form parameters
     -> RequestBuilder m ()
head :: forall (m :: * -> *).
MonadIO m =>
ByteString -> Params -> RequestBuilder m ()
head ByteString
uri Params
params = do
  forall (m :: * -> *).
MonadIO m =>
RequestType -> RequestBuilder m ()
setRequestType forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> ByteString -> RequestType
RequestWithRawBody Method
HEAD forall a b. (a -> b) -> a -> b
$ ByteString
""
  forall (m :: * -> *). Monad m => Params -> RequestBuilder m ()
setQueryString Params
params
  forall (m :: * -> *). Monad m => ByteString -> RequestBuilder m ()
setRequestPath ByteString
uri

------------------------------------------------------------------------------
-- | Builds an HTTP \"DELETE\" request with the given query parameters.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> 'buildRequest' $ 'delete' \"\/foo\/bar\" M.empty
-- DELETE \/foo\/bar HTTP\/1.1
-- host: localhost
--
-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a
-- @
delete :: MonadIO m =>
          ByteString            -- ^ request path
       -> Params                -- ^ request's form parameters
       -> RequestBuilder m ()
delete :: forall (m :: * -> *).
MonadIO m =>
ByteString -> Params -> RequestBuilder m ()
delete ByteString
uri Params
params = do
    forall (m :: * -> *).
MonadIO m =>
RequestType -> RequestBuilder m ()
setRequestType RequestType
DeleteRequest
    forall (m :: * -> *). Monad m => Params -> RequestBuilder m ()
setQueryString Params
params
    forall (m :: * -> *). Monad m => ByteString -> RequestBuilder m ()
setRequestPath ByteString
uri


------------------------------------------------------------------------------
-- | Builds an HTTP \"POST\" request with the given form parameters, using the
-- \"application/x-www-form-urlencoded\" MIME type.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> 'buildRequest' $ 'postUrlEncoded' \"\/foo\/bar\" (M.fromList [("param0", ["baz", "quux"])])
-- POST \/foo\/bar HTTP\/1.1
-- content-type: application\/x-www-form-urlencoded
-- content-length: 22
-- host: localhost
--
-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=22
-- params: param0: ["baz","quux"]
-- @
postUrlEncoded :: MonadIO m =>
                  ByteString    -- ^ request path
               -> Params        -- ^ request's form parameters
               -> RequestBuilder m ()
postUrlEncoded :: forall (m :: * -> *).
MonadIO m =>
ByteString -> Params -> RequestBuilder m ()
postUrlEncoded ByteString
uri Params
params = do
    forall (m :: * -> *).
MonadIO m =>
RequestType -> RequestBuilder m ()
setRequestType forall a b. (a -> b) -> a -> b
$ Params -> RequestType
UrlEncodedPostRequest Params
params
    forall (m :: * -> *). Monad m => ByteString -> RequestBuilder m ()
setRequestPath ByteString
uri


------------------------------------------------------------------------------
-- | Builds an HTTP \"POST\" request with the given form parameters, using the
-- \"form-data/multipart\" MIME type.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> 'buildRequest' $ 'postMultipart' \"\/foo\/bar\" [("param0", FormData ["baz", "quux"])]
-- POST \/foo\/bar HTTP\/1.1
-- content-type: multipart\/form-data; boundary=snap-boundary-572334111ec0c05ad4812481e8585dfa
-- content-length: 406
-- host: localhost
--
-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=406
-- @
postMultipart :: MonadIO m =>
                 ByteString        -- ^ request path
              -> MultipartParams   -- ^ multipart form parameters
              -> RequestBuilder m ()
postMultipart :: forall (m :: * -> *).
MonadIO m =>
ByteString -> MultipartParams -> RequestBuilder m ()
postMultipart ByteString
uri MultipartParams
params = do
    forall (m :: * -> *).
MonadIO m =>
RequestType -> RequestBuilder m ()
setRequestType forall a b. (a -> b) -> a -> b
$ MultipartParams -> RequestType
MultipartPostRequest MultipartParams
params
    forall (m :: * -> *). Monad m => ByteString -> RequestBuilder m ()
setRequestPath ByteString
uri


------------------------------------------------------------------------------
-- | Builds an HTTP \"PUT\" request.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> 'buildRequest' $ 'put' \"\/foo\/bar\" "text\/plain" "some text"
-- PUT \/foo\/bar HTTP\/1.1
-- content-type: text/plain
-- content-length: 9
-- host: localhost
--
-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=9
-- @
put :: MonadIO m =>
       ByteString               -- ^ request path
    -> ByteString               -- ^ request body MIME content-type
    -> ByteString               -- ^ request body contents
    -> RequestBuilder m ()
put :: forall (m :: * -> *).
MonadIO m =>
ByteString -> ByteString -> ByteString -> RequestBuilder m ()
put ByteString
uri ByteString
contentType ByteString
putData = do
    forall (m :: * -> *).
MonadIO m =>
RequestType -> RequestBuilder m ()
setRequestType forall a b. (a -> b) -> a -> b
$ Method -> ByteString -> RequestType
RequestWithRawBody Method
PUT ByteString
putData
    forall (m :: * -> *).
Monad m =>
CI ByteString -> ByteString -> RequestBuilder m ()
setHeader CI ByteString
"Content-Type" ByteString
contentType
    forall (m :: * -> *). Monad m => ByteString -> RequestBuilder m ()
setRequestPath ByteString
uri


------------------------------------------------------------------------------
-- | Builds a \"raw\" HTTP \"POST\" request, with the given MIME type and body
-- contents.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> 'buildRequest' $ 'postRaw' \"\/foo\/bar\" "text/plain" "some text"
-- POST \/foo\/bar HTTP\/1.1
-- content-type: text\/plain
-- content-length: 9
-- host: localhost
--
-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=9
-- @
postRaw :: MonadIO m =>
           ByteString           -- ^ request path
        -> ByteString           -- ^ request body MIME content-type
        -> ByteString           -- ^ request body contents
        -> RequestBuilder m ()
postRaw :: forall (m :: * -> *).
MonadIO m =>
ByteString -> ByteString -> ByteString -> RequestBuilder m ()
postRaw ByteString
uri ByteString
contentType ByteString
postData = do
    forall (m :: * -> *).
MonadIO m =>
RequestType -> RequestBuilder m ()
setRequestType forall a b. (a -> b) -> a -> b
$ Method -> ByteString -> RequestType
RequestWithRawBody Method
POST ByteString
postData
    forall (m :: * -> *). Monad m => ByteString -> RequestBuilder m ()
setContentType ByteString
contentType
    forall (m :: * -> *). Monad m => ByteString -> RequestBuilder m ()
setRequestPath ByteString
uri


------------------------------------------------------------------------------
-- | Given a web handler in the 'Snap' monad, and a 'RequestBuilder' defining
-- a test request, runs the handler, producing an HTTP 'Response'.
--
-- This function will produce almost exactly the same output as running the
-- handler in a real server, except that chunked transfer encoding is not
-- applied, and the \"Transfer-Encoding\" header is not set (this makes it
-- easier to test response output).
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import "Snap.Core"
-- ghci> 'runHandler' ('get' "foo/bar" M.empty) ('Snap.Core.writeBS' "Hello, world!")
-- HTTP\/1.1 200 OK
-- server: Snap/test
-- date: Thu, 17 Jul 2014 21:03:23 GMT
--
-- Hello, world!
-- @
runHandler :: MonadIO m =>
              RequestBuilder m ()   -- ^ a request builder
           -> Snap a                -- ^ a web handler
           -> m Response
runHandler :: forall (m :: * -> *) a.
MonadIO m =>
RequestBuilder m () -> Snap a -> m Response
runHandler = forall (m :: * -> *) (n :: * -> *) b.
(MonadIO m, MonadSnap n) =>
(forall a. Request -> n a -> m Response)
-> RequestBuilder m () -> n b -> m Response
runHandlerM forall {m :: * -> *} {a}.
MonadIO m =>
Request -> Snap a -> m Response
rs
  where
    rs :: Request -> Snap a -> m Response
rs Request
rq Snap a
s = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        (Request
_,Response
rsp) <- forall a.
Snap a
-> (ByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> Request
-> IO (Request, Response)
runSnap Snap a
s (\ByteString
x -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (ByteString
x seq :: forall a b. a -> b -> b
`seq` ()))
                             (\Int -> Int
f -> let !Int
_ = Int -> Int
f Int
0 in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ())
                             Request
rq
        Request -> Response -> IO Response
fixupResponse Request
rq Response
rsp


------------------------------------------------------------------------------
-- | Given a web handler in some arbitrary 'MonadSnap' monad, a function
-- specifying how to evaluate it within the context of the test monad, and a
-- 'RequestBuilder' defining a test request, runs the handler, producing an
-- HTTP 'Response'.
runHandlerM :: (MonadIO m, MonadSnap n) =>
               (forall a . Request -> n a -> m Response)
            -- ^ a function defining how the 'MonadSnap' monad should be run
            -> RequestBuilder m ()
            -- ^ a request builder
            -> n b
            -- ^ a web handler
            -> m Response
runHandlerM :: forall (m :: * -> *) (n :: * -> *) b.
(MonadIO m, MonadSnap n) =>
(forall a. Request -> n a -> m Response)
-> RequestBuilder m () -> n b -> m Response
runHandlerM forall a. Request -> n a -> m Response
rSnap RequestBuilder m ()
rBuilder n b
snap = do
    Request
rq  <- forall (m :: * -> *). MonadIO m => RequestBuilder m () -> m Request
buildRequest RequestBuilder m ()
rBuilder
    Response
rsp <- forall a. Request -> n a -> m Response
rSnap Request
rq n b
snap

    -- simulate server logic
    ByteString
t1  <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO EpochTime
epochTime forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= EpochTime -> IO ByteString
formatHttpTime)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
H.setHeader CI ByteString
"Date" ByteString
t1
           forall a b. (a -> b) -> a -> b
$ forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
H.setHeader CI ByteString
"Server" ByteString
"Snap/test"
           forall a b. (a -> b) -> a -> b
$ if Response -> Maybe Word64
rspContentLength Response
rsp forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing Bool -> Bool -> Bool
&&
                Request -> HttpVersion
rqVersion Request
rq forall a. Ord a => a -> a -> Bool
< (Int
1,Int
1)
               then forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
H.setHeader CI ByteString
"Connection" ByteString
"close" Response
rsp
               else Response
rsp


------------------------------------------------------------------------------
-- | Given a web handler in the 'Snap' monad, and a 'RequestBuilder' defining a
-- test request, runs the handler and returns the monadic value it produces.
--
-- Throws an exception if the 'Snap' handler early-terminates with
-- 'Snap.Core.finishWith' or 'Control.Monad.mzero'.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import "Control.Monad"
-- ghci> import qualified "Data.Map" as M
-- ghci> import "Snap.Core"
-- ghci> 'evalHandler' ('get' "foo/bar" M.empty) ('Snap.Core.writeBS' "Hello, world!" >> return 42)
-- 42
-- ghci> 'evalHandler' ('get' "foo/bar" M.empty) 'Control.Monad.mzero'
-- *** Exception: No handler for request: failure was pass
-- @
evalHandler :: MonadIO m =>
               RequestBuilder m ()
            -> Snap a
            -> m a
evalHandler :: forall (m :: * -> *) a.
MonadIO m =>
RequestBuilder m () -> Snap a -> m a
evalHandler = forall (m :: * -> *) (n :: * -> *) b.
(MonadIO m, MonadSnap n) =>
(forall a. Request -> n a -> m a)
-> RequestBuilder m () -> n b -> m b
evalHandlerM forall {m :: * -> *} {a}. MonadIO m => Request -> Snap a -> m a
rs
  where
    rs :: Request -> Snap a -> m a
rs Request
rq Snap a
s = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a.
Snap a
-> (ByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> Request
-> IO a
evalSnap Snap a
s (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ())
                                  (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ())
                                  Request
rq


------------------------------------------------------------------------------
-- | Given a web handler in some arbitrary 'MonadSnap' monad, a function
-- specifying how to evaluate it within the context of the test monad, and a
-- 'RequestBuilder' defining a test request, runs the handler, returning the
-- monadic value it produces.
--
-- Throws an exception if the 'Snap' handler early-terminates with
-- 'Snap.Core.finishWith' or 'Control.Monad.mzero'.
evalHandlerM :: (MonadIO m, MonadSnap n) =>
                (forall a . Request -> n a -> m a)  -- ^ a function defining
                                                    -- how the 'MonadSnap'
                                                    -- monad should be run
             -> RequestBuilder m ()                 -- ^ a request builder
             -> n b                                 -- ^ a web handler
             -> m b
evalHandlerM :: forall (m :: * -> *) (n :: * -> *) b.
(MonadIO m, MonadSnap n) =>
(forall a. Request -> n a -> m a)
-> RequestBuilder m () -> n b -> m b
evalHandlerM forall a. Request -> n a -> m a
rSnap RequestBuilder m ()
rBuilder n b
snap = do
    Request
rq <- forall (m :: * -> *). MonadIO m => RequestBuilder m () -> m Request
buildRequest RequestBuilder m ()
rBuilder
    forall a. Request -> n a -> m a
rSnap Request
rq n b
snap


------------------------------------------------------------------------------
-- | Converts the given 'Response' to a bytestring.
--
-- Example:
--
-- @
-- ghci> import "Snap.Core"
-- ghci> 'responseToString' 'Snap.Core.emptyResponse'
-- \"HTTP\/1.1 200 OK\\r\\n\\r\\n\"
-- @
responseToString :: Response -> IO ByteString
responseToString :: Response -> IO ByteString
responseToString Response
resp = do
    let act :: StreamProc
act = ResponseBody -> StreamProc
rspBodyToEnum forall a b. (a -> b) -> a -> b
$ Response -> ResponseBody
rspBody Response
resp

    (OutputStream Builder
listOut, IO [Builder]
grab) <- forall c. IO (OutputStream c, IO [c])
Streams.listOutputStream
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ StreamProc
act OutputStream Builder
listOut
    Builder
builder <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. Monoid a => [a] -> a
mconcat IO [Builder]
grab

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Builder -> ByteString
toByteString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Builder
fromShow Response
resp forall a. Monoid a => a -> a -> a
`mappend` Builder
builder


------------------------------------------------------------------------------
-- | Converts the given 'Request' to a bytestring.
--
-- Since: 1.0.0.0
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> r <- 'buildRequest' $ get \"\/foo\/bar\" M.empty
-- ghci> 'requestToString' r
-- \"GET \/foo\/bar HTTP\/1.1\\r\\nhost: localhost\\r\\n\\r\\n\"
-- @
requestToString :: Request -> IO ByteString
requestToString :: Request -> IO ByteString
requestToString Request
req0 = do
    (Request
req, InputStream ByteString
is) <- IO (Request, InputStream ByteString)
maybeChunk
    ByteString
body <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [ByteString] -> ByteString
S.concat forall a b. (a -> b) -> a -> b
$ forall a. InputStream a -> IO [a]
Streams.toList InputStream ByteString
is
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Builder -> ByteString
toByteString forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [ Builder
statusLine
                                     , forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (CI ByteString, ByteString) -> Builder
oneHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. Headers -> [(CI ByteString, ByteString)]
H.toList
                                               forall a b. (a -> b) -> a -> b
$ Request -> Headers
rqHeaders Request
req
                                     , Builder
crlf
                                     , ByteString -> Builder
byteString ByteString
body
                                     ]
  where
    maybeChunk :: IO (Request, InputStream ByteString)
maybeChunk = do
        if forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader CI ByteString
"Transfer-Encoding" Request
req0 forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ByteString
"chunked"
          then do
              let req :: Request
req = forall a. HasHeaders a => CI ByteString -> a -> a
deleteHeader CI ByteString
"Content-Length" forall a b. (a -> b) -> a -> b
$
                        Request
req0 { rqContentLength :: Maybe Word64
rqContentLength = forall a. Maybe a
Nothing }
              InputStream ByteString
is' <- forall a b. (a -> b) -> InputStream a -> IO (InputStream b)
Streams.map ByteString -> ByteString
chunk forall a b. (a -> b) -> a -> b
$ Request -> InputStream ByteString
rqBody Request
req
              InputStream ByteString
out <- IO (InputStream ByteString)
eof forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. InputStream a -> InputStream a -> IO (InputStream a)
Streams.appendInputStream InputStream ByteString
is'
              forall (m :: * -> *) a. Monad m => a -> m a
return (Request
req, InputStream ByteString
out)
          else forall (m :: * -> *) a. Monad m => a -> m a
return (Request
req0, Request -> InputStream ByteString
rqBody Request
req0)
      where
        chunk :: ByteString -> ByteString
chunk ByteString
s = [ByteString] -> ByteString
S.concat [ String -> ByteString
S.pack forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"%x\r\n" (ByteString -> Int
S.length ByteString
s)
                           , ByteString
s
                           , ByteString
"\r\n"
                           ]
        eof :: IO (InputStream ByteString)
eof = forall c. [c] -> IO (InputStream c)
Streams.fromList [ByteString
"0\r\n\r\n"]

    (Int
v1,Int
v2) = Request -> HttpVersion
rqVersion Request
req0
    crlf :: Builder
crlf = Char -> Builder
char8 Char
'\r' forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
char8 Char
'\n'
    statusLine :: Builder
statusLine = forall a. Monoid a => [a] -> a
mconcat [ forall a. Show a => a -> Builder
fromShow forall a b. (a -> b) -> a -> b
$ Request -> Method
rqMethod Request
req0
                         , Char -> Builder
char8 Char
' '
                         , ByteString -> Builder
byteString forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rqURI Request
req0
                         , ByteString -> Builder
byteString ByteString
" HTTP/"
                         , forall a. Show a => a -> Builder
fromShow Int
v1
                         , Char -> Builder
char8 Char
'.'
                         , forall a. Show a => a -> Builder
fromShow Int
v2
                         , Builder
crlf
                         ]

    oneHeader :: (CI ByteString, ByteString) -> Builder
oneHeader (CI ByteString
k,ByteString
v) = forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Builder
byteString forall a b. (a -> b) -> a -> b
$ forall s. CI s -> s
original CI ByteString
k
                              , ByteString -> Builder
byteString ByteString
": "
                              , ByteString -> Builder
byteString ByteString
v
                              , Builder
crlf
                              ]


------------------------------------------------------------------------------
rGet :: Monad m => RequestBuilder m Request
rGet :: forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet   = forall (m :: * -> *) a. StateT Request m a -> RequestBuilder m a
RequestBuilder forall s (m :: * -> *). MonadState s m => m s
State.get

rPut :: Monad m => Request -> RequestBuilder m ()
rPut :: forall (m :: * -> *). Monad m => Request -> RequestBuilder m ()
rPut Request
s = forall (m :: * -> *) a. StateT Request m a -> RequestBuilder m a
RequestBuilder forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => s -> m ()
State.put Request
s

rModify :: Monad m => (Request -> Request) -> RequestBuilder m ()
rModify :: forall (m :: * -> *).
Monad m =>
(Request -> Request) -> RequestBuilder m ()
rModify Request -> Request
f = forall (m :: * -> *) a. StateT Request m a -> RequestBuilder m a
RequestBuilder forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify Request -> Request
f


------------------------------------------------------------------------------
toByteString :: Builder -> ByteString
toByteString :: Builder -> ByteString
toByteString = [ByteString] -> ByteString
S.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString


------------------------------------------------------------------------------
fromShow :: Show a => a -> Builder
fromShow :: forall a. Show a => a -> Builder
fromShow = String -> Builder
stringUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show