warp 3.2.3 → 3.2.4
raw patch · 26 files changed
+644/−576 lines, 26 filesdep +silently
Dependencies added: silently
Files
- ChangeLog.md +4/−0
- Network/Wai/Handler/Warp.hs +6/−2
- Network/Wai/Handler/Warp/Date.hs +2/−11
- Network/Wai/Handler/Warp/FdCache.hs +69/−77
- Network/Wai/Handler/Warp/File.hs +58/−28
- Network/Wai/Handler/Warp/FileInfoCache.hs +8/−12
- Network/Wai/Handler/Warp/HTTP2.hs +5/−5
- Network/Wai/Handler/Warp/HTTP2/HPACK.hs +2/−2
- Network/Wai/Handler/Warp/HTTP2/Receiver.hs +25/−6
- Network/Wai/Handler/Warp/HTTP2/Request.hs +13/−30
- Network/Wai/Handler/Warp/HTTP2/Sender.hs +36/−28
- Network/Wai/Handler/Warp/HTTP2/Types.hs +19/−18
- Network/Wai/Handler/Warp/HTTP2/Worker.hs +33/−35
- Network/Wai/Handler/Warp/HashMap.hs +5/−0
- Network/Wai/Handler/Warp/MultiMap.hs +43/−193
- Network/Wai/Handler/Warp/Request.hs +14/−10
- Network/Wai/Handler/Warp/Response.hs +23/−42
- Network/Wai/Handler/Warp/Run.hs +30/−27
- Network/Wai/Handler/Warp/SendFile.hs +3/−3
- Network/Wai/Handler/Warp/Some.hs +73/−0
- Network/Wai/Handler/Warp/Types.hs +30/−13
- Network/Wai/Handler/Warp/WithApplication.hs +90/−0
- test/FdCacheSpec.hs +2/−2
- test/MultiMapSpec.hs +0/−30
- test/WithApplicationSpec.hs +45/−0
- warp.cabal +6/−2
ChangeLog.md view
@@ -1,3 +1,7 @@+## 3.2.4++* Added `withApplication`, `testWithApplication`, and `openFreePort`+ ## 3.2.3 * Using http2 v1.5.x which much improves the performance of HTTP/2.
Network/Wai/Handler/Warp.hs view
@@ -90,6 +90,9 @@ , pauseTimeout , FileInfo(..) , getFileInfo+ , withApplication+ , testWithApplication+ , openFreePort -- * Version , warpVersion ) where@@ -108,7 +111,8 @@ import Network.Wai.Handler.Warp.Run import Network.Wai.Handler.Warp.Settings import Network.Wai.Handler.Warp.Timeout-import Network.Wai.Handler.Warp.Types+import Network.Wai.Handler.Warp.Types hiding (getFileInfo)+import Network.Wai.Handler.Warp.WithApplication -- | Port to listen on. Default value: 3000 --@@ -242,7 +246,7 @@ -- -- For instance, this code should set up a UNIX signal -- handler. The handler should call the first argument,--- which close the listen socket, at shutdown.+-- which closes the listen socket, at shutdown. -- -- Default: does not install any code. --
Network/Wai/Handler/Warp/Date.hs view
@@ -2,8 +2,6 @@ module Network.Wai.Handler.Warp.Date ( withDateCache- , getDate- , DateCache , GMTDate ) where @@ -25,21 +23,14 @@ -- | The type of the Date header value. type GMTDate = ByteString --- | The type of the cache of the Date header value.-type DateCache = IO GMTDate- -- | Creating 'DateCache' and executing the action.-withDateCache :: (DateCache -> IO a) -> IO a+withDateCache :: (IO GMTDate -> IO a) -> IO a withDateCache action = initialize >>= action -initialize :: IO DateCache+initialize :: IO (IO GMTDate) initialize = mkAutoUpdate defaultUpdateSettings { updateAction = formatHTTPDate <$> getCurrentHTTPDate }---- | Getting current 'GMTDate' based on 'DateCache'.-getDate :: DateCache -> IO GMTDate-getDate = id #ifdef WINDOWS uToH :: UTCTime -> HTTPDate
Network/Wai/Handler/Warp/FdCache.hs view
@@ -2,47 +2,58 @@ -- | File descriptor cache to avoid locks in kernel. -#ifdef WINDOWS module Network.Wai.Handler.Warp.FdCache ( withFdCache- , MutableFdCache- , Refresh- ) where--type Refresh = IO ()-type MutableFdCache = ()--withFdCache :: Int -> (Maybe MutableFdCache -> IO a) -> IO a-withFdCache _ f = f Nothing-#else-module Network.Wai.Handler.Warp.FdCache (- withFdCache- , getFd- , getFd'- , MutableFdCache+ , Fd , Refresh+#ifndef WINDOWS+ , openFile+ , closeFile+ , setFileCloseOnExec+#endif ) where +#ifndef WINDOWS #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>), (<*>)) #endif import Control.Exception (bracket)-import Data.Hashable (hash) import Network.Wai.Handler.Warp.IORef import Network.Wai.Handler.Warp.MultiMap-import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd)-import System.Posix.Types (Fd) import Control.Reaper+import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd, FdOption(CloseOnExec), setFdOption)+#endif+import System.Posix.Types (Fd) ---------------------------------------------------------------- -data Status = Active | Inactive--newtype MutableStatus = MutableStatus (IORef Status)+type Hash = Int -- | An action to activate a Fd cache entry. type Refresh = IO () +getFdNothing :: Hash -> FilePath -> IO (Maybe Fd, Refresh)+getFdNothing _ _ = return (Nothing, return ())++----------------------------------------------------------------++-- | Creating 'MutableFdCache' and executing the action in the second+-- argument. The first argument is a cache duration in second.+withFdCache :: Int -> ((Hash -> FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a+#ifdef WINDOWS+withFdCache _ action = action getFdNothing+#else+withFdCache 0 action = action getFdNothing+withFdCache duration action = bracket (initialize duration)+ terminate+ (\mfc -> action (getFd mfc))++----------------------------------------------------------------++data Status = Active | Inactive++newtype MutableStatus = MutableStatus (IORef Status)+ status :: MutableStatus -> IO Status status (MutableStatus ref) = readIORef ref @@ -59,15 +70,24 @@ data FdEntry = FdEntry !FilePath !Fd !MutableStatus +openFile :: FilePath -> IO Fd+openFile path = do+ fd <- openFd path ReadOnly Nothing defaultFileFlags{nonBlock=False}+ setFileCloseOnExec fd+ return fd++closeFile :: Fd -> IO ()+closeFile = closeFd+ newFdEntry :: FilePath -> IO FdEntry-newFdEntry path = FdEntry path- <$> openFd path ReadOnly Nothing defaultFileFlags{nonBlock=True}- <*> newActiveStatus+newFdEntry path = FdEntry path <$> openFile path <*> newActiveStatus +setFileCloseOnExec :: Fd -> IO ()+setFileCloseOnExec fd = setFdOption fd CloseOnExec True+ ---------------------------------------------------------------- -type Hash = Int-type FdCache = MMap Hash FdEntry+type FdCache = MMap FdEntry -- | Mutable Fd cacher. newtype MutableFdCache = MutableFdCache (Reaper FdCache (Hash, FdEntry))@@ -78,80 +98,52 @@ look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry) look mfc path key = searchWith key check <$> fdCache mfc where- check (One ent@(FdEntry path' _ _))- | path == path' = Just ent- | otherwise = Nothing- check (Tom ent@(FdEntry path' _ _) vs)- | path == path' = Just ent- | otherwise = check vs---------------------------------------------------------------------- | Creating 'MutableFdCache' and executing the action in the second--- argument. The first argument is a cache duration in second.-withFdCache :: Int -> (Maybe MutableFdCache -> IO a) -> IO a-withFdCache duration action = bracket (initialize duration)- terminate- action+ check (FdEntry path' _ _) = path == path' ---------------------------------------------------------------- -- The first argument is a cache duration in second.-initialize :: Int -> IO (Maybe MutableFdCache)-initialize 0 = return Nothing-initialize duration = Just . MutableFdCache <$> mkReaper defaultReaperSettings- { reaperAction = clean- , reaperDelay = duration- , reaperCons = uncurry insert- , reaperNull = isEmpty- , reaperEmpty = empty- }+initialize :: Int -> IO MutableFdCache+initialize duration = MutableFdCache <$> mkReaper settings+ where+ settings = defaultReaperSettings {+ reaperAction = clean+ , reaperDelay = duration+ , reaperCons = uncurry insert+ , reaperNull = isEmpty+ , reaperEmpty = empty+ } clean :: FdCache -> IO (FdCache -> FdCache) clean old = do new <- pruneWith old prune return $ merge new--prune :: t -> Some FdEntry -> IO [(t, Some FdEntry)]-prune k v@(One (FdEntry _ fd mst)) = status mst >>= prune' where- prune' Active = inactive mst >> return [(k,v)]- prune' Inactive = closeFd fd >> return []-prune k (Tom ent@(FdEntry _ fd mst) vs) = status mst >>= prune'- where- prune' Active = do- inactive mst- zs <- prune k vs- case zs of- [] -> return [(k,One ent)]- [(_,zvs)] -> return [(k,Tom ent zvs)]- _ -> error "prune"- prune' Inactive = closeFd fd >> prune k vs+ prune (FdEntry _ fd mst) = status mst >>= act+ where+ act Active = inactive mst >> return True+ act Inactive = closeFd fd >> return False ---------------------------------------------------------------- -terminate :: Maybe MutableFdCache -> IO ()-terminate Nothing = return ()-terminate (Just (MutableFdCache reaper)) = do+terminate :: MutableFdCache -> IO ()+terminate (MutableFdCache reaper) = do !t <- reaperStop reaper mapM_ closeIt $ toList t where- closeIt (_, FdEntry _ fd _) = closeFd fd+ closeIt (FdEntry _ fd _) = closeFd fd ---------------------------------------------------------------- -getFd :: MutableFdCache -> FilePath -> IO (Fd, Refresh)-getFd mfc path = getFd' mfc (hash path) path- -- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.-getFd' :: MutableFdCache -> Hash -> FilePath -> IO (Fd, Refresh)-getFd' mfc@(MutableFdCache reaper) h path = look mfc path h >>= get+getFd :: MutableFdCache -> Hash -> FilePath -> IO (Maybe Fd, Refresh)+getFd mfc@(MutableFdCache reaper) h path = look mfc path h >>= get where get Nothing = do ent@(FdEntry _ fd mst) <- newFdEntry path reaperAdd reaper (h, ent)- return (fd, refresh mst)+ return (Just fd, refresh mst) get (Just (FdEntry _ fd mst)) = do refresh mst- return (fd, refresh mst)+ return (Just fd, refresh mst) #endif
Network/Wai/Handler/Warp/File.hs view
@@ -7,14 +7,19 @@ , conditionalRequest , addContentHeadersForFilePart , parseByteRanges+ , packInteger -- testing ) where import Control.Applicative ((<|>))+import Control.Monad import Data.Array ((!))-import Data.ByteString (ByteString) import qualified Data.ByteString as B hiding (pack) import qualified Data.ByteString.Char8 as B (pack, readInteger)+import Data.ByteString.Internal (ByteString(..), unsafeCreate) import Data.Maybe (fromMaybe)+import Data.Word8 (Word8)+import Foreign.Ptr (Ptr, plusPtr)+import Foreign.Storable (poke) import Network.HTTP.Date import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as H@@ -27,6 +32,9 @@ #define MIN_VERSION_http_types(x,y,z) 1 #endif +-- $setup+-- >>> import Test.QuickCheck+ ---------------------------------------------------------------- data RspFileInfo = WithoutBody H.Status@@ -40,17 +48,17 @@ -> 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+ 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 = fromMaybe (unconditional reqidx size) mcondition+ !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 = fromMaybe (unconditional reqidx size) mcondition ---------------------------------------------------------------- @@ -70,7 +78,7 @@ date <- ifModifiedSince reqidx return $ if date /= mtime then unconditional reqidx size- else WithoutBody H.notModified304+ else WithoutBody H.notModified304 ifunmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo ifunmodified reqidx size mtime = do@@ -140,16 +148,17 @@ ---------------------------------------------------------------- --- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header'--- for the range specified.-contentRangeHeader :: Integer -> Integer -> Integer -> H.Header-contentRangeHeader beg end total = (+contentRange :: H.HeaderName #if MIN_VERSION_http_types(0,9,0)- H.hContentRange+contentRange = H.hContentRange #else- "Content-Range"+contentRange = "Content-Range" #endif- , range)++-- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header'+-- for the range specified.+contentRangeHeader :: Integer -> Integer -> Integer -> H.Header+contentRangeHeader beg end total = (contentRange, range) where range = B.pack -- building with ShowS@@ -161,19 +170,40 @@ ( '/' : 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 = B.pack $ show len- hs' = (H.hContentLength, lengthBS):(+acceptRange :: H.HeaderName #if MIN_VERSION_http_types(0,9,0)- H.hAcceptRanges+acceptRange = H.hAcceptRanges #else- "Accept-Ranges"+acceptRange = "Accept-Ranges" #endif- , "bytes"):hs- hs'' = if len == size then hs' else contentRange:hs'++addContentHeaders :: H.ResponseHeaders -> Integer -> Integer -> Integer -> H.ResponseHeaders+addContentHeaders hs off len size+ | len == size = hs'+ | otherwise = let !ctrng = contentRangeHeader off (off + len - 1) size+ in ctrng:hs'+ where+ !lengthBS = packInteger len+ !hs' = (H.hContentLength, lengthBS) : (acceptRange,"bytes") : hs++-- |+--+-- prop> packInteger (abs n) == B.pack (show (abs n))+-- prop> \(Large n) -> let n' = fromIntegral (abs n :: Int) in packInteger n' == B.pack (show n')++packInteger :: Integer -> ByteString+packInteger 0 = "0"+packInteger n | n < 0 = error "packInteger"+packInteger n = unsafeCreate len go0+ where+ n' = fromIntegral n + 1 :: Double+ len = ceiling $ logBase 10 n'+ go0 p = go n $ p `plusPtr` (len - 1)+ go :: Integer -> Ptr Word8 -> IO ()+ go i p = do+ let (d,r) = i `divMod` 10+ poke p (48 + fromIntegral r)+ when (d /= 0) $ go d (p `plusPtr` (-1)) -- | --
Network/Wai/Handler/Warp/FileInfoCache.hs view
@@ -11,7 +11,6 @@ import Control.Monad (void) import Control.Reaper import Data.ByteString (ByteString)-import Data.Hashable (hash) import Network.HTTP.Date import Network.Wai.Handler.Warp.HashMap (HashMap) import qualified Network.Wai.Handler.Warp.HashMap as M@@ -55,16 +54,13 @@ else throwIO (userError "FileInfoCache:getInfo") -getInfo' :: Hash -> FilePath -> IO FileInfo-getInfo' _ = getInfo+getInfoNaive :: Hash -> FilePath -> IO FileInfo+getInfoNaive _ = getInfo ---------------------------------------------------------------- -getAndRegisterInfo :: FileInfoCache -> FilePath -> IO FileInfo-getAndRegisterInfo reaper path = getAndRegisterInfo' reaper (hash path) path--getAndRegisterInfo' :: FileInfoCache -> Hash -> FilePath -> IO FileInfo-getAndRegisterInfo' reaper@Reaper{..} h path = do+getAndRegisterInfo :: FileInfoCache -> Hash -> FilePath -> IO FileInfo+getAndRegisterInfo reaper@Reaper{..} h path = do cache <- reaperRead case M.lookup h path cache of Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo")@@ -89,20 +85,20 @@ -- and executing the action in the second argument. -- The first argument is a cache duration in second. withFileInfoCache :: Int- -> ((FilePath -> IO FileInfo) -> (Hash -> FilePath -> IO FileInfo) -> IO a)+ -> ((Hash -> FilePath -> IO FileInfo) -> IO a) -> IO a-withFileInfoCache 0 action = action getInfo getInfo'+withFileInfoCache 0 action = action getInfoNaive withFileInfoCache duration action = E.bracket (initialize duration) terminate- (\r -> action (getAndRegisterInfo r) (getAndRegisterInfo' r))+ (\r -> action (getAndRegisterInfo r)) initialize :: Hash -> IO FileInfoCache initialize duration = mkReaper settings where settings = defaultReaperSettings { reaperAction = override- , reaperDelay = duration * 1000000+ , reaperDelay = duration , reaperCons = \(h,k,v) -> M.insert h k v , reaperNull = M.null , reaperEmpty = M.empty
Network/Wai/Handler/Warp/HTTP2.hs view
@@ -22,15 +22,15 @@ ---------------------------------------------------------------- -http2 :: Connection -> InternalInfo -> SockAddr -> Transport -> S.Settings -> (BufSize -> IO ByteString) -> Application -> IO ()-http2 conn ii addr transport settings readN app = do+http2 :: Connection -> InternalInfo1 -> SockAddr -> Transport -> S.Settings -> (BufSize -> IO ByteString) -> Application -> IO ()+http2 conn ii1 addr transport settings readN app = do checkTLS ok <- checkPreface when ok $ do ctx <- newContext -- Workers, worker manager and timer manager mgr <- start settings- let responder = response ii settings ctx mgr+ let responder = response settings ctx mgr action = worker ctx settings app responder setAction mgr action -- The number of workers is 3.@@ -40,12 +40,12 @@ -- context switches happen. replicateM_ 3 $ spawnAction mgr -- Receiver- let mkreq = mkRequest ii settings addr+ let mkreq = mkRequest ii1 settings addr tid <- forkIO $ frameReceiver ctx mkreq readN -- Sender -- frameSender is the main thread because it ensures to send -- a goway frame.- frameSender ctx conn ii settings mgr `E.finally` do+ frameSender ctx conn settings mgr `E.finally` do clearContext ctx stop mgr killThread tid
Network/Wai/Handler/Warp/HTTP2/HPACK.hs view
@@ -34,10 +34,10 @@ encodeHeaderBuffer buf siz strategy True encodeDynamicTable hs where status = B8.pack $ show $ H.statusCode s- dc = dateCacher ii+ getdate = getDate ii rspidxhdr = indexResponseHeader hdr0 defServer = S.settingsServerName settings- addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr+ addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr hpackEncodeHeaderLoop :: Context -> Buffer -> BufSize -> HeaderList -> IO (HeaderList, Int)
Network/Wai/Handler/Warp/HTTP2/Receiver.hs view
@@ -111,8 +111,8 @@ E.throwIO $ StreamError ProtocolError streamId writeIORef streamPrecedence $ toPrecedence pri writeIORef streamState HalfClosed- let !req = mkreq vh (return "")- atomically $ writeTQueue inputQ $ Input strm req+ let (!req, !ii) = mkreq vh (return "")+ atomically $ writeTQueue inputQ $ Input strm req ii Nothing -> E.throwIO $ StreamError ProtocolError streamId Open (HasBody hdr pri) -> do resetContinued@@ -124,8 +124,8 @@ writeIORef streamContentLength $ vhCL vh readQ <- newReadBody q bodySource <- mkSource readQ- let !req = mkreq vh (readSource bodySource)- atomically $ writeTQueue inputQ $ Input strm req+ let (!req, !ii) = mkreq vh (readSource bodySource)+ atomically $ writeTQueue inputQ $ Input strm req ii Nothing -> E.throwIO $ StreamError ProtocolError streamId s@(Open Continued{}) -> do setContinued@@ -187,9 +187,11 @@ modifyIORef' http2settings $ \old -> updateSettings old alist let !frame = settingsFrame setAck [] sent <- readIORef firstSettings- let !frame' = if sent then frame else BS.append initialFrame frame+ let !setframe+ | sent = CSettings frame alist+ | otherwise = CSettings0 initialFrame frame alist unless sent $ writeIORef firstSettings True- enqueueControl controlQ $ CSettings frame' alist+ enqueueControl controlQ setframe return True control FramePing FrameHeader{flags} bs Context{controlQ} =@@ -345,3 +347,20 @@ stream _ _ _ _ st@(Closed (ResetByMe _)) _ = return st stream FrameData FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError StreamClosed streamId stream _ FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError ProtocolError streamId++----------------------------------------------------------------++newReadBody :: TQueue ByteString -> IO (IO ByteString)+newReadBody q = do+ ref <- newIORef False+ return $ readBody q ref++readBody :: TQueue ByteString -> IORef Bool -> IO ByteString+readBody q ref = do+ eof <- readIORef ref+ if eof then+ return ""+ else do+ bs <- atomically $ readTQueue q+ when (bs == "") $ writeIORef ref True+ return bs
Network/Wai/Handler/Warp/HTTP2/Request.hs view
@@ -3,7 +3,6 @@ module Network.Wai.Handler.Warp.HTTP2.Request ( mkRequest- , newReadBody , MkReq , ValidHeaders(..) , validateHeaders@@ -12,13 +11,10 @@ #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif-import Control.Concurrent.STM-import Control.Monad (when) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 import Data.CaseInsensitive (mk)-import Data.IORef (IORef, readIORef, newIORef, writeIORef) import Data.Maybe (isJust) import qualified Data.Vault.Lazy as Vault #if __GLASGOW_HASKELL__ < 709@@ -30,11 +26,12 @@ import qualified Network.HTTP.Types as H import Network.Socket (SockAddr) import Network.Wai-import Network.Wai.Internal (Request(..)) import Network.Wai.Handler.Warp.HTTP2.Types+import Network.Wai.Handler.Warp.HashMap (hashByteString) import Network.Wai.Handler.Warp.ReadInt import Network.Wai.Handler.Warp.Request (pauseTimeoutKey, getFileInfoKey)-import Network.Wai.Handler.Warp.Types (InternalInfo(..))+import Network.Wai.Handler.Warp.Types+import Network.Wai.Internal (Request(..)) import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath) import qualified Network.Wai.Handler.Warp.Timeout as Timeout @@ -49,23 +46,26 @@ , vhHeader :: !RequestHeaders } deriving Show -type MkReq = ValidHeaders -> IO ByteString -> Request+type MkReq = ValidHeaders -> IO ByteString -> (Request,InternalInfo) -mkRequest :: InternalInfo -> S.Settings -> SockAddr -> MkReq-mkRequest ii settings addr (ValidHeaders m p ma mrng mrr mua _ hdr) body = req+mkRequest :: InternalInfo1 -> S.Settings -> SockAddr -> MkReq+mkRequest ii1 settings addr (ValidHeaders m p ma mrng mrr mua _ hdr) body =+ (req,ii) where (unparsedPath,query) = B8.break (=='?') p !path = H.extractPath unparsedPath+ !rawPath = if S.settingsNoParsePath settings then unparsedPath else path+ !h = hashByteString rawPath !req = Request { requestMethod = m , httpVersion = http2ver- , rawPathInfo = if S.settingsNoParsePath settings then unparsedPath else path+ , rawPathInfo = rawPath , pathInfo = H.decodePathSegments path , rawQueryString = query , queryString = H.parseQuery query , requestHeaders = case ma of Nothing -> hdr- Just h -> (mk "host", h) : hdr+ Just hv -> (mk "host", hv) : hdr , isSecure = True , remoteHost = addr , requestBody = body@@ -76,9 +76,10 @@ , requestHeaderReferer = mrr , requestHeaderUserAgent = mua }+ !ii = toInternalInfo ii1 h !th = threadHandle ii !vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)- $ Vault.insert getFileInfoKey (fileInfo ii)+ $ Vault.insert getFileInfoKey (getFileInfo ii) Vault.empty ----------------------------------------------------------------@@ -163,21 +164,3 @@ in [("cookie",v)] isPseudo "" = False isPseudo k = BS.head k == _colon---------------------------------------------------------------------newReadBody :: TQueue ByteString -> IO (IO ByteString)-newReadBody q = do- ref <- newIORef False- return $ readBody q ref--readBody :: TQueue ByteString -> IORef Bool -> IO ByteString-readBody q ref = do- eof <- readIORef ref- if eof then- return ""- else do- bs <- atomically $ readTQueue q- when (bs == "") $ writeIORef ref True- return bs
Network/Wai/Handler/Warp/HTTP2/Sender.hs view
@@ -34,8 +34,6 @@ import Network.Wai.Handler.Warp.FdCache import Network.Wai.Handler.Warp.SendFile (positionRead) import qualified Network.Wai.Handler.Warp.Timeout as T-import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd)-import System.Posix.Types #endif ----------------------------------------------------------------@@ -63,10 +61,10 @@ | O (StreamId,Precedence,Output) | Flush -frameSender :: Context -> Connection -> InternalInfo -> S.Settings -> Manager -> IO ()+frameSender :: Context -> Connection -> S.Settings -> Manager -> IO () frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable} conn@Connection{connWriteBuffer,connBufferSize,connSendAll}- ii settings mgr = loop 0 `E.catch` ignore+ settings mgr = loop 0 `E.catch` ignore where dequeue off = do isEmpty <- isEmptyTQueue controlQ@@ -86,28 +84,37 @@ case x of C ctl -> do when (off /= 0) $ flushN off- cont <- control ctl- when cont $ loop 0+ off' <- control ctl off+ when (off' >= 0) $ loop off' O (_,pre,out) -> do let strm = outputStream out writeIORef (streamPrecedence strm) pre off' <- whenReadyOrEnqueueAgain out off $ output out off case off' of 0 -> loop 0- _ | off' > 12288 -> flushN off' >> loop 0 -- fixme: hard-coding+ _ | off' > 15872 -> flushN off' >> loop 0 -- fixme: hard-coding | otherwise -> loop off' Flush -> flushN off >> loop 0 - control CFinish = return False- control (CGoaway frame) = connSendAll frame >> return False- control (CFrame frame) = connSendAll frame >> return True- control (CSettings frame alist) = do+ control CFinish _ = return (-1)+ control (CGoaway frame) _ = connSendAll frame >> return (-1)+ control (CFrame frame) _ = connSendAll frame >> return 0+ control (CSettings frame alist) _ = do connSendAll frame- case lookup SettingsHeaderTableSize alist of- Nothing -> return ()- Just siz -> setLimitForEncoding siz encodeDynamicTable- return True+ setLimit alist+ return 0+ control (CSettings0 frame1 frame2 alist) off = do -- off == 0, just in case+ let !buf = connWriteBuffer `plusPtr` off+ !off' = off + BS.length frame1 + BS.length frame2+ buf' <- copy buf frame1+ void $ copy buf' frame2+ setLimit alist+ return off' + setLimit alist = case lookup SettingsHeaderTableSize alist of+ Nothing -> return ()+ Just siz -> setLimitForEncoding siz encodeDynamicTable+ output (ONext strm curr mtbq) off0 lim = do -- Data frame payload let !buf = connWriteBuffer `plusPtr` off0@@ -117,23 +124,23 @@ maybeEnqueueNext strm mtbq mnext return off - output (ORspn strm rspn) off0 lim = do+ output (ORspn strm rspn ii) off0 lim = do -- Header frame and Continuation frame let sid = streamNumber strm endOfStream = case rspn of RspnNobody _ _ -> True _ -> False- kvlen <- headerContinue sid rspn endOfStream off0+ kvlen <- headerContinue sid rspn endOfStream off0 ii off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen case rspn of RspnNobody _ _ -> do closed ctx strm Finished return off- RspnFile _ _ h path mpart -> do+ RspnFile _ _ path mpart -> do -- Data frame payload let payloadOff = off + frameHeaderLength Next datPayloadLen mnext <-- fillFileBodyGetNext conn ii payloadOff lim h path mpart+ fillFileBodyGetNext conn ii payloadOff lim path mpart off' <- fillDataHeader strm off datPayloadLen mnext maybeEnqueueNext strm Nothing mnext return off'@@ -190,7 +197,7 @@ flushN :: Int -> IO () flushN n = bufferIO connWriteBuffer n connSendAll - headerContinue sid rspn endOfStream off = do+ headerContinue sid rspn endOfStream off ii = do let !s = rspnStatus rspn !h = rspnHeaders rspn let !offkv = off + frameHeaderLength@@ -274,10 +281,10 @@ (len, signal) <- B.runBuilder bb datBuf room return $ nextForBuilder len signal -fillFileBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> Int -> FilePath -> Maybe FilePart -> IO Next+fillFileBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> FilePath -> Maybe FilePart -> IO Next #ifdef WINDOWS fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize}- _ off lim _ path mpart = do+ _ off lim path mpart = do let datBuf = connWriteBuffer `plusPtr` off room = min (connBufferSize - off) lim (start, bytes) <- fileStartEnd path mpart@@ -290,13 +297,14 @@ return $ nextForFile len hdl bytes' (return ()) #else fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize}- ii off lim h path mpart = do- (fd, refresh) <- case fdCacher ii of- Just fdcache -> getFd' fdcache h path- Nothing -> do- fd' <- openFd path ReadOnly Nothing defaultFileFlags{nonBlock=True}- th <- T.register (timeoutManager ii) (closeFd fd')+ ii off lim path mpart = do+ (mfd, refresh') <- getFd ii path+ (fd, refresh) <- case mfd of+ Nothing -> do+ fd' <- openFile path+ th <- T.register (timeoutManager ii) (closeFile fd') return (fd', T.tickle th)+ Just fd -> return (fd, refresh') let datBuf = connWriteBuffer `plusPtr` off room = min (connBufferSize - off) lim (start, bytes) <- fileStartEnd path mpart
Network/Wai/Handler/Warp/HTTP2/Types.hs view
@@ -41,7 +41,7 @@ ---------------------------------------------------------------- -data Input = Input Stream Request+data Input = Input Stream Request InternalInfo ---------------------------------------------------------------- @@ -54,36 +54,37 @@ data Rspn = RspnNobody H.Status H.ResponseHeaders | RspnStreaming H.Status H.ResponseHeaders (TBQueue Sequence) | RspnBuilder H.Status H.ResponseHeaders Builder- | RspnFile H.Status H.ResponseHeaders Int FilePath (Maybe FilePart)+ | RspnFile H.Status H.ResponseHeaders FilePath (Maybe FilePart) rspnStatus :: Rspn -> H.Status-rspnStatus (RspnNobody s _) = s-rspnStatus (RspnStreaming s _ _) = s-rspnStatus (RspnBuilder s _ _) = s-rspnStatus (RspnFile s _ _ _ _ ) = s+rspnStatus (RspnNobody s _) = s+rspnStatus (RspnStreaming s _ _) = s+rspnStatus (RspnBuilder s _ _) = s+rspnStatus (RspnFile s _ _ _ ) = s rspnHeaders :: Rspn -> H.ResponseHeaders-rspnHeaders (RspnNobody _ h) = h-rspnHeaders (RspnStreaming _ h _) = h-rspnHeaders (RspnBuilder _ h _) = h-rspnHeaders (RspnFile _ h _ _ _ ) = h+rspnHeaders (RspnNobody _ h) = h+rspnHeaders (RspnStreaming _ h _) = h+rspnHeaders (RspnBuilder _ h _) = h+rspnHeaders (RspnFile _ h _ _ ) = h -data Output = ORspn !Stream !Rspn+data Output = ORspn !Stream !Rspn !InternalInfo | ONext !Stream !DynaNext !(Maybe (TBQueue Sequence)) outputStream :: Output -> Stream-outputStream (ORspn strm _) = strm+outputStream (ORspn strm _ _) = strm outputStream (ONext strm _ _) = strm outputMaybeTBQueue :: Output -> Maybe (TBQueue Sequence)-outputMaybeTBQueue (ORspn _ (RspnStreaming _ _ tbq)) = Just tbq-outputMaybeTBQueue (ORspn _ _) = Nothing-outputMaybeTBQueue (ONext _ _ mtbq) = mtbq+outputMaybeTBQueue (ORspn _ (RspnStreaming _ _ tbq) _) = Just tbq+outputMaybeTBQueue (ORspn _ _ _) = Nothing+outputMaybeTBQueue (ONext _ _ mtbq) = mtbq data Control = CFinish- | CGoaway !ByteString- | CFrame !ByteString- | CSettings !ByteString !SettingsList+ | CGoaway !ByteString+ | CFrame !ByteString+ | CSettings !ByteString !SettingsList+ | CSettings0 !ByteString !ByteString !SettingsList ----------------------------------------------------------------
Network/Wai/Handler/Warp/HTTP2/Worker.hs view
@@ -20,7 +20,6 @@ import qualified Control.Exception as E import Control.Monad (when) import Data.ByteString.Builder (byteString)-import Data.Hashable (hash) import qualified Network.HTTP.Types as H import Network.HTTP2 import Network.Wai@@ -42,29 +41,31 @@ -- | The wai definition is 'type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived'. -- This type implements the second argument (Response -> IO ResponseReceived) -- with extra arguments.-type Responder = ThreadContinue -> T.Handle -> Stream -> Request ->+type Responder = InternalInfo -> ThreadContinue -> Stream -> Request -> Response -> IO ResponseReceived -- | This function is passed to workers. -- They also pass 'Response's from 'Application's to this function. -- This function enqueues commands for the HTTP/2 sender.-response :: InternalInfo -> S.Settings -> Context -> Manager -> Responder-response ii settings Context{outputQ} mgr tconf th strm req rsp- | R.hasBody s0 = case rsp of- ResponseStream _ _ strmbdy- | isHead -> responseNoBody s0 hs0- | otherwise -> responseStreaming strmbdy- ResponseBuilder _ _ b- | isHead -> responseNoBody s0 hs0- | otherwise -> responseBuilderBody s0 hs0 b- ResponseFile _ _ p mp -> responseFileXXX p mp- ResponseRaw _ _ -> error "HTTP/2 does not support ResponseRaw"- | otherwise = responseNoBody s0 hs0+response :: S.Settings -> Context -> Manager -> Responder+response settings Context{outputQ} mgr ii tconf strm req rsp = case rsp of+ ResponseStream s0 hs0 strmbdy+ | noBody s0 -> responseNoBody s0 hs0+ | isHead -> responseNoBody s0 hs0+ | otherwise -> responseStreaming s0 hs0 strmbdy+ ResponseBuilder s0 hs0 b+ | noBody s0 -> responseNoBody s0 hs0+ | isHead -> responseNoBody s0 hs0+ | otherwise -> responseBuilderBody s0 hs0 b+ ResponseFile s0 hs0 p mp+ | noBody s0 -> responseNoBody s0 hs0+ | otherwise -> responseFileXXX s0 hs0 p mp+ ResponseRaw _ _ -> error "HTTP/2 does not support ResponseRaw" where+ noBody = not . R.hasBody !isHead = requestMethod req == H.methodHead- !s0 = responseStatus rsp- !hs0 = responseHeaders rsp !logger = S.settingsLogger settings+ !th = threadHandle ii -- Ideally, log messages should be written when responses are -- actually sent. But there is no way to keep good memory usage@@ -76,7 +77,7 @@ logger req s Nothing setThreadContinue tconf True let rspn = RspnNobody s hs- out = ORspn strm rspn+ out = ORspn strm rspn ii enqueueOutput outputQ out return ResponseReceived @@ -84,42 +85,39 @@ logger req s Nothing setThreadContinue tconf True let rspn = RspnBuilder s hs bdy- out = ORspn strm rspn+ out = ORspn strm rspn ii enqueueOutput outputQ out return ResponseReceived - responseFileXXX path Nothing = do- let !h = hash $ rawPathInfo req- efinfo <- E.try $ fileInfo' ii h path+ responseFileXXX _ hs0 path Nothing = do+ efinfo <- E.try $ getFileInfo ii path case efinfo of- Left (_ex :: E.IOException) -> response404+ Left (_ex :: E.IOException) -> response404 hs0 Right finfo -> case conditionalRequest finfo hs0 (indexRequestHeader (requestHeaders req)) of WithoutBody s -> responseNoBody s hs0- WithBody s hs beg len -> responseFile2XX s hs h path (Just (FilePart beg len (fileInfoSize finfo)))+ WithBody s hs beg len -> responseFile2XX s hs path (Just (FilePart beg len (fileInfoSize finfo))) - responseFileXXX path mpart = responseFile2XX s0 hs0 h path mpart- where- !h = hash $ rawPathInfo req+ responseFileXXX s0 hs0 path mpart = responseFile2XX s0 hs0 path mpart - responseFile2XX s hs h path mpart+ responseFile2XX s hs path mpart | isHead = do logger req s Nothing responseNoBody s hs | otherwise = do logger req s (filePartByteCount <$> mpart) setThreadContinue tconf True- let rspn = RspnFile s hs h path mpart- out = ORspn strm rspn+ let rspn = RspnFile s hs path mpart+ out = ORspn strm rspn ii enqueueOutput outputQ out return ResponseReceived - response404 = responseBuilderBody s hs body+ response404 hs0 = responseBuilderBody s hs body where s = H.notFound404 hs = R.replaceHeader H.hContentType "text/plain; charset=utf-8" hs0 body = byteString "File not found" - responseStreaming strmbdy = do+ responseStreaming s0 hs0 strmbdy = do logger req s0 Nothing -- We must not exit this WAI application. -- If the application exits, streaming would be also closed.@@ -134,7 +132,7 @@ -- So, let's serialize 'Builder' with a designated queue. tbq <- newTBQueueIO 10 -- fixme: hard coding: 10 let rspn = RspnStreaming s0 hs0 tbq- out = ORspn strm rspn+ out = ORspn strm rspn ii enqueueOutput outputQ out let push b = do atomically $ writeTBQueue tbq (SBuilder b)@@ -155,11 +153,11 @@ setThreadContinue tcont True ex <- E.try $ do T.pause th- inp@(Input strm req) <- atomically $ readTQueue inputQ+ inp@(Input strm req ii) <- atomically $ readTQueue inputQ setStreamInfo sinfo inp T.resume th T.tickle th- app req $ responder tcont th strm req+ app req $ responder ii tcont strm req cont1 <- case ex of Right ResponseReceived -> return True Left e@(SomeException _)@@ -179,7 +177,7 @@ minp <- getStreamInfo sinfo case minp of Nothing -> return ()- Just (Input strm req) -> do+ Just (Input strm req _ii) -> do closed ctx strm Killed let frame = resetFrame InternalError (streamNumber strm) enqueueControl controlQ $ CFrame frame
Network/Wai/Handler/Warp/HashMap.hs view
@@ -1,5 +1,7 @@ module Network.Wai.Handler.Warp.HashMap where +import Data.ByteString (ByteString)+import Data.Hashable (hash) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as I import Data.Map.Strict (Map)@@ -7,6 +9,9 @@ type Hash = Int newtype HashMap k v = HashMap (IntMap (Map k v))++hashByteString :: ByteString -> Hash+hashByteString = hash empty :: HashMap k v empty = HashMap $ I.empty
Network/Wai/Handler/Warp/MultiMap.hs view
@@ -1,240 +1,90 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, BangPatterns #-} module Network.Wai.Handler.Warp.MultiMap ( MMap- , Some(..)+ , isEmpty , empty , singleton , insert , search , searchWith- , isEmpty- , valid , pruneWith- , fromList , toList- , fromSortedList- , toSortedList , merge ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif-import Data.List (foldl')---------------------------------------------------------------------- | One ore more list to implement multimap.-data Some a = One !a- | Tom !a !(Some a) -- Two or more- deriving (Eq,Show)---- This is slow but assuming rarely used.-snoc :: Some a -> a -> Some a-snoc (One x) y = Tom x (One y)-snoc (Tom x xs) y = Tom x (snoc xs y)--top :: Some a -> a-top (One x) = x-top (Tom x _) = x---------------------------------------------------------------------- | Red black tree as multimap.-data MMap k v = Leaf -- color is Black- | Node Color !(MMap k v) !k !(Some v) !(MMap k v)- deriving (Show)--data Color = B -- ^ Black- | R -- ^ Red- deriving (Eq, Show)--------------------------------------------------------------------instance (Eq k, Eq v) => Eq (MMap k v) where- t1 == t2 = toSortedList t1 == toSortedList t2+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as I+import qualified Network.Wai.Handler.Warp.Some as S ---------------------------------------------------------------- --- | O(log N)-search :: Ord k => k -> MMap k v -> Maybe v-search _ Leaf = Nothing-search xk (Node _ l k v r) = case compare xk k of- LT -> search xk l- GT -> search xk r- EQ -> Just $ top v---- | O(log N)-searchWith :: Ord k => k -> (Some v -> Maybe v) -> MMap k v -> Maybe v-searchWith _ _ Leaf = Nothing-searchWith xk f (Node _ l k v r) = case compare xk k of- LT -> searchWith xk f l- GT -> searchWith xk f r- EQ -> f v+type MMap v = IntMap (S.Some v) ---------------------------------------------------------------- -- | O(1)-isEmpty :: MMap k v -> Bool-isEmpty Leaf = True-isEmpty _ = False+isEmpty :: MMap v -> Bool+isEmpty = I.null -- | O(1)-empty :: MMap k v-empty = Leaf+empty :: MMap v+empty = I.empty ---------------------------------------------------------------- -- | O(1)-singleton :: Ord k => k -> v -> MMap k v-singleton k v = Node B Leaf k (One v) Leaf---------------------------------------------------------------------- | O(log N)-insert :: Ord k => k -> v -> MMap k v -> MMap k v-insert kx kv t = turnB (insert' kx kv t)--insert' :: Ord k => k -> v -> MMap k v -> MMap k v-insert' xk xv Leaf = Node R Leaf xk (One xv) Leaf-insert' xk xv (Node B l k v r) = case compare xk k of- LT -> balanceL' (insert' xk xv l) k v r- GT -> balanceR' l k v (insert' xk xv r)- EQ -> Node B l k (snoc v xv) r-insert' xk xv (Node R l k v r) = case compare xk k of- LT -> Node R (insert' xk xv l) k v r- GT -> Node R l k v (insert' xk xv r)- EQ -> Node R l k (snoc v xv) r--balanceL' :: MMap k v -> k -> Some v -> MMap k v -> MMap k v-balanceL' (Node R (Node R a xk xv b) yk yv c) zk zv d =- Node R (Node B a xk xv b) yk yv (Node B c zk zv d)-balanceL' (Node R a xk xv (Node R b yk yv c)) zk zv d =- Node R (Node B a xk xv b) yk yv (Node B c zk zv d)-balanceL' l k v r = Node B l k v r--balanceR' :: MMap k v -> k -> Some v -> MMap k v -> MMap k v-balanceR' a xk xv (Node R b yk yv (Node R c zk zv d)) =- Node R (Node B a xk xv b) yk yv (Node B c zk zv d)-balanceR' a xk xv (Node R (Node R b yk yv c) zk zv d) =- Node R (Node B a xk xv b) yk yv (Node B c zk zv d)-balanceR' l xk xv r = Node B l xk xv r--turnB :: MMap k v -> MMap k v-turnB Leaf = error "turnB"-turnB (Node _ l k v r) = Node B l k v r+singleton :: Int -> v -> MMap v+singleton k v = I.singleton k (S.singleton v) ---------------------------------------------------------------- --- | O(N log N)-fromList :: Ord k => [(k,v)] -> MMap k v-fromList = foldl' (\t (k,v) -> insert k v t) empty+-- | O(log n)+search :: Int -> MMap v -> Maybe v+search k m = case I.lookup k m of+ Nothing -> Nothing+ Just s -> Just $! S.top s --- | O(N)-toList :: MMap k v -> [(k,v)]-toList t = inorder t []- where- inorder Leaf xs = xs- inorder (Node _ l k v r) xs = inorder l (pairs k v ++ inorder r xs)- pairs k (One v) = [(k,v)]- pairs k (Tom v vs) = (k,v) : pairs k vs+-- | O(log n)+searchWith :: Int -> (v -> Bool) -> MMap v -> Maybe v+searchWith k f m = case I.lookup k m of+ Nothing -> Nothing+ Just s -> S.lookupWith f s ---------------------------------------------------------------- --- | O(N)--- "Constructing Red-Black Trees" by Ralf Hinze-fromSortedList :: Ord k => [(k,Some v)] -> MMap k v-fromSortedList = linkAll . foldr add []--data Digit k v = Uno k (Some v) (MMap k v)- | Due k (Some v) (MMap k v) k (Some v) (MMap k v)- deriving (Eq,Show)--incr :: Digit k v -> [Digit k v] -> [Digit k v]-incr (Uno k v t) [] = [Uno k v t]-incr (Uno k1 v1 t1) (Uno k2 v2 t2 : ps) = Due k1 v1 t1 k2 v2 t2 : ps-incr (Uno k1 v1 t1) (Due k2 v2 t2 k3 v3 t3 : ps) = Uno k1 v1 t1 : incr (Uno k2 v2 (Node B t2 k3 v3 t3)) ps-incr _ _ = error "incr"--add :: (k,Some v) -> [Digit k v] -> [Digit k v]-add (k,v) ps = incr (Uno k v Leaf) ps--linkAll :: [Digit k v] -> MMap k v-linkAll = foldl' link Leaf--link :: MMap k v -> Digit k v -> MMap k v-link l (Uno k v t) = Node B l k v t---link l (Due k1 v1 t1 k2 v2 t2) = Node B (Node R l k1 v1 t1) k2 v2 t2-link l (Due k1 v1 t1 k2 v2 t2) = Node B l k1 v1 (Node R t1 k2 v2 t2)+-- | O(log n)+insert :: Int -> v -> MMap v -> MMap v+insert k v m = I.insertWith S.union k (S.singleton v) m ---------------------------------------------------------------- --- | O(N)-toSortedList :: MMap k v -> [(k,Some v)]-toSortedList t = inorder t []+-- | O(n)+toList :: MMap v -> [v]+toList m = concatMap f $ I.toAscList m where- inorder Leaf xs = xs- inorder (Node _ l k v r) xs = inorder l ((k,v) : inorder r xs)+ f (_,s) = S.toList s ---------------------------------------------------------------- --- | O(N)-pruneWith :: Ord k =>- MMap k v- -> (k -> Some v -> IO [(k, Some v)])- -> IO (MMap k v)-pruneWith t run = fromSortedList <$> inorder t []+-- | O(n)+pruneWith :: MMap v+ -> (v -> IO Bool)+ -> IO (MMap v)+pruneWith m action = I.fromAscList <$> go (I.toDescList m) [] where- inorder Leaf xs = return xs- inorder (Node _ l k v r) xs = do- ys <- run k v- zs <- inorder r xs- inorder l (ys ++ zs)+ go [] acc = return acc+ go ((k,s):kss) acc = do+ mt <- S.prune action s+ case mt of+ Nothing -> go kss acc+ Just t -> go kss ((k,t) : acc) ---------------------------------------------------------------- --- O(N log N) where N is the size of the second argument-merge :: Ord k => MMap k v -> MMap k v -> MMap k v-merge base m = foldl' ins base xs- where- ins t (k,v) = insert k v t- xs = toList m--------------------------------------------------------------------- for testing--valid :: Ord k => MMap k v -> Bool-valid t = isBalanced t && isOrdered t--isBalanced :: MMap k v -> Bool-isBalanced t = isBlackSame t && isRedSeparate t--isBlackSame :: MMap k v -> Bool-isBlackSame t = all (n==) ns- where- n:ns = blacks t--blacks :: MMap k v -> [Int]-blacks = blacks' 0- where- blacks' n Leaf = [n+1]- blacks' n (Node R l _ _ r) = blacks' n l ++ blacks' n r- blacks' n (Node B l _ _ r) = blacks' n' l ++ blacks' n' r- where- n' = n + 1--isRedSeparate :: MMap k v -> Bool-isRedSeparate = reds B--reds :: Color -> MMap k v -> Bool-reds _ Leaf = True-reds R (Node R _ _ _ _) = False-reds _ (Node c l _ _ r) = reds c l && reds c r--isOrdered :: Ord k => MMap k v -> Bool-isOrdered t = ordered $ toSortedList t- where- ordered [] = True- ordered [_] = True- ordered (x:y:xys) = fst x <= fst y && ordered (y:xys)+-- O(n + m) where N is the size of the second argument+merge :: MMap v -> MMap v -> MMap v+merge m1 m2 = I.unionWith S.union m1 m2
Network/Wai/Handler/Warp/Request.hs view
@@ -23,6 +23,7 @@ import Network.Wai import Network.Wai.Handler.Warp.Conduit import Network.Wai.Handler.Warp.FileInfoCache+import Network.Wai.Handler.Warp.HashMap (hashByteString) import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.ReadInt import Network.Wai.Handler.Warp.RequestHeader@@ -47,19 +48,20 @@ -- to create 'Request'. recvRequest :: Settings -> Connection- -> InternalInfo+ -> InternalInfo1 -> SockAddr -- ^ Peer's address. -> Source -- ^ Where HTTP request comes from. -> IO (Request ,Maybe (I.IORef Int) ,IndexedHeader- ,IO ByteString) -- ^+ ,IO ByteString+ ,InternalInfo) -- ^ -- 'Request' passed to 'Application', -- how many bytes remain to be consumed, if known -- 'IndexedHeader' of HTTP request for internal use, -- Body producing action used for flushing the request body -recvRequest settings conn ii addr src = do+recvRequest settings conn ii1 addr src = do hdrlines <- headerLines src (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines let idxhdr = indexRequestHeader hdr@@ -67,6 +69,13 @@ cl = idxhdr ! fromEnum ReqContentLength te = idxhdr ! fromEnum ReqTransferEncoding handle100Continue = handleExpect conn httpversion expect+ rawPath = if settingsNoParsePath settings then unparsedPath else path+ h = hashByteString rawPath+ ii = toInternalInfo ii1 h+ th = threadHandle ii+ vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)+ $ Vault.insert getFileInfoKey (getFileInfo ii)+ Vault.empty (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te -- body producing function which will produce '100-continue', if needed rbody' <- timeoutBody remainingRef th rbody handle100Continue@@ -76,7 +85,7 @@ requestMethod = method , httpVersion = httpversion , pathInfo = H.decodePathSegments path- , rawPathInfo = if settingsNoParsePath settings then unparsedPath else path+ , rawPathInfo = rawPath , rawQueryString = query , queryString = H.parseQuery query , requestHeaders = hdr@@ -90,12 +99,7 @@ , requestHeaderReferer = idxhdr ! fromEnum ReqReferer , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent }- return (req, remainingRef, idxhdr, rbodyFlush)- where- th = threadHandle ii- vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)- $ Vault.insert getFileInfoKey (fileInfo ii)- Vault.empty+ return (req, remainingRef, idxhdr, rbodyFlush, ii) ----------------------------------------------------------------
Network/Wai/Handler/Warp/Response.hs view
@@ -36,7 +36,6 @@ import Data.ByteString.Builder.Extra (flush) import qualified Data.CaseInsensitive as CI import Data.Function (on)-import Data.Hashable (hash) import Data.List (deleteBy) import Data.Maybe #if MIN_VERSION_base(4,5,0)@@ -57,9 +56,6 @@ import Network.Wai import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer) import qualified Network.Wai.Handler.Warp.Date as D-#ifndef WINDOWS-import qualified Network.Wai.Handler.Warp.FdCache as F-#endif import Network.Wai.Handler.Warp.File import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.IO (toBufIOWith)@@ -148,14 +144,14 @@ -- and status, the response to HEAD is processed here. -- -- See definition of rsp below for proper body stripping.- (ms, mlen) <- sendRsp conn ii req ver s hs rsp+ (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- _ <- sendRsp conn ii req ver s hs RspNoBody+ _ <- sendRsp conn ii ver s hs RspNoBody logger req s Nothing T.tickle th return isPersist@@ -167,8 +163,8 @@ hs0 = sanitizeHeaders $ responseHeaders response rspidxhdr = indexResponseHeader hs0 th = threadHandle ii- dc = dateCacher ii- addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr+ getdate = getDate ii+ addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr (isPersist,isChunked0) = infoFromRequest req reqidxhdr isChunked = not isHead && isChunked0 (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr (isPersist,isChunked)@@ -225,7 +221,6 @@ sendRsp :: Connection -> InternalInfo- -> Request -> H.HttpVersion -> H.Status -> H.ResponseHeaders@@ -234,7 +229,7 @@ ---------------------------------------------------------------- -sendRsp conn _ _ ver s hs RspNoBody = do+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@@ -242,7 +237,7 @@ ---------------------------------------------------------------- -sendRsp conn _ _ ver s hs (RspBuilder body needsChunked) = do+sendRsp conn _ ver s hs (RspBuilder body needsChunked) = do header <- composeHeaderBuilder ver s hs needsChunked let hdrBdy | needsChunked = header <> chunkedTransferEncoding body@@ -255,7 +250,7 @@ ---------------------------------------------------------------- -sendRsp conn _ _ ver s hs (RspStream streamingBody needsChunked th) = do+sendRsp conn _ ver s hs (RspStream streamingBody needsChunked th) = do header <- composeHeaderBuilder ver s hs needsChunked (recv, finish) <- newBlazeRecv $ reuseBufferStrategy $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)@@ -279,7 +274,7 @@ ---------------------------------------------------------------- -sendRsp conn _ _ _ _ _ (RspRaw withApp src tickle) = do+sendRsp conn _ _ _ _ (RspRaw withApp src tickle) = do withApp recv send return (Nothing, Nothing) where@@ -293,10 +288,9 @@ -- Sophisticated WAI applications. -- We respect s0. s0 MUST be a proper value.-sendRsp conn ii req ver s0 hs0 (RspFile path (Just part) _ isHead hook) =- sendRspFile2XX conn ii req ver s0 hs h path beg len isHead hook+sendRsp conn ii ver s0 hs0 (RspFile path (Just part) _ isHead hook) =+ sendRspFile2XX conn ii ver s0 hs path beg len isHead hook where- h = hash $ rawPathInfo req beg = filePartOffset part len = filePartByteCount part hs = addContentHeadersForFilePart hs0 part@@ -305,60 +299,47 @@ -- Simple WAI applications. -- Status is ignored-sendRsp conn ii req ver _ hs0 (RspFile path Nothing idxhdr isHead hook) = do- let h = hash $ rawPathInfo req- efinfo <- E.try $ fileInfo' ii h path+sendRsp conn ii ver _ hs0 (RspFile path Nothing idxhdr isHead hook) = do+ efinfo <- E.try $ getFileInfo ii path case efinfo of Left (_ex :: E.IOException) -> #ifdef WARP_DEBUG print _ex >> #endif- sendRspFile404 conn ii req ver hs0+ sendRspFile404 conn ii ver hs0 Right finfo -> case conditionalRequest finfo hs0 idxhdr of- WithoutBody s -> sendRsp conn ii req ver s hs0 RspNoBody- WithBody s hs beg len -> sendRspFile2XX conn ii req ver s hs h path beg len isHead hook+ 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- -> Request -> H.HttpVersion -> H.Status -> H.ResponseHeaders- -> Hash -> FilePath -> Integer -> Integer -> Bool -> IO () -> IO (Maybe H.Status, Maybe Integer)-sendRspFile2XX conn ii req ver s hs h path beg len isHead hook- | isHead = sendRsp conn ii req ver s hs RspNoBody+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 h path- return (Just fd, hook >> fresher)+ (mfd, fresher) <- getFd ii path let fid = FileId path mfd-#endif+ hook' = hook >> fresher connSendFile conn fid beg len hook' [lheader] return (Just s, Just len) sendRspFile404 :: Connection -> InternalInfo- -> Request -> H.HttpVersion -> H.ResponseHeaders -> IO (Maybe H.Status, Maybe Integer)-sendRspFile404 conn ii req ver hs0 = sendRsp conn ii req ver s hs (RspBuilder body True)+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@@ -435,10 +416,10 @@ addTransferEncoding hdrs = ("transfer-encoding", "chunked") : hdrs #endif -addDate :: D.DateCache -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders-addDate dc rspidxhdr hdrs = case rspidxhdr ! fromEnum ResDate of+addDate :: IO D.GMTDate -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders+addDate getdate rspidxhdr hdrs = case rspidxhdr ! fromEnum ResDate of Nothing -> do- gmtdate <- D.getDate dc+ gmtdate <- getdate return $ (H.hDate, gmtdate) : hdrs Just _ -> return hdrs
Network/Wai/Handler/Warp/Run.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} module Network.Wai.Handler.Warp.Run where@@ -22,7 +23,7 @@ import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Streaming.Network (bindPortTCP) import Network (sClose, Socket)-import Network.Socket (accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6))+import Network.Socket (accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..)) import qualified Network.Socket.ByteString as Sock import Network.Wai import Network.Wai.Handler.Warp.Buffer@@ -47,7 +48,6 @@ #if WINDOWS import Network.Wai.Handler.Warp.Windows #else-import System.Posix.IO (FdOption(CloseOnExec), setFdOption) import Network.Socket (fdSocket) #endif @@ -130,6 +130,7 @@ (s, sa) <- accept socket #endif setSocketCloseOnExec s+ setSocketOption s NoDelay 1 conn <- socketConnection s return (conn, sa) @@ -171,22 +172,23 @@ runSettingsConnectionMakerSecure set getConnMaker app = do settingsBeforeMainLoop set counter <- newCounter- withII $ acceptConnection set getConnMaker app counter+ withII0 $ acceptConnection set getConnMaker app counter where- withII action =+ withII0 action =+ withTimeoutManager $ \tm -> D.withDateCache $ \dc ->- F.withFdCache fdCacheDurationInSeconds $ \fc ->- I.withFileInfoCache fdFileInfoDurationInSeconds $ \get get' ->- withTimeoutManager $ \tm -> do- let ii0 = InternalInfo undefined tm fc get get' dc -- fixme: undefined+ F.withFdCache fdCacheDurationInSeconds $ \fdc ->+ I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do+ let ii0 = InternalInfo0 tm dc fdc fic action ii0 - fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000- fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000+ !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000+ !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000+ !timeoutInSeconds = settingsTimeout set * 1000000 withTimeoutManager f = case settingsManager set of Just tm -> f tm Nothing -> bracket- (T.initialize $ settingsTimeout set * 1000000)+ (T.initialize timeoutInSeconds) T.stopManager f @@ -207,7 +209,7 @@ -> IO (IO (Connection, Transport), SockAddr) -> Application -> Counter- -> InternalInfo+ -> InternalInfo0 -> IO () acceptConnection set getConnMaker app counter ii0 = do -- First mask all exceptions in acceptLoop. This is necessary to@@ -257,7 +259,7 @@ -> SockAddr -> Application -> Counter- -> InternalInfo+ -> InternalInfo0 -> IO () fork set mkConn addr app counter ii0 = settingsFork set $ \ unmask -> -- Run the connection maker to get a new connection, and ensure@@ -274,9 +276,9 @@ -- We need to register a timeout handler for this thread, and -- cancel that handler as soon as we exit.- bracket (T.registerKillThread (timeoutManager ii0)) T.cancel $ \th ->+ bracket (T.registerKillThread (timeoutManager0 ii0)) T.cancel $ \th -> - let ii = ii0 { threadHandle = th }+ let ii1 = toInternalInfo1 ii0 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.@@ -290,7 +292,7 @@ -- Actually serve this connection. -- bracket with closeConn above ensures the connection is closed.- when goingon $ serveConnection conn ii addr transport set app+ when goingon $ serveConnection conn ii1 addr transport set app where closeConn (conn, _transport) = connClose conn @@ -298,13 +300,13 @@ onClose adr _ = decrease counter >> settingsOnClose set adr serveConnection :: Connection- -> InternalInfo+ -> InternalInfo1 -> SockAddr -> Transport -> Settings -> Application -> IO ()-serveConnection conn ii origAddr transport settings app = do+serveConnection conn ii1 origAddr transport settings app = do -- fixme: Upgrading to HTTP/2 should be supported. (h2,bs) <- if isHTTP2 transport then return (True, "")@@ -317,7 +319,7 @@ if settingsHTTP2Enabled settings && h2 then do recvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn) -- fixme: origAddr- http2 conn ii origAddr transport settings recvN app+ http2 conn ii1 origAddr transport settings recvN app else do istatus <- newIORef False src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))@@ -368,7 +370,7 @@ decodeAscii = map (chr . fromEnum) . S.unpack - th = threadHandle ii+ th = threadHandle1 ii1 shouldSendErrorResponse se | Just ConnectionClosedByPeer <- fromException se = False@@ -376,17 +378,19 @@ sendErrorResponse addr istatus e = do status <- readIORef istatus- when (shouldSendErrorResponse e && status) $ void $- sendResponse settings conn ii (dummyreq addr) defaultIndexRequestHeader (return S.empty) (errorResponse e)+ when (shouldSendErrorResponse e && status) $ do+ let ii = toInternalInfo ii1 0 -- dummy+ dreq = dummyreq addr+ void $ sendResponse settings conn ii dreq defaultIndexRequestHeader (return S.empty) (errorResponse e) dummyreq addr = defaultRequest { remoteHost = addr } errorResponse e = settingsOnExceptionResponse settings e http1 addr istatus src = do- (req', mremainingRef, idxhdr, nextBodyFlush) <- recvRequest settings conn ii addr src+ (req', mremainingRef, idxhdr, nextBodyFlush, ii) <- recvRequest settings conn ii1 addr src let req = req' { isSecure = isTransportSecure transport }- keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush+ keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii `E.catch` \e -> do -- Call the user-supplied exception handlers, passing the request. sendErrorResponse addr istatus e@@ -395,7 +399,7 @@ return False when keepAlive $ http1 addr istatus src - processRequest istatus src req mremainingRef idxhdr nextBodyFlush = do+ processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii = do -- Let the application run for as long as it wants T.pause th @@ -489,8 +493,7 @@ #if WINDOWS setSocketCloseOnExec _ = return () #else-setSocketCloseOnExec socket =- setFdOption (fromIntegral $ fdSocket socket) CloseOnExec True+setSocketCloseOnExec socket = F.setFileCloseOnExec $ fromIntegral $ fdSocket socket #endif gracefulShutdown :: Counter -> IO ()
Network/Wai/Handler/Warp/SendFile.hs view
@@ -30,7 +30,7 @@ import Foreign.C.Types import Foreign.Ptr (Ptr, castPtr, plusPtr) import Network.Sendfile-import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd)+import Network.Wai.Handler.Warp.FdCache (openFile, closeFile) import System.Posix.Types #endif @@ -129,10 +129,10 @@ path = fileIdPath fid setup = case fileIdFd fid of Just fd -> return fd- Nothing -> openFd path ReadOnly Nothing defaultFileFlags{nonBlock=True}+ Nothing -> openFile path teardown fd = case fileIdFd fid of Just _ -> return ()- Nothing -> closeFd fd+ Nothing -> closeFile fd loop fd len off | len <= 0 = return () | otherwise = do
+ Network/Wai/Handler/Warp/Some.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE BangPatterns #-}++module Network.Wai.Handler.Warp.Some (+ Some+ , singleton+ , top+ , lookupWith+ , union+ , toList+ , prune+ ) where++----------------------------------------------------------------++-- | One ore more list to implement multimap.+data Some a = One !a+ | Tom !a !(Some a) -- Two or more+ deriving (Eq,Show)++{-# INLINE singleton #-}+singleton :: a -> Some a+singleton x = One x++{-# INLINE top #-}+top :: Some a -> a+top (One x) = x+top (Tom x _) = x++{-# INLINE lookupWith #-}+lookupWith :: (a -> Bool) -> Some a -> Maybe a+lookupWith f s = go s+ where+ go (One x)+ | f x = Just x+ | otherwise = Nothing+ go (Tom x xs)+ | f x = Just x+ | otherwise = go xs++{-# INLINE union #-}+union :: Some a -> Some a -> Some a+union s t = go s t+ where+ go (One x) u = Tom x u+ go (Tom x xs) u = go xs (Tom x u)++{-# INLINE toList #-}+toList :: Some a -> [a]+toList s = go s []+ where+ go (One x) !acc = x : acc+ go (Tom x xs) !acc = go xs (x : acc)++{-# INLINE prune #-}+prune :: (a -> IO Bool) -> Some a -> IO (Maybe (Some a))+prune act s = go s+ where+ go (One x) = do+ keep <- act x+ return $ if keep then+ Just (One x)+ else+ Nothing+ go (Tom x xs) = do+ keep <- act x+ mys <- go xs+ return $ if keep then+ case mys of+ Nothing -> Just (One x)+ Just ys -> Just (Tom x ys)+ else+ mys+
Network/Wai/Handler/Warp/Types.hs view
@@ -15,10 +15,7 @@ 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 import System.Posix.Types (Fd)-#endif ---------------------------------------------------------------- @@ -55,10 +52,6 @@ ---------------------------------------------------------------- -#ifdef WINDOWS-type Fd = ()-#endif- -- | Data type to abstract file identifiers. -- On Unix, a file descriptor would be specified to make use of -- the file descriptor cache.@@ -116,15 +109,39 @@ type Hash = Int --- | Internal information.++data InternalInfo0 =+ InternalInfo0 T.Manager+ (IO D.GMTDate)+ (Hash -> FilePath -> IO (Maybe F.Fd, F.Refresh))+ (Hash -> FilePath -> IO I.FileInfo)++timeoutManager0 :: InternalInfo0 -> T.Manager+timeoutManager0 (InternalInfo0 tm _ _ _) = tm++data InternalInfo1 =+ InternalInfo1 T.Handle+ T.Manager+ (IO D.GMTDate)+ (Hash -> FilePath -> IO (Maybe F.Fd, F.Refresh))+ (Hash -> FilePath -> IO I.FileInfo)++toInternalInfo1 :: InternalInfo0 -> T.Handle -> InternalInfo1+toInternalInfo1 (InternalInfo0 b c d e) a = InternalInfo1 a b c d e++threadHandle1 :: InternalInfo1 -> T.Handle+threadHandle1 (InternalInfo1 th _ _ _ _) = th+ data InternalInfo = InternalInfo {- threadHandle :: T.Handle+ threadHandle :: T.Handle , timeoutManager :: T.Manager- , fdCacher :: Maybe F.MutableFdCache- , fileInfo :: FilePath -> IO I.FileInfo- , fileInfo' :: Int -> FilePath -> IO I.FileInfo- , dateCacher :: D.DateCache+ , getDate :: IO D.GMTDate+ , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh)+ , getFileInfo :: FilePath -> IO I.FileInfo }++toInternalInfo :: InternalInfo1 -> Hash -> InternalInfo+toInternalInfo (InternalInfo1 a b c d e) h = InternalInfo a b c (d h) (e h) ----------------------------------------------------------------
+ Network/Wai/Handler/Warp/WithApplication.hs view
@@ -0,0 +1,90 @@++module Network.Wai.Handler.Warp.WithApplication (+ withApplication,+ testWithApplication,+ openFreePort,+ withFreePort,+) where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Exception+import Network.Socket+import Network.Wai+import Network.Wai.Handler.Warp.Run+import Network.Wai.Handler.Warp.Settings+import Network.Wai.Handler.Warp.Types++-- | Runs the given 'Application' on a free port. Passes the port to the given+-- operation and executes it, while the 'Application' is running. Shuts down the+-- server before returning.+--+-- @since 3.2.4+withApplication :: IO Application -> (Port -> IO a) -> IO a+withApplication mkApp action = do+ app <- mkApp+ withFreePort $ \ (port, sock) -> do+ started <- mkWaiter+ let settings =+ defaultSettings{+ settingsBeforeMainLoop = notify started ()+ }+ result <- race+ (runSettingsSocket settings sock app)+ (waitFor started >> action port)+ case result of+ Left () -> throwIO $ ErrorCall "Unexpected: runSettingsSocket exited"+ Right x -> return x++-- | Same as 'withApplication' but with different exception handling: If the+-- given 'Application' throws an exception, 'testWithApplication' will re-throw+-- the exception to the calling thread, possibly interrupting the execution of+-- the given operation.+--+-- This is handy for running tests against an 'Application' over a real network+-- port. When running tests, it's useful to let exceptions thrown by your+-- 'Application' propagate to the main thread of the test-suite.+--+-- __The exception handling makes this function unsuitable for use in production.__+-- Use 'withApplication' instead.+--+-- @since 3.2.4+testWithApplication :: IO Application -> (Port -> IO a) -> IO a+testWithApplication mkApp action = do+ callingThread <- myThreadId+ app <- mkApp+ let wrappedApp request respond =+ app request respond `catch` \ e -> do+ throwTo callingThread (e :: SomeException)+ throwIO e+ withApplication (return wrappedApp) action++data Waiter a+ = Waiter {+ notify :: a -> IO (),+ waitFor :: IO a+ }++mkWaiter :: IO (Waiter a)+mkWaiter = do+ mvar <- newEmptyMVar+ return $ Waiter {+ notify = putMVar mvar,+ waitFor = readMVar mvar+ }++-- | Opens a socket on a free port and returns both port and socket.+--+-- @since 3.2.4+openFreePort :: IO (Port, Socket)+openFreePort = do+ s <- socket AF_INET Stream defaultProtocol+ localhost <- inet_addr "127.0.0.1"+ bind s (SockAddrInet aNY_PORT localhost)+ listen s 1+ port <- socketPort s+ return (fromIntegral port, s)++-- | Like 'openFreePort' but closes the socket before exiting.+withFreePort :: ((Port, Socket) -> IO a) -> IO a+withFreePort = bracket openFreePort (close . snd)
test/FdCacheSpec.hs view
@@ -16,8 +16,8 @@ spec = describe "withFdCache" $ do it "clean up Fd" $ do ref <- newIORef (Fd (-1))- withFdCache 30000000 $ \(Just mfc) -> do- (fd,_) <- getFd mfc "warp.cabal"+ withFdCache 30000000 $ \getFd -> do+ (Just fd,_) <- getFd 0 "warp.cabal" writeIORef ref fd nfd <- readIORef ref fdRead nfd 1 `shouldThrow` anyIOException
− test/MultiMapSpec.hs
@@ -1,30 +0,0 @@-module MultiMapSpec where--import Network.Wai.Handler.Warp.MultiMap-import Test.Hspec-import Test.QuickCheck (property)--type Alist = [(Int,Char)]--spec :: Spec-spec = do- describe "fromList" $ do- it "generates a valid tree" $ property $ \xs ->- valid $ fromList (xs :: Alist)- describe "toSortedList" $ do- it "generated a sorted list" $ property $ \xs ->- ordered $ toSortedList $ fromList (xs :: Alist)- describe "search" $ do- it "acts as the list model" $ property $ \x xs ->- search x (fromList xs) == lookup x (xs :: Alist)- describe "fromSortedList" $ do- it "generates a valid tree" $ property $ \xs ->- valid . fromSortedList . toSortedList . fromList $ (xs :: Alist)- it "maintains the tree with toSortedList" $ property $ \xs ->- let t1 = fromList (xs :: Alist)- t2 = fromSortedList $ toSortedList t1- in t1 == t2--ordered :: Ord a => [(a, b)] -> Bool-ordered (x:y:xys) = fst x <= fst y && ordered (y:xys)-ordered _ = True
+ test/WithApplicationSpec.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}++module WithApplicationSpec where++import Control.Concurrent+import Control.Exception+import Network.HTTP.Types+import Network.Socket+import Network.Wai+import System.IO+import System.IO.Silently+import System.Process+import Test.Hspec++import Network.Wai.Handler.Warp.WithApplication++spec :: Spec+spec = do+ describe "withApplication" $ do+ it "runs a wai Application while executing the given action" $ do+ let mkApp = return $ \ _request respond -> respond $ responseLBS ok200 [] "foo"+ withApplication mkApp $ \ port -> do+ output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""+ output `shouldBe` "foo"++ it "does not propagate exceptions from the server to the executing thread" $+ hSilence [stderr] $ do+ let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"+ withApplication mkApp $ \ port -> do+ output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""+ output `shouldContain` "Something went wron"++ describe "testWithApplication" $ do+ it "propagates exceptions from the server to the executing thread" $+ hSilence [stderr] $ do+ let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"+ (testWithApplication mkApp $ \ port -> do+ readProcess "curl" ["-s", "localhost:" ++ show port] "")+ `shouldThrow` (errorCall "foo")++ describe "withFreePort" $ do+ it "closes the socket before exiting" $ do+ MkSocket _ _ _ _ statusMVar <- withFreePort $ \ (_, sock) -> do+ return sock+ readMVar statusMVar `shouldReturn` Closed
warp.cabal view
@@ -1,5 +1,5 @@ Name: warp-Version: 3.2.3+Version: 3.2.4 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE@@ -34,6 +34,7 @@ Library Build-Depends: base >= 3 && < 5 , array+ , async , auto-update >= 0.1.3 && < 0.2 , blaze-builder >= 0.4 , bytestring >= 0.9.1.4@@ -90,9 +91,11 @@ Network.Wai.Handler.Warp.Run Network.Wai.Handler.Warp.SendFile Network.Wai.Handler.Warp.Settings+ Network.Wai.Handler.Warp.Some Network.Wai.Handler.Warp.Timeout Network.Wai.Handler.Warp.Types Network.Wai.Handler.Warp.Windows+ Network.Wai.Handler.Warp.WithApplication Paths_warp Ghc-Options: -Wall @@ -122,13 +125,13 @@ ExceptionSpec FdCacheSpec FileSpec- MultiMapSpec ReadIntSpec RequestSpec ResponseHeaderSpec ResponseSpec RunSpec SendFileSpec+ WithApplicationSpec HTTP Hs-Source-Dirs: test, . Type: exitcode-stdio-1.0@@ -157,6 +160,7 @@ , time , text , streaming-commons >= 0.1.10+ , silently , async , vault , stm >= 2.3