{- Temporary workaround for https://ghc.haskell.org/trac/ghc/ticket/9127 -} {-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} module Snap.Internal.Test.RequestBuilder ( RequestBuilder , MultipartParams , MultipartParam(..) , FileData (..) , RequestType (..) , addHeader , buildRequest , delete , evalHandler , evalHandlerM , get , 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 (randomIO) import Text.Printf (printf) #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative) import Data.Monoid (Monoid (mappend, mconcat, mempty)) #endif ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- | RequestBuilder is a monad transformer that allows you to conveniently -- build a snap 'Request' for testing. newtype RequestBuilder m a = RequestBuilder (StateT Request m a) deriving ( Applicative , Functor , Monad #if MIN_VERSION_base(4,13,0) , MonadFail #endif , MonadIO , MonadState Request , MonadTrans ) ------------------------------------------------------------------------------ mkDefaultRequest :: IO Request mkDefaultRequest = do b <- Streams.fromList $! [] return $ Request "localhost" "127.0.0.1" 60000 "127.0.0.1" 8080 "localhost" False H.empty b Nothing GET (1,1) [] "" "/" "/" "" Map.empty Map.empty Map.empty ------------------------------------------------------------------------------ -- | Runs a 'RequestBuilder', producing the desired 'Request'. -- -- N.B. /please/ don't use the request you get here in a real Snap application; -- things will probably break. Don't say you weren't warned :-) -- -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> import qualified "Data.Map" as M -- ghci> 'buildRequest' $ 'get' \"\/foo\/bar\" M.empty -- GET \/foo\/bar HTTP\/1.1 -- host: localhost -- -- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a -- @ buildRequest :: MonadIO m => RequestBuilder m () -> m Request buildRequest mm = do let (RequestBuilder m) = (mm >> fixup) rq0 <- liftIO mkDefaultRequest execStateT m rq0 where fixup = do fixupURI fixupMethod fixupCL fixupParams fixupHost fixupMethod = do rq <- rGet if (rqMethod rq == GET || rqMethod rq == DELETE || rqMethod rq == HEAD) then do -- drain the old request body and replace it with a new one !_ <- liftIO $ Streams.toList $ rqBody rq !b <- liftIO $ Streams.fromList $! [] -- These requests are not permitted to have bodies let rq' = deleteHeader "Content-Type" $ rq { rqBody = b } rPut $ rq' { rqContentLength = Nothing } else return $! () fixupCL = do rq <- rGet maybe (rPut $ deleteHeader "Content-Length" rq) (\cl -> rPut $ H.setHeader "Content-Length" (S.pack (show cl)) rq) (rqContentLength rq) fixupParams = do rq <- rGet let !query = rqQueryString rq -- force the stuff from mkDefaultRequest that we just overwrite let !_ = rqPostParams rq let !_ = rqParams rq let !_ = rqQueryParams rq let !queryParams = parseUrlEncoded query let !mbCT = getHeader "Content-Type" rq (!postParams, rq') <- if mbCT == Just "application/x-www-form-urlencoded" then liftIO $ do !l <- Streams.toList $ rqBody rq -- snap-server regurgitates the parsed form body !b <- Streams.fromList l return (parseUrlEncoded (S.concat l), rq { rqBody = b }) else return (Map.empty, rq) let !newParams = Map.unionWith (flip (++)) queryParams postParams rPut $ rq' { rqParams = newParams , rqPostParams = postParams , rqQueryParams = queryParams } fixupHost = do rq <- rGet case H.getHeader "Host" rq of Nothing -> do let !hn = rqHostName rq rPut $ H.setHeader "Host" hn rq Just hn -> rPut $ rq { rqHostName = hn } ------------------------------------------------------------------------------ -- | A request body of type \"@multipart/form-data@\" consists of a set of -- named form parameters, each of which can by either a list of regular form -- values or a set of file uploads. type MultipartParams = [(ByteString, MultipartParam)] ------------------------------------------------------------------------------ -- | A single \"@multipart/form-data@\" form parameter: either a list of regular -- form values or a set of file uploads. data MultipartParam = FormData [ByteString] -- ^ a form variable consisting of the given 'ByteString' values. | Files [FileData] -- ^ a file upload consisting of the given 'FileData' values. deriving (Show) ------------------------------------------------------------------------------ -- | Represents a single file upload for the 'MultipartParam'. data FileData = FileData { fdFileName :: ByteString -- ^ the file's name , fdContentType :: ByteString -- ^ the file's content-type , fdContents :: ByteString -- ^ the file contents } deriving (Show) ------------------------------------------------------------------------------ -- | The 'RequestType' datatype enumerates the different kinds of HTTP -- requests you can generate using the testing interface. Most users will -- prefer to use the 'get', 'postUrlEncoded', 'postMultipart', 'put', and -- 'delete' convenience functions. data RequestType = GetRequest | RequestWithRawBody Method ByteString | MultipartPostRequest MultipartParams | UrlEncodedPostRequest Params | DeleteRequest deriving (Show) ------------------------------------------------------------------------------ -- | Sets the type of the 'Request' being built. -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> import qualified "Data.Map" as M -- ghci> 'buildRequest' $ 'delete' \"\/foo\/bar\" M.empty >> 'setRequestType' GetRequest -- GET \/foo\/bar HTTP\/1.1 -- host: localhost -- -- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a -- @ setRequestType :: MonadIO m => RequestType -> RequestBuilder m () setRequestType GetRequest = do rq <- rGet body <- liftIO $ Streams.fromList $! [] rPut $ rq { rqMethod = GET , rqContentLength = Nothing , rqBody = body } setRequestType DeleteRequest = do rq <- rGet body <- liftIO $ Streams.fromList $! [] rPut $ rq { rqMethod = DELETE , rqContentLength = Nothing , rqBody = body } setRequestType (RequestWithRawBody m b) = do rq <- rGet body <- liftIO $ Streams.fromList $! [ b ] rPut $ rq { rqMethod = m , rqContentLength = Just $ fromIntegral $ S.length b , rqBody = body } setRequestType (MultipartPostRequest fp) = encodeMultipart fp setRequestType (UrlEncodedPostRequest fp) = do rq <- liftM (H.setHeader "Content-Type" "application/x-www-form-urlencoded") rGet let b = printUrlEncoded fp body <- liftIO $ Streams.fromList $! [b] rPut $ rq { rqMethod = POST , rqContentLength = Just $! fromIntegral $ S.length b , rqBody = body } ------------------------------------------------------------------------------ makeBoundary :: MonadIO m => m ByteString makeBoundary = do xs <- liftIO $ replicateM 16 randomWord8 let x = S.pack $ map (toEnum . fromEnum) xs return $ S.concat [ "snap-boundary-", encode x ] where randomWord8 :: IO Word8 randomWord8 = liftM (\c -> toEnum $ c .&. 0xff) randomIO table = V.fromList [ '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' , 'a', 'b', 'c', 'd', 'e', 'f' ] encode = toByteString . S8.foldl' f mempty #if MIN_VERSION_base(4,5,0) shR = unsafeShiftR #else shR = shiftR #endif f m c = let low = c .&. 0xf hi = (c .&. 0xf0) `shR` 4 k = \i -> word8 $! toEnum $! fromEnum $! V.unsafeIndex table (fromEnum i) in m `mappend` k hi `mappend` k low ------------------------------------------------------------------------------ multipartHeader :: ByteString -> ByteString -> Builder multipartHeader boundary name = mconcat [ byteString boundary , byteString "\r\ncontent-disposition: form-data" , byteString "; name=\"" , byteString name , byteString "\"\r\n" ] ------------------------------------------------------------------------------ -- Assume initial or preceding "--" just before this encodeFormData :: ByteString -> ByteString -> [ByteString] -> IO Builder encodeFormData boundary name vals = case vals of [] -> return mempty [v] -> return $ mconcat [ hdr , cr , byteString v , byteString "\r\n--" ] _ -> multi where hdr = multipartHeader boundary name cr = byteString "\r\n" oneVal b v = mconcat [ byteString b , cr , cr , byteString v , byteString "\r\n--" ] multi = do b <- makeBoundary return $ mconcat [ hdr , multipartMixed b , cr , byteString "--" , mconcat (map (oneVal b) vals) , byteString b , byteString "--\r\n--" ] ------------------------------------------------------------------------------ multipartMixed :: ByteString -> Builder multipartMixed b = mconcat [ byteString "Content-Type: multipart/mixed" , byteString "; boundary=" , byteString b , byteString "\r\n" ] ------------------------------------------------------------------------------ encodeFiles :: ByteString -> ByteString -> [FileData] -> IO Builder encodeFiles boundary name files = case files of [] -> return mempty _ -> do b <- makeBoundary return $ mconcat [ hdr , multipartMixed b , cr , byteString "--" , mconcat (map (oneVal b) files) , byteString b , byteString "--\r\n--" ] where -------------------------------------------------------------------------- contentDisposition fn = mconcat [ byteString "Content-Disposition: attachment" , byteString "; filename=\"" , byteString fn , byteString "\"\r\n" ] -------------------------------------------------------------------------- contentType ct = mconcat [ byteString "Content-Type: " , byteString ct , cr ] -------------------------------------------------------------------------- oneVal b fd = mconcat [ byteString b , cr , contentType ct , contentDisposition fileName , byteString "Content-Transfer-Encoding: binary\r\n" , cr , byteString contents , byteString "\r\n--" ] where fileName = fdFileName fd ct = fdContentType fd contents = fdContents fd -------------------------------------------------------------------------- hdr = multipartHeader boundary name cr = byteString "\r\n" ------------------------------------------------------------------------------ encodeMultipart :: MonadIO m => MultipartParams -> RequestBuilder m () encodeMultipart kvps = do boundary <- liftIO $ makeBoundary builders <- liftIO $ mapM (handleOne boundary) kvps let b = toByteString $ mconcat (byteString "--" : builders) `mappend` finalBoundary boundary rq0 <- rGet body <- liftIO $ Streams.fromList [b] let rq = H.setHeader "Content-Type" (S.append "multipart/form-data; boundary=" boundary) rq0 rPut $ rq { rqMethod = POST , rqContentLength = Just $ fromIntegral $ S.length b , rqBody = body } where finalBoundary b = mconcat [byteString b, byteString "--\r\n"] handleOne boundary (name, mp) = case mp of (FormData vals) -> encodeFormData boundary name vals (Files fs) -> encodeFiles boundary name fs ------------------------------------------------------------------------------ fixupURI :: Monad m => RequestBuilder m () fixupURI = do rq <- rGet upd rq $! S.concat [ rqContextPath rq , rqPathInfo rq , let q = rqQueryString rq in if S.null q then "" else S.append "?" q ] where upd rq !u = let !_ = rqURI rq in rPut $ rq { rqURI = u } ------------------------------------------------------------------------------ -- | Sets the request's query string to be the raw bytestring provided, -- without any escaping or other interpretation. Most users should instead -- choose the 'setQueryString' function, which takes a parameter mapping. -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> import qualified "Data.Map" as M -- ghci> 'buildRequest' $ 'get' \"\/foo\/bar\" M.empty >> 'setQueryStringRaw' "param0=baz¶m1=qux" -- GET \/foo\/bar?param0=baz¶m1=qux HTTP\/1.1 -- host: localhost -- -- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a -- params: param0: ["baz"], param1: ["qux"] -- @ setQueryStringRaw :: Monad m => ByteString -> RequestBuilder m () setQueryStringRaw r = do rq <- rGet rPut $ rq { rqQueryString = r } fixupURI ------------------------------------------------------------------------------ -- | Escapes the given parameter mapping and sets it as the request's query -- string. -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> import qualified "Data.Map" as M -- ghci> 'buildRequest' $ 'get' \"\/foo\/bar\" M.empty >> 'setQueryString' (M.fromList [("param0", ["baz"]), ("param1", ["qux"])]) -- GET \/foo\/bar?param0=baz¶m1=qux HTTP\/1.1 -- host: localhost -- -- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a -- params: param0: ["baz"], param1: ["qux"] -- @ setQueryString :: Monad m => Params -> RequestBuilder m () setQueryString p = setQueryStringRaw $ printUrlEncoded p ------------------------------------------------------------------------------ -- | Sets the given header in the request being built, overwriting any header -- with the same name already present. -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> import qualified "Data.Map" as M -- ghci> :{ -- ghci| 'buildRequest' $ do get \"\/foo\/bar\" M.empty -- ghci| 'setHeader' \"Accept\" "text\/html" -- ghci| 'setHeader' \"Accept\" "text\/plain" -- ghci| :} -- GET \/foo\/bar HTTP\/1.1 -- accept: text\/plain -- host: localhost -- -- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a -- @ setHeader :: (Monad m) => CI ByteString -> ByteString -> RequestBuilder m () setHeader k v = rModify (H.setHeader k v) ------------------------------------------------------------------------------ -- | Adds the given header to the request being built. -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> import qualified "Data.Map" as M -- ghci> :{ -- ghci| 'buildRequest' $ do 'get' \"\/foo\/bar\" M.empty -- ghci| 'addHeader' \"Accept\" "text\/html" -- ghci| 'addHeader' \"Accept\" "text\/plain" -- ghci| :} -- GET \/foo\/bar HTTP\/1.1 -- accept: text\/html,text\/plain -- host: localhost -- -- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a -- @ addHeader :: (Monad m) => CI ByteString -> ByteString -> RequestBuilder m () addHeader k v = rModify (H.addHeader k v) ------------------------------------------------------------------------------ -- | Adds the given cookies to the request being built. -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> import qualified "Data.Map" as M -- ghci> import "Snap.Core" -- ghci> let cookie = 'Snap.Core.Cookie' "name" "value" Nothing Nothing Nothing False False -- ghci> 'buildRequest' $ 'get' \"\/foo\/bar\" M.empty >> 'addCookies' [cookie] -- GET \/foo\/bar HTTP\/1.1 -- cookie: name=value -- host: localhost -- -- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a -- cookies: Cookie {cookieName = "name", cookieValue = "value", ...} -- @ addCookies :: (Monad m) => [Cookie] -> RequestBuilder m () addCookies cookies = do rModify $ \rq -> rq { rqCookies = rqCookies rq ++ cookies } allCookies <- liftM rqCookies rGet let cstr = map cookieToBS allCookies setHeader "Cookie" $ S.intercalate "; " cstr ------------------------------------------------------------------------------ -- | Convert 'Cookie' into 'ByteString' for output. cookieToBS :: Cookie -> ByteString cookieToBS (Cookie k v !_ !_ !_ !_ !_) = cookie where cookie = S.concat [k, "=", v] ------------------------------------------------------------------------------ -- | Sets the request's @content-type@ to the given MIME type. -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> import qualified "Data.Map" as M -- ghci> 'buildRequest' $ 'put' \"\/foo\/bar\" "text\/html" "some text" >> 'setContentType' "text\/plain" -- PUT \/foo\/bar HTTP\/1.1 -- content-type: text\/plain -- content-length: 9 -- host: localhost -- -- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=9 -- @ setContentType :: Monad m => ByteString -> RequestBuilder m () setContentType c = rModify (H.setHeader "Content-Type" c) ------------------------------------------------------------------------------ -- | Controls whether the test request being generated appears to be an https -- request or not. -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> import qualified "Data.Map" as M -- ghci> 'buildRequest' $ 'delete' \"\/foo\/bar\" M.empty >> 'setSecure' True -- DELETE \/foo\/bar HTTP\/1.1 -- host: localhost -- -- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a secure -- @ setSecure :: Monad m => Bool -> RequestBuilder m () setSecure b = rModify $ \rq -> rq { rqIsSecure = b } ------------------------------------------------------------------------------ -- | Sets the test request's http version -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> import qualified "Data.Map" as M -- ghci> 'buildRequest' $ 'delete' \"\/foo\/bar\" M.empty >> 'setHttpVersion' (1,0) -- DELETE \/foo\/bar HTTP\/1.0 -- host: localhost -- -- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a -- @ setHttpVersion :: Monad m => (Int,Int) -> RequestBuilder m () setHttpVersion v = rModify $ \rq -> rq { rqVersion = v } ------------------------------------------------------------------------------ -- | Sets the request's path. The path provided must begin with a \"@/@\" and -- must /not/ contain a query string; if you want to provide a query string -- in your test request, you must use 'setQueryString' or 'setQueryStringRaw'. -- Note that 'rqContextPath' is never set by any 'RequestBuilder' function. -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> import qualified "Data.Map" as M -- ghci> 'buildRequest' $ 'get' \"\/foo\/bar\" M.empty >> 'setRequestPath' "\/bar\/foo" -- GET \/bar\/foo HTTP\/1.1 -- host: localhost -- -- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a -- @ setRequestPath :: Monad m => ByteString -> RequestBuilder m () setRequestPath p0 = do rModify $ \rq -> rq { rqContextPath = "/" , rqPathInfo = p } fixupURI where p = if S.isPrefixOf "/" p0 then S.drop 1 p0 else p0 ------------------------------------------------------------------------------ -- | Builds an HTTP \"GET\" request with the given query parameters. -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> import qualified "Data.Map" as M -- ghci> 'buildRequest' $ 'get' \"\/foo\/bar\" (M.fromList [("param0", ["baz", "quux"])]) -- GET \/foo\/bar?param0=baz¶m0=quux HTTP\/1.1 -- host: localhost -- -- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a -- params: param0: ["baz","quux"] -- @ get :: MonadIO m => ByteString -- ^ request path -> Params -- ^ request's form parameters -> RequestBuilder m () get uri params = do setRequestType GetRequest setQueryString params setRequestPath uri ------------------------------------------------------------------------------ -- | Builds an HTTP \"DELETE\" request with the given query parameters. -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> import qualified "Data.Map" as M -- ghci> 'buildRequest' $ 'delete' \"\/foo\/bar\" M.empty -- DELETE \/foo\/bar HTTP\/1.1 -- host: localhost -- -- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a -- @ delete :: MonadIO m => ByteString -- ^ request path -> Params -- ^ request's form parameters -> RequestBuilder m () delete uri params = do setRequestType DeleteRequest setQueryString params setRequestPath uri ------------------------------------------------------------------------------ -- | Builds an HTTP \"POST\" request with the given form parameters, using the -- \"application/x-www-form-urlencoded\" MIME type. -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> import qualified "Data.Map" as M -- ghci> 'buildRequest' $ 'postUrlEncoded' \"\/foo\/bar\" (M.fromList [("param0", ["baz", "quux"])]) -- POST \/foo\/bar HTTP\/1.1 -- content-type: application\/x-www-form-urlencoded -- content-length: 22 -- host: localhost -- -- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=22 -- params: param0: ["baz","quux"] -- @ postUrlEncoded :: MonadIO m => ByteString -- ^ request path -> Params -- ^ request's form parameters -> RequestBuilder m () postUrlEncoded uri params = do setRequestType $ UrlEncodedPostRequest params setRequestPath uri ------------------------------------------------------------------------------ -- | Builds an HTTP \"POST\" request with the given form parameters, using the -- \"form-data/multipart\" MIME type. -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> 'buildRequest' $ 'postMultipart' \"\/foo\/bar\" [("param0", FormData ["baz", "quux"])] -- POST \/foo\/bar HTTP\/1.1 -- content-type: multipart\/form-data; boundary=snap-boundary-572334111ec0c05ad4812481e8585dfa -- content-length: 406 -- host: localhost -- -- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=406 -- @ postMultipart :: MonadIO m => ByteString -- ^ request path -> MultipartParams -- ^ multipart form parameters -> RequestBuilder m () postMultipart uri params = do setRequestType $ MultipartPostRequest params setRequestPath uri ------------------------------------------------------------------------------ -- | Builds an HTTP \"PUT\" request. -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> 'buildRequest' $ 'put' \"\/foo\/bar\" "text\/plain" "some text" -- PUT \/foo\/bar HTTP\/1.1 -- content-type: text/plain -- content-length: 9 -- host: localhost -- -- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=9 -- @ put :: MonadIO m => ByteString -- ^ request path -> ByteString -- ^ request body MIME content-type -> ByteString -- ^ request body contents -> RequestBuilder m () put uri contentType putData = do setRequestType $ RequestWithRawBody PUT putData setHeader "Content-Type" contentType setRequestPath uri ------------------------------------------------------------------------------ -- | Builds a \"raw\" HTTP \"POST\" request, with the given MIME type and body -- contents. -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> 'buildRequest' $ 'postRaw' \"\/foo\/bar\" "text/plain" "some text" -- POST \/foo\/bar HTTP\/1.1 -- content-type: text\/plain -- content-length: 9 -- host: localhost -- -- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=9 -- @ postRaw :: MonadIO m => ByteString -- ^ request path -> ByteString -- ^ request body MIME content-type -> ByteString -- ^ request body contents -> RequestBuilder m () postRaw uri contentType postData = do setRequestType $ RequestWithRawBody POST postData setContentType contentType setRequestPath uri ------------------------------------------------------------------------------ -- | Given a web handler in the 'Snap' monad, and a 'RequestBuilder' defining -- a test request, runs the handler, producing an HTTP 'Response'. -- -- This function will produce almost exactly the same output as running the -- handler in a real server, except that chunked transfer encoding is not -- applied, and the \"Transfer-Encoding\" header is not set (this makes it -- easier to test response output). -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> import qualified "Data.Map" as M -- ghci> import "Snap.Core" -- ghci> 'runHandler' ('get' "foo/bar" M.empty) ('Snap.Core.writeBS' "Hello, world!") -- HTTP\/1.1 200 OK -- server: Snap/test -- date: Thu, 17 Jul 2014 21:03:23 GMT -- -- Hello, world! -- @ runHandler :: MonadIO m => RequestBuilder m () -- ^ a request builder -> Snap a -- ^ a web handler -> m Response runHandler = runHandlerM rs where rs rq s = liftIO $ do (_,rsp) <- runSnap s (\x -> return $! (x `seq` ())) (\f -> let !_ = f 0 in return $! ()) rq fixupResponse rq rsp ------------------------------------------------------------------------------ -- | Given a web handler in some arbitrary 'MonadSnap' monad, a function -- specifying how to evaluate it within the context of the test monad, and a -- 'RequestBuilder' defining a test request, runs the handler, producing an -- HTTP 'Response'. runHandlerM :: (MonadIO m, MonadSnap n) => (forall a . Request -> n a -> m Response) -- ^ a function defining how the 'MonadSnap' monad should be run -> RequestBuilder m () -- ^ a request builder -> n b -- ^ a web handler -> m Response runHandlerM rSnap rBuilder snap = do rq <- buildRequest rBuilder rsp <- rSnap rq snap -- simulate server logic t1 <- liftIO (epochTime >>= formatHttpTime) return $ H.setHeader "Date" t1 $ H.setHeader "Server" "Snap/test" $ if rspContentLength rsp == Nothing && rqVersion rq < (1,1) then H.setHeader "Connection" "close" rsp else rsp ------------------------------------------------------------------------------ -- | Given a web handler in the 'Snap' monad, and a 'RequestBuilder' defining a -- test request, runs the handler and returns the monadic value it produces. -- -- Throws an exception if the 'Snap' handler early-terminates with -- 'Snap.Core.finishWith' or 'Control.Monad.mzero'. -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> import "Control.Monad" -- ghci> import qualified "Data.Map" as M -- ghci> import "Snap.Core" -- ghci> 'evalHandler' ('get' "foo/bar" M.empty) ('Snap.Core.writeBS' "Hello, world!" >> return 42) -- 42 -- ghci> 'evalHandler' ('get' "foo/bar" M.empty) 'Control.Monad.mzero' -- *** Exception: No handler for request: failure was pass -- @ evalHandler :: MonadIO m => RequestBuilder m () -> Snap a -> m a evalHandler = evalHandlerM rs where rs rq s = liftIO $ evalSnap s (const $ return $! ()) (const $ return $! ()) rq ------------------------------------------------------------------------------ -- | Given a web handler in some arbitrary 'MonadSnap' monad, a function -- specifying how to evaluate it within the context of the test monad, and a -- 'RequestBuilder' defining a test request, runs the handler, returning the -- monadic value it produces. -- -- Throws an exception if the 'Snap' handler early-terminates with -- 'Snap.Core.finishWith' or 'Control.Monad.mzero'. evalHandlerM :: (MonadIO m, MonadSnap n) => (forall a . Request -> n a -> m a) -- ^ a function defining -- how the 'MonadSnap' -- monad should be run -> RequestBuilder m () -- ^ a request builder -> n b -- ^ a web handler -> m b evalHandlerM rSnap rBuilder snap = do rq <- buildRequest rBuilder rSnap rq snap ------------------------------------------------------------------------------ -- | Converts the given 'Response' to a bytestring. -- -- Example: -- -- @ -- ghci> import "Snap.Core" -- ghci> 'responseToString' 'Snap.Core.emptyResponse' -- \"HTTP\/1.1 200 OK\\r\\n\\r\\n\" -- @ responseToString :: Response -> IO ByteString responseToString resp = do let act = rspBodyToEnum $ rspBody resp (listOut, grab) <- Streams.listOutputStream void $ act listOut builder <- liftM mconcat grab return $! toByteString $ fromShow resp `mappend` builder ------------------------------------------------------------------------------ -- | Converts the given 'Request' to a bytestring. -- -- Since: 1.0.0.0 -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> import qualified "Data.Map" as M -- ghci> r <- 'buildRequest' $ get \"\/foo\/bar\" M.empty -- ghci> 'requestToString' r -- \"GET \/foo\/bar HTTP\/1.1\\r\\nhost: localhost\\r\\n\\r\\n\" -- @ requestToString :: Request -> IO ByteString requestToString req0 = do (req, is) <- maybeChunk body <- liftM S.concat $ Streams.toList is return $! toByteString $ mconcat [ statusLine , mconcat . map oneHeader . H.toList $ rqHeaders req , crlf , byteString body ] where maybeChunk = do if getHeader "Transfer-Encoding" req0 == Just "chunked" then do let req = deleteHeader "Content-Length" $ req0 { rqContentLength = Nothing } is' <- Streams.map chunk $ rqBody req out <- eof >>= Streams.appendInputStream is' return (req, out) else return (req0, rqBody req0) where chunk s = S.concat [ S.pack $ printf "%x\r\n" (S.length s) , s , "\r\n" ] eof = Streams.fromList ["0\r\n\r\n"] (v1,v2) = rqVersion req0 crlf = char8 '\r' `mappend` char8 '\n' statusLine = mconcat [ fromShow $ rqMethod req0 , char8 ' ' , byteString $ rqURI req0 , byteString " HTTP/" , fromShow v1 , char8 '.' , fromShow v2 , crlf ] oneHeader (k,v) = mconcat [ byteString $ original k , byteString ": " , byteString v , crlf ] ------------------------------------------------------------------------------ rGet :: Monad m => RequestBuilder m Request rGet = RequestBuilder State.get rPut :: Monad m => Request -> RequestBuilder m () rPut s = RequestBuilder $ State.put s rModify :: Monad m => (Request -> Request) -> RequestBuilder m () rModify f = RequestBuilder $ modify f ------------------------------------------------------------------------------ toByteString :: Builder -> ByteString toByteString = S.concat . L.toChunks . toLazyByteString ------------------------------------------------------------------------------ fromShow :: Show a => a -> Builder fromShow = stringUtf8 . show