{-# 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
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
InputStream StrictByteString
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
$! []
Request -> IO Request
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> IO Request) -> Request -> IO Request
forall a b. (a -> b) -> a -> b
$ StrictByteString
-> StrictByteString
-> Int
-> StrictByteString
-> Int
-> StrictByteString
-> Bool
-> Headers
-> InputStream StrictByteString
-> Maybe Word64
-> Method
-> HttpVersion
-> [Cookie]
-> StrictByteString
-> StrictByteString
-> StrictByteString
-> StrictByteString
-> Params
-> Params
-> Params
-> Request
Request StrictByteString
"localhost"
StrictByteString
"127.0.0.1"
Int
60000
StrictByteString
"127.0.0.1"
Int
8080
StrictByteString
"localhost"
Bool
False
Headers
H.empty
InputStream StrictByteString
b
Maybe Word64
forall a. Maybe a
Nothing
Method
GET
(Int
1,Int
1)
[]
StrictByteString
""
StrictByteString
"/"
StrictByteString
"/"
StrictByteString
""
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 :: 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)
Request
rq0 <- IO Request -> m Request
forall a. IO a -> m a
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
![StrictByteString]
_ <- 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
$ InputStream StrictByteString -> IO [StrictByteString]
forall a. InputStream a -> IO [a]
Streams.toList (InputStream StrictByteString -> IO [StrictByteString])
-> InputStream StrictByteString -> IO [StrictByteString]
forall a b. (a -> b) -> a -> b
$ Request -> InputStream StrictByteString
rqBody Request
rq
!InputStream StrictByteString
b <- IO (InputStream StrictByteString)
-> RequestBuilder m (InputStream StrictByteString)
forall a. IO a -> RequestBuilder m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (InputStream StrictByteString)
-> RequestBuilder m (InputStream StrictByteString))
-> IO (InputStream StrictByteString)
-> RequestBuilder m (InputStream StrictByteString)
forall a b. (a -> b) -> a -> 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
$! []
let rq' :: Request
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 }
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 = Nothing }
else () -> RequestBuilder m ()
forall a. a -> RequestBuilder m a
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 StrictByteString -> Request -> Request
forall a. HasHeaders a => CI StrictByteString -> a -> a
deleteHeader CI StrictByteString
"Content-Length" Request
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)
(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 :: StrictByteString
query = Request -> StrictByteString
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 = StrictByteString -> Params
parseUrlEncoded StrictByteString
query
let !mbCT :: Maybe StrictByteString
mbCT = CI StrictByteString -> Request -> Maybe StrictByteString
forall a.
HasHeaders a =>
CI StrictByteString -> a -> Maybe StrictByteString
getHeader CI StrictByteString
"Content-Type" Request
rq
(!Params
postParams, Request
rq') <-
if Maybe StrictByteString
mbCT Maybe StrictByteString -> Maybe StrictByteString -> Bool
forall a. Eq a => a -> a -> Bool
== StrictByteString -> Maybe StrictByteString
forall a. a -> Maybe a
Just StrictByteString
"application/x-www-form-urlencoded"
then IO (Params, Request) -> RequestBuilder m (Params, Request)
forall a. IO a -> RequestBuilder m a
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
![StrictByteString]
l <- InputStream StrictByteString -> IO [StrictByteString]
forall a. InputStream a -> IO [a]
Streams.toList (InputStream StrictByteString -> IO [StrictByteString])
-> InputStream StrictByteString -> IO [StrictByteString]
forall a b. (a -> b) -> a -> b
$ Request -> InputStream StrictByteString
rqBody Request
rq
!InputStream StrictByteString
b <- [StrictByteString] -> IO (InputStream StrictByteString)
forall c. [c] -> IO (InputStream c)
Streams.fromList [StrictByteString]
l
(Params, Request) -> IO (Params, Request)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (StrictByteString -> Params
parseUrlEncoded ([StrictByteString] -> StrictByteString
S.concat [StrictByteString]
l), Request
rq { rqBody = b })
else (Params, Request) -> RequestBuilder m (Params, Request)
forall a. a -> RequestBuilder m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Params
forall k a. Map k a
Map.empty, Request
rq)
let !newParams :: Params
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
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 = newParams
, rqPostParams = postParams
, rqQueryParams = queryParams }
fixupHost :: RequestBuilder m ()
fixupHost = do
Request
rq <- RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
case CI StrictByteString -> Request -> Maybe StrictByteString
forall a.
HasHeaders a =>
CI StrictByteString -> a -> Maybe StrictByteString
H.getHeader CI StrictByteString
"Host" Request
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 }
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
$cshowsPrec :: Int -> MultipartParam -> ShowS
showsPrec :: Int -> MultipartParam -> ShowS
$cshow :: MultipartParam -> String
show :: MultipartParam -> String
$cshowList :: [MultipartParam] -> ShowS
showList :: [MultipartParam] -> ShowS
Show)
data FileData = FileData {
FileData -> StrictByteString
fdFileName :: ByteString
, FileData -> StrictByteString
fdContentType :: ByteString
, FileData -> StrictByteString
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
$cshowsPrec :: Int -> FileData -> ShowS
showsPrec :: Int -> FileData -> ShowS
$cshow :: FileData -> String
show :: FileData -> String
$cshowList :: [FileData] -> ShowS
showList :: [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
$cshowsPrec :: Int -> RequestType -> ShowS
showsPrec :: Int -> RequestType -> ShowS
$cshow :: RequestType -> String
show :: RequestType -> String
$cshowList :: [RequestType] -> ShowS
showList :: [RequestType] -> ShowS
Show)
setRequestType :: MonadIO m => RequestType -> RequestBuilder m ()
setRequestType :: forall (m :: * -> *).
MonadIO m =>
RequestType -> RequestBuilder m ()
setRequestType RequestType
GetRequest = do
Request
rq <- RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
InputStream StrictByteString
body <- IO (InputStream StrictByteString)
-> RequestBuilder m (InputStream StrictByteString)
forall a. IO a -> RequestBuilder m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (InputStream StrictByteString)
-> RequestBuilder m (InputStream StrictByteString))
-> IO (InputStream StrictByteString)
-> RequestBuilder m (InputStream StrictByteString)
forall a b. (a -> b) -> a -> 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
$! []
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 = GET
, rqContentLength = Nothing
, rqBody = body
}
setRequestType RequestType
DeleteRequest = do
Request
rq <- RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
InputStream StrictByteString
body <- IO (InputStream StrictByteString)
-> RequestBuilder m (InputStream StrictByteString)
forall a. IO a -> RequestBuilder m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (InputStream StrictByteString)
-> RequestBuilder m (InputStream StrictByteString))
-> IO (InputStream StrictByteString)
-> RequestBuilder m (InputStream StrictByteString)
forall a b. (a -> b) -> a -> 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
$! []
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 = DELETE
, rqContentLength = Nothing
, rqBody = body
}
setRequestType (RequestWithRawBody Method
m StrictByteString
b) = do
Request
rq <- RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
InputStream StrictByteString
body <- IO (InputStream StrictByteString)
-> RequestBuilder m (InputStream StrictByteString)
forall a. IO a -> RequestBuilder m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (InputStream StrictByteString)
-> RequestBuilder m (InputStream StrictByteString))
-> IO (InputStream StrictByteString)
-> RequestBuilder m (InputStream StrictByteString)
forall a b. (a -> b) -> a -> 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
$! [ StrictByteString
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 = 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
Request
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 :: StrictByteString
b = Params -> StrictByteString
printUrlEncoded Params
fp
InputStream StrictByteString
body <- IO (InputStream StrictByteString)
-> RequestBuilder m (InputStream StrictByteString)
forall a. IO a -> RequestBuilder m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (InputStream StrictByteString)
-> RequestBuilder m (InputStream StrictByteString))
-> IO (InputStream StrictByteString)
-> RequestBuilder m (InputStream StrictByteString)
forall a b. (a -> b) -> a -> 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
$! [StrictByteString
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 = POST
, rqContentLength = Just $! fromIntegral $ S.length b
, rqBody = body
}
makeBoundary :: MonadIO m => m ByteString
makeBoundary :: forall (m :: * -> *). MonadIO m => m StrictByteString
makeBoundary = do
[Word8]
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 :: StrictByteString
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
StrictByteString -> m StrictByteString
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (StrictByteString -> m StrictByteString)
-> StrictByteString -> m StrictByteString
forall a b. (a -> b) -> a -> b
$ [StrictByteString] -> StrictByteString
S.concat [ StrictByteString
"snap-boundary-", StrictByteString -> StrictByteString
encode StrictByteString
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
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" ]
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
StrictByteString
b <- IO StrictByteString
forall (m :: * -> *). MonadIO m => m StrictByteString
makeBoundary
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
, StrictByteString -> Builder
multipartMixed StrictByteString
b
, Builder
cr
, StrictByteString -> Builder
byteString StrictByteString
"--"
, [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ((StrictByteString -> Builder) -> [StrictByteString] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (StrictByteString -> StrictByteString -> Builder
oneVal StrictByteString
b) [StrictByteString]
vals)
, StrictByteString -> Builder
byteString StrictByteString
b
, StrictByteString -> Builder
byteString StrictByteString
"--\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
StrictByteString
b <- IO StrictByteString
forall (m :: * -> *). MonadIO m => m StrictByteString
makeBoundary
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
, StrictByteString -> Builder
multipartMixed StrictByteString
b
, Builder
cr
, StrictByteString -> Builder
byteString StrictByteString
"--"
, [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ((FileData -> Builder) -> [FileData] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (StrictByteString -> FileData -> Builder
oneVal StrictByteString
b) [FileData]
files)
, StrictByteString -> Builder
byteString StrictByteString
b
, StrictByteString -> Builder
byteString StrictByteString
"--\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
StrictByteString
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
[Builder]
builders <- IO [Builder] -> RequestBuilder m [Builder]
forall a. IO a -> RequestBuilder m a
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
$ ((StrictByteString, MultipartParam) -> IO Builder)
-> MultipartParams -> IO [Builder]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (StrictByteString
-> (StrictByteString, MultipartParam) -> IO Builder
handleOne StrictByteString
boundary) MultipartParams
kvps
let b :: StrictByteString
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
Request
rq0 <- RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
InputStream StrictByteString
body <- IO (InputStream StrictByteString)
-> RequestBuilder m (InputStream StrictByteString)
forall a. IO a -> RequestBuilder m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (InputStream StrictByteString)
-> RequestBuilder m (InputStream StrictByteString))
-> IO (InputStream StrictByteString)
-> RequestBuilder m (InputStream StrictByteString)
forall a b. (a -> b) -> a -> b
$ [StrictByteString] -> IO (InputStream StrictByteString)
forall c. [c] -> IO (InputStream c)
Streams.fromList [StrictByteString
b]
let rq :: Request
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
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 = 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
Request
rq <- RequestBuilder m Request
forall (m :: * -> *). Monad m => RequestBuilder m Request
rGet
Request -> StrictByteString -> RequestBuilder m ()
forall {m :: * -> *}.
Monad m =>
Request -> StrictByteString -> RequestBuilder m ()
upd Request
rq (StrictByteString -> RequestBuilder m ())
-> StrictByteString -> RequestBuilder m ()
forall a b. (a -> b) -> a -> b
$! [StrictByteString] -> StrictByteString
S.concat [ Request -> StrictByteString
rqContextPath Request
rq
, Request -> StrictByteString
rqPathInfo Request
rq
, let q :: StrictByteString
q = Request -> StrictByteString
rqQueryString Request
rq
in if StrictByteString -> Bool
S.null StrictByteString
q
then StrictByteString
""
else StrictByteString -> StrictByteString -> StrictByteString
S.append StrictByteString
"?" StrictByteString
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 }
setQueryStringRaw :: Monad m => ByteString -> RequestBuilder m ()
setQueryStringRaw :: forall (m :: * -> *).
Monad m =>
StrictByteString -> RequestBuilder m ()
setQueryStringRaw StrictByteString
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 = r }
RequestBuilder m ()
forall (m :: * -> *). Monad m => RequestBuilder m ()
fixupURI
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
setHeader :: (Monad m) => CI ByteString -> ByteString -> RequestBuilder m ()
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)
addHeader :: (Monad m) => CI ByteString -> ByteString -> RequestBuilder m ()
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)
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 }
[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 :: [StrictByteString]
cstr = (Cookie -> StrictByteString) -> [Cookie] -> [StrictByteString]
forall a b. (a -> b) -> [a] -> [b]
map Cookie -> StrictByteString
cookieToBS [Cookie]
allCookies
CI StrictByteString -> StrictByteString -> RequestBuilder m ()
forall (m :: * -> *).
Monad m =>
CI StrictByteString -> StrictByteString -> RequestBuilder m ()
setHeader CI StrictByteString
"Cookie" (StrictByteString -> RequestBuilder m ())
-> StrictByteString -> RequestBuilder m ()
forall a b. (a -> b) -> a -> b
$ StrictByteString -> [StrictByteString] -> StrictByteString
S.intercalate StrictByteString
"; " [StrictByteString]
cstr
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]
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)
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 }
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 }
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
get :: MonadIO m =>
ByteString
-> Params
-> 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
head :: MonadIO m =>
ByteString
-> Params
-> 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
delete :: MonadIO m =>
ByteString
-> Params
-> 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
postUrlEncoded :: MonadIO m =>
ByteString
-> Params
-> 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
postMultipart :: MonadIO m =>
ByteString
-> MultipartParams
-> 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
put :: MonadIO m =>
ByteString
-> ByteString
-> ByteString
-> 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
postRaw :: MonadIO m =>
ByteString
-> ByteString
-> ByteString
-> 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
runHandler :: MonadIO m =>
RequestBuilder m ()
-> Snap a
-> 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
(Request
_,Response
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
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 (m :: * -> *) (n :: * -> *) b.
(MonadIO m, MonadSnap n) =>
(forall a. Request -> n a -> m Response)
-> RequestBuilder m () -> n b -> m Response
runHandlerM forall a. Request -> n a -> m Response
rSnap RequestBuilder m ()
rBuilder n b
snap = do
Request
rq <- 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
StrictByteString
t1 <- IO StrictByteString -> m StrictByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO EpochTime
epochTime IO EpochTime
-> (EpochTime -> IO StrictByteString) -> IO StrictByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= EpochTime -> IO StrictByteString
formatHttpTime)
Response -> m Response
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> m Response) -> Response -> m Response
forall a b. (a -> b) -> a -> b
$ CI StrictByteString -> StrictByteString -> Response -> Response
forall a.
HasHeaders a =>
CI StrictByteString -> StrictByteString -> a -> a
H.setHeader CI StrictByteString
"Date" StrictByteString
t1
(Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$ CI StrictByteString -> StrictByteString -> Response -> Response
forall a.
HasHeaders a =>
CI StrictByteString -> StrictByteString -> a -> a
H.setHeader CI StrictByteString
"Server" StrictByteString
"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
< (Int
1,Int
1)
then CI StrictByteString -> StrictByteString -> Response -> Response
forall a.
HasHeaders a =>
CI StrictByteString -> StrictByteString -> a -> a
H.setHeader CI StrictByteString
"Connection" StrictByteString
"close" Response
rsp
else Response
rsp
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
evalHandlerM :: (MonadIO m, MonadSnap n) =>
(forall a . Request -> n a -> m a)
-> RequestBuilder m ()
-> n b
-> m b
evalHandlerM :: forall (m :: * -> *) (n :: * -> *) b.
(MonadIO m, MonadSnap n) =>
(forall a. Request -> n a -> m a)
-> RequestBuilder m () -> n b -> m b
evalHandlerM forall a. Request -> n a -> m a
rSnap RequestBuilder m ()
rBuilder n b
snap = do
Request
rq <- 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 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
(OutputStream Builder
listOut, 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
StrictByteString -> IO StrictByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (StrictByteString -> IO StrictByteString)
-> StrictByteString -> IO StrictByteString
forall a b. (a -> b) -> a -> b
$! Builder -> StrictByteString
toByteString (Builder -> StrictByteString) -> Builder -> StrictByteString
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 StrictByteString
requestToString Request
req0 = do
(Request
req, InputStream StrictByteString
is) <- IO (Request, InputStream StrictByteString)
maybeChunk
StrictByteString
body <- ([StrictByteString] -> StrictByteString)
-> IO [StrictByteString] -> IO StrictByteString
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [StrictByteString] -> StrictByteString
S.concat (IO [StrictByteString] -> IO StrictByteString)
-> IO [StrictByteString] -> IO StrictByteString
forall a b. (a -> b) -> a -> b
$ InputStream StrictByteString -> IO [StrictByteString]
forall a. InputStream a -> IO [a]
Streams.toList InputStream StrictByteString
is
StrictByteString -> IO StrictByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (StrictByteString -> IO StrictByteString)
-> StrictByteString -> IO StrictByteString
forall a b. (a -> b) -> a -> b
$! Builder -> StrictByteString
toByteString (Builder -> StrictByteString) -> Builder -> StrictByteString
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 StrictByteString, StrictByteString) -> Builder)
-> [(CI StrictByteString, StrictByteString)] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (CI StrictByteString, StrictByteString) -> Builder
oneHeader ([(CI StrictByteString, StrictByteString)] -> [Builder])
-> (Headers -> [(CI StrictByteString, StrictByteString)])
-> Headers
-> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Headers -> [(CI StrictByteString, StrictByteString)]
H.toList
(Headers -> Builder) -> Headers -> Builder
forall a b. (a -> b) -> a -> b
$ Request -> Headers
rqHeaders Request
req
, Builder
crlf
, StrictByteString -> Builder
byteString StrictByteString
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 }
InputStream StrictByteString
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
InputStream StrictByteString
out <- IO (InputStream StrictByteString)
eof IO (InputStream StrictByteString)
-> (InputStream StrictByteString
-> IO (InputStream StrictByteString))
-> IO (InputStream StrictByteString)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InputStream StrictByteString
-> InputStream StrictByteString
-> IO (InputStream StrictByteString)
forall a. InputStream a -> InputStream a -> IO (InputStream a)
Streams.appendInputStream InputStream StrictByteString
is'
(Request, InputStream StrictByteString)
-> IO (Request, InputStream StrictByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Request
req, InputStream StrictByteString
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