packages feed

warp 1.3.1.1 → 1.3.1.2

raw patch · 7 files changed

+430/−19 lines, 7 filesdep +hashabledep +unix

Dependencies added: hashable, unix

Files

Network/Wai/Handler/Warp/Conduit.hs view
@@ -93,7 +93,10 @@      go src NeedLen = go' src id     go src NeedLenNewline = go' src (CB.take 2 >>)-    go src (HaveLen 0) = liftIO $ I.writeIORef ipair (src, HaveLen 0)+    go src (HaveLen 0) = do+        -- Drop the final CRLF+        (src', ()) <- lift $ src $$++ CB.drop 2+        liftIO $ I.writeIORef ipair (src', HaveLen 0)     go src (HaveLen len) = do         (src', mbs) <- lift $ src $$++ CL.head         case mbs of
+ Network/Wai/Handler/Warp/FdCache.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE BangPatterns, FlexibleInstances #-}++module Network.Wai.Handler.Warp.FdCache (+    initialize+  , getFd+  , MutableFdCache+  ) where++import Control.Applicative ((<$>), (<*>))+import Control.Concurrent+import Control.Monad+import Data.Hashable+import Data.IORef+import Network.Wai.Handler.Warp.MultiMap+import System.Posix.IO+import System.Posix.Types++----------------------------------------------------------------++data Status = Active | Inactive++newtype MutableStatus = MutableStatus (IORef Status)++type Refresh = IO ()++status :: MutableStatus -> IO Status+status (MutableStatus ref) = readIORef ref++newActiveStatus :: IO MutableStatus+newActiveStatus = MutableStatus <$> newIORef Active++refresh :: MutableStatus -> Refresh+refresh (MutableStatus ref) = writeIORef ref Active++inactive :: MutableStatus -> IO ()+inactive (MutableStatus ref) = writeIORef ref Inactive++----------------------------------------------------------------++data FdEntry = FdEntry !FilePath !Fd !MutableStatus++newFdEntry :: FilePath -> IO FdEntry+newFdEntry path = FdEntry path+              <$> openFd path ReadOnly Nothing defaultFileFlags+              <*> newActiveStatus++----------------------------------------------------------------++type Hash = Int+type FdCache = MMap Hash FdEntry+newtype MutableFdCache = MutableFdCache (IORef FdCache)++newMutableFdCache :: IO MutableFdCache+newMutableFdCache = MutableFdCache <$> newIORef empty++fdCache :: MutableFdCache -> IO FdCache+fdCache (MutableFdCache ref) = readIORef ref++swapWithNew :: MutableFdCache -> IO FdCache+swapWithNew (MutableFdCache ref) = atomicModifyIORef ref (\t -> (empty, t))++update :: MutableFdCache -> (FdCache -> FdCache) -> IO ()+update (MutableFdCache ref) f = do+    !_  <- atomicModifyIORef ref $ \t -> let !new = f t in (new, ())+    return ()++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++----------------------------------------------------------------++initialize :: IO MutableFdCache+initialize = do+    mfc <- newMutableFdCache+    void . forkIO $ loop mfc+    return mfc+  where+    loop mfc = do+        old <- swapWithNew mfc+        new <- pruneWith old prune+        update mfc (merge new)+        threadDelay 10000000 -- FIXME+        loop mfc++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++----------------------------------------------------------------++getFd :: MutableFdCache -> FilePath -> IO (Fd, Refresh)+getFd mfc path = look mfc path key >>= getFd'+  where+    key = hash path+    getFd' Nothing = do+        ent@(FdEntry _ fd mst) <- newFdEntry path+        update mfc (insert key ent)+        return $ (fd, refresh mst)+    getFd' (Just (FdEntry _ fd mst)) = do+        refresh mst+        return $ (fd, refresh mst)
+ Network/Wai/Handler/Warp/MultiMap.hs view
@@ -0,0 +1,236 @@+module Network.Wai.Handler.Warp.MultiMap (+    MMap+  , Some(..)+  , empty+  , singleton+  , insert+  , search+  , searchWith+  , isEmpty+  , valid+  , pruneWith+  , fromList+  , toList+  , fromSortedList+  , toSortedList+  , merge+  ) where++import Control.Applicative ((<$>))+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++----------------------------------------------------------------++-- | 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++----------------------------------------------------------------++-- | O(1)+isEmpty :: (Eq k, Eq v) => MMap k v -> Bool+isEmpty Leaf = True+isEmpty _    = False++-- | O(1)+empty :: MMap k v+empty = Leaf++----------------------------------------------------------------++-- | 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++----------------------------------------------------------------++-- | O(N log N)+fromList :: Ord k => [(k,v)] -> MMap k v+fromList = foldl' (\t (k,v) -> insert k v t) empty++-- | 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(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(N)+toSortedList :: MMap k v -> [(k,Some v)]+toSortedList t = inorder t []+  where+    inorder Leaf xs = xs+    inorder (Node _ l k v r) xs = inorder l ((k,v) : inorder r xs)++----------------------------------------------------------------++-- | 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 []+  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)++----------------------------------------------------------------++-- 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)
Network/Wai/Handler/Warp/Response.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}  module Network.Wai.Handler.Warp.Response (     sendResponse@@ -30,18 +31,19 @@ ---------------------------------------------------------------- ---------------------------------------------------------------- -sendResponse :: T.Handle-             -> Request -> Connection -> Response -> ResourceT IO Bool+sendResponse :: Cleaner -> Request -> Connection -> Response+             -> ResourceT IO Bool  ---------------------------------------------------------------- -sendResponse th req conn (ResponseFile s hs fp mpart) =+sendResponse cleaner req conn (ResponseFile s hs path mpart) =     headerAndLength >>= sendResponse'   where+    th = threadHandle cleaner     headerAndLength = case (readInt <$> checkLength hs, mpart) of         (Just cl, _)         -> return $ Right (hs, cl)         (Nothing, Nothing)   -> liftIO . try $ do-            cl <- fromIntegral . P.fileSize <$> P.getFileStatus fp+            cl <- fromIntegral . P.fileSize <$> P.getFileStatus path             return (addLength cl hs, cl)         (Nothing, Just part) -> do             let cl = fromIntegral $ filePartByteCount part@@ -49,7 +51,7 @@      sendResponse' (Right (lengthyHeaders, cl))       | hasBody s req = liftIO $ do-          connSendFile conn fp beg end (T.tickle th) [lheader]+          connSendFile conn path beg end (T.tickle th) [lheader] cleaner           T.tickle th           return isPersist       | otherwise = liftIO $ do@@ -65,13 +67,13 @@         (isPersist,_) = infoFromRequest req      sendResponse' (Left (_ :: SomeException)) =-        sendResponse th req conn notFound+        sendResponse cleaner req conn notFound       where         notFound = responseLBS H.status404 [(H.hContentType, "text/plain")] "File not found"  ---------------------------------------------------------------- -sendResponse th req conn (ResponseBuilder s hs b)+sendResponse cleaner req conn (ResponseBuilder s hs b)   | hasBody s req = liftIO $ do       flip toByteStringIO body $ \bs -> do           connSendAll conn bs@@ -82,6 +84,7 @@       T.tickle th       return isPersist   where+    th = threadHandle cleaner     header = composeHeaderBuilder version s hs needsChunked     body       | needsChunked = header `mappend` chunkedTransferEncoding b@@ -93,7 +96,7 @@  ---------------------------------------------------------------- -sendResponse th req conn (ResponseSource s hs bodyFlush)+sendResponse cleaner req conn (ResponseSource s hs bodyFlush)   | hasBody s req = do       let src = CL.sourceList [header] `mappend` cbody       src $$ builderToByteString =$ connSink conn th@@ -103,6 +106,7 @@       T.tickle th       return isPersist   where+    th = threadHandle cleaner     header = composeHeaderBuilder version s hs needsChunked     body = mapOutput (\x -> case x of                     Flush -> flush
Network/Wai/Handler/Warp/Run.hs view
@@ -40,6 +40,8 @@ #if WINDOWS import qualified Control.Concurrent.MVar as MV import Network.Socket (withSocketsDo)+#else+import qualified Network.Wai.Handler.Warp.FdCache as F #endif  -- FIXME come up with good values here@@ -55,7 +57,7 @@ #endif     { connSendMany = Sock.sendMany s     , connSendAll = Sock.sendAll s-    , connSendFile = \fp off len act hdr -> sendfileWithHeader s fp (PartOfFile off len) act hdr+    , connSendFile = sendFile s     , connClose = sClose s #ifdef PESSIMISTIC_RECV     , connRecv = threadWaitRead (Fd fd) >> Sock.recv s bytesPerRead@@ -64,6 +66,16 @@ #endif     } +sendFile :: Socket -> FilePath -> Integer -> Integer -> IO () -> [ByteString] -> Cleaner -> IO ()+#if WINDOWS+sendFile s path off len act hdr _ =+    sendfileWithHeader s path (PartOfFile off len) act hdr+#else+sendFile s path off len act hdr cleaner = do+    (fd, fresher) <- F.getFd (fdCacher cleaner) path+    sendfileFdWithHeader s fd (PartOfFile off len) (act>>fresher) hdr+#endif+ #if __GLASGOW_HASKELL__ < 702 allowInterrupt :: IO () allowInterrupt = unblock $ return ()@@ -113,14 +125,22 @@ runSettingsConnection set getConn app = do     tm <- maybe (T.initialize $ settingsTimeout set * 1000000) return         $ settingsManager set+#if !WINDOWS+    fc <- F.initialize+#endif     mask $ \restore -> forever $ do         allowInterrupt         (conn, addr) <- getConnLoop         void . forkIO $ do             th <- T.registerKillThread tm+#if WINDOWS+            let cleaner = Cleaner th+#else+            let cleaner = Cleaner th fc+#endif             let serve = do                     onOpen-                    restore $ serveConnection set th port app conn addr+                    restore $ serveConnection set cleaner port app conn addr                     cleanup                 cleanup = connClose conn >> T.cancel th >> onClose             handle onE $ (serve `onException` cleanup)@@ -138,11 +158,13 @@     onClose = settingsOnClose set  serveConnection :: Settings-                -> T.Handle+                -> Cleaner                 -> Port -> Application -> Connection -> SockAddr-> IO ()-serveConnection settings th port app conn remoteHost' =+serveConnection settings cleaner port app conn remoteHost' =     runResourceT serveConnection'   where+    th = threadHandle cleaner+     serveConnection' :: ResourceT IO ()     serveConnection' = serveConnection'' $ connSource conn th @@ -155,7 +177,7 @@                 res <- app env                  liftIO $ T.resume th-                keepAlive <- sendResponse th env conn res+                keepAlive <- sendResponse cleaner env conn res                  -- flush the rest of the request body                 requestBody env $$ CL.sinkNull
Network/Wai/Handler/Warp/Types.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}  module Network.Wai.Handler.Warp.Types where @@ -9,6 +10,10 @@ import Data.Version (showVersion) import Network.HTTP.Types.Header import qualified Paths_warp+import qualified Network.Wai.Handler.Warp.Timeout as T+#if !WINDOWS+import qualified Network.Wai.Handler.Warp.FdCache as F+#endif  ---------------------------------------------------------------- @@ -66,7 +71,18 @@ data Connection = Connection     { connSendMany :: [ByteString] -> IO ()     , connSendAll  :: ByteString -> IO ()-    , connSendFile :: FilePath -> Integer -> Integer -> IO () -> [ByteString] -> IO () -- ^ offset, length+    , connSendFile :: FilePath -> Integer -> Integer -> IO () -> [ByteString] -> Cleaner -> IO () -- ^ offset, length     , connClose    :: IO ()     , connRecv     :: IO ByteString     }++----------------------------------------------------------------++#if WINDOWS+newtype Cleaner = Cleaner { threadHandle :: T.Handle }+#else+data Cleaner = Cleaner {+    threadHandle :: T.Handle+  , fdCacher :: F.MutableFdCache+  }+#endif
warp.cabal view
@@ -1,9 +1,9 @@ Name:                warp-Version:             1.3.1.1+Version:             1.3.1.2 Synopsis:            A fast, light-weight web server for WAI applications. License:             MIT License-file:        LICENSE-Author:              Michael Snoyman, Matt Brown+Author:              Michael Snoyman, Kazu Yamamoto, Matt Brown Maintainer:          michael@snoyman.com Homepage:            http://github.com/yesodweb/wai Category:            Web, Yesod@@ -32,8 +32,8 @@                    , void                    , wai                       >= 1.3      && < 1.4   if flag(network-bytestring)-      Build-Depends: network               >= 2.2.1.5 && < 2.2.3-                   , network-bytestring    >= 0.1.3   && < 0.1.4+      Build-Depends: network                   >= 2.2.1.5  && < 2.2.3+                   , network-bytestring        >= 0.1.3    && < 0.1.4   else       Build-Depends: network               >= 2.3   Exposed-modules:   Network.Wai.Handler.Warp@@ -50,6 +50,11 @@   Ghc-Options:       -Wall   if os(windows)       Cpp-options:   -DWINDOWS+  else+      Build-Depends: unix+                   , hashable+      Other-modules: Network.Wai.Handler.Warp.FdCache+                     Network.Wai.Handler.Warp.MultiMap  Test-Suite spec     Main-Is:         Spec.hs@@ -76,6 +81,11 @@                    , HUnit                    , QuickCheck                    , hspec                    == 1.3.*+  if os(windows)+      Cpp-options:   -DWINDOWS+  else+      Build-Depends: unix+                   , hashable  Source-Repository head   Type:     git