diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -6,3 +6,4 @@ James Sanders Jacob Stanley Jonas Kramer +Jurriën Stutterheim diff --git a/README.SNAP.md b/README.SNAP.md --- a/README.SNAP.md +++ b/README.SNAP.md @@ -16,11 +16,11 @@ * a sensible and clean monad for web programming - * an xml-based templating system for generating HTML based on - [expat](http://expat.sourceforge.net/) (via - [hexpat](http://hackage.haskell.org/package/hexpat)) that allows you to - bind Haskell functionality to XML tags without getting PHP-style tag soup - all over your pants + * an xml-based templating system for generating HTML that allows you to bind + Haskell functionality to XML tags without getting PHP-style tag soup all + over your pants + + * a "snaplet" system for building web sites from composable pieces. Snap is currently only officially supported on Unix platforms; it has been tested on Linux and Mac OSX Snow Leopard, and is reported to work on Windows. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,14 +1,10 @@ Snap Framework Core =================== -This is the first developer prerelease of the Snap Framework Core library. For -more information about Snap, read the `README.SNAP.md` or visit the Snap -project website at http://www.snapframework.com/. - -Snap is a nascent web framework for Haskell, based on iteratee I/O (as -[popularized by Oleg -Kiselyov](http://okmij.org/ftp/Streams.html#iteratee)). - +Snap is a web framework for Haskell, based on iteratee I/O (as [popularized by +Oleg Kiselyov](http://okmij.org/ftp/Streams.html#iteratee)). For more +information about Snap, read the `README.SNAP.md` or visit the Snap project +website at http://www.snapframework.com/. ## Library contents diff --git a/snap-core.cabal b/snap-core.cabal --- a/snap-core.cabal +++ b/snap-core.cabal @@ -1,5 +1,5 @@ name: snap-core -version: 0.5.5 +version: 0.6.0 synopsis: Snap: A Haskell Web Framework (Core) description: @@ -26,7 +26,7 @@ * Early termination of the computation if you know early what you want to return and want to prevent further monadic processing . - /Quick start/: The 'Snap' monad and HTTP definitions are in "Snap.Types", + /Quick start/: The 'Snap' monad and HTTP definitions are in "Snap.Core", some iteratee utilities are in "Snap.Iteratee". . Higher-level facilities for building web applications (like user/session @@ -68,11 +68,12 @@ test/data/fileServe/mydir3/altindex.html, test/runTestsAndCoverage.sh, test/snap-core-testsuite.cabal, + test/suite/Snap/Core/Tests.hs, test/suite/Snap/Internal/Http/Types/Tests.hs, + test/suite/Snap/Internal/Parsing/Tests.hs, test/suite/Snap/Internal/Routing/Tests.hs, test/suite/Snap/Iteratee/Tests.hs, test/suite/Snap/Test/Common.hs, - test/suite/Snap/Types/Tests.hs, test/suite/Snap/Util/FileServe/Tests.hs, test/suite/Snap/Util/FileUploads/Tests.hs, test/suite/Snap/Util/GZip/Tests.hs @@ -110,12 +111,15 @@ cpp-options: -DUSE_UNIX exposed-modules: + Snap.Core, Snap.Types, Snap.Iteratee, Snap.Internal.Debug, Snap.Internal.Http.Types, Snap.Internal.Iteratee.Debug, Snap.Internal.Parsing, + Snap.Test, + Snap.Types.Headers, Snap.Util.FileServe, Snap.Util.FileUploads, Snap.Util.GZip, @@ -125,32 +129,39 @@ Snap.Internal.Instances, Snap.Internal.Iteratee.BoyerMooreHorspool, Snap.Internal.Routing, - Snap.Internal.Types + Snap.Internal.Types, + Snap.Internal.Test.RequestBuilder, + Snap.Internal.Test.Assertions build-depends: attoparsec >= 0.8.0.2 && < 0.10, attoparsec-enumerator >= 0.2.0.3, base >= 4 && < 5, + base16-bytestring <= 0.2, blaze-builder >= 0.2.1.4 && <0.4, blaze-builder-enumerator >= 0.2 && <0.3, bytestring, bytestring-nums, - case-insensitive >= 0.2 && < 0.4, + case-insensitive >= 0.3 && < 0.4, containers, deepseq >= 1.1 && <1.3, directory, dlist >= 0.5 && < 0.6, enumerator >= 0.4.13.1 && < 0.5, filepath, + HUnit >= 1.2 && < 2, MonadCatchIO-transformers >= 0.2.1 && < 0.3, mtl == 2.0.*, + mwc-random >= 0.10 && <0.11, old-locale, old-time, + regex-posix <= 0.94.4, text >= 0.11 && <0.12, time >= 1.0 && < 1.4, transformers == 0.2.*, unix-compat >= 0.2 && <0.4, + unordered-containers >= 0.1.4.3 && <0.2, vector >= 0.6 && <0.10, zlib-enum >= 0.2.1 && <0.3 diff --git a/src/Snap/Core.hs b/src/Snap/Core.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Core.hs @@ -0,0 +1,159 @@ +{-| + +This module contains the core type definitions, class instances, and functions +for HTTP as well as the 'Snap' monad, which is used for web handlers. + +-} +module Snap.Core + ( + -- * The Snap Monad + Snap + , runSnap + , MonadSnap(..) + , NoHandlerException(..) + + -- ** Functions for control flow and early termination + , bracketSnap + , finishWith + , catchFinishWith + , pass + , terminateConnection + + -- ** Routing + , method + , methods + , path + , pathArg + , dir + , ifTop + , route + , routeLocal + + -- ** Access to state + , getRequest + , getResponse + , putRequest + , putResponse + , modifyRequest + , modifyResponse + , localRequest + , withRequest + , withResponse + + -- ** Logging + , logError + + -- ** Grabbing/transforming request bodies + , runRequestBody + , getRequestBody + , readRequestBody + , transformRequestBody + + -- * HTTP Datatypes and Functions + -- $httpDoc + -- + , Request + , Response + , Headers + , HasHeaders(..) + , Params + , Method(..) + , Cookie(..) + , HttpVersion + + -- ** Headers + , addHeader + , setHeader + , getHeader + , getHeaders + , listHeaders + , deleteHeader + , ipHeaderFilter + , ipHeaderFilter' + + -- ** Requests + , rqServerName + , rqServerPort + , rqRemoteAddr + , rqRemotePort + , rqLocalAddr + , rqLocalHostname + , rqIsSecure + , rqContentLength + , rqMethod + , rqVersion + , rqCookies + , rqPathInfo + , rqContextPath + , rqURI + , rqQueryString + , rqParams + , rqParam + , getParam + , getParams + , rqModifyParams + , rqSetParam + + -- ** Responses + , emptyResponse + , setResponseCode + , setResponseStatus + , rspStatus + , rspStatusReason + , setContentType + , addResponseCookie + , getResponseCookie + , getResponseCookies + , deleteResponseCookie + , modifyResponseCookie + , expireCookie + , getCookie + , readCookie + , setContentLength + , clearContentLength + , redirect + , redirect' + + -- *** Response I/O + , setResponseBody + , modifyResponseBody + , addToOutput + , writeBuilder + , writeBS + , writeLazyText + , writeText + , writeLBS + , sendFile + , sendFilePartial + + -- ** Timeouts + , setTimeout + , getTimeoutAction + + -- * Iteratee + , Enumerator + , SomeEnumerator(..) + + -- * HTTP utilities + , formatHttpTime + , parseHttpTime + , parseUrlEncoded + , buildUrlEncoded + , printUrlEncoded + , urlEncode + , urlEncodeBuilder + , urlDecode + ) where + +------------------------------------------------------------------------------ +import Snap.Internal.Http.Types +import Snap.Internal.Instances () +import Snap.Internal.Parsing +import Snap.Internal.Routing +import Snap.Internal.Types +import Snap.Iteratee (Enumerator) +import Snap.Types.Headers (Headers) +------------------------------------------------------------------------------ + +-- $httpDoc +-- HTTP-related datatypes: 'Request', 'Response', 'Cookie', etc. diff --git a/src/Snap/Internal/Http/Types.hs b/src/Snap/Internal/Http/Types.hs --- a/src/Snap/Internal/Http/Types.hs +++ b/src/Snap/Internal/Http/Types.hs @@ -2,7 +2,7 @@ -- -- /N.B./ this is an internal interface, please don't write user code that -- depends on it. Most of these declarations (except for the --- unsafe/encapsulation-breaking ones) are re-exported from "Snap.Types". +-- unsafe/encapsulation-breaking ones) are re-exported from "Snap.Core". {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} @@ -18,20 +18,11 @@ ------------------------------------------------------------------------------ import Blaze.ByteString.Builder -import Control.Applicative hiding (empty) -import Control.Monad (liftM, when) -import qualified Data.Attoparsec as Atto -import Data.Attoparsec hiding (many, Result(..)) -import Data.Bits +import Control.Monad (liftM) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import Data.ByteString.Internal (c2w,w2c) -import qualified Data.ByteString.Nums.Careless.Hex as Cvt import qualified Data.ByteString as S -import qualified Data.ByteString.Unsafe as S -import Data.Char -import Data.DList (DList) -import qualified Data.DList as DL import Data.Int import qualified Data.IntMap as IM import Data.IORef @@ -41,8 +32,6 @@ import Data.Maybe import Data.Monoid import Data.Time.Clock -import Data.Word -import Foreign hiding (new) import Foreign.C.Types import Prelude hiding (take) @@ -54,6 +43,8 @@ import System.Locale (defaultTimeLocale) #else import Data.Time.Format () +import Foreign +import qualified Data.ByteString.Unsafe as S import Foreign.C.String #endif @@ -62,7 +53,8 @@ import qualified Data.CaseInsensitive as CI import Snap.Iteratee (Enumerator) import qualified Snap.Iteratee as I - +import Snap.Types.Headers (Headers) +import qualified Snap.Types.Headers as H #ifndef PORTABLE @@ -85,11 +77,6 @@ ------------------------------------------------------------------------------ --- | A type alias for a case-insensitive key-value mapping. -type Headers = Map (CI ByteString) [ByteString] - - ------------------------------------------------------------------------------- -- | A typeclass for datatypes which contain HTTP headers. class HasHeaders a where @@ -105,33 +92,40 @@ -- with the same name already exists, the new value is appended to the headers -- list. addHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a -addHeader k v = updateHeaders $ Map.insertWith' (++) k [v] +addHeader k v = updateHeaders $ H.insert k v ------------------------------------------------------------------------------ -- | Sets a header key-value-pair in a 'HasHeaders' datatype. If a header with -- the same name already exists, it is overwritten with the new value. setHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a -setHeader k v = updateHeaders $ Map.insert k [v] +setHeader k v = updateHeaders $ H.set k v ------------------------------------------------------------------------------ -- | Gets all of the values for a given header. getHeaders :: (HasHeaders a) => CI ByteString -> a -> Maybe [ByteString] -getHeaders k a = Map.lookup k $ headers a +getHeaders k a = H.lookup k $ headers a ------------------------------------------------------------------------------ -- | Gets a header value out of a 'HasHeaders' datatype. If many headers came -- in with the same name, they will be catenated together. getHeader :: (HasHeaders a) => CI ByteString -> a -> Maybe ByteString -getHeader k a = liftM (S.intercalate " ") (Map.lookup k $ headers a) +getHeader k a = liftM (S.intercalate " ") (H.lookup k $ headers a) ------------------------------------------------------------------------------ +-- | Lists all the headers out of a 'HasHeaders' datatype. If many +-- headers came in with the same name, they will be catenated together. +listHeaders :: (HasHeaders a) => a -> [(CI ByteString, ByteString)] +listHeaders = H.toList . headers + + +------------------------------------------------------------------------------ -- | Clears a header value from a 'HasHeaders' datatype. deleteHeader :: (HasHeaders a) => CI ByteString -> a -> a -deleteHeader k = updateHeaders $ Map.delete k +deleteHeader k = updateHeaders $ H.delete k ------------------------------------------------------------------------------ @@ -149,19 +143,25 @@ -- | A datatype representing an HTTP cookie. data Cookie = Cookie { -- | The name of the cookie. - cookieName :: !ByteString + cookieName :: !ByteString -- | The cookie's string value. - , cookieValue :: !ByteString + , cookieValue :: !ByteString -- | The cookie's expiration value, if it has one. - , cookieExpires :: !(Maybe UTCTime) + , cookieExpires :: !(Maybe UTCTime) -- | The cookie's \"domain\" value, if it has one. - , cookieDomain :: !(Maybe ByteString) + , cookieDomain :: !(Maybe ByteString) -- | The cookie path. - , cookiePath :: !(Maybe ByteString) + , cookiePath :: !(Maybe ByteString) + + -- | Tag as secure cookie? + , cookieSecure :: !Bool + + -- | HttpOnly? + , cookieHttpOnly :: !Bool } deriving (Eq, Show) @@ -237,7 +237,7 @@ -- > , rqContextPath r -- > , rqPathInfo r -- > , let q = rqQueryString r - -- > , in if S.null q + -- > in if S.null q -- > then "" -- > else S.append "?" q -- > ] @@ -252,11 +252,11 @@ -- value of 'rqPathInfo' will be @\"bar\"@. , rqPathInfo :: !ByteString - -- | The \"context path\" of the request; catenating 'rqContextPath', and - -- 'rqPathInfo' should get you back to the original 'rqURI' (ignoring - -- query strings). The 'rqContextPath' always begins and ends with a - -- slash (@\"\/\"@) character, and represents the path (relative to your - -- component\/snaplet) you took to get to your handler. + -- | The \"context path\" of the request; catenating 'rqContextPath', + -- and 'rqPathInfo' should get you back to the original 'rqURI' + -- (ignoring query strings). The 'rqContextPath' always begins and ends + -- with a slash (@\"\/\"@) character, and represents the path (relative + -- to your component\/snaplet) you took to get to your handler. , rqContextPath :: !ByteString -- | Returns the @URI@ requested by the client. @@ -310,9 +310,9 @@ beginheaders = "Headers:\n ========================================" endheaders = " ========================================" - hdrs' (a,b) = (B.unpack $ CI.original a) ++ ": " ++ (show (map B.unpack b)) + hdrs' (a,b) = (B.unpack $ CI.original a) ++ ": " ++ B.unpack b hdrs = " " ++ (concat $ intersperse "\n " $ - map hdrs' (Map.toAscList $ rqHeaders r)) + map hdrs' (H.toList $ rqHeaders r)) contentlength = concat [ "content-length: " , show $ rqContentLength r ] @@ -414,27 +414,28 @@ ------------------------------------------------------------------------------ instance Show Response where - show r = concat [ "Response <\n" - , body - , ">" ] + show r = concat [ statusline + , hdrs + , "\r\n" + ] where - body = concat $ map ((" "++) . (++ "\n")) [ - hdrs - , version - , status - , reason - ] + (v1,v2) = rspHttpVersion r - hdrs = concat [ "headers:\n" - , " ==============================\n " - , show $ rspHeaders r - , "\n ==============================" ] + statusline = concat [ "HTTP/" + , show v1 + , "." + , show v2 + , " " + , show $ rspStatus r + , " " + , toStr $ rspStatusReason r + , "\r\n" ] - version = concat [ "version: ", show $ rspHttpVersion r ] - status = concat [ "status: ", show $ rspStatus r ] - reason = concat [ "reason: ", toStr $ rspStatusReason r ] + hdrs = concatMap showHdr $ H.toList $ rspHeaders r + showHdr (k,v) = concat [ toStr (CI.original k), ": ", toStr v, "\r\n" ] + ------------------------------------------------------------------------------ instance HasHeaders Response where headers = rspHeaders @@ -479,7 +480,7 @@ -- | An empty 'Response'. emptyResponse :: Response -emptyResponse = Response Map.empty Map.empty (1,1) Nothing +emptyResponse = Response H.empty Map.empty (1,1) Nothing (Enum (I.enumBuilder mempty)) 200 "OK" False @@ -535,20 +536,11 @@ ------------------------------------------------------------------------------ --- | addCookie has been deprecated and will be removed in 0.5. Please use --- 'addResponseCookie' instead. -addCookie :: Cookie -- ^ cookie value - -> Response -- ^ response to modify - -> Response -addCookie = addResponseCookie - - ------------------------------------------------------------------------------- -- | Adds an HTTP 'Cookie' to 'Response' headers. addResponseCookie :: Cookie -- ^ cookie value -> Response -- ^ response to modify -> Response -addResponseCookie ck@(Cookie k _ _ _ _) r = r { rspCookies = cks' } +addResponseCookie ck@(Cookie k _ _ _ _ _ _) r = r { rspCookies = cks' } where cks'= Map.insert k ck $ rspCookies r {-# INLINE addResponseCookie #-} @@ -571,7 +563,8 @@ ------------------------------------------------------------------------------ --- | Deletes an HTTP 'Cookie' from the 'Response' headers. +-- | Deletes an HTTP 'Cookie' from the 'Response' headers. Please note +-- this does not necessarily erase the cookie from the client browser. deleteResponseCookie :: ByteString -- ^ cookie name -> Response -- ^ response to modify -> Response @@ -678,102 +671,6 @@ c_parse_http_time ptr #endif - - ------------------------------------------------------------------------------- --- URL ENCODING ------------------------------------------------------------------------------- - -parseToCompletion :: Parser a -> ByteString -> Maybe a -parseToCompletion p s = toResult $ finish r - where - r = parse p s - - toResult (Atto.Done _ c) = Just c - toResult _ = Nothing - - ------------------------------------------------------------------------------- -pUrlEscaped :: Parser ByteString -pUrlEscaped = do - sq <- nextChunk DL.empty - return $ S.concat $ DL.toList sq - - where - nextChunk :: DList ByteString -> Parser (DList ByteString) - nextChunk s = (endOfInput *> pure s) <|> do - c <- anyWord8 - case w2c c of - '+' -> plusSpace s - '%' -> percentEncoded s - _ -> unEncoded c s - - percentEncoded :: DList ByteString -> Parser (DList ByteString) - percentEncoded l = do - hx <- take 2 - when (S.length hx /= 2 || - (not $ S.all (isHexDigit . w2c) hx)) $ - fail "bad hex in url" - - let code = (Cvt.hex hx) :: Word8 - nextChunk $ DL.snoc l (S.singleton code) - - unEncoded :: Word8 -> DList ByteString -> Parser (DList ByteString) - unEncoded c l' = do - let l = DL.snoc l' (S.singleton c) - bs <- takeTill (flip elem (map c2w "%+")) - if S.null bs - then nextChunk l - else nextChunk $ DL.snoc l bs - - plusSpace :: DList ByteString -> Parser (DList ByteString) - plusSpace l = nextChunk (DL.snoc l (S.singleton $ c2w ' ')) - - ------------------------------------------------------------------------------- --- | Decodes an URL-escaped string (see --- ) -urlDecode :: ByteString -> Maybe ByteString -urlDecode = parseToCompletion pUrlEscaped - - ------------------------------------------------------------------------------- --- "...Only alphanumerics [0-9a-zA-Z], the special characters "$-_.+!*'()," --- [not including the quotes - ed], and reserved characters used for their --- reserved purposes may be used unencoded within a URL." - --- | URL-escapes a string (see --- ) -urlEncode :: ByteString -> ByteString -urlEncode = toByteString . S.foldl' f mempty - where - f b c = - if c == c2w ' ' - then b `mappend` fromWord8 (c2w '+') - else if isKosher c - then b `mappend` fromWord8 c - else b `mappend` hexd c - - isKosher w = any ($ c) [ isAlphaNum - , flip elem ['$', '-', '.', '!', '*' - , '\'', '(', ')', ',' ]] - where - c = w2c w - - ------------------------------------------------------------------------------- -hexd :: Word8 -> Builder -hexd c = fromWord8 (c2w '%') `mappend` fromWord8 hi `mappend` fromWord8 low - where - d = c2w . intToDigit - low = d $ fromEnum $ c .&. 0xf - hi = d $ fromEnum $ (c .&. 0xf0) `shift` (-4) - - ------------------------------------------------------------------------------- -finish :: Atto.Result a -> Atto.Result a -finish (Atto.Partial f) = flip feed "" $ f "" -finish x = x ------------------------------------------------------------------------------ diff --git a/src/Snap/Internal/Instances.hs b/src/Snap/Internal/Instances.hs --- a/src/Snap/Internal/Instances.hs +++ b/src/Snap/Internal/Instances.hs @@ -3,21 +3,22 @@ module Snap.Internal.Instances where -import Control.Applicative -import Control.Monad.Cont -import Control.Monad.Error -import Control.Monad.List -import Control.Monad.RWS.Strict hiding (pass) -import qualified Control.Monad.RWS.Lazy as LRWS -import Control.Monad.Reader -import Control.Monad.State.Strict -import qualified Control.Monad.State.Lazy as LState -import Control.Monad.Writer.Strict hiding (pass) -import qualified Control.Monad.Writer.Lazy as LWriter -import Prelude hiding (catch) +import Control.Applicative +import Control.Monad.CatchIO () +import Control.Monad.Cont +import Control.Monad.Error +import Control.Monad.List +import Control.Monad.RWS.Strict hiding (pass) +import qualified Control.Monad.RWS.Lazy as LRWS +import Control.Monad.Reader +import Control.Monad.State.Strict +import qualified Control.Monad.State.Lazy as LState +import Control.Monad.Writer.Strict hiding (pass) +import qualified Control.Monad.Writer.Lazy as LWriter +import Prelude hiding (catch) ------------------------------------------------------------------------------ -import Snap.Internal.Types +import Snap.Internal.Types ------------------------------------------------------------------------------ diff --git a/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs b/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs --- a/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs +++ b/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs @@ -127,7 +127,8 @@ let !aftermatch = S.drop (hend+1) haystack step <- if not $ S.null nomatch - then lift $ runIteratee $ k $ Chunks [NoMatch nomatch] + then lift $ runIteratee $ k + $ Chunks [NoMatch nomatch] else return $ Continue k cDone step $ \k' -> do @@ -144,7 +145,7 @@ mkCoeff hidx = let !ll = hlen - hidx !nm = nlen - ll in (ll,nm) - + crossBound !hidx0 = {-# SCC "crossBound" #-} do let (!leftLen, needMore) = mkCoeff hidx0 diff --git a/src/Snap/Internal/Parsing.hs b/src/Snap/Internal/Parsing.hs --- a/src/Snap/Internal/Parsing.hs +++ b/src/Snap/Internal/Parsing.hs @@ -2,24 +2,40 @@ module Snap.Internal.Parsing where -import Control.Arrow (first) -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as S -import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.CaseInsensitive as CI -import Data.CaseInsensitive (CI) -import Data.Char (isAlpha, isAscii, isControl) +------------------------------------------------------------------------------ +import Blaze.ByteString.Builder import Control.Applicative +import Control.Arrow (first, second) import Control.Monad import Data.Attoparsec.Char8 hiding (Done, many) import qualified Data.Attoparsec.Char8 as Atto +import Data.Attoparsec.FastSet (FastSet) +import qualified Data.Attoparsec.FastSet as FS +import Data.Bits +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +import Data.ByteString.Internal (c2w, w2c) +import qualified Data.ByteString.Lazy.Char8 as L import Data.ByteString.Nums.Careless.Int (int) +import qualified Data.ByteString.Nums.Careless.Hex as Cvt +import qualified Data.CaseInsensitive as CI +import Data.CaseInsensitive (CI) +import Data.Char hiding (isDigit, isSpace) +import Data.DList (DList) +import qualified Data.DList as DL import Data.Int -import qualified Data.Vector.Unboxed as Vec -import Data.Vector.Unboxed (Vector) +import Data.List (intersperse) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Monoid +import Data.Word import Prelude hiding (head, take, takeWhile) +------------------------------------------------------------------------------ +import Snap.Internal.Http.Types + ------------------------------------------------------------------------------ fullyParse :: ByteString -> Parser a -> Either String a fullyParse s p = @@ -58,6 +74,11 @@ ------------------------------------------------------------------------------ +generateFS :: (Word8 -> Bool) -> FastSet +generateFS f = FS.fromList $ filter f [0..255] + + +------------------------------------------------------------------------------ -- | Parser for zero or more spaces. spaces :: Parser [Char] spaces = many sp @@ -72,14 +93,15 @@ fieldChars :: Parser ByteString fieldChars = takeWhile isFieldChar where - isFieldChar c = (Vec.!) fieldCharTable (fromEnum c) + isFieldChar = flip FS.memberChar fieldCharSet ------------------------------------------------------------------------------ -fieldCharTable :: Vector Bool -fieldCharTable = Vec.generate 256 f +fieldCharSet :: FastSet +fieldCharSet = generateFS f where - f d = let c=toEnum d in (isDigit c) || (isAlpha c) || c == '-' || c == '_' + f d = let c = (toEnum $ fromEnum d) + in (isDigit c) || (isAlpha c) || c == '-' || c == '_' ------------------------------------------------------------------------------ @@ -212,11 +234,11 @@ ------------------------------------------------------------------------------ {-# INLINE isToken #-} isToken :: Char -> Bool -isToken c = (Vec.!) tokenTable (fromEnum c) - where - tokenTable :: Vector Bool - tokenTable = Vec.generate 256 (f . toEnum) +isToken c = FS.memberChar c tokenTable +tokenTable :: FastSet +tokenTable = generateFS (f . toEnum . fromEnum) + where f = matchAll [ isAscii , not . isControl , not . isSpace @@ -224,6 +246,185 @@ , ':', '\\', '\"', '/', '[', ']' , '?', '=', '{', '}' ] ] + + +------------------------------------------------------------------------------ +-- URL ENCODING +------------------------------------------------------------------------------ + +parseToCompletion :: Parser a -> ByteString -> Maybe a +parseToCompletion p s = toResult $ finish r + where + r = parse p s + + toResult (Atto.Done _ c) = Just c + toResult _ = Nothing + + +------------------------------------------------------------------------------ +pUrlEscaped :: Parser ByteString +pUrlEscaped = do + sq <- nextChunk DL.empty + return $ S.concat $ DL.toList sq + + where + nextChunk :: DList ByteString -> Parser (DList ByteString) + nextChunk s = (endOfInput *> pure s) <|> do + c <- anyChar + case c of + '+' -> plusSpace s + '%' -> percentEncoded s + _ -> unEncoded c s + + percentEncoded :: DList ByteString -> Parser (DList ByteString) + percentEncoded l = do + hx <- take 2 + when (S.length hx /= 2 || (not $ S.all isHexDigit hx)) $ + fail "bad hex in url" + + let code = w2c ((Cvt.hex hx) :: Word8) + nextChunk $ DL.snoc l (S.singleton code) + + unEncoded :: Char -> DList ByteString -> Parser (DList ByteString) + unEncoded c l' = do + let l = DL.snoc l' (S.singleton c) + bs <- takeTill (flip elem "%+") + if S.null bs + then nextChunk l + else nextChunk $ DL.snoc l bs + + plusSpace :: DList ByteString -> Parser (DList ByteString) + plusSpace l = nextChunk (DL.snoc l (S.singleton ' ')) + + +------------------------------------------------------------------------------ +-- | Decodes an URL-escaped string (see +-- ) +urlDecode :: ByteString -> Maybe ByteString +urlDecode = parseToCompletion pUrlEscaped + + +------------------------------------------------------------------------------ +-- "...Only alphanumerics [0-9a-zA-Z], the special characters "$-_.+!*'()," +-- [not including the quotes - ed], and reserved characters used for their +-- reserved purposes may be used unencoded within a URL." + +-- | URL-escapes a string (see +-- ) +urlEncode :: ByteString -> ByteString +urlEncode = toByteString . urlEncodeBuilder + + +------------------------------------------------------------------------------ +-- | URL-escapes a string (see +-- ) into a 'Builder'. +urlEncodeBuilder :: ByteString -> Builder +urlEncodeBuilder = S.foldl' f mempty + where + f b c = + if c == ' ' + then b `mappend` fromWord8 (c2w '+') + else if FS.memberChar c urlEncodeTable + then b `mappend` fromWord8 (c2w c) + else b `mappend` hexd c + + +------------------------------------------------------------------------------ +urlEncodeTable :: FastSet +urlEncodeTable = generateFS f + where + f w = any ($ c) [ isAlphaNum + , flip elem ['$', '-', '.', '!', '*' + , '\'', '(', ')', ',' ]] + where + c = w2c w + + +------------------------------------------------------------------------------ +hexd :: Char -> Builder +hexd c0 = fromWord8 (c2w '%') `mappend` fromWord8 hi `mappend` fromWord8 low + where + c = c2w c0 + d = c2w . intToDigit + low = d $ fromEnum $ c .&. 0xf + hi = d $ fromEnum $ (c .&. 0xf0) `shiftR` 4 + + +------------------------------------------------------------------------------ +finish :: Atto.Result a -> Atto.Result a +finish (Atto.Partial f) = flip feed "" $ f "" +finish x = x + + + +------------------------------------------------------------------------------ +-- application/x-www-form-urlencoded +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- | Parses a string encoded in @application/x-www-form-urlencoded@ format. +parseUrlEncoded :: ByteString -> Map ByteString [ByteString] +parseUrlEncoded s = foldr (\(k,v) m -> Map.insertWith' (++) k [v] m) + Map.empty + decoded + where + breakApart = (second (S.drop 1)) . S.break (== '=') + + parts :: [(ByteString,ByteString)] + parts = map breakApart $ + S.splitWith (\c -> c == '&' || c == ';') s + + urldecode = parseToCompletion pUrlEscaped + + decodeOne (a,b) = do + a' <- urldecode a + b' <- urldecode b + return (a',b') + + decoded = catMaybes $ map decodeOne parts + + +------------------------------------------------------------------------------ +buildUrlEncoded :: Map ByteString [ByteString] -> Builder +buildUrlEncoded m = mconcat builders + where + builders = intersperse (fromWord8 $ c2w '&') $ + concatMap encodeVS $ Map.toList m + + encodeVS (k,vs) = map (encodeOne k) vs + + encodeOne k v = mconcat [ urlEncodeBuilder k + , fromWord8 $ c2w '=' + , urlEncodeBuilder v ] + + +------------------------------------------------------------------------------ +printUrlEncoded :: Map ByteString [ByteString] -> ByteString +printUrlEncoded = toByteString . buildUrlEncoded + + +------------------------------------------------------------------------------ +-- COOKIE PARSING +------------------------------------------------------------------------------ + +-- these definitions try to mirror RFC-2068 (the HTTP/1.1 spec) and RFC-2109 +-- (cookie spec): please point out any errors! + +------------------------------------------------------------------------------ +pCookies :: Parser [Cookie] +pCookies = do + -- grab kvps and turn to strict bytestrings + kvps <- pAvPairs + + return $ map toCookie $ filter (not . S.isPrefixOf "$" . fst) kvps + + where + toCookie (nm,val) = Cookie nm val Nothing Nothing Nothing False False + + +------------------------------------------------------------------------------ +parseCookie :: ByteString -> Maybe [Cookie] +parseCookie = parseToCompletion pCookies ------------------------------------------------------------------------------ diff --git a/src/Snap/Internal/Routing.hs b/src/Snap/Internal/Routing.hs --- a/src/Snap/Internal/Routing.hs +++ b/src/Snap/Internal/Routing.hs @@ -13,6 +13,7 @@ ------------------------------------------------------------------------------ import Snap.Internal.Http.Types +import Snap.Internal.Parsing import Snap.Internal.Types diff --git a/src/Snap/Internal/Test/Assertions.hs b/src/Snap/Internal/Test/Assertions.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Internal/Test/Assertions.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} +module Snap.Internal.Test.Assertions where + +------------------------------------------------------------------------------ +import Blaze.ByteString.Builder +import Control.Monad (liftM) +import Data.ByteString.Char8 (ByteString) +import Data.Maybe (fromJust) +import Data.Monoid (mconcat) +import Test.HUnit (Assertion, assertBool, assertEqual) +import Text.Regex.Posix ((=~)) + +------------------------------------------------------------------------------ +import Snap.Internal.Http.Types +import Snap.Iteratee (run_, consume, ($$)) + +------------------------------------------------------------------------------ +getResponseBody :: Response -> IO ByteString +getResponseBody rsp = run_ $ enum $$ liftM toBS consume + where + enum = rspBodyToEnum $ rspBody rsp + toBS = toByteString . mconcat + +------------------------------------------------------------------------------ +-- | Given a Response, asserts that its HTTP status code is 200 (success). +assertSuccess :: Response -> Assertion +assertSuccess rsp = assertEqual message 200 status + where + message = "Expected success (200) but got (" ++ (show status) ++ ")" + status = rspStatus rsp + +------------------------------------------------------------------------------ +-- | Given a Response, asserts that its HTTP status code is 404 (Not Found). +assert404 :: Response -> Assertion +assert404 rsp = assertEqual message 404 status + where + message = "Expected Not Found (404) but got (" ++ (show status) ++ ")" + status = rspStatus rsp + + +------------------------------------------------------------------------------ +-- | Given a Response, asserts that its HTTP status code is between 300 and +-- 399 (a redirect), and that the Location header of the Response points to +-- the specified URI. +assertRedirectTo :: ByteString -- ^ The Response should redirect to this + -- URI + -> Response + -> Assertion +assertRedirectTo uri rsp = do + assertRedirect rsp + assertEqual message uri rspUri + + where + rspUri = fromJust $ getHeader "Location" rsp + message = "Expected redirect to " ++ show uri + ++ " but got redirected to " + ++ show rspUri ++ " instead" + + +------------------------------------------------------------------------------ +-- | Given a Response, asserts that its HTTP status code is between 300 and +-- 399 (a redirect). +assertRedirect :: Response -> Assertion +assertRedirect rsp = assertBool message (300 <= status && status <= 399) + where + message = "Expected redirect but got status code (" + ++ show status ++ ")" + status = rspStatus rsp + + +------------------------------------------------------------------------------ +-- | Given a Response, asserts that its body matches the given regular +-- expression. +assertBodyContains :: ByteString -- ^ Regexp that will match the body content + -> Response + -> Assertion +assertBodyContains match rsp = do + body <- getResponseBody rsp + assertBool message (body =~ match) + where + message = "Expected body to match regexp \"" ++ show match + ++ "\", but didn't" diff --git a/src/Snap/Internal/Test/RequestBuilder.hs b/src/Snap/Internal/Test/RequestBuilder.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Internal/Test/RequestBuilder.hs @@ -0,0 +1,559 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module Snap.Internal.Test.RequestBuilder + ( RequestBuilder + , buildRequest + , MultipartParams + , MultipartParam(..) + , FileData (..) + , RequestType (..) + , setQueryStringRaw + , setQueryString + , setRequestType + , addHeader + , setHeader + , setContentType + , setSecure + , setHttpVersion + , setRequestPath + , get + , postUrlEncoded + , postMultipart + , put + , postRaw + , delete + , runHandler + , runHandler' + , dumpResponse + , responseToString + ) where + +------------------------------------------------------------------------------ +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Char8 +import Control.Monad.State hiding (get, put) +import qualified Control.Monad.State as State +import qualified Data.ByteString.Base16 as B16 +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +import Data.CaseInsensitive (CI) +import Data.IORef +import qualified Data.Map as Map +import Data.Monoid +import Data.Word +import System.PosixCompat.Time +import System.Random.MWC +------------------------------------------------------------------------------ +import Snap.Internal.Http.Types hiding (addHeader, + setContentType, + setHeader) +import qualified Snap.Internal.Http.Types as H +import Snap.Internal.Parsing +import Snap.Iteratee hiding (map) +import Snap.Core hiding (addHeader, setContentType, setHeader) +import qualified Snap.Types.Headers as H + +------------------------------------------------------------------------------ +-- | 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 (Monad, MonadIO, MonadTrans) + + +------------------------------------------------------------------------------ +mkDefaultRequest :: IO Request +mkDefaultRequest = do + bodyRef <- newIORef $ SomeEnumerator enumEOF + return $ Request "localhost" + 8080 + "127.0.0.1" + 60000 + "127.0.0.1" + 8080 + "localhost" + False + H.empty + bodyRef + Nothing + GET + (1,1) + [] + "" + "" + "/" + "/" + "" + Map.empty + + +------------------------------------------------------------------------------ +-- | Runs a 'RequestBuilder', producing the desired 'Request'. +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 + + fixupMethod = do + rq <- rGet + if (rqMethod rq == GET || rqMethod rq == DELETE || + rqMethod rq == HEAD) + then do + -- These requests are not permitted to have bodies + let rq' = deleteHeader "Content-Type" rq + liftIO $ writeIORef (rqBody rq') (SomeEnumerator enumEOF) + 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 q = rqQueryString rq + let pms = parseUrlEncoded q + + let mbCT = getHeader "Content-Type" rq + post <- if mbCT == Just "application/x-www-form-urlencoded" + then do + (SomeEnumerator e) <- liftIO $ readIORef $ rqBody rq + s <- liftM S.concat (liftIO $ run_ $ e $$ consume) + return $ parseUrlEncoded s + else return Map.empty + + rPut $ rq { rqParams = Map.unionWith (++) pms post } + +------------------------------------------------------------------------------ +-- | 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)] + + +------------------------------------------------------------------------------ +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) + + +------------------------------------------------------------------------------ +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. +setRequestType :: MonadIO m => RequestType -> RequestBuilder m () +setRequestType GetRequest = do + rq <- rGet + liftIO $ writeIORef (rqBody rq) $ SomeEnumerator enumEOF + rPut $ rq { rqMethod = GET + , rqContentLength = Nothing + } + +setRequestType DeleteRequest = do + rq <- rGet + liftIO $ writeIORef (rqBody rq) $ SomeEnumerator enumEOF + rPut $ rq { rqMethod = DELETE + , rqContentLength = Nothing + } + +setRequestType (RequestWithRawBody m b) = do + rq <- rGet + liftIO $ writeIORef (rqBody rq) $ SomeEnumerator $ enumBS b + rPut $ rq { rqMethod = m + , rqContentLength = Just $ S.length b + } + +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 + liftIO $ writeIORef (rqBody rq) $ SomeEnumerator $ enumBS b + rPut $ rq { rqMethod = POST + , rqContentLength = Just $ S.length b + } + + +------------------------------------------------------------------------------ +makeBoundary :: MonadIO m => m ByteString +makeBoundary = do + xs <- liftIO $ withSystemRandom $ \rng -> + replicateM 16 ((uniform rng) :: IO Word8) + let x = S.pack $ map (toEnum . fromEnum) xs + return $ S.concat [ "snap-boundary-", B16.encode x ] + + +------------------------------------------------------------------------------ +multipartHeader :: ByteString -> ByteString -> Builder +multipartHeader boundary name = + mconcat [ fromByteString boundary + , fromByteString "\r\ncontent-disposition: form-data" + , fromByteString "; name=\"" + , fromByteString name + , fromByteString "\"\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 + , fromByteString v + , fromByteString "\r\n--" ] + _ -> multi + + where + hdr = multipartHeader boundary name + cr = fromByteString "\r\n" + + oneVal b v = mconcat [ fromByteString b + , cr + , cr + , fromByteString v + , fromByteString "\r\n--" ] + + multi = do + b <- makeBoundary + return $ mconcat [ hdr + , multipartMixed b + , cr + , fromByteString "--" + , mconcat (map (oneVal b) vals) + , fromByteString b + , fromByteString "--\r\n--" ] + +multipartMixed :: ByteString -> Builder +multipartMixed b = mconcat [ fromByteString "Content-Type: multipart/mixed" + , fromByteString "; boundary=" + , fromByteString b + , fromByteString "\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 + , fromByteString "--" + , mconcat (map (oneVal b) files) + , fromByteString b + , fromByteString "--\r\n--" + ] + + where + contentDisposition fn = mconcat [ + fromByteString "Content-Disposition: attachment" + , fromByteString "; filename=\"" + , fromByteString fn + , fromByteString "\"\r\n" + ] + + contentType ct = mconcat [ + fromByteString "Content-Type: " + , fromByteString ct + , cr + ] + + oneVal b (FileData fileName ct contents) = + mconcat [ fromByteString b + , cr + , contentType ct + , contentDisposition fileName + , fromByteString "Content-Transfer-Encoding: binary\r\n" + , cr + , fromByteString contents + , fromByteString "\r\n--" + ] + + hdr = multipartHeader boundary name + cr = fromByteString "\r\n" + + +------------------------------------------------------------------------------ +encodeMultipart :: MonadIO m => MultipartParams -> RequestBuilder m () +encodeMultipart kvps = do + boundary <- liftIO $ makeBoundary + builders <- liftIO $ mapM (handleOne boundary) kvps + + let b = toByteString $ + mconcat (fromByteString "--" : builders) + `mappend` finalBoundary boundary + + rq0 <- rGet + liftIO $ writeIORef (rqBody rq0) $ SomeEnumerator $ enumBS b + let rq = H.setHeader "Content-Type" + (S.append "multipart/form-data; boundary=" boundary) + rq0 + + rPut $ rq { rqMethod = POST + , rqContentLength = Just $ S.length b + } + + + where + finalBoundary b = mconcat [fromByteString b, fromByteString "--\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 + let u = S.concat [ rqSnapletPath rq + , rqContextPath rq + , rqPathInfo rq + , let q = rqQueryString rq + in if S.null q + then "" + else S.append "?" q + ] + 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. +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. +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. +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. +addHeader :: (Monad m) => CI ByteString -> ByteString -> RequestBuilder m () +addHeader k v = rModify (H.addHeader k v) + + +------------------------------------------------------------------------------ +-- | Sets the request's @content-type@ to the given MIME type. +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. +setSecure :: Monad m => Bool -> RequestBuilder m () +setSecure b = rModify $ \rq -> rq { rqIsSecure = b } + + +------------------------------------------------------------------------------ +-- | Sets the test request's http version +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. +setRequestPath :: Monad m => ByteString -> RequestBuilder m () +setRequestPath p = do + rModify $ \rq -> rq { rqSnapletPath = "" + , rqContextPath = "" + , rqPathInfo = p } + fixupURI + + +------------------------------------------------------------------------------ +-- | Builds an HTTP \"GET\" request with the given query parameters. +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. +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. +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. +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. +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. +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 + setHeader "Content-Type" contentType + setRequestPath uri + + +------------------------------------------------------------------------------ +-- | Given a web handler in some 'MonadSnap' monad, and a 'RequestBuilder' +-- defining a test request, runs the handler, producing an HTTP 'Response'. +runHandler' :: (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 +runHandler' rSnap rBuilder snap = do + rq <- buildRequest rBuilder + rsp <- rSnap rq snap + t1 <- liftIO (epochTime >>= formatHttpTime) + return $ H.setHeader "Date" t1 rsp + + +------------------------------------------------------------------------------ +-- | Given a web handler in the 'Snap' monad, and a 'RequestBuilder' defining +-- a test request, runs the handler, producing an HTTP 'Response'. +runHandler :: MonadIO m => + RequestBuilder m () -- ^ a request builder + -> Snap a -- ^ a web handler + -> m Response +runHandler = runHandler' rs + where + rs rq s = do + (_,rsp) <- liftIO $ run_ $ runSnap s + (const $ return $! ()) + (const $ return $! ()) + rq + return rsp + + +------------------------------------------------------------------------------ +-- | Dumps the given response to stdout. +dumpResponse :: Response -> IO () +dumpResponse resp = responseToString resp >>= S.putStrLn + + +------------------------------------------------------------------------------ +-- | Converts the given response to a bytestring. +responseToString :: Response -> IO ByteString +responseToString resp = do + b <- run_ (rspBodyToEnum (rspBody resp) $$ + liftM mconcat consume) + + return $ toByteString $ fromShow resp `mappend` b + + + +------------------------------------------------------------------------------ +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 diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs --- a/src/Snap/Internal/Types.hs +++ b/src/Snap/Internal/Types.hs @@ -23,11 +23,12 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L -import Data.CaseInsensitive (CI) +import Data.CaseInsensitive (CI) import Data.Int import Data.IORef import Data.Maybe import Data.Monoid +import Data.Time import qualified Data.Text as T import qualified Data.Text.Lazy as LT import Data.Typeable @@ -257,7 +258,7 @@ -- | The Typeable instance is here so Snap can be dynamically executed with -- Hint. snapTyCon :: TyCon -snapTyCon = mkTyCon "Snap.Types.Snap" +snapTyCon = mkTyCon "Snap.Core.Snap" {-# NOINLINE snapTyCon #-} instance Typeable1 Snap where @@ -319,13 +320,32 @@ ------------------------------------------------------------------------------ --- | Returns the request body as a bytestring. +-- | Returns the request body as a lazy bytestring. +-- +-- This function is deprecated as of 0.6; it places no limits on the size of +-- the request being read, and as such, if used, can result in a +-- denial-of-service attack on your server. Please use 'readRequestBody' +-- instead. getRequestBody :: MonadSnap m => m L.ByteString getRequestBody = liftM L.fromChunks $ runRequestBody consume {-# INLINE getRequestBody #-} +{-# DEPRECATED getRequestBody + "As of 0.6, please use 'readRequestBody' instead" #-} ------------------------------------------------------------------------------ +-- | Returns the request body as a lazy bytestring. /New in 0.6./ +readRequestBody :: MonadSnap m => + Int64 -- ^ size of the largest request body we're willing + -- to accept. If a request body longer than this is + -- received, a 'TooManyBytesReadException' is + -- thrown. See 'takeNoMoreThan'. + -> m L.ByteString +readRequestBody sz = liftM L.fromChunks $ runRequestBody $ + joinI $ takeNoMoreThan sz $$ consume + + +------------------------------------------------------------------------------ -- | Normally Snap is careful to ensure that the request body is fully -- consumed after your web handler runs, but before the 'Response' enumerator -- is streamed out the socket. If you want to transform the request body into @@ -488,8 +508,8 @@ let (p,_) = S.break (=='/') (rqPathInfo req) a <- fromBS p localRequest (updateContextPath $ S.length p) (f a) - + ------------------------------------------------------------------------------ -- | Runs a 'Snap' monad action only when 'rqPathInfo' is empty. ifTop :: MonadSnap m => m a -> m a @@ -804,7 +824,8 @@ ------------------------------------------------------------------------------ -data ConnectionTerminatedException = ConnectionTerminatedException SomeException +data ConnectionTerminatedException = + ConnectionTerminatedException SomeException deriving (Typeable) @@ -913,6 +934,20 @@ => ByteString -> m a readCookie name = maybe pass (fromBS . cookieValue) =<< getCookie name + + +------------------------------------------------------------------------------ +-- | Expire the given 'Cookie' in client's browser. +expireCookie :: (MonadSnap m) + => ByteString + -- ^ Cookie name + -> Maybe ByteString + -- ^ Cookie domain + -> m () +expireCookie nm dm = do + let old = UTCTime (ModifiedJulianDay 0) 0 + modifyResponse $ addResponseCookie + $ Cookie nm "" (Just old) Nothing dm False False ------------------------------------------------------------------------------ diff --git a/src/Snap/Iteratee.hs b/src/Snap/Iteratee.hs --- a/src/Snap/Iteratee.hs +++ b/src/Snap/Iteratee.hs @@ -684,10 +684,11 @@ enumBuilderToByteString = builderToByteString ------------------------------------------------------------------------------ -unsafeEnumBuilderToByteString :: MonadIO m => Enumeratee Builder ByteString m a +unsafeEnumBuilderToByteString :: MonadIO m + => Enumeratee Builder ByteString m a unsafeEnumBuilderToByteString = builderToByteStringWith (reuseBufferStrategy (allocBuffer 65536)) - + ------------------------------------------------------------------------------ enumByteStringToBuilder :: MonadIO m => Enumeratee ByteString Builder m a diff --git a/src/Snap/Test.hs b/src/Snap/Test.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Test.hs @@ -0,0 +1,55 @@ +-- | The Snap.Test module contains primitives and combinators for testing Snap +-- applications. +module Snap.Test + ( -- * Combinators and types for testing Snap handlers. + + -- ** Types + RequestBuilder + , MultipartParams + , MultipartParam(..) + , FileData (..) + , RequestType (..) + + -- ** Building Requests and testing handlers + , buildRequest + , runHandler + + -- *** Convenience functions for generating common types of HTTP requests + , get + , postUrlEncoded + , postMultipart + , put + , postRaw + , delete + + -- *** Precise control over building Requests + , addHeader + , setContentType + , setHeader + , setHttpVersion + , setQueryString + , setQueryStringRaw + , setRequestPath + , setRequestType + , setSecure + + -- * HUnit Assertions + , assertSuccess + , assert404 + , assertRedirectTo + , assertRedirect + , assertBodyContains + + -- * Getting response bodies + , getResponseBody + + -- * Dumping HTTP Responses + , dumpResponse + , responseToString + ) + where + +import Snap.Internal.Test.Assertions +import Snap.Internal.Test.RequestBuilder + + diff --git a/src/Snap/Types.hs b/src/Snap/Types.hs --- a/src/Snap/Types.hs +++ b/src/Snap/Types.hs @@ -1,150 +1,6 @@ -{-| - -This module contains the core type definitions, class instances, and functions -for HTTP as well as the 'Snap' monad, which is used for web handlers. - --} -module Snap.Types - ( - -- * The Snap Monad - Snap - , runSnap - , MonadSnap(..) - , NoHandlerException(..) - - -- ** Functions for control flow and early termination - , bracketSnap - , finishWith - , catchFinishWith - , pass - , terminateConnection - - -- ** Routing - , method - , methods - , path - , pathArg - , dir - , ifTop - , route - , routeLocal - - -- ** Access to state - , getRequest - , getResponse - , putRequest - , putResponse - , modifyRequest - , modifyResponse - , localRequest - , withRequest - , withResponse - - -- ** Logging - , logError - - -- ** Grabbing/transforming request bodies - , runRequestBody - , getRequestBody - , transformRequestBody - - -- * HTTP Datatypes and Functions - -- $httpDoc - -- - , Request - , Response - , Headers - , HasHeaders(..) - , Params - , Method(..) - , Cookie(..) - , HttpVersion - - -- ** Headers - , addHeader - , setHeader - , getHeader - , deleteHeader - , ipHeaderFilter - , ipHeaderFilter' - - -- ** Requests - , rqServerName - , rqServerPort - , rqRemoteAddr - , rqRemotePort - , rqLocalAddr - , rqLocalHostname - , rqIsSecure - , rqContentLength - , rqMethod - , rqVersion - , rqCookies - , rqPathInfo - , rqContextPath - , rqURI - , rqQueryString - , rqParams - , rqParam - , getParam - , getParams - , rqModifyParams - , rqSetParam - - -- ** Responses - , emptyResponse - , setResponseCode - , setResponseStatus - , rspStatus - , rspStatusReason - , setContentType - , addCookie - , addResponseCookie - , getResponseCookie - , getResponseCookies - , deleteResponseCookie - , modifyResponseCookie - , getCookie - , readCookie - , setContentLength - , clearContentLength - , redirect - , redirect' - - -- *** Response I/O - , setResponseBody - , modifyResponseBody - , addToOutput - , writeBuilder - , writeBS - , writeLazyText - , writeText - , writeLBS - , sendFile - , sendFilePartial - - -- ** Timeouts - , setTimeout - , getTimeoutAction - - -- * Iteratee - , Enumerator - , SomeEnumerator(..) - - -- * HTTP utilities - , formatHttpTime - , parseHttpTime - , urlEncode - , urlDecode - ) where - ------------------------------------------------------------------------------- -import Snap.Internal.Http.Types -import Snap.Internal.Instances () -import Snap.Internal.Routing -import Snap.Internal.Types -import Snap.Iteratee (Enumerator) ------------------------------------------------------------------------------- +-- | As of Snap 0.6, the "Snap.Types" module is deprecated: please use +-- "Snap.Core" instead. +module Snap.Types {-# DEPRECATED "As of 0.6, use Snap.Core instead" #-} + ( module Snap.Core ) where --- $httpDoc --- HTTP-related datatypes: 'Request', 'Response', 'Cookie', etc. +import Snap.Core diff --git a/src/Snap/Types/Headers.hs b/src/Snap/Types/Headers.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Types/Headers.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE BangPatterns #-} + +-- | An opaque data type for HTTP headers. Intended to be imported qualified, +-- i.e: +-- +-- > import Snap.Types.Headers (Headers) +-- > import qualified Snap.Types.Headers as H +-- > +-- > foo :: Headers +-- > foo = H.empty + +module Snap.Types.Headers + ( -- * Headers type + Headers + + -- * Headers creation + , empty + + -- * Predicates + , null + , member + + -- * Lookup + , lookup + , lookupWithDefault + + -- * Adding/setting headers + , insert + , set + + -- * Deleting + , delete + + -- * Traversal + , fold + + -- * Lists + , toList + , fromList + + ) where + +import Data.ByteString.Char8 (ByteString) +import Data.CaseInsensitive (CI) +import Data.List (foldl') +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as Map +import Data.Maybe (isJust) +import Prelude hiding (null, lookup) + +------------------------------------------------------------------------------ +newtype Headers = H { unH :: HashMap (CI ByteString) [ByteString] } + deriving (Show) + + +------------------------------------------------------------------------------ +empty :: Headers +empty = H (Map.empty) + + +------------------------------------------------------------------------------ +null :: Headers -> Bool +null = Map.null . unH +{-# INLINE null #-} + + +------------------------------------------------------------------------------ +member :: CI ByteString -> Headers -> Bool +member k = f . unH + where + f m = isJust $ Map.lookup k m +{-# INLINE member #-} + + +------------------------------------------------------------------------------ +lookup :: CI ByteString -> Headers -> Maybe [ByteString] +lookup k (H m) = Map.lookup k m +{-# INLINE lookup #-} + + +------------------------------------------------------------------------------ +lookupWithDefault :: ByteString -> CI ByteString -> Headers -> [ByteString] +lookupWithDefault d k (H m) = Map.lookupDefault [d] k m + + +------------------------------------------------------------------------------ +insert :: CI ByteString -> ByteString -> Headers -> Headers +insert k v (H m) = H $ Map.insertWith (flip (++)) k [v] m + + +------------------------------------------------------------------------------ +set :: CI ByteString -> ByteString -> Headers -> Headers +set k v (H m) = H $ Map.insert k [v] m + + +------------------------------------------------------------------------------ +delete :: CI ByteString -> Headers -> Headers +delete k (H m) = H $ Map.delete k m + + +------------------------------------------------------------------------------ +fold :: (a -> CI ByteString -> [ByteString] -> a) + -> a + -> Headers + -> a +fold f a (H m) = Map.foldlWithKey' f a m + + +------------------------------------------------------------------------------ +toList :: Headers -> [(CI ByteString, ByteString)] +toList (H m) = (Map.foldlWithKey' f id m) [] + where + f !dl k vs = dl . ((map (\v -> (k,v)) vs) ++) + + +------------------------------------------------------------------------------ +fromList :: [(CI ByteString, ByteString)] -> Headers +fromList = foldl' f empty + where + f m (k,v) = insert k v m diff --git a/src/Snap/Util/FileServe.hs b/src/Snap/Util/FileServe.hs --- a/src/Snap/Util/FileServe.hs +++ b/src/Snap/Util/FileServe.hs @@ -16,16 +16,12 @@ , fancyDirectoryConfig , defaultIndexGenerator , defaultMimeTypes +, fileType -- * File servers , serveDirectory , serveDirectoryWith , serveFile , serveFileAs - -- * Deprecated interface -, fileServe -, fileServe' -, fileServeSingle -, fileServeSingle' ) where ------------------------------------------------------------------------------ @@ -54,10 +50,10 @@ import System.FilePath import System.PosixCompat.Files ------------------------------------------------------------------------------ +import Snap.Core import Snap.Internal.Debug import Snap.Internal.Parsing import Snap.Iteratee hiding (drop) -import Snap.Types ------------------------------------------------------------------------------ @@ -269,7 +265,8 @@ , "border-top: 1px solid rgb(194,209,225);" , "color: rgb(160,172,186); font-size:10pt;" , "background: rgb(245,249,255) }" - , "table { max-width:100%; margin: 0 auto; border-collapse: collapse; }" + , "table { max-width:100%; margin: 0 auto;" `S.append` + " border-collapse: collapse; }" , "tr:hover { background:rgb(256,256,224) }" , "td { border:0; font-family:monospace; padding: 2px 0; }" , "td.filename, td.type { padding-right: 2em; }" @@ -698,68 +695,6 @@ ------------------------------------------------------------------------------ dbg :: (MonadIO m) => String -> m () dbg s = debug $ "FileServe:" ++ s - - ------------------------------------------------------------------------------- --- Obsolete functions retained for compatibility. ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- | Serves files out of the given directory, using no index files and default --- MIME types. --- --- The function name is obsolete. You should use 'serveDirectory' or --- 'serveDirectoryWith' instead, which do similar things but with more options --- and clearer, more consistent names. -fileServe :: MonadSnap m - => FilePath -- ^ root directory - -> m () -fileServe = serveDirectoryWith simpleDirectoryConfig -{-# INLINE fileServe #-} -{-# DEPRECATED fileServe "Use serveDirectory or serveDirectoryWith" #-} - - ------------------------------------------------------------------------------- --- | Serves files out of the given directory, with a given MIME type mapping. --- --- The function name is obsolete. You should use 'serveDirectoryWith' --- instead, which offers more options and a clearer, more consistent name. -fileServe' :: MonadSnap m - => MimeMap -- ^ MIME type mapping - -> FilePath -- ^ root directory - -> m () -fileServe' mm = serveDirectoryWith (simpleDirectoryConfig { mimeTypes = mm }) -{-# INLINE fileServe' #-} -{-# DEPRECATED fileServe' "Use serveDirectoryWith instead" #-} - - ------------------------------------------------------------------------------- --- | Serves a single file specified by a full or relative path. The --- path restrictions on fileServe don't apply to this function since --- the path is not being supplied by the user. --- --- The function name is obsolete. You should use 'serveFile' instead, which --- does the same thing but with a clearer, more consistent name. -fileServeSingle :: MonadSnap m - => FilePath -- ^ path to file - -> m () -fileServeSingle = serveFile -{-# INLINE fileServeSingle #-} -{-# DEPRECATED fileServeSingle "Use serveFile instead" #-} - - ------------------------------------------------------------------------------- --- | Same as 'fileServeSingle', with control over the MIME mapping used. --- --- The function name is obsolete. You should use 'serveFileAs' instead, which --- does the same thing but with a clearer, more consistent name. -fileServeSingle' :: MonadSnap m - => ByteString -- ^ MIME type mapping - -> FilePath -- ^ path to file - -> m () -fileServeSingle' = serveFileAs -{-# INLINE fileServeSingle' #-} -{-# DEPRECATED fileServeSingle' "Use serveFileAs instead" #-} ------------------------------------------------------------------------------ diff --git a/src/Snap/Util/FileUploads.hs b/src/Snap/Util/FileUploads.hs --- a/src/Snap/Util/FileUploads.hs +++ b/src/Snap/Util/FileUploads.hs @@ -93,13 +93,14 @@ import System.Directory import System.IO hiding (isEOF) ------------------------------------------------------------------------------ +import Snap.Core import Snap.Iteratee hiding (map) import qualified Snap.Iteratee as I import Snap.Internal.Debug import Snap.Internal.Iteratee.Debug import Snap.Internal.Iteratee.BoyerMooreHorspool import Snap.Internal.Parsing -import Snap.Types +import qualified Snap.Types.Headers as H #ifdef USE_UNIX import System.FilePath (()) @@ -292,7 +293,7 @@ rateLimit bump $ internalHandleMultipart boundary ph - ins k v = Map.insertWith' (\a b -> Prelude.head a : b) k [v] + ins k v = Map.insertWith' (flip (++)) k [v] maxFormVars = maximumNumberOfFormInputs uploadPolicy @@ -749,11 +750,11 @@ go :: (Monad m) => (Stream ByteString -> Iteratee ByteString m a) -> Iteratee MatchInfo m (Step ByteString m a) go !k = {-# SCC "pPart/go" #-} - I.head >>= maybe finish process + I.head >>= maybe finished process where -- called when outer stream is EOF - finish = {-# SCC "pPart/finish" #-} - lift $ runIteratee $ k EOF + finished = {-# SCC "pPart/finish" #-} + lift $ runIteratee $ k EOF -- no match ==> pass the stream chunk along process (NoMatch !s) = {-# SCC "pPart/noMatch" #-} do @@ -819,10 +820,9 @@ ------------------------------------------------------------------------------ toHeaders :: [(ByteString,ByteString)] -> Headers -toHeaders kvps = foldl' f Map.empty kvps' +toHeaders kvps = H.fromList kvps' where - kvps' = map (first CI.mk . second (:[])) kvps - f m (k,v) = Map.insertWith' (flip (++)) k v m + kvps' = map (first CI.mk) kvps ------------------------------------------------------------------------------ diff --git a/src/Snap/Util/GZip.hs b/src/Snap/Util/GZip.hs --- a/src/Snap/Util/GZip.hs +++ b/src/Snap/Util/GZip.hs @@ -11,13 +11,11 @@ import Blaze.ByteString.Builder import qualified Codec.Zlib.Enum as Z -import Control.Concurrent import Control.Applicative hiding (many) import Control.Exception import Control.Monad import Control.Monad.Trans import Data.Attoparsec.Char8 hiding (Done) -import qualified Data.ByteString.Lazy.Char8 as L import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import qualified Data.Char as Char @@ -30,11 +28,11 @@ ---------------------------------------------------------------------------- +import Snap.Core import Snap.Internal.Debug import Snap.Internal.Parsing import Snap.Iteratee import qualified Snap.Iteratee as I -import Snap.Types ------------------------------------------------------------------------------ diff --git a/test/runTestsAndCoverage.sh b/test/runTestsAndCoverage.sh --- a/test/runTestsAndCoverage.sh +++ b/test/runTestsAndCoverage.sh @@ -38,7 +38,9 @@ Snap.Internal.Http.Server.Tests Snap.Internal.Http.Types.Tests Snap.Internal.Iteratee.Tests +Snap.Internal.Parsing.Tests Snap.Internal.Routing.Tests +Snap.Test.Tests Snap.Types.Tests Snap.Util.FileServe.Tests Snap.Util.FileUploads.Tests diff --git a/test/snap-core-testsuite.cabal b/test/snap-core-testsuite.cabal --- a/test/snap-core-testsuite.cabal +++ b/test/snap-core-testsuite.cabal @@ -31,7 +31,7 @@ blaze-builder-enumerator >= 0.2 && <0.3, bytestring, bytestring-nums, - case-insensitive >= 0.2 && < 0.4, + case-insensitive >= 0.3 && < 0.4, cereal == 0.3.*, containers, deepseq >= 1.1 && <1.3, @@ -42,18 +42,20 @@ enumerator >= 0.4.13.1 && < 0.5, MonadCatchIO-transformers >= 0.2 && < 0.3, mtl >= 2 && <3, + mwc-random >= 0.10 && <0.11, old-locale, old-time, parallel >= 3 && <4, pureMD5 == 2.1.*, regex-posix >= 0.94.4 && <0.96, - test-framework >= 0.3.1 && <0.5, + test-framework >= 0.4 && < 0.5, test-framework-hunit >= 0.2.5 && < 0.3, test-framework-quickcheck2 >= 0.2.6 && < 0.3, text >= 0.11 && <0.12, time, transformers, unix-compat >= 0.2 && <0.4, + unordered-containers >= 0.1.4.3 && <0.2, vector >= 0.6 && <0.10, zlib, zlib-enum >= 0.2.1 && <0.3 diff --git a/test/suite/Snap/Core/Tests.hs b/test/suite/Snap/Core/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Core/Tests.hs @@ -0,0 +1,590 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Snap.Core.Tests + ( tests ) where + +import Blaze.ByteString.Builder +import Control.Applicative +import Control.Concurrent.MVar +import Control.DeepSeq +import Control.Exception (ErrorCall(..), SomeException, throwIO) +import Control.Monad +import Control.Monad.CatchIO +import Control.Monad.Trans (liftIO) +import Control.Parallel.Strategies +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.IntMap as IM +import Data.IORef +import Data.Maybe (isJust) +import Data.Monoid +import Data.Text () +import Data.Text.Lazy () +import qualified Data.Map as Map +import Prelude hiding (catch) +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit hiding (Test, path) + +import Snap.Internal.Http.Types +import Snap.Internal.Parsing +import Snap.Internal.Types +import Snap.Iteratee +import qualified Snap.Iteratee as I +import Snap.Test.Common +import qualified Snap.Types.Headers as H + + +tests :: [Test] +tests = [ testFail + , testAlternative + , testEarlyTermination + , testCatchFinishWith + , testRqBody + , testRqBodyTooLong + , testRqBodyException + , testRqBodyTermination + , testTrivials + , testMethod + , testMethods + , testDir + , testCatchIO + , testWrites + , testParam + , testURLEncode1 + , testURLEncode2 + , testDir2 + , testIpHeaderFilter + , testMZero404 + , testEvalSnap + , testLocalRequest + , testRedirect + , testBracketSnap ] + + +expectSpecificException :: Exception e => e -> IO a -> IO () +expectSpecificException e0 m = do + r <- try m + + let b = either (\se -> isJust $ + forceSameType (Just e0) (fromException se)) + (const False) + r + assertBool ("expected specific exception: " ++ show e0) b + + +expect404 :: IO (Request,Response) -> IO () +expect404 m = do + (_,r) <- m + assertBool "expected 404" (rspStatus r == 404) + + +expectNo404 :: IO (Request,Response) -> IO () +expectNo404 m = do + (_,r) <- m + assertBool ("expected 200, got " ++ show (rspStatus r)) + (rspStatus r /= 404) + + +mkRequest :: ByteString -> IO Request +mkRequest uri = do + enum <- newIORef $ SomeEnumerator returnI + + return $ Request "foo" 80 "127.0.0.1" 999 "foo" 1000 "foo" False H.empty + enum Nothing GET (1,1) [] "" uri "/" + (S.concat ["/",uri]) "" Map.empty + +mkRequestQuery :: ByteString -> ByteString -> [ByteString] -> IO Request +mkRequestQuery uri k v = do + enum <- newIORef $ SomeEnumerator returnI + + let mp = Map.fromList [(k,v)] + let q = S.concat [k,"=", S.concat v] + + return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False H.empty + enum Nothing GET (1,1) [] "" uri "/" + (S.concat ["/",uri,"?",q]) q mp + + +mkZomgRq :: IO Request +mkZomgRq = do + enum <- newIORef $ SomeEnumerator returnI + + return $ Request "foo" 80 "127.0.0.1" 999 "foo" 1000 "foo" False H.empty + enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty + + +mkIpHeaderRq :: IO Request +mkIpHeaderRq = do + rq <- mkZomgRq + return $ setHeader "X-Forwarded-For" "1.2.3.4" + $ deleteHeader "X-Forwarded-For" + $ setHeader "X-Forwarded-For" "1.2.3.4" rq + + +mkRqWithBody :: IO Request +mkRqWithBody = mkRqWithEnum (enumBS "zazzle" >==> enumEOF) + + +mkRqWithEnum :: (forall a . Enumerator ByteString IO a) -> IO Request +mkRqWithEnum e = do + enum <- newIORef $ SomeEnumerator e + return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False H.empty + enum Nothing GET (1,1) [] "" "/" "/" "/" "" + Map.empty + +testCatchIO :: Test +testCatchIO = testCase "types/catchIO" $ do + (_,rsp) <- go f + (_,rsp2) <- go g + + assertEqual "catchIO 1" (Just "bar") $ getHeader "foo" rsp + assertEqual "catchIO 2" Nothing $ getHeader "foo" rsp2 + + where + f :: Snap () + f = (block $ unblock $ throw $ NoHandlerException "") `catch` h + + g :: Snap () + g = return () `catch` h + + h :: SomeException -> Snap () + h e = e `seq` modifyResponse $ addHeader "foo" "bar" + +go :: Snap a -> IO (Request,Response) +go m = do + zomgRq <- mkZomgRq + run_ $ runSnap m dummy dummy zomgRq + where + dummy !x = return $! (show x `using` rdeepseq) `seq` () + +goIP :: Snap a -> IO (Request,Response) +goIP m = do + rq <- mkIpHeaderRq + run_ $ runSnap m dummy dummy rq + where + dummy = const $ return () + +goPath :: ByteString -> Snap a -> IO (Request,Response) +goPath s m = do + rq <- mkRequest s + run_ $ runSnap m dummy dummy rq + where + dummy = const $ return () + + +goPathQuery :: ByteString + -> ByteString + -> [ByteString] + -> Snap a + -> IO (Request,Response) +goPathQuery s k v m = do + rq <- mkRequestQuery s k v + run_ $ runSnap m dummy dummy rq + where + dummy = const $ return () + + +goBody :: Snap a -> IO (Request,Response) +goBody m = do + rq <- mkRqWithBody + run_ $ runSnap m dummy dummy rq + where + dummy = const $ return () + + +goEnum :: (forall a . Enumerator ByteString IO a) + -> Snap b + -> IO (Request,Response) +goEnum enum m = do + rq <- mkRqWithEnum enum + run_ $ runSnap m dummy dummy rq + where + dummy = const $ return () + + +testFail :: Test +testFail = testCase "failure" $ expect404 (go pass) + + +setFoo :: ByteString -> Snap () +setFoo s = do + modifyResponse (addHeader "Foo" s) + fmap id $ pure () + pure id <*> (liftIO $ return ()) + + +testAlternative :: Test +testAlternative = testCase "types/alternative" $ do + (_,resp) <- go (pass <|> setFoo "Bar") + assertEqual "foo present" (Just "Bar") $ getHeader "Foo" resp + + (_,resp2) <- go (fail "" + <|> fail2 + <|> setFoo "Bar" + <|> setFoo "Baz") + assertEqual "alternative chooses correct branch" + (Just ["Bar"]) $ getHeaders "Foo" resp2 + + where + fail2 :: Snap () + fail2 = pass >>= \_ -> return () + + +sampleResponse :: Response +sampleResponse = addHeader "Foo" "Quux" $ emptyResponse + + +testEarlyTermination :: Test +testEarlyTermination = testCase "types/earlyTermination" $ do + (_,resp) <- go (finishWith sampleResponse >>= \_ -> setFoo "Bar") + assertEqual "foo" (Just ["Quux"]) $ getHeaders "Foo" resp + + +isLeft :: Either a b -> Bool +isLeft (Left _) = True +isLeft _ = False + +isRight :: Either a b -> Bool +isRight (Right _) = True +isRight _ = False + + +testBracketSnap :: Test +testBracketSnap = testCase "types/bracketSnap" $ do + rq <- mkZomgRq + + ref <- newIORef 0 + + expectSpecificException (NoHandlerException "") $ + run_ $ evalSnap (act ref) (const $ return ()) (const $ return ()) rq + + y <- readIORef ref + assertEqual "bracketSnap/after1" (1::Int) y + + expectSpecificException (ErrorCall "no value") $ + run_ $ evalSnap (act ref <|> finishWith emptyResponse) + (const $ return ()) + (const $ return ()) + rq + + y' <- readIORef ref + assertEqual "bracketSnap/after" 2 y' + + + expectSpecificException (ErrorCall "foo") $ + run_ $ evalSnap (act2 ref) + (const $ return ()) + (const $ return ()) + rq + + y'' <- readIORef ref + assertEqual "bracketSnap/after" 3 y'' + + where + act ref = bracketSnap (liftIO $ readIORef ref) + (\z -> liftIO $ writeIORef ref $! z+1) + (\z -> z `seq` mzero) + + act2 ref = bracketSnap (liftIO $ readIORef ref) + (\z -> liftIO $ writeIORef ref $! z+1) + (\z -> z `seq` liftIO $ throwIO $ ErrorCall "foo") + + +testCatchFinishWith :: Test +testCatchFinishWith = testCase "types/catchFinishWith" $ do + rq <- mkZomgRq + x <- run_ $ evalSnap (catchFinishWith $ finishWith emptyResponse) + (const $ return ()) + (const $ return ()) + rq + assertBool "catchFinishWith" $ isLeft x + y <- run_ $ evalSnap (catchFinishWith $ return ()) + (const $ return ()) + (const $ return ()) + rq + assertBool "catchFinishWith" $ isRight y + + +testRqBody :: Test +testRqBody = testCase "types/requestBodies" $ do + mvar1 <- newEmptyMVar + mvar2 <- newEmptyMVar + + _ <- goBody $ f mvar1 mvar2 + + v1 <- takeMVar mvar1 + v2 <- takeMVar mvar2 + + assertEqual "rq body" "zazzle" v1 + assertEqual "rq body 2" "" v2 + + (_,rsp) <- goBody g + bd <- getBody rsp + + assertEqual "detached rq body" "zazzle" bd + + + where + f mvar1 mvar2 = do + getRequestBody >>= liftIO . putMVar mvar1 + getRequestBody >>= liftIO . putMVar mvar2 + + g = transformRequestBody returnI + + +testRqBodyTooLong :: Test +testRqBodyTooLong = testCase "types/requestBodyTooLong" $ do + expectExceptionH $ goBody $ f 2 + (_, rsp) <- goBody $ f 200000 + bd <- getBody rsp + + assertEqual "detached rq body" "zazzle" bd + + + where + f sz = readRequestBody sz >>= writeLBS + + +testRqBodyException :: Test +testRqBodyException = testCase "types/requestBodyException" $ do + (req,resp) <- goEnum (enumList 1 ["the", "quick", "brown", "fox"]) hndlr + bd <- getBody resp + + (SomeEnumerator e) <- readIORef $ rqBody req + b' <- liftM (S.concat) $ run_ $ e $$ consume + assertEqual "request body was consumed" "" b' + assertEqual "response body was produced" "OK" bd + + where + h0 = runRequestBody $ do + _ <- I.head + throw $ ErrorCall "foo" + + hndlr = h0 `catch` \(_::SomeException) -> writeBS "OK" + + +testRqBodyTermination :: Test +testRqBodyTermination = + testCase "types/requestBodyTermination" $ + expectExceptionH $ + goEnum (enumList 1 ["the", "quick", "brown", "fox"]) hndlr + + where + h0 = runRequestBody $ do + _ <- I.head + terminateConnection $ ErrorCall "foo" + + hndlr = h0 `catch` \(_::SomeException) -> writeBS "OK" + + + +testTrivials :: Test +testTrivials = testCase "types/trivials" $ do + (rq,rsp) <- go $ do + req <- getRequest + putRequest $ req { rqIsSecure=True } + putResponse $ setResponseStatus 333 "333" sampleResponse + r <- getResponse + liftIO $ assertEqual "rsp status" 333 $ rspStatus r + !_ <- localRequest (\x -> x {rqIsSecure=False}) $ do + q <- getRequest + liftIO $ assertEqual "localrq" False $ rqIsSecure q + return () + + logError "foo" + writeText "zzz" + writeLazyText "zzz" + + let req' = updateContextPath 0 req + let cp1 = rqContextPath req + let cp2 = rqContextPath req' + + liftIO $ assertEqual "updateContextPath 0" cp1 cp2 + + withRequest $ return . (`seq` ()) + withResponse $ return . (`seq` ()) + + return () + + b <- getBody rsp + coverShowInstance b + coverShowInstance $ NoHandlerException "" + coverShowInstance GET + coverReadInstance GET + coverEqInstance GET + coverEqInstance $ NoHandlerException "" + coverOrdInstance GET + + Prelude.map (\(x,y) -> (x,show y)) (IM.toList statusReasonMap) + `deepseq` return () + + let cookie = Cookie "" "" Nothing Nothing Nothing False False + coverEqInstance cookie + coverShowInstance cookie + + assertEqual "rq secure" True $ rqIsSecure rq + assertEqual "rsp status" 333 $ rspStatus rsp + + +testMethod :: Test +testMethod = testCase "types/method" $ do + expect404 $ go (method POST $ return ()) + expectNo404 $ go (method GET $ return ()) + +testMethods :: Test +testMethods = testCase "types/methods" $ do + expect404 $ go (methods [POST,PUT] $ return ()) + expectNo404 $ go (methods [GET] $ return ()) + expectNo404 $ go (methods [POST,GET] $ return ()) + expectNo404 $ go (methods [PUT,GET] $ return ()) + expectNo404 $ go (methods [GET,PUT,DELETE] $ return ()) + + +testDir :: Test +testDir = testCase "types/dir" $ do + expect404 $ goPath "foo/bar" (dir "zzz" $ return ()) + expectNo404 $ goPath "foo/bar" (dir "foo" $ return ()) + expect404 $ goPath "fooz/bar" (dir "foo" $ return ()) + expectNo404 $ goPath "foo/bar" (path "foo/bar" $ return ()) + expect404 $ goPath "foo/bar/z" (path "foo/bar" $ return ()) + expectNo404 $ goPath "" (ifTop $ return ()) + expect404 $ goPath "a" (ifTop $ return ()) + + +testParam :: Test +testParam = testCase "types/getParam" $ do + expect404 $ goPath "/foo" f + expectNo404 $ goPathQuery "/foo" "param" ["foo"] f + where + f = do + mp <- getParam "param" + maybe pass + (\s -> if s == "foo" then return () else pass) + mp + + +getBody :: Response -> IO L.ByteString +getBody r = do + let benum = rspBodyToEnum $ rspBody r + liftM (toLazyByteString . mconcat) (runIteratee consume >>= run_ . benum) + + +testWrites :: Test +testWrites = testCase "types/writes" $ do + (_,r) <- go h + b <- getBody r + assertEqual "output functions" "Foo1Foo2Foo3" b + where + h :: Snap () + h = do + addToOutput $ enumBuilder $ fromByteString "Foo1" + writeBS "Foo2" + writeLBS "Foo3" + + +testURLEncode1 :: Test +testURLEncode1 = testCase "types/urlEncoding1" $ do + let b = urlEncode "the quick brown fox~#" + assertEqual "url encoding 1" "the+quick+brown+fox%7e%23" b + assertEqual "fail" Nothing $ urlDecode "%" + + +testURLEncode2 :: Test +testURLEncode2 = testProperty "types/urlEncoding2" prop + where + prop s = (urlDecode $ urlEncode s) == Just s + + +testDir2 :: Test +testDir2 = testCase "types/dir2" $ do + (_,resp) <- goPath "foo/bar" f + b <- getBody resp + assertEqual "context path" "/foo/bar/" b + + where + f = dir "foo" $ dir "bar" $ do + p <- liftM rqContextPath getRequest + addToOutput $ enumBuilder $ fromByteString p + + +testIpHeaderFilter :: Test +testIpHeaderFilter = testCase "types/ipHeaderFilter" $ do + (_,r) <- goIP f + b <- getBody r + assertEqual "ipHeaderFilter" "1.2.3.4" b + + + (_,r2) <- go f + b2 <- getBody r2 + assertEqual "ipHeaderFilter" "127.0.0.1" b2 + + where + f = do + ipHeaderFilter + ip <- liftM rqRemoteAddr getRequest + writeBS ip + + +testMZero404 :: Test +testMZero404 = testCase "types/mzero404" $ do + (_,r) <- go mzero + let l = rspContentLength r + b <- getBody r + assertEqual "mzero 404" "404" b + assertEqual "mzero 404 length" (Just 3) l + + +testEvalSnap :: Test +testEvalSnap = testCase "types/evalSnap-exception" $ do + rq <- mkZomgRq + expectExceptionH (run_ $ evalSnap f + (const $ return ()) + (const $ return ()) + rq >> return ()) + where + f = do + logError "zzz" + v <- withResponse (return . rspHttpVersion) + liftIO $ assertEqual "evalSnap rsp version" (1,1) v + finishWith emptyResponse + + +testLocalRequest :: Test +testLocalRequest = testCase "types/localRequest" $ do + rq1 <- mkZomgRq + rq2 <- mkRequest "zzz/zz/z" + + let h = localRequest (const rq2) mzero + + (rq',_) <- go (h <|> return ()) + + let u1 = rqURI rq1 + let u2 = rqURI rq' + + assertEqual "localRequest backtrack" u1 u2 + + + +testRedirect :: Test +testRedirect = testCase "types/redirect" $ do + (_,rsp) <- go (redirect "/foo/bar") + + b <- getBody rsp + assertEqual "no response body" "" b + assertEqual "response content length" (Just 0) $ rspContentLength rsp + assertEqual "redirect path" (Just "/foo/bar") $ getHeader "Location" rsp + assertEqual "redirect status" 302 $ rspStatus rsp + assertEqual "status description" "Found" $ rspStatusReason rsp + + + (_,rsp2) <- go (redirect' "/bar/foo" 307) + + assertEqual "redirect path" (Just "/bar/foo") $ getHeader "Location" rsp2 + assertEqual "redirect status" 307 $ rspStatus rsp2 + assertEqual "status description" "Temporary Redirect" $ rspStatusReason rsp2 diff --git a/test/suite/Snap/Internal/Http/Types/Tests.hs b/test/suite/Snap/Internal/Http/Types/Tests.hs --- a/test/suite/Snap/Internal/Http/Types/Tests.hs +++ b/test/suite/Snap/Internal/Http/Types/Tests.hs @@ -20,7 +20,9 @@ import Text.Regex.Posix import Snap.Internal.Http.Types +import Snap.Internal.Parsing import Snap.Iteratee +import qualified Snap.Types.Headers as H tests :: [Test] @@ -34,7 +36,7 @@ mkRq :: IO Request mkRq = do enum <- newIORef (SomeEnumerator $ enumBS "") - return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty + return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False H.empty enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty @@ -57,7 +59,7 @@ let x = getHeader "foo" req - assertEqual "addHeader x 2" (Just "bar baz") x + assertEqual "addHeader x 2" (Just "baz bar") x testUrlDecode :: Test @@ -70,7 +72,7 @@ defReq <- mkRq let req = rqModifyParams (Map.insert "zzz" ["bbb"]) $ - updateHeaders (Map.insert "zzz" ["bbb"]) $ + updateHeaders (H.set "zzz" "bbb") $ rqSetParam "foo" ["bar"] $ defReq @@ -84,7 +86,7 @@ assertBool "show" $ a /= b assertEqual "rqParam" (Just ["bar"]) (rqParam "foo" req) assertEqual "lookup" (Just ["bbb"]) (Map.lookup "zzz" $ rqParams req) - assertEqual "lookup 2" (Just ["bbb"]) (Map.lookup "zzz" $ headers req) + assertEqual "lookup 2" (Just ["bbb"]) (H.lookup "zzz" $ headers req) assertEqual "response status" 555 $ rspStatus resp assertEqual "response status reason" "bogus" $ rspStatusReason resp @@ -116,8 +118,8 @@ resp2 = addResponseCookie cook2 resp utc = UTCTime (ModifiedJulianDay 55226) 0 - cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") - cook2 = Cookie "zoo" "baz" (Just utc) (Just ".foo.com") (Just "/") + cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") False False + cook2 = Cookie "zoo" "baz" (Just utc) (Just ".foo.com") (Just "/") False False testCookies :: Test @@ -146,9 +148,9 @@ resp4 = addResponseCookie cook3 emptyResponse utc = UTCTime (ModifiedJulianDay 55226) 0 - cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") - cook2 = Cookie "zoo" "baz" (Just utc) (Just ".foo.com") (Just "/") - cook3 = Cookie "boo" "baz" Nothing Nothing Nothing + cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") False True + cook2 = Cookie "zoo" "baz" (Just utc) (Just ".foo.com") (Just "/") True False + cook3 = Cookie "boo" "baz" Nothing Nothing Nothing False False rCook = getResponseCookie "foo" resp nilCook = getResponseCookie "foo" resp' diff --git a/test/suite/Snap/Internal/Parsing/Tests.hs b/test/suite/Snap/Internal/Parsing/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Internal/Parsing/Tests.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +module Snap.Internal.Parsing.Tests + ( tests ) where + + +import qualified Data.ByteString as S +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test, path) + +import Snap.Internal.Http.Types +import Snap.Internal.Parsing + + +tests :: [Test] +tests = [ testCookie ] + + +testCookie :: Test +testCookie = + testCase "parsing/parseCookie" $ do + assertEqual "cookie parsing" (Just [cv]) cv2 + + where + cv = Cookie nm v Nothing Nothing Nothing False False + cv2 = parseCookie ct + + nm = "foo" + v = "bar" + + ct = S.concat [ nm , "=" , v ] diff --git a/test/suite/Snap/Internal/Routing/Tests.hs b/test/suite/Snap/Internal/Routing/Tests.hs --- a/test/suite/Snap/Internal/Routing/Tests.hs +++ b/test/suite/Snap/Internal/Routing/Tests.hs @@ -16,11 +16,11 @@ import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, path) - import Snap.Internal.Http.Types import Snap.Internal.Routing import Snap.Internal.Types import Snap.Iteratee hiding (head) +import qualified Snap.Types.Headers as H tests :: [Test] tests = [ testRouting1 @@ -65,7 +65,7 @@ mkRequest uri = do enum <- newIORef $ SomeEnumerator returnI - return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty + return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False H.empty enum Nothing GET (1,1) [] "" uri "/" (B.concat ["/",uri]) "" Map.empty diff --git a/test/suite/Snap/Iteratee/Tests.hs b/test/suite/Snap/Iteratee/Tests.hs --- a/test/suite/Snap/Iteratee/Tests.hs +++ b/test/suite/Snap/Iteratee/Tests.hs @@ -32,32 +32,12 @@ import Snap.Iteratee import Snap.Internal.Iteratee.BoyerMooreHorspool -import Snap.Test.Common (coverShowInstance) +import Snap.Test.Common import Snap.Internal.Iteratee.Debug -liftQ :: forall a m . (Monad m) => m a -> PropertyM m a -liftQ = QC.run - - throwErr :: String -> Iteratee a IO b throwErr = throwError . AssertionFailed - - -expectException :: IO a -> PropertyM IO () -expectException m = do - e <- liftQ $ E.try m - case e of - Left (z::SomeException) -> (show z) `seq` return () - Right _ -> fail "expected exception, didn't get one" - - -expectExceptionH :: IO a -> IO () -expectExceptionH act = do - e <- E.try act - case e of - Left (z::SomeException) -> (show z) `seq` return () - Right _ -> fail "expected expected, didn't get one" tests :: [Test] diff --git a/test/suite/Snap/Test/Common.hs b/test/suite/Snap/Test/Common.hs --- a/test/suite/Snap/Test/Common.hs +++ b/test/suite/Snap/Test/Common.hs @@ -10,6 +10,9 @@ , coverShowInstance , coverTypeableInstance , forceSameType + , expectException + , expectExceptionH + , liftQ , eatException ) where @@ -24,6 +27,8 @@ import Data.Typeable import Prelude hiding (catch) import Test.QuickCheck +import qualified Test.QuickCheck.Monadic as QC +import Test.QuickCheck.Monadic instance Arbitrary S.ByteString where @@ -83,3 +88,23 @@ coverTypeableInstance :: (Monad m, Typeable a) => a -> m () coverTypeableInstance a = typeOf a `seq` return () + + +expectException :: IO a -> PropertyM IO () +expectException m = do + e <- liftQ $ try m + case e of + Left (z::SomeException) -> (length $ show z) `seq` return () + Right _ -> fail "expected exception, didn't get one" + + +expectExceptionH :: IO a -> IO () +expectExceptionH act = do + e <- try act + case e of + Left (z::SomeException) -> (length $ show z) `seq` return () + Right _ -> fail "expected exception, didn't get one" + + +liftQ :: forall a m . (Monad m) => m a -> PropertyM m a +liftQ = QC.run diff --git a/test/suite/Snap/Types/Tests.hs b/test/suite/Snap/Types/Tests.hs deleted file mode 100644 --- a/test/suite/Snap/Types/Tests.hs +++ /dev/null @@ -1,584 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Snap.Types.Tests - ( tests ) where - -import Blaze.ByteString.Builder -import Control.Applicative -import Control.Concurrent.MVar -import Control.DeepSeq -import Control.Exception (ErrorCall(..), SomeException, throwIO) -import Control.Monad -import Control.Monad.CatchIO -import Control.Monad.Trans (liftIO) -import Control.Parallel.Strategies -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as S -import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.IntMap as IM -import Data.IORef -import Data.Maybe (isJust) -import Data.Monoid -import Data.Text () -import Data.Text.Lazy () -import qualified Data.Map as Map -import Prelude hiding (catch) -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 -import Test.HUnit hiding (Test, path) - -import Snap.Internal.Types -import Snap.Internal.Http.Types -import Snap.Iteratee -import qualified Snap.Iteratee as I -import Snap.Test.Common - - -tests :: [Test] -tests = [ testFail - , testAlternative - , testEarlyTermination - , testCatchFinishWith - , testRqBody - , testRqBodyException - , testRqBodyTermination - , testTrivials - , testMethod - , testMethods - , testDir - , testCatchIO - , testWrites - , testParam - , testURLEncode1 - , testURLEncode2 - , testDir2 - , testIpHeaderFilter - , testMZero404 - , testEvalSnap - , testLocalRequest - , testRedirect - , testBracketSnap ] - - -expectException :: IO a -> IO () -expectException m = do - r <- try m - let b = either (\e -> (show (e::SomeException) `using` rdeepseq) - `seq` True) - (const False) - r - assertBool "expected exception" b - - -expectSpecificException :: Exception e => e -> IO a -> IO () -expectSpecificException e0 m = do - r <- try m - - let b = either (\se -> isJust $ - forceSameType (Just e0) (fromException se)) - (const False) - r - assertBool ("expected specific exception: " ++ show e0) b - - -expect404 :: IO (Request,Response) -> IO () -expect404 m = do - (_,r) <- m - assertBool "expected 404" (rspStatus r == 404) - - -expectNo404 :: IO (Request,Response) -> IO () -expectNo404 m = do - (_,r) <- m - assertBool ("expected 200, got " ++ show (rspStatus r)) - (rspStatus r /= 404) - - -mkRequest :: ByteString -> IO Request -mkRequest uri = do - enum <- newIORef $ SomeEnumerator returnI - - return $ Request "foo" 80 "127.0.0.1" 999 "foo" 1000 "foo" False Map.empty - enum Nothing GET (1,1) [] "" uri "/" - (S.concat ["/",uri]) "" Map.empty - -mkRequestQuery :: ByteString -> ByteString -> [ByteString] -> IO Request -mkRequestQuery uri k v = do - enum <- newIORef $ SomeEnumerator returnI - - let mp = Map.fromList [(k,v)] - let q = S.concat [k,"=", S.concat v] - - return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty - enum Nothing GET (1,1) [] "" uri "/" - (S.concat ["/",uri,"?",q]) q mp - - -mkZomgRq :: IO Request -mkZomgRq = do - enum <- newIORef $ SomeEnumerator returnI - - return $ Request "foo" 80 "127.0.0.1" 999 "foo" 1000 "foo" False Map.empty - enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty - - -mkIpHeaderRq :: IO Request -mkIpHeaderRq = do - rq <- mkZomgRq - return $ setHeader "X-Forwarded-For" "1.2.3.4" - $ deleteHeader "X-Forwarded-For" - $ setHeader "X-Forwarded-For" "1.2.3.4" rq - - -mkRqWithBody :: IO Request -mkRqWithBody = mkRqWithEnum (enumBS "zazzle" >==> enumEOF) - - -mkRqWithEnum :: (forall a . Enumerator ByteString IO a) -> IO Request -mkRqWithEnum e = do - enum <- newIORef $ SomeEnumerator e - return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty - enum Nothing GET (1,1) [] "" "/" "/" "/" "" - Map.empty - -testCatchIO :: Test -testCatchIO = testCase "types/catchIO" $ do - (_,rsp) <- go f - (_,rsp2) <- go g - - assertEqual "catchIO 1" (Just "bar") $ getHeader "foo" rsp - assertEqual "catchIO 2" Nothing $ getHeader "foo" rsp2 - - where - f :: Snap () - f = (block $ unblock $ throw $ NoHandlerException "") `catch` h - - g :: Snap () - g = return () `catch` h - - h :: SomeException -> Snap () - h e = e `seq` modifyResponse $ addHeader "foo" "bar" - -go :: Snap a -> IO (Request,Response) -go m = do - zomgRq <- mkZomgRq - run_ $ runSnap m dummy dummy zomgRq - where - dummy !x = return $! (show x `using` rdeepseq) `seq` () - -goIP :: Snap a -> IO (Request,Response) -goIP m = do - rq <- mkIpHeaderRq - run_ $ runSnap m dummy dummy rq - where - dummy = const $ return () - -goPath :: ByteString -> Snap a -> IO (Request,Response) -goPath s m = do - rq <- mkRequest s - run_ $ runSnap m dummy dummy rq - where - dummy = const $ return () - - -goPathQuery :: ByteString - -> ByteString - -> [ByteString] - -> Snap a - -> IO (Request,Response) -goPathQuery s k v m = do - rq <- mkRequestQuery s k v - run_ $ runSnap m dummy dummy rq - where - dummy = const $ return () - - -goBody :: Snap a -> IO (Request,Response) -goBody m = do - rq <- mkRqWithBody - run_ $ runSnap m dummy dummy rq - where - dummy = const $ return () - - -goEnum :: (forall a . Enumerator ByteString IO a) - -> Snap b - -> IO (Request,Response) -goEnum enum m = do - rq <- mkRqWithEnum enum - run_ $ runSnap m dummy dummy rq - where - dummy = const $ return () - - -testFail :: Test -testFail = testCase "failure" $ expect404 (go pass) - - -setFoo :: ByteString -> Snap () -setFoo s = do - modifyResponse (addHeader "Foo" s) - fmap id $ pure () - pure id <*> (liftIO $ return ()) - - -testAlternative :: Test -testAlternative = testCase "types/alternative" $ do - (_,resp) <- go (pass <|> setFoo "Bar") - assertEqual "foo present" (Just "Bar") $ getHeader "Foo" resp - - (_,resp2) <- go (fail "" - <|> fail2 - <|> setFoo "Bar" - <|> setFoo "Baz") - assertEqual "alternative chooses correct branch" - (Just ["Bar"]) $ getHeaders "Foo" resp2 - - where - fail2 :: Snap () - fail2 = pass >>= \_ -> return () - - -sampleResponse :: Response -sampleResponse = addHeader "Foo" "Quux" $ emptyResponse - - -testEarlyTermination :: Test -testEarlyTermination = testCase "types/earlyTermination" $ do - (_,resp) <- go (finishWith sampleResponse >>= \_ -> setFoo "Bar") - assertEqual "foo" (Just ["Quux"]) $ getHeaders "Foo" resp - - -isLeft :: Either a b -> Bool -isLeft (Left _) = True -isLeft _ = False - -isRight :: Either a b -> Bool -isRight (Right _) = True -isRight _ = False - - -testBracketSnap :: Test -testBracketSnap = testCase "types/bracketSnap" $ do - rq <- mkZomgRq - - ref <- newIORef 0 - - expectSpecificException (NoHandlerException "") $ - run_ $ evalSnap (act ref) (const $ return ()) (const $ return ()) rq - - y <- readIORef ref - assertEqual "bracketSnap/after1" (1::Int) y - - expectSpecificException (ErrorCall "no value") $ - run_ $ evalSnap (act ref <|> finishWith emptyResponse) - (const $ return ()) - (const $ return ()) - rq - - y' <- readIORef ref - assertEqual "bracketSnap/after" 2 y' - - - expectSpecificException (ErrorCall "foo") $ - run_ $ evalSnap (act2 ref) - (const $ return ()) - (const $ return ()) - rq - - y'' <- readIORef ref - assertEqual "bracketSnap/after" 3 y'' - - where - act ref = bracketSnap (liftIO $ readIORef ref) - (\z -> liftIO $ writeIORef ref $! z+1) - (\z -> z `seq` mzero) - - act2 ref = bracketSnap (liftIO $ readIORef ref) - (\z -> liftIO $ writeIORef ref $! z+1) - (\z -> z `seq` liftIO $ throwIO $ ErrorCall "foo") - - -testCatchFinishWith :: Test -testCatchFinishWith = testCase "types/catchFinishWith" $ do - rq <- mkZomgRq - x <- run_ $ evalSnap (catchFinishWith $ finishWith emptyResponse) - (const $ return ()) - (const $ return ()) - rq - assertBool "catchFinishWith" $ isLeft x - y <- run_ $ evalSnap (catchFinishWith $ return ()) - (const $ return ()) - (const $ return ()) - rq - assertBool "catchFinishWith" $ isRight y - - -testRqBody :: Test -testRqBody = testCase "types/requestBodies" $ do - mvar1 <- newEmptyMVar - mvar2 <- newEmptyMVar - - _ <- goBody $ f mvar1 mvar2 - - v1 <- takeMVar mvar1 - v2 <- takeMVar mvar2 - - assertEqual "rq body" "zazzle" v1 - assertEqual "rq body 2" "" v2 - - (_,rsp) <- goBody g - bd <- getBody rsp - - assertEqual "detached rq body" "zazzle" bd - - - where - f mvar1 mvar2 = do - getRequestBody >>= liftIO . putMVar mvar1 - getRequestBody >>= liftIO . putMVar mvar2 - - g = transformRequestBody returnI - - -testRqBodyException :: Test -testRqBodyException = testCase "types/requestBodyException" $ do - (req,resp) <- goEnum (enumList 1 ["the", "quick", "brown", "fox"]) hndlr - bd <- getBody resp - - (SomeEnumerator e) <- readIORef $ rqBody req - b' <- liftM (S.concat) $ run_ $ e $$ consume - assertEqual "request body was consumed" "" b' - assertEqual "response body was produced" "OK" bd - - where - h0 = runRequestBody $ do - _ <- I.head - throw $ ErrorCall "foo" - - hndlr = h0 `catch` \(_::SomeException) -> writeBS "OK" - - -testRqBodyTermination :: Test -testRqBodyTermination = - testCase "types/requestBodyTermination" $ - expectException $ - goEnum (enumList 1 ["the", "quick", "brown", "fox"]) hndlr - - where - h0 = runRequestBody $ do - _ <- I.head - terminateConnection $ ErrorCall "foo" - - hndlr = h0 `catch` \(_::SomeException) -> writeBS "OK" - - - -testTrivials :: Test -testTrivials = testCase "types/trivials" $ do - (rq,rsp) <- go $ do - req <- getRequest - putRequest $ req { rqIsSecure=True } - putResponse $ setResponseStatus 333 "333" sampleResponse - r <- getResponse - liftIO $ assertEqual "rsp status" 333 $ rspStatus r - !_ <- localRequest (\x -> x {rqIsSecure=False}) $ do - q <- getRequest - liftIO $ assertEqual "localrq" False $ rqIsSecure q - return () - - logError "foo" - writeText "zzz" - writeLazyText "zzz" - - let req' = updateContextPath 0 req - let cp1 = rqContextPath req - let cp2 = rqContextPath req' - - liftIO $ assertEqual "updateContextPath 0" cp1 cp2 - - withRequest $ return . (`seq` ()) - withResponse $ return . (`seq` ()) - - return () - - b <- getBody rsp - coverShowInstance b - coverShowInstance $ NoHandlerException "" - coverShowInstance GET - coverReadInstance GET - coverEqInstance GET - coverEqInstance $ NoHandlerException "" - coverOrdInstance GET - - Prelude.map (\(x,y) -> (x,show y)) (IM.toList statusReasonMap) - `deepseq` return () - - let cookie = Cookie "" "" Nothing Nothing Nothing - coverEqInstance cookie - coverShowInstance cookie - - assertEqual "rq secure" True $ rqIsSecure rq - assertEqual "rsp status" 333 $ rspStatus rsp - - -testMethod :: Test -testMethod = testCase "types/method" $ do - expect404 $ go (method POST $ return ()) - expectNo404 $ go (method GET $ return ()) - -testMethods :: Test -testMethods = testCase "types/methods" $ do - expect404 $ go (methods [POST,PUT] $ return ()) - expectNo404 $ go (methods [GET] $ return ()) - expectNo404 $ go (methods [POST,GET] $ return ()) - expectNo404 $ go (methods [PUT,GET] $ return ()) - expectNo404 $ go (methods [GET,PUT,DELETE] $ return ()) - - -testDir :: Test -testDir = testCase "types/dir" $ do - expect404 $ goPath "foo/bar" (dir "zzz" $ return ()) - expectNo404 $ goPath "foo/bar" (dir "foo" $ return ()) - expect404 $ goPath "fooz/bar" (dir "foo" $ return ()) - expectNo404 $ goPath "foo/bar" (path "foo/bar" $ return ()) - expect404 $ goPath "foo/bar/z" (path "foo/bar" $ return ()) - expectNo404 $ goPath "" (ifTop $ return ()) - expect404 $ goPath "a" (ifTop $ return ()) - - -testParam :: Test -testParam = testCase "types/getParam" $ do - expect404 $ goPath "/foo" f - expectNo404 $ goPathQuery "/foo" "param" ["foo"] f - where - f = do - mp <- getParam "param" - maybe pass - (\s -> if s == "foo" then return () else pass) - mp - - -getBody :: Response -> IO L.ByteString -getBody r = do - let benum = rspBodyToEnum $ rspBody r - liftM (toLazyByteString . mconcat) (runIteratee consume >>= run_ . benum) - - -testWrites :: Test -testWrites = testCase "types/writes" $ do - (_,r) <- go h - b <- getBody r - assertEqual "output functions" "Foo1Foo2Foo3" b - where - h :: Snap () - h = do - addToOutput $ enumBuilder $ fromByteString "Foo1" - writeBS "Foo2" - writeLBS "Foo3" - - -testURLEncode1 :: Test -testURLEncode1 = testCase "types/urlEncoding1" $ do - let b = urlEncode "the quick brown fox~#" - assertEqual "url encoding 1" "the+quick+brown+fox%7e%23" b - assertEqual "fail" Nothing $ urlDecode "%" - - -testURLEncode2 :: Test -testURLEncode2 = testProperty "types/urlEncoding2" prop - where - prop s = (urlDecode $ urlEncode s) == Just s - - -testDir2 :: Test -testDir2 = testCase "types/dir2" $ do - (_,resp) <- goPath "foo/bar" f - b <- getBody resp - assertEqual "context path" "/foo/bar/" b - - where - f = dir "foo" $ dir "bar" $ do - p <- liftM rqContextPath getRequest - addToOutput $ enumBuilder $ fromByteString p - - -testIpHeaderFilter :: Test -testIpHeaderFilter = testCase "types/ipHeaderFilter" $ do - (_,r) <- goIP f - b <- getBody r - assertEqual "ipHeaderFilter" "1.2.3.4" b - - - (_,r2) <- go f - b2 <- getBody r2 - assertEqual "ipHeaderFilter" "127.0.0.1" b2 - - where - f = do - ipHeaderFilter - ip <- liftM rqRemoteAddr getRequest - writeBS ip - - -testMZero404 :: Test -testMZero404 = testCase "types/mzero404" $ do - (_,r) <- go mzero - let l = rspContentLength r - b <- getBody r - assertEqual "mzero 404" "404" b - assertEqual "mzero 404 length" (Just 3) l - - -testEvalSnap :: Test -testEvalSnap = testCase "types/evalSnap-exception" $ do - rq <- mkZomgRq - expectException (run_ $ evalSnap f - (const $ return ()) - (const $ return ()) - rq >> return ()) - where - f = do - logError "zzz" - v <- withResponse (return . rspHttpVersion) - liftIO $ assertEqual "evalSnap rsp version" (1,1) v - finishWith emptyResponse - - -testLocalRequest :: Test -testLocalRequest = testCase "types/localRequest" $ do - rq1 <- mkZomgRq - rq2 <- mkRequest "zzz/zz/z" - - let h = localRequest (const rq2) mzero - - (rq',_) <- go (h <|> return ()) - - let u1 = rqURI rq1 - let u2 = rqURI rq' - - assertEqual "localRequest backtrack" u1 u2 - - - -testRedirect :: Test -testRedirect = testCase "types/redirect" $ do - (_,rsp) <- go (redirect "/foo/bar") - - b <- getBody rsp - assertEqual "no response body" "" b - assertEqual "response content length" (Just 0) $ rspContentLength rsp - assertEqual "redirect path" (Just "/foo/bar") $ getHeader "Location" rsp - assertEqual "redirect status" 302 $ rspStatus rsp - assertEqual "status description" "Found" $ rspStatusReason rsp - - - (_,rsp2) <- go (redirect' "/bar/foo" 307) - - assertEqual "redirect path" (Just "/bar/foo") $ getHeader "Location" rsp2 - assertEqual "redirect status" 307 $ rspStatus rsp2 - assertEqual "status description" "Temporary Redirect" $ rspStatusReason rsp2 diff --git a/test/suite/Snap/Util/FileServe/Tests.hs b/test/suite/Snap/Util/FileServe/Tests.hs --- a/test/suite/Snap/Util/FileServe/Tests.hs +++ b/test/suite/Snap/Util/FileServe/Tests.hs @@ -23,6 +23,7 @@ import Snap.Internal.Types import Snap.Util.FileServe import Snap.Iteratee +import qualified Snap.Types.Headers as H tests :: [Test] tests = [ testFooBin @@ -134,7 +135,7 @@ mkRequest :: ByteString -> IO Request mkRequest uri = do enum <- newIORef $ SomeEnumerator returnI - return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty + return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False H.empty enum Nothing GET (1,1) [] "" pathPart "/" (S.concat ["/",uri]) queryPart Map.empty diff --git a/test/suite/Snap/Util/FileUploads/Tests.hs b/test/suite/Snap/Util/FileUploads/Tests.hs --- a/test/suite/Snap/Util/FileUploads/Tests.hs +++ b/test/suite/Snap/Util/FileUploads/Tests.hs @@ -34,6 +34,7 @@ import Snap.Internal.Iteratee.Debug import Snap.Internal.Types import Snap.Iteratee hiding (map) +import qualified Snap.Types.Headers as H import Snap.Test.Common import Snap.Util.FileUploads @@ -44,7 +45,6 @@ instance Exception TestException - ------------------------------------------------------------------------------ tests :: [Test] tests = [ testSuccess1 @@ -211,7 +211,7 @@ ------------------------------------------------------------------------------ testNoBoundary :: Test testNoBoundary = testCase "fileUploads/noBoundary" $ - expectException $ + expectExceptionH $ harness' goBadContentType tmpdir hndl mixedTestBody where tmpdir = "tempdir_noboundary" @@ -227,7 +227,7 @@ ------------------------------------------------------------------------------ testNoMixedBoundary :: Test testNoMixedBoundary = testCase "fileUploads/noMixedBoundary" $ - expectException $ + expectExceptionH $ harness' go tmpdir hndl badMixedBody where tmpdir = "tempdir_mixednoboundary" @@ -243,7 +243,7 @@ ------------------------------------------------------------------------------ testWrongContentType :: Test testWrongContentType = testCase "fileUploads/wrongContentType" $ - expectException $ + expectExceptionH $ harness' goWrongContentType tmpdir hndl mixedTestBody where tmpdir = "tempdir_noboundary" @@ -363,9 +363,9 @@ mkRequest body = do enum <- newIORef $ SomeEnumerator $ enumBS body - let hdrs = Map.fromList [ - ("Content-type", [S.append "multipart/form-data; boundary=" - boundaryValue]) + let hdrs = H.fromList [ + ("Content-type", S.append "multipart/form-data; boundary=" + boundaryValue) ] return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False hdrs @@ -378,9 +378,9 @@ mkDamagedRequest body = do enum <- newIORef $ SomeEnumerator $ enum - let hdrs = Map.fromList [ - ("Content-type", [S.append "multipart/form-data; boundary=" - boundaryValue]) + let hdrs = H.fromList [ + ("Content-type", S.append "multipart/form-data; boundary=" + boundaryValue) ] return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False hdrs @@ -599,12 +599,3 @@ , boundaryValue , "--\r\n" ]) - - ------------------------------------------------------------------------------- -expectException :: IO a -> IO () -expectException m = do - e <- try m - case e of - Left (z::SomeException) -> (show z) `deepseq` return () - Right _ -> assertFailure "expected exception, didn't get one" diff --git a/test/suite/Snap/Util/GZip/Tests.hs b/test/suite/Snap/Util/GZip/Tests.hs --- a/test/suite/Snap/Util/GZip/Tests.hs +++ b/test/suite/Snap/Util/GZip/Tests.hs @@ -26,11 +26,12 @@ import Test.Framework.Providers.HUnit import qualified Test.HUnit as H -import Snap.Types +import Snap.Core import Snap.Internal.Http.Types import Snap.Iteratee import Snap.Test.Common () import Snap.Util.GZip +import qualified Snap.Types.Headers as H stream2stream @@ -70,7 +71,7 @@ ------------------------------------------------------------------------------ gzipHdrs, xGzipHdrs, badHdrs, compressHdrs, xCompressHdrs, emptyHdrs :: Headers -emptyHdrs = Map.empty +emptyHdrs = H.empty gzipHdrs = setHeader "Accept-Encoding" "froz,gzip, x-gzip" emptyHdrs xGzipHdrs = setHeader "Accept-Encoding" "x-gzip;q=1.0" emptyHdrs badHdrs = setHeader "Accept-Encoding" "*&%^&^$%&%&*^\023" emptyHdrs diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs --- a/test/suite/TestSuite.hs +++ b/test/suite/TestSuite.hs @@ -2,13 +2,15 @@ import Test.Framework (defaultMain, testGroup) -import qualified Snap.Types.Tests +import qualified Snap.Core.Tests import qualified Snap.Internal.Http.Types.Tests +import qualified Snap.Internal.Parsing.Tests import qualified Snap.Internal.Routing.Tests import qualified Snap.Iteratee.Tests import qualified Snap.Util.FileServe.Tests import qualified Snap.Util.FileUploads.Tests import qualified Snap.Util.GZip.Tests +import qualified Snap.Test.Tests main :: IO () @@ -18,14 +20,18 @@ Snap.Internal.Http.Types.Tests.tests , testGroup "Snap.Internal.Routing.Tests" Snap.Internal.Routing.Tests.tests - , testGroup "Snap.Types.Tests" - Snap.Types.Tests.tests + , testGroup "Snap.Core.Tests" + Snap.Core.Tests.tests , testGroup "Snap.Iteratee.Tests" Snap.Iteratee.Tests.tests + , testGroup "Snap.Internal.Parsing.Tests" + Snap.Internal.Parsing.Tests.tests , testGroup "Snap.Util.GZip.Tests" Snap.Util.GZip.Tests.tests , testGroup "Snap.Util.FileServe.Tests" Snap.Util.FileServe.Tests.tests , testGroup "Snap.Util.FileUploads.Tests" Snap.Util.FileUploads.Tests.tests + , testGroup "Snap.Test.Tests" + Snap.Test.Tests.tests ]