diff --git a/snap-server.cabal b/snap-server.cabal index bc7f96e6..6dc32bed 100644 --- a/snap-server.cabal +++ b/snap-server.cabal @@ -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 @@ -108,17 +108,17 @@ Library blaze-builder-enumerator >= 0.2.0 && <0.3, bytestring, bytestring-nums, - case-insensitive >= 0.2 && < 0.4, + case-insensitive >= 0.3 && < 0.4, containers, directory-tree >= 0.10 && < 0.11, enumerator >= 0.4.13.1 && <0.5, filepath, monad-control >= 0.2, - mtl == 2.0.*, + mtl >= 2 && <3, murmur-hash >= 0.1 && < 0.2, network >= 2.3 && <2.4, old-locale, - snap-core >= 0.5.4 && <0.6, + snap-core >= 0.6 && < 0.7, template-haskell, text >= 0.11 && <0.12, time >= 1.0 && < 1.4, diff --git a/src/Snap/Http/Server.hs b/src/Snap/Http/Server.hs index 8dc61c87..e6c13eb4 100644 --- a/src/Snap/Http/Server.hs +++ b/src/Snap/Http/Server.hs @@ -28,7 +28,7 @@ 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 @@ -49,7 +49,7 @@ snapServerVersion = Int.snapServerVersion -- 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 diff --git a/src/Snap/Http/Server/Config.hs b/src/Snap/Http/Server/Config.hs index ad086f22..216cdb31 100644 --- a/src/Snap/Http/Server/Config.hs +++ b/src/Snap/Http/Server/Config.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-| @@ -66,8 +67,9 @@ import Data.Maybe 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 @@ -206,6 +208,17 @@ instance Monoid (Config m a) where ov f x y = getLast $! (mappend `on` (Last . f)) x y +------------------------------------------------------------------------------ +-- | 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 @@ -445,7 +458,7 @@ defaultErrorHandler e = do 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" diff --git a/src/Snap/Internal/Http/Parser.hs b/src/Snap/Internal/Http/Parser.hs index c63dd21e..4bc837a6 100644 --- a/src/Snap/Internal/Http/Parser.hs +++ b/src/Snap/Internal/Http/Parser.hs @@ -225,54 +225,3 @@ pGetTransferChunk = do 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 - - diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs index 10e93237..0ade1fee 100644 --- a/src/Snap/Internal/Http/Server.hs +++ b/src/Snap/Internal/Http/Server.hs @@ -18,7 +18,6 @@ import Control.Exception.Control import Control.Monad.State.Strict import Control.Exception.Control 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 @@ -60,6 +59,9 @@ import Snap.Internal.Iteratee.Debug 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 @@ -261,8 +263,8 @@ logA' logger req rsp = do 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 @@ -337,8 +339,8 @@ requestErrorMessage req e = ------------------------------------------------------------------------------ -sERVER_HEADER :: [ByteString] -sERVER_HEADER = [S.concat ["Snap/", snapServerVersion]] +sERVER_HEADER :: ByteString +sERVER_HEADER = S.concat ["Snap/", snapServerVersion] ------------------------------------------------------------------------------ @@ -422,8 +424,8 @@ httpSession defaultTimeout writeEnd' buffer onSendFile tickle handler = do "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 @@ -546,7 +548,7 @@ receiveRequest writeEnd = do where isChunked = maybe False ((== ["chunked"]) . map CI.mk) - (Map.lookup "transfer-encoding" hdrs) + (H.lookup "transfer-encoding" hdrs) hasContentLength :: Int64 -> ServerMonad () hasContentLength len = do @@ -580,7 +582,7 @@ receiveRequest writeEnd = do hdrs = rqHeaders req - mbCL = Map.lookup "content-length" hdrs >>= return . Cvt.int . head + mbCL = H.lookup "content-length" hdrs >>= return . Cvt.int . head -------------------------------------------------------------------------- @@ -588,7 +590,7 @@ receiveRequest writeEnd = do 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 @@ -620,7 +622,8 @@ receiveRequest writeEnd = do e st' liftIO $ writeIORef (rqBody req) $ SomeEnumerator e' - return $ req { rqParams = rqParams req `mappend` newParams } + return $ req { rqParams = Map.unionWith (++) (rqParams req) + newParams } -------------------------------------------------------------------------- @@ -636,7 +639,7 @@ receiveRequest writeEnd = do 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 "") @@ -673,12 +676,12 @@ receiveRequest writeEnd = do 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 = "/" @@ -781,13 +784,12 @@ sendResponse req rsp' buffer writeEnd' onSendFile = do -------------------------------------------------------------------------- - 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') @@ -871,7 +873,7 @@ sendResponse req rsp' buffer writeEnd' onSendFile = do -------------------------------------------------------------------------- handle304 :: Response -> Response handle304 r = setResponseBody (enumBuilder mempty) $ - updateHeaders (Map.delete "Transfer-Encoding") $ + updateHeaders (H.delete "Transfer-Encoding") $ setContentLength 0 r @@ -881,7 +883,7 @@ sendResponse req rsp' buffer writeEnd' onSendFile = do 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 @@ -955,28 +957,29 @@ checkConnectionClose ver hdrs = 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" diff --git a/test/.ghci b/test/.ghci new file mode 100644 index 00000000..ca847662 --- /dev/null +++ b/test/.ghci @@ -0,0 +1,3 @@ +:set -i../src +:set -isuite +:set -icommon diff --git a/test/common/Test/Common/TestHandler.hs b/test/common/Test/Common/TestHandler.hs index e012dd95..4f9d6d7c 100644 --- a/test/common/Test/Common/TestHandler.hs +++ b/test/common/Test/Common/TestHandler.hs @@ -15,7 +15,7 @@ import Data.Maybe 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 @@ uploadHandler = do 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 ) ] diff --git a/test/pongserver/Main.hs b/test/pongserver/Main.hs index ae3a7f2a..3e6eb05f 100644 --- a/test/pongserver/Main.hs +++ b/test/pongserver/Main.hs @@ -6,7 +6,7 @@ import Control.Concurrent import Control.Exception (finally) import Snap.Iteratee -import Snap.Types +import Snap.Core import Snap.Http.Server -- FIXME: need better primitives for output diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal index 8e614da2..c2b3a630 100644 --- a/test/snap-server-testsuite.cabal +++ b/test/snap-server-testsuite.cabal @@ -45,9 +45,9 @@ Executable testsuite 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, @@ -105,7 +105,7 @@ Executable pongserver 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 @@ Executable testserver 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 @@ Executable testserver 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, diff --git a/test/suite/Snap/Internal/Http/Parser/Tests.hs b/test/suite/Snap/Internal/Http/Parser/Tests.hs index b5cced13..2bb105cf 100644 --- a/test/suite/Snap/Internal/Http/Parser/Tests.hs +++ b/test/suite/Snap/Internal/Http/Parser/Tests.hs @@ -137,15 +137,13 @@ testCookie = 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 diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs b/test/suite/Snap/Internal/Http/Server/Tests.hs index 15c4cd8b..345fc73a 100644 --- a/test/suite/Snap/Internal/Http/Server/Tests.hs +++ b/test/suite/Snap/Internal/Http/Server/Tests.hs @@ -44,6 +44,7 @@ import Test.HUnit hiding (Test, path) 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 +52,7 @@ import qualified Snap.Iteratee as I 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 +191,12 @@ testHttpRequest1 = 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 +309,7 @@ testHttpRequest3 = 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 +398,7 @@ testHttpResponse1 = testCase "server/HttpResponse1" $ do ]) b where - rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $ + rsp1 = updateHeaders (H.insert "Foo" "Bar") $ setContentLength 10 $ setResponseStatus 600 "Test" $ modifyResponseBody (>==> (enumBuilder $ @@ -426,7 +428,7 @@ testHttpResponse2 = testCase "server/HttpResponse2" $ do , "0123456789" ]) b2 where - rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $ + rsp1 = updateHeaders (H.insert "Foo" "Bar") $ setContentLength 10 $ setResponseStatus 600 "Test" $ modifyResponseBody (>==> (enumBuilder $ @@ -457,7 +459,7 @@ testHttpResponse3 = testCase "server/HttpResponse3" $ do where - rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $ + rsp1 = updateHeaders (H.insert "Foo" "Bar") $ setContentLength 10 $ setResponseStatus 600 "Test" $ modifyResponseBody (>==> (enumBuilder $ @@ -492,37 +494,30 @@ testHttpResponseCookies :: Test 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 [ + -- Having some weird issues here with lazy ByteString comparison; run thru + -- strict ByteString to get around it. Slow/lame, but whatever. + assertEqual "http response multi-cookies" (L.fromChunks . return . S.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 - - - 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 + , "Set-Cookie: ck1=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com; Secure\r\n" + , "Set-Cookie: ck2=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com; HttpOnly\r\n" + , "Set-Cookie: ck3=bar\r\n\r\n" + ]) (L.fromChunks . return . S.concat . L.toChunks $ b) where - rsp1 = setResponseStatus 304 "Test" $ - emptyResponse { rspHttpVersion = (1,0) } - rsp2 = addResponseCookie cook rsp1 - rsp3 = addResponseCookie cook2 rsp2 + 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 +544,7 @@ echoServer2 _ _ req = do (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