{- 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 ( Functor (RequestBuilder m)
Functor (RequestBuilder m) =>
(forall a. a -> RequestBuilder m a)
-> (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 a b.
    RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m b)
-> (forall a b.
    RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m a)
-> Applicative (RequestBuilder m)
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
$cpure :: forall (m :: * -> *) a. Monad m => a -> RequestBuilder m a
pure :: forall a. a -> RequestBuilder m a
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
RequestBuilder m (a -> b)
-> RequestBuilder m a -> RequestBuilder m b
<*> :: forall a b.
RequestBuilder m (a -> b)
-> RequestBuilder m a -> RequestBuilder m b
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m c
liftA2 :: forall a b c.
(a -> b -> c)
-> RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m c
$c*> :: forall (m :: * -> *) a b.
Monad m =>
RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m b
*> :: 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 a
<* :: forall a b.
RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m a
Applicative
           , (forall a b. (a -> b) -> RequestBuilder m a -> RequestBuilder m b)
-> (forall a b. a -> RequestBuilder m b -> RequestBuilder m a)
-> Functor (RequestBuilder m)
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
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> RequestBuilder m a -> RequestBuilder m b
fmap :: forall a b. (a -> b) -> RequestBuilder m a -> RequestBuilder m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> RequestBuilder m b -> RequestBuilder m a
<$ :: forall a b. a -> RequestBuilder m b -> RequestBuilder m a
Functor
           , Applicative (RequestBuilder m)
Applicative (RequestBuilder m) =>
(forall a b.
 RequestBuilder m a
 -> (a -> RequestBuilder m b) -> RequestBuilder m b)
-> (forall a b.
    RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m b)
-> (forall a. a -> RequestBuilder m a)
-> Monad (RequestBuilder m)
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
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
RequestBuilder m a
-> (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 -> RequestBuilder m b -> RequestBuilder m b
>> :: forall a b.
RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> RequestBuilder m a
return :: forall a. a -> RequestBuilder m a
Monad
#if MIN_VERSION_base(4,13,0)
           , Monad (RequestBuilder m)
Monad (RequestBuilder m) =>
(forall a. String -> RequestBuilder m a)
-> MonadFail (RequestBuilder m)
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
$cfail :: forall (m :: * -> *) a. MonadFail m => String -> RequestBuilder m a
fail :: forall a. String -> RequestBuilder m a
MonadFail
#endif
           , Monad (RequestBuilder m)
Monad (RequestBuilder m) =>
(forall a. IO a -> RequestBuilder m a)
-> MonadIO (RequestBuilder m)
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
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> RequestBuilder m a
liftIO :: forall a. IO a -> RequestBuilder m a
MonadIO
           , MonadState Request
           , (forall (m :: * -> *). Monad m => Monad (RequestBuilder m)) =>
(forall (m :: * -> *) a. Monad m => m a -> RequestBuilder m a)
-> MonadTrans RequestBuilder
forall (m :: * -> *). Monad m => Monad (RequestBuilder m)
forall (m :: * -> *) a. Monad m => m a -> RequestBuilder m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *). Monad m => Monad (t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall (m :: * -> *) a. Monad m => m a -> RequestBuilder m a
lift :: forall (m :: * -> *) a. Monad m => m a -> RequestBuilder m a
MonadTrans
           )


------------------------------------------------------------------------------
mkDefaultRequest :: IO Request
mkDefaultRequest :: IO Request
mkDefaultRequest = do
    b <- [StrictByteString] -> IO (InputStream StrictByteString)
forall c. [c] -> IO (InputStream c)
Streams.fromList ([StrictByteString] -> IO (InputStream StrictByteString))
-> [StrictByteString] -> IO (InputStream StrictByteString)
forall a b. (a -> b) -> a -> b
$! []
    return $ Request "localhost"
                     "127.0.0.1"
                     60000
                     "127.0.0.1"
                     8080
                     "localhost"
                     False
                     H.empty
                     b
                     Nothing
                     GET
                     (1,1)
                     []
                     ""
                     "/"
                     "/"
                     ""
                     Map.empty
                     Map.empty
                     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 RequestBuilder m () -> RequestBuilder m () -> RequestBuilder m ()
forall a b.
RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RequestBuilder m ()
fixup)
    rq0 <- IO Request -> m Request
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Request
mkDefaultRequest
    execStateT m rq0

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

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

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

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

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

        rPut $ rq' { rqParams      = newParams
                   , rqPostParams  = postParams
                   , rqQueryParams = queryParams }

    fixupHost :: RequestBuilder m ()
fixupHost = do
        rq <- RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
        case H.getHeader "Host" rq of
          Maybe StrictByteString
Nothing -> do
            let !hn :: StrictByteString
hn = Request -> StrictByteString
rqHostName Request
rq
            Request -> RequestBuilder m ()
forall (m :: * -> *). Monad m => Request -> RequestBuilder m ()
rPut (Request -> RequestBuilder m ()) -> Request -> RequestBuilder m ()
forall a b. (a -> b) -> a -> b
$ CI StrictByteString -> StrictByteString -> Request -> Request
forall a.
HasHeaders a =>
CI StrictByteString -> StrictByteString -> a -> a
H.setHeader CI StrictByteString
"Host" StrictByteString
hn Request
rq
          Just StrictByteString
hn ->
            Request -> RequestBuilder m ()
forall (m :: * -> *). Monad m => Request -> RequestBuilder m ()
rPut (Request -> RequestBuilder m ()) -> Request -> RequestBuilder m ()
forall a b. (a -> b) -> a -> b
$ Request
rq { rqHostName = 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
(Int -> MultipartParam -> ShowS)
-> (MultipartParam -> String)
-> ([MultipartParam] -> ShowS)
-> Show MultipartParam
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MultipartParam -> ShowS
showsPrec :: Int -> MultipartParam -> ShowS
$cshow :: MultipartParam -> String
show :: MultipartParam -> String
$cshowList :: [MultipartParam] -> ShowS
showList :: [MultipartParam] -> ShowS
Show)


------------------------------------------------------------------------------
-- | Represents a single file upload for the 'MultipartParam'.
data FileData = FileData {
      FileData -> StrictByteString
fdFileName    :: ByteString  -- ^ the file's name
    , FileData -> StrictByteString
fdContentType :: ByteString  -- ^ the file's content-type
    , FileData -> StrictByteString
fdContents    :: ByteString  -- ^ the file contents
    }
  deriving (Int -> FileData -> ShowS
[FileData] -> ShowS
FileData -> String
(Int -> FileData -> ShowS)
-> (FileData -> String) -> ([FileData] -> ShowS) -> Show FileData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FileData -> ShowS
showsPrec :: Int -> FileData -> ShowS
$cshow :: FileData -> String
show :: FileData -> String
$cshowList :: [FileData] -> ShowS
showList :: [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
(Int -> RequestType -> ShowS)
-> (RequestType -> String)
-> ([RequestType] -> ShowS)
-> Show RequestType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RequestType -> ShowS
showsPrec :: Int -> RequestType -> ShowS
$cshow :: RequestType -> String
show :: RequestType -> String
$cshowList :: [RequestType] -> ShowS
showList :: [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
    rq   <- RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
    body <- liftIO $ Streams.fromList $! []

    rPut $ rq { rqMethod        = GET
              , rqContentLength = Nothing
              , rqBody          = body
              }

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

    rPut $ rq { rqMethod        = DELETE
              , rqContentLength = Nothing
              , rqBody          = body
              }

setRequestType (RequestWithRawBody Method
m StrictByteString
b) = do
    rq <- RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
    body <- liftIO $ Streams.fromList $! [ b ]
    rPut $ rq { rqMethod        = m
              , rqContentLength = Just $ fromIntegral $ S.length b
              , rqBody          = body
              }

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

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

    rPut $ rq { rqMethod        = POST
              , rqContentLength = Just $!  fromIntegral $ S.length b
              , rqBody          = body
              }


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

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

    table :: Vector Char
table = String -> Vector Char
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 :: StrictByteString -> StrictByteString
encode = Builder -> StrictByteString
toByteString (Builder -> StrictByteString)
-> (StrictByteString -> Builder)
-> StrictByteString
-> StrictByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Builder -> Word8 -> Builder)
-> Builder -> StrictByteString -> Builder
forall a. (a -> Word8 -> a) -> a -> StrictByteString -> a
S8.foldl' Builder -> Word8 -> Builder
f Builder
forall a. Monoid a => a
mempty

#if MIN_VERSION_base(4,5,0)
    shR :: Word8 -> Int -> Word8
shR = Word8 -> Int -> Word8
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 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xf
                hi :: Word8
hi  = (Word8
c Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xf0) Word8 -> Int -> Word8
`shR` Int
4
                k :: Word8 -> Builder
k   = \Word8
i -> Word8 -> Builder
word8 (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$! Int -> Word8
forall a. Enum a => Int -> a
toEnum (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$! Char -> Int
forall a. Enum a => a -> Int
fromEnum (Char -> Int) -> Char -> Int
forall a b. (a -> b) -> a -> b
$!
                            Vector Char -> Int -> Char
forall a. Vector a -> Int -> a
V.unsafeIndex Vector Char
table (Word8 -> Int
forall a. Enum a => a -> Int
fromEnum Word8
i)
            in Builder
m Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Word8 -> Builder
k Word8
hi Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Word8 -> Builder
k Word8
low


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


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

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

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

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


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


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

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

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

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

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


------------------------------------------------------------------------------
encodeMultipart :: MonadIO m => MultipartParams -> RequestBuilder m ()
encodeMultipart :: forall (m :: * -> *).
MonadIO m =>
MultipartParams -> RequestBuilder m ()
encodeMultipart MultipartParams
kvps = do
    boundary <- IO StrictByteString -> RequestBuilder m StrictByteString
forall a. IO a -> RequestBuilder m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO StrictByteString -> RequestBuilder m StrictByteString)
-> IO StrictByteString -> RequestBuilder m StrictByteString
forall a b. (a -> b) -> a -> b
$ IO StrictByteString
forall (m :: * -> *). MonadIO m => m StrictByteString
makeBoundary
    builders <- liftIO $ mapM (handleOne boundary) kvps

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

    rq0 <- rGet

    body <- liftIO $ Streams.fromList [b]

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

    rPut $ rq { rqMethod        = POST
              , rqContentLength = Just $ fromIntegral $ S.length b
              , rqBody          = body
              }


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

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


------------------------------------------------------------------------------
fixupURI :: Monad m => RequestBuilder m ()
fixupURI :: forall (m :: * -> *). Monad m => RequestBuilder m ()
fixupURI = do
    rq <- RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
    upd rq $! S.concat [ rqContextPath rq
                       , rqPathInfo rq
                       , let q = Request -> StrictByteString
rqQueryString Request
rq
                         in if S.null q
                              then ""
                              else S.append "?" q
                       ]
  where
    upd :: Request -> StrictByteString -> RequestBuilder m ()
upd Request
rq !StrictByteString
u = let !StrictByteString
_ = Request -> StrictByteString
rqURI Request
rq
                in Request -> RequestBuilder m ()
forall (m :: * -> *). Monad m => Request -> RequestBuilder m ()
rPut (Request -> RequestBuilder m ()) -> Request -> RequestBuilder m ()
forall a b. (a -> b) -> a -> b
$ Request
rq { rqURI = 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 =>
StrictByteString -> RequestBuilder m ()
setQueryStringRaw StrictByteString
r = do
    rq <- RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
    rPut $ rq { rqQueryString = r }
    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 = StrictByteString -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
StrictByteString -> RequestBuilder m ()
setQueryStringRaw (StrictByteString -> RequestBuilder m ())
-> StrictByteString -> RequestBuilder m ()
forall a b. (a -> b) -> a -> b
$ Params -> StrictByteString
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 StrictByteString -> StrictByteString -> RequestBuilder m ()
setHeader CI StrictByteString
k StrictByteString
v = (Request -> Request) -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
(Request -> Request) -> RequestBuilder m ()
rModify (CI StrictByteString -> StrictByteString -> Request -> Request
forall a.
HasHeaders a =>
CI StrictByteString -> StrictByteString -> a -> a
H.setHeader CI StrictByteString
k StrictByteString
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 StrictByteString -> StrictByteString -> RequestBuilder m ()
addHeader CI StrictByteString
k StrictByteString
v = (Request -> Request) -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
(Request -> Request) -> RequestBuilder m ()
rModify (CI StrictByteString -> StrictByteString -> Request -> Request
forall a.
HasHeaders a =>
CI StrictByteString -> StrictByteString -> a -> a
H.addHeader CI StrictByteString
k StrictByteString
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
    (Request -> Request) -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
(Request -> Request) -> RequestBuilder m ()
rModify ((Request -> Request) -> RequestBuilder m ())
-> (Request -> Request) -> RequestBuilder m ()
forall a b. (a -> b) -> a -> b
$ \Request
rq -> Request
rq { rqCookies = rqCookies rq ++ cookies }
    allCookies <- (Request -> [Cookie])
-> RequestBuilder m Request -> RequestBuilder m [Cookie]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Request -> [Cookie]
rqCookies RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
    let cstr = (Cookie -> StrictByteString) -> [Cookie] -> [StrictByteString]
forall a b. (a -> b) -> [a] -> [b]
map Cookie -> StrictByteString
cookieToBS [Cookie]
allCookies
    setHeader "Cookie" $ S.intercalate "; " cstr


------------------------------------------------------------------------------
-- | Convert 'Cookie' into 'ByteString' for output.
cookieToBS :: Cookie -> ByteString
cookieToBS :: Cookie -> StrictByteString
cookieToBS (Cookie StrictByteString
k StrictByteString
v !Maybe UTCTime
_ !Maybe StrictByteString
_ !Maybe StrictByteString
_ !Bool
_ !Bool
_) = StrictByteString
cookie
  where
    cookie :: StrictByteString
cookie  = [StrictByteString] -> StrictByteString
S.concat [StrictByteString
k, StrictByteString
"=", StrictByteString
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 =>
StrictByteString -> RequestBuilder m ()
setContentType StrictByteString
c = (Request -> Request) -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
(Request -> Request) -> RequestBuilder m ()
rModify (CI StrictByteString -> StrictByteString -> Request -> Request
forall a.
HasHeaders a =>
CI StrictByteString -> StrictByteString -> a -> a
H.setHeader CI StrictByteString
"Content-Type" StrictByteString
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 = (Request -> Request) -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
(Request -> Request) -> RequestBuilder m ()
rModify ((Request -> Request) -> RequestBuilder m ())
-> (Request -> Request) -> RequestBuilder m ()
forall a b. (a -> b) -> a -> b
$ \Request
rq -> Request
rq { rqIsSecure = 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 = (Request -> Request) -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
(Request -> Request) -> RequestBuilder m ()
rModify ((Request -> Request) -> RequestBuilder m ())
-> (Request -> Request) -> RequestBuilder m ()
forall a b. (a -> b) -> a -> b
$ \Request
rq -> Request
rq { rqVersion = 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 =>
StrictByteString -> RequestBuilder m ()
setRequestPath StrictByteString
p0 = do
    (Request -> Request) -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
(Request -> Request) -> RequestBuilder m ()
rModify ((Request -> Request) -> RequestBuilder m ())
-> (Request -> Request) -> RequestBuilder m ()
forall a b. (a -> b) -> a -> b
$ \Request
rq -> Request
rq { rqContextPath = "/"
                        , rqPathInfo    = p }
    RequestBuilder m ()
forall (m :: * -> *). Monad m => RequestBuilder m ()
fixupURI

  where
    p :: StrictByteString
p = if StrictByteString -> StrictByteString -> Bool
S.isPrefixOf StrictByteString
"/" StrictByteString
p0 then Int -> StrictByteString -> StrictByteString
S.drop Int
1 StrictByteString
p0 else StrictByteString
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 =>
StrictByteString -> Params -> RequestBuilder m ()
get StrictByteString
uri Params
params = do
    RequestType -> RequestBuilder m ()
forall (m :: * -> *).
MonadIO m =>
RequestType -> RequestBuilder m ()
setRequestType RequestType
GetRequest
    Params -> RequestBuilder m ()
forall (m :: * -> *). Monad m => Params -> RequestBuilder m ()
setQueryString Params
params
    StrictByteString -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
StrictByteString -> RequestBuilder m ()
setRequestPath StrictByteString
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 =>
StrictByteString -> Params -> RequestBuilder m ()
head StrictByteString
uri Params
params = do
  RequestType -> RequestBuilder m ()
forall (m :: * -> *).
MonadIO m =>
RequestType -> RequestBuilder m ()
setRequestType (RequestType -> RequestBuilder m ())
-> (StrictByteString -> RequestType)
-> StrictByteString
-> RequestBuilder m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> StrictByteString -> RequestType
RequestWithRawBody Method
HEAD (StrictByteString -> RequestBuilder m ())
-> StrictByteString -> RequestBuilder m ()
forall a b. (a -> b) -> a -> b
$ StrictByteString
""
  Params -> RequestBuilder m ()
forall (m :: * -> *). Monad m => Params -> RequestBuilder m ()
setQueryString Params
params
  StrictByteString -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
StrictByteString -> RequestBuilder m ()
setRequestPath StrictByteString
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 =>
StrictByteString -> Params -> RequestBuilder m ()
delete StrictByteString
uri Params
params = do
    RequestType -> RequestBuilder m ()
forall (m :: * -> *).
MonadIO m =>
RequestType -> RequestBuilder m ()
setRequestType RequestType
DeleteRequest
    Params -> RequestBuilder m ()
forall (m :: * -> *). Monad m => Params -> RequestBuilder m ()
setQueryString Params
params
    StrictByteString -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
StrictByteString -> RequestBuilder m ()
setRequestPath StrictByteString
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 =>
StrictByteString -> Params -> RequestBuilder m ()
postUrlEncoded StrictByteString
uri Params
params = do
    RequestType -> RequestBuilder m ()
forall (m :: * -> *).
MonadIO m =>
RequestType -> RequestBuilder m ()
setRequestType (RequestType -> RequestBuilder m ())
-> RequestType -> RequestBuilder m ()
forall a b. (a -> b) -> a -> b
$ Params -> RequestType
UrlEncodedPostRequest Params
params
    StrictByteString -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
StrictByteString -> RequestBuilder m ()
setRequestPath StrictByteString
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 =>
StrictByteString -> MultipartParams -> RequestBuilder m ()
postMultipart StrictByteString
uri MultipartParams
params = do
    RequestType -> RequestBuilder m ()
forall (m :: * -> *).
MonadIO m =>
RequestType -> RequestBuilder m ()
setRequestType (RequestType -> RequestBuilder m ())
-> RequestType -> RequestBuilder m ()
forall a b. (a -> b) -> a -> b
$ MultipartParams -> RequestType
MultipartPostRequest MultipartParams
params
    StrictByteString -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
StrictByteString -> RequestBuilder m ()
setRequestPath StrictByteString
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 =>
StrictByteString
-> StrictByteString -> StrictByteString -> RequestBuilder m ()
put StrictByteString
uri StrictByteString
contentType StrictByteString
putData = do
    RequestType -> RequestBuilder m ()
forall (m :: * -> *).
MonadIO m =>
RequestType -> RequestBuilder m ()
setRequestType (RequestType -> RequestBuilder m ())
-> RequestType -> RequestBuilder m ()
forall a b. (a -> b) -> a -> b
$ Method -> StrictByteString -> RequestType
RequestWithRawBody Method
PUT StrictByteString
putData
    CI StrictByteString -> StrictByteString -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
CI StrictByteString -> StrictByteString -> RequestBuilder m ()
setHeader CI StrictByteString
"Content-Type" StrictByteString
contentType
    StrictByteString -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
StrictByteString -> RequestBuilder m ()
setRequestPath StrictByteString
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 =>
StrictByteString
-> StrictByteString -> StrictByteString -> RequestBuilder m ()
postRaw StrictByteString
uri StrictByteString
contentType StrictByteString
postData = do
    RequestType -> RequestBuilder m ()
forall (m :: * -> *).
MonadIO m =>
RequestType -> RequestBuilder m ()
setRequestType (RequestType -> RequestBuilder m ())
-> RequestType -> RequestBuilder m ()
forall a b. (a -> b) -> a -> b
$ Method -> StrictByteString -> RequestType
RequestWithRawBody Method
POST StrictByteString
postData
    StrictByteString -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
StrictByteString -> RequestBuilder m ()
setContentType StrictByteString
contentType
    StrictByteString -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
StrictByteString -> RequestBuilder m ()
setRequestPath StrictByteString
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 a. Request -> Snap a -> m Response)
-> RequestBuilder m () -> Snap a -> m Response
forall (m :: * -> *) (n :: * -> *) b.
(MonadIO m, MonadSnap n) =>
(forall a. Request -> n a -> m Response)
-> RequestBuilder m () -> n b -> m Response
runHandlerM Request -> Snap a -> m Response
forall a. Request -> Snap a -> m Response
forall {m :: * -> *} {a}.
MonadIO m =>
Request -> Snap a -> m Response
rs
  where
    rs :: Request -> Snap a -> m Response
rs Request
rq Snap a
s = IO Response -> m Response
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Response -> m Response) -> IO Response -> m Response
forall a b. (a -> b) -> a -> b
$ do
        (_,rsp) <- Snap a
-> (StrictByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> Request
-> IO (Request, Response)
forall a.
Snap a
-> (StrictByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> Request
-> IO (Request, Response)
runSnap Snap a
s (\StrictByteString
x -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$! (StrictByteString
x StrictByteString -> () -> ()
forall a b. a -> b -> b
`seq` ()))
                             (\Int -> Int
f -> let !Int
_ = Int -> Int
f Int
0 in () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$! ())
                             Request
rq
        fixupResponse rq 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
    rq  <- RequestBuilder m () -> m Request
forall (m :: * -> *). MonadIO m => RequestBuilder m () -> m Request
buildRequest RequestBuilder m ()
rBuilder
    rsp <- rSnap rq snap

    -- simulate server logic
    t1  <- liftIO (epochTime >>= formatHttpTime)
    return $ H.setHeader "Date" t1
           $ H.setHeader "Server" "Snap/test"
           $ if rspContentLength rsp == Nothing &&
                rqVersion rq < (1,1)
               then H.setHeader "Connection" "close" rsp
               else 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 a. Request -> Snap a -> m a)
-> RequestBuilder m () -> Snap a -> m a
forall (m :: * -> *) (n :: * -> *) b.
(MonadIO m, MonadSnap n) =>
(forall a. Request -> n a -> m a)
-> RequestBuilder m () -> n b -> m b
evalHandlerM Request -> Snap a -> m a
forall a. Request -> Snap a -> m a
forall {m :: * -> *} {a}. MonadIO m => Request -> Snap a -> m a
rs
  where
    rs :: Request -> Snap a -> m a
rs Request
rq Snap a
s = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ Snap a
-> (StrictByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> Request
-> IO a
forall a.
Snap a
-> (StrictByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> Request
-> IO a
evalSnap Snap a
s (IO () -> StrictByteString -> IO ()
forall a b. a -> b -> a
const (IO () -> StrictByteString -> IO ())
-> IO () -> StrictByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$! ())
                                  (IO () -> (Int -> Int) -> IO ()
forall a b. a -> b -> a
const (IO () -> (Int -> Int) -> IO ()) -> IO () -> (Int -> Int) -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()) -> () -> IO ()
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
    rq <- RequestBuilder m () -> m Request
forall (m :: * -> *). MonadIO m => RequestBuilder m () -> m Request
buildRequest RequestBuilder m ()
rBuilder
    rSnap rq 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 StrictByteString
responseToString Response
resp = do
    let act :: StreamProc
act = ResponseBody -> StreamProc
rspBodyToEnum (ResponseBody -> StreamProc) -> ResponseBody -> StreamProc
forall a b. (a -> b) -> a -> b
$ Response -> ResponseBody
rspBody Response
resp

    (listOut, grab) <- IO (OutputStream Builder, IO [Builder])
forall c. IO (OutputStream c, IO [c])
Streams.listOutputStream
    void $ act listOut
    builder <- liftM mconcat grab

    return $! toByteString $ fromShow resp `mappend` 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 StrictByteString
requestToString Request
req0 = do
    (req, is) <- IO (Request, InputStream StrictByteString)
maybeChunk
    body <- liftM S.concat $ Streams.toList is
    return $! toByteString $ mconcat [ statusLine
                                     , mconcat . map oneHeader . H.toList
                                               $ rqHeaders req
                                     , crlf
                                     , byteString body
                                     ]
  where
    maybeChunk :: IO (Request, InputStream StrictByteString)
maybeChunk = do
        if CI StrictByteString -> Request -> Maybe StrictByteString
forall a.
HasHeaders a =>
CI StrictByteString -> a -> Maybe StrictByteString
getHeader CI StrictByteString
"Transfer-Encoding" Request
req0 Maybe StrictByteString -> Maybe StrictByteString -> Bool
forall a. Eq a => a -> a -> Bool
== StrictByteString -> Maybe StrictByteString
forall a. a -> Maybe a
Just StrictByteString
"chunked"
          then do
              let req :: Request
req = CI StrictByteString -> Request -> Request
forall a. HasHeaders a => CI StrictByteString -> a -> a
deleteHeader CI StrictByteString
"Content-Length" (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$
                        Request
req0 { rqContentLength = Nothing }
              is' <- (StrictByteString -> StrictByteString)
-> InputStream StrictByteString
-> IO (InputStream StrictByteString)
forall a b. (a -> b) -> InputStream a -> IO (InputStream b)
Streams.map StrictByteString -> StrictByteString
chunk (InputStream StrictByteString -> IO (InputStream StrictByteString))
-> InputStream StrictByteString
-> IO (InputStream StrictByteString)
forall a b. (a -> b) -> a -> b
$ Request -> InputStream StrictByteString
rqBody Request
req
              out <- eof >>= Streams.appendInputStream is'
              return (req, out)
          else (Request, InputStream StrictByteString)
-> IO (Request, InputStream StrictByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Request
req0, Request -> InputStream StrictByteString
rqBody Request
req0)
      where
        chunk :: StrictByteString -> StrictByteString
chunk StrictByteString
s = [StrictByteString] -> StrictByteString
S.concat [ String -> StrictByteString
S.pack (String -> StrictByteString) -> String -> StrictByteString
forall a b. (a -> b) -> a -> b
$ String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%x\r\n" (StrictByteString -> Int
S.length StrictByteString
s)
                           , StrictByteString
s
                           , StrictByteString
"\r\n"
                           ]
        eof :: IO (InputStream StrictByteString)
eof = [StrictByteString] -> IO (InputStream StrictByteString)
forall c. [c] -> IO (InputStream c)
Streams.fromList [StrictByteString
"0\r\n\r\n"]

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

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


------------------------------------------------------------------------------
rGet :: Monad m => RequestBuilder m Request
rGet :: forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet   = StateT Request m Request -> RequestBuilder m Request
forall (m :: * -> *) a. StateT Request m a -> RequestBuilder m a
RequestBuilder StateT Request m Request
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 = StateT Request m () -> RequestBuilder m ()
forall (m :: * -> *) a. StateT Request m a -> RequestBuilder m a
RequestBuilder (StateT Request m () -> RequestBuilder m ())
-> StateT Request m () -> RequestBuilder m ()
forall a b. (a -> b) -> a -> b
$ Request -> StateT Request m ()
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 = StateT Request m () -> RequestBuilder m ()
forall (m :: * -> *) a. StateT Request m a -> RequestBuilder m a
RequestBuilder (StateT Request m () -> RequestBuilder m ())
-> StateT Request m () -> RequestBuilder m ()
forall a b. (a -> b) -> a -> b
$ (Request -> Request) -> StateT Request m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify Request -> Request
f


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


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