{-# 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
, 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 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 (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
newtype RequestBuilder m a = RequestBuilder (StateT Request m a)
deriving ( Functor (RequestBuilder m)
a -> RequestBuilder m a
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)
RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m b
RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m a
RequestBuilder m (a -> b)
-> RequestBuilder m a -> RequestBuilder m b
(a -> b -> c)
-> RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m c
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
<* :: 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
*> :: 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 :: (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
<*> :: 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 :: a -> RequestBuilder m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> RequestBuilder m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (RequestBuilder m)
Applicative
, a -> RequestBuilder m b -> RequestBuilder m a
(a -> b) -> RequestBuilder m a -> RequestBuilder m b
(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
<$ :: a -> RequestBuilder m b -> RequestBuilder m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> RequestBuilder m b -> RequestBuilder m a
fmap :: (a -> b) -> RequestBuilder m a -> RequestBuilder m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> RequestBuilder m a -> RequestBuilder m b
Functor
, Applicative (RequestBuilder m)
a -> RequestBuilder m a
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)
RequestBuilder m a
-> (a -> RequestBuilder m b) -> RequestBuilder m b
RequestBuilder m a -> RequestBuilder m b -> RequestBuilder m b
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 :: a -> RequestBuilder m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> RequestBuilder m a
>> :: 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
>>= :: 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
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (RequestBuilder m)
Monad
#if MIN_VERSION_base(4,13,0)
, Monad (RequestBuilder m)
Monad (RequestBuilder m) =>
(forall a. String -> RequestBuilder m a)
-> MonadFail (RequestBuilder m)
String -> RequestBuilder m a
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 :: String -> RequestBuilder m a
$cfail :: forall (m :: * -> *) a. MonadFail m => String -> RequestBuilder m a
$cp1MonadFail :: forall (m :: * -> *). MonadFail m => Monad (RequestBuilder m)
MonadFail
#endif
, Monad (RequestBuilder m)
Monad (RequestBuilder m) =>
(forall a. IO a -> RequestBuilder m a)
-> MonadIO (RequestBuilder m)
IO a -> RequestBuilder m a
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 :: IO a -> RequestBuilder m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> RequestBuilder m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (RequestBuilder m)
MonadIO
, MonadState Request
, m a -> RequestBuilder m a
(forall (m :: * -> *) a. Monad m => m a -> RequestBuilder m a)
-> MonadTrans RequestBuilder
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 :: 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 <- [ByteString] -> IO (InputStream ByteString)
forall c. [c] -> IO (InputStream c)
Streams.fromList ([ByteString] -> IO (InputStream ByteString))
-> [ByteString] -> IO (InputStream ByteString)
forall a b. (a -> b) -> a -> b
$! []
Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> IO Request) -> Request -> IO Request
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 "localhost"
"127.0.0.1"
60000
"127.0.0.1"
8080
"localhost"
Bool
False
Headers
H.empty
InputStream ByteString
b
Maybe Word64
forall a. Maybe a
Nothing
Method
GET
(1,1)
[]
""
"/"
"/"
""
Params
forall k a. Map k a
Map.empty
Params
forall k a. Map k a
Map.empty
Params
forall k a. Map k a
Map.empty
buildRequest :: MonadIO m => RequestBuilder m () -> m Request
buildRequest :: RequestBuilder m () -> m Request
buildRequest mm :: RequestBuilder m ()
mm = do
let (RequestBuilder m :: StateT Request m ()
m) = (RequestBuilder m ()
mm RequestBuilder m () -> RequestBuilder m () -> RequestBuilder m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RequestBuilder m ()
fixup)
Request
rq0 <- IO Request -> m Request
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Request
mkDefaultRequest
StateT Request m () -> Request -> m Request
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
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
Request
rq <- RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
if (Request -> Method
rqMethod Request
rq Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
GET Bool -> Bool -> Bool
|| Request -> Method
rqMethod Request
rq Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
DELETE Bool -> Bool -> Bool
||
Request -> Method
rqMethod Request
rq Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
HEAD)
then do
![ByteString]
_ <- IO [ByteString] -> RequestBuilder m [ByteString]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ByteString] -> RequestBuilder m [ByteString])
-> IO [ByteString] -> RequestBuilder m [ByteString]
forall a b. (a -> b) -> a -> b
$ InputStream ByteString -> IO [ByteString]
forall a. InputStream a -> IO [a]
Streams.toList (InputStream ByteString -> IO [ByteString])
-> InputStream ByteString -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ Request -> InputStream ByteString
rqBody Request
rq
!InputStream ByteString
b <- IO (InputStream ByteString)
-> RequestBuilder m (InputStream ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (InputStream ByteString)
-> RequestBuilder m (InputStream ByteString))
-> IO (InputStream ByteString)
-> RequestBuilder m (InputStream ByteString)
forall a b. (a -> b) -> a -> b
$ [ByteString] -> IO (InputStream ByteString)
forall c. [c] -> IO (InputStream c)
Streams.fromList ([ByteString] -> IO (InputStream ByteString))
-> [ByteString] -> IO (InputStream ByteString)
forall a b. (a -> b) -> a -> b
$! []
let rq' :: Request
rq' = CI ByteString -> Request -> Request
forall a. HasHeaders a => CI ByteString -> a -> a
deleteHeader "Content-Type" (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$
Request
rq { rqBody :: InputStream ByteString
rqBody = InputStream ByteString
b }
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' { rqContentLength :: Maybe Word64
rqContentLength = Maybe Word64
forall a. Maybe a
Nothing }
else () -> RequestBuilder m ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> RequestBuilder m ()) -> () -> RequestBuilder m ()
forall a b. (a -> b) -> a -> b
$! ()
fixupCL :: RequestBuilder m ()
fixupCL = do
Request
rq <- RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
RequestBuilder m ()
-> (Word64 -> RequestBuilder m ())
-> Maybe Word64
-> RequestBuilder m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (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 ByteString -> Request -> Request
forall a. HasHeaders a => CI ByteString -> a -> a
deleteHeader "Content-Length" Request
rq)
(\cl :: 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 ByteString -> ByteString -> Request -> Request
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
H.setHeader "Content-Length"
(String -> ByteString
S.pack (Word64 -> String
forall a. Show a => a -> String
show Word64
cl)) Request
rq)
(Request -> Maybe Word64
rqContentLength Request
rq)
fixupParams :: RequestBuilder m ()
fixupParams = do
Request
rq <- RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
let !query :: ByteString
query = Request -> ByteString
rqQueryString Request
rq
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 = CI ByteString -> Request -> Maybe ByteString
forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader "Content-Type" Request
rq
(!Params
postParams, rq' :: Request
rq') <-
if Maybe ByteString
mbCT Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just "application/x-www-form-urlencoded"
then IO (Params, Request) -> RequestBuilder m (Params, Request)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Params, Request) -> RequestBuilder m (Params, Request))
-> IO (Params, Request) -> RequestBuilder m (Params, Request)
forall a b. (a -> b) -> a -> b
$ do
![ByteString]
l <- InputStream ByteString -> IO [ByteString]
forall a. InputStream a -> IO [a]
Streams.toList (InputStream ByteString -> IO [ByteString])
-> InputStream ByteString -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ Request -> InputStream ByteString
rqBody Request
rq
!InputStream ByteString
b <- [ByteString] -> IO (InputStream ByteString)
forall c. [c] -> IO (InputStream c)
Streams.fromList [ByteString]
l
(Params, Request) -> IO (Params, Request)
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 (Params, Request) -> RequestBuilder m (Params, Request)
forall (m :: * -> *) a. Monad m => a -> m a
return (Params
forall k a. Map k a
Map.empty, Request
rq)
let !newParams :: Params
newParams = ([ByteString] -> [ByteString] -> [ByteString])
-> Params -> Params -> Params
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (([ByteString] -> [ByteString] -> [ByteString])
-> [ByteString] -> [ByteString] -> [ByteString]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
(++)) Params
queryParams Params
postParams
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' { rqParams :: Params
rqParams = Params
newParams
, rqPostParams :: Params
rqPostParams = Params
postParams
, rqQueryParams :: Params
rqQueryParams = Params
queryParams }
fixupHost :: RequestBuilder m ()
fixupHost = do
Request
rq <- RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
case CI ByteString -> Request -> Maybe ByteString
forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
H.getHeader "Host" Request
rq of
Nothing -> do
let !hn :: ByteString
hn = Request -> ByteString
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 ByteString -> ByteString -> Request -> Request
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
H.setHeader "Host" ByteString
hn Request
rq
Just hn :: ByteString
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 :: ByteString
rqHostName = ByteString
hn }
type MultipartParams = [(ByteString, MultipartParam)]
data MultipartParam =
FormData [ByteString]
| Files [FileData]
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
showList :: [MultipartParam] -> ShowS
$cshowList :: [MultipartParam] -> ShowS
show :: MultipartParam -> String
$cshow :: MultipartParam -> String
showsPrec :: Int -> MultipartParam -> ShowS
$cshowsPrec :: Int -> MultipartParam -> ShowS
Show)
data FileData = FileData {
FileData -> ByteString
fdFileName :: ByteString
, FileData -> ByteString
fdContentType :: ByteString
, FileData -> ByteString
fdContents :: ByteString
}
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
showList :: [FileData] -> ShowS
$cshowList :: [FileData] -> ShowS
show :: FileData -> String
$cshow :: FileData -> String
showsPrec :: Int -> FileData -> ShowS
$cshowsPrec :: Int -> FileData -> ShowS
Show)
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
showList :: [RequestType] -> ShowS
$cshowList :: [RequestType] -> ShowS
show :: RequestType -> String
$cshow :: RequestType -> String
showsPrec :: Int -> RequestType -> ShowS
$cshowsPrec :: Int -> RequestType -> ShowS
Show)
setRequestType :: MonadIO m => RequestType -> RequestBuilder m ()
setRequestType :: RequestType -> RequestBuilder m ()
setRequestType GetRequest = do
Request
rq <- RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
InputStream ByteString
body <- IO (InputStream ByteString)
-> RequestBuilder m (InputStream ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (InputStream ByteString)
-> RequestBuilder m (InputStream ByteString))
-> IO (InputStream ByteString)
-> RequestBuilder m (InputStream ByteString)
forall a b. (a -> b) -> a -> b
$ [ByteString] -> IO (InputStream ByteString)
forall c. [c] -> IO (InputStream c)
Streams.fromList ([ByteString] -> IO (InputStream ByteString))
-> [ByteString] -> IO (InputStream ByteString)
forall a b. (a -> b) -> a -> b
$! []
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 { rqMethod :: Method
rqMethod = Method
GET
, rqContentLength :: Maybe Word64
rqContentLength = Maybe Word64
forall a. Maybe a
Nothing
, rqBody :: InputStream ByteString
rqBody = InputStream ByteString
body
}
setRequestType DeleteRequest = do
Request
rq <- RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
InputStream ByteString
body <- IO (InputStream ByteString)
-> RequestBuilder m (InputStream ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (InputStream ByteString)
-> RequestBuilder m (InputStream ByteString))
-> IO (InputStream ByteString)
-> RequestBuilder m (InputStream ByteString)
forall a b. (a -> b) -> a -> b
$ [ByteString] -> IO (InputStream ByteString)
forall c. [c] -> IO (InputStream c)
Streams.fromList ([ByteString] -> IO (InputStream ByteString))
-> [ByteString] -> IO (InputStream ByteString)
forall a b. (a -> b) -> a -> b
$! []
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 { rqMethod :: Method
rqMethod = Method
DELETE
, rqContentLength :: Maybe Word64
rqContentLength = Maybe Word64
forall a. Maybe a
Nothing
, rqBody :: InputStream ByteString
rqBody = InputStream ByteString
body
}
setRequestType (RequestWithRawBody m :: Method
m b :: ByteString
b) = do
Request
rq <- RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
InputStream ByteString
body <- IO (InputStream ByteString)
-> RequestBuilder m (InputStream ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (InputStream ByteString)
-> RequestBuilder m (InputStream ByteString))
-> IO (InputStream ByteString)
-> RequestBuilder m (InputStream ByteString)
forall a b. (a -> b) -> a -> b
$ [ByteString] -> IO (InputStream ByteString)
forall c. [c] -> IO (InputStream c)
Streams.fromList ([ByteString] -> IO (InputStream ByteString))
-> [ByteString] -> IO (InputStream ByteString)
forall a b. (a -> b) -> a -> b
$! [ ByteString
b ]
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 { rqMethod :: Method
rqMethod = Method
m
, rqContentLength :: Maybe Word64
rqContentLength = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just (Word64 -> Maybe Word64) -> Word64 -> Maybe Word64
forall a b. (a -> b) -> a -> b
$ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
S.length ByteString
b
, rqBody :: InputStream ByteString
rqBody = InputStream ByteString
body
}
setRequestType (MultipartPostRequest fp :: MultipartParams
fp) = MultipartParams -> RequestBuilder m ()
forall (m :: * -> *).
MonadIO m =>
MultipartParams -> RequestBuilder m ()
encodeMultipart MultipartParams
fp
setRequestType (UrlEncodedPostRequest fp :: Params
fp) = do
Request
rq <- (Request -> Request)
-> RequestBuilder m Request -> RequestBuilder m Request
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (CI ByteString -> ByteString -> Request -> Request
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
H.setHeader "Content-Type"
"application/x-www-form-urlencoded") RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
let b :: ByteString
b = Params -> ByteString
printUrlEncoded Params
fp
InputStream ByteString
body <- IO (InputStream ByteString)
-> RequestBuilder m (InputStream ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (InputStream ByteString)
-> RequestBuilder m (InputStream ByteString))
-> IO (InputStream ByteString)
-> RequestBuilder m (InputStream ByteString)
forall a b. (a -> b) -> a -> b
$ [ByteString] -> IO (InputStream ByteString)
forall c. [c] -> IO (InputStream c)
Streams.fromList ([ByteString] -> IO (InputStream ByteString))
-> [ByteString] -> IO (InputStream ByteString)
forall a b. (a -> b) -> a -> b
$! [ByteString
b]
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 { rqMethod :: Method
rqMethod = Method
POST
, rqContentLength :: Maybe Word64
rqContentLength = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just (Word64 -> Maybe Word64) -> Word64 -> Maybe Word64
forall a b. (a -> b) -> a -> b
$! Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
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 :: m ByteString
makeBoundary = do
[Word8]
xs <- IO [Word8] -> m [Word8]
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 16 IO Word8
randomWord8
let x :: ByteString
x = String -> ByteString
S.pack (String -> ByteString) -> String -> ByteString
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
ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> m ByteString) -> ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S.concat [ "snap-boundary-", ByteString -> ByteString
encode ByteString
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 (\c :: 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
.&. 0xff) IO Int
forall a. Random a => IO a
randomIO
table :: Vector Char
table = String -> Vector Char
forall a. [a] -> Vector a
V.fromList [ '0', '1', '2', '3', '4', '5', '6', '7', '8', '9'
, 'a', 'b', 'c', 'd', 'e', 'f' ]
encode :: ByteString -> ByteString
encode = Builder -> ByteString
toByteString (Builder -> ByteString)
-> (ByteString -> Builder) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Builder -> Word8 -> Builder) -> Builder -> ByteString -> Builder
forall a. (a -> Word8 -> a) -> a -> ByteString -> 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 m :: Builder
m c :: Word8
c = let low :: Word8
low = Word8
c Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0xf
hi :: Word8
hi = (Word8
c Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0xf0) Word8 -> Int -> Word8
`shR` 4
k :: Word8 -> Builder
k = \i :: 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
boundary :: ByteString
boundary name :: ByteString
name =
[Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Builder
byteString ByteString
boundary
, ByteString -> Builder
byteString "\r\ncontent-disposition: form-data"
, ByteString -> Builder
byteString "; name=\""
, ByteString -> Builder
byteString ByteString
name
, ByteString -> Builder
byteString "\"\r\n" ]
encodeFormData :: ByteString -> ByteString -> [ByteString] -> IO Builder
encodeFormData :: ByteString -> ByteString -> [ByteString] -> IO Builder
encodeFormData boundary :: ByteString
boundary name :: ByteString
name vals :: [ByteString]
vals =
case [ByteString]
vals of
[] -> Builder -> IO Builder
forall (m :: * -> *) a. Monad m => a -> m a
return Builder
forall a. Monoid a => a
mempty
[v :: ByteString
v] -> Builder -> IO Builder
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
, ByteString -> Builder
byteString ByteString
v
, ByteString -> Builder
byteString "\r\n--" ]
_ -> IO Builder
multi
where
hdr :: Builder
hdr = ByteString -> ByteString -> Builder
multipartHeader ByteString
boundary ByteString
name
cr :: Builder
cr = ByteString -> Builder
byteString "\r\n"
oneVal :: ByteString -> ByteString -> Builder
oneVal b :: ByteString
b v :: ByteString
v = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Builder
byteString ByteString
b
, Builder
cr
, Builder
cr
, ByteString -> Builder
byteString ByteString
v
, ByteString -> Builder
byteString "\r\n--" ]
multi :: IO Builder
multi = do
ByteString
b <- IO ByteString
forall (m :: * -> *). MonadIO m => m ByteString
makeBoundary
Builder -> IO Builder
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
, ByteString -> Builder
multipartMixed ByteString
b
, Builder
cr
, ByteString -> Builder
byteString "--"
, [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ((ByteString -> Builder) -> [ByteString] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> ByteString -> Builder
oneVal ByteString
b) [ByteString]
vals)
, ByteString -> Builder
byteString ByteString
b
, ByteString -> Builder
byteString "--\r\n--" ]
multipartMixed :: ByteString -> Builder
multipartMixed :: ByteString -> Builder
multipartMixed b :: ByteString
b = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Builder
byteString "Content-Type: multipart/mixed"
, ByteString -> Builder
byteString "; boundary="
, ByteString -> Builder
byteString ByteString
b
, ByteString -> Builder
byteString "\r\n" ]
encodeFiles :: ByteString -> ByteString -> [FileData] -> IO Builder
encodeFiles :: ByteString -> ByteString -> [FileData] -> IO Builder
encodeFiles boundary :: ByteString
boundary name :: ByteString
name files :: [FileData]
files =
case [FileData]
files of
[] -> Builder -> IO Builder
forall (m :: * -> *) a. Monad m => a -> m a
return Builder
forall a. Monoid a => a
mempty
_ -> do
ByteString
b <- IO ByteString
forall (m :: * -> *). MonadIO m => m ByteString
makeBoundary
Builder -> IO Builder
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
, ByteString -> Builder
multipartMixed ByteString
b
, Builder
cr
, ByteString -> Builder
byteString "--"
, [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ((FileData -> Builder) -> [FileData] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> FileData -> Builder
oneVal ByteString
b) [FileData]
files)
, ByteString -> Builder
byteString ByteString
b
, ByteString -> Builder
byteString "--\r\n--"
]
where
contentDisposition :: ByteString -> Builder
contentDisposition fn :: ByteString
fn = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [
ByteString -> Builder
byteString "Content-Disposition: attachment"
, ByteString -> Builder
byteString "; filename=\""
, ByteString -> Builder
byteString ByteString
fn
, ByteString -> Builder
byteString "\"\r\n"
]
contentType :: ByteString -> Builder
contentType ct :: ByteString
ct = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [
ByteString -> Builder
byteString "Content-Type: "
, ByteString -> Builder
byteString ByteString
ct
, Builder
cr
]
oneVal :: ByteString -> FileData -> Builder
oneVal b :: ByteString
b fd :: FileData
fd =
[Builder] -> Builder
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 "Content-Transfer-Encoding: binary\r\n"
, Builder
cr
, ByteString -> Builder
byteString ByteString
contents
, ByteString -> Builder
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 "\r\n"
encodeMultipart :: MonadIO m => MultipartParams -> RequestBuilder m ()
encodeMultipart :: MultipartParams -> RequestBuilder m ()
encodeMultipart kvps :: MultipartParams
kvps = do
ByteString
boundary <- IO ByteString -> RequestBuilder m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> RequestBuilder m ByteString)
-> IO ByteString -> RequestBuilder m ByteString
forall a b. (a -> b) -> a -> b
$ IO ByteString
forall (m :: * -> *). MonadIO m => m ByteString
makeBoundary
[Builder]
builders <- IO [Builder] -> RequestBuilder m [Builder]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Builder] -> RequestBuilder m [Builder])
-> IO [Builder] -> RequestBuilder m [Builder]
forall a b. (a -> b) -> a -> b
$ ((ByteString, MultipartParam) -> IO Builder)
-> MultipartParams -> IO [Builder]
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 (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (ByteString -> Builder
byteString "--" Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: [Builder]
builders)
Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
finalBoundary ByteString
boundary
Request
rq0 <- RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
InputStream ByteString
body <- IO (InputStream ByteString)
-> RequestBuilder m (InputStream ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (InputStream ByteString)
-> RequestBuilder m (InputStream ByteString))
-> IO (InputStream ByteString)
-> RequestBuilder m (InputStream ByteString)
forall a b. (a -> b) -> a -> b
$ [ByteString] -> IO (InputStream ByteString)
forall c. [c] -> IO (InputStream c)
Streams.fromList [ByteString
b]
let rq :: Request
rq = CI ByteString -> ByteString -> Request -> Request
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
H.setHeader "Content-Type"
(ByteString -> ByteString -> ByteString
S.append "multipart/form-data; boundary=" ByteString
boundary)
Request
rq0
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 { rqMethod :: Method
rqMethod = Method
POST
, rqContentLength :: Maybe Word64
rqContentLength = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just (Word64 -> Maybe Word64) -> Word64 -> Maybe Word64
forall a b. (a -> b) -> a -> b
$ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
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 b :: ByteString
b = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ByteString -> Builder
byteString ByteString
b, ByteString -> Builder
byteString "--\r\n"]
handleOne :: ByteString -> (ByteString, MultipartParam) -> IO Builder
handleOne boundary :: ByteString
boundary (name :: ByteString
name, mp :: MultipartParam
mp) =
case MultipartParam
mp of
(FormData vals :: [ByteString]
vals) -> ByteString -> ByteString -> [ByteString] -> IO Builder
encodeFormData ByteString
boundary ByteString
name [ByteString]
vals
(Files fs :: [FileData]
fs) -> ByteString -> ByteString -> [FileData] -> IO Builder
encodeFiles ByteString
boundary ByteString
name [FileData]
fs
fixupURI :: Monad m => RequestBuilder m ()
fixupURI :: RequestBuilder m ()
fixupURI = do
Request
rq <- RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
Request -> ByteString -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
Request -> ByteString -> RequestBuilder m ()
upd Request
rq (ByteString -> RequestBuilder m ())
-> ByteString -> RequestBuilder m ()
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 ""
else ByteString -> ByteString -> ByteString
S.append "?" ByteString
q
]
where
upd :: Request -> ByteString -> RequestBuilder m ()
upd rq :: Request
rq !ByteString
u = let !ByteString
_ = Request -> ByteString
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 :: ByteString
rqURI = ByteString
u }
setQueryStringRaw :: Monad m => ByteString -> RequestBuilder m ()
setQueryStringRaw :: ByteString -> RequestBuilder m ()
setQueryStringRaw r :: ByteString
r = do
Request
rq <- RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
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 { rqQueryString :: ByteString
rqQueryString = ByteString
r }
RequestBuilder m ()
forall (m :: * -> *). Monad m => RequestBuilder m ()
fixupURI
setQueryString :: Monad m => Params -> RequestBuilder m ()
setQueryString :: Params -> RequestBuilder m ()
setQueryString p :: Params
p = ByteString -> RequestBuilder m ()
forall (m :: * -> *). Monad m => ByteString -> RequestBuilder m ()
setQueryStringRaw (ByteString -> RequestBuilder m ())
-> ByteString -> RequestBuilder m ()
forall a b. (a -> b) -> a -> b
$ Params -> ByteString
printUrlEncoded Params
p
setHeader :: (Monad m) => CI ByteString -> ByteString -> RequestBuilder m ()
k :: CI ByteString
k v :: ByteString
v = (Request -> Request) -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
(Request -> Request) -> RequestBuilder m ()
rModify (CI ByteString -> ByteString -> Request -> Request
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
H.setHeader CI ByteString
k ByteString
v)
addHeader :: (Monad m) => CI ByteString -> ByteString -> RequestBuilder m ()
k :: CI ByteString
k v :: ByteString
v = (Request -> Request) -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
(Request -> Request) -> RequestBuilder m ()
rModify (CI ByteString -> ByteString -> Request -> Request
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
H.addHeader CI ByteString
k ByteString
v)
addCookies :: (Monad m) => [Cookie] -> RequestBuilder m ()
addCookies :: [Cookie] -> RequestBuilder m ()
addCookies cookies :: [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
$ \rq :: Request
rq -> Request
rq { rqCookies :: [Cookie]
rqCookies = Request -> [Cookie]
rqCookies Request
rq [Cookie] -> [Cookie] -> [Cookie]
forall a. [a] -> [a] -> [a]
++ [Cookie]
cookies }
[Cookie]
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 :: [ByteString]
cstr = (Cookie -> ByteString) -> [Cookie] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Cookie -> ByteString
cookieToBS [Cookie]
allCookies
CI ByteString -> ByteString -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
CI ByteString -> ByteString -> RequestBuilder m ()
setHeader "Cookie" (ByteString -> RequestBuilder m ())
-> ByteString -> RequestBuilder m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString] -> ByteString
S.intercalate "; " [ByteString]
cstr
cookieToBS :: Cookie -> ByteString
cookieToBS :: Cookie -> ByteString
cookieToBS (Cookie k :: ByteString
k v :: ByteString
v !Maybe UTCTime
_ !Maybe ByteString
_ !Maybe ByteString
_ !Bool
_ !Bool
_) = ByteString
cookie
where
cookie :: ByteString
cookie = [ByteString] -> ByteString
S.concat [ByteString
k, "=", ByteString
v]
setContentType :: Monad m => ByteString -> RequestBuilder m ()
setContentType :: ByteString -> RequestBuilder m ()
setContentType c :: ByteString
c = (Request -> Request) -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
(Request -> Request) -> RequestBuilder m ()
rModify (CI ByteString -> ByteString -> Request -> Request
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
H.setHeader "Content-Type" ByteString
c)
setSecure :: Monad m => Bool -> RequestBuilder m ()
setSecure :: Bool -> RequestBuilder m ()
setSecure b :: 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
$ \rq :: Request
rq -> Request
rq { rqIsSecure :: Bool
rqIsSecure = Bool
b }
setHttpVersion :: Monad m => (Int,Int) -> RequestBuilder m ()
setHttpVersion :: HttpVersion -> RequestBuilder m ()
setHttpVersion v :: 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
$ \rq :: Request
rq -> Request
rq { rqVersion :: HttpVersion
rqVersion = HttpVersion
v }
setRequestPath :: Monad m => ByteString -> RequestBuilder m ()
setRequestPath :: ByteString -> RequestBuilder m ()
setRequestPath p0 :: ByteString
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
$ \rq :: Request
rq -> Request
rq { rqContextPath :: ByteString
rqContextPath = "/"
, rqPathInfo :: ByteString
rqPathInfo = ByteString
p }
RequestBuilder m ()
forall (m :: * -> *). Monad m => RequestBuilder m ()
fixupURI
where
p :: ByteString
p = if ByteString -> ByteString -> Bool
S.isPrefixOf "/" ByteString
p0 then Int -> ByteString -> ByteString
S.drop 1 ByteString
p0 else ByteString
p0
get :: MonadIO m =>
ByteString
-> Params
-> RequestBuilder m ()
get :: ByteString -> Params -> RequestBuilder m ()
get uri :: ByteString
uri params :: 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
ByteString -> RequestBuilder m ()
forall (m :: * -> *). Monad m => ByteString -> RequestBuilder m ()
setRequestPath ByteString
uri
delete :: MonadIO m =>
ByteString
-> Params
-> RequestBuilder m ()
delete :: ByteString -> Params -> RequestBuilder m ()
delete uri :: ByteString
uri params :: 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
ByteString -> RequestBuilder m ()
forall (m :: * -> *). Monad m => ByteString -> RequestBuilder m ()
setRequestPath ByteString
uri
postUrlEncoded :: MonadIO m =>
ByteString
-> Params
-> RequestBuilder m ()
postUrlEncoded :: ByteString -> Params -> RequestBuilder m ()
postUrlEncoded uri :: ByteString
uri params :: 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
ByteString -> RequestBuilder m ()
forall (m :: * -> *). Monad m => ByteString -> RequestBuilder m ()
setRequestPath ByteString
uri
postMultipart :: MonadIO m =>
ByteString
-> MultipartParams
-> RequestBuilder m ()
postMultipart :: ByteString -> MultipartParams -> RequestBuilder m ()
postMultipart uri :: ByteString
uri params :: 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
ByteString -> RequestBuilder m ()
forall (m :: * -> *). Monad m => ByteString -> RequestBuilder m ()
setRequestPath ByteString
uri
put :: MonadIO m =>
ByteString
-> ByteString
-> ByteString
-> RequestBuilder m ()
put :: ByteString -> ByteString -> ByteString -> RequestBuilder m ()
put uri :: ByteString
uri contentType :: ByteString
contentType putData :: ByteString
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 -> ByteString -> RequestType
RequestWithRawBody Method
PUT ByteString
putData
CI ByteString -> ByteString -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
CI ByteString -> ByteString -> RequestBuilder m ()
setHeader "Content-Type" ByteString
contentType
ByteString -> RequestBuilder m ()
forall (m :: * -> *). Monad m => ByteString -> RequestBuilder m ()
setRequestPath ByteString
uri
postRaw :: MonadIO m =>
ByteString
-> ByteString
-> ByteString
-> RequestBuilder m ()
postRaw :: ByteString -> ByteString -> ByteString -> RequestBuilder m ()
postRaw uri :: ByteString
uri contentType :: ByteString
contentType postData :: ByteString
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 -> ByteString -> RequestType
RequestWithRawBody Method
POST ByteString
postData
ByteString -> RequestBuilder m ()
forall (m :: * -> *). Monad m => ByteString -> RequestBuilder m ()
setContentType ByteString
contentType
ByteString -> RequestBuilder m ()
forall (m :: * -> *). Monad m => ByteString -> RequestBuilder m ()
setRequestPath ByteString
uri
runHandler :: MonadIO m =>
RequestBuilder m ()
-> Snap a
-> m Response
runHandler :: 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 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 rq :: Request
rq s :: Snap a
s = IO Response -> m Response
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 :: Response
rsp) <- Snap a
-> (ByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> Request
-> IO (Request, Response)
forall a.
Snap a
-> (ByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> Request
-> IO (Request, Response)
runSnap Snap a
s (\x :: ByteString
x -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$! (ByteString
x ByteString -> () -> ()
forall a b. a -> b -> b
`seq` ()))
(\f :: Int -> Int
f -> let !Int
_ = Int -> Int
f 0 in () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$! ())
Request
rq
Request -> Response -> IO Response
fixupResponse Request
rq Response
rsp
runHandlerM :: (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)
-> RequestBuilder m () -> n b -> m Response
runHandlerM rSnap :: forall a. Request -> n a -> m Response
rSnap rBuilder :: RequestBuilder m ()
rBuilder snap :: n b
snap = do
Request
rq <- RequestBuilder m () -> m Request
forall (m :: * -> *). MonadIO m => RequestBuilder m () -> m Request
buildRequest RequestBuilder m ()
rBuilder
Response
rsp <- Request -> n b -> m Response
forall a. Request -> n a -> m Response
rSnap Request
rq n b
snap
ByteString
t1 <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO EpochTime
epochTime IO EpochTime -> (EpochTime -> IO ByteString) -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= EpochTime -> IO ByteString
formatHttpTime)
Response -> m Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> m Response) -> Response -> m Response
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString -> Response -> Response
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
H.setHeader "Date" ByteString
t1
(Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString -> Response -> Response
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
H.setHeader "Server" "Snap/test"
(Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$ if Response -> Maybe Word64
rspContentLength Response
rsp Maybe Word64 -> Maybe Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Word64
forall a. Maybe a
Nothing Bool -> Bool -> Bool
&&
Request -> HttpVersion
rqVersion Request
rq HttpVersion -> HttpVersion -> Bool
forall a. Ord a => a -> a -> Bool
< (1,1)
then CI ByteString -> ByteString -> Response -> Response
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
H.setHeader "Connection" "close" Response
rsp
else Response
rsp
evalHandler :: MonadIO m =>
RequestBuilder m ()
-> Snap a
-> m a
evalHandler :: 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 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 rq :: Request
rq s :: Snap a
s = 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
-> (ByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> Request
-> IO a
forall a.
Snap a
-> (ByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> Request
-> IO a
evalSnap Snap a
s (IO () -> ByteString -> IO ()
forall a b. a -> b -> a
const (IO () -> ByteString -> IO ()) -> IO () -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
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 (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$! ())
Request
rq
evalHandlerM :: (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)
-> RequestBuilder m () -> n b -> m b
evalHandlerM rSnap :: forall a. Request -> n a -> m a
rSnap rBuilder :: RequestBuilder m ()
rBuilder snap :: n b
snap = do
Request
rq <- RequestBuilder m () -> m Request
forall (m :: * -> *). MonadIO m => RequestBuilder m () -> m Request
buildRequest RequestBuilder m ()
rBuilder
Request -> n b -> m b
forall a. Request -> n a -> m a
rSnap Request
rq n b
snap
responseToString :: Response -> IO ByteString
responseToString :: Response -> IO ByteString
responseToString resp :: 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 :: OutputStream Builder
listOut, grab :: IO [Builder]
grab) <- IO (OutputStream Builder, IO [Builder])
forall c. IO (OutputStream c, IO [c])
Streams.listOutputStream
IO (OutputStream Builder) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (OutputStream Builder) -> IO ())
-> IO (OutputStream Builder) -> IO ()
forall a b. (a -> b) -> a -> b
$ StreamProc
act OutputStream Builder
listOut
Builder
builder <- ([Builder] -> Builder) -> IO [Builder] -> IO Builder
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat IO [Builder]
grab
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$! Builder -> ByteString
toByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Response -> Builder
forall a. Show a => a -> Builder
fromShow Response
resp Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
builder
requestToString :: Request -> IO ByteString
requestToString :: Request -> IO ByteString
requestToString req0 :: Request
req0 = do
(req :: Request
req, is :: InputStream ByteString
is) <- IO (Request, InputStream ByteString)
maybeChunk
ByteString
body <- ([ByteString] -> ByteString) -> IO [ByteString] -> IO ByteString
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [ByteString] -> ByteString
S.concat (IO [ByteString] -> IO ByteString)
-> IO [ByteString] -> IO ByteString
forall a b. (a -> b) -> a -> b
$ InputStream ByteString -> IO [ByteString]
forall a. InputStream a -> IO [a]
Streams.toList InputStream ByteString
is
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$! Builder -> ByteString
toByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ Builder
statusLine
, [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> (Headers -> [Builder]) -> Headers -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CI ByteString, ByteString) -> Builder)
-> [(CI ByteString, ByteString)] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (CI ByteString, ByteString) -> Builder
oneHeader ([(CI ByteString, ByteString)] -> [Builder])
-> (Headers -> [(CI ByteString, ByteString)])
-> Headers
-> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Headers -> [(CI ByteString, ByteString)]
H.toList
(Headers -> Builder) -> Headers -> Builder
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 CI ByteString -> Request -> Maybe ByteString
forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader "Transfer-Encoding" Request
req0 Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just "chunked"
then do
let req :: Request
req = CI ByteString -> Request -> Request
forall a. HasHeaders a => CI ByteString -> a -> a
deleteHeader "Content-Length" (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$
Request
req0 { rqContentLength :: Maybe Word64
rqContentLength = Maybe Word64
forall a. Maybe a
Nothing }
InputStream ByteString
is' <- (ByteString -> ByteString)
-> InputStream ByteString -> IO (InputStream ByteString)
forall a b. (a -> b) -> InputStream a -> IO (InputStream b)
Streams.map ByteString -> ByteString
chunk (InputStream ByteString -> IO (InputStream ByteString))
-> InputStream ByteString -> IO (InputStream ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> InputStream ByteString
rqBody Request
req
InputStream ByteString
out <- IO (InputStream ByteString)
eof IO (InputStream ByteString)
-> (InputStream ByteString -> IO (InputStream ByteString))
-> IO (InputStream ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InputStream ByteString
-> InputStream ByteString -> IO (InputStream ByteString)
forall a. InputStream a -> InputStream a -> IO (InputStream a)
Streams.appendInputStream InputStream ByteString
is'
(Request, InputStream ByteString)
-> IO (Request, InputStream ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Request
req, InputStream ByteString
out)
else (Request, InputStream ByteString)
-> IO (Request, InputStream ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Request
req0, Request -> InputStream ByteString
rqBody Request
req0)
where
chunk :: ByteString -> ByteString
chunk s :: ByteString
s = [ByteString] -> ByteString
S.concat [ String -> ByteString
S.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Int -> String
forall r. PrintfType r => String -> r
printf "%x\r\n" (ByteString -> Int
S.length ByteString
s)
, ByteString
s
, "\r\n"
]
eof :: IO (InputStream ByteString)
eof = [ByteString] -> IO (InputStream ByteString)
forall c. [c] -> IO (InputStream c)
Streams.fromList ["0\r\n\r\n"]
(v1 :: Int
v1,v2 :: Int
v2) = Request -> HttpVersion
rqVersion Request
req0
crlf :: Builder
crlf = Char -> Builder
char8 '\r' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
char8 '\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 ' '
, ByteString -> Builder
byteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rqURI Request
req0
, ByteString -> Builder
byteString " HTTP/"
, Int -> Builder
forall a. Show a => a -> Builder
fromShow Int
v1
, Char -> Builder
char8 '.'
, Int -> Builder
forall a. Show a => a -> Builder
fromShow Int
v2
, Builder
crlf
]
oneHeader :: (CI ByteString, ByteString) -> Builder
oneHeader (k :: CI ByteString
k,v :: ByteString
v) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Builder
byteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString
forall s. CI s -> s
original CI ByteString
k
, ByteString -> Builder
byteString ": "
, ByteString -> Builder
byteString ByteString
v
, Builder
crlf
]
rGet :: Monad m => RequestBuilder m Request
rGet :: 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 :: Request -> RequestBuilder m ()
rPut s :: 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 :: (Request -> Request) -> RequestBuilder m ()
rModify f :: 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 -> ByteString
toByteString = [ByteString] -> ByteString
S.concat ([ByteString] -> ByteString)
-> (Builder -> [ByteString]) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks (ByteString -> [ByteString])
-> (Builder -> ByteString) -> Builder -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString
fromShow :: Show a => a -> Builder
fromShow :: 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