snap-core 0.7.0.1 → 0.8.0

raw patch · 28 files changed

+1248/−573 lines, 28 filesdep ~enumeratordep ~mwc-randomdep ~unordered-containersPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: enumerator, mwc-random, unordered-containers

API changes (from Hackage documentation)

Files

• snap-core.cabal +20/−28
• src/Snap/Core.hs +17/−1
• src/Snap/Internal/Debug.hs +27/−24
• src/Snap/Internal/Exceptions.hs +86/−0
• src/Snap/Internal/Http/Types.hs +116/−56
• src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs +4/−4
• src/Snap/Internal/Parsing.hs +120/−91
• src/Snap/Internal/Parsing/FastSet.hs +2/−2
• src/Snap/Internal/Routing.hs +5/−5
• src/Snap/Internal/Test/RequestBuilder.hs +125/−62
• src/Snap/Internal/Types.hs +128/−107
• src/Snap/Iteratee.hs +14/−14
• src/Snap/Test.hs +3/−0
• src/Snap/Util/FileServe.hs +3/−3
• src/Snap/Util/FileUploads.hs +17/−11
• src/Snap/Util/GZip.hs +27/−17
• src/Snap/Util/Proxy.hs +71/−0
• test/runTestsAndCoverage.sh +6/−4
• test/snap-core-testsuite.cabal +27/−27
• test/suite/Snap/Core/Tests.hs +30/−22
• test/suite/Snap/Internal/Http/Types/Tests.hs +3/−2
• test/suite/Snap/Internal/Routing/Tests.hs +122/−31
• test/suite/Snap/Test/Common.hs +22/−10
• test/suite/Snap/Util/FileServe/Tests.hs +42/−14
• test/suite/Snap/Util/FileUploads/Tests.hs +17/−12
• test/suite/Snap/Util/GZip/Tests.hs +14/−6
• test/suite/Snap/Util/Proxy/Tests.hs +155/−0
• test/suite/TestSuite.hs +25/−20

@@ -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 (<http://happstack.com/index.html>), 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 

@@ -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

@@ -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 

@@ -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++

@@ -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 

@@ -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

@@ -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 -- <http://tools.ietf.org/html/rfc2396.html#section-2.4>) 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 -- <http://tools.ietf.org/html/rfc2396.html#section-2.4>) urlEncode :: ByteString -> ByteString urlEncode = toByteString . urlEncodeBuilder+{-# INLINE urlEncode #-}   ------------------------------------------------------------------------------ -- | URL-escapes a string (see -- <http://tools.ietf.org/html/rfc2396.html#section-2.4>) 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

@@ -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     (

@@ -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

@@ -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-   ------------------------------------------------------------------------------

@@ -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 [ "<!DOCTYPE html>\n"+                      , "<html>\n"+                      , "<head>\n"+                      , "<title>Not found</title>\n"+                      , "</head>\n"+                      , "<body>\n"+                      , "<code>No handler accepted \""+                      ]+           , rqURI req+           , "\"</code>\n</body></html>"+           ]+     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

@@ -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   ------------------------------------------------------------------------------

@@ -13,6 +13,9 @@     -- ** Building Requests and testing handlers   , buildRequest   , runHandler+  , runHandlerM+  , evalHandler+  , evalHandlerM      -- *** Convenience functions for generating common types of HTTP requests   , get

@@ -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 "<tr><td class='filename'><a href='"         writeBS f-        writeBS "/'>"+        writeBS "'>"         writeBS f         writeBS "</a></td><td class='type' colspan=2>DIR</td></tr>" @@ -607,7 +607,7 @@         char '-'         end   <- option Nothing $ liftM Just parseNum -        return $ RangeReq start end+        return $! RangeReq start end      suffixByteRangeSpec = liftM SuffixRangeReq $ char '-' *> parseNum 

@@ -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

@@ -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 

@@ -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 #-}

@@ -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="" 

@@ -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,

@@ -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" ("<!DOCTYPE html" `L.isPrefixOf` b)   testEvalSnap :: Test

@@ -37,7 +37,8 @@ mkRq = do     enum <- newIORef (SomeEnumerator $ enumBS "")     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   testFormatLogTime :: Test@@ -59,7 +60,7 @@       let x = getHeader "foo" req-    assertEqual "addHeader x 2" (Just "baz bar") x+    assertEqual "addHeader x 2" (Just "baz,bar") x   testUrlDecode :: Test

@@ -1,27 +1,29 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}  module Snap.Internal.Routing.Tests   ( tests ) where -import           Control.Exception+------------------------------------------------------------------------------+import           Control.Applicative ((<|>)) 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

@@ -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

@@ -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 @@         "<a href='foo.txt'" `S.isInfixOf` bE2  -+------------------------------------------------------------------------------ testFsSingle :: Test testFsSingle = testCase "fileServe/Single" $ do     r1 <- go fsSingle "foo.html"@@ -490,7 +514,7 @@     assertEqual "foo.html size" (Just 4) (rspContentLength r1)  -+------------------------------------------------------------------------------ testRangeOK :: Test testRangeOK = testCase "fileServe/range/ok" $ do     r1 <- goRange fsSingle "foo.html" (1,2)@@ -514,6 +538,7 @@     assertEqual "foo.html partial prefix" "O\n" b3  +------------------------------------------------------------------------------ testMultiRange :: Test testMultiRange = testCase "fileServe/range/multi" $ do     r1 <- goMultiRange fsSingle "foo.html" (1,2) (3,3)@@ -526,6 +551,7 @@     assertEqual "foo.html" "FOO\n" b1  +------------------------------------------------------------------------------ testRangeBad :: Test testRangeBad = testCase "fileServe/range/bad" $ do     r1 <- goRange fsSingle "foo.html" (1,17)@@ -541,12 +567,14 @@     assertEqual "bad suffix range" 416 $ rspStatus r2  +------------------------------------------------------------------------------ coverMimeMap :: (Monad m) => 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"

@@ -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 ()

@@ -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

@@ -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"

@@ -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+            ]