diff --git a/snap-server.cabal b/snap-server.cabal --- a/snap-server.cabal +++ b/snap-server.cabal @@ -1,5 +1,5 @@ name: snap-server -version: 1.0.1.1 +version: 1.0.2.0 synopsis: A web server for the Snap Framework description: Snap is a simple and fast web development framework and server written in @@ -102,9 +102,9 @@ old-locale >= 1.0 && < 1.1, snap-core >= 1.0 && < 1.1, text >= 0.11 && < 1.3, - time >= 1.0 && < 1.7, + time >= 1.0 && < 1.9, unix-compat >= 0.2 && < 0.5, - vector >= 0.7 && < 0.12 + vector >= 0.7 && < 0.13 other-extensions: BangPatterns, @@ -201,7 +201,7 @@ case-insensitive >= 1.1 && < 1.3, clock >= 0.7.1 && < 0.8, containers >= 0.3 && < 0.6, - directory >= 1.0 && < 1.3, + directory >= 1.0 && < 1.4, filepath >= 1.1 && < 2.0, io-streams >= 1.3 && < 1.4, io-streams-haproxy >= 1.0 && < 1.1, @@ -217,7 +217,7 @@ time >= 1.0 && < 1.7, transformers >= 0.3 && < 0.6, unix-compat >= 0.2 && < 0.5, - vector >= 0.7 && < 0.12, + vector >= 0.7 && < 0.13, HUnit >= 1.2 && < 2, QuickCheck >= 2.3.0.2 && < 3, @@ -308,7 +308,7 @@ io-streams >= 1.3 && < 1.4, io-streams-haproxy >= 1.0 && < 1.1, snap-core >= 1.0 && < 1.1, - vector >= 0.7 && < 0.12 + vector >= 0.7 && < 0.13 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind -rtsopts @@ -398,7 +398,7 @@ text >= 0.11 && < 1.3, time >= 1.0 && < 1.7, unix-compat >= 0.2 && < 0.5, - vector >= 0.7 && < 0.12 + vector >= 0.7 && < 0.13 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind -threaded -rtsopts @@ -479,7 +479,7 @@ case-insensitive >= 1.1 && < 1.3, clock >= 0.7.1 && < 0.8, containers >= 0.3 && < 0.6, - directory >= 1.1 && < 1.3, + directory >= 1.1 && < 1.4, io-streams >= 1.3 && < 1.4, io-streams-haproxy >= 1.0 && < 1.1, lifted-base >= 0.1 && < 0.3, @@ -491,7 +491,7 @@ time >= 1.0 && < 1.7, transformers >= 0.3 && < 0.6, unix-compat >= 0.2 && < 0.5, - vector >= 0.7 && < 0.12 + vector >= 0.7 && < 0.13 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind -threaded -rtsopts diff --git a/src/Snap/Internal/Http/Server/Config.hs b/src/Snap/Internal/Http/Server/Config.hs --- a/src/Snap/Internal/Http/Server/Config.hs +++ b/src/Snap/Internal/Http/Server/Config.hs @@ -86,9 +86,10 @@ import qualified Data.CaseInsensitive as CI import Data.Function (on) import Data.List (foldl') +import qualified Data.Map as Map import Data.Maybe (isJust, isNothing) #if !MIN_VERSION_base(4,8,0) -import Data.Monoid (Monoid(..)) +import Data.Monoid (Monoid (..)) #endif import Data.Monoid (Last (Last, getLast)) import qualified Data.Text as T @@ -96,7 +97,7 @@ #if MIN_VERSION_base(4,7,0) import Data.Typeable (Typeable) #else -import Data.Typeable (TyCon, Typeable, Typeable1 (..), mkTyConApp, mkTyCon3) +import Data.Typeable (TyCon, Typeable, Typeable1 (..), mkTyCon3, mkTyConApp) #endif import Network (Socket) import Numeric (readOct, showOct) @@ -115,7 +116,7 @@ import Data.ByteString.Builder (Builder, byteString, stringUtf8, toLazyByteString) import qualified System.IO.Streams as Streams ------------------------------------------------------------------------------ -import Snap.Core (MonadSnap, Request (rqClientAddr, rqClientPort), emptyResponse, finishWith, getRequest, logError, setContentLength, setContentType, setResponseBody, setResponseStatus) +import Snap.Core (MonadSnap, Request (rqClientAddr, rqClientPort, rqParams, rqPostParams), emptyResponse, finishWith, getsRequest, logError, setContentLength, setContentType, setResponseBody, setResponseStatus) import Snap.Internal.Debug (debug) @@ -699,7 +700,7 @@ defaultErrorHandler :: MonadSnap m => SomeException -> m () defaultErrorHandler e = do debug "Snap.Http.Server.Config errorHandler:" - req <- getRequest + req <- getsRequest blindParams let sm = smsg req debug $ toString sm logError sm @@ -711,6 +712,10 @@ $ emptyResponse where + blindParams r = r { rqPostParams = rmValues $ rqPostParams r + , rqParams = rmValues $ rqParams r } + rmValues = Map.map (const ["..."]) + errBody os = Streams.write (Just msgB) os >> return os toByteString = S.concat . L.toChunks . toLazyByteString diff --git a/src/Snap/Internal/Http/Server/TimeoutManager.hs b/src/Snap/Internal/Http/Server/TimeoutManager.hs --- a/src/Snap/Internal/Http/Server/TimeoutManager.hs +++ b/src/Snap/Internal/Http/Server/TimeoutManager.hs @@ -19,10 +19,10 @@ ------------------------------------------------------------------------------ import Control.Exception (evaluate, finally) import qualified Control.Exception as E -import Control.Monad (Monad ((>>=), return), mapM_, void) +import Control.Monad (Monad ((>>=), return), mapM_, void, when) import qualified Data.ByteString.Char8 as S import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Prelude (Bool, Double, IO, Int, Show (..), const, fromIntegral, max, max, min, null, otherwise, round, ($), ($!), (+), (++), (-), (.), (<=), (==)) +import Prelude (Bool, Double, IO, Int, Show (..), const, fromIntegral, max, null, otherwise, round, ($), ($!), (+), (++), (-), (.), (<=), (==)) ------------------------------------------------------------------------------ import Control.Concurrent (MVar, newEmptyMVar, putMVar, readMVar, takeMVar, tryPutMVar) ------------------------------------------------------------------------------ @@ -193,40 +193,35 @@ -------------------------------------------------------------------------- loop = do now <- getTime - nextWakeup <- E.uninterruptibleMask $ \restore' -> do + E.uninterruptibleMask $ \restore' -> do handles <- atomicModifyIORef' threads (\x -> ([], x)) if null handles then do restore' $ takeMVar morePlease - return now else do - (handles', next) <- processHandles now handles + handles' <- processHandles now handles atomicModifyIORef' threads (\x -> (handles' ++ x, ())) >>= evaluate - return $! next - now' <- getTime - Clock.sleepFor $ max 0 (nextWakeup - now') + Clock.sleepFor pollInterval loop -------------------------------------------------------------------------- - processHandles now handles = go handles [] (now + pollInterval) + processHandles now handles = go handles [] where - go [] !kept !nextWakeup = return $! (kept, nextWakeup) + go [] !kept = return $! kept - go (x:xs) !kept !nextWakeup = do + go (x:xs) !kept = do !state <- readIORef $ _state x - (!kept', !next) <- + !kept' <- if isCanceled state then do b <- T.isFinished (_thread x) return $! if b - then (kept, nextWakeup) - else ((x:kept), nextWakeup) - else do t <- if state <= now - then do T.cancel (_thread x) - writeIORef (_state x) canceled - return nextWakeup - else return (min nextWakeup state) - return ((x:kept), t) - go xs kept' next + then kept + else (x:kept) + else do when (state <= now) $ do + T.cancel (_thread x) + writeIORef (_state x) canceled + return (x:kept) + go xs kept' -------------------------------------------------------------------------- destroyAll xs = do