snap-server 0.7.0.1 → 0.8.0
raw patch · 17 files changed
+504/−323 lines, 17 filesdep ~enumeratordep ~snap-core
Dependency ranges changed: enumerator, snap-core
Files
- snap-server.cabal +3/−12
- src/Snap/Http/Server.hs +26/−14
- src/Snap/Http/Server/Config.hs +40/−10
- src/Snap/Internal/Http/Parser.hs +2/−2
- src/Snap/Internal/Http/Server.hs +62/−44
- src/Snap/Internal/Http/Server/Backend.hs +1/−1
- src/Snap/Internal/Http/Server/HttpPort.hs +26/−26
- src/Snap/Internal/Http/Server/LibevBackend.hs +34/−13
- src/Snap/Internal/Http/Server/ListenHelpers.hs +14/−18
- src/Snap/Internal/Http/Server/SimpleBackend.hs +6/−5
- src/Snap/Internal/Http/Server/TLS.hs +59/−35
- src/Snap/Internal/Http/Server/TimeoutManager.hs +70/−17
- test/common/Snap/Test/Common.hs +11/−2
- test/common/Test/Common/TestHandler.hs +42/−26
- test/snap-server-testsuite.cabal +76/−76
- test/suite/Snap/Internal/Http/Server/Tests.hs +19/−19
- test/suite/Test/Blackbox.hs +13/−3
snap-server.cabal view
@@ -1,5 +1,5 @@ name: snap-server-version: 0.7.0.1+version: 0.8.0 synopsis: A fast, iteratee-based, epoll-enabled web server for the Snap Framework description: Snap is a simple and fast web development framework and server written in@@ -10,15 +10,6 @@ server library written in Haskell. Together with the @snap-core@ library upon which it depends, it provides a clean and efficient Haskell programming interface to the HTTP protocol.- .- 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@@ -111,14 +102,14 @@ case-insensitive >= 0.3 && < 0.5, containers >= 0.3 && < 0.5, directory-tree >= 0.10 && < 0.11,- enumerator >= 0.4.13.1 && < 0.5,+ enumerator >= 0.4.15 && < 0.5, filepath >= 1.1 && < 1.4, MonadCatchIO-transformers >= 0.2.1 && < 0.3, mtl >= 2 && < 3, murmur-hash >= 0.1 && < 0.2, network >= 2.3 && < 2.4, old-locale,- snap-core >= 0.7 && < 0.8,+ snap-core >= 0.8 && < 0.9, template-haskell >= 2.2 && < 2.8, text >= 0.11 && < 0.12, time >= 1.0 && < 1.5,
src/Snap/Http/Server.hs view
@@ -1,15 +1,13 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-|--The Snap HTTP server is a high performance, epoll-enabled, iteratee-based web-server library written in Haskell. Together with the @snap-core@ library upon-which it depends, it provides a clean and efficient Haskell programming-interface to the HTTP protocol.---}-+------------------------------------------------------------------------------+-- | The Snap HTTP server is a high performance, epoll-enabled, iteratee-based+-- web server library written in Haskell. Together with the @snap-core@+-- library upon which it depends, it provides a clean and efficient Haskell+-- programming interface to the HTTP protocol.+-- module Snap.Http.Server ( simpleHttpServe , httpServe@@ -19,6 +17,7 @@ , module Snap.Http.Server.Config ) where +------------------------------------------------------------------------------ import Control.Applicative import Control.Concurrent (newMVar, withMVar) import Control.Monad@@ -32,12 +31,14 @@ import qualified Snap.Internal.Http.Server as Int import Snap.Core import Snap.Util.GZip+import Snap.Util.Proxy #ifndef PORTABLE import System.Posix.Env #endif import System.IO import System.FastLogger + ------------------------------------------------------------------------------ -- | A short string describing the Snap server version snapServerVersion :: ByteString@@ -48,7 +49,8 @@ -- | Starts serving HTTP requests using the given handler. This function never -- returns; to shut down the HTTP server, kill the controlling thread. ----- This function is like 'httpServe' except it doesn't setup compression or+-- This function is like 'httpServe' except it doesn't setup compression,+-- reverse proxy address translation (via 'Snap.Util.Proxy.behindProxy'), or -- the error handler; this allows it to be used from 'MonadSnap'. simpleHttpServe :: MonadSnap m => Config m a -> Snap () -> IO () simpleHttpServe config handler = do@@ -57,9 +59,11 @@ mapM_ (output . ("Listening on "++) . show) $ listeners conf go conf `finally` output "\nShutting down..."+ where go conf = do let tout = fromMaybe 60 $ getDefaultTimeout conf+ setUnicodeLocale $ fromJust $ getLocale conf withLoggers (fromJust $ getAccessLog conf) (fromJust $ getErrorLog conf) $@@ -93,6 +97,7 @@ {-# INLINE simpleHttpServe #-} +------------------------------------------------------------------------------ listeners :: Config m a -> [Int.ListenPort] listeners conf = catMaybes [ httpListener, httpsListener ] where@@ -101,12 +106,12 @@ p <- getSSLPort conf cert <- getSSLCert conf key <- getSSLKey conf- return $ Int.HttpsPort b p cert key+ return $! Int.HttpsPort b p cert key httpListener = do p <- getPort conf b <- getBind conf- return $ Int.HttpPort b p+ return $! Int.HttpPort b p ------------------------------------------------------------------------------@@ -114,10 +119,16 @@ -- the 'Config' passed in. This function never returns; to shut down the HTTP -- server, kill the controlling thread. httpServe :: Config Snap a -> Snap () -> IO ()-httpServe config handler = do+httpServe config handler0 = do conf <- completeConfig config+ let !handler = chooseProxy conf let serve = compress conf . catch500 conf $ handler simpleHttpServe conf serve++ where+ chooseProxy conf = maybe handler0+ (\ptype -> behindProxy ptype handler0)+ (getProxyType conf) {-# INLINE httpServe #-} @@ -131,6 +142,7 @@ compress :: MonadSnap m => Config m a -> m () -> m () compress conf = if fromJust $ getCompression conf then withCompression else id {-# INLINE compress #-}+ ------------------------------------------------------------------------------ -- | Starts serving HTTP using the given handler. The configuration is read
src/Snap/Http/Server/Config.hs view
@@ -19,6 +19,8 @@ , commandLineConfig , completeConfig + , optDescrs+ , getAccessLog , getBackend , getBind@@ -30,6 +32,7 @@ , getLocale , getOther , getPort+ , getProxyType , getSSLBind , getSSLCert , getSSLKey@@ -47,6 +50,7 @@ , setLocale , setOther , setPort+ , setProxyType , setSSLBind , setSSLCert , setSSLKey@@ -54,7 +58,7 @@ , setVerbose ) where -+------------------------------------------------------------------------------ import Blaze.ByteString.Builder import Blaze.ByteString.Builder.Char8 import Control.Exception (SomeException)@@ -73,6 +77,7 @@ import Snap.Core import Snap.Iteratee ((>==>), enumBuilder) import Snap.Internal.Debug (debug)+import Snap.Util.Proxy import System.Console.GetOpt import System.Environment hiding (getEnv) #ifndef PORTABLE@@ -80,7 +85,6 @@ #endif import System.Exit import System.IO- ------------------------------------------------------------------------------ import Snap.Internal.Http.Server (requestErrorMessage) @@ -133,6 +137,7 @@ , defaultTimeout :: Maybe Int , other :: Maybe a , backend :: Maybe ConfigBackend+ , proxyType :: Maybe ProxyType } instance Show (Config m a) where@@ -151,6 +156,7 @@ , "verbose: " ++ _verbose , "defaultTimeout: " ++ _defaultTimeout , "backend: " ++ _backend+ , "proxyType: " ++ _proxyType ] where@@ -168,6 +174,7 @@ _verbose = show $ verbose c _defaultTimeout = show $ defaultTimeout c _backend = show $ backend c+ _proxyType = show $ proxyType c ------------------------------------------------------------------------------@@ -196,6 +203,7 @@ , defaultTimeout = Nothing , other = Nothing , backend = Nothing+ , proxyType = Nothing } a `mappend` b = Config@@ -215,6 +223,7 @@ , defaultTimeout = ov defaultTimeout a b , other = ov other a b , backend = ov backend a b+ , proxyType = ov proxyType a b } where ov f x y = getLast $! (mappend `on` (Last . f)) x y@@ -251,7 +260,9 @@ --------------------------------------------------------------------------------- | The hostname of the HTTP server+-- | The hostname of the HTTP server. This field has the same format as an HTTP+-- @Host@ header; if a @Host@ header came in with the request, we use that,+-- otherwise we default to this value specified in the configuration. getHostname :: Config m a -> Maybe ByteString getHostname = hostname @@ -263,7 +274,10 @@ getErrorLog :: Config m a -> Maybe ConfigLog getErrorLog = errorLog --- | The locale to use+-- | Gets the locale to use. Locales are used on Unix only, to set the+-- @LANG@\/@LC_ALL@\/etc. environment variable. For instance if you set the+-- locale to \"@en_US@\", we'll set the relevant environment variables to+-- \"@en_US.UTF-8@\". getLocale :: Config m a -> Maybe String getLocale = locale @@ -312,7 +326,10 @@ getBackend :: Config m a -> Maybe ConfigBackend getBackend = backend +getProxyType :: Config m a -> Maybe ProxyType+getProxyType = proxyType + ------------------------------------------------------------------------------ setHostname :: ByteString -> Config m a -> Config m a setHostname x c = c { hostname = Just x }@@ -362,14 +379,17 @@ setBackend :: ConfigBackend -> Config m a -> Config m a setBackend x c = c { backend = Just x } +setProxyType :: ProxyType -> Config m a -> Config m a+setProxyType x c = c { proxyType = Just x } + ------------------------------------------------------------------------------ completeConfig :: (MonadSnap m) => Config m a -> IO (Config m a) completeConfig config = do when noPort $ hPutStrLn stderr "no port specified, defaulting to port 8000" - return $ cfg `mappend` cfg'+ return $! cfg `mappend` cfg' where cfg = defaultConfig `mappend` config@@ -396,10 +416,12 @@ -------------------------------------------------------------------------------options :: MonadSnap m =>- Config m a- -> [OptDescr (Maybe (Config m a))]-options defaults =+-- | Returns a description of the snap command line options suitable for use+-- with "System.Console.GetOpt".+optDescrs :: MonadSnap m =>+ Config m a -- ^ the configuration defaults.+ -> [OptDescr (Maybe (Config m a))]+optDescrs defaults = [ Option [] ["hostname"] (ReqArg (Just . setConfig setHostname . bsFromString) "NAME") $ "local hostname" ++ defaultC getHostname@@ -452,10 +474,17 @@ , Option ['q'] ["quiet"] (NoArg $ Just $ setConfig setVerbose False) $ "do not print anything to stderr"+ , Option [] ["proxy"]+ (ReqArg (\t -> Just $ setConfig setProxyType $ read t)+ "X_Forwarded_For")+ $ concat [ "Set --proxy=X_Forwarded_For if your snap application "+ , "is behind an HTTP reverse proxy to ensure that "+ , "rqRemoteAddr is set properly."] , Option ['h'] ["help"] (NoArg Nothing) $ "display this help and exit" ]+ where setConfig f c = f c mempty conf = defaultConfig `mappend` defaults@@ -478,6 +507,7 @@ . modifyResponseBody (>==> enumBuilder (fromByteString msg)) $ emptyResponse+ where smsg req = toByteString $ requestErrorMessage req e @@ -505,7 +535,7 @@ args <- getArgs prog <- getProgName - let opts = options defaults+ let opts = optDescrs defaults result <- either (usage prog opts) return
src/Snap/Internal/Http/Parser.hs view
@@ -85,7 +85,7 @@ let ver@(!_,!_) = pVer vStr hdrs <- pHeaders- return $ Just $ IRequest method uri ver hdrs+ return $! Just $! IRequest method uri ver hdrs where pVer s = if S.isPrefixOf "HTTP/" s@@ -215,7 +215,7 @@ else do x <- take hex crlf- return $ Just x+ return $! Just x where fromHex :: ByteString -> Int fromHex s = Cvt.hex (L.fromChunks [s])
src/Snap/Internal/Http/Server.hs view
@@ -29,6 +29,7 @@ import qualified Data.ByteString.Lazy as L import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Nums.Careless.Int as Cvt+import Data.Enumerator.Internal import Data.Int import Data.IORef import Data.List (foldl')@@ -46,9 +47,9 @@ import System.Locale ------------------------------------------------------------------------------ import System.FastLogger (timestampedLogEntry, combinedLogEntry)-import Snap.Core (EscapeHttpException (..)) import Snap.Internal.Http.Types import Snap.Internal.Debug+import Snap.Internal.Exceptions (EscapeHttpException (..)) import Snap.Internal.Http.Parser import Snap.Internal.Http.Server.Date @@ -77,7 +78,7 @@ -- Note that we won't be bothering end users with this -- the details will be -- hidden inside the Snap monad type ServerHandler = (ByteString -> IO ())- -> (Int -> IO ())+ -> ((Int -> Int) -> IO ()) -> Request -> Iteratee ByteString IO (Request,Response) @@ -95,8 +96,9 @@ ------------------------------------------------------------------------------ instance Show ListenPort where- show (HttpPort b p) =- concat [ "http://", SC.unpack b, ":", show p, "/" ]+ show (HttpPort b p ) =+ concat [ "http://" , SC.unpack b, ":", show p, "/" ]+ show (HttpsPort b p _ _) = concat [ "https://", SC.unpack b, ":", show p, "/" ] @@ -198,7 +200,7 @@ logE elog "Server.httpServe: BACKEND STOPPED" --------------------------------------------------------------------------- bindPort (HttpPort baddr port) = bindHttp baddr port+ bindPort (HttpPort baddr port ) = bindHttp baddr port bindPort (HttpsPort baddr port cert key) = TLS.bindHttps baddr port cert key @@ -263,7 +265,7 @@ -> Iteratee ByteString IO () -- ^ write end of socket -> (FilePath -> Int64 -> Int64 -> IO ()) -- ^ sendfile end- -> (Int -> IO ()) -- ^ timeout tickler+ -> ((Int -> Int) -> IO ()) -- ^ timeout tickler -> IO () runHTTP defaultTimeout alog elog handler lh sinfo readEnd writeEnd onSendFile tickle =@@ -284,7 +286,8 @@ , fromShow $ remoteAddress sinfo , fromByteString "]: " , fromByteString "an exception escaped to toplevel:\n"- , fromShow e ]+ , fromShow e+ ] go = do buf <- allocBuffer 16384@@ -312,7 +315,8 @@ , fromByteString "\nrequest:\n" , fromShow $ show req , fromByteString "\n"- , msgB ]+ , msgB+ ] where msgB = mconcat [ fromByteString "A web handler threw an exception. Details:\n"@@ -347,7 +351,7 @@ -> Buffer -- ^ builder buffer -> (FilePath -> Int64 -> Int64 -> IO ()) -- ^ sendfile continuation- -> (Int -> IO ()) -- ^ timeout tickler+ -> ((Int -> Int) -> IO ()) -- ^ timeout modifier -> ServerHandler -- ^ handler procedure -> ServerMonad () httpSession defaultTimeout writeEnd' buffer onSendFile tickle handler = do@@ -359,7 +363,7 @@ debug "Server.httpSession: receiveRequest finished" -- successfully got a request, so restart timer- liftIO $ tickle defaultTimeout+ liftIO $ tickle (max defaultTimeout) case mreq of (Just req) -> do@@ -446,7 +450,8 @@ mconcat [ fromByteString "httpSession caught an exception during " , fromByteString phase , fromByteString " phase:\n"- , requestErrorMessage req e ]+ , requestErrorMessage req e+ ] throw ExceptionAlreadyCaught @@ -468,7 +473,8 @@ , fromShow major , fromWord8 $ c2w '.' , fromShow minor- , fromByteString " 100 Continue\r\n\r\n" ]+ , fromByteString " 100 Continue\r\n\r\n"+ ] liftIO $ runIteratee ((enumBS (toByteString hl) >==> enumEOF) $$ writeEnd) return ()@@ -490,7 +496,8 @@ , fromWord8 $ c2w '.' , fromShow minor , fromByteString " 411 Length Required\r\n\r\n"- , fromByteString "411 Length Required\r\n" ]+ , fromByteString "411 Length Required\r\n"+ ] liftIO $ runIteratee ((enumBS (toByteString hl) >==> enumEOF) $$ writeEnd) return ()@@ -501,7 +508,8 @@ receiveRequest writeEnd = do debug "receiveRequest: entered" mreq <- {-# SCC "receiveRequest/parseRequest" #-} lift $- iterateeDebugWrapper "parseRequest" parseRequest+ iterateeDebugWrapper "parseRequest" $+ joinI' $ takeNoMoreThan maxHeadersSize $$ parseRequest debug "receiveRequest: parseRequest returned" case mreq of@@ -510,13 +518,17 @@ setEnumerator req' req <- parseForm req' checkConnectionClose (rqVersion req) (rqHeaders req)- return $ Just req+ return $! Just req Nothing -> return Nothing - where --------------------------------------------------------------------------+ -- TODO(gdc): make this a policy decision (expose in+ -- Snap.Http.Server.Config)+ maxHeadersSize = 256 * 1024++ -------------------------------------------------------------------------- -- check: did the client specify "transfer-encoding: chunked"? then we -- have to honor that. --@@ -613,8 +625,10 @@ e st' liftIO $ writeIORef (rqBody req) $ SomeEnumerator e'- return $ req { rqParams = Map.unionWith (++) (rqParams req)- newParams }+ return $! req { rqParams = Map.unionWith (++) (rqParams req)+ newParams+ , rqPostParams = newParams+ } --------------------------------------------------------------------------@@ -635,30 +649,29 @@ -- will override in "setEnumerator" enum <- liftIO $ newIORef $ SomeEnumerator (enumBS "") - return $ Request serverName- serverPort- remoteAddr- rport- localAddr- lport- localHostname- secure- hdrs- enum- mbContentLength- method- version- cookies- snapletPath- pathInfo- contextPath- uri- queryString- params+ return $! Request serverName+ serverPort+ remoteAddr+ rport+ localAddr+ lport+ localHostname+ secure+ hdrs+ enum+ mbContentLength+ method+ version+ cookies+ pathInfo+ contextPath+ uri+ queryString+ params+ params+ Map.empty where- snapletPath = "" -- TODO: snaplets in v0.2- dropLeadingSlash s = maybe s f mbS where f (a,s') = if a == c2w '/' then s' else s@@ -741,9 +754,14 @@ outstep <- lift $ runIteratee $ iterateeDebugWrapper "countBytes writeEnd" $ countBytes writeEnd++ let bufferFunc = if getBufferingMode rsp+ then unsafeBuilderToByteString (return buffer)+ else I.map (toByteString . (`mappend` flush))+ (x,bs) <- mapIter fromByteString toByteString- (enum $$ joinI $ unsafeBuilderToByteString- (return buffer) outstep)+ (enum $$ joinI $ bufferFunc outstep)+ debug $ "sendResponse: whenEnum: " ++ show bs ++ " bytes enumerated" @@ -858,7 +876,7 @@ {-# SCC "setFileSize" #-} do fs <- liftM fromIntegral $ liftIO $ getFileSize fp- return $ r { rspContentLength = Just fs }+ return $! r { rspContentLength = Just fs } --------------------------------------------------------------------------@@ -892,7 +910,7 @@ z <- case rspBody r'' of (Enum _) -> return r'' (SendFile f Nothing) -> setFileSize f r''- (SendFile _ (Just (s,e))) -> return $+ (SendFile _ (Just (s,e))) -> return $! setContentLength (e-s) r'' case rspContentLength z of
src/Snap/Internal/Http/Server/Backend.hs view
@@ -42,7 +42,7 @@ -> Enumerator ByteString IO () -- ^ read end of socket -> Iteratee ByteString IO () -- ^ write end of socket -> (FilePath -> Int64 -> Int64 -> IO ()) -- ^ sendfile end- -> (Int -> IO ()) -- ^ timeout tickler+ -> ((Int -> Int) -> IO ()) -- ^ timeout tickler -> IO ()
src/Snap/Internal/Http/Server/HttpPort.hs view
@@ -1,6 +1,6 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} module Snap.Internal.Http.Server.HttpPort ( bindHttp@@ -10,68 +10,66 @@ , send ) where - ------------------------------------------------------------------------------ import Data.ByteString (ByteString)-#ifdef PORTABLE-import qualified Data.ByteString as B-#endif import Foreign import Foreign.C import Network.Socket hiding (recv, send) import Unsafe.Coerce-+------------------------------------------------------------------------------ #ifdef PORTABLE+import qualified Data.ByteString as B import qualified Network.Socket.ByteString as SB #else import qualified Data.ByteString.Internal as BI import qualified Data.ByteString.Unsafe as BI #endif-+------------------------------------------------------------------------------ import Snap.Internal.Debug import Snap.Internal.Http.Server.Backend import Snap.Internal.Http.Server.Address + ------------------------------------------------------------------------------ bindHttp :: ByteString -> Int -> IO ListenSocket bindHttp bindAddr bindPort = do (family, addr) <- getSockAddr bindPort bindAddr- sock <- socket family Stream 0+ sock <- socket family Stream 0+ debug $ "bindHttp: binding port " ++ show addr setSocketOption sock ReuseAddr 1 bindSocket sock addr listen sock 150+ debug $ "bindHttp: bound socket " ++ show sock- return $ ListenHttp sock+ return $! ListenHttp sock ------------------------------------------------------------------------------ createSession :: Int -> CInt -> IO () -> IO NetworkSession createSession buffSize s _ =- return $ NetworkSession s (unsafeCoerce ()) $ fromIntegral buffSize+ return $! NetworkSession s (unsafeCoerce ()) $ fromIntegral buffSize ------------------------------------------------------------------------------ endSession :: NetworkSession -> IO () endSession _ = return () -#ifdef PORTABLE +#ifdef PORTABLE ------------------------------------------------------------------------------ recv :: Socket -> IO () -> NetworkSession -> IO (Maybe ByteString) recv sock _ (NetworkSession { _recvLen = s }) = do bs <- SB.recv sock (fromIntegral s)- if B.null bs- then return Nothing- else return $ Just bs+ return $! if B.null bs then Nothing else Just bs ------------------------------------------------------------------------------ send :: Socket -> IO () -> IO () -> NetworkSession -> ByteString -> IO () send sock tickle _ _ bs = SB.sendAll sock bs >> tickle -#else +#else ------------------------------------------------------------------------------ recv :: IO () -> NetworkSession -> IO (Maybe ByteString) recv onBlock (NetworkSession s _ buffSize) = do@@ -84,23 +82,25 @@ if sz == 0 then return Nothing- else return $ Just $ BI.fromForeignPtr fp 0 $ fromEnum sz+ else return $! Just $! BI.fromForeignPtr fp 0 $! fromEnum sz ------------------------------------------------------------------------------ send :: IO () -> IO () -> NetworkSession -> ByteString -> IO () send tickleTimeout onBlock (NetworkSession s _ _) bs = BI.unsafeUseAsCStringLen bs $ uncurry loop- where loop ptr len = do- sent <- throwErrnoIfMinus1RetryMayBlock- "send"- (c_write s ptr $ toEnum len)- onBlock - let sent' = fromIntegral sent- if sent' < len- then tickleTimeout >> loop (plusPtr ptr sent') (len - sent')- else tickleTimeout+ where+ loop ptr len = do+ sent <- throwErrnoIfMinus1RetryMayBlock+ "send"+ (c_write s ptr $ toEnum len)+ onBlock++ let sent' = fromIntegral sent+ if sent' < len+ then tickleTimeout >> loop (plusPtr ptr sent') (len - sent')+ else tickleTimeout ------------------------------------------------------------------------------
src/Snap/Internal/Http/Server/LibevBackend.hs view
@@ -238,7 +238,7 @@ where go = runSession defaultTimeout back handler sock cleanup = [ Handler $ \(_ :: TimeoutException) -> return ()- , Handler $ \(e :: AsyncException) -> return ()+ , Handler $ \(_ :: AsyncException) -> return () , Handler $ \(e :: SomeException) -> elog $ S.concat [ "libev.acceptCallback: " , S.pack . map c2w $ show e ]@@ -570,24 +570,45 @@ -------------------------------------------------------------------------------tickleTimeout :: Connection -> Int -> IO ()-tickleTimeout conn tm = do- debug "Libev.tickleTimeout"- now <- getCurrentDateTime- prev <- readIORef ref- let !n = max (now + toEnum tm) prev- writeIORef ref n+modifyTimeout :: Connection -> (Int -> Int) -> IO ()+modifyTimeout conn f = do+ debug "Libev.modifyTimeout"+ !prev <- readIORef tt+ !now <- getCurrentDateTime + let !remaining = fromEnum $ max 0 (prev - now)+ let !newRemaining = f remaining+ let !newTimeout = now + toEnum newRemaining++ writeIORef tt $! now + toEnum newRemaining++ -- Here the question is: do we reset the ev timer? If we're extending the+ -- timeout, the ev manual suggests it's more efficient to let the timer+ -- lapse and re-arm. If we're shortening the timeout, we need to update the+ -- timer so it fires when it's supposed to.+ when (newTimeout < prev) $ withMVar loopLock $ \_ -> do+ evTimerSetRepeat tmr $! toEnum newRemaining+ evTimerAgain loop tmr+ -- wake up the event loop so it can be apprised of the changes+ evAsyncSend loop asyncObj+ where- ref = _timerTimeoutTime conn+ tt = _timerTimeoutTime conn+ backend = _backend conn+ asyncObj = _asyncObj backend+ loopLock = _loopLock backend+ loop = _evLoop backend+ tmr = _timerObj conn ------------------------------------------------------------------------------+tickleTimeout :: Connection -> Int -> IO ()+tickleTimeout conn = modifyTimeout conn . max+++------------------------------------------------------------------------------ setTimeout :: Connection -> Int -> IO ()-setTimeout conn tm = do- debug "Libev.tickleTimeout"- now <- getCurrentDateTime- writeIORef (_timerTimeoutTime conn) (now + toEnum tm)+setTimeout conn = modifyTimeout conn . const ------------------------------------------------------------------------------
src/Snap/Internal/Http/Server/ListenHelpers.hs view
@@ -14,13 +14,13 @@ ------------------------------------------------------------------------------ listenSocket :: ListenSocket -> Socket-listenSocket (ListenHttp s) = s+listenSocket (ListenHttp s ) = s listenSocket (ListenHttps s _) = s ------------------------------------------------------------------------------ isSecure :: ListenSocket -> Bool-isSecure (ListenHttp _) = False+isSecure (ListenHttp _ ) = False isSecure (ListenHttps _ _) = True @@ -31,52 +31,48 @@ ------------------------------------------------------------------------------ createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession-createSession (ListenHttp _) = Http.createSession-createSession p@(ListenHttps _ _) = TLS.createSession p+createSession (ListenHttp _ ) = Http.createSession+createSession p@(ListenHttps _ _) = TLS.createSession p ------------------------------------------------------------------------------ endSession :: ListenSocket -> NetworkSession -> IO ()-endSession (ListenHttp _) = Http.endSession-endSession (ListenHttps _ _) = TLS.endSession+endSession (ListenHttp _ ) = Http.endSession+endSession (ListenHttps _ _) = TLS.endSession #ifdef PORTABLE-- -- For portable builds, we can't call read/write directly so we need the -- original haskell socket to use with network-bytestring package. -- Only the simple backend creates sockets in haskell so the following -- functions only work with the simple backend. - ------------------------------------------------------------------------------ recv :: ListenSocket -> Socket -> IO () -> NetworkSession -> IO (Maybe ByteString)-recv (ListenHttp _) s = Http.recv s-recv (ListenHttps _ _) _ = TLS.recv+recv (ListenHttp _ ) s = Http.recv s+recv (ListenHttps _ _) _ = TLS.recv ------------------------------------------------------------------------------ send :: ListenSocket -> Socket -> IO () -> IO () -> NetworkSession -> ByteString -> IO ()-send (ListenHttp _) s = Http.send s-send (ListenHttps _ _) _ = TLS.send+send (ListenHttp _ ) s = Http.send s+send (ListenHttps _ _) _ = TLS.send #else - ------------------------------------------------------------------------------ recv :: ListenSocket -> IO () -> NetworkSession -> IO (Maybe ByteString)-recv (ListenHttp _) = Http.recv-recv (ListenHttps _ _) = TLS.recv+recv (ListenHttp _ ) = Http.recv+recv (ListenHttps _ _) = TLS.recv ------------------------------------------------------------------------------ send :: ListenSocket -> IO () -> IO () -> NetworkSession -> ByteString -> IO ()-send (ListenHttp _) = Http.send-send (ListenHttps _ _) = TLS.send+send (ListenHttp _ ) = Http.send+send (ListenHttps _ _) = TLS.send #endif
src/Snap/Internal/Http/Server/SimpleBackend.hs view
@@ -85,7 +85,7 @@ accThreads <- forM sockets $ \p -> forkOnIO cpu $ acceptThread defaultTimeout handler tmgr elog cpu p exit - return $ EventLoopCpu cpu accThreads tmgr exit+ return $! EventLoopCpu cpu accThreads tmgr exit ------------------------------------------------------------------------------@@ -110,6 +110,7 @@ acceptAndFork = do debug $ "acceptThread: calling accept() on socket " ++ show sock (s,addr) <- accept $ Listen.listenSocket sock+ setSocketOption s NoDelay 1 debug $ "acceptThread: accepted connection from remote: " ++ show addr _ <- forkOnIO cpu (go s addr `catches` cleanup) return ()@@ -120,7 +121,7 @@ go = runSession defaultTimeout handler tmgr sock - acceptHandler = + acceptHandler = [ Handler $ \(e :: AsyncException) -> throwIO e , Handler $ \(e :: SomeException) -> do elog $ S.concat [ "SimpleBackend.acceptThread: accept threw: "@@ -160,8 +161,8 @@ let sinfo = SessionInfo lhost lport rhost rport $ Listen.isSecure lsock timeoutHandle <- TM.register (killThread curId) tmgr- let setTimeout = TM.set timeoutHandle- let tickleTimeout = TM.tickle timeoutHandle+ let modifyTimeout = TM.modify timeoutHandle+ let tickleTimeout = modifyTimeout . max bracket (Listen.createSession lsock 8192 fd (threadWaitRead $ fromIntegral fd))@@ -182,7 +183,7 @@ writeEnd (sendFile lsock (tickleTimeout defaultTimeout) fd writeEnd)- setTimeout+ modifyTimeout )
src/Snap/Internal/Http/Server/TLS.hs view
@@ -1,10 +1,10 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} +------------------------------------------------------------------------------ module Snap.Internal.Http.Server.TLS ( TLSException , initTLS@@ -17,15 +17,12 @@ , send ) where - ------------------------------------------------------------------------------ import Control.Exception import Data.ByteString.Char8 (ByteString) import Data.Dynamic import Foreign.C--import Snap.Internal.Http.Server.Backend-+------------------------------------------------------------------------------ #ifdef OPENSSL import Control.Monad import qualified Data.ByteString.Char8 as S@@ -40,51 +37,73 @@ import OpenSSL import OpenSSL.Session import qualified OpenSSL.Session as SSL+import Prelude hiding (catch) import Unsafe.Coerce- import Snap.Internal.Http.Server.Address #endif+------------------------------------------------------------------------------+import Snap.Internal.Http.Server.Backend +------------------------------------------------------------------------------ data TLSException = TLSException String- deriving (Show, Typeable)+ deriving (Show, Typeable) instance Exception TLSException -#ifndef OPENSSL +#ifndef OPENSSL+------------------------------------------------------------------------------ initTLS :: IO () initTLS = throwIO $ TLSException "TLS is not supported" ++------------------------------------------------------------------------------ stopTLS :: IO () stopTLS = return () ++------------------------------------------------------------------------------ bindHttps :: ByteString -> Int -> FilePath -> FilePath -> IO ListenSocket bindHttps _ _ _ _ = throwIO $ TLSException "TLS is not supported" ++------------------------------------------------------------------------------ freePort :: ListenSocket -> IO () freePort _ = return () ++------------------------------------------------------------------------------ createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession createSession _ _ _ _ = throwIO $ TLSException "TLS is not supported" ++------------------------------------------------------------------------------ endSession :: NetworkSession -> IO () endSession _ = return () ++------------------------------------------------------------------------------ send :: IO () -> IO () -> NetworkSession -> ByteString -> IO () send _ _ _ _ = return () ++------------------------------------------------------------------------------ recv :: IO b -> NetworkSession -> IO (Maybe ByteString) recv _ _ = throwIO $ TLSException "TLS is not supported" --------------------------------------------------------------------------------#else +#else+------------------------------------------------------------------------------ initTLS :: IO () initTLS = withOpenSSL $ return () ++------------------------------------------------------------------------------ stopTLS :: IO () stopTLS = return () ++------------------------------------------------------------------------------ bindHttps :: ByteString -> Int -> FilePath@@ -92,44 +111,50 @@ -> IO ListenSocket bindHttps bindAddress bindPort cert key = do (family, addr) <- getSockAddr bindPort bindAddress- sock <- Socket.socket family Socket.Stream 0+ sock <- Socket.socket family Socket.Stream 0+ Socket.setSocketOption sock Socket.ReuseAddr 1 Socket.bindSocket sock addr Socket.listen sock 150 ctx <- context- contextSetPrivateKeyFile ctx key+ contextSetPrivateKeyFile ctx key contextSetCertificateFile ctx cert- contextSetDefaultCiphers ctx+ contextSetDefaultCiphers ctx+ certOK <- contextCheckPrivateKey ctx- when (not certOK) $ do- throwIO $ TLSException $ "OpenSSL says that the certificate "- ++ "doesn't match the private key!"+ when (not certOK) $ throwIO $ TLSException certificateError+ return $! ListenHttps sock ctx - return $ ListenHttps sock ctx+ where+ certificateError = "OpenSSL says that the certificate " +++ "doesn't match the private key!" +------------------------------------------------------------------------------ freePort :: ListenSocket -> IO () freePort (ListenHttps sock _) = Socket.sClose sock freePort _ = return () +------------------------------------------------------------------------------ createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession createSession (ListenHttps _ ctx) recvSize socket _ = do csock <- mkSocket socket AF_INET Stream defaultProtocol Connected- ssl <- connection ctx csock-- accept ssl- return $ NetworkSession socket (unsafeCoerce ssl) recvSize+ handle (\(e::SomeException) -> Socket.sClose csock >> throwIO e) $ do+ ssl <- connection ctx csock+ accept ssl+ return $! NetworkSession socket (unsafeCoerce ssl) recvSize createSession _ _ _ _ = error "can't call createSession on a ListenHttp" +------------------------------------------------------------------------------ endSession :: NetworkSession -> IO ()-endSession (NetworkSession _ aSSL _) = shutdown ssl Bidirectional- where- ssl = unsafeCoerce aSSL+endSession (NetworkSession _ aSSL _) =+ shutdown (unsafeCoerce aSSL) Unidirectional +------------------------------------------------------------------------------ send :: IO () -> IO () -> NetworkSession -> ByteString -> IO () send tickleTimeout _ (NetworkSession _ aSSL sz) bs = go bs where@@ -141,20 +166,19 @@ go !s = if S.null s then return () else do- SSL.write ssl a- tickleTimeout- go b-+ SSL.write ssl a+ tickleTimeout+ go b where (a,b) = S.splitAt sz s +------------------------------------------------------------------------------ recv :: IO b -> NetworkSession -> IO (Maybe ByteString) recv _ (NetworkSession _ aSSL recvLen) = do b <- SSL.read ssl recvLen- if S.null b then return Nothing else return $ Just b+ return $! if S.null b then Nothing else Just b where ssl = unsafeCoerce aSSL- #endif
src/Snap/Internal/Http/Server/TimeoutManager.hs view
@@ -8,6 +8,7 @@ , register , tickle , set+ , modify , cancel ) where @@ -21,8 +22,10 @@ ------------------------------------------------------------------------------ data State = Deadline !CTime | Canceled- deriving (Eq)+ deriving (Eq, Show) ++------------------------------------------------------------------------------ instance Ord State where compare Canceled Canceled = EQ compare Canceled _ = LT@@ -31,6 +34,43 @@ ------------------------------------------------------------------------------+-- Probably breaks Num laws, but I can live with it+--+instance Num State where+ --------------------------------------------------------------------------+ Canceled + Canceled = Canceled+ Canceled + x = x+ x + Canceled = x+ (Deadline a) + (Deadline b) = Deadline $! a + b++ --------------------------------------------------------------------------+ Canceled - Canceled = Canceled+ Canceled - x = negate x+ x - Canceled = x+ (Deadline a) - (Deadline b) = Deadline $! a - b++ --------------------------------------------------------------------------+ Canceled * _ = Canceled+ _ * Canceled = Canceled+ (Deadline a) * (Deadline b) = Deadline $! a * b++ --------------------------------------------------------------------------+ negate Canceled = Canceled+ negate (Deadline d) = Deadline (negate d)++ --------------------------------------------------------------------------+ abs Canceled = Canceled+ abs (Deadline d) = Deadline (abs d)++ --------------------------------------------------------------------------+ signum Canceled = Canceled+ signum (Deadline d) = Deadline (signum d)++ --------------------------------------------------------------------------+ fromInteger = Deadline . fromInteger+++------------------------------------------------------------------------------ data TimeoutHandle = TimeoutHandle { _killAction :: !(IO ()) , _state :: !(IORef State)@@ -39,6 +79,20 @@ ------------------------------------------------------------------------------+-- | Given a 'State' value and the current time, apply the given modification+-- function to the amount of time remaining.+--+smap :: CTime -> (Int -> Int) -> State -> State+smap _ _ Canceled = Canceled++smap now f (Deadline t) = Deadline t'+ where+ !remaining = fromEnum $ max 0 (t - now)+ !newremaining = f remaining+ !t' = now + toEnum newremaining+++------------------------------------------------------------------------------ data TimeoutManager = TimeoutManager { _defaultTimeout :: !Int , _getTime :: !(IO CTime)@@ -108,38 +162,37 @@ -- future. If the existing timeout is set for M seconds from now, where M > N, -- then the timeout is unaffected. tickle :: TimeoutHandle -> Int -> IO ()-tickle th n = do- now <- getTime-- -- don't need atomicity here -- kill the space leak.- orig <- readIORef stateRef- let state = Deadline $ now + toEnum n- let !newState = max orig state- writeIORef stateRef newState-- where- getTime = _hGetTime th- stateRef = _state th+tickle th = modify th . max+{-# INLINE tickle #-} ------------------------------------------------------------------------------ -- | Set the timeout on a connection to be N seconds into the future. set :: TimeoutHandle -> Int -> IO ()-set th n = do- now <- getTime+set th = modify th . const+{-# INLINE set #-} - let state = Deadline $ now + toEnum n- writeIORef stateRef state +------------------------------------------------------------------------------+-- | Modify the timeout with the given function.+modify :: TimeoutHandle -> (Int -> Int) -> IO ()+modify th f = do+ now <- getTime+ state <- readIORef stateRef+ let !state' = smap now f state+ writeIORef stateRef state'+ where getTime = _hGetTime th stateRef = _state th+{-# INLINE modify #-} ------------------------------------------------------------------------------ -- | Cancel a timeout. cancel :: TimeoutHandle -> IO () cancel h = writeIORef (_state h) Canceled+{-# INLINE cancel #-} ------------------------------------------------------------------------------
test/common/Snap/Test/Common.hs view
@@ -18,6 +18,7 @@ import Network.Socket import qualified Network.Socket.ByteString as N import Prelude hiding (catch)+import Test.HUnit (assertFailure) import Test.QuickCheck import System.Timeout @@ -31,10 +32,18 @@ arbitrary = do n <- choose(0,5) chunks <- replicateM n arbitrary- return $ L.fromChunks chunks+ return $! L.fromChunks chunks +expectException :: IO a -> IO ()+expectException m = do+ e <- try m+ case e of+ Left (_::SomeException) -> return ()+ Right _ -> assertFailure "expected exception, didn't get it"++ expectExceptionBeforeTimeout :: IO a -- ^ action to run -> Int -- ^ number of seconds to expect -- exception by@@ -71,7 +80,7 @@ recvAll :: Socket -> IO ByteString recvAll sock = do b <- f mempty sock- return $ toByteString b+ return $! toByteString b where f b sk = do
test/common/Test/Common/TestHandler.hs view
@@ -13,6 +13,7 @@ import qualified Data.Map as Map import Data.Maybe import Data.Monoid+import Snap.Internal.Debug import Snap.Iteratee hiding (Enumerator) import qualified Snap.Iteratee as I import Snap.Core@@ -31,29 +32,43 @@ timeoutTickleHandler = do noCompression -- FIXME: remove this when zlib-bindings and -- zlib-enumerator support gzip stream flushing- modifyResponse $ setResponseBody (trickleOutput 6)+ modifyResponse $ setResponseBody (trickleOutput 10) . setContentType "text/plain"+ . setBufferingMode False setTimeout 2 ++badTimeoutTickleHandler :: Snap ()+badTimeoutTickleHandler = do+ noCompression -- FIXME: remove this when zlib-bindings and+ -- zlib-enumerator support gzip stream flushing+ modifyResponse $ setResponseBody (trickleOutput 10)+ . setContentType "text/plain"+ setTimeout 2+++trickleOutput :: Int -> Enumerator Builder IO a+trickleOutput n = concatEnums $ dots `interleave` delays where- trickleOutput :: Int -> Enumerator Builder IO a- trickleOutput n = concatEnums $ dots `interleave` delays- where- enumOne = enumList 1 [fromByteString ".\n", flush]- delay st = do- liftIO $ threadDelay 1000000- returnI st+ enumOne i = do+ debug "enumOne: .\\n"+ enumList 1 [fromByteString ".\n"] i - interleave x0 y0 = (go id x0 y0) []- where- go !dl [] ys = dl . (++ys)- go !dl xs [] = dl . (++xs)- go !dl (x:xs) (y:ys) = go (dl . (x:) . (y:)) xs ys+ delay st = do+ debug "delay 1s"+ liftIO $ threadDelay 1000000+ returnI st - dots = replicate n enumOne- delays = replicate n delay+ interleave x0 y0 = (go id x0 y0) []+ where+ go !dl [] ys = dl . (++ys)+ go !dl xs [] = dl . (++xs)+ go !dl (x:xs) (y:ys) = go (dl . (x:) . (y:)) xs ys + dots = replicate n enumOne+ delays = replicate n delay + ------------------------------------------------------------------------------ pongHandler :: Snap () pongHandler = modifyResponse $@@ -148,8 +163,8 @@ modifyResponse $ setContentType "text/plain" writeBuilder $ buildRqParams params `mappend` buildFiles m- + builder _ [] = mempty builder ty ((k,v):xs) = mconcat [ fromByteString ty@@ -172,14 +187,15 @@ testHandler :: Snap () testHandler = withCompression $- route [ ("pong" , pongHandler )- , ("echo" , echoHandler )- , ("rot13" , rot13Handler )- , ("echoUri" , echoUriHandler )- , ("fileserve" , serveDirectory "testserver/static")- , ("bigresponse" , bigResponseHandler )- , ("respcode/:code" , responseHandler )- , ("upload/form" , uploadForm )- , ("upload/handle" , uploadHandler )- , ("timeout/tickle" , timeoutTickleHandler )+ route [ ("pong" , pongHandler )+ , ("echo" , echoHandler )+ , ("rot13" , rot13Handler )+ , ("echoUri" , echoUriHandler )+ , ("fileserve" , serveDirectory "testserver/static")+ , ("bigresponse" , bigResponseHandler )+ , ("respcode/:code" , responseHandler )+ , ("upload/form" , uploadForm )+ , ("upload/handle" , uploadHandler )+ , ("timeout/tickle" , timeoutTickleHandler )+ , ("timeout/badtickle" , badTimeoutTickleHandler ) ]
test/snap-server-testsuite.cabal view
@@ -21,42 +21,42 @@ main-is: TestSuite.hs build-depends:- QuickCheck >= 2,- array >= 0.3 && <0.4,- attoparsec >= 0.10 && < 0.11,- attoparsec-enumerator >= 0.3 && < 0.4,- base >= 4 && < 5,- base16-bytestring == 0.1.*,- binary >= 0.5 && < 0.6,- blaze-builder >= 0.2.1.4 && <0.4,- blaze-builder-enumerator >= 0.2.0 && <0.3,+ QuickCheck >= 2,+ array >= 0.3 && <0.5,+ attoparsec >= 0.10 && <0.11,+ attoparsec-enumerator >= 0.3 && <0.4,+ base >= 4 && <5,+ base16-bytestring == 0.1.*,+ binary >= 0.5 && <0.6,+ blaze-builder >= 0.2.1.4 && <0.4,+ blaze-builder-enumerator >= 0.2.0 && <0.3, bytestring,- bytestring-nums >= 0.3.1 && < 0.4,+ bytestring-nums >= 0.3.1 && <0.4, containers, directory, directory-tree,- enumerator >= 0.4.13.1 && <0.5,+ enumerator >= 0.4.15 && <0.5, filepath,- http-enumerator >= 0.7.1.6 && <0.8,- HUnit >= 1.2 && < 2,- mtl >= 2 && <3,- murmur-hash >= 0.1 && < 0.2,- network == 2.3.*,+ http-enumerator >= 0.7.1.6 && <0.8,+ HUnit >= 1.2 && <2,+ mtl >= 2 && <3,+ murmur-hash >= 0.1 && <0.2,+ network == 2.3.*, old-locale,- parallel > 2,+ parallel >= 2 && <4, process,- snap-core >= 0.7 && < 0.8,+ snap-core >= 0.8 && <0.9, template-haskell,- 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,+ 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,- tls >= 0.8.2 && <0.9,+ tls >= 0.8.2 && <0.10, transformers,- vector >= 0.7 && <0.10,- vector-algorithms >= 0.4 && <0.6,- PSQueue >= 1.1 && <1.2+ vector >= 0.7 && <0.10,+ vector-algorithms >= 0.4 && <0.6,+ PSQueue >= 1.1 && <1.2 extensions: BangPatterns,@@ -97,37 +97,37 @@ main-is: Main.hs build-depends:- QuickCheck >= 2,- array >= 0.3 && <0.4,- attoparsec >= 0.10 && < 0.11,- attoparsec-enumerator >= 0.3 && < 0.4,- base >= 4 && < 5,- base16-bytestring == 0.1.*,- blaze-builder >= 0.2.1.4 && <0.4,- blaze-builder-enumerator >= 0.2.0 && <0.3,+ QuickCheck >= 2,+ array >= 0.3 && <0.5,+ attoparsec >= 0.10 && <0.11,+ attoparsec-enumerator >= 0.3 && <0.4,+ base >= 4 && <5,+ base16-bytestring == 0.1.*,+ blaze-builder >= 0.2.1.4 && <0.4,+ blaze-builder-enumerator >= 0.2.0 && <0.3, bytestring,- bytestring-nums >= 0.3.1 && < 0.4,- cereal >= 0.3 && < 0.4,+ bytestring-nums >= 0.3.1 && <0.4,+ cereal >= 0.3 && <0.4, containers, directory-tree,- enumerator >= 0.4.7 && <0.5,+ enumerator >= 0.4.15 && <0.5, filepath,- HUnit >= 1.2 && < 2,- mtl >= 2 && <3,- murmur-hash >= 0.1 && < 0.2,+ HUnit >= 1.2 && <2,+ mtl >= 2 && <3,+ murmur-hash >= 0.1 && <0.2, old-locale,- parallel > 2,- MonadCatchIO-transformers >= 0.2.1 && < 0.3,- network == 2.3.*,- snap-core >= 0.7 && < 0.8,+ parallel >= 2 && <4,+ MonadCatchIO-transformers >= 0.2.1 && <0.3,+ network == 2.3.*,+ snap-core >= 0.8 && <0.9, template-haskell, time, transformers,- unix-compat >= 0.2 && <0.4,- utf8-string >= 0.3.6 && <0.4,- vector >= 0.7 && <0.10,- vector-algorithms >= 0.4 && <0.6,- PSQueue >= 1.1 && <1.2+ unix-compat >= 0.2 && <0.4,+ utf8-string >= 0.3.6 && <0.4,+ vector >= 0.7 && <0.10,+ vector-algorithms >= 0.4 && <0.6,+ PSQueue >= 1.1 && <1.2 if flag(portable) || os(windows) cpp-options: -DPORTABLE@@ -173,38 +173,38 @@ main-is: Main.hs build-depends:- QuickCheck >= 2,- array >= 0.3 && <0.4,- attoparsec >= 0.10 && < 0.11,- attoparsec-enumerator >= 0.3 && < 0.4,- base >= 4 && < 5,- binary >= 0.5 && < 0.6,- blaze-builder >= 0.2.1.4 && <0.4,- blaze-builder-enumerator >= 0.2.0 && <0.3,+ QuickCheck >= 2,+ array >= 0.3 && <0.5,+ attoparsec >= 0.10 && <0.11,+ attoparsec-enumerator >= 0.3 && <0.4,+ base >= 4 && <5,+ binary >= 0.5 && <0.6,+ blaze-builder >= 0.2.1.4 && <0.4,+ blaze-builder-enumerator >= 0.2.0 && <0.3, bytestring,- bytestring-nums >= 0.3.1 && < 0.4,- case-insensitive >= 0.3 && < 0.5,+ bytestring-nums >= 0.3.1 && <0.4,+ case-insensitive >= 0.3 && <0.5, containers, directory-tree,- enumerator >= 0.4.7 && <0.5,+ enumerator >= 0.4.15 && <0.5, filepath,- HUnit >= 1.2 && < 2,- MonadCatchIO-transformers >= 0.2.1 && < 0.3,- mtl >= 2 && <3,- murmur-hash >= 0.1 && < 0.2,- network == 2.3.*,+ HUnit >= 1.2 && <2,+ MonadCatchIO-transformers >= 0.2.1 && <0.3,+ mtl >= 2 && <3,+ murmur-hash >= 0.1 && <0.2,+ network == 2.3.*, old-locale,- parallel > 2,- snap-core >= 0.7 && < 0.8,+ parallel >= 2 && <4,+ snap-core >= 0.8 && <0.9, template-haskell,- 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,+ 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,- vector >= 0.7 && <0.10,- vector-algorithms >= 0.4 && <0.6,- PSQueue >= 1.1 && <1.2+ vector >= 0.7 && <0.10,+ vector-algorithms >= 0.4 && <0.6,+ PSQueue >= 1.1 && <1.2 if !os(windows) build-depends: unix@@ -240,5 +240,5 @@ base >= 4 && < 5, network == 2.3.*, http-enumerator >= 0.7.1.6 && <0.8,- tls >= 0.8.2 && <0.9,- criterion >= 0.5 && <0.6+ tls >= 0.8.2 && <0.10,+ criterion >= 0.6 && <0.7
test/suite/Snap/Internal/Http/Server/Tests.hs view
@@ -195,8 +195,8 @@ assertEqual "parse body" "0123456789" body - assertEqual "cookie" - [Cookie "foo" "bar\"" Nothing Nothing Nothing False False] + assertEqual "cookie"+ [Cookie "foo" "bar\"" Nothing Nothing Nothing False False] (rqCookies req) assertEqual "continued headers" (Just ["foo bar"]) $@@ -262,14 +262,7 @@ sampleShortRequest :: ByteString sampleShortRequest = "GET /fo" -expectException :: IO a -> IO ()-expectException m = do- e <- try m- case e of- Left (_::SomeException) -> return ()- Right _ -> assertFailure "expected exception, didn't get it" - testPartialParse :: Test testPartialParse = testCase "server/short" $ do step <- runIteratee $ liftM fromJust $ rsm $ receiveRequest dummyIter@@ -394,14 +387,21 @@ sendResponse req rsp1 buf copyingStream2Stream testOnSendFile >>= return . snd - assertEqual "http response" (L.concat [- "HTTP/1.0 600 Test\r\n"- , "Content-Length: 10\r\n"- , "Foo: Bar\r\n\r\n"- , "0123456789"- ]) b+ assertBool "http response" (b == text1 || b == text2) where+ text1 = L.concat [ "HTTP/1.0 600 Test\r\n"+ , "Content-Length: 10\r\n"+ , "Foo: Bar\r\n\r\n"+ , "0123456789"+ ]++ text2 = L.concat [ "HTTP/1.0 600 Test\r\n"+ , "Foo: Bar\r\n"+ , "Content-Length: 10\r\n\r\n"+ , "0123456789"+ ]+ rsp1 = updateHeaders (H.insert "Foo" "Bar") $ setContentLength 10 $ setResponseStatus 600 "Test" $@@ -554,16 +554,16 @@ ch Nothing = False ch (Just l) =- sort l == [ + sort l == [ "ck1=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com; Secure\r" , "ck2=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com; HttpOnly\r" , "ck3=bar\r" ] - + rsp1 = setResponseStatus 304 "Test" $ emptyResponse { rspHttpVersion = (1,0) }- rsp2 = addResponseCookie cook3 . addResponseCookie cook2 + rsp2 = addResponseCookie cook3 . addResponseCookie cook2 . addResponseCookie cook $ rsp1 utc = UTCTime (ModifiedJulianDay 55226) 0@@ -574,7 +574,7 @@ echoServer :: (ByteString -> IO ())- -> (Int -> IO ())+ -> ((Int -> Int) -> IO ()) -> Request -> Iteratee ByteString IO (Request,Response) echoServer _ _ req = do
test/suite/Test/Blackbox.hs view
@@ -58,6 +58,7 @@ , testPartial , testFileUpload , testTimeoutTickle+ , testTimeoutBadTickle ] @@ -414,8 +415,8 @@ req <- parseURL url `catch` (\(e::SomeException) -> do debug $ "parseURL threw exception: " ++ show e throwIO e)- fetchReq $ req { HTTP.requestBody = HTTP.RequestBodyLBS body- , HTTP.method = "POST"+ fetchReq $ req { HTTP.requestBody = HTTP.RequestBodyLBS body+ , HTTP.method = "POST" , HTTP.requestHeaders = hdrs } @@ -430,5 +431,14 @@ let uri = (if ssl then "https" else "http") ++ "://127.0.0.1:" ++ show port ++ "/timeout/tickle" doc <- liftM (S.concat . L.toChunks) $ fetch uri- let expected = S.concat $ replicate 6 ".\n"+ let expected = S.concat $ replicate 10 ".\n" assertEqual "response equal" expected doc+++------------------------------------------------------------------------------+testTimeoutBadTickle :: Bool -> Int -> String -> Test+testTimeoutBadTickle ssl port name =+ testCase (name ++ "/blackbox/timeout/badtickle") $ do+ let uri = (if ssl then "https" else "http")+ ++ "://127.0.0.1:" ++ show port ++ "/timeout/badtickle"+ expectException $ fetch uri