diff --git a/snap-server.cabal b/snap-server.cabal --- a/snap-server.cabal +++ b/snap-server.cabal @@ -1,5 +1,5 @@ name: snap-server -version: 0.2.8.1 +version: 0.2.9 synopsis: A fast, iteratee-based, epoll-enabled web server for the Snap Framework description: This is the first developer prerelease of the Snap framework. Snap is a @@ -107,7 +107,7 @@ bytestring, bytestring-nums, bytestring-show >= 0.3.2 && < 0.4, - cereal >= 0.2 && < 0.3, + cereal >= 0.3 && < 0.4, containers, directory-tree, dlist >= 0.5 && < 0.6, @@ -117,7 +117,7 @@ murmur-hash >= 0.1 && < 0.2, network == 2.2.1.*, old-locale, - snap-core >= 0.2.8.1 && <0.3, + snap-core >= 0.2.9 && <0.3, time, transformers, unix-compat, @@ -129,7 +129,7 @@ build-depends: unix if flag(libev) - build-depends: hlibev >= 0.2.5 && < 0.3 + build-depends: hlibev >= 0.2.8 && < 0.3 other-modules: Snap.Internal.Http.Server.LibevBackend cpp-options: -DLIBEV else diff --git a/src/Snap/Internal/Http/Parser.hs b/src/Snap/Internal/Http/Parser.hs --- a/src/Snap/Internal/Http/Parser.hs +++ b/src/Snap/Internal/Http/Parser.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE PackageImports #-} @@ -16,35 +17,35 @@ ------------------------------------------------------------------------------ -import Control.Applicative -import Control.Arrow (second) -import Control.Monad (liftM) +import Control.Applicative +import Control.Arrow (second) +import Control.Monad (liftM) import "monads-fd" Control.Monad.Trans -import Data.Attoparsec hiding (many, Result(..)) -import Data.Attoparsec.Iteratee -import Data.Bits -import Data.ByteString (ByteString) -import qualified Data.ByteString as S -import Data.ByteString.Internal (c2w, w2c) -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Nums.Careless.Hex as Cvt -import Data.Char -import Data.List (foldl') -import Data.Int -import Data.IORef -import Data.Iteratee.WrappedByteString -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (catMaybes) -import qualified Data.Vector.Unboxed as Vec -import Data.Vector.Unboxed (Vector) -import Data.Word (Word8, Word64) -import Foreign.C.Types -import Foreign.ForeignPtr -import Prelude hiding (take, takeWhile) +import Data.Attoparsec hiding (many, Result(..)) +import Data.Attoparsec.Iteratee +import Data.Bits +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import Data.ByteString.Internal (c2w, w2c) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Nums.Careless.Hex as Cvt +import Data.Char +import Data.List (foldl') +import Data.Int +import Data.IORef +import Data.Iteratee.WrappedByteString +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (catMaybes) +import qualified Data.Vector.Unboxed as Vec +import Data.Vector.Unboxed (Vector) +import Data.Word (Word8, Word64) +import Foreign.C.Types +import Foreign.ForeignPtr +import Prelude hiding (take, takeWhile) ------------------------------------------------------------------------------ -import Snap.Internal.Http.Types hiding (Enumerator) -import Snap.Iteratee hiding (take, foldl', filter) +import Snap.Internal.Http.Types hiding (Enumerator) +import Snap.Iteratee hiding (take, foldl', filter) @@ -57,6 +58,8 @@ , iRequestHeaders :: [(ByteString, ByteString)] } + +------------------------------------------------------------------------------ instance Show IRequest where show (IRequest m u v r) = concat [ show m @@ -67,43 +70,45 @@ , " " , show r ] + ------------------------------------------------------------------------------ parseRequest :: (Monad m) => Iteratee m (Maybe IRequest) parseRequest = parserToIteratee pRequest +------------------------------------------------------------------------------ readChunkedTransferEncoding :: (Monad m) => Iteratee m a -> m (Iteratee m a) readChunkedTransferEncoding iter = do i <- chunkParserToEnumerator (parserToIteratee pGetTransferChunk) iter - return i + return i -toHex :: Int64 -> ByteString -toHex !i' = S.reverse s +------------------------------------------------------------------------------ +toHex :: Int64 -> S.ByteString +toHex 0 = "0" +toHex n' = s where - !i = abs i' - (!s,_) = S.unfoldrN 16 f (fromIntegral i) + !s = trim 16 (fromIntegral (abs n')) - f :: Word64 -> Maybe (Word8, Word64) - f d = if d == 0 - then Nothing - else Just (ch, theRest) + trim :: Int -> Word64 -> S.ByteString + trim !i !n + | n .&. 0xf000000000000000 == 0 = trim (i-1) (n `shiftL` 4) + | otherwise = fst (S.unfoldrN i f n) - where - low4 = fromIntegral $ d .&. 0xf - ch = if low4 >= 10 - then c2w 'a' + low4 - 10 - else c2w '0' + low4 - theRest = (d .&. (complement 0xf)) `shiftR` 4 + f n = Just (char (n `shiftR` 60), n `shiftL` 4) + char (fromIntegral -> i) + | i < 10 = (c2w '0' - 0) + i + | otherwise = (c2w 'a' - 10) + i + +------------------------------------------------------------------------------ -- | Given an iteratee, produces a new one that wraps chunks sent to it with a -- chunked transfer-encoding. Example usage: -- --- FIXME: sample output no longer looks like this, we buffer now -- -- > > (writeChunkedTransferEncoding -- > (enumLBS (L.fromChunks ["foo","bar","quux"])) @@ -111,15 +116,13 @@ -- > run >>= -- > return . fromWrap -- > --- > Chunk "3\r\nfoo\r\n3\r\nbar\r\n4\r\nquux\r\n0\r\n\r\n" Empty +-- > Chunk "a\r\nfoobarquux\r\n0\r\n\r\n" Empty -- - writeChunkedTransferEncoding :: ForeignPtr CChar -> Enumerator IO a -> Enumerator IO a writeChunkedTransferEncoding buf enum it = do killwrap <- newIORef False - --(out,_) <- bufferIteratee (ignoreEOF $ wrap killwrap it) (out,_) <- unsafeBufferIterateeWithBuffer buf (ignoreEOF $ wrap killwrap it) i <- enum out @@ -144,12 +147,10 @@ then runIter iter s else case s of (EOF Nothing) -> do - --S.putStrLn "wrap: eof" return $ Cont iter Nothing (EOF e) -> return $ Cont undefined e (Chunk (WrapBS x)) -> do - --S.putStrLn $ S.concat ["wrap: got ", x] let n = S.length x if n == 0 then do @@ -163,6 +164,7 @@ return $ Cont (wrap killwrap i) Nothing +------------------------------------------------------------------------------ chunkParserToEnumerator :: (Monad m) => Iteratee m (Maybe ByteString) -> Iteratee m a @@ -209,31 +211,45 @@ -- theft alert: many of these routines adapted from Johan Tibell's hyena -- package + +------------------------------------------------------------------------------ -- | Parsers for different tokens in an HTTP request. sp, digit, letter :: Parser Word8 sp = word8 $ c2w ' ' digit = satisfy (isDigit . w2c) letter = satisfy (isAlpha . w2c) + +------------------------------------------------------------------------------ untilEOL :: Parser ByteString untilEOL = takeWhile notend where notend d = let c = w2c d in not $ c == '\r' || c == '\n' + +------------------------------------------------------------------------------ crlf :: Parser ByteString crlf = string "\r\n" + +------------------------------------------------------------------------------ -- | Parser for zero or more spaces. spaces :: Parser [Word8] spaces = many sp + +------------------------------------------------------------------------------ pSpaces :: Parser ByteString pSpaces = takeWhile (isSpace . w2c) + +------------------------------------------------------------------------------ -- | Parser for the internal request data type. pRequest :: Parser (Maybe IRequest) pRequest = (Just <$> pRequest') <|> (endOfInput *> pure Nothing) + +------------------------------------------------------------------------------ pRequest' :: Parser IRequest pRequest' = IRequest <$> (option "" crlf *> pMethod) <* sp @@ -245,6 +261,7 @@ -- send an extra crlf after a POST body +------------------------------------------------------------------------------ -- | Parser for the request method. pMethod :: Parser Method pMethod = (OPTIONS <$ string "OPTIONS") @@ -256,10 +273,14 @@ <|> (TRACE <$ string "TRACE") <|> (CONNECT <$ string "CONNECT") + +------------------------------------------------------------------------------ -- | Parser for the request URI. pUri :: Parser ByteString pUri = takeWhile (not . isSpace . w2c) + +------------------------------------------------------------------------------ -- | Parser for the request's HTTP protocol version. pVersion :: Parser (Int, Int) pVersion = string "HTTP/" *> @@ -267,17 +288,22 @@ where digit' = fmap (digitToInt . w2c) digit + +------------------------------------------------------------------------------ fieldChars :: Parser ByteString fieldChars = takeWhile isFieldChar where isFieldChar c = (Vec.!) fieldCharTable (fromEnum c) + +------------------------------------------------------------------------------ fieldCharTable :: Vector Bool fieldCharTable = Vec.generate 256 f where f d = let c=toEnum d in (isDigit c) || (isAlpha c) || c == '-' || c == '_' +------------------------------------------------------------------------------ -- | Parser for request headers. pHeaders :: Parser [(ByteString, ByteString)] pHeaders = many header @@ -309,6 +335,7 @@ contents +------------------------------------------------------------------------------ pGetTransferChunk :: Parser (Maybe ByteString) pGetTransferChunk = do !hex <- liftM fromHex $ (takeWhile (isHexDigit . w2c)) @@ -332,10 +359,13 @@ -- these definitions try to mirror RFC-2068 (the HTTP/1.1 spec) and RFC-2109 -- (cookie spec): please point out any errors! +------------------------------------------------------------------------------ {-# INLINE matchAll #-} matchAll :: [ Char -> Bool ] -> Char -> Bool matchAll x c = and $ map ($ c) x + +------------------------------------------------------------------------------ {-# INLINE isToken #-} isToken :: Char -> Bool isToken c = (Vec.!) tokenTable (fromEnum c) @@ -345,20 +375,24 @@ f = matchAll [ isAscii , not . isControl - , not . isSpace + , not . isSpace , not . flip elem [ '(', ')', '<', '>', '@', ',', ';' , ':', '\\', '\"', '/', '[', ']' , '?', '=', '{', '}' ] ] +------------------------------------------------------------------------------ {-# INLINE isRFCText #-} isRFCText :: Char -> Bool isRFCText = not . isControl + +------------------------------------------------------------------------------ pToken :: Parser ByteString pToken = takeWhile (isToken . w2c) +------------------------------------------------------------------------------ pQuotedString :: Parser ByteString pQuotedString = q *> quotedText <* q where @@ -377,8 +411,9 @@ q = word8 $ c2w '\"' qdtext = matchAll [ isRFCText, (/= '\"'), (/= '\\') ] . w2c - + +------------------------------------------------------------------------------ pCookies :: Parser [Cookie] pCookies = do -- grab kvps and turn to strict bytestrings @@ -390,11 +425,14 @@ toCookie (nm,val) = Cookie nm val Nothing Nothing Nothing +------------------------------------------------------------------------------ -- unhelpfully, the spec mentions "old-style" cookies that don't have quotes -- around the value. wonderful. pWord :: Parser ByteString pWord = pQuotedString <|> (takeWhile ((/= ';') . w2c)) + +------------------------------------------------------------------------------ pAvPairs :: Parser [(ByteString, ByteString)] pAvPairs = do a <- pAvPair @@ -402,6 +440,8 @@ return $ a:b + +------------------------------------------------------------------------------ pAvPair :: Parser (ByteString, ByteString) pAvPair = do key <- pToken <* pSpaces @@ -409,19 +449,23 @@ return (key,val) + +------------------------------------------------------------------------------ parseCookie :: ByteString -> Maybe [Cookie] parseCookie = parseToCompletion pCookies + ------------------------------------------------------------------------------ --- MULTIPART/FORMDATA +-- 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 (== (c2w '=')) + breakApart = (second (S.drop 1)) . S.break (== (c2w '=')) parts :: [(ByteString,ByteString)] parts = map breakApart $ S.split (c2w '&') s @@ -440,10 +484,11 @@ -- utility functions ------------------------------------------------------------------------------ +------------------------------------------------------------------------------ strictize :: L.ByteString -> ByteString strictize = S.concat . L.toChunks + ------------------------------------------------------------------------------ char :: Char -> Parser Word8 char = word8 . c2w - diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs --- a/src/Snap/Internal/Http/Server.hs +++ b/src/Snap/Internal/Http/Server.hs @@ -469,8 +469,11 @@ parseForm req = {-# SCC "receiveRequest/parseForm" #-} if doIt then getIt else return req where - doIt = mbCT == Just "application/x-www-form-urlencoded" - mbCT = liftM head $ Map.lookup "content-type" (rqHeaders req) + mbCT = liftM head $ Map.lookup "content-type" (rqHeaders req) + trimIt = fst . SC.spanEnd isSpace . SC.takeWhile (/= ';') + . SC.dropWhile isSpace + mbCT' = liftM trimIt mbCT + doIt = mbCT' == Just "application/x-www-form-urlencoded" maximumPOSTBodySize :: Int64 maximumPOSTBodySize = 10*1024*1024 diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs b/src/Snap/Internal/Http/Server/LibevBackend.hs --- a/src/Snap/Internal/Http/Server/LibevBackend.hs +++ b/src/Snap/Internal/Http/Server/LibevBackend.hs @@ -198,7 +198,7 @@ killObj <- mkEvAsync killCB <- mkAsyncCallback $ \_ _ _ -> do debug "async kill wakeup" - evUnloop lp 2 + evUnloop lp evunloop_all return () evAsyncInit asyncObj asyncCB @@ -320,8 +320,7 @@ debug $ "Backend.stop: all threads presumed dead, unlooping" withMVar lock $ \_ -> do - -- FIXME: hlibev should export EVUNLOOP_ALL - evUnloop loop 2 + evUnloop loop evunloop_all evAsyncSend loop killObj debug $ "unloop sent" @@ -377,10 +376,9 @@ tid <- readMVar tmv throwTo tid TimeoutException - else do -- re-arm the timer - -- fixme: should set repeat here, have to wait for an hlibev patch to - -- do it - evTimerAgain loop tmr + else do + evTimerSetRepeat tmr $ fromRational . toRational $ (whenToDie - now) + evTimerAgain loop tmr freeConnection :: Connection -> IO () @@ -513,9 +511,9 @@ now <- getCurrentDateTime timeoutTime <- newIORef $ now + 20 tcb <- mkTimerCallback $ timerCallback lp - tmr - timeoutTime - thrmv + tmr + timeoutTime + thrmv -- 20 second timeout evTimerInit tmr tcb 0 20.0 diff --git a/src/System/SendFile/FreeBSD.hsc b/src/System/SendFile/FreeBSD.hsc --- a/src/System/SendFile/FreeBSD.hsc +++ b/src/System/SendFile/FreeBSD.hsc @@ -2,6 +2,7 @@ -- | FreeBSD system-dependent code for 'sendfile'. module System.SendFile.FreeBSD (sendFile) where +import Control.Concurrent (threadWaitWrite) import Data.Int import Foreign.C.Error (eAGAIN, eINTR, getErrno, throwErrno) import Foreign.C.Types (CInt, CSize) diff --git a/test/runTestsAndCoverage.sh b/test/runTestsAndCoverage.sh --- a/test/runTestsAndCoverage.sh +++ b/test/runTestsAndCoverage.sh @@ -4,7 +4,7 @@ SUITE=./dist/build/testsuite/testsuite -rm -f testsuite.tix +rm -f *.tix if [ ! -f $SUITE ]; then cat < 2, iteratee >= 0.3.1 && < 0.4, - snap-core >= 0.2.7 && <0.3, + snap-core >= 0.2.9 && <0.3, test-framework >= 0.3.1 && <0.4, test-framework-hunit >= 0.2.5 && < 0.3, test-framework-quickcheck2 >= 0.2.6 && < 0.3, @@ -81,7 +81,7 @@ bytestring, bytestring-nums >= 0.3.1 && < 0.4, bytestring-show >= 0.3.2 && < 0.4, - cereal >= 0.2 && < 0.3, + cereal >= 0.3 && < 0.4, containers, directory-tree, dlist >= 0.5 && < 0.6, @@ -95,7 +95,7 @@ murmur-hash >= 0.1 && < 0.2, network == 2.2.1.7, network-bytestring >= 0.1.2 && < 0.2, - snap-core >= 0.2.7 && <0.3, + snap-core >= 0.2.9 && <0.3, time, transformers, unix-compat, @@ -141,6 +141,81 @@ -fno-warn-unused-do-bind ghc-prof-options: -prof -auto-all + +Executable testserver + hs-source-dirs: testserver ../src + main-is: Main.hs + + build-depends: + QuickCheck >= 2, + array >= 0.3 && <0.4, + attoparsec >= 0.8.0.2 && < 0.9, + attoparsec-iteratee >= 0.1.1 && <0.2, + base >= 4 && < 5, + bytestring, + bytestring-nums >= 0.3.1 && < 0.4, + bytestring-show >= 0.3.2 && < 0.4, + cereal >= 0.3 && < 0.4, + containers, + directory-tree, + dlist >= 0.5 && < 0.6, + filepath, + haskell98, + HUnit >= 1.2 && < 2, + monads-fd, + old-locale, + parallel > 2, + iteratee >= 0.3.1 && < 0.4, + murmur-hash >= 0.1 && < 0.2, + network == 2.2.1.7, + network-bytestring >= 0.1.2 && < 0.2, + snap-core >= 0.2.9 && <0.3, + time, + transformers, + unix-compat, + vector >= 0.6.0.1 && < 0.7 + + if flag(portable) || os(windows) + cpp-options: -DPORTABLE + else + build-depends: unix + + if flag(libev) + build-depends: hlibev >= 0.2.5 && < 0.3 + other-modules: Snap.Internal.Http.Server.LibevBackend + cpp-options: -DLIBEV + else + build-depends: network-bytestring >= 0.1.2 && < 0.2, + PSQueue >= 1.1 && <1.2 + + other-modules: Snap.Internal.Http.Server.SimpleBackend + + if os(linux) && !flag(portable) + cpp-options: -DLINUX -DHAS_SENDFILE + other-modules: + System.SendFile, + System.SendFile.Linux + + if os(darwin) && !flag(portable) + cpp-options: -DOSX -DHAS_SENDFILE + other-modules: + System.SendFile, + System.SendFile.Darwin + + if os(freebsd) && !flag(portable) + cpp-options: -DFREEBSD -DHAS_SENDFILE + other-modules: + System.SendFile, + System.SendFile.FreeBSD + + if flag(portable) || os(windows) + cpp-options: -DPORTABLE + + ghc-options: -Wall -O2 -fwarn-tabs -funbox-strict-fields -threaded + -fno-warn-unused-do-bind + ghc-prof-options: -prof -auto-all + + Executable benchmark hs-source-dirs: benchmark ../src main-is: Benchmark.hs @@ -148,5 +223,5 @@ base >= 4 && < 5, network == 2.2.1.7, HTTP >= 4000.0.9 && < 4001, - criterion == 0.5.0.0 + criterion >= 0.5 && <0.6 diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs b/test/suite/Snap/Internal/Http/Server/Tests.hs --- a/test/suite/Snap/Internal/Http/Server/Tests.hs +++ b/test/suite/Snap/Internal/Http/Server/Tests.hs @@ -43,9 +43,11 @@ , testMultiRequest , testHttpRequest2 , testHttpRequest3 + , testHttpRequest3' , testHttpResponse1 , testHttpResponse2 , testHttpResponse3 + , testHttpResponse4 , testHttp1 , testHttp2 , testPartialParse @@ -270,9 +272,35 @@ assertEqual "parse body" (LC.fromChunks [samplePostBody3]) body +testHttpRequest3' :: Test +testHttpRequest3' = + testCase "HttpRequest3'" $ do + iter <- enumBS sampleRequest3' $ + do + r <- liftM fromJust $ rsm receiveRequest + se <- liftIO $ readIORef (rqBody r) + let (SomeEnumerator e) = se + b <- liftM fromWrap $ joinIM $ e copyingStream2stream + return (r,b) + + (req,body) <- run iter + + assertEqual "post param 1" + (rqParam "postparam1" req) + (Just ["1"]) + + assertEqual "post param 2" + (rqParam "postparam2" req) + (Just ["2"]) + + -- make sure the post body is still emitted + assertEqual "parse body" (LC.fromChunks [samplePostBody3]) body + + samplePostBody3 :: ByteString samplePostBody3 = "postparam1=1&postparam2=2" + sampleRequest3 :: ByteString sampleRequest3 = S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n" @@ -285,8 +313,20 @@ , samplePostBody3 ] +sampleRequest3' :: ByteString +sampleRequest3' = + S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n" + , "Content-Type: application/x-www-form-urlencoded; charset=UTF-8\r\n" + , "Content-Length: 25\r\n" + , "Multiheader: 1\r\n" + , "Multiheader: 2\r\n" + , "X-Random-Other-Header: foo\r\n bar\r\n" + , "\r\n" + , samplePostBody3 ] + + rsm :: ServerMonad a -> Iteratee IO a rsm = runServerMonad "localhost" "127.0.0.1" 80 "127.0.0.1" 58382 alog elog where @@ -376,6 +416,26 @@ emptyResponse { rspHttpVersion = (1,0) } rsp2 = rsp1 { rspContentLength = Nothing } rsp3 = setContentType "text/plain" $ (rsp2 { rspHttpVersion = (1,1) }) + + +testHttpResponse4 :: Test +testHttpResponse4 = testCase "HttpResponse4" $ do + let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run + + buf <- mkIterateeBuffer + + b <- run $ rsm $ + sendResponse rsp1 copyingStream2stream buf (return ()) onSendFile >>= + return . fromWrap . snd + + assertEqual "http response" (L.concat [ + "HTTP/1.0 304 Test\r\n" + , "Content-Length: 0\r\n\r\n" + ]) b + + where + rsp1 = setResponseStatus 304 "Test" $ + emptyResponse { rspHttpVersion = (1,0) } -- httpServe "127.0.0.1" 8080 "localhost" pongServer