warp 3.1.9 → 3.1.10
raw patch · 21 files changed
+688/−229 lines, 21 filesdep +unordered-containersdep −old-locale
Dependencies added: unordered-containers
Dependencies removed: old-locale
Files
- ChangeLog.md +7/−0
- Network/Wai/Handler/Warp.hs +50/−2
- Network/Wai/Handler/Warp/Date.hs +18/−14
- Network/Wai/Handler/Warp/File.hs +187/−0
- Network/Wai/Handler/Warp/FileInfoCache.hs +106/−0
- Network/Wai/Handler/Warp/HTTP2/Receiver.hs +3/−2
- Network/Wai/Handler/Warp/HTTP2/Request.hs +4/−2
- Network/Wai/Handler/Warp/HTTP2/Sender.hs +4/−2
- Network/Wai/Handler/Warp/Header.hs +31/−25
- Network/Wai/Handler/Warp/Internal.hs +3/−0
- Network/Wai/Handler/Warp/Request.hs +15/−8
- Network/Wai/Handler/Warp/Response.hs +137/−102
- Network/Wai/Handler/Warp/Run.hs +26/−23
- Network/Wai/Handler/Warp/Settings.hs +7/−0
- Network/Wai/Handler/Warp/Types.hs +2/−0
- test/FileSpec.hs +45/−0
- test/HTTP.hs +9/−0
- test/ResponseSpec.hs +1/−46
- test/RunSpec.hs +25/−0
- test/head-response +1/−0
- warp.cabal +7/−3
ChangeLog.md view
@@ -1,3 +1,10 @@+## 3.1.10++* `setFileInfoCacheDuration`+* `setLogger`+* `FileInfo`/`getFileInfo`+* Fix: warp-tls strips out the Host request header [#478](https://github.com/yesodweb/wai/issues/478)+ ## 3.1.9 * Using the new priority queue based on PSQ provided by http2 lib again.
Network/Wai/Handler/Warp.hs view
@@ -66,6 +66,7 @@ , setTimeout , setManager , setFdCacheDuration+ , setFileInfoCacheDuration , setBeforeMainLoop , setNoParsePath , setInstallShutdownHandler@@ -77,6 +78,7 @@ , setProxyProtocolOptional , setSlowlorisSize , setHTTP2Disabled+ , setLogger -- ** Getters , getPort , getHost@@ -95,6 +97,8 @@ , InvalidRequest (..) -- * Utilities , pauseTimeout+ , FileInfo(..)+ , getFileInfo -- * Internal -- | The following APIs will be removed in Warp 3.2.0. Please use ones exported from Network.Wai.Handler.Warp.Internal. @@ -136,16 +140,18 @@ , module Network.Wai.Handler.Warp.Timeout ) where -import Control.Exception (SomeException)+import Control.Exception (SomeException, throwIO) import Data.ByteString (ByteString) import Data.Maybe (fromMaybe) import Data.Streaming.Network (HostPreference) import qualified Data.Vault.Lazy as Vault+import qualified Network.HTTP.Types as H import Network.Socket (SockAddr) import Network.Wai (Request, Response, vault) import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.Date import Network.Wai.Handler.Warp.FdCache+import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.Request import Network.Wai.Handler.Warp.Response@@ -219,10 +225,26 @@ -- Enabling this cache results in drastic performance improvement for file -- transfers. ----- Default value: since 3.0.13, default value is 0, was previously 10+-- Default value: 0, was previously 10+--+-- Since 3.0.13 setFdCacheDuration :: Int -> Settings -> Settings setFdCacheDuration x y = y { settingsFdCacheDuration = x } +-- | Cache duration time of file information in seconds. 0 means that the cache mechanism is not used.+--+-- The file information cache is an optimization that is useful for servers dealing with+-- static files. However, if files are being modified, it can cause incorrect+-- results in some cases. Therefore, we disable it by default. If you know that+-- your files will be static or you prefer performance to file consistency,+-- it's recommended to turn this on; a reasonable value for those cases is 10.+-- Enabling this cache results in drastic performance improvement for file+-- transfers.+--+-- Default value: 0+setFileInfoCacheDuration :: Int -> Settings -> Settings+setFileInfoCacheDuration x y = y { settingsFileInfoCacheDuration = x }+ -- | Code to run after the listening socket is ready but before entering -- the main event loop. Useful for signaling to tests that they can start -- running, or to drop permissions after binding to a restricted port.@@ -363,6 +385,13 @@ setHTTP2Disabled :: Settings -> Settings setHTTP2Disabled y = y { settingsHTTP2Enabled = False } +-- | Setting a log function.+--+-- Since 3.X.X+setLogger :: (Request -> H.Status -> Maybe Integer -> IO ())+ -> Settings -> Settings+setLogger lgr y = y { settingsLogger = lgr }+ -- | Explicitly pause the slowloris timeout. -- -- This is useful for cases where you partially consume a request body. For@@ -371,3 +400,22 @@ -- Since 3.0.10 pauseTimeout :: Request -> IO () pauseTimeout = fromMaybe (return ()) . Vault.lookup pauseTimeoutKey . vault++-- | Getting file information of the target file.+--+-- This function first uses a stat(2) or similar system call+-- to obtain information of the target file, then registers+-- it into the internal cache.+-- From the next time, the information is obtained+-- from the cache. This reduces the overhead to call the system call.+-- The internal cache is refreshed every duration specified by+-- 'setFileInfoCacheDuration'.+--+-- This function throws an 'IO' exception if the information is not+-- available. For instance, the target file does not exist.+-- If this function is used an a Request generated by a WAI+-- backend besides Warp, it also throws an 'IO' exception.+--+-- Since 3.1.10+getFileInfo :: Request -> FilePath -> IO FileInfo+getFileInfo = fromMaybe (\_ -> throwIO (userError "getFileInfo")) . Vault.lookup getFileInfoKey . vault
Network/Wai/Handler/Warp/Date.hs view
@@ -5,6 +5,9 @@ , getDate , DateCache , GMTDate+#if WINDOWS+ , uToH+#endif ) where #if __GLASGOW_HASKELL__ < 709@@ -12,16 +15,13 @@ #endif import Control.AutoUpdate (defaultUpdateSettings, updateAction, mkAutoUpdate) import Data.ByteString.Char8+import Network.HTTP.Date #if WINDOWS-import Data.Time (formatTime, getCurrentTime)-# if MIN_VERSION_time(1,5,0)-import Data.Time (defaultTimeLocale)-# else-import System.Locale (defaultTimeLocale)-# endif+import Data.Time (UTCTime, formatTime, getCurrentTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)+import Foreign.C.Types (CTime(..)) #else-import Network.HTTP.Date import System.Posix (epochTime) #endif @@ -36,17 +36,21 @@ withDateCache action = initialize >>= action initialize :: IO DateCache-initialize = mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentGMTDate }+initialize = mkAutoUpdate defaultUpdateSettings {+ updateAction = formatHTTPDate <$> getCurrentHTTPDate+ } --- | Getting 'GMTDate' based on 'DateCache'.+-- | Getting current 'GMTDate' based on 'DateCache'. getDate :: DateCache -> IO GMTDate getDate = id -getCurrentGMTDate :: IO GMTDate #ifdef WINDOWS-getCurrentGMTDate = formatDate <$> getCurrentTime- where- formatDate = pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"+uToH :: UTCTime -> HTTPDate+uToH = epochTimeToHTTPDate . CTime . truncate . utcTimeToPOSIXSeconds++getCurrentHTTPDate :: IO HTTPDate+getCurrentHTTPDate = uToH <$> getCurrentTime #else-getCurrentGMTDate = formatHTTPDate . epochTimeToHTTPDate <$> epochTime+getCurrentHTTPDate :: IO HTTPDate+getCurrentHTTPDate = epochTimeToHTTPDate <$> epochTime #endif
+ Network/Wai/Handler/Warp/File.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}++module Network.Wai.Handler.Warp.File (+ RspFileInfo(..)+ , conditionalRequest+ , addContentHeadersForFilePart+ ) where++import Control.Applicative ((<|>))+import Data.Array ((!))+import Data.ByteString (ByteString)+import qualified Data.ByteString as B hiding (pack)+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Char8 as B (pack, readInteger)+import qualified Data.ByteString.Lazy as L+import Network.HTTP.Date+import qualified Network.HTTP.Types as H+import qualified Network.HTTP.Types.Header as H+import Network.Wai+import qualified Network.Wai.Handler.Warp.FileInfoCache as I+import Network.Wai.Handler.Warp.Header+import Numeric (showInt)++----------------------------------------------------------------++data RspFileInfo = WithoutBody H.Status+ | WithBody H.Status H.ResponseHeaders Integer Integer+ deriving (Eq,Show)++----------------------------------------------------------------++conditionalRequest :: I.FileInfo+ -> H.ResponseHeaders -> IndexedHeader+ -> RspFileInfo+conditionalRequest finfo hs0 reqidx = case condition of+ nobody@(WithoutBody _) -> nobody+ WithBody s _ off len -> let hs = (H.hLastModified,date) :+ addContentHeaders hs0 off len size+ in WithBody s hs off len+ where+ mtime = I.fileInfoTime finfo+ size = I.fileInfoSize finfo+ date = I.fileInfoDate finfo+ mcondition = ifmodified reqidx size mtime+ <|> ifunmodified reqidx size mtime+ <|> ifrange reqidx size mtime+ condition = case mcondition of+ Nothing -> unconditional reqidx size+ Just x -> x++----------------------------------------------------------------++ifModifiedSince :: IndexedHeader -> Maybe HTTPDate+ifModifiedSince reqidx = reqidx ! fromEnum ReqIfModifiedSince >>= parseHTTPDate++ifUnmodifiedSince :: IndexedHeader -> Maybe HTTPDate+ifUnmodifiedSince reqidx = reqidx ! fromEnum ReqIfUnmodifiedSince >>= parseHTTPDate++ifRange :: IndexedHeader -> Maybe HTTPDate+ifRange reqidx = reqidx ! fromEnum ReqIfRange >>= parseHTTPDate++----------------------------------------------------------------++ifmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo+ifmodified reqidx size mtime = do+ date <- ifModifiedSince reqidx+ return $ if date /= mtime+ then unconditional reqidx size+ else WithoutBody H.notModified304++ifunmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo+ifunmodified reqidx size mtime = do+ date <- ifUnmodifiedSince reqidx+ return $ if date == mtime+ then unconditional reqidx size+ else WithoutBody H.preconditionFailed412++ifrange :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo+ifrange reqidx size mtime = do+ date <- ifRange reqidx+ rng <- reqidx ! fromEnum ReqRange+ return $ if date == mtime+ then parseRange rng size+ else WithBody H.ok200 [] 0 size++unconditional :: IndexedHeader -> Integer -> RspFileInfo+unconditional reqidx size = case reqidx ! fromEnum ReqRange of+ Nothing -> WithBody H.ok200 [] 0 size+ Just rng -> parseRange rng size++----------------------------------------------------------------++parseRange :: ByteString -> Integer -> RspFileInfo+parseRange rng size = case parseByteRanges rng of+ Nothing -> WithoutBody H.requestedRangeNotSatisfiable416+ Just [] -> WithoutBody H.requestedRangeNotSatisfiable416+ Just (r:_) -> let (!beg, !end) = checkRange r size+ !len = end - beg + 1+ s = if beg == 0 && end == size - 1 then+ H.ok200+ else+ H.partialContent206+ in WithBody s [] beg len++checkRange :: H.ByteRange -> Integer -> (Integer, Integer)+checkRange (H.ByteRangeFrom beg) size = (beg, size - 1)+checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end)+checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1)++-- | Parse the value of a Range header into a 'H.ByteRanges'.+parseByteRanges :: B.ByteString -> Maybe H.ByteRanges+parseByteRanges bs1 = do+ bs2 <- stripPrefix "bytes=" bs1+ (r, bs3) <- range bs2+ ranges (r:) bs3+ where+ range bs2 = do+ (i, bs3) <- B.readInteger bs2+ if i < 0 -- has prefix "-" ("-0" is not valid, but here treated as "0-")+ then Just (H.ByteRangeSuffix (negate i), bs3)+ else do+ bs4 <- stripPrefix "-" bs3+ case B.readInteger bs4 of+ Just (j, bs5) | j >= i -> Just (H.ByteRangeFromTo i j, bs5)+ _ -> Just (H.ByteRangeFrom i, bs4)+ ranges front bs3+ | B.null bs3 = Just (front [])+ | otherwise = do+ bs4 <- stripPrefix "," bs3+ (r, bs5) <- range bs4+ ranges (front . (r:)) bs5++ stripPrefix x y+ | x `B.isPrefixOf` y = Just (B.drop (B.length x) y)+ | otherwise = Nothing++----------------------------------------------------------------++-- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header'+-- for the range specified.+contentRangeHeader :: Integer -> Integer -> Integer -> H.Header+contentRangeHeader beg end total = (+#if MIN_VERSION_http_types(0,9,0)+ H.hContentRange+#else+ "Content-Range"+#endif+ , range)+ where+ range = B.pack+ -- building with ShowS+ $ 'b' : 'y': 't' : 'e' : 's' : ' '+ : (if beg > end then ('*':) else+ showInt beg+ . ('-' :)+ . showInt end)+ ( '/'+ : showInt total "")++addContentHeaders :: H.ResponseHeaders -> Integer -> Integer -> Integer -> H.ResponseHeaders+addContentHeaders hs off len size = hs''+ where+ contentRange = contentRangeHeader off (off + len - 1) size+ lengthBS = L.toStrict $ B.toLazyByteString $ B.integerDec len+ hs' = (H.hContentLength, lengthBS):(+#if MIN_VERSION_http_types(0,9,0)+ H.hAcceptRanges+#else+ "Accept-Ranges"+#endif+ , "bytes"):hs+ hs'' = if len == size then hs' else contentRange:hs'++-- |+--+-- >>> addContentHeadersForFilePart [] (FilePart 2 10 16)+-- [("Content-Range","bytes 2-11/16"),("Content-Length","10"),("Accept-Ranges","bytes")]+-- >>> addContentHeadersForFilePart [] (FilePart 0 16 16)+-- [("Content-Length","16"),("Accept-Ranges","bytes")]+addContentHeadersForFilePart :: H.ResponseHeaders -> FilePart -> H.ResponseHeaders+addContentHeadersForFilePart hs part = addContentHeaders hs off len size+ where+ off = filePartOffset part+ len = filePartByteCount part+ size = filePartFileSize part
+ Network/Wai/Handler/Warp/FileInfoCache.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE RecordWildCards, CPP #-}++module Network.Wai.Handler.Warp.FileInfoCache (+ FileInfo(..)+ , withFileInfoCache+ , getInfo -- test purpose only+ ) where++import Control.Exception as E+import Control.Monad (void)+import Control.Reaper+import Data.ByteString (ByteString)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as M+import Network.HTTP.Date+import System.PosixCompat.Files++#if WINDOWS+import Data.Time (UTCTime)+import Network.Wai.Handler.Warp.Date (uToH)+#endif++----------------------------------------------------------------++-- | File information.+data FileInfo = FileInfo {+ fileInfoName :: !FilePath+ , fileInfoSize :: !Integer+ , fileInfoTime :: HTTPDate -- ^ Modification time+ , fileInfoDate :: ByteString -- ^ Modification time in the GMT format+ } deriving (Eq, Show)++data Entry = Negative | Positive FileInfo+type Cache = HashMap FilePath Entry+type FileInfoCache = Reaper Cache (FilePath,Entry)++----------------------------------------------------------------++-- | Getting the file information corresponding to the file.+getInfo :: FilePath -> IO FileInfo+getInfo path = do+ fs <- getFileStatus path -- file access+ let regular = not (isDirectory fs)+ readable = fileMode fs `intersectFileModes` ownerReadMode /= 0+ if regular && readable then do+ let time = epochTimeToHTTPDate $ modificationTime fs+ date = formatHTTPDate time+ size = fromIntegral $ fileSize fs+ info = FileInfo {+ fileInfoName = path+ , fileInfoSize = size+ , fileInfoTime = time+ , fileInfoDate = date+ }+ return info+ else+ throwIO (userError "FileInfoCache:getInfo")++----------------------------------------------------------------++getAndRegisterInfo :: FileInfoCache -> FilePath -> IO FileInfo+getAndRegisterInfo reaper@Reaper{..} path = do+ cache <- reaperRead+ case M.lookup path cache of+ Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo")+ Just (Positive x) -> return x+ Nothing -> positive reaper path `E.onException` negative reaper path++positive :: FileInfoCache -> FilePath -> IO FileInfo+positive Reaper{..} path = do+ info <- getInfo path+ reaperAdd (path, Positive info)+ return info++negative :: FileInfoCache -> FilePath -> IO FileInfo+negative Reaper{..} path = do+ reaperAdd (path,Negative)+ throwIO (userError "FileInfoCache:negative")++----------------------------------------------------------------++-- | Creating a file information cache+-- and executing the action in the second argument.+-- The first argument is a cache duration in second.+withFileInfoCache :: Int -> ((FilePath -> IO FileInfo) -> IO a) -> IO a+withFileInfoCache 0 action = action getInfo+withFileInfoCache duration action = E.bracket (initialize duration)+ terminate+ (\c -> action (getAndRegisterInfo c))++initialize :: Int -> IO FileInfoCache+initialize duration = mkReaper settings+ where+ settings = defaultReaperSettings {+ reaperAction = override+ , reaperDelay = duration * 1000000+ , reaperCons = uncurry M.insert+ , reaperNull = M.null+ , reaperEmpty = M.empty+ }++override :: Cache -> IO (Cache -> Cache)+override _ = return $ const M.empty++terminate :: FileInfoCache -> IO ()+terminate x = void $ reaperStop x
Network/Wai/Handler/Warp/HTTP2/Receiver.hs view
@@ -246,7 +246,7 @@ let !siz = BS.length frag return $ Open $ Continued [frag] siz 1 endOfStream pri -stream FrameHeaders header@FrameHeader{flags} bs _ s@(Open (Body q)) _ = do+stream FrameHeaders header@FrameHeader{flags} bs _ (Open (Body q)) _ = do -- trailer is not supported. -- let's read and ignore it. HeadersFrame _ _ <- guardIt $ decodeHeadersFrame header bs@@ -255,7 +255,8 @@ atomically $ writeTQueue q "" return HalfClosed else- return s+ -- we don't support continuation here.+ E.throwIO $ ConnectionError ProtocolError "continuation in trailer is not supported" stream FrameData header@FrameHeader{flags,payloadLength,streamId}
Network/Wai/Handler/Warp/HTTP2/Request.hs view
@@ -55,7 +55,9 @@ , pathInfo = H.decodePathSegments path , rawQueryString = query , queryString = H.parseQuery query- , requestHeaders = hdr+ , requestHeaders = case ma of+ Nothing -> hdr+ Just h -> (mk "host", h) : hdr , isSecure = True , remoteHost = addr , requestBody = body@@ -110,7 +112,7 @@ else Nothing | k == "content-length"- = normal kvs (p { contentLen = Just v },b)+ = normal kvs (p { contentLen = Just v }, b . ((mk k,v) :)) | k == "host" = if isJust (colonAuth p) then normal kvs (p,b) else
Network/Wai/Handler/Warp/HTTP2/Sender.hs view
@@ -310,8 +310,10 @@ Just (SFile path part) -> do (leftover, len) <- runStreamFile ii buf room path part let !total' = total + len- return (leftover, Nothing, total')- -- TODO if file part is done, go back to loop+ case leftover of+ LZero -> loop (buf `plusPtr` len) (room - len) total'+ _ -> return (leftover, Nothing, total')+ Just SFlush -> return (LZero, Nothing, total) Just (SFinish trailers) -> return (LZero, Just trailers, total)
Network/Wai/Handler/Warp/Header.hs view
@@ -17,29 +17,35 @@ indexRequestHeader :: RequestHeaders -> IndexedHeader indexRequestHeader hdr = traverseHeader hdr requestMaxIndex requestKeyIndex -idxContentLength,idxTransferEncoding,idxExpect :: Int-idxConnection,idxRange,idxHost :: Int-idxContentLength = 0-idxTransferEncoding = 1-idxExpect = 2-idxConnection = 3-idxRange = 4-idxHost = 5+data RequestHeaderIndex = ReqContentLength+ | ReqTransferEncoding+ | ReqExpect+ | ReqConnection+ | ReqRange+ | ReqHost+ | ReqIfModifiedSince+ | ReqIfUnmodifiedSince+ | ReqIfRange+ deriving (Enum,Bounded) -- | The size for 'IndexedHeader' for HTTP Request. -- From 0 to this corresponds to \"Content-Length\", \"Transfer-Encoding\",--- \"Expect\", \"Connection\", \"Range\", and \"Host\".+-- \"Expect\", \"Connection\", \"Range\", \"Host\",+-- \"If-Modified-Since\", \"If-Unmodified-Since\" and \"If-Range\". requestMaxIndex :: Int-requestMaxIndex = 5+requestMaxIndex = fromEnum (maxBound :: RequestHeaderIndex) requestKeyIndex :: HeaderName -> Int-requestKeyIndex "content-length" = idxContentLength-requestKeyIndex "transfer-encoding" = idxTransferEncoding-requestKeyIndex "expect" = idxExpect-requestKeyIndex "connection" = idxConnection-requestKeyIndex "range" = idxRange-requestKeyIndex "host" = idxHost-requestKeyIndex _ = -1+requestKeyIndex "content-length" = fromEnum ReqContentLength+requestKeyIndex "transfer-encoding" = fromEnum ReqTransferEncoding+requestKeyIndex "expect" = fromEnum ReqExpect+requestKeyIndex "connection" = fromEnum ReqConnection+requestKeyIndex "range" = fromEnum ReqRange+requestKeyIndex "host" = fromEnum ReqHost+requestKeyIndex "if-modified-since" = fromEnum ReqIfModifiedSince+requestKeyIndex "if-unmodified-since" = fromEnum ReqIfUnmodifiedSince+requestKeyIndex "if-range" = fromEnum ReqIfRange+requestKeyIndex _ = -1 defaultIndexRequestHeader :: IndexedHeader defaultIndexRequestHeader = array (0,requestMaxIndex) [(i,Nothing)|i<-[0..requestMaxIndex]]@@ -49,19 +55,19 @@ indexResponseHeader :: ResponseHeaders -> IndexedHeader indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex -idxServer, idxDate :: Int---idxContentLength = 0-idxServer = 1-idxDate = 2+data ResponseHeaderIndex = ResContentLength+ | ResServer+ | ResDate+ deriving (Enum,Bounded) -- | The size for 'IndexedHeader' for HTTP Response. responseMaxIndex :: Int-responseMaxIndex = 2+responseMaxIndex = fromEnum (maxBound :: ResponseHeaderIndex) responseKeyIndex :: HeaderName -> Int-responseKeyIndex "content-length" = idxContentLength-responseKeyIndex "server" = idxServer-responseKeyIndex "date" = idxDate+responseKeyIndex "content-length" = fromEnum ResContentLength+responseKeyIndex "server" = fromEnum ResServer+responseKeyIndex "date" = fromEnum ResDate responseKeyIndex _ = -1 ----------------------------------------------------------------
Network/Wai/Handler/Warp/Internal.hs view
@@ -67,6 +67,8 @@ , module Network.Wai.Handler.Warp.Timeout -- * File descriptor cache , module Network.Wai.Handler.Warp.FdCache+ -- * File information cache+ , module Network.Wai.Handler.Warp.FileInfoCache -- * Date , module Network.Wai.Handler.Warp.Date -- * Request and response@@ -78,6 +80,7 @@ import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.Date import Network.Wai.Handler.Warp.FdCache+import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.Recv import Network.Wai.Handler.Warp.Request
Network/Wai/Handler/Warp/Request.hs view
@@ -7,6 +7,7 @@ recvRequest , headerLines , pauseTimeoutKey+ , getFileInfoKey ) where import qualified Control.Concurrent as Conc (yield)@@ -21,6 +22,7 @@ import Network.Socket (SockAddr) import Network.Wai import Network.Wai.Handler.Warp.Conduit+import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.ReadInt import Network.Wai.Handler.Warp.RequestHeader@@ -61,9 +63,9 @@ hdrlines <- headerLines src (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines let idxhdr = indexRequestHeader hdr- expect = idxhdr ! idxExpect- cl = idxhdr ! idxContentLength- te = idxhdr ! idxTransferEncoding+ expect = idxhdr ! fromEnum ReqExpect+ cl = idxhdr ! fromEnum ReqContentLength+ te = idxhdr ! fromEnum ReqTransferEncoding handle100Continue = handleExpect conn httpversion expect (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te -- body producing function which will produce '100-continue', if needed@@ -81,16 +83,17 @@ , isSecure = False , remoteHost = addr , requestBody = rbody'- , vault = Vault.insert pauseTimeoutKey- (Timeout.pause th)- Vault.empty+ , vault = vaultValue , requestBodyLength = bodyLength- , requestHeaderHost = idxhdr ! idxHost- , requestHeaderRange = idxhdr ! idxRange+ , requestHeaderHost = idxhdr ! fromEnum ReqHost+ , requestHeaderRange = idxhdr ! fromEnum ReqRange } return (req, remainingRef, idxhdr, rbodyFlush) where th = threadHandle ii+ vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)+ $ Vault.insert getFileInfoKey (fileInfo ii)+ Vault.empty ---------------------------------------------------------------- @@ -278,3 +281,7 @@ pauseTimeoutKey :: Vault.Key (IO ()) pauseTimeoutKey = unsafePerformIO Vault.newKey {-# NOINLINE pauseTimeoutKey #-}++getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo)+getFileInfoKey = unsafePerformIO Vault.newKey+{-# NOINLINE getFileInfoKey #-}
Network/Wai/Handler/Warp/Response.hs view
@@ -7,7 +7,6 @@ module Network.Wai.Handler.Warp.Response ( sendResponse , sanitizeHeaderValue -- for testing- , fileRange -- for testing , warpVersion , addDate , addServer@@ -26,7 +25,7 @@ #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif-import Control.Exception+import qualified Control.Exception as E import Control.Monad (unless, when) import Data.Array ((!)) import Data.ByteString (ByteString)@@ -57,9 +56,11 @@ import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer) import qualified Network.Wai.Handler.Warp.Date as D import qualified Network.Wai.Handler.Warp.FdCache as F+import Network.Wai.Handler.Warp.File import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.IO (toBufIOWith) import Network.Wai.Handler.Warp.ResponseHeader+import Network.Wai.Handler.Warp.Settings import qualified Network.Wai.Handler.Warp.Timeout as T import Network.Wai.Handler.Warp.Types import Network.Wai.Internal@@ -75,36 +76,14 @@ ---------------------------------------------------------------- -fileRange :: H.Status -> H.ResponseHeaders -> FilePath- -> Maybe FilePart -> Maybe HeaderValue- -> IO (Either IOException- (H.Status, H.ResponseHeaders, Integer, Integer))-fileRange s0 hs0 path Nothing mRange =- fmap (fileRangeSized s0 hs0 Nothing mRange) <$> tryGetFileSize path-fileRange s0 hs0 _ mPart@(Just part) mRange =- return . Right $ fileRangeSized s0 hs0 mPart mRange size- where- size = filePartFileSize part--fileRangeSized :: H.Status -> H.ResponseHeaders- -> Maybe FilePart -> Maybe HeaderValue -> Integer- -> (H.Status, H.ResponseHeaders, Integer, Integer)-fileRangeSized s0 hs0 mPart mRange fileSize = (s, hs, beg, len)- where- part = fromMaybe (chooseFilePart fileSize mRange) mPart- beg = filePartOffset part- len = filePartByteCount part- (s, hs) = adjustForFilePart s0 hs0 $ FilePart beg len fileSize------------------------------------------------------------------- -- | Sending a HTTP response to 'Connection' according to 'Response'. ----- Applications/middlewares MUST specify a proper 'H.ResponseHeaders'.+-- Applications/middlewares MUST provide a proper 'H.ResponseHeaders'. -- so that inconsistency does not happen. -- No header is deleted by this function. ----- Especially, Applications/middlewares MUST take care of+-- Especially, Applications/middlewares MUST provide a proper+-- Content-Type. They MUST NOT provide -- Content-Length, Content-Range, and Transfer-Encoding -- because they are inserted, when necessary, -- regardless they already exist.@@ -116,22 +95,6 @@ -- -- There are three basic APIs to create 'Response': ----- ['responseFile' :: 'H.Status' -> 'H.ResponseHeaders' -> 'FilePath' -> 'Maybe' 'FilePart' -> 'Response']--- HTTP response body is sent by sendfile() for GET method.--- HTTP response body is not sent by HEAD method.--- Applications are categorized into simple and sophisticated.--- Simple applications should specify 'Nothing' to--- 'Maybe' 'FilePart'. The size of the specified file is obtained--- by disk access. Then Range is handled.--- Sophisticated applications should specify 'Just' to--- 'Maybe' 'FilePart'. They should treat Range (and If-Range) by--- themselves. In both cases,--- Content-Length and Content-Range (if necessary) are automatically--- added into the HTTP response header.--- If Content-Length and Content-Range exist in the HTTP response header,--- they would cause inconsistency.--- Status is also changed to 206 (Partial Content) if necessary.--- -- ['responseBuilder' :: 'H.Status' -> 'H.ResponseHeaders' -> 'Builder' -> 'Response'] -- HTTP response body is created from 'Builder'. -- Transfer-Encoding: chunked is used in HTTP/1.1.@@ -142,8 +105,29 @@ -- -- ['responseRaw' :: ('IO' 'ByteString' -> ('ByteString' -> 'IO' ()) -> 'IO' ()) -> 'Response' -> 'Response'] -- No header is added and no Transfer-Encoding: is applied.+--+-- ['responseFile' :: 'H.Status' -> 'H.ResponseHeaders' -> 'FilePath' -> 'Maybe' 'FilePart' -> 'Response']+-- HTTP response body is sent (by sendfile(), if possible) for GET method.+-- HTTP response body is not sent by HEAD method.+-- Content-Length and Content-Range are automatically+-- added into the HTTP response header if necessary.+-- If Content-Length and Content-Range exist in the HTTP response header,+-- they would cause inconsistency.+-- \"Accept-Ranges: bytes\" is also inserted.+--+-- Applications are categorized into simple and sophisticated.+-- Sophisticated applications should specify 'Just' to+-- 'Maybe' 'FilePart'. They should treat the conditional request+-- by themselves. A proper 'Status' (200 or 206) must be provided.+--+-- Simple applications should specify 'Nothing' to+-- 'Maybe' 'FilePart'. The size of the specified file is obtained+-- by disk access or from the file infor cache.+-- If-Modified-Since, If-Unmodified-Since, If-Range and Range+-- are processed. Since a proper status is chosen, 'Status' is+-- ignored. Last-Modified is inserted. -sendResponse :: ByteString -- ^ default server value+sendResponse :: Settings -> Connection -> InternalInfo -> Request -- ^ HTTP request.@@ -151,35 +135,48 @@ -> IO ByteString -- ^ source from client, for raw response -> Response -- ^ HTTP response including status code and response header. -> IO Bool -- ^ Returing True if the connection is persistent.-sendResponse defServer conn ii req reqidxhdr src response = do+sendResponse settings conn ii req reqidxhdr src response = do hs <- addServerAndDate hs0 if hasBody s then do- -- HEAD comes here even if it does not have body.- sendRsp conn mfdc ver s hs rsp+ -- The response to HEAD does not have body.+ -- But to handle the conditional requests defined RFC 7232 and+ -- to generate appropriate content-length, content-range,+ -- and status, the response to HEAD is processed here.+ --+ -- See definition of rsp below for proper body stripping.+ (ms, mlen) <- sendRsp conn ii ver s hs rsp+ case ms of+ Nothing -> return ()+ Just realStatus -> logger req realStatus mlen T.tickle th return ret else do- sendResponseNoBody conn ver s hs+ _ <- sendRsp conn ii ver s hs RspNoBody+ logger req s Nothing T.tickle th return isPersist where+ defServer = settingsServerName settings+ logger = settingsLogger settings ver = httpVersion req s = responseStatus response hs0 = sanitizeHeaders $ responseHeaders response rspidxhdr = indexResponseHeader hs0 th = threadHandle ii dc = dateCacher ii- mfdc = fdCacher ii addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr- mRange = reqidxhdr ! idxRange (isPersist,isChunked0) = infoFromRequest req reqidxhdr isChunked = not isHead && isChunked0 (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr (isPersist,isChunked) isHead = requestMethod req == H.methodHead rsp = case response of- ResponseFile _ _ path mPart -> RspFile path mPart mRange isHead (T.tickle th)- ResponseBuilder _ _ b -> RspBuilder b needsChunked- ResponseStream _ _ fb -> RspStream fb needsChunked th+ ResponseFile _ _ path mPart -> RspFile path mPart reqidxhdr isHead (T.tickle th)+ ResponseBuilder _ _ b+ | isHead -> RspNoBody+ | otherwise -> RspBuilder b needsChunked+ ResponseStream _ _ fb+ | isHead -> RspNoBody+ | otherwise -> RspStream fb needsChunked th ResponseRaw raw _ -> RspRaw raw src (T.tickle th) ret = case response of ResponseFile {} -> isPersist@@ -214,7 +211,8 @@ ---------------------------------------------------------------- -data Rsp = RspFile FilePath (Maybe FilePart) (Maybe HeaderValue) Bool (IO ())+data Rsp = RspNoBody+ | RspFile FilePath (Maybe FilePart) IndexedHeader Bool (IO ()) | RspBuilder Builder Bool | RspStream StreamingBody Bool T.Handle | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString) (IO ())@@ -222,50 +220,23 @@ ---------------------------------------------------------------- sendRsp :: Connection- -> Maybe F.MutableFdCache+ -> InternalInfo -> H.HttpVersion -> H.Status -> H.ResponseHeaders -> Rsp- -> IO ()-sendRsp conn mfdc ver s0 hs0 (RspFile path mPart mRange isHead hook) = do- ex <- fileRange s0 hs0 path mPart mRange- case ex of- Left _ex ->-#ifdef WARP_DEBUG- print _ex >>-#endif- sendRsp conn mfdc ver s2 hs2 (RspBuilder body True)- Right (s, hs, beg, len)- | len >= 0 ->- if isHead then- sendRsp conn mfdc ver s hs (RspBuilder mempty False)- else do- lheader <- composeHeader ver s hs-#ifdef WINDOWS- let fid = FileId path Nothing- hook' = hook-#else- (mfd, hook') <- case mfdc of- -- settingsFdCacheDuration is 0- Nothing -> return (Nothing, hook)- Just fdc -> do- (fd, fresher) <- F.getFd fdc path- return (Just fd, hook >> fresher)- let fid = FileId path mfd-#endif- connSendFile conn fid beg len hook' [lheader]- | otherwise ->- sendRsp conn mfdc ver H.status416- (filter (\(k, _) -> k /= "content-length") hs)- (RspBuilder mempty True)- where- s2 = H.status404- hs2 = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0- body = byteString "File not found"+ -> IO (Maybe H.Status, Maybe Integer) ---------------------------------------------------------------- +sendRsp conn _ ver s hs RspNoBody = do+ -- Not adding Content-Length.+ -- User agents treats it as Content-Length: 0.+ composeHeader ver s hs >>= connSendAll conn+ return (Just s, Nothing)++----------------------------------------------------------------+ sendRsp conn _ ver s hs (RspBuilder body needsChunked) = do header <- composeHeaderBuilder ver s hs needsChunked let hdrBdy@@ -275,6 +246,7 @@ buffer = connWriteBuffer conn size = connBufferSize conn toBufIOWith buffer size (connSendAll conn) hdrBdy+ return (Just s, Nothing) -- fixme: can we tell the actual sent bytes? ---------------------------------------------------------------- @@ -298,11 +270,13 @@ when needsChunked $ send chunkedTransferTerminator mbs <- finish maybe (return ()) (sendFragment conn th) mbs+ return (Just s, Nothing) -- fixme: can we tell the actual sent bytes? ---------------------------------------------------------------- -sendRsp conn _ _ _ _ (RspRaw withApp src tickle) =+sendRsp conn _ _ _ _ (RspRaw withApp src tickle) = do withApp recv send+ return (Nothing, Nothing) where recv = do bs <- src@@ -312,16 +286,77 @@ ---------------------------------------------------------------- -sendResponseNoBody :: Connection- -> H.HttpVersion- -> H.Status- -> H.ResponseHeaders- -> IO ()-sendResponseNoBody conn ver s hs = composeHeader ver s hs >>= connSendAll conn+-- Sophisticated WAI applications.+-- We respect s0. s0 MUST be a proper value.+sendRsp conn ii ver s0 hs0 (RspFile path (Just part) _ isHead hook) =+ sendRspFile2XX conn ii ver s0 hs path beg len isHead hook+ where+ beg = filePartOffset part+ len = filePartByteCount part+ hs = addContentHeadersForFilePart hs0 part ----------------------------------------------------------------++-- Simple WAI applications.+-- Status is ignored+sendRsp conn ii ver _ hs0 (RspFile path Nothing idxhdr isHead hook) = do+ efinfo <- E.try $ fileInfo ii path+ case efinfo of+ Left (_ex :: E.IOException) ->+#ifdef WARP_DEBUG+ print _ex >>+#endif+ sendRspFile404 conn ii ver hs0+ Right finfo -> case conditionalRequest finfo hs0 idxhdr of+ WithoutBody s -> sendRsp conn ii ver s hs0 RspNoBody+ WithBody s hs beg len -> sendRspFile2XX conn ii ver s hs path beg len isHead hook+ ---------------------------------------------------------------- +sendRspFile2XX :: Connection+ -> InternalInfo+ -> H.HttpVersion+ -> H.Status+ -> H.ResponseHeaders+ -> FilePath+ -> Integer+ -> Integer+ -> Bool+ -> IO ()+ -> IO (Maybe H.Status, Maybe Integer)+sendRspFile2XX conn ii ver s hs path beg len isHead hook+ | isHead = sendRsp conn ii ver s hs RspNoBody+ | otherwise = do+ lheader <- composeHeader ver s hs+#ifdef WINDOWS+ let fid = FileId path Nothing+ hook' = hook+#else+ (mfd, hook') <- case fdCacher ii of+ -- settingsFdCacheDuration is 0+ Nothing -> return (Nothing, hook)+ Just fdc -> do+ (fd, fresher) <- F.getFd fdc path+ return (Just fd, hook >> fresher)+ let fid = FileId path mfd+#endif+ connSendFile conn fid beg len hook' [lheader]+ return (Just s, Just len)++sendRspFile404 :: Connection+ -> InternalInfo+ -> H.HttpVersion+ -> H.ResponseHeaders+ -> IO (Maybe H.Status, Maybe Integer)+sendRspFile404 conn ii ver hs0 = sendRsp conn ii ver s hs (RspBuilder body True)+ where+ s = H.notFound404+ hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0+ body = byteString "File not found"++----------------------------------------------------------------+----------------------------------------------------------------+ -- | Use 'connSendAll' to send this data while respecting timeout rules. sendFragment :: Connection -> T.Handle -> ByteString -> IO () sendFragment Connection { connSendAll = send } th bs = do@@ -345,7 +380,7 @@ | otherwise = checkPersist10 conn where ver = httpVersion req- conn = reqidxhdr ! idxConnection+ conn = reqidxhdr ! fromEnum ReqConnection checkPersist11 (Just x) | CI.foldCase x == "close" = False checkPersist11 _ = True@@ -370,7 +405,7 @@ where needsChunked = isChunked && not hasLength isKeepAlive = isPersist && (isChunked || hasLength)- hasLength = isJust $ rspidxhdr ! idxContentLength+ hasLength = isJust $ rspidxhdr ! fromEnum ResContentLength ---------------------------------------------------------------- @@ -391,7 +426,7 @@ #endif addDate :: D.DateCache -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders-addDate dc rspidxhdr hdrs = case rspidxhdr ! idxDate of+addDate dc rspidxhdr hdrs = case rspidxhdr ! fromEnum ResDate of Nothing -> do gmtdate <- D.getDate dc return $ (H.hDate, gmtdate) : hdrs@@ -404,7 +439,7 @@ warpVersion = showVersion Paths_warp.version addServer :: HeaderValue -> IndexedHeader -> H.ResponseHeaders -> H.ResponseHeaders-addServer serverName rspidxhdr hdrs = case rspidxhdr ! idxServer of+addServer serverName rspidxhdr hdrs = case rspidxhdr ! fromEnum ResServer of Nothing -> (H.hServer, serverName) : hdrs _ -> hdrs
Network/Wai/Handler/Warp/Run.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} module Network.Wai.Handler.Warp.Run where@@ -29,6 +30,7 @@ import Network.Wai.Handler.Warp.Counter import qualified Network.Wai.Handler.Warp.Date as D import qualified Network.Wai.Handler.Warp.FdCache as F+import qualified Network.Wai.Handler.Warp.FileInfoCache as I import Network.Wai.Handler.Warp.HTTP2 (http2, isHTTP2) import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.ReadInt@@ -237,13 +239,18 @@ runServeSettingsConnectionMakerSecure set getConnMaker serveConn = do settingsBeforeMainLoop set counter <- newCounter-- D.withDateCache $ \dc ->- F.withFdCache fdCacheDurationInSeconds $ \fc ->- withTimeoutManager $ \tm ->- acceptConnection set getConnMaker serveConn dc fc tm counter+ withII $ acceptConnection set getConnMaker serveConn counter where+ withII action =+ D.withDateCache $ \dc ->+ F.withFdCache fdCacheDurationInSeconds $ \fc ->+ I.withFileInfoCache fdFileInfoDurationInSeconds $ \get ->+ withTimeoutManager $ \tm -> do+ let ii0 = InternalInfo undefined tm fc get dc -- fixme: undefined+ action ii0+ fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000+ fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000 withTimeoutManager f = case settingsManager set of Just tm -> f tm Nothing -> bracket@@ -267,12 +274,10 @@ acceptConnection :: Settings -> IO (IO (Connection, Transport), SockAddr) -> ServeConnection- -> D.DateCache- -> Maybe F.MutableFdCache- -> T.Manager -> Counter+ -> InternalInfo -> IO ()-acceptConnection set getConnMaker serveConn dc fc tm counter = do+acceptConnection set getConnMaker serveConn counter ii0 = do -- First mask all exceptions in acceptLoop. This is necessary to -- ensure that no async exception is throw between the call to -- acceptNewConnection and the registering of connClose.@@ -294,7 +299,7 @@ case mx of Nothing -> return () Just (mkConn, addr) -> do- fork set mkConn addr serveConn dc fc tm counter+ fork set mkConn addr serveConn counter ii0 acceptLoop acceptNewConnection = do@@ -319,12 +324,10 @@ -> IO (Connection, Transport) -> SockAddr -> ServeConnection- -> D.DateCache- -> Maybe F.MutableFdCache- -> T.Manager -> Counter+ -> InternalInfo -> IO ()-fork set mkConn addr serveConn dc fc tm counter = settingsFork set $ \ unmask ->+fork set mkConn addr serveConn counter ii0 = settingsFork set $ \ unmask -> -- Run the connection maker to get a new connection, and ensure -- that the connection is closed. If the mkConn call throws an -- exception, we will leak the connection. If the mkConn call is@@ -339,9 +342,9 @@ -- We need to register a timeout handler for this thread, and -- cancel that handler as soon as we exit.- bracket (T.registerKillThread tm) T.cancel $ \th ->+ bracket (T.registerKillThread (timeoutManager ii0)) T.cancel $ \th -> - let ii = InternalInfo th tm fc dc+ let ii = ii0 { threadHandle = th } -- We now have fully registered a connection close handler -- in the case of all exceptions, so it is safe to one -- again allow async exceptions.@@ -443,12 +446,14 @@ th = threadHandle ii + shouldSendErrorResponse se+ | Just ConnectionClosedByPeer <- fromException se = False+ | otherwise = True+ sendErrorResponse addr istatus e = do status <- readIORef istatus- when status $ void $- sendResponse- (settingsServerName settings)- conn ii (dummyreq addr) defaultIndexRequestHeader (return S.empty) (errorResponse e)+ when (shouldSendErrorResponse e && status) $ void $+ sendResponse settings conn ii (dummyreq addr) defaultIndexRequestHeader (return S.empty) (errorResponse e) dummyreq addr = defaultRequest { remoteHost = addr } @@ -480,9 +485,7 @@ -- send more meaningful error messages to the user. -- However, it may affect performance. writeIORef istatus False- keepAlive <- sendResponse- (settingsServerName settings)- conn ii req idxhdr (readSource src) res+ keepAlive <- sendResponse settings conn ii req idxhdr (readSource src) res writeIORef keepAliveRef keepAlive return ResponseReceived keepAlive <- readIORef keepAliveRef
Network/Wai/Handler/Warp/Settings.hs view
@@ -48,6 +48,7 @@ , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30 , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing' , settingsFdCacheDuration :: Int -- ^ Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 0+ , settingsFileInfoCacheDuration :: Int -- ^ Cache duration time of file information in seconds. 0 means that the cache mechanism is not used. Default value: 0 , settingsBeforeMainLoop :: IO () -- ^ Code to run after the listening socket is ready but before entering -- the main event loop. Useful for signaling to tests that they can start@@ -96,6 +97,10 @@ -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True -- -- Since 3.1.7.+ , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()+ -- ^ A log function. Default: no action.+ --+ -- Since 3.X.X. } -- | Specify usage of the PROXY protocol.@@ -119,6 +124,7 @@ , settingsTimeout = 30 , settingsManager = Nothing , settingsFdCacheDuration = 0+ , settingsFileInfoCacheDuration = 0 , settingsBeforeMainLoop = return () , settingsFork = void . forkIOWithUnmask , settingsNoParsePath = False@@ -128,6 +134,7 @@ , settingsProxyProtocol = ProxyProtocolNone , settingsSlowlorisSize = 2048 , settingsHTTP2Enabled = True+ , settingsLogger = \_ _ _ -> return () } -- | Apply the logic provided by 'defaultOnException' to determine if an
Network/Wai/Handler/Warp/Types.hs view
@@ -13,6 +13,7 @@ import Foreign.Ptr (Ptr) import qualified Network.Wai.Handler.Warp.Date as D import qualified Network.Wai.Handler.Warp.FdCache as F+import qualified Network.Wai.Handler.Warp.FileInfoCache as I import qualified Network.Wai.Handler.Warp.Timeout as T #ifndef WINDOWS@@ -118,6 +119,7 @@ threadHandle :: T.Handle , timeoutManager :: T.Manager , fdCacher :: Maybe F.MutableFdCache+ , fileInfo :: FilePath -> IO I.FileInfo , dateCacher :: D.DateCache }
+ test/FileSpec.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}++module FileSpec (main, spec) where++import Network.HTTP.Types+import Network.Wai.Handler.Warp.File+import Network.Wai.Handler.Warp.FileInfoCache+import Network.Wai.Handler.Warp.Header++import Test.Hspec++main :: IO ()+main = hspec spec++testFileRange :: String+ -> RequestHeaders -> FilePath+ -> RspFileInfo+ -> Spec+testFileRange desc reqhs file ans = it desc $ do+ finfo <- getInfo file+ let WithBody s hs off len = ans+ hs' = ("Last-Modified",fileInfoDate finfo) : hs+ ans' = WithBody s hs' off len+ conditionalRequest finfo [] (indexRequestHeader reqhs) `shouldBe` ans'++spec :: Spec+spec = do+ describe "conditionalRequest" $ do+ testFileRange+ "gets a file size from file system"+ [] "attic/hex"+ $ WithBody ok200 [("Content-Length","16"),("Accept-Ranges","bytes")] 0 16+ testFileRange+ "gets a file size from file system and handles Range and returns Partical Content"+ [("Range","bytes=2-14")] "attic/hex"+ $ WithBody status206 [("Content-Range","bytes 2-14/16"),("Content-Length","13"),("Accept-Ranges","bytes")] 2 13+ testFileRange+ "truncates end point of range to file size"+ [("Range","bytes=10-20")] "attic/hex"+ $ WithBody status206 [("Content-Range","bytes 10-15/16"),("Content-Length","6"),("Accept-Ranges","bytes")] 10 6+ testFileRange+ "gets a file size from file system and handles Range and returns OK if Range means the entire"+ [("Range:","bytes=0-15")] "attic/hex"+ $ WithBody status200 [("Content-Length","16"),("Accept-Ranges","bytes")] 0 16+
test/HTTP.hs view
@@ -3,11 +3,14 @@ module HTTP ( sendGET , sendGETwH+ , sendHEAD+ , sendHEADwH , rspBody , rspCode , rspHeaders , getHeaderValue , HeaderName(..)+ , mkHeader ) where import Network.HTTP@@ -18,6 +21,12 @@ sendGETwH :: String -> [Header] -> IO (Response String) sendGETwH url hdr = unResult $ simpleHTTP $ (getRequest url) { rqHeaders = hdr }++sendHEAD :: String -> IO (Response String)+sendHEAD url = sendHEADwH url []++sendHEADwH :: String -> [Header] -> IO (Response String)+sendHEADwH url hdr = unResult $ simpleHTTP $ (headRequest url) { rqHeaders = hdr } unResult :: IO (Result (Response String)) -> IO (Response String) unResult action = do
test/ResponseSpec.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+ module ResponseSpec (main, spec) where import Control.Concurrent (threadDelay)@@ -70,18 +71,6 @@ _ -> Nothing range = "bytes " ++ show offset ++ "-" ++ show (offset + count - 1) ++ "/" ++ show size -testFileRange :: String- -> Status -> ResponseHeaders -> FilePath- -> Maybe FilePart -> Maybe HeaderValue- -> Either String (Status, ResponseHeaders, Integer, Integer)- -> Spec-testFileRange desc s rsphdr file mPart mRange ans = it desc $ do- eres <- fileRange s rsphdr file mPart mRange- let res = case eres of- Left e -> Left $ show e- Right r -> Right r- res `shouldBe` ans- spec :: Spec spec = do describe "preventing response splitting attack" $ do@@ -124,37 +113,3 @@ testPartial 16 2 2 "23" testPartial 16 0 2 "01" testPartial 16 3 8 "3456789a"-- describe "fileRange" $ do- testFileRange- "gets a file size from file system"- status200 [] "attic/hex" Nothing Nothing- $ Right (status200,[("Content-Length","16"), ("Accept-Ranges","bytes")],0,16)- testFileRange- "gets an error if a file does not exist"- status200 [] "attic/nonexist" Nothing Nothing- $ Left "attic/nonexist: getFileStatus: does not exist (No such file or directory)"- testFileRange- "changes status if FileParts is specified"- status200 [] "attic/hex" (Just (FilePart 2 10 16)) Nothing- $ Right (status206,[("Content-Range", "bytes 2-11/16"),("Content-Length","10"),("Accept-Ranges","bytes")],2,10)- testFileRange- "does not change status and does not add Content-Range if FileParts means the entire"- status200 [] "attic/hex" (Just (FilePart 0 16 16)) Nothing- $ Right (status200,[("Content-Length","16"), ("Accept-Ranges","bytes")],0,16)- testFileRange- "gets a file size from file system and handles Range and returns Partical Content"- status200 [] "attic/hex" Nothing (Just "bytes=2-14")- $ Right (status206,[("Content-Range","bytes 2-14/16"),("Content-Length","13"),("Accept-Ranges","bytes")],2,13)- testFileRange- "truncates end point of range to file size"- status200 [] "attic/hex" Nothing (Just "bytes=10-20")- $ Right (status206,[("Content-Range","bytes 10-15/16"),("Content-Length","6"),("Accept-Ranges","bytes")],10,6)- testFileRange- "gets a file size from file system and handles Range and returns OK if Range means the entire"- status200 [] "attic/hex" Nothing (Just "bytes=0-15")- $ Right (status200,[("Content-Length","16"),("Accept-Ranges","bytes")],0,16)- testFileRange- "igores Range if FilePart is specified"- status200 [] "attic/hex" (Just (FilePart 2 10 16)) (Just "bytes=8-9")- $ Right (status206,[("Content-Range", "bytes 2-11/16"),("Content-Length","10"),("Accept-Ranges","bytes")],2,10)
test/RunSpec.hs view
@@ -377,6 +377,31 @@ res <- sendGET $ "http://127.0.0.1:" ++ show port rspBody res `shouldBe` "HelloHelloHelloHello" + describe "head requests" $ do+ let fp = "test/head-response"+ let app req f =+ f $ case pathInfo req of+ ["builder"] -> responseBuilder status200 [] $ error "should never be evaluated"+ ["streaming"] -> responseStream status200 [] $ \write _ ->+ write $ error "should never be evaluated"+ ["file"] -> responseFile status200 [] fp Nothing+ _ -> error "invalid path"+ it "builder" $ withApp defaultSettings app $ \port -> do+ res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/builder"]+ rspBody res `shouldBe` ""+ it "streaming" $ withApp defaultSettings app $ \port -> do+ res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/streaming"]+ rspBody res `shouldBe` ""+ it "file, no range" $ withApp defaultSettings app $ \port -> do+ bs <- S.readFile fp+ res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/file"]+ getHeaderValue HdrContentLength res `shouldBe` Just (show $ S.length bs)+ it "file, with range" $ withApp defaultSettings app $ \port -> do+ res <- sendHEADwH+ (concat ["http://127.0.0.1:", show port, "/file"])+ [mkHeader HdrRange "bytes=0-1"]+ getHeaderValue HdrContentLength res `shouldBe` Just "2"+ consumeBody :: IO ByteString -> IO [ByteString] consumeBody body = loop id
+ test/head-response view
@@ -0,0 +1,1 @@+This is the body
warp.cabal view
@@ -1,5 +1,5 @@ Name: warp-Version: 3.1.9+Version: 3.1.10 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE@@ -18,6 +18,7 @@ extra-source-files: attic/hex ChangeLog.md README.md+ test/head-response Flag network-bytestring Default: False@@ -52,6 +53,7 @@ , stm >= 2.3 , word8 , hashable+ , unordered-containers if flag(network-bytestring) Build-Depends: network >= 2.2.1.5 && < 2.2.3 , network-bytestring >= 0.1.3 && < 0.1.4@@ -64,6 +66,8 @@ Network.Wai.Handler.Warp.Counter Network.Wai.Handler.Warp.Date Network.Wai.Handler.Warp.FdCache+ Network.Wai.Handler.Warp.File+ Network.Wai.Handler.Warp.FileInfoCache Network.Wai.Handler.Warp.HTTP2 Network.Wai.Handler.Warp.HTTP2.EncodeFrame Network.Wai.Handler.Warp.HTTP2.HPACK@@ -98,7 +102,6 @@ if os(windows) Cpp-Options: -DWINDOWS Build-Depends: time- , old-locale else Build-Depends: unix , http-date@@ -118,6 +121,7 @@ ConduitSpec ExceptionSpec FdCacheSpec+ FileSpec MultiMapSpec ReadIntSpec RequestSpec@@ -151,7 +155,6 @@ , QuickCheck , hspec >= 1.3 , time- , old-locale , text , streaming-commons >= 0.1.10 , async@@ -163,6 +166,7 @@ , http2 >= 1.3 , word8 , hashable+ , unordered-containers if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd) Cpp-Options: -DSENDFILEFD