snap-server 0.2.8.1 → 0.2.9
raw patch · 8 files changed
+256/−74 lines, 8 filesdep ~cerealdep ~hlibevdep ~snap-core
Dependency ranges changed: cereal, hlibev, snap-core
Files
- snap-server.cabal +4/−4
- src/Snap/Internal/Http/Parser.hs +98/−53
- src/Snap/Internal/Http/Server.hs +5/−2
- src/Snap/Internal/Http/Server/LibevBackend.hs +8/−10
- src/System/SendFile/FreeBSD.hsc +1/−0
- test/runTestsAndCoverage.sh +1/−1
- test/snap-server-testsuite.cabal +79/−4
- test/suite/Snap/Internal/Http/Server/Tests.hs +60/−0
snap-server.cabal view
@@ -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
src/Snap/Internal/Http/Parser.hs view
@@ -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-
src/Snap/Internal/Http/Server.hs view
@@ -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
src/Snap/Internal/Http/Server/LibevBackend.hs view
@@ -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
src/System/SendFile/FreeBSD.hsc view
@@ -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)
test/runTestsAndCoverage.sh view
@@ -4,7 +4,7 @@ SUITE=./dist/build/testsuite/testsuite -rm -f testsuite.tix+rm -f *.tix if [ ! -f $SUITE ]; then cat <<EOF
test/snap-server-testsuite.cabal view
@@ -40,7 +40,7 @@ old-locale, parallel > 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
test/suite/Snap/Internal/Http/Server/Tests.hs view
@@ -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