snap-server 0.5.5 → 0.6.0
raw patch · 20 files changed
+378/−323 lines, 20 filesdep ~bytestringdep ~case-insensitivedep ~containers
Dependency ranges changed: bytestring, case-insensitive, containers, directory-tree, filepath, mtl, snap-core, template-haskell, transformers
Files
- CONTRIBUTORS +2/−0
- README.SNAP.md +5/−5
- snap-server.cabal +27/−27
- src/Snap/Http/Server.hs +37/−12
- src/Snap/Http/Server/Config.hs +49/−23
- src/Snap/Internal/Http/Parser.hs +1/−58
- src/Snap/Internal/Http/Server.hs +48/−69
- src/Snap/Internal/Http/Server/Address.hs +5/−5
- src/Snap/Internal/Http/Server/HttpPort.hs +2/−1
- src/Snap/Internal/Http/Server/LibevBackend.hs +2/−1
- src/Snap/Internal/Http/Server/SimpleBackend.hs +2/−2
- src/Snap/Internal/Http/Server/TLS.hs +0/−1
- src/Snap/Internal/Http/Server/TimeoutManager.hs +3/−3
- src/System/FastLogger.hs +2/−2
- test/common/Test/Common/TestHandler.hs +11/−11
- test/pongserver/Main.hs +3/−3
- test/snap-server-testsuite.cabal +8/−8
- test/suite/Snap/Internal/Http/Parser/Tests.hs +2/−4
- test/suite/Snap/Internal/Http/Server/Tests.hs +165/−86
- test/suite/Test/Blackbox.hs +4/−2
CONTRIBUTORS view
@@ -3,5 +3,7 @@ Shu-yu Guo <shu@rfrn.org> Carl Howells <chowells79@gmail.com> John Lenz <jlenz2@math.uiuc.edu>+Herbert Valerio Riedel <hvriedel@gmail.com> James Sanders <jimmyjazz14@gmail.com> Jacob Stanley <jacob@stanley.io>+Jurriën Stutterheim <j.stutterheim@me.com>
README.SNAP.md view
@@ -16,11 +16,11 @@ * a sensible and clean monad for web programming - * an xml-based templating system for generating HTML based on- [expat](http://expat.sourceforge.net/) (via- [hexpat](http://hackage.haskell.org/package/hexpat)) that allows you to- bind Haskell functionality to XML tags without getting PHP-style tag soup- all over your pants+ * an xml-based templating system for generating HTML that allows you to bind+ Haskell functionality to XML tags without getting PHP-style tag soup all+ over your pants++ * a "snaplet" system for building web sites from composable pieces. Snap is currently only officially supported on Unix platforms; it has been tested on Linux and Mac OSX Snow Leopard, and is reported to work on Windows.
snap-server.cabal view
@@ -1,5 +1,5 @@ name: snap-server-version: 0.5.5+version: 0.6.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@@ -99,34 +99,34 @@ Snap.Internal.Http.Server.LibevBackend build-depends:- array >= 0.2 && <0.4,- attoparsec >= 0.8.1 && < 0.10,- attoparsec-enumerator >= 0.2.0.1 && < 0.3,- 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,+ array >= 0.2 && <0.4,+ attoparsec >= 0.8.1 && < 0.10,+ attoparsec-enumerator >= 0.2.0.1 && < 0.3,+ 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 >= 0.9.1 && < 0.10, bytestring-nums,- case-insensitive >= 0.2 && < 0.4,- containers,- directory-tree,- enumerator >= 0.4.13.1 && <0.5,- filepath,- MonadCatchIO-transformers >= 0.2.1 && < 0.3,- mtl == 2.0.*,- murmur-hash >= 0.1 && < 0.2,- network >= 2.3 && <2.4,+ case-insensitive >= 0.3 && < 0.4,+ containers >= 0.3 && < 0.5,+ directory-tree >= 0.10 && < 0.11,+ enumerator >= 0.4.13.1 && < 0.5,+ filepath >= 1.1 && < 1.3,+ 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.5.4 && <0.6,- template-haskell,- text >= 0.11 && <0.12,- time >= 1.0 && < 1.4,- transformers,- unix-compat >= 0.2 && <0.4,- vector >= 0.7 && <0.10,- vector-algorithms >= 0.4 && <0.6,- PSQueue >= 1.1 && <1.2+ snap-core >= 0.6 && < 0.7,+ template-haskell >= 2.2 && < 2.7,+ text >= 0.11 && < 0.12,+ time >= 1.0 && < 1.4,+ transformers >= 0.2 && < 0.3,+ unix-compat >= 0.2 && < 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
src/Snap/Http/Server.hs view
@@ -19,22 +19,25 @@ , module Snap.Http.Server.Config ) where +import Control.Applicative+import Control.Concurrent (newMVar, withMVar) import Control.Monad import Control.Monad.CatchIO import Data.ByteString (ByteString)+import qualified Data.ByteString as BS import Data.Char import Data.List import Data.Maybe import Prelude hiding (catch) import Snap.Http.Server.Config import qualified Snap.Internal.Http.Server as Int-import Snap.Types+import Snap.Core import Snap.Util.GZip #ifndef PORTABLE import System.Posix.Env #endif import System.IO-+import System.FastLogger ------------------------------------------------------------------------------ -- | A short string describing the Snap server version@@ -46,10 +49,10 @@ -- | 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 the--- error handler; this allows it to be used from 'MonadSnap'.+-- This function is like 'httpServe' except it doesn't setup compression or+-- the error handler; this allows it to be used from 'MonadSnap'. simpleHttpServe :: MonadSnap m => Config m a -> Snap () -> IO ()-simpleHttpServe config handler = do +simpleHttpServe config handler = do conf <- completeConfig config let output = when (fromJust $ getVerbose conf) . hPutStrLn stderr mapM_ (output . ("Listening on "++) . show) $ listeners conf@@ -59,13 +62,35 @@ go conf = do let tout = fromMaybe 60 $ getDefaultTimeout conf setUnicodeLocale $ fromJust $ getLocale conf- Int.httpServe tout- (listeners conf)- (fmap backendToInternal $ getBackend conf)- (fromJust $ getHostname conf)- (fromJust $ getAccessLog conf)- (fromJust $ getErrorLog conf)- (runSnap handler)+ withLoggers (fromJust $ getAccessLog conf)+ (fromJust $ getErrorLog conf) $+ \(alog, elog) -> Int.httpServe tout+ (listeners conf)+ (fmap backendToInternal $ getBackend conf)+ (fromJust $ getHostname conf)+ alog+ elog+ (runSnap handler)++ maybeSpawnLogger f (ConfigFileLog fp) =+ liftM Just $ newLoggerWithCustomErrorFunction f fp+ maybeSpawnLogger _ _ = return Nothing++ maybeIoLog (ConfigIoLog a) = Just a+ maybeIoLog _ = Nothing++ withLoggers afp efp act =+ bracket (do mvar <- newMVar ()+ let f s = withMVar mvar+ (const $ BS.hPutStr stderr s >> hFlush stderr)+ alog <- maybeSpawnLogger f afp+ elog <- maybeSpawnLogger f efp+ return (alog, elog))+ (\(alog, elog) -> do+ maybe (return ()) stopLogger alog+ maybe (return ()) stopLogger elog)+ (\(alog, elog) -> act ( liftM logMsg alog <|> maybeIoLog afp+ , liftM logMsg elog <|> maybeIoLog efp)) {-# INLINE simpleHttpServe #-}
src/Snap/Http/Server/Config.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} {-| @@ -11,6 +12,7 @@ module Snap.Http.Server.Config ( Config , ConfigBackend(..)+ , ConfigLog(..) , emptyConfig , defaultConfig@@ -66,8 +68,9 @@ import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Encoding as T+import Data.Typeable import Prelude hiding (catch)-import Snap.Types+import Snap.Core import Snap.Iteratee ((>==>), enumBuilder) import Snap.Internal.Debug (debug) import System.Console.GetOpt@@ -94,6 +97,17 @@ deriving (Show, Eq) ------------------------------------------------------------------------------+-- | Data type representing the configuration of a logging target+data ConfigLog = ConfigNoLog -- ^ no logging+ | ConfigFileLog FilePath -- ^ log to text file+ | ConfigIoLog (ByteString -> IO ()) -- ^ log custom IO handler++instance Show ConfigLog where+ show ConfigNoLog = "ConfigNoLog"+ show (ConfigFileLog f) = "ConfigFileLog " ++ show f+ show (ConfigIoLog _) = "ConfigIoLog"++------------------------------------------------------------------------------ -- | A record type which represents partial configurations (for 'httpServe') -- by wrapping all of its fields in a 'Maybe'. Values of this type are usually -- constructed via its 'Monoid' instance by doing something like:@@ -104,8 +118,8 @@ -- this is the norm) are filled in with default values from 'defaultConfig'. data Config m a = Config { hostname :: Maybe ByteString- , accessLog :: Maybe (Maybe FilePath)- , errorLog :: Maybe (Maybe FilePath)+ , accessLog :: Maybe ConfigLog+ , errorLog :: Maybe ConfigLog , locale :: Maybe String , port :: Maybe Int , bind :: Maybe ByteString@@ -207,12 +221,23 @@ ------------------------------------------------------------------------------+-- | The 'Typeable1' instance is here so 'Config' values can be+-- dynamically loaded with Hint.+configTyCon :: TyCon+configTyCon = mkTyCon "Snap.Http.Server.Config.Config"+{-# NOINLINE configTyCon #-}++instance (Typeable1 m) => Typeable1 (Config m) where+ typeOf1 _ = mkTyConApp configTyCon [typeOf1 (undefined :: m ())]+++------------------------------------------------------------------------------ -- | These are the default values for the options defaultConfig :: MonadSnap m => Config m a defaultConfig = mempty { hostname = Just "localhost"- , accessLog = Just $ Just "log/access.log"- , errorLog = Just $ Just "log/error.log"+ , accessLog = Just $ ConfigFileLog "log/access.log"+ , errorLog = Just $ ConfigFileLog "log/error.log" , locale = Just "en_US" , compression = Just True , verbose = Just True@@ -231,11 +256,11 @@ getHostname = hostname -- | Path to the access log-getAccessLog :: Config m a -> Maybe (Maybe FilePath)+getAccessLog :: Config m a -> Maybe ConfigLog getAccessLog = accessLog -- | Path to the error log-getErrorLog :: Config m a -> Maybe (Maybe FilePath)+getErrorLog :: Config m a -> Maybe ConfigLog getErrorLog = errorLog -- | The locale to use@@ -292,10 +317,10 @@ setHostname :: ByteString -> Config m a -> Config m a setHostname x c = c { hostname = Just x } -setAccessLog :: (Maybe FilePath) -> Config m a -> Config m a+setAccessLog :: ConfigLog -> Config m a -> Config m a setAccessLog x c = c { accessLog = Just x } -setErrorLog :: (Maybe FilePath) -> Config m a -> Config m a+setErrorLog :: ConfigLog -> Config m a -> Config m a setErrorLog x c = c { errorLog = Just x } setLocale :: String -> Config m a -> Config m a@@ -341,7 +366,8 @@ ------------------------------------------------------------------------------ completeConfig :: (MonadSnap m) => Config m a -> IO (Config m a) completeConfig config = do- when noPort $ hPutStrLn stderr "no port specified, defaulting to port 8000"+ when noPort $ hPutStrLn stderr+ "no port specified, defaulting to port 8000" return $ cfg `mappend` cfg' @@ -398,16 +424,16 @@ (ReqArg (\s -> Just $ mempty { sslkey = Just s}) "PATH") $ "path to ssl private key in PEM format" ++ defaultO sslkey , Option [] ["access-log"]- (ReqArg (Just . setConfig setAccessLog . Just) "PATH")- $ "access log" ++ (defaultC $ join . getAccessLog)+ (ReqArg (Just . setConfig setAccessLog . ConfigFileLog) "PATH")+ $ "access log" ++ (defaultC $ getAccessLog) , Option [] ["error-log"]- (ReqArg (Just . setConfig setErrorLog . Just) "PATH")- $ "error log" ++ (defaultC $ join . getErrorLog)+ (ReqArg (Just . setConfig setErrorLog . ConfigFileLog) "PATH")+ $ "error log" ++ (defaultC $ getErrorLog) , Option [] ["no-access-log"]- (NoArg $ Just $ setConfig setAccessLog Nothing)+ (NoArg $ Just $ setConfig setAccessLog ConfigNoLog) $ "don't have an access log" , Option [] ["no-error-log"]- (NoArg $ Just $ setConfig setErrorLog Nothing)+ (NoArg $ Just $ setConfig setErrorLog ConfigNoLog) $ "don't have an error log" , Option ['c'] ["compression"] (NoArg $ Just $ setConfig setCompression True)@@ -445,7 +471,7 @@ let sm = smsg req debug $ toString sm logError sm- + finishWith $ setContentType "text/plain; charset=utf-8" . setContentLength (fromIntegral $ B.length msg) . setResponseStatus 500 "Internal Server Error"@@ -468,12 +494,12 @@ -- command-line. -- -- On Unix systems, the locale is read from the @LANG@ environment variable.-commandLineConfig :: MonadSnap m =>- Config m a -- ^ default configuration. This is combined- -- with 'defaultConfig' to obtain default- -- values to use if the given parameter is not- -- specified on the command line. Usually it is- -- fine to use 'emptyConfig' here.+commandLineConfig :: MonadSnap m+ => Config m a+ -- ^ default configuration. This is combined with+ -- 'defaultConfig' to obtain default values to use if the+ -- given parameter is specified on the command line. Usually+ -- it is fine to use 'emptyConfig' here. -> IO (Config m a) commandLineConfig defaults = do args <- getArgs
src/Snap/Internal/Http/Parser.hs view
@@ -18,7 +18,6 @@ -------------------------------------------------------------------------------import Control.Arrow (second) import Control.Exception import Control.Monad (liftM) import Control.Monad.Trans@@ -31,16 +30,11 @@ import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Nums.Careless.Hex as Cvt import Data.Char-import Data.List (foldl') import Data.Int-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe (catMaybes) import Data.Typeable import Prelude hiding (head, take, takeWhile) ---------------------------------------------------------------------------- import Snap.Internal.Http.Types-import Snap.Internal.Debug import Snap.Internal.Iteratee.Debug import Snap.Internal.Parsing hiding (pHeaders) import Snap.Iteratee hiding (map, take)@@ -177,7 +171,7 @@ methodFromString "TRACE" = return TRACE methodFromString "OPTIONS" = return OPTIONS methodFromString "CONNECT" = return CONNECT-methodFromString s = +methodFromString s = throwError $ HttpParseException $ "Bad method '" ++ S.unpack s ++ "'" @@ -225,54 +219,3 @@ where fromHex :: ByteString -> Int fromHex s = Cvt.hex (L.fromChunks [s])------------------------------------------------------------------------------------ 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-- where- toCookie (nm,val) = Cookie nm val Nothing Nothing Nothing----------------------------------------------------------------------------------parseCookie :: ByteString -> Maybe [Cookie]-parseCookie = parseToCompletion pCookies------------------------------------------------------------------------------------ application/x-www-form-urlencoded----------------------------------------------------------------------------------------------------------------------------------------------------------------parseUrlEncoded :: ByteString -> Map ByteString [ByteString]-parseUrlEncoded s = foldl' (\m (k,v) -> Map.insertWith' (++) k [v] m)- Map.empty- decoded- where- breakApart = (second (S.drop 1)) . S.break (== '=')-- parts :: [(ByteString,ByteString)]- parts = map breakApart $ S.splitWith (\c -> c == '&' || c == ';') s-- urldecode = parseToCompletion pUrlEscaped-- decodeOne (a,b) = do- a' <- urldecode a- b' <- urldecode b- return (a',b')-- decoded = catMaybes $ map decodeOne parts--
src/Snap/Internal/Http/Server.hs view
@@ -13,7 +13,6 @@ import Blaze.ByteString.Builder.Enumerator import Blaze.ByteString.Builder.HTTP import Control.Arrow (first, second)-import Control.Concurrent (newMVar) import Control.Monad.CatchIO hiding ( bracket , catches , finally@@ -22,7 +21,6 @@ import Control.Monad.State.Strict import Control.Exception hiding (catch, throw) import Data.Char-import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Data.ByteString (ByteString) import qualified Data.ByteString as S@@ -33,7 +31,6 @@ import Data.Int import Data.IORef import Data.List (foldl')-import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (catMaybes, fromJust, fromMaybe) import Data.Monoid@@ -43,12 +40,11 @@ import GHC.Conc import Network.Socket (withSocketsDo) import Prelude hiding (catch)-import System.IO import System.PosixCompat.Files hiding (setFileSize) import System.Posix.Types (FileOffset) import System.Locale -------------------------------------------------------------------------------import System.FastLogger+import System.FastLogger (timestampedLogEntry, combinedLogEntry) import Snap.Internal.Http.Types import Snap.Internal.Debug import Snap.Internal.Http.Parser@@ -64,6 +60,9 @@ import Snap.Iteratee hiding (head, take, map) import qualified Snap.Iteratee as I +import Snap.Types.Headers (Headers)+import qualified Snap.Types.Headers as H+ import qualified Paths_snap_server as V @@ -156,19 +155,17 @@ -------------------------------------------------------------------------------httpServe :: Int -- ^ default timeout- -> [ListenPort] -- ^ ports to listen on- -> Maybe EventLoopType -- ^ Specify a given event loop,- -- otherwise a default is picked- -> ByteString -- ^ local hostname (server name)- -> Maybe FilePath -- ^ path to the access log- -> Maybe FilePath -- ^ path to the error log- -> ServerHandler -- ^ handler procedure+httpServe :: Int -- ^ default timeout+ -> [ListenPort] -- ^ ports to listen on+ -> Maybe EventLoopType -- ^ Specify a given event loop,+ -- otherwise a default is picked+ -> ByteString -- ^ local hostname (server name)+ -> Maybe (ByteString -> IO ()) -- ^ access log action+ -> Maybe (ByteString -> IO ()) -- ^ error log action+ -> ServerHandler -- ^ handler procedure -> IO ()-httpServe defaultTimeout ports mevType localHostname alogPath elogPath- handler =- withSocketsDo $ withLoggers alogPath elogPath $ uncurry spawnAll-+httpServe defaultTimeout ports mevType localHostname alog' elog'+ handler = withSocketsDo $ spawnAll alog' elog' where -------------------------------------------------------------------------- spawnAll alog elog = {-# SCC "httpServe/spawnAll" #-} do@@ -209,38 +206,19 @@ runEventLoop EventLoopLibEv = libEvEventLoop - --------------------------------------------------------------------------- maybeSpawnLogger f =- maybe (return Nothing)- ((liftM Just) . newLoggerWithCustomErrorFunction f)--- --------------------------------------------------------------------------- withLoggers afp efp =- bracket (do mvar <- newMVar ()- let f s = withMVar mvar- (const $ S.hPutStr stderr s >> hFlush stderr)- alog <- maybeSpawnLogger f afp- elog <- maybeSpawnLogger f efp- return (alog, elog))- (\(alog, elog) -> do- maybe (return ()) stopLogger alog- maybe (return ()) stopLogger elog)-- ------------------------------------------------------------------------------ debugE :: (MonadIO m) => ByteString -> m () debugE s = debug $ "Server: " ++ (map w2c $ S.unpack s) -------------------------------------------------------------------------------logE :: Maybe Logger -> ByteString -> IO ()+logE :: Maybe (ByteString -> IO ()) -> ByteString -> IO () logE elog = maybe debugE (\l s -> debugE s >> logE' l s) elog -------------------------------------------------------------------------------logE' :: Logger -> ByteString -> IO ()-logE' logger s = (timestampedLogEntry s) >>= logMsg logger+logE' :: (ByteString -> IO ()) -> ByteString -> IO ()+logE' logger s = (timestampedLogEntry s) >>= logger ------------------------------------------------------------------------------@@ -249,12 +227,12 @@ -------------------------------------------------------------------------------logA ::Maybe Logger -> Request -> Response -> IO ()+logA :: Maybe (ByteString -> IO ()) -> Request -> Response -> IO () logA alog = maybe (\_ _ -> return ()) logA' alog -------------------------------------------------------------------------------logA' :: Logger -> Request -> Response -> IO ()+logA' :: (ByteString -> IO ()) -> Request -> Response -> IO () logA' logger req rsp = do let hdrs = rqHeaders req let host = rqRemoteAddr req@@ -265,17 +243,17 @@ let reql = S.intercalate " " [ method, rqURI req, ver ] let status = rspStatus rsp let cl = rspContentLength rsp- let referer = maybe Nothing (Just . head) $ Map.lookup "referer" hdrs- let userAgent = maybe "-" head $ Map.lookup "user-agent" hdrs+ let referer = maybe Nothing (Just . head) $ H.lookup "referer" hdrs+ let userAgent = maybe "-" head $ H.lookup "user-agent" hdrs msg <- combinedLogEntry host user reql status cl referer userAgent- logMsg logger msg+ logger msg ------------------------------------------------------------------------------ runHTTP :: Int -- ^ default timeout- -> Maybe Logger -- ^ access logger- -> Maybe Logger -- ^ error logger+ -> Maybe (ByteString -> IO ()) -- ^ access logger+ -> Maybe (ByteString -> IO ()) -- ^ error logger -> ServerHandler -- ^ handler procedure -> ByteString -- ^ local host name -> SessionInfo -- ^ session port information@@ -341,8 +319,8 @@ -------------------------------------------------------------------------------sERVER_HEADER :: [ByteString]-sERVER_HEADER = [S.concat ["Snap/", snapServerVersion]]+sERVER_HEADER :: ByteString+sERVER_HEADER = S.concat ["Snap/", snapServerVersion] ------------------------------------------------------------------------------@@ -426,8 +404,8 @@ "sending response" date <- liftIO getDateString- let ins = Map.insert "Date" [date] .- Map.insert "Server" sERVER_HEADER+ let ins = H.set "Date" date .+ H.set "Server" sERVER_HEADER let rsp' = updateHeaders ins rsp (bytesSent,_) <- sendResponse req rsp' buffer writeEnd onSendFile `catch` errCatch "sending response" req@@ -550,7 +528,7 @@ where isChunked = maybe False ((== ["chunked"]) . map CI.mk)- (Map.lookup "transfer-encoding" hdrs)+ (H.lookup "transfer-encoding" hdrs) hasContentLength :: Int64 -> ServerMonad () hasContentLength len = do@@ -584,7 +562,7 @@ hdrs = rqHeaders req- mbCL = Map.lookup "content-length" hdrs >>= return . Cvt.int . head+ mbCL = H.lookup "content-length" hdrs >>= return . Cvt.int . head --------------------------------------------------------------------------@@ -592,7 +570,7 @@ parseForm req = {-# SCC "receiveRequest/parseForm" #-} if doIt then getIt else return req where- mbCT = liftM head $ Map.lookup "content-type" (rqHeaders req)+ mbCT = liftM head $ H.lookup "content-type" (rqHeaders req) trimIt = fst . SC.spanEnd isSpace . SC.takeWhile (/= ';') . SC.dropWhile isSpace mbCT' = liftM trimIt mbCT@@ -624,7 +602,8 @@ e st' liftIO $ writeIORef (rqBody req) $ SomeEnumerator e'- return $ req { rqParams = rqParams req `mappend` newParams }+ return $ req { rqParams = Map.unionWith (++) (rqParams req)+ newParams } --------------------------------------------------------------------------@@ -640,7 +619,7 @@ let (serverName, serverPort) = fromMaybe (localHostname, lport) (liftM (parseHost . head)- (Map.lookup "host" hdrs))+ (H.lookup "host" hdrs)) -- will override in "setEnumerator" enum <- liftIO $ newIORef $ SomeEnumerator (enumBS "")@@ -677,12 +656,12 @@ hdrs = toHeaders kvps mbContentLength = liftM (Cvt.int . head) $- Map.lookup "content-length" hdrs+ H.lookup "content-length" hdrs cookies = concat $ maybe [] (catMaybes . map parseCookie)- (Map.lookup "cookie" hdrs)+ (H.lookup "cookie" hdrs) contextPath = "/" @@ -785,13 +764,12 @@ --------------------------------------------------------------------------- buildHdrs :: Map (CI ByteString) [ByteString]- -> (Builder,Int)+ buildHdrs :: Headers -> (Builder,Int) buildHdrs hdrs = {-# SCC "buildHdrs" #-}- Map.foldlWithKey f (mempty,0) hdrs+ H.fold f (mempty,0) hdrs where- f (b,len) k ys =+ f (!b,!len) !k !ys = let (!b',len') = h k ys in (b `mappend` b', len+len') @@ -875,7 +853,7 @@ -------------------------------------------------------------------------- handle304 :: Response -> Response handle304 r = setResponseBody (enumBuilder mempty) $- updateHeaders (Map.delete "Transfer-Encoding") $+ updateHeaders (H.delete "Transfer-Encoding") $ setContentLength 0 r @@ -885,7 +863,7 @@ where f h = if null cookies then h- else Map.insertWith (flip (++)) "Set-Cookie" cookies h+ else foldl' (\m v -> H.insert "Set-Cookie" v m) h cookies cookies = fmap cookieToBS . Map.elems $ rspCookies r @@ -959,28 +937,29 @@ then modify $ \s -> s { _forceConnectionClose = True } else return () where- l = liftM (map tl) $ Map.lookup "Connection" hdrs+ l = liftM (map tl) $ H.lookup "Connection" hdrs tl = S.map (c2w . toLower . w2c) ------------------------------------------------------------------------------ -- FIXME: whitespace-trim the values here. toHeaders :: [(ByteString,ByteString)] -> Headers-toHeaders kvps = foldl' f Map.empty kvps'+toHeaders kvps = H.fromList kvps' where- kvps' = map (first CI.mk . second (:[])) kvps- f m (k,v) = Map.insertWith' (flip (++)) k v m+ kvps' = map (first CI.mk) kvps ------------------------------------------------------------------------------ -- | Convert 'Cookie' into 'ByteString' for output. cookieToBS :: Cookie -> ByteString-cookieToBS (Cookie k v mbExpTime mbDomain mbPath) = cookie+cookieToBS (Cookie k v mbExpTime mbDomain mbPath isSec isHOnly) = cookie where- cookie = S.concat [k, "=", v, path, exptime, domain]+ cookie = S.concat [k, "=", v, path, exptime, domain, secure, hOnly] path = maybe "" (S.append "; path=") mbPath domain = maybe "" (S.append "; domain=") mbDomain exptime = maybe "" (S.append "; expires=" . fmt) mbExpTime+ secure = if isSec then "; Secure" else ""+ hOnly = if isHOnly then "; HttpOnly" else "" fmt = fromStr . formatTime defaultTimeLocale "%a, %d-%b-%Y %H:%M:%S GMT"
src/Snap/Internal/Http/Server/Address.hs view
@@ -7,7 +7,7 @@ , getAddress ) where --------------------------------------------------------------------------------+------------------------------------------------------------------------------ import Network.Socket import Data.Maybe import Control.Monad@@ -18,7 +18,7 @@ import Data.ByteString.Char8 () import Data.ByteString.Internal (c2w, w2c) --------------------------------------------------------------------------------+------------------------------------------------------------------------------ data AddressNotSupportedException = AddressNotSupportedException String deriving (Typeable) @@ -27,12 +27,12 @@ instance Exception AddressNotSupportedException --------------------------------------------------------------------------------+------------------------------------------------------------------------------ getHostAddr :: SockAddr -> IO String getHostAddr addr = (fromMaybe "" . fst) `liftM` getNameInfo [NI_NUMERICHOST] True False addr --------------------------------------------------------------------------------+------------------------------------------------------------------------------ getAddress :: SockAddr -> IO (Int, ByteString) getAddress addr = do port <- case addr of@@ -42,7 +42,7 @@ host <- getHostAddr addr return (fromIntegral port, S.pack $ map c2w host) --------------------------------------------------------------------------------+------------------------------------------------------------------------------ getSockAddr :: Int -> ByteString -> IO (Family, SockAddr)
src/Snap/Internal/Http/Server/HttpPort.hs view
@@ -13,8 +13,9 @@ ------------------------------------------------------------------------------ import Data.ByteString (ByteString)+#ifdef PORTABLE import qualified Data.ByteString as B-import Data.ByteString.Internal (w2c)+#endif import Foreign import Foreign.C import Network.Socket hiding (recv, send)
src/Snap/Internal/Http/Server/LibevBackend.hs view
@@ -238,6 +238,7 @@ where go = runSession defaultTimeout back handler sock cleanup = [ Handler $ \(_ :: TimeoutException) -> return ()+ , Handler $ \(e :: AsyncException) -> return () , Handler $ \(e :: SomeException) -> elog $ S.concat [ "libev.acceptCallback: " , S.pack . map c2w $ show e ]@@ -508,7 +509,7 @@ go sinfo conn `finally` (block $ do debug "runSession: thread finished, freeing connection" ignoreException $ freeConnection conn)- + where go sinfo conn = bracket (Listen.createSession lsock bLOCKSIZE fd $
src/Snap/Internal/Http/Server/SimpleBackend.hs view
@@ -165,8 +165,8 @@ in handler sinfo (enumerate lsock s sock) writeEnd- (sendFile lsock (tickleTimeout defaultTimeout) fd- writeEnd)+ (sendFile lsock (tickleTimeout defaultTimeout)+ fd writeEnd) setTimeout )
src/Snap/Internal/Http/Server/TLS.hs view
@@ -24,7 +24,6 @@ import Data.Dynamic import Foreign.C -import Snap.Internal.Debug import Snap.Internal.Http.Server.Backend #ifdef OPENSSL
src/Snap/Internal/Http/Server/TimeoutManager.hs view
@@ -75,9 +75,9 @@ ------------------------------------------------------------------------------ -- | Register a new connection with the TimeoutManager.-register :: IO () -- ^ action to run when the timeout deadline is- -- exceeded.- -> TimeoutManager -- ^ manager to register with.+register :: IO ()+ -- ^ action to run when the timeout deadline is exceeded.+ -> TimeoutManager -- ^ manager to register with. -> IO TimeoutHandle register killAction tm = do now <- getTime
src/System/FastLogger.hs view
@@ -57,8 +57,8 @@ ------------------------------------------------------------------------------ -- | Like 'newLogger', but uses a custom error action if the logger needs to--- print an error message of its own (for instance, if it can't open the output--- file.)+-- print an error message of its own (for instance, if it can't open the+-- output file.) newLoggerWithCustomErrorFunction :: (ByteString -> IO ()) -- ^ logger uses this action to log any -- error messages of its own
test/common/Test/Common/TestHandler.hs view
@@ -15,7 +15,7 @@ import Data.Monoid import Snap.Iteratee hiding (Enumerator) import qualified Snap.Iteratee as I-import Snap.Types+import Snap.Core import Snap.Util.FileServe import Snap.Util.FileUploads import Snap.Util.GZip@@ -172,14 +172,14 @@ testHandler :: Snap () testHandler = withCompression $- route [ ("pong" , pongHandler )- , ("echo" , echoHandler )- , ("rot13" , rot13Handler )- , ("echoUri" , echoUriHandler )- , ("fileserve" , fileServe "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 ) ]
test/pongserver/Main.hs view
@@ -6,7 +6,7 @@ import Control.Exception (finally) import Snap.Iteratee-import Snap.Types+import Snap.Core import Snap.Http.Server -- FIXME: need better primitives for output@@ -29,6 +29,6 @@ where go m = httpServe config pongServer `finally` putMVar m () config = setPort 8000 $- setErrorLog Nothing $- setAccessLog Nothing $+ setErrorLog ConfigNoLog $+ setAccessLog ConfigNoLog $ setCompression False $ emptyConfig
test/snap-server-testsuite.cabal view
@@ -45,14 +45,14 @@ old-locale, parallel > 2, process,- snap-core >= 0.5.4 && <0.6,+ snap-core >= 0.6 && < 0.7, template-haskell,- test-framework >= 0.3.1 && <0.5,+ 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, time,- tls >= 0.7.1 && <0.8,+ tls >= 0.7.1 && <0.9, transformers, vector >= 0.7 && <0.10, vector-algorithms >= 0.4 && <0.6,@@ -105,7 +105,7 @@ parallel > 2, MonadCatchIO-transformers >= 0.2.1 && < 0.3, network == 2.3.*,- snap-core >= 0.5.4 && <0.6,+ snap-core >= 0.6 && < 0.7, template-haskell, time, transformers,@@ -169,7 +169,7 @@ blaze-builder-enumerator >= 0.2.0 && <0.3, bytestring, bytestring-nums >= 0.3.1 && < 0.4,- case-insensitive >= 0.2 && < 0.5,+ case-insensitive >= 0.3 && < 0.4, containers, directory-tree, enumerator >= 0.4.7 && <0.5,@@ -181,9 +181,9 @@ network == 2.3.*, old-locale, parallel > 2,- snap-core >= 0.5.4 && <0.6,+ snap-core >= 0.6 && < 0.7, template-haskell,- test-framework >= 0.3.1 && <0.5,+ 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,@@ -226,5 +226,5 @@ base >= 4 && < 5, network == 2.3.*, http-enumerator >= 0.7 && <0.8,- tls >= 0.7.1 && <0.8,+ tls >= 0.7.1 && <0.9, criterion >= 0.5 && <0.6
test/suite/Snap/Internal/Http/Parser/Tests.hs view
@@ -137,15 +137,13 @@ assertEqual "cookie parsing" (Just [cv]) cv2 where- cv = Cookie nm v Nothing Nothing Nothing+ cv = Cookie nm v Nothing Nothing Nothing False False cv2 = parseCookie ct nm = "foo" v = "bar" - ct = S.concat [ nm- , "="- , v ]+ ct = S.concat [ nm , "=" , v ] testFormEncoded :: Test
test/suite/Snap/Internal/Http/Server/Tests.hs view
@@ -25,11 +25,12 @@ import qualified Data.ByteString.Lazy.Char8 as LC import Data.ByteString (ByteString) import Data.ByteString.Internal (c2w)+import qualified Data.CaseInsensitive as CI import Data.Char import Data.Int import Data.IORef-import qualified Data.Map as Map-import Data.Maybe (fromJust)+import Data.List (foldl', sort)+import Data.Maybe (fromJust, isJust) import Data.Time.Calendar import Data.Time.Clock import Data.Typeable@@ -44,6 +45,7 @@ import qualified Snap.Http.Server as Svr +import Snap.Core import Snap.Internal.Debug import Snap.Internal.Http.Types import Snap.Internal.Http.Server@@ -51,7 +53,7 @@ import Snap.Iteratee hiding (map) import Snap.Internal.Http.Server.Backend import Snap.Test.Common-import Snap.Types+import qualified Snap.Types.Headers as H data TestException = TestException deriving (Show, Typeable)@@ -190,11 +192,12 @@ assertEqual "parse body" "0123456789" body - assertEqual "cookie" [Cookie "foo" "bar\"" Nothing Nothing Nothing] $- rqCookies req+ assertEqual "cookie" + [Cookie "foo" "bar\"" Nothing Nothing Nothing False False] + (rqCookies req) assertEqual "continued headers" (Just ["foo bar"]) $- Map.lookup "x-random-other-header" $ rqHeaders req+ H.lookup "x-random-other-header" $ rqHeaders req assertEqual "parse URI" "/foo/bar.html?param1=abc¶m2=def%20+¶m1=abc"@@ -307,7 +310,7 @@ assertEqual "no cookies" [] $ rqCookies req assertEqual "multiheader" (Just ["1","2"]) $- Map.lookup "Multiheader" (rqHeaders req)+ H.lookup "Multiheader" (rqHeaders req) assertEqual "host" ("localhost", 80) $ (rqServerName req, rqServerPort req)@@ -396,7 +399,7 @@ ]) b where- rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $+ rsp1 = updateHeaders (H.insert "Foo" "Bar") $ setContentLength 10 $ setResponseStatus 600 "Test" $ modifyResponseBody (>==> (enumBuilder $@@ -405,28 +408,47 @@ emptyResponse { rspHttpVersion = (1,0) } +strToHeaders :: L.ByteString -> H.Headers+strToHeaders s = foldl' mkHeader H.empty lns+ where+ lns = LC.lines s + mkHeader hdrs x = hdrs'+ where+ (a0,b0) = LC.break (== ':') x+ a = CI.mk $ S.concat $ LC.toChunks a0+ b = S.concat $ LC.toChunks $ LC.drop 2 b0+ hdrs' = H.insert a b hdrs++ testOnSendFile :: FilePath -> Int64 -> Int64 -> IO L.ByteString testOnSendFile f st sz = do sstep <- runIteratee copyingStream2Stream run_ $ enumFilePartial f (st,st+sz) sstep + testHttpResponse2 :: Test testHttpResponse2 = testCase "server/HttpResponse2" $ do req <- mkRequest sampleRequest buf <- allocBuffer 16384- b2 <- run_ $ rsm $+ b2 <- liftM (S.concat . L.toChunks) $ run_ $ rsm $ sendResponse req rsp2 buf copyingStream2Stream testOnSendFile >>= return . snd - assertEqual "http response" (L.concat [- "HTTP/1.0 600 Test\r\n"- , "Connection: close\r\n"- , "Foo: Bar\r\n\r\n"- , "0123456789"- ]) b2+ assertBool "http prefix"+ ("HTTP/1.0 600 Test\r\n" `S.isPrefixOf` b2)++ assertBool "connection close"+ ("Connection: close\r\n" `S.isInfixOf` b2)++ assertBool "foo: bar"+ ("Foo: Bar\r\n" `S.isInfixOf` b2)++ assertBool "body"+ ("\r\n\r\n0123456789" `S.isSuffixOf` b2)+ where- rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $+ rsp1 = updateHeaders (H.insert "Foo" "Bar") $ setContentLength 10 $ setResponseStatus 600 "Test" $ modifyResponseBody (>==> (enumBuilder $@@ -445,19 +467,31 @@ sendResponse req rsp3 buf copyingStream2Stream testOnSendFile >>= return . snd - assertEqual "http response" (L.concat [- "HTTP/1.1 600 Test\r\n"- , "Content-Type: text/plain\r\n"- , "Foo: Bar\r\n"- , "Transfer-Encoding: chunked\r\n\r\n"- , "000A\r\n"- , "0123456789\r\n"- , "0\r\n\r\n"- ]) b3+ let lns = LC.lines b3 + let ok = case lns of+ ([ "HTTP/1.1 600 Test\r"+ , h1, h2, h3+ , "\r"+ , "000A\r"+ , "0123456789\r"+ , "0\r"+ , "\r"]) -> check $ LC.unlines [h1,h2,h3]+ _ -> False + when (not ok) $ LC.putStrLn $+ LC.concat ["***testHttpResponse3: b3 was:\n", b3]++ assertBool "http response" ok+ where- rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $+ check s = (H.lookup "Content-Type" hdrs == Just ["text/plain\r"]) &&+ (H.lookup "Foo" hdrs == Just ["Bar\r"]) &&+ (H.lookup "Transfer-Encoding" hdrs == Just ["chunked\r"])+ where+ hdrs = strToHeaders s++ rsp1 = updateHeaders (H.insert "Foo" "Bar") $ setContentLength 10 $ setResponseStatus 600 "Test" $ modifyResponseBody (>==> (enumBuilder $@@ -492,37 +526,47 @@ testHttpResponseCookies = testCase "server/HttpResponseCookies" $ do buf <- allocBuffer 16384 req <- mkRequest sampleRequest+ b <- run_ $ rsm $- sendResponse req rsp2 buf copyingStream2Stream testOnSendFile >>=- return . snd- b2 <- run_ $ rsm $- sendResponse req rsp3 buf copyingStream2Stream testOnSendFile >>=+ sendResponse req rsp2 buf copyingStream2Stream testOnSendFile >>= return . snd - assertEqual "http response cookie" (L.concat [- "HTTP/1.0 304 Test\r\n"- , "Content-Length: 0\r\n"- , "Set-Cookie: foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r\n\r\n"- ]) b+ let lns = LC.lines b + let ok = case lns of+ ([ "HTTP/1.0 304 Test\r"+ , h1, h2, h3, h4+ , "\r"]) -> check $ LC.unlines [h1,h2,h3,h4]+ _ -> False - assertEqual "http response multi-cookies" (L.concat [- "HTTP/1.0 304 Test\r\n"- , "Content-Length: 0\r\n"- , "Set-Cookie: foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r\n"- , "Set-Cookie: zoo=baz; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r\n\r\n"- ]) b2+ when (not ok) $ LC.putStrLn $+ LC.concat ["*** testHttpResponseCookies: b was:\n", b]+ assertBool "http response" ok where- rsp1 = setResponseStatus 304 "Test" $- emptyResponse { rspHttpVersion = (1,0) }- rsp2 = addResponseCookie cook rsp1- rsp3 = addResponseCookie cook2 rsp2+ check s = (H.lookup "Content-Length" hdrs == Just ["0\r"]) &&+ (ch $ H.lookup "Set-Cookie" hdrs)+ where+ hdrs = strToHeaders s + ch Nothing = False+ ch (Just 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 + . addResponseCookie cook $ rsp1+ utc = UTCTime (ModifiedJulianDay 55226) 0- cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/")- cook2 = Cookie "zoo" "baz" (Just utc) (Just ".foo.com") (Just "/")- cook3 = Cookie "boo" "baz" Nothing Nothing Nothing+ cook = Cookie "ck1" "bar" (Just utc) (Just ".foo.com") (Just "/") True False+ cook2 = Cookie "ck2" "bar" (Just utc) (Just ".foo.com") (Just "/") False True+ cook3 = Cookie "ck3" "bar" Nothing Nothing Nothing False False @@ -549,7 +593,7 @@ (rq,rsp) <- echoServer (const $ return ()) (const $ return ()) req return (rq, addResponseCookie cook rsp) where- cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/")+ cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") False False utc = UTCTime (ModifiedJulianDay 55226) 0 @@ -571,29 +615,40 @@ let ok = case lns of ([ "HTTP/1.1 200 OK\r"- , "Content-Length: 10\r"- , d1- , s1+ , h1+ , h2+ , h3 , "\r" , "0123456789HTTP/1.1 200 OK\r"- , "Content-Length: 14\r"- , d2- , s2+ , g1+ , g2+ , g3 , "\r"- , "01234567890123" ]) -> (("Date" `L.isPrefixOf` d1) &&- ("Date" `L.isPrefixOf` d2) &&- ("Server" `L.isPrefixOf` s1) &&- ("Server" `L.isPrefixOf` s2))-+ , "01234567890123" ]) -> (check1 $ LC.unlines [h1,h2,h3]) &&+ (check2 $ LC.unlines [g1,g2,g3]) _ -> False + when (not ok) $ do putStrLn "server/httpSession fail!!!! got:" LC.putStrLn s assertBool "pipelined responses" ok + where+ check1 s = (H.lookup "Content-Length" hdrs == Just ["10\r"]) &&+ (isJust $ H.lookup "Server" hdrs) &&+ (isJust $ H.lookup "Date" hdrs)+ where+ hdrs = strToHeaders s + check2 s = (H.lookup "Content-Length" hdrs == Just ["14\r"]) &&+ (isJust $ H.lookup "Server" hdrs) &&+ (isJust $ H.lookup "Date" hdrs)+ where+ hdrs = strToHeaders s++ mkIter :: IORef L.ByteString -> (Iteratee ByteString IO (), FilePath -> Int64 -> Int64 -> IO ()) mkIter ref = (iter, \f st sz -> onF f st sz iter)@@ -653,7 +708,7 @@ testHttp2 :: Test-testHttp2 = testCase "server/connection: close" $ do+testHttp2 = testCase "server/connectionClose" $ do let enumBody = enumBS sampleRequest4 >==> enumBS sampleRequest2 ref <- newIORef ""@@ -681,21 +736,31 @@ let ok = case lns of ([ "HTTP/1.1 200 OK\r"- , "Connection: close\r"- , "Content-Length: 10\r"- , d1- , s1- , "Set-Cookie: foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r"+ , h1+ , h2+ , h3+ , h4+ , h5 , "\r"- , "0123456789" ]) -> (("Date" `L.isPrefixOf` d1) &&- ("Server" `L.isPrefixOf` s1))+ , "0123456789" ]) -> (check $ LC.unlines [h1,h2,h3,h4,h5]) _ -> False assertBool "connection: close" ok + where+ check s = (H.lookup "Content-Length" hdrs == Just ["10\r"]) &&+ (H.lookup "Connection" hdrs == Just ["close\r"]) &&+ (H.lookup "Set-Cookie" hdrs == Just [+ "foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r"+ ]) &&+ (isJust $ H.lookup "Server" hdrs) &&+ (isJust $ H.lookup "Date" hdrs)+ where+ hdrs = strToHeaders s + testHttp100 :: Test testHttp100 = testCase "server/expect100" $ do let enumBody = enumBS sampleRequestExpectContinue@@ -723,14 +788,12 @@ ([ "HTTP/1.1 100 Continue\r" , "\r" , "HTTP/1.1 200 OK\r"- , "Content-Length: 10\r"- , d1- , s1- , "Set-Cookie: foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r"+ , h1+ , h2+ , h3+ , h4 , "\r"- , "0123456789" ]) -> (("Date" `L.isPrefixOf` d1) &&- ("Server" `L.isPrefixOf` s1))-+ , "0123456789" ]) -> (check $ LC.unlines [h1,h2,h3,h4]) _ -> False when (not ok) $ do@@ -739,7 +802,17 @@ assertBool "100 Continue" ok + where+ check s = (H.lookup "Content-Length" hdrs == Just ["10\r"]) &&+ (H.lookup "Set-Cookie" hdrs == Just [+ "foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r"+ ]) &&+ (isJust $ H.lookup "Server" hdrs) &&+ (isJust $ H.lookup "Date" hdrs)+ where+ hdrs = strToHeaders s + test411 :: Test test411 = testCase "server/expect411" $ do let enumBody = enumBS sampleRequest411@@ -776,7 +849,7 @@ testExpectGarbage :: Test-testExpectGarbage = testCase "server/Expect: garbage" $ do+testExpectGarbage = testCase "server/expectGarbage" $ do let enumBody = enumBS sampleRequestExpectGarbage ref <- newIORef ""@@ -800,19 +873,25 @@ let ok = case lns of ([ "HTTP/1.1 200 OK\r"- , "Content-Length: 10\r"- , d1- , s1- , "Set-Cookie: foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r"+ , h1+ , h2+ , h3+ , h4 , "\r"- , "0123456789" ]) -> (("Date" `L.isPrefixOf` d1) &&- ("Server" `L.isPrefixOf` s1))-+ , "0123456789" ]) -> (check $ LC.unlines [h1,h2,h3,h4]) _ -> False assertBool "random expect: header" ok -+ where+ check s = (H.lookup "Content-Length" hdrs == Just ["10\r"]) &&+ (H.lookup "Set-Cookie" hdrs == Just [+ "foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r"+ ]) &&+ (isJust $ H.lookup "Server" hdrs) &&+ (isJust $ H.lookup "Date" hdrs)+ where+ hdrs = strToHeaders s pongServer :: Snap ()@@ -865,8 +944,8 @@ [HttpPort "*" port] Nothing "localhost"- (Just "test-access.log")- (Just "test-error.log")+ (Just $ const (return ())) -- dummy logging+ (Just $ const (return ())) -- dummy logging (runSnap pongServer)) (killThread) (\tid -> do
test/suite/Test/Blackbox.hs view
@@ -86,8 +86,10 @@ -> ConfigBackend -> IO (ThreadId, MVar ()) startTestServer port sslport backend = do- let cfg = setAccessLog (Just $ "ts-access." ++ show backend ++ ".log") .- setErrorLog (Just $ "ts-error." ++ show backend ++ ".log") .+ let cfg = setAccessLog+ (ConfigFileLog $ "ts-access." ++ show backend ++ ".log") .+ setErrorLog+ (ConfigFileLog $ "ts-error." ++ show backend ++ ".log") . setBind "*" . setPort port . setBackend backend .