snap-server 1.0.1.1 → 1.0.2.0
raw patch · 3 files changed
+34/−34 lines, 3 filesdep ~io-streamsdep ~time
Dependency ranges changed: io-streams, time
Files
- snap-server.cabal +9/−9
- src/Snap/Internal/Http/Server/Config.hs +9/−4
- src/Snap/Internal/Http/Server/TimeoutManager.hs +16/−21
snap-server.cabal view
@@ -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
src/Snap/Internal/Http/Server/Config.hs view
@@ -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
src/Snap/Internal/Http/Server/TimeoutManager.hs view
@@ -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