diff --git a/snap-core.cabal b/snap-core.cabal --- a/snap-core.cabal +++ b/snap-core.cabal @@ -1,6 +1,6 @@ name: snap-core -version: 0.7.0.1 -synopsis: Snap: A Haskell Web Framework (Core) +version: 0.8.0 +synopsis: Snap: A Haskell Web Framework (core interfaces and types) description: Snap is a simple and fast web development framework and server written in @@ -15,8 +15,7 @@ . 2. Type aliases and helper functions for Iteratee I/O . - 3. A monad for programming web handlers called \"Snap\", inspired by - happstack's (), which allows: + 3. A monad for programming web handlers called \"Snap\", which allows: . * Stateful access to the HTTP request and response objects . @@ -28,15 +27,6 @@ . /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 - management, component interfaces, data modeling, etc.) are planned but not - yet implemented, so this release will mostly be of interest for those who: - . - * need a fast and minimal HTTP API at roughly the same level of abstraction - as Java servlets, or - . - * are interested in contributing to the Snap Framework project. license: BSD3 license-file: LICENSE @@ -76,8 +66,8 @@ test/suite/Snap/Test/Common.hs, test/suite/Snap/Util/FileServe/Tests.hs, test/suite/Snap/Util/FileUploads/Tests.hs, - test/suite/Snap/Util/GZip/Tests.hs - + test/suite/Snap/Util/GZip/Tests.hs, + test/suite/Snap/Util/Proxy/Tests.hs Flag portable Description: Compile in cross-platform mode. No platform-specific code or @@ -115,6 +105,7 @@ Snap.Types, Snap.Iteratee, Snap.Internal.Debug, + Snap.Internal.Exceptions, Snap.Internal.Http.Types, Snap.Internal.Iteratee.Debug, Snap.Internal.Parsing, @@ -123,6 +114,7 @@ Snap.Util.FileServe, Snap.Util.FileUploads, Snap.Util.GZip, + Snap.Util.Proxy, Snap.Util.Readable other-modules: @@ -149,12 +141,12 @@ deepseq >= 1.1 && <1.4, directory, dlist >= 0.5 && < 0.6, - enumerator >= 0.4.13.1 && < 0.5, + enumerator >= 0.4.15 && < 0.5, filepath, HUnit >= 1.2 && < 2, MonadCatchIO-transformers >= 0.2.1 && < 0.3, mtl == 2.0.*, - mwc-random >= 0.10 && <0.11, + mwc-random >= 0.10 && <0.13, old-locale, old-time, regex-posix <= 0.95.2, @@ -162,27 +154,27 @@ time >= 1.0 && < 1.5, transformers == 0.2.*, unix-compat >= 0.2 && <0.4, - unordered-containers >= 0.1.4.3 && <0.2, + unordered-containers >= 0.1.4.3 && <0.3, vector >= 0.6 && <0.10, zlib-enum >= 0.2.1 && <0.3 extensions: BangPatterns, CPP, - PackageImports, - ScopedTypeVariables, + DeriveDataTypeable, EmptyDataDecls, - ForeignFunctionInterface, - OverloadedStrings, - Rank2Types, - TypeSynonymInstances, - FlexibleInstances, ExistentialQuantification, - OverloadedStrings, FlexibleContexts, + FlexibleInstances, + ForeignFunctionInterface, GeneralizedNewtypeDeriving, - DeriveDataTypeable, - MultiParamTypeClasses + MultiParamTypeClasses, + OverloadedStrings, + OverloadedStrings, + PackageImports, + Rank2Types, + ScopedTypeVariables, + TypeSynonymInstances ghc-prof-options: -prof -auto-all diff --git a/src/Snap/Core.hs b/src/Snap/Core.hs --- a/src/Snap/Core.hs +++ b/src/Snap/Core.hs @@ -11,7 +11,6 @@ , runSnap , MonadSnap(..) , NoHandlerException(..) - , EscapeHttpException(..) -- ** Functions for control flow and early termination , bracketSnap @@ -19,6 +18,9 @@ , catchFinishWith , pass , terminateConnection + + -- *** Escaping HTTP + , EscapeHttpHandler , escapeHttp -- ** Routing @@ -92,9 +94,17 @@ , rqURI , rqQueryString , rqParams + , rqQueryParams + , rqPostParams , rqParam + , rqPostParam + , rqQueryParam , getParam + , getPostParam + , getQueryParam , getParams + , getPostParams + , getQueryParams , rqModifyParams , rqSetParam @@ -117,6 +127,8 @@ , clearContentLength , redirect , redirect' + , setBufferingMode + , getBufferingMode -- *** Response I/O , setResponseBody @@ -132,7 +144,10 @@ -- ** Timeouts , setTimeout + , extendTimeout + , modifyTimeout , getTimeoutAction + , getTimeoutModifier -- * Iteratee , Enumerator @@ -150,6 +165,7 @@ ) where ------------------------------------------------------------------------------ +import Snap.Internal.Exceptions (EscapeHttpHandler) import Snap.Internal.Http.Types import Snap.Internal.Instances () import Snap.Internal.Parsing diff --git a/src/Snap/Internal/Debug.hs b/src/Snap/Internal/Debug.hs --- a/src/Snap/Internal/Debug.hs +++ b/src/Snap/Internal/Debug.hs @@ -16,20 +16,21 @@ module Snap.Internal.Debug where ------------------------------------------------------------------------------ -import Control.Monad.Trans +import Control.Monad.Trans #ifndef NODEBUG -import Control.Concurrent -import Control.DeepSeq -import Control.Exception -import Data.Char -import Data.List -import Data.Maybe -import Foreign.C.Error -import System.Environment -import System.IO -import System.IO.Unsafe -import Text.Printf +import Control.Concurrent +import Control.DeepSeq +import Data.Either +import Control.Exception +import Data.Char +import Data.List +import Data.Maybe +import Foreign.C.Error +import System.Environment +import System.IO +import System.IO.Unsafe +import Text.Printf #endif ------------------------------------------------------------------------------ @@ -43,12 +44,13 @@ !e <- try $ getEnv "DEBUG" !f <- either (\(_::SomeException) -> return debugIgnore) - (\y -> if y == "1" || y == "on" - then return debugOn - else if y == "testsuite" - then return debugSeq - else return debugIgnore) - (fmap (map toLower) e) + (\y0 -> let y = map toLower y0 + in if y == "1" || y == "on" + then return debugOn + else if y == "testsuite" + then return debugSeq + else return debugIgnore) + e return $! f in x @@ -58,12 +60,13 @@ e <- try $ getEnv "DEBUG" !f <- either (\(_::SomeException) -> return debugErrnoIgnore) - (\y -> if y == "1" || y == "on" - then return debugErrnoOn - else if y == "testsuite" - then return debugErrnoSeq - else return debugErrnoIgnore) - (fmap (map toLower) e) + (\y0 -> let y = map toLower y0 + in if y == "1" || y == "on" + then return debugErrnoOn + else if y == "testsuite" + then return debugErrnoSeq + else return debugErrnoIgnore) + e return $! f in x diff --git a/src/Snap/Internal/Exceptions.hs b/src/Snap/Internal/Exceptions.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Internal/Exceptions.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} + +-- | An internal Snap module containing the exception that escapes HTTP types. +-- +-- /N.B./ this is an internal interface, please don't write user code that +-- depends on it. Interfaces subject to change etc etc etc. +-- +module Snap.Internal.Exceptions where + +------------------------------------------------------------------------------ +import Control.Exception +import Data.ByteString.Char8 (ByteString) +import Data.Typeable +import Snap.Iteratee + +------------------------------------------------------------------------------ +-- | An exception hierarchy for exceptions that cannot be caught by +-- user-defined error handlers +data UncatchableException = forall e. Exception e => UncatchableException e + deriving (Typeable) + + +------------------------------------------------------------------------------ +instance Show UncatchableException where + show (UncatchableException e) = "Uncatchable exception: " ++ show e + + +------------------------------------------------------------------------------ +instance Exception UncatchableException + + +------------------------------------------------------------------------------ +uncatchableExceptionToException :: Exception e => e -> SomeException +uncatchableExceptionToException = toException . UncatchableException + + +------------------------------------------------------------------------------ +uncatchableExceptionFromException :: Exception e => SomeException -> Maybe e +uncatchableExceptionFromException e = do + UncatchableException ue <- fromException e + cast ue + + +------------------------------------------------------------------------------ +data ConnectionTerminatedException = + ConnectionTerminatedException SomeException + deriving (Typeable) + + +------------------------------------------------------------------------------ +instance Show ConnectionTerminatedException where + show (ConnectionTerminatedException e) = + "Connection terminated with exception: " ++ show e + + +------------------------------------------------------------------------------ +instance Exception ConnectionTerminatedException where + toException = uncatchableExceptionToException + fromException = uncatchableExceptionFromException + + +------------------------------------------------------------------------------ +-- | This exception is thrown if the handler chooses to escape regular HTTP +-- traffic. +data EscapeHttpException = EscapeHttpException EscapeHttpHandler + deriving (Typeable) + + +------------------------------------------------------------------------------ +type EscapeHttpHandler = ((Int -> Int) -> IO ()) -- ^ timeout modifier + -> Iteratee ByteString IO () -- ^ socket write end + -> Iteratee ByteString IO () + + +------------------------------------------------------------------------------ +instance Show EscapeHttpException where + show = const "HTTP traffic was escaped" + + +------------------------------------------------------------------------------ +instance Exception EscapeHttpException where + toException = uncatchableExceptionToException + fromException = uncatchableExceptionFromException + + 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 @@ -1,22 +1,22 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeSynonymInstances #-} + +------------------------------------------------------------------------------ -- | An internal Snap module containing HTTP types. -- -- /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.Core". - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ExistentialQuantification #-} - +-- module Snap.Internal.Http.Types where - ------------------------------------------------------------------------------ import Blaze.ByteString.Builder import Control.Monad (liftM) @@ -24,6 +24,8 @@ import qualified Data.ByteString.Char8 as B import Data.ByteString.Internal (c2w,w2c) import qualified Data.ByteString as S +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI import Data.Int import qualified Data.IntMap as IM import Data.IORef @@ -36,7 +38,7 @@ import Foreign.C.Types import Prelude hiding (take) - +------------------------------------------------------------------------------ #ifdef PORTABLE import Data.Time.Format import Data.Time.LocalTime @@ -50,18 +52,16 @@ #endif ------------------------------------------------------------------------------ -import Data.CaseInsensitive (CI) -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 ------------------------------------------------------------------------------ -- foreign imports from cbits - foreign import ccall unsafe "set_c_locale" set_c_locale :: IO () @@ -80,7 +80,6 @@ ------------------------------------------------------------------------------ -- | A typeclass for datatypes which contain HTTP headers. class HasHeaders a where - -- | Modify the datatype's headers. updateHeaders :: (Headers -> Headers) -> a -> a @@ -113,7 +112,7 @@ -- | 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 " ") (H.lookup k $ headers a) +getHeader k a = liftM (S.intercalate ",") (H.lookup k $ headers a) ------------------------------------------------------------------------------ @@ -187,30 +186,30 @@ data Request = Request { -- | The server name of the request, as it came in from the request's -- @Host:@ header. - rqServerName :: !ByteString + rqServerName :: ByteString -- | Returns the port number the HTTP server is listening on. , rqServerPort :: !Int -- | The remote IP address. - , rqRemoteAddr :: !ByteString + , rqRemoteAddr :: ByteString -- | The remote TCP port number. - , rqRemotePort :: !Int + , rqRemotePort :: Int -- | The local IP address for this request. - , rqLocalAddr :: !ByteString + , rqLocalAddr :: ByteString -- | Returns the port number the HTTP server is listening on. - , rqLocalPort :: !Int + , rqLocalPort :: Int -- | Returns the HTTP server's idea of its local hostname. - , rqLocalHostname :: !ByteString + , rqLocalHostname :: ByteString -- | Returns @True@ if this is an @HTTPS@ session. - , rqIsSecure :: !Bool + , rqIsSecure :: Bool , rqHeaders :: Headers - , rqBody :: IORef SomeEnumerator + , rqBody :: !(IORef SomeEnumerator) -- | Returns the @Content-Length@ of the HTTP request body. , rqContentLength :: !(Maybe Int) @@ -219,38 +218,26 @@ , rqMethod :: !Method -- | Returns the HTTP version used by the client. - , rqVersion :: !HttpVersion + , rqVersion :: HttpVersion -- | Returns a list of the cookies that came in from the HTTP request -- headers. , rqCookies :: [Cookie] - - -- | We'll be doing web components (or \"snaplets\") for version 0.2. - -- The \"snaplet path\" refers to the place on the URL where your - -- containing snaplet is hung. The value of 'rqSnapletPath' is either - -- @\"\"@ (at the top-level context) or is a path beginning with a - -- slash, but not ending with one. + -- | Handlers can be hung on a @URI@ \"entry point\"; this is called the + -- \"context path\". If a handler is hung on the context path + -- @\"\/foo\/\"@, and you request @\"\/foo\/bar\"@, the value of + -- 'rqPathInfo' will be @\"bar\"@. -- - -- An identity is that: + -- The following identity holds: -- - -- > rqURI r == S.concat [ rqSnapletPath r - -- > , rqContextPath r + -- > rqURI r == S.concat [ rqContextPath r -- > , rqPathInfo r -- > , let q = rqQueryString r -- > in if S.null q -- > then "" -- > else S.append "?" q -- > ] - -- - -- note that until we introduce snaplets in v0.2, 'rqSnapletPath' will - -- be \"\" - , rqSnapletPath :: !ByteString - - -- | Handlers can (/will be; --ed/) be hung on a @URI@ \"entry point\"; - -- this is called the \"context path\". If a handler is hung on the - -- context path @\"\/foo\/\"@, and you request @\"\/foo\/bar\"@, the - -- value of 'rqPathInfo' will be @\"bar\"@. , rqPathInfo :: !ByteString -- | The \"context path\" of the request; catenating 'rqContextPath', @@ -266,10 +253,19 @@ -- | Returns the HTTP query string for this 'Request'. , rqQueryString :: !ByteString - -- | Returns the 'Params' mapping for this 'Request'. \"Parameters\" are - -- automatically decoded from the query string and @POST@ body and - -- entered into this mapping. + -- | Returns the parameters mapping for this 'Request'. \"Parameters\" + -- are automatically decoded from the URI's query string and @POST@ body + -- and entered into this mapping. The 'rqParams' value is thus a union of + -- 'rqQueryParams' and 'rqPostParams'. , rqParams :: Params + + -- | The parameter mapping decoded from the URI's query string. + , rqQueryParams :: Params + + -- | The parameter mapping decoded from the POST body. Note that Snap + -- only auto-decodes POST request bodies when the request's + -- @Content-Type@ is @application/x-www-form-urlencoded@. + , rqPostParams :: Params } @@ -292,7 +288,6 @@ , cookies , pathinfo , contextpath - , snapletpath , uri , params ] @@ -333,7 +328,6 @@ ] pathinfo = concat [ "pathinfo: ", toStr $ rqPathInfo r ] contextpath = concat [ "contextpath: ", toStr $ rqContextPath r ] - snapletpath = concat [ "snapletpath: ", toStr $ rqSnapletPath r ] uri = concat [ "URI: ", toStr $ rqURI r ] params' = " " ++ (concat $ intersperse "\n " $ @@ -410,6 +404,12 @@ -- | If true, we are transforming the request body with -- 'transformRequestBody' , rspTransformingRqBody :: !Bool + + -- | Controls whether Snap will buffer the output or not. You may wish to + -- disable buffering when using Comet-like techniques which rely on the + -- immediate sending of output data in order to maintain interactive + -- semantics. + , rspOutputBuffering :: !Bool } @@ -456,6 +456,26 @@ ------------------------------------------------------------------------------ +-- | Looks up the value(s) for the given named parameter in the POST parameters +-- mapping. +rqPostParam :: ByteString -- ^ parameter name to look up + -> Request -- ^ HTTP request + -> Maybe [ByteString] +rqPostParam k rq = Map.lookup k $ rqPostParams rq +{-# INLINE rqPostParam #-} + + +------------------------------------------------------------------------------ +-- | Looks up the value(s) for the given named parameter in the query +-- parameters mapping. +rqQueryParam :: ByteString -- ^ parameter name to look up + -> Request -- ^ HTTP request + -> Maybe [ByteString] +rqQueryParam k rq = Map.lookup k $ rqQueryParams rq +{-# INLINE rqQueryParam #-} + + +------------------------------------------------------------------------------ -- | Modifies the parameters mapping (which is a @Map ByteString ByteString@) -- in a 'Request' using the given function. rqModifyParams :: (Params -> Params) -> Request -> Request @@ -475,15 +495,17 @@ rqSetParam k v = rqModifyParams $ Map.insert k v {-# INLINE rqSetParam #-} ------------------------------------------------------------------------------- --- responses ------------------------------------------------------------------------------- + --------------- + -- responses -- + --------------- + +------------------------------------------------------------------------------ -- | An empty 'Response'. emptyResponse :: Response emptyResponse = Response H.empty Map.empty (1,1) Nothing (Enum (I.enumBuilder mempty)) - 200 "OK" False + 200 "OK" False True ------------------------------------------------------------------------------ @@ -614,19 +636,49 @@ ------------------------------------------------------------------------------ --- HTTP dates +-- | The buffering mode controls whether Snap will buffer the output or not. +-- You may wish to disable buffering when using Comet-like techniques which +-- rely on the immediate sending of output data in order to maintain +-- interactive semantics. +getBufferingMode :: Response -> Bool +getBufferingMode = rspOutputBuffering +{-# INLINE getBufferingMode #-} + +------------------------------------------------------------------------------ +-- | The buffering mode controls whether Snap will buffer the output or not. +-- You may wish to disable buffering when using Comet-like techniques which +-- rely on the immediate sending of output data in order to maintain +-- interactive semantics. +setBufferingMode :: Bool -- ^ if True, buffer the output, if False, send + -- output immediately + -> Response + -> Response +setBufferingMode b r = r { rspOutputBuffering = b } +{-# INLINE setBufferingMode #-} + + + ---------------- + -- HTTP dates -- + ---------------- + +------------------------------------------------------------------------------ -- | Converts a 'CTime' into an HTTP timestamp. formatHttpTime :: CTime -> IO ByteString + +------------------------------------------------------------------------------ -- | Converts a 'CTime' into common log entry format. formatLogTime :: CTime -> IO ByteString + +------------------------------------------------------------------------------ -- | Converts an HTTP timestamp into a 'CTime'. parseHttpTime :: ByteString -> IO CTime #ifdef PORTABLE +------------------------------------------------------------------------------ formatHttpTime = return . format . toUTCTime where format :: UTCTime -> ByteString @@ -635,9 +687,11 @@ toUTCTime :: CTime -> UTCTime toUTCTime = posixSecondsToUTCTime . realToFrac + +------------------------------------------------------------------------------ formatLogTime ctime = do t <- utcToLocalZonedTime $ toUTCTime ctime - return $ format t + return $! format t where format :: ZonedTime -> ByteString @@ -647,6 +701,7 @@ toUTCTime = posixSecondsToUTCTime . realToFrac +------------------------------------------------------------------------------ parseHttpTime = return . toCTime . prs . toStr where prs :: String -> Maybe UTCTime @@ -658,16 +713,21 @@ #else +------------------------------------------------------------------------------ formatLogTime t = do ptr <- mallocBytes 40 c_format_log_time t ptr S.unsafePackMallocCString ptr + +------------------------------------------------------------------------------ formatHttpTime t = do ptr <- mallocBytes 40 c_format_http_time t ptr S.unsafePackMallocCString ptr + +------------------------------------------------------------------------------ parseHttpTime s = S.unsafeUseAsCString s $ \ptr -> c_parse_http_time ptr 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 @@ -44,7 +44,7 @@ -- debug $ "lookahead " ++ show n -- ++ " failing, returning " ++ show ls - return $ Left ls) + return $! Left ls) (\x -> do let !l = S.length x let !r = k - l @@ -56,7 +56,7 @@ -- debug $ "lookahead " ++ show n -- ++ " successfully returning " -- ++ show ls - return $ Right $ ls + return $! Right ls else go d' r) {-# INLINE lookahead #-} @@ -129,7 +129,7 @@ step <- if not $ S.null nomatch then lift $ runIteratee $ k $ Chunks [NoMatch nomatch] - else return $ Continue k + else return $! Continue k cDone step $ \k' -> do step' <- lift $ runIteratee $ k' $ Chunks [Match needle] @@ -171,7 +171,7 @@ step <- if not $ S.null nomatch then lift $ runIteratee $ k $ Chunks [NoMatch nomatch] - else return $ Continue k + else return $! Continue k -- debug $ "matching" cDone step $ \k' -> do 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 @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} module Snap.Internal.Parsing where @@ -7,14 +9,13 @@ import Control.Applicative import Control.Arrow (first, second) import Control.Monad -import Data.Attoparsec.Types (IResult(..)) import Data.Attoparsec.Char8 +import Data.Attoparsec.Types (IResult(..)) 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) @@ -28,8 +29,9 @@ import Data.Maybe import Data.Monoid import Data.Word +import GHC.Exts +import GHC.Word (Word8(..)) import Prelude hiding (head, take, takeWhile) - ------------------------------------------------------------------------------ import Snap.Internal.Http.Types import Snap.Internal.Parsing.FastSet (FastSet) @@ -37,6 +39,7 @@ ------------------------------------------------------------------------------ +{-# INLINE fullyParse #-} fullyParse :: ByteString -> Parser a -> Either String a fullyParse s p = case r' of @@ -50,7 +53,7 @@ ------------------------------------------------------------------------------ parseNum :: Parser Int64 -parseNum = liftM int $ takeWhile1 isDigit +parseNum = decimal ------------------------------------------------------------------------------ @@ -109,31 +112,35 @@ pHeaders :: Parser [(ByteString, ByteString)] pHeaders = many header where - header = {-# SCC "pHeaders/header" #-} - liftA2 (,) - fieldName - (char ':' *> spaces *> contents) - - fieldName = {-# SCC "pHeaders/fieldName" #-} - liftA2 S.cons letter fieldChars + -------------------------------------------------------------------------- + header = {-# SCC "pHeaders/header" #-} + liftA2 (,) + fieldName + (char ':' *> spaces *> contents) - contents = {-# SCC "pHeaders/contents" #-} - liftA2 S.append - (untilEOL <* crlf) - (continuation <|> pure S.empty) + -------------------------------------------------------------------------- + fieldName = {-# SCC "pHeaders/fieldName" #-} + liftA2 S.cons letter fieldChars - isLeadingWS w = {-# SCC "pHeaders/isLeadingWS" #-} - elem w wstab + -------------------------------------------------------------------------- + contents = {-# SCC "pHeaders/contents" #-} + liftA2 S.append + (untilEOL <* crlf) + (continuation <|> pure S.empty) - wstab = " \t" + -------------------------------------------------------------------------- + isLeadingWS w = {-# SCC "pHeaders/isLeadingWS" #-} + w == ' ' || w == '\t' + -------------------------------------------------------------------------- leadingWhiteSpace = {-# SCC "pHeaders/leadingWhiteSpace" #-} takeWhile1 isLeadingWS - continuation = {-# SCC "pHeaders/continuation" #-} - liftA2 S.cons - (leadingWhiteSpace *> pure ' ') - contents + -------------------------------------------------------------------------- + continuation = {-# SCC "pHeaders/continuation" #-} + liftA2 S.cons + (leadingWhiteSpace *> pure ' ') + contents ------------------------------------------------------------------------------ @@ -151,16 +158,12 @@ f soFar = do t <- takeWhile qdtext - let soFar' = t:soFar - -- RFC says that backslash only escapes for <"> choice [ string "\\\"" *> f ("\"" : soFar') , pure soFar' ] - - q = char '\"' - + q = char '\"' qdtext = matchAll [ isRFCText, (/= '\"'), (/= '\\') ] @@ -181,17 +184,16 @@ pAvPairs = do a <- pAvPair b <- many (pSpaces *> char ';' *> pSpaces *> pAvPair) - - return $ a:b + return $! a:b ------------------------------------------------------------------------------ +{-# INLINE pAvPair #-} pAvPair :: Parser (ByteString, ByteString) pAvPair = do key <- pToken <* pSpaces val <- liftM trim (option "" $ char '=' *> pSpaces *> pWord) - - return (key, val) + return $! (key, val) ------------------------------------------------------------------------------ @@ -199,10 +201,11 @@ pParameter = do key <- pToken <* pSpaces val <- liftM trim (char '=' *> pSpaces *> pWord) - return (trim key, val) + return $! (trim key, val) ------------------------------------------------------------------------------ +{-# INLINE trim #-} trim :: ByteString -> ByteString trim = snd . S.span isSpace . fst . S.spanEnd isSpace @@ -213,20 +216,25 @@ value <- liftM trim (pSpaces *> takeWhile (/= ';')) params <- many pParam return (value, map (first CI.mk) params) + where pParam = pSpaces *> char ';' *> pSpaces *> pParameter + ------------------------------------------------------------------------------ -pContentTypeWithParameters :: - Parser (ByteString, [(CI ByteString, ByteString)]) +pContentTypeWithParameters :: Parser ( ByteString + , [(CI ByteString, ByteString)] ) pContentTypeWithParameters = do value <- liftM trim (pSpaces *> takeWhile (not . isSep)) params <- many (pSpaces *> satisfy isSep *> pSpaces *> pParameter) - return (value, map (first CI.mk) params) + return $! (value, map (first CI.mk) params) + where isSep c = c == ';' || c == ',' + ------------------------------------------------------------------------------ +{-# INLINE pToken #-} pToken :: Parser ByteString pToken = takeWhile isToken @@ -236,6 +244,8 @@ isToken :: Char -> Bool isToken c = FS.memberChar c tokenTable + +------------------------------------------------------------------------------ tokenTable :: FastSet tokenTable = generateFS (f . toEnum . fromEnum) where @@ -248,10 +258,12 @@ ] ------------------------------------------------------------------------------- --- URL ENCODING ------------------------------------------------------------------------------- + ------------------ + -- Url encoding -- + ------------------ +------------------------------------------------------------------------------ +{-# INLINE parseToCompletion #-} parseToCompletion :: Parser a -> ByteString -> Maybe a parseToCompletion p s = toResult $ finish r where @@ -265,19 +277,21 @@ pUrlEscaped :: Parser ByteString pUrlEscaped = do sq <- nextChunk DL.empty - return $ S.concat $ DL.toList sq + return $! S.concat $ DL.toList sq where + -------------------------------------------------------------------------- nextChunk :: DList ByteString -> Parser (DList ByteString) - nextChunk s = (endOfInput *> pure s) <|> do + 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 + percentEncoded !l = do hx <- take 2 when (S.length hx /= 2 || (not $ S.all isHexDigit hx)) $ fail "bad hex in url" @@ -285,117 +299,134 @@ 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 + unEncoded !c !l' = do let l = DL.snoc l' (S.singleton c) - bs <- takeTill (flip elem "%+") + 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 ' ')) ------------------------------------------------------------------------------ +-- "...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." + + +------------------------------------------------------------------------------ -- | Decodes an URL-escaped string (see -- ) urlDecode :: ByteString -> Maybe ByteString urlDecode = parseToCompletion pUrlEscaped +{-# INLINE urlDecode #-} ------------------------------------------------------------------------------ --- "...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 +{-# INLINE urlEncode #-} ------------------------------------------------------------------------------ -- | URL-escapes a string (see -- ) into a 'Builder'. urlEncodeBuilder :: ByteString -> Builder -urlEncodeBuilder = S.foldl' f mempty +urlEncodeBuilder = go 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 + go !b !s = maybe b' esc (S.uncons y) + where + (x,y) = S.span (flip FS.memberChar urlEncodeTable) s + b' = b `mappend` fromByteString x + esc (c,r) = let b'' = if c == ' ' + then b' `mappend` fromWord8 (c2w '+') + else b' `mappend` hexd c + in go b'' r ------------------------------------------------------------------------------ urlEncodeTable :: FastSet urlEncodeTable = generateFS f where - f w = any ($ c) [ isAlphaNum - , flip elem ['$', '-', '.', '!', '*' - , '\'', '(', ')', ',' ]] - where - c = w2c w + f c = any ($ (w2c c)) [isAlphaNum, flip elem "$-.!*'(),"] ------------------------------------------------------------------------------ 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 + !c = c2w c0 + toDigit = c2w . intToDigit + !low = toDigit $ fromEnum $ c .&. 0xf + !hi = toDigit $ (c .&. 0xf0) `shiftr` 4 + shiftr (W8# a#) (I# b#) = I# (word2Int# (uncheckedShiftRL# a# b#)) + ------------------------------------------------------------------------------ finish :: Result a -> Result a finish (Partial f) = flip feed "" $ f "" finish x = x - ------------------------------------------------------------------------------- --- application/x-www-form-urlencoded ------------------------------------------------------------------------------- + --------------------------------------- + -- 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 +parseUrlEncoded s = foldr ins Map.empty decoded + where - breakApart = (second (S.drop 1)) . S.break (== '=') + -------------------------------------------------------------------------- + ins (!k,v) !m = Map.insertWith' (++) k [v] m + -------------------------------------------------------------------------- parts :: [(ByteString,ByteString)] parts = map breakApart $ S.splitWith (\c -> c == '&' || c == ';') s + -------------------------------------------------------------------------- + breakApart = (second (S.drop 1)) . S.break (== '=') + + -------------------------------------------------------------------------- urldecode = parseToCompletion pUrlEscaped + -------------------------------------------------------------------------- decodeOne (a,b) = do - a' <- urldecode a - b' <- urldecode b - return (a',b') + !a' <- urldecode a + !b' <- urldecode b + return $! (a',b') - decoded = catMaybes $ map decodeOne parts + -------------------------------------------------------------------------- + decoded = go id parts + where + go !dl [] = dl [] + go !dl (x:xs) = maybe (go dl xs) + (\p -> go (dl . (p:)) xs) + (decodeOne x) ------------------------------------------------------------------------------ buildUrlEncoded :: Map ByteString [ByteString] -> Builder buildUrlEncoded m = mconcat builders where - builders = intersperse (fromWord8 $ c2w '&') $ - concatMap encodeVS $ Map.toList m + 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 ] + encodeOne k v = mconcat [ urlEncodeBuilder k + , fromWord8 $ c2w '=' + , urlEncodeBuilder v ] ------------------------------------------------------------------------------ @@ -403,20 +434,19 @@ printUrlEncoded = toByteString . buildUrlEncoded ------------------------------------------------------------------------------- --- COOKIE PARSING ------------------------------------------------------------------------------- + -------------------- + -- 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 + return $! map toCookie $ filter (not . S.isPrefixOf "$" . fst) kvps where toCookie (nm,val) = Cookie nm val Nothing Nothing Nothing False False @@ -427,11 +457,10 @@ parseCookie = parseToCompletion pCookies ------------------------------------------------------------------------------- --- utility functions ------------------------------------------------------------------------------- - + ----------------------- + -- utility functions -- + ----------------------- ------------------------------------------------------------------------------ strictize :: L.ByteString -> ByteString -strictize = S.concat . L.toChunks +strictize = S.concat . L.toChunks diff --git a/src/Snap/Internal/Parsing/FastSet.hs b/src/Snap/Internal/Parsing/FastSet.hs --- a/src/Snap/Internal/Parsing/FastSet.hs +++ b/src/Snap/Internal/Parsing/FastSet.hs @@ -5,7 +5,7 @@ -- Module : Snap.Internal.Parsing.FastSet -- Copyright : Bryan O'Sullivan 2008 -- License : BSD3 --- +-- -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : unknown @@ -17,7 +17,7 @@ -- -- Note: this module copied here from the attoparsec source because it was made -- private in version 0.10. --- +-- ----------------------------------------------------------------------------- module Snap.Internal.Parsing.FastSet ( 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 @@ -236,15 +236,15 @@ route' pre !ctx [] !params (Capture _ _ fb) = route' pre ctx [] params fb -route' pre !ctx (cwd:rest) !params (Capture p rt fb) = - m <|> (route' pre ctx (cwd:rest) params fb) +route' pre !ctx paths@(cwd:rest) !params (Capture p rt fb) + | B.null cwd = fallback + | otherwise = m <|> fallback where - m = do - maybe pass + fallback = route' pre ctx paths params fb + m = maybe pass (\cwd' -> let params' = Map.insertWith (++) p [cwd'] params in route' pre (cwd:ctx) rest params' rt) (urlDecode cwd) - route' pre !ctx [] !params (Dir _ fb) = route' pre ctx [] params fb diff --git a/src/Snap/Internal/Test/RequestBuilder.hs b/src/Snap/Internal/Test/RequestBuilder.hs --- a/src/Snap/Internal/Test/RequestBuilder.hs +++ b/src/Snap/Internal/Test/RequestBuilder.hs @@ -4,43 +4,45 @@ module Snap.Internal.Test.RequestBuilder ( RequestBuilder - , buildRequest , MultipartParams , MultipartParam(..) , FileData (..) , RequestType (..) - , setQueryStringRaw - , setQueryString - , setRequestType , addHeader - , setHeader - , setContentType - , setSecure - , setHttpVersion - , setRequestPath + , buildRequest + , delete + , dumpResponse + , evalHandler + , evalHandlerM , get - , postUrlEncoded , postMultipart - , put , postRaw - , delete - , runHandler - , runHandler' - , dumpResponse + , postUrlEncoded + , put , responseToString + , runHandler + , runHandlerM + , setContentType + , setHeader + , setHttpVersion + , setQueryString + , setQueryStringRaw + , setRequestPath + , setRequestType + , setSecure ) 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 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 qualified Data.Map as Map import Data.Monoid import Data.Word import System.PosixCompat.Time @@ -49,17 +51,21 @@ import Snap.Internal.Http.Types hiding (addHeader, setContentType, setHeader) -import qualified Snap.Internal.Http.Types as H +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 +import Snap.Internal.Types (evalSnap) +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) + deriving (Monad, MonadIO, MonadState Request, MonadTrans) ------------------------------------------------------------------------------ @@ -81,15 +87,20 @@ (1,1) [] "" - "" "/" "/" "" Map.empty + Map.empty + Map.empty ------------------------------------------------------------------------------ -- | Runs a 'RequestBuilder', producing the desired 'Request'. +-- +-- N.B. /please/ don't use the request you get here in a real Snap application; +-- things will probably break. Don't say you weren't warned :-) +-- buildRequest :: MonadIO m => RequestBuilder m () -> m Request buildRequest mm = do let (RequestBuilder m) = (mm >> fixup) @@ -123,19 +134,21 @@ fixupParams = do rq <- rGet - let q = rqQueryString rq - let pms = parseUrlEncoded q + let query = rqQueryString rq + let queryParams = parseUrlEncoded query + let mbCT = getHeader "Content-Type" rq - 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 + postParams <- 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 } + rPut $ rq { rqParams = Map.unionWith (++) queryParams postParams + , rqQueryParams = queryParams } + ------------------------------------------------------------------------------ -- | 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 @@ -262,12 +275,15 @@ , 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 = @@ -285,6 +301,7 @@ ] where + -------------------------------------------------------------------------- contentDisposition fn = mconcat [ fromByteString "Content-Disposition: attachment" , fromByteString "; filename=\"" @@ -292,12 +309,14 @@ , fromByteString "\"\r\n" ] + -------------------------------------------------------------------------- contentType ct = mconcat [ fromByteString "Content-Type: " , fromByteString ct , cr ] + -------------------------------------------------------------------------- oneVal b (FileData fileName ct contents) = mconcat [ fromByteString b , cr @@ -309,8 +328,9 @@ , fromByteString "\r\n--" ] + -------------------------------------------------------------------------- hdr = multipartHeader boundary name - cr = fromByteString "\r\n" + cr = fromByteString "\r\n" ------------------------------------------------------------------------------ @@ -347,8 +367,7 @@ fixupURI :: Monad m => RequestBuilder m () fixupURI = do rq <- rGet - let u = S.concat [ rqSnapletPath rq - , rqContextPath rq + let u = S.concat [ rqContextPath rq , rqPathInfo rq , let q = rqQueryString rq in if S.null q @@ -414,13 +433,15 @@ -- 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 = "" +setRequestPath p0 = do + rModify $ \rq -> rq { rqContextPath = "/" , rqPathInfo = p } fixupURI + where + p = if S.isPrefixOf "/" p0 then S.drop 1 p0 else p0 + ------------------------------------------------------------------------------ -- | Builds an HTTP \"GET\" request with the given query parameters. get :: MonadIO m => @@ -497,9 +518,29 @@ ------------------------------------------------------------------------------ --- | 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) => +-- | 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 = runHandlerM rs + where + rs rq s = do + (_,rsp) <- liftIO $ run_ $ runSnap s + (const $ return $! ()) + (const $ return $! ()) + rq + return rsp + + +------------------------------------------------------------------------------ +-- | Given a web handler in some arbitrary 'MonadSnap' monad, a function +-- specifying how to evaluate it within the context of the test monad, and a +-- 'RequestBuilder' defining a test request, runs the handler, producing an +-- HTTP 'Response'. +runHandlerM :: (MonadIO m, MonadSnap n) => (forall a . Request -> n a -> m Response) -- ^ a function defining how the 'MonadSnap' monad should be run -> RequestBuilder m () @@ -507,7 +548,7 @@ -> n b -- ^ a web handler -> m Response -runHandler' rSnap rBuilder snap = do +runHandlerM rSnap rBuilder snap = do rq <- buildRequest rBuilder rsp <- rSnap rq snap t1 <- liftIO (epochTime >>= formatHttpTime) @@ -515,23 +556,46 @@ ------------------------------------------------------------------------------ --- | 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 +-- | Given a web handler in the 'Snap' monad, and a 'RequestBuilder' defining a +-- test request, runs the handler and returns the monadic value it produces. +-- +-- Throws an exception if the 'Snap' handler early-terminates with 'finishWith' +-- or 'mzero'. +-- +evalHandler :: MonadIO m => + RequestBuilder m () + -> Snap a + -> m a +evalHandler = evalHandlerM rs where - rs rq s = do - (_,rsp) <- liftIO $ run_ $ runSnap s - (const $ return $! ()) - (const $ return $! ()) - rq - return rsp + rs rq s = liftIO $ run_ + $ evalSnap s (const $ return $! ()) + (const $ return $! ()) + rq ------------------------------------------------------------------------------ +-- | Given a web handler in some arbitrary 'MonadSnap' monad, a function +-- specifying how to evaluate it within the context of the test monad, and a +-- 'RequestBuilder' defining a test request, runs the handler, returning the +-- monadic value it produces. +-- +-- Throws an exception if the 'Snap' handler early-terminates with 'finishWith' +-- or 'mzero'. +-- +evalHandlerM :: (MonadIO m, MonadSnap n) => + (forall a . Request -> n a -> m a) -- ^ a function defining + -- how the 'MonadSnap' + -- monad should be run + -> RequestBuilder m () -- ^ a request builder + -> n b -- ^ a web handler + -> m b +evalHandlerM rSnap rBuilder snap = do + rq <- buildRequest rBuilder + rSnap rq snap + + +------------------------------------------------------------------------------ -- | Dumps the given response to stdout. dumpResponse :: Response -> IO () dumpResponse resp = responseToString resp >>= S.putStrLn @@ -545,7 +609,6 @@ liftM mconcat consume) return $ toByteString $ fromShow resp `mappend` b - ------------------------------------------------------------------------------ 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 @@ -1,11 +1,9 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -34,19 +32,18 @@ import qualified Data.Text.Lazy as LT import Data.Typeable import Prelude hiding (catch, take) - - ------------------------------------------------------------------- +------------------------------------------------------------------------------ import Snap.Internal.Http.Types +import Snap.Internal.Exceptions import Snap.Internal.Iteratee.Debug import Snap.Util.Readable -import Snap.Iteratee - - ------------------------------------------------------------------------------- --- The Snap Monad +import Snap.Iteratee hiding (map) ------------------------------------------------------------------------------ + + -------------------- + -- The Snap Monad -- + -------------------- {-| 'Snap' is the 'Monad' that user web handlers run in. 'Snap' gives you: @@ -95,8 +92,8 @@ > a :: Snap () > a = liftIO fireTheMissiles -7. the ability to set a timeout which will kill the handler thread after @N@ - seconds of inactivity (the default is 20 seconds): +7. the ability to set or extend a timeout which will kill the handler thread + after @N@ seconds of inactivity (the default is 20 seconds): > a :: Snap () > a = setTimeout 30 @@ -144,10 +141,11 @@ ------------------------------------------------------------------------------ data SnapState = SnapState - { _snapRequest :: Request - , _snapResponse :: Response - , _snapLogError :: ByteString -> IO () - , _snapSetTimeout :: Int -> IO () } + { _snapRequest :: Request + , _snapResponse :: Response + , _snapLogError :: ByteString -> IO () + , _snapModifyTimeout :: (Int -> Int) -> IO () + } ------------------------------------------------------------------------------ @@ -181,12 +179,12 @@ ------------------------------------------------------------------------------ instance MonadIO Snap where - liftIO m = Snap $ liftM SnapValue $ liftIO m + liftIO m = Snap $! liftM SnapValue $! liftIO m ------------------------------------------------------------------------------ instance MonadCatchIO Snap where - catch (Snap m) handler = Snap $ m `catch` h + catch (Snap m) handler = Snap $! m `catch` h where h e = do rethrowIfUncatchable $ fromException e @@ -208,10 +206,10 @@ ------------------------------------------------------------------------------ instance MonadPlus Snap where - mzero = Snap $ return $ PassOnProcessing "" + mzero = Snap $! return $! PassOnProcessing "" a `mplus` b = - Snap $ do + Snap $! do r <- unSnap a -- redundant just in case ordering by frequency helps here. case r of @@ -281,7 +279,7 @@ -- immediately close the socket. runRequestBody :: MonadSnap m => Iteratee ByteString IO a -> m a runRequestBody iter = do - bumpTimeout <- liftM ($ 5) getTimeoutAction + bumpTimeout <- liftM ($ max 5) getTimeoutModifier req <- getRequest senum <- liftIO $ readIORef $ rqBody req let (SomeEnumerator enum) = senum @@ -841,84 +839,19 @@ ------------------------------------------------------------------------------ --- | An exception hierarchy for exceptions that cannot be caught by --- user-defined error handlers -data UncatchableException = forall e. Exception e => UncatchableException e - deriving (Typeable) - - ------------------------------------------------------------------------------- -instance Show UncatchableException where - show (UncatchableException e) = "Uncatchable exception: " ++ show e - - ------------------------------------------------------------------------------- -instance Exception UncatchableException - - ------------------------------------------------------------------------------- -uncatchableExceptionToException :: Exception e => e -> SomeException -uncatchableExceptionToException = toException . UncatchableException - - ------------------------------------------------------------------------------- -uncatchableExceptionFromException :: Exception e => SomeException -> Maybe e -uncatchableExceptionFromException e = do - UncatchableException ue <- fromException e - cast ue - - ------------------------------------------------------------------------------- -data ConnectionTerminatedException = - ConnectionTerminatedException SomeException - deriving (Typeable) - - ------------------------------------------------------------------------------- -instance Show ConnectionTerminatedException where - show (ConnectionTerminatedException e) = - "Connection terminated with exception: " ++ show e - - ------------------------------------------------------------------------------- -instance Exception ConnectionTerminatedException where - toException = uncatchableExceptionToException - fromException = uncatchableExceptionFromException - - ------------------------------------------------------------------------------- -- | Terminate the HTTP session with the given exception. terminateConnection :: (Exception e, MonadCatchIO m) => e -> m a terminateConnection = throw . ConnectionTerminatedException . toException --- | This is exception is thrown if the handler chooses to escape regular HTTP --- traffic. -data EscapeHttpException = EscapeHttpException - ((Int -> IO ()) -> Iteratee ByteString IO () -> Iteratee ByteString IO ()) - deriving (Typeable) - - ------------------------------------------------------------------------------ -instance Show EscapeHttpException where - show = const "HTTP traffic was escaped" - - ------------------------------------------------------------------------------- -instance Exception EscapeHttpException where - toException = uncatchableExceptionToException - fromException = uncatchableExceptionFromException - - ------------------------------------------------------------------------------- -- | Terminate the HTTP session and hand control to some external handler, -- escaping all further HTTP traffic. -- --- The external handler takes two arguments: a function to tickle the timeout --- manager, and a write end to the socket. -escapeHttp :: MonadCatchIO m - => ((Int -> IO ()) -> Iteratee ByteString IO () -> - Iteratee ByteString IO ()) +-- The external handler takes two arguments: a function to modify the thread's +-- timeout, and a write end to the socket. +escapeHttp :: MonadCatchIO m => + EscapeHttpHandler -> m () escapeHttp = throw . EscapeHttpException @@ -927,7 +860,7 @@ -- | Runs a 'Snap' monad action in the 'Iteratee IO' monad. runSnap :: Snap a -> (ByteString -> IO ()) - -> (Int -> IO ()) + -> ((Int -> Int) -> IO ()) -> Request -> Iteratee ByteString IO (Request,Response) runSnap (Snap m) logerr timeoutAction req = do @@ -941,12 +874,26 @@ return (_snapRequest ss', resp) where - fourohfour = - setContentLength 3 $ - setResponseStatus 404 "Not Found" $ - modifyResponseBody (>==> enumBuilder (fromByteString "404")) $ - emptyResponse + fourohfour = do + clearContentLength $ + setResponseStatus 404 "Not Found" $ + setResponseBody enum404 $ + emptyResponse + enum404 = enumBuilder $ mconcat $ map fromByteString html + + html = [ S.concat [ "\n" + , "\n" + , "\n" + , "Not found\n" + , "\n" + , "\n" + , "No handler accepted \"" + ] + , rqURI req + , "\"\n" + ] + dresp = emptyResponse { rspHttpVersion = rqVersion req } ss = SnapState req dresp logerr timeoutAction @@ -956,7 +903,7 @@ ------------------------------------------------------------------------------ evalSnap :: Snap a -> (ByteString -> IO ()) - -> (Int -> IO ()) + -> ((Int -> Int) -> IO ()) -> Request -> Iteratee ByteString IO a evalSnap (Snap m) logerr timeoutAction req = do @@ -973,7 +920,17 @@ {-# INLINE evalSnap #-} +------------------------------------------------------------------------------ +getParamFrom :: MonadSnap m => + (ByteString -> Request -> Maybe [ByteString]) + -> ByteString + -> m (Maybe ByteString) +getParamFrom f k = do + rq <- getRequest + return $! liftM (S.intercalate " ") $ f k rq +{-# INLINE getParamFrom #-} + ------------------------------------------------------------------------------ -- | See 'rqParam'. Looks up a value for the given named parameter in the -- 'Request'. If more than one value was entered for the given parameter name, @@ -984,12 +941,41 @@ getParam :: MonadSnap m => ByteString -- ^ parameter name to look up -> m (Maybe ByteString) -getParam k = do - rq <- getRequest - return $ liftM (S.intercalate " ") $ rqParam k rq +getParam = getParamFrom rqParam +{-# INLINE getParam #-} ------------------------------------------------------------------------------ +-- | See 'rqPostParam'. Looks up a value for the given named parameter in the +-- POST form parameters mapping in 'Request'. If more than one value was +-- entered for the given parameter name, 'getPostParam' gloms the values +-- together with: +-- +-- @ 'S.intercalate' \" \"@ +-- +getPostParam :: MonadSnap m + => ByteString -- ^ parameter name to look up + -> m (Maybe ByteString) +getPostParam = getParamFrom rqPostParam +{-# INLINE getPostParam #-} + + +------------------------------------------------------------------------------ +-- | See 'rqQueryParam'. Looks up a value for the given named parameter in the +-- query string parameters mapping in 'Request'. If more than one value was +-- entered for the given parameter name, 'getQueryParam' gloms the values +-- together with: +-- +-- @ 'S.intercalate' \" \"@ +-- +getQueryParam :: MonadSnap m + => ByteString -- ^ parameter name to look up + -> m (Maybe ByteString) +getQueryParam = getParamFrom rqQueryParam +{-# INLINE getQueryParam #-} + + +------------------------------------------------------------------------------ -- | See 'rqParams'. Convenience function to return 'Params' from the -- 'Request' inside of a 'MonadSnap' instance. getParams :: MonadSnap m => m Params @@ -997,6 +983,20 @@ ------------------------------------------------------------------------------ +-- | See 'rqParams'. Convenience function to return 'Params' from the +-- 'Request' inside of a 'MonadSnap' instance. +getPostParams :: MonadSnap m => m Params +getPostParams = getRequest >>= return . rqPostParams + + +------------------------------------------------------------------------------ +-- | See 'rqParams'. Convenience function to return 'Params' from the +-- 'Request' inside of a 'MonadSnap' instance. +getQueryParams :: MonadSnap m => m Params +getQueryParams = getRequest >>= return . rqQueryParams + + +------------------------------------------------------------------------------ -- | Gets the HTTP 'Cookie' with the specified name. getCookie :: MonadSnap m => ByteString @@ -1030,15 +1030,36 @@ ------------------------------------------------------------------------------ -- | Causes the handler thread to be killed @n@ seconds from now. -setTimeout :: MonadSnap m - => Int -> m () -setTimeout n = do - t <- getTimeoutAction - liftIO $ t n +setTimeout :: MonadSnap m => Int -> m () +setTimeout = modifyTimeout . const ------------------------------------------------------------------------------ --- | Returns an 'IO' action which you can use to reset the handling thread's +-- | Causes the handler thread to be killed at least @n@ seconds from now. +extendTimeout :: MonadSnap m => Int -> m () +extendTimeout = modifyTimeout . max + + +------------------------------------------------------------------------------ +-- | Modifies the amount of time remaining before the request times out. +modifyTimeout :: MonadSnap m => (Int -> Int) -> m () +modifyTimeout f = do + m <- getTimeoutModifier + liftIO $ m f + + +------------------------------------------------------------------------------ +-- | Returns an 'IO' action which you can use to set the handling thread's -- timeout value. getTimeoutAction :: MonadSnap m => m (Int -> IO ()) -getTimeoutAction = liftSnap $ liftM _snapSetTimeout sget +getTimeoutAction = do + modifier <- liftSnap $ liftM _snapModifyTimeout sget + return $! modifier . const +{-# DEPRECATED getTimeoutAction + "use getTimeoutModifier instead. Since 0.8." #-} + + +------------------------------------------------------------------------------ +-- | Returns an 'IO' action which you can use to modify the timeout value. +getTimeoutModifier :: MonadSnap m => m ((Int -> Int) -> IO ()) +getTimeoutModifier = liftSnap $ liftM _snapModifyTimeout sget diff --git a/src/Snap/Iteratee.hs b/src/Snap/Iteratee.hs --- a/src/Snap/Iteratee.hs +++ b/src/Snap/Iteratee.hs @@ -149,7 +149,7 @@ (Right v) -> step v step (Continue !k) = do - return $ Continue (\s -> insideCatch $ k s) + return $! Continue (\s -> insideCatch $ k s) -- don't worry about Error here because the error had to come from the -- handler (because of 'catchError' above) step y = return y @@ -162,12 +162,12 @@ --block :: m a -> m a block m = Iteratee $ block $ (runIteratee m >>= step) where - step (Continue k) = return $ Continue (\s -> block (k s)) + step (Continue k) = return $! Continue (\s -> block (k s)) step y = return y unblock m = Iteratee $ unblock $ (runIteratee m >>= step) where - step (Continue k) = return $ Continue (\s -> unblock (k s)) + step (Continue k) = return $! Continue (\s -> unblock (k s)) step y = return y @@ -217,8 +217,8 @@ step <- runIteratee i case step of (Continue k) -> return (Continue $ go 0 k) - (Yield x s) -> return $ Yield (x,0) s - (Error e) -> return $ Error e + (Yield x s) -> return $! Yield (x,0) s + (Error e) -> return $! Error e where go !n k str = Iteratee $ do @@ -252,7 +252,7 @@ -> IO (Iteratee ByteString IO a) unsafeBufferIteratee step = do buf <- mkIterateeBuffer - return $ unsafeBufferIterateeWithBuffer buf step + return $! unsafeBufferIterateeWithBuffer buf step ------------------------------------------------------------------------------ @@ -274,7 +274,7 @@ where -------------------------------------------------------------------------- start :: Step ByteString IO a -> IO (Step ByteString IO a) - start (Continue k) = return $ Continue $ go 0 k + start (Continue k) = return $! Continue $ go 0 k start s@_ = return s @@ -312,7 +312,7 @@ step <- sendBuf n k step2 <- runIteratee $ enumEOF step - return $ copyStep step2 + return $! copyStep step2 go !n !k (Chunks xs) = Iteratee $ do @@ -347,7 +347,7 @@ let b' = plusPtr bufp n copyBytes b' p sz - return $ Continue $ go (n+m) k + return $! Continue $! go (n+m) k @@ -375,8 +375,8 @@ iv <- sendBuf bUFSIZ k case iv of (Yield x r) -> let !z = copy r - in return $ Yield x $ (z `mappend` Chunks [s2]) - (Error e) -> return $ Error e + in return $! Yield x $! (z `mappend` Chunks [s2]) + (Error e) -> return $! Error e (Continue k') -> do -- check the size of the remainder; if it's bigger than the -- buffer size then just send it @@ -386,8 +386,8 @@ case step of (Yield x r) -> let !z = copy r in return $! Yield x z - (Error e) -> return $ Error e - (Continue k'') -> return $ Continue $ go 0 k'' + (Error e) -> return $! Error e + (Continue k'') -> return $! Continue $! go 0 k'' else copyAndCont 0 k' s2 m2 @@ -600,7 +600,7 @@ tooBigForMMap :: FilePath -> IO Bool tooBigForMMap fp = do stat <- getFileStatus fp - return $ fileSize stat > maxMMapFileSize + return $! fileSize stat > maxMMapFileSize ------------------------------------------------------------------------------ diff --git a/src/Snap/Test.hs b/src/Snap/Test.hs --- a/src/Snap/Test.hs +++ b/src/Snap/Test.hs @@ -13,6 +13,9 @@ -- ** Building Requests and testing handlers , buildRequest , runHandler + , runHandlerM + , evalHandler + , evalHandlerM -- *** Convenience functions for generating common types of HTTP requests , get 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 @@ -74,7 +74,7 @@ let dirs = splitDirectories p when (elem ".." dirs) pass - return $ joinPath dirs + return $! joinPath dirs ------------------------------------------------------------------------------ @@ -324,7 +324,7 @@ f <- liftIO $ liftM (\s -> T.encodeUtf8 s `mappend` "/") $ packFn f0 writeBS "" + writeBS "'>" writeBS f writeBS "DIR" @@ -607,7 +607,7 @@ char '-' end <- option Nothing $ liftM Just parseNum - return $ RangeReq start end + return $! RangeReq start end suffixByteRangeSpec = liftM SuffixRangeReq $ char '-' *> parseNum 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 @@ -252,7 +252,7 @@ hdrs <- liftM headers getRequest let (ct, mbBoundary) = getContentType hdrs - tickleTimeout <- getTimeoutAction + tickleTimeout <- liftM (. max) getTimeoutModifier let bumpTimeout = tickleTimeout $ uploadTimeout uploadPolicy let partHandler = if doProcessFormInputs uploadPolicy @@ -274,7 +274,11 @@ let boundary = fromJust mbBoundary captures <- runRequestBody (iter bumpTimeout boundary partHandler) - procCaptures [] captures + xs <- procCaptures [] captures + modifyRequest $ \req -> + let pp = rqPostParams req + in rqModifyParams (\p -> Map.unionWith (++) p pp) req + return xs where rateLimit bump m = @@ -297,16 +301,18 @@ maxFormVars = maximumNumberOfFormInputs uploadPolicy - procCaptures l [] = return $ reverse l + modifyParams f r = r { rqPostParams = f $ rqPostParams r } + + procCaptures l [] = return $! reverse l procCaptures l ((File x):xs) = procCaptures (x:l) xs procCaptures l ((Capture k v):xs) = do rq <- getRequest - let n = Map.size $ rqParams rq + let n = Map.size $ rqPostParams rq when (n >= maxFormVars) $ throw $ PolicyViolationException $ T.concat [ "number of form inputs exceeded maximum of " , T.pack $ show maxFormVars ] - modifyRequest $ rqModifyParams (ins k v) + modifyRequest $ modifyParams (ins k v) procCaptures l xs @@ -565,7 +571,7 @@ var <- liftM S.concat $ joinI' $ takeNoMoreThan maxSize $$ consume - return $ Capture fieldName var + return $! Capture fieldName var handler e = do debug $ "captureVariableOrReadFile/handler: caught " ++ show e @@ -781,15 +787,15 @@ if isLast then return Nothing else do - x <- partIter + !x <- partIter skipToEof - return $ Just x + return $! Just x - go soFar = {-# SCC "processParts/go" #-} do + go !soFar = {-# SCC "processParts/go" #-} do b <- isEOF if b - then return $ D.toList soFar + then return $! D.toList soFar else do -- processPart $$ iter -- :: Iteratee MatchInfo m (Step ByteString m a) @@ -800,7 +806,7 @@ case output of Just x -> go (D.append soFar $ D.singleton x) - Nothing -> return $ D.toList soFar + Nothing -> return $! D.toList soFar bParser = iterateeDebugWrapper "boundary debugger" $ iterParser $ pBoundaryEnd 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 @@ -150,46 +150,56 @@ gzipCompression :: MonadSnap m => ByteString -> m () gzipCompression ce = modifyResponse f where - f = setHeader "Content-Encoding" ce . - setHeader "Vary" "Accept-Encoding" . - clearContentLength . - modifyResponseBody gcompress + f r = setHeader "Content-Encoding" ce $ + setHeader "Vary" "Accept-Encoding" $ + clearContentLength $ + modifyResponseBody (gcompress (getBufferingMode r)) r ------------------------------------------------------------------------------ compressCompression :: MonadSnap m => ByteString -> m () compressCompression ce = modifyResponse f where - f = setHeader "Content-Encoding" ce . - setHeader "Vary" "Accept-Encoding" . - clearContentLength . - modifyResponseBody ccompress + f r = setHeader "Content-Encoding" ce $ + setHeader "Vary" "Accept-Encoding" $ + clearContentLength $ + modifyResponseBody (ccompress (getBufferingMode r)) r ------------------------------------------------------------------------------ -gcompress :: forall a . Enumerator Builder IO a +gcompress :: Bool -- ^ buffer? + -> forall a . Enumerator Builder IO a -> Enumerator Builder IO a -gcompress e st = e $$ iFinal +gcompress buffer e st = e $$ iFinal where i0 = returnI st - iB = mapFlush =$ i0 + iNoB = mapFlush =$ i0 + iZNoB = Z.gzip =$ iNoB + + iB = I.map fromByteString =$ i0 iZ = Z.gzip =$ iB - iFinal = enumBuilderToByteString =$ iZ + iFinal = enumBuilderToByteString =$ if buffer then iZ else iZNoB + mapFlush :: Monad m => Enumeratee ByteString Builder m b mapFlush = I.map ((`mappend` flush) . fromByteString) ------------------------------------------------------------------------------ -ccompress :: forall a . Enumerator Builder IO a +ccompress :: Bool -- ^ buffer? + -> forall a . Enumerator Builder IO a -> Enumerator Builder IO a -ccompress e st = e $$ iFinal +ccompress buffer e st = e $$ iFinal where i0 = returnI st - iB = mapFlush =$ i0 + iNoB = mapFlush =$ i0 + iZNoB = Z.compress 5 Z.defaultWindowBits =$ iNoB + + iB = I.map fromByteString =$ i0 iZ = Z.compress 5 Z.defaultWindowBits =$ iB - iFinal = enumBuilderToByteString =$ iZ + iFinal = enumBuilderToByteString =$ if buffer then iZ else iZNoB + mapFlush :: Monad m => Enumeratee ByteString Builder m b mapFlush = I.map ((`mappend` flush) . fromByteString) @@ -202,7 +212,7 @@ xs <- option [] $ (:[]) <$> encoding ys <- many (char ',' *> encoding) endOfInput - return $ xs ++ ys + return $! xs ++ ys where encoding = skipSpace *> c <* skipSpace diff --git a/src/Snap/Util/Proxy.hs b/src/Snap/Util/Proxy.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Util/Proxy.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | This module provides facilities for patching incoming 'Requests' to +-- correct the value of 'rqRemoteAddr' if the snap server is running behind a +-- proxy. +-- +-- Example usage: +-- +-- @ +-- m :: Snap () +-- m = undefined -- code goes here +-- +-- applicationHandler :: Snap () +-- applicationHandler = behindProxy X_Forwarded_For m +-- @ +-- +module Snap.Util.Proxy + ( ProxyType(..) + , behindProxy + ) where + +------------------------------------------------------------------------------ +import Control.Applicative +import Control.Arrow (second) +import qualified Data.ByteString.Char8 as S +import Data.Char (isSpace) +import Data.Maybe (fromJust) +------------------------------------------------------------------------------ +import Snap.Core +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +-- | What kind of proxy is this? Affects which headers 'behindProxy' pulls the +-- original remote address from. +-- +-- Currently only proxy servers that send @X-Forwarded-For@ or @Forwarded-For@ +-- are supported. +data ProxyType = NoProxy -- ^ no proxy, leave the request alone + | X_Forwarded_For -- ^ Use the @Forwarded-For@ or + -- @X-Forwarded-For@ header + deriving (Read, Show, Eq, Ord) + + +------------------------------------------------------------------------------ +-- | Rewrite 'rqRemoteAddr' if we're behind a proxy. +behindProxy :: MonadSnap m => ProxyType -> m a -> m a +behindProxy NoProxy = id +behindProxy X_Forwarded_For = ((modifyRequest xForwardedFor) >>) +{-# INLINE behindProxy #-} + + +------------------------------------------------------------------------------ +xForwardedFor :: Request -> Request +xForwardedFor req = req { rqRemoteAddr = ip + , rqRemotePort = port + } + where + proxyString = getHeader "Forwarded-For" req <|> + getHeader "X-Forwarded-For" req <|> + Just (rqRemoteAddr req) + + proxyAddr = trim . snd . S.breakEnd (== ',') . fromJust $ proxyString + + trim = fst . S.spanEnd isSpace . S.dropWhile isSpace + + (ip,portStr) = second (S.drop 1) . S.break (== ':') $ proxyAddr + + port = fromJust (fst <$> S.readInt portStr <|> + Just (rqRemotePort req)) +{-# INLINE xForwardedFor #-} diff --git a/test/runTestsAndCoverage.sh b/test/runTestsAndCoverage.sh --- a/test/runTestsAndCoverage.sh +++ b/test/runTestsAndCoverage.sh @@ -31,22 +31,24 @@ mkdir -p $DIR EXCLUDES='Main +Snap.Core.Tests Snap.Internal.Debug -Snap.Internal.Iteratee.Debug -Snap.Iteratee.Tests Snap.Internal.Http.Parser.Tests Snap.Internal.Http.Server.Tests Snap.Internal.Http.Types.Tests +Snap.Internal.Iteratee.Debug Snap.Internal.Iteratee.Tests Snap.Internal.Parsing.Tests Snap.Internal.Routing.Tests +Snap.Iteratee.Tests +Snap.Test.Common Snap.Test.Tests Snap.Types.Tests Snap.Util.FileServe.Tests Snap.Util.FileUploads.Tests Snap.Util.GZip.Tests -Text.Snap.Templates.Tests -Snap.Test.Common' +Snap.Util.Proxy.Tests +Text.Snap.Templates.Tests' EXCL="" 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 @@ -22,43 +22,43 @@ cpp-options: -DUSE_UNIX build-depends: - QuickCheck >= 2.3.0.2, - attoparsec >= 0.10 && < 0.11, - attoparsec-enumerator >= 0.3, - base >= 4 && < 5, - base16-bytestring == 0.1.*, - blaze-builder >= 0.2.1.4 && <0.4, - blaze-builder-enumerator >= 0.2 && <0.3, + QuickCheck >= 2.3.0.2 && <3, + attoparsec >= 0.10 && <0.11, + attoparsec-enumerator >= 0.3, + base >= 4 && <5, + base16-bytestring >= 0.1 && <0.2, + blaze-builder >= 0.2.1.4 && <0.4, + blaze-builder-enumerator >= 0.2 && <0.3, bytestring, bytestring-nums, - case-insensitive >= 0.3 && < 0.5, - cereal == 0.3.*, + case-insensitive >= 0.3 && <0.5, + cereal >= 0.3 && <0.4, containers, - deepseq >= 1.1 && <1.3, + deepseq >= 1.1 && <1.4, directory, - dlist >= 0.5 && < 0.6, + dlist >= 0.5 && <0.6, filepath, - HUnit >= 1.2 && < 2, - enumerator >= 0.4.13.1 && < 0.5, - MonadCatchIO-transformers >= 0.2 && < 0.3, - mtl >= 2 && <3, - mwc-random >= 0.10 && <0.11, + HUnit >= 1.2 && <2, + enumerator >= 0.4.13.1 && <0.5, + MonadCatchIO-transformers >= 0.2 && <0.3, + mtl >= 2 && <3, + mwc-random >= 0.10 && <0.13, old-locale, old-time, - parallel >= 3 && <4, - pureMD5 == 2.1.*, - regex-posix >= 0.94.4 && <0.96, - 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, + parallel >= 3 && <4, + pureMD5 == 2.1.*, + regex-posix >= 0.94.4 && <0.96, + test-framework >= 0.4 && <0.6, + 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, + unix-compat >= 0.2 && <0.4, + unordered-containers >= 0.1.4.3 && <0.3, + vector >= 0.6 && <0.10, zlib, - zlib-enum >= 0.2.1 && <0.3 + zlib-enum >= 0.2.1 && <0.3 extensions: BangPatterns, diff --git a/test/suite/Snap/Core/Tests.hs b/test/suite/Snap/Core/Tests.hs --- a/test/suite/Snap/Core/Tests.hs +++ b/test/suite/Snap/Core/Tests.hs @@ -30,7 +30,8 @@ import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 import Test.HUnit hiding (Test, path) - + +import Snap.Internal.Exceptions import Snap.Internal.Http.Types import Snap.Internal.Parsing import Snap.Internal.Types @@ -96,10 +97,11 @@ 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 + 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 Map.empty Map.empty + mkRequestQuery :: ByteString -> ByteString -> [ByteString] -> IO Request mkRequestQuery uri k v = do enum <- newIORef $ SomeEnumerator returnI @@ -108,8 +110,8 @@ 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 + enum Nothing GET (1,1) [] uri "/" + (S.concat ["/",uri,"?",q]) q mp mp Map.empty mkZomgRq :: IO Request @@ -117,7 +119,8 @@ 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 + enum Nothing GET (1,1) [] "/" "/" "/" "" + Map.empty Map.empty Map.empty mkIpHeaderRq :: IO Request @@ -136,8 +139,8 @@ 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 + enum Nothing GET (1,1) [] "/" "/" "/" "" + Map.empty Map.empty Map.empty testCatchIO :: Test testCatchIO = testCase "types/catchIO" $ do @@ -160,21 +163,21 @@ go :: Snap a -> IO (Request,Response) go m = do zomgRq <- mkZomgRq - run_ $ runSnap m dummy dummy zomgRq + run_ $ runSnap m dummy (const (return ())) 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 + run_ $ runSnap m dummy (const (return ())) 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 + run_ $ runSnap m dummy (const (return ())) rq where dummy = const $ return () @@ -186,7 +189,7 @@ -> IO (Request,Response) goPathQuery s k v m = do rq <- mkRequestQuery s k v - run_ $ runSnap m dummy dummy rq + run_ $ runSnap m dummy (const (return ())) rq where dummy = const $ return () @@ -194,7 +197,7 @@ goBody :: Snap a -> IO (Request,Response) goBody m = do rq <- mkRqWithBody - run_ $ runSnap m dummy dummy rq + run_ $ runSnap m dummy (const (return ())) rq where dummy = const $ return () @@ -204,7 +207,7 @@ -> IO (Request,Response) goEnum enum m = do rq <- mkRqWithEnum enum - run_ $ runSnap m dummy dummy rq + run_ $ runSnap m dummy (const (return ())) rq where dummy = const $ return () @@ -284,7 +287,7 @@ (const $ return ()) (const $ return ()) rq - + y' <- readIORef ref assertEqual "bracketSnap/after" 2 y' @@ -294,7 +297,7 @@ (const $ return ()) (const $ return ()) rq - + y'' <- readIORef ref assertEqual "bracketSnap/after" 3 y'' @@ -473,14 +476,21 @@ testParam = testCase "types/getParam" $ do expect404 $ goPath "/foo" f expectNo404 $ goPathQuery "/foo" "param" ["foo"] f + expectNo404 $ goPathQuery "/foo" "param" ["foo"] fQ + expect404 $ goPathQuery "/foo" "param" ["foo"] fP + where - f = do - mp <- getParam "param" + p gp = do + mp <- gp "param" maybe pass (\s -> if s == "foo" then return () else pass) mp + f = p getParam + fQ = p getQueryParam + fP = p getPostParam + getBody :: Response -> IO L.ByteString getBody r = do let benum = rspBodyToEnum $ rspBody r @@ -546,10 +556,8 @@ 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 + assertBool "mzero 404" (")) import Control.Monad import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.IORef +import qualified Data.ByteString as S import qualified Data.Map as Map import Data.Maybe import Test.Framework 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 +import Snap.Test +import Snap.Test.Common +------------------------------------------------------------------------------ + tests :: [Test] tests = [ testRouting1 , testRouting2 @@ -54,31 +56,20 @@ , testRouteLocal , testRouteUrlDecode , testRouteUrlEncodedPath + , testRouteEmptyCapture ] -expectException :: IO a -> IO () -expectException m = do - e <- try m - case e of - Left (z::SomeException) -> (show z) `seq` return () - Right _ -> assertFailure "expected exception, didn't get one" - -mkRequest :: ByteString -> IO Request -mkRequest uri = do - enum <- newIORef $ SomeEnumerator returnI - - return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False H.empty - enum Nothing GET (1,1) [] "" uri "/" - (B.concat ["/",uri]) "" Map.empty - +------------------------------------------------------------------------------ go :: Snap a -> ByteString -> IO a -go m s = do - req <- mkRequest s - run_ $ evalSnap m dummy dummy req +go m s0 = evalHandler (get s Map.empty) m where - dummy = const $ return () + s = if S.isPrefixOf "/" s0 + then s0 + else S.append "/" s0 + +------------------------------------------------------------------------------ routes :: Snap ByteString routes = route [ ("foo" , topFoo ) , ("foo/bar" , fooBar ) @@ -92,31 +83,45 @@ , ("bar" , bar ) , ("z/:a/:b/:c/d" , zabc ) ] + +------------------------------------------------------------------------------ routesLocal :: Snap ByteString routesLocal = routeLocal [ ("foo/bar/baz" , getRqPathInfo ) , ("bar" , pass ) ] + +------------------------------------------------------------------------------ routes2 :: Snap ByteString routes2 = route [ ("" , topTop ) , ("foo" , topFoo ) ] + +------------------------------------------------------------------------------ routes3 :: Snap ByteString routes3 = route [ (":foo" , topCapture ) , ("" , topTop ) ] + +------------------------------------------------------------------------------ routes4 :: Snap ByteString routes4 = route [ (":foo" , pass ) , (":foo" , topCapture ) , (":qqq/:id" , fooCapture ) , (":id2/baz" , fooCapture2 ) ] + +------------------------------------------------------------------------------ routes5 :: Snap ByteString routes5 = route [ ("" , pass ) , ("" , topTop ) ] + +------------------------------------------------------------------------------ routes6 :: Snap ByteString routes6 = route [ (":a/:a" , dblA ) ] + +------------------------------------------------------------------------------ routes7 :: Snap ByteString routes7 = route [ ("foo/:id" , fooCapture ) , ("foo/:id/:id2" , fooCapture2) @@ -125,8 +130,14 @@ , ("" , topTop ) ] +------------------------------------------------------------------------------ +routesEmptyCapture :: Snap ByteString +routesEmptyCapture = route [ ("foo/:id", fooCapture) ] + + +------------------------------------------------------------------------------ topTop, topFoo, fooBar, fooCapture, getRqPathInfo, bar, - getRqContextPath, barQuux, dblA, zabc, topCapture, + getRqContextPath, barQuux, dblA, zabc, topCapture, fooCapture2 :: Snap ByteString dblA = do @@ -162,147 +173,209 @@ barQuux = return "barQuux" bar = return "bar" --- TODO more useful test names + ----------- + -- Tests -- + ----------- + + +------------------------------------------------------------------------------ +-- TODO more useful test names testRouting1 :: Test testRouting1 = testCase "route/1" $ do r1 <- go routes "foo" assertEqual "/foo" "topFoo" r1 + +------------------------------------------------------------------------------ testRouting2 :: Test testRouting2 = testCase "route/2" $ do r2 <- go routes "foo/baz" assertEqual "/foo/baz" "baz" r2 + +------------------------------------------------------------------------------ testRouting3 :: Test testRouting3 = testCase "route/3" $ do - expectException $ go routes "/xsaxsaxsax" + expectExceptionH $ go routes "/xsaxsaxsax" + +------------------------------------------------------------------------------ testRouting4 :: Test testRouting4 = testCase "route/4" $ do r3 <- go routes "foo/bar" assertEqual "/foo/bar" "fooBar" r3 + +------------------------------------------------------------------------------ testRouting5 :: Test testRouting5 = testCase "route/5" $ do r4 <- go routes "foo/bar/baz/quux" assertEqual "/foo/bar/baz/quux" "quux" r4 + +------------------------------------------------------------------------------ testRouting6 :: Test testRouting6 = testCase "route/6" $ do r5 <- go routes "foo/bar/sproing" assertEqual "/foo/bar/sproing" "fooBar" r5 + +------------------------------------------------------------------------------ testRouting7 :: Test testRouting7 = testCase "route/7" $ do r <- go routes "bar" assertEqual "/bar" "bar" r + +------------------------------------------------------------------------------ testRouting8 :: Test testRouting8 = testCase "route/8" $ do r2 <- go routes "bar/quux" assertEqual "/bar/quux" "barQuux" r2 + +------------------------------------------------------------------------------ testRouting9 :: Test testRouting9 = testCase "route/9" $ do r3 <- go routes "bar/whatever" assertEqual "/bar/whatever" "whatever" r3 + +------------------------------------------------------------------------------ testRouting10 :: Test testRouting10 = testCase "route/10" $ do r4 <- go routes "bar/quux/whatever" assertEqual "/bar/quux/whatever" "barQuux" r4 + +------------------------------------------------------------------------------ testRouting11 :: Test testRouting11 = testCase "route/11" $ do r1 <- go routes2 "" assertEqual "/" "topTop" r1 + +------------------------------------------------------------------------------ testRouting12 :: Test testRouting12 = testCase "route/12" $ do r1 <- go routes2 "foo" assertEqual "/foo" "topFoo" r1 + +------------------------------------------------------------------------------ testRouting13 :: Test testRouting13 = testCase "route/13" $ do r1 <- go routes3 "zzzz" assertEqual "/zzzz" "zzzz" r1 + +------------------------------------------------------------------------------ testRouting14 :: Test testRouting14 = testCase "route/14" $ do r1 <- go routes3 "" assertEqual "/" "topTop" r1 + +------------------------------------------------------------------------------ testRouting15 :: Test testRouting15 = testCase "route/15" $ do r1 <- go routes4 "zzzz" assertEqual "/zzzz" "zzzz" r1 + +------------------------------------------------------------------------------ testRouting16 :: Test testRouting16 = testCase "route/16" $ do r1 <- go routes5 "" assertEqual "/" "topTop" r1 + +------------------------------------------------------------------------------ testRouting17 :: Test testRouting17 = testCase "route/17" $ do r1 <- go routes "z/a/b/c/d" assertEqual "/z/a/b/c/d" "ok" r1 + +------------------------------------------------------------------------------ testRouting18 :: Test testRouting18 = testCase "route/18" $ do r1 <- go routes6 "a/a" assertEqual "/a/a" "ok" r1 + +------------------------------------------------------------------------------ testRouting19 :: Test testRouting19 = testCase "route/19" $ do r1 <- go routes7 "foo" assertEqual "/foo" "topTop" r1 + +------------------------------------------------------------------------------ testRouting20 :: Test testRouting20 = testCase "route/20" $ do r1 <- go routes7 "foo/baz" assertEqual "/foo/baz" "baz" r1 + +------------------------------------------------------------------------------ testRouting21 :: Test testRouting21 = testCase "route/21" $ do r1 <- go routes7 "foo/baz/quux" assertEqual "/foo/baz/quux" "quux" r1 + +------------------------------------------------------------------------------ testRouting22 :: Test testRouting22 = testCase "route/22" $ do r1 <- go routes7 "fooo/baz" assertEqual "/fooo/baz" "topTop" r1 + +------------------------------------------------------------------------------ testRouting23 :: Test testRouting23 = testCase "route/23" $ do r1 <- go routes7 "fooo/baz/quux" assertEqual "/fooo/baz/quux" "quux" r1 + +------------------------------------------------------------------------------ testRouting24 :: Test testRouting24 = testCase "route/24" $ do r1 <- go routes7 "foooo/bar/bax" assertEqual "/foooo/bar/bax" "topTop" r1 + +------------------------------------------------------------------------------ testRouting25 :: Test testRouting25 = testCase "route/25" $ do r1 <- go routes7 "foooo/bar/baz" assertEqual "/foooo/bar/baz" "bar" r1 + +------------------------------------------------------------------------------ testRouting26 :: Test testRouting26 = testCase "route/26" $ do r1 <- go routes4 "foo/bar" assertEqual "capture union" "bar" r1 + +------------------------------------------------------------------------------ testRouting27 :: Test testRouting27 = testCase "route/27" $ do r1 <- go routes4 "foo" assertEqual "capture union" "foo" r1 + +------------------------------------------------------------------------------ testRouting28 :: Test testRouting28 = testCase "route/28" $ do r1 <- go routes4 "quux/baz" assertEqual "capture union" "quux" r1 + +------------------------------------------------------------------------------ testRouteUrlDecode :: Test testRouteUrlDecode = testCase "route/urlDecode" $ do r1 <- go routes "herp/%7Bderp%7D/" @@ -312,14 +385,32 @@ r3 <- go routes "nerp/%7Bderp%7D/" assertEqual "rqContextPath on urldecode" "/nerp/%7Bderp%7D/" r3 + +------------------------------------------------------------------------------ testRouteUrlEncodedPath :: Test testRouteUrlEncodedPath = testCase "route/urlEncodedPath" $ do -- make sure path search urlDecodes. r1 <- go routes "a+b+c+d" assertEqual "urlEncoded search works" "OK" r1 + +------------------------------------------------------------------------------ testRouteLocal :: Test testRouteLocal = testCase "route/routeLocal" $ do r4 <- go routesLocal "foo/bar/baz/quux" assertEqual "/foo/bar/baz/quux" "foo/bar/baz/quux" r4 - expectException $ go routesLocal "bar" + expectExceptionH $ go routesLocal "bar" + + +------------------------------------------------------------------------------ +testRouteEmptyCapture :: Test +testRouteEmptyCapture = testCase "route/emptyCapture" $ do + r <- go m "foo" + assertEqual "empty capture must fail" expected r + + r2 <- go m "foo/" + assertEqual "empty capture must fail" expected r2 + + where + expected = "ZOMG_OK" + m = routesEmptyCapture <|> return expected 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 @@ -16,6 +16,7 @@ , eatException ) where +------------------------------------------------------------------------------ import Control.DeepSeq import Control.Exception (SomeException(..), evaluate) import Control.Monad @@ -31,6 +32,7 @@ import Test.QuickCheck.Monadic +------------------------------------------------------------------------------ instance Arbitrary S.ByteString where arbitrary = liftM (S.pack . map c2w) arbitrary @@ -41,15 +43,7 @@ return $ L.fromChunks chunks --- | Kill the false negative on derived show instances. -coverShowInstance :: (Monad m, Show a) => a -> m () -coverShowInstance x = a `deepseq` b `deepseq` c `deepseq` return () - where - a = showsPrec 0 x "" - b = show x - c = showList [x] "" - - +------------------------------------------------------------------------------ eatException :: (MonadCatchIO m) => m a -> m () eatException a = (a >> return ()) `catch` handler where @@ -57,16 +51,29 @@ handler _ = return () +------------------------------------------------------------------------------ forceSameType :: a -> a -> a forceSameType _ a = a +------------------------------------------------------------------------------ +-- | Kill the false negative on derived show instances. +coverShowInstance :: (Monad m, Show a) => a -> m () +coverShowInstance x = a `deepseq` b `deepseq` c `deepseq` return () + where + a = showsPrec 0 x "" + b = show x + c = showList [x] "" + + +------------------------------------------------------------------------------ coverReadInstance :: (MonadIO m, Read a) => a -> m () coverReadInstance x = do liftIO $ eatException $ evaluate $ forceSameType [(x,"")] $ readsPrec 0 "" liftIO $ eatException $ evaluate $ forceSameType [([x],"")] $ readList "" +------------------------------------------------------------------------------ coverEqInstance :: (Monad m, Eq a) => a -> m () coverEqInstance x = a `seq` b `seq` return () where @@ -74,22 +81,25 @@ b = x /= x +------------------------------------------------------------------------------ coverOrdInstance :: (Monad m, Ord a) => a -> m () coverOrdInstance x = a `deepseq` b `deepseq` return () where a = [ x < x , x >= x , x > x - , x <= x + , x <= x , compare x x == EQ ] b = min a $ max a a +------------------------------------------------------------------------------ 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 @@ -98,6 +108,7 @@ Right _ -> fail "expected exception, didn't get one" +------------------------------------------------------------------------------ expectExceptionH :: IO a -> IO () expectExceptionH act = do e <- try act @@ -106,5 +117,6 @@ 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/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 @@ -5,6 +5,7 @@ module Snap.Util.FileServe.Tests ( tests ) where +------------------------------------------------------------------------------ import Blaze.ByteString.Builder import Control.Monad import Data.ByteString (ByteString) @@ -18,13 +19,16 @@ import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, path) - +------------------------------------------------------------------------------ import Snap.Internal.Http.Types import Snap.Internal.Types import Snap.Util.FileServe import Snap.Iteratee import qualified Snap.Types.Headers as H +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ tests :: [Test] tests = [ testFooBin , testFooTxt @@ -32,25 +36,26 @@ , testFooBinBinBin , test404s , testFsSingle - , testFsCfgA , testFsCfgB , testFsCfgC , testFsCfgD , testFsCfgFancy - , testRangeOK , testRangeBad , testMultiRange - , testIfRange ] + , testIfRange + ] +------------------------------------------------------------------------------ expect404 :: IO Response -> IO () expect404 m = do r <- m assertBool "expected 404" (rspStatus r == 404) +------------------------------------------------------------------------------ expect302 :: ByteString -> IO Response -> IO () expect302 p m = do r <- m @@ -60,24 +65,28 @@ (getHeader "location" r) +------------------------------------------------------------------------------ getBody :: Response -> IO L.ByteString getBody r = do let benum = rspBodyToEnum $ rspBody r liftM (toLazyByteString . mconcat) (runIteratee consume >>= run_ . benum) +------------------------------------------------------------------------------ runIt :: Snap a -> Request -> Iteratee ByteString IO (Request, Response) runIt m rq = runSnap m d d rq where d = const $ return () +------------------------------------------------------------------------------ go :: Snap a -> ByteString -> IO Response go m s = do rq <- mkRequest s liftM snd (run_ $ runIt m rq) +------------------------------------------------------------------------------ goIfModifiedSince :: Snap a -> ByteString -> ByteString -> IO Response goIfModifiedSince m s lm = do rq <- mkRequest s @@ -85,6 +94,7 @@ liftM snd (run_ $ runIt m r) +------------------------------------------------------------------------------ goIfRange :: Snap a -> ByteString -> (Int,Int) -> ByteString -> IO Response goIfRange m s (start,end) lm = do rq <- mkRequest s @@ -95,6 +105,7 @@ liftM snd (run_ $ runIt m r) +------------------------------------------------------------------------------ goRange :: Snap a -> ByteString -> (Int,Int) -> IO Response goRange m s (start,end) = do rq' <- mkRequest s @@ -104,6 +115,7 @@ liftM snd (run_ $ runIt m rq) +------------------------------------------------------------------------------ goMultiRange :: Snap a -> ByteString -> (Int,Int) -> (Int,Int) -> IO Response goMultiRange m s (start,end) (start2,end2) = do rq' <- mkRequest s @@ -114,6 +126,7 @@ liftM snd (run_ $ runIt m rq) +------------------------------------------------------------------------------ goRangePrefix :: Snap a -> ByteString -> Int -> IO Response goRangePrefix m s start = do rq' <- mkRequest s @@ -123,6 +136,7 @@ liftM snd (run_ $ runIt m rq) +------------------------------------------------------------------------------ goRangeSuffix :: Snap a -> ByteString -> Int -> IO Response goRangeSuffix m s end = do rq' <- mkRequest s @@ -132,12 +146,14 @@ liftM snd (run_ $ runIt m rq) +------------------------------------------------------------------------------ mkRequest :: ByteString -> IO Request mkRequest uri = do enum <- newIORef $ SomeEnumerator returnI return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False H.empty - enum Nothing GET (1,1) [] "" pathPart "/" - (S.concat ["/",uri]) queryPart Map.empty + enum Nothing GET (1,1) [] pathPart "/" + (S.concat ["/",uri]) queryPart + Map.empty Map.empty Map.empty where (pathPart, queryPart) = breakQuery uri @@ -147,25 +163,27 @@ (a,b) = S.break (=='?') s +------------------------------------------------------------------------------ fs :: Snap () fs = do x <- serveDirectory "data/fileServe" return $! x `seq` () +------------------------------------------------------------------------------ fsSingle :: Snap () fsSingle = do x <- serveFile "data/fileServe/foo.html" return $! x `seq` () +------------------------------------------------------------------------------ fsCfg :: DirectoryConfig Snap -> Snap () fsCfg cfg = do x <- serveDirectoryWith cfg "data/fileServe" return $! x `seq` () - ------------------------------------------------------------------------------ testFooBin :: Test testFooBin = testCase "fileServe/foo.bin" $ do @@ -224,9 +242,8 @@ assertEqual (name ++ "/accept-ranges") (Just "bytes") (getHeader "accept-ranges" r) - - + ------------------------------------------------------------------------------ testFooHtml :: Test testFooHtml = testCase "fileServe/foo.html" $ do @@ -291,6 +308,7 @@ printName c = writeBS $ snd $ S.breakEnd (=='/') $ S.pack c +------------------------------------------------------------------------------ cfgA, cfgB, cfgC, cfgD :: DirectoryConfig Snap cfgA = DirectoryConfig { indexFiles = [] @@ -325,6 +343,7 @@ } +------------------------------------------------------------------------------ testFsCfgA :: Test testFsCfgA = testCase "fileServe/cfgA" $ do let gooo = go (fsCfg cfgA) @@ -338,9 +357,9 @@ expect404 $ gooo "bar.bin" -- Named file in a subdirectory - gooo "mydir2/foo.txt" >>= checkProps "cfgA1/subdir/1" "text/plain" + gooo "mydir2/foo.txt" >>= checkProps "cfgA1/subdir/1" "text/plain" gooo "mydir2/foo.txt?z=z" >>= checkProps "cfgA1/subdir/2" "text/plain" - + -- Missing file in a subdirectory expect404 $ gooo "mydir2/bar.txt" @@ -375,7 +394,9 @@ assertEqual (name ++ "/accept-ranges") (Just "bytes") (getHeader "accept-ranges" r) - + + +------------------------------------------------------------------------------ testFsCfgB :: Test testFsCfgB = testCase "fileServe/cfgB" $ do let gooo = go (fsCfg cfgB) @@ -412,6 +433,7 @@ expect404 $ gooo "mydir2/" +------------------------------------------------------------------------------ testFsCfgC :: Test testFsCfgC = testCase "fileServe/cfgC" $ do let gooo = go (fsCfg cfgC) @@ -441,6 +463,7 @@ assertEqual "C3" "mydir2" bC3 +------------------------------------------------------------------------------ testFsCfgD :: Test testFsCfgD = testCase "fileServe/cfgD" $ do -- Request for file with dynamic handler @@ -450,6 +473,7 @@ assertEqual "D1" "foo.txt" bD1 +------------------------------------------------------------------------------ testFsCfgFancy :: Test testFsCfgFancy = testCase "fileServe/cfgFancy" $ do -- Request for directory with autogen index @@ -476,7 +500,7 @@ " m () coverMimeMap = Prelude.mapM_ f $ Map.toList defaultMimeTypes where f (!k,!v) = return $ case k `seq` v `seq` () of () -> () +------------------------------------------------------------------------------ testIfRange :: Test testIfRange = testCase "fileServe/range/if-range" $ do r <- goIfRange fs "foo.bin" (1,2) "Wed, 15 Nov 1995 04:58:08 GMT" 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 @@ -31,6 +31,7 @@ ------------------------------------------------------------------------------ import Snap.Internal.Http.Types import Snap.Internal.Debug +import Snap.Internal.Exceptions import Snap.Internal.Iteratee.Debug import Snap.Internal.Types import Snap.Iteratee hiding (map) @@ -78,8 +79,10 @@ hndl' xs = do fileMap <- foldM f Map.empty xs - p1 <- getParam "field1" - p2 <- getParam "field2" + p1 <- getParam "field1" + p1P <- getPostParam "field1" + p1Q <- getQueryParam "field1" + p2 <- getParam "field2" liftIO $ do assertEqual "file1 contents" @@ -94,9 +97,9 @@ (Just formContents1) p1 - assertEqual "field2 contents" - (Just formContents2) - p2 + assertEqual "field1 POST contents" (Just formContents1) p1P + assertEqual "field1 query contents" Nothing p1Q + assertEqual "field2 contents" (Just formContents2) p2 @@ -330,8 +333,8 @@ dirs <- liftM (filter (\x -> x /= "." && x /= "..")) $ getDirectoryContents tmpdir assertEqual "files should be cleaned up" [] dirs - + tmpdir = "tempdirC" hndl = handleFileUploads tmpdir defaultUploadPolicy @@ -339,8 +342,8 @@ hndl' hndl' _ = return () - + ------------------------------------------------------------------------------ harness :: FilePath -> Snap a -> ByteString -> IO () harness = harness' go @@ -369,8 +372,8 @@ ] return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False hdrs - enum Nothing POST (1,1) [] "" "/" "/" - "/" "" Map.empty + enum Nothing POST (1,1) [] "/" "/" + "/" "" Map.empty Map.empty Map.empty ------------------------------------------------------------------------------ @@ -384,8 +387,8 @@ ] return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False hdrs - enum Nothing POST (1,1) [] "" "/" "/" - "/" "" Map.empty + enum Nothing POST (1,1) [] "/" "/" + "/" "" Map.empty Map.empty Map.empty where enum = enumBS (S.take (S.length body - 1) body) >==> dieNow dieNow _ = throw TestException @@ -413,6 +416,7 @@ let rq' = setHeader "Content-Type" "text/plain" rq liftM snd (run_ $ runIt m rq') + ------------------------------------------------------------------------------ goSlowEnumerator :: Snap a -> ByteString -> IO Response goSlowEnumerator m s = do @@ -440,6 +444,7 @@ waitabit :: IO () waitabit = threadDelay $ 2*seconds + ------------------------------------------------------------------------------ seconds :: Int seconds = (10::Int) ^ (6::Int) @@ -447,7 +452,7 @@ ------------------------------------------------------------------------------ runIt :: Snap a -> Request -> Iteratee ByteString IO (Request, Response) -runIt m rq = iterateeDebugWrapper "test" $ runSnap m d d rq +runIt m rq = iterateeDebugWrapper "test" $ runSnap m d (const $ return ()) rq where d :: forall a . Show a => a -> IO () d = \x -> show x `deepseq` return () 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 @@ -86,7 +86,8 @@ enum <- newIORef $ SomeEnumerator returnI return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False emptyHdrs - enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty + enum Nothing GET (1,1) [] "/" "/" "/" "" + Map.empty Map.empty Map.empty mkGzipRq :: IO Request @@ -94,14 +95,16 @@ enum <- newIORef $ SomeEnumerator returnI return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False gzipHdrs - enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty + enum Nothing GET (1,1) [] "/" "/" "/" "" + Map.empty Map.empty Map.empty mkXGzipRq :: IO Request mkXGzipRq = do enum <- newIORef $ SomeEnumerator returnI return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False xGzipHdrs - enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty + enum Nothing GET (1,1) [] "/" "/" "/" "" + Map.empty Map.empty Map.empty @@ -111,14 +114,17 @@ enum <- newIORef $ SomeEnumerator returnI return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False compressHdrs - enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty + enum Nothing GET (1,1) [] "/" "/" "/" "" + Map.empty Map.empty Map.empty + mkXCompressRq :: IO Request mkXCompressRq = do enum <- newIORef $ SomeEnumerator returnI return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False xCompressHdrs - enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty + enum Nothing GET (1,1) [] "/" "/" "/" "" + Map.empty Map.empty Map.empty @@ -128,7 +134,9 @@ enum <- newIORef $ SomeEnumerator returnI return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False badHdrs - enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty + enum Nothing GET (1,1) [] "/" "/" "/" "" + Map.empty Map.empty Map.empty + ------------------------------------------------------------------------------ seqSnap :: Snap a -> Snap a diff --git a/test/suite/Snap/Util/Proxy/Tests.hs b/test/suite/Snap/Util/Proxy/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Util/Proxy/Tests.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Snap.Util.Proxy.Tests (tests) where + +------------------------------------------------------------------------------ +import Control.Monad.State hiding (get) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +import Data.CaseInsensitive (CI(..)) +import qualified Data.Map as Map +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test, path) +------------------------------------------------------------------------------ +import Snap.Core hiding (setHeader) +import Snap.Test +import Snap.Test.Common +import Snap.Util.Proxy +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +tests :: [Test] +tests = [ testNoProxy + , testForwardedFor + , testTrivials + ] + + + --------------- + -- Constants -- + --------------- + +------------------------------------------------------------------------------ +initialPort :: Int +initialPort = 9999 + +initialAddr :: ByteString +initialAddr = "127.0.0.1" + + + ----------- + -- Tests -- + ----------- + +------------------------------------------------------------------------------ +testNoProxy :: Test +testNoProxy = testCase "proxy/no-proxy" $ do + a <- evalHandler (mkReq $ forwardedFor [("4.3.2.1", Nothing)]) + (behindProxy NoProxy reportRemoteAddr) + p <- evalHandler (mkReq $ forwardedFor [("4.3.2.1", Nothing)]) + (behindProxy NoProxy reportRemotePort) + assertEqual "NoProxy leaves request alone" initialAddr a + assertEqual "NoProxy leaves request alone" initialPort p + + -------------------------------------------------------------------------- + b <- evalHandler (mkReq $ xForwardedFor [("4.3.2.1", Nothing)]) + (behindProxy NoProxy reportRemoteAddr) + assertEqual "NoProxy leaves request alone" initialAddr b + + -------------------------------------------------------------------------- + c <- evalHandler (mkReq $ return ()) + (behindProxy NoProxy reportRemoteAddr) + assertEqual "NoProxy leaves request alone" initialAddr c + + +------------------------------------------------------------------------------ +testForwardedFor :: Test +testForwardedFor = testCase "proxy/forwarded-for" $ do + (a,p) <- evalHandler (mkReq $ return ()) handler + assertEqual "No Forwarded-For, no change" initialAddr a + assertEqual "port" initialPort p + + -------------------------------------------------------------------------- + (b,_) <- evalHandler (mkReq $ forwardedFor addr) handler + assertEqual "Behind 5.6.7.8" ip b + + -------------------------------------------------------------------------- + (c,q) <- evalHandler (mkReq $ xForwardedFor addrs2) handler + assertEqual "Behind 5.6.7.8" ip c + assertEqual "port change" port q + + where + handler = behindProxy X_Forwarded_For $ do + !a <- reportRemoteAddr + !p <- reportRemotePort + return $! (a,p) + + ip = "5.6.7.8" + port = 10101 + + addr = [ (ip, Nothing) ] + + addr2 = [ (ip, Just port) ] + addrs2 = [("4.3.2.1", Just 20202)] ++ addr2 + + +------------------------------------------------------------------------------ +testTrivials :: Test +testTrivials = testCase "proxy/trivials" $ do + coverShowInstance NoProxy + coverReadInstance NoProxy + coverEqInstance NoProxy + coverOrdInstance NoProxy + + + --------------- + -- Functions -- + --------------- + +------------------------------------------------------------------------------ +mkReq :: RequestBuilder IO () -> RequestBuilder IO () +mkReq m = do + get "/" Map.empty + modify $ \req -> req { rqRemoteAddr = initialAddr + , rqRemotePort = initialPort + } + m + + +------------------------------------------------------------------------------ +reportRemoteAddr :: Snap ByteString +reportRemoteAddr = withRequest $ \req -> return $ rqRemoteAddr req + + +------------------------------------------------------------------------------ +reportRemotePort :: Snap Int +reportRemotePort = withRequest $ \req -> return $ rqRemotePort req + + +------------------------------------------------------------------------------ +forwardedFor' :: CI ByteString -- ^ header name + -> [(ByteString, Maybe Int)] -- ^ list of "forwarded-for" + -> RequestBuilder IO () +forwardedFor' hdr addrs = do + setHeader hdr out + + where + toStr (a, Nothing) = a + toStr (a, Just p ) = S.concat [ a, ":", S.pack $ show p ] + + out = S.intercalate ", " $ map toStr addrs + + +------------------------------------------------------------------------------ +forwardedFor :: [(ByteString, Maybe Int)] + -> RequestBuilder IO () +forwardedFor = forwardedFor' "Forwarded-For" + + +------------------------------------------------------------------------------ +xForwardedFor :: [(ByteString, Maybe Int)] + -> RequestBuilder IO () +xForwardedFor = forwardedFor' "X-Forwarded-For" diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs --- a/test/suite/TestSuite.hs +++ b/test/suite/TestSuite.hs @@ -2,6 +2,7 @@ import Test.Framework (defaultMain, testGroup) +------------------------------------------------------------------------------ import qualified Snap.Core.Tests import qualified Snap.Internal.Http.Types.Tests import qualified Snap.Internal.Parsing.Tests @@ -10,28 +11,32 @@ import qualified Snap.Util.FileServe.Tests import qualified Snap.Util.FileUploads.Tests import qualified Snap.Util.GZip.Tests +import qualified Snap.Util.Proxy.Tests import qualified Snap.Test.Tests +------------------------------------------------------------------------------ main :: IO () main = defaultMain tests - where tests = [ - testGroup "Snap.Internal.Http.Types.Tests" - Snap.Internal.Http.Types.Tests.tests - , testGroup "Snap.Internal.Routing.Tests" - Snap.Internal.Routing.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 - ] + where + tests = [ testGroup "Snap.Internal.Http.Types.Tests" + Snap.Internal.Http.Types.Tests.tests + , testGroup "Snap.Internal.Routing.Tests" + Snap.Internal.Routing.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.FileServe.Tests" + Snap.Util.FileServe.Tests.tests + , testGroup "Snap.Util.FileUploads.Tests" + Snap.Util.FileUploads.Tests.tests + , testGroup "Snap.Util.Proxy.Tests" + Snap.Util.Proxy.Tests.tests + , testGroup "Snap.Util.GZip.Tests" + Snap.Util.GZip.Tests.tests + , testGroup "Snap.Test.Tests" + Snap.Test.Tests.tests + ]