warp 3.0.0.5 → 3.0.0.6
raw patch · 7 files changed
+42/−123 lines, 7 filesdep +auto-update
Dependencies added: auto-update
Files
- Network/Wai/Handler/Warp/Date.hs +6/−19
- Network/Wai/Handler/Warp/FdCache.hs +17/−26
- Network/Wai/Handler/Warp/MultiMap.hs +1/−1
- Network/Wai/Handler/Warp/Thread.hs +0/−28
- Network/Wai/Handler/Warp/Timeout.hs +15/−20
- test/ThreadSpec.hs +0/−26
- warp.cabal +3/−3
Network/Wai/Handler/Warp/Date.hs view
@@ -8,11 +8,8 @@ ) where import Control.Applicative-import Control.Concurrent-import Control.Exception-import Control.Monad+import Control.AutoUpdate (defaultUpdateSettings, updateAction, mkAutoUpdate) import Data.ByteString.Char8-import Data.IORef #if WINDOWS import Data.Time@@ -26,28 +23,18 @@ type GMTDate = ByteString -- | The type of the cache of the Date header value.-data DateCache = DateCache (IORef GMTDate)+type DateCache = IO GMTDate -- | Creating 'DateCache' and executing the action. withDateCache :: (DateCache -> IO a) -> IO a-withDateCache action = bracket initialize- (\(t,_) -> killThread t)- (\(_,dc) -> action dc)+withDateCache action = initialize >>= action -initialize :: IO (ThreadId, DateCache)-initialize = do- dc <- DateCache <$> (getCurrentGMTDate >>= newIORef)- t <- forkIO $ forever $ do- threadDelay 1000000- update dc- return (t, dc)+initialize :: IO DateCache+initialize = mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentGMTDate } -- | Getting 'GMTDate' based on 'DateCache'. getDate :: DateCache -> IO GMTDate-getDate (DateCache ref) = readIORef ref--update :: DateCache -> IO ()-update (DateCache ref) = getCurrentGMTDate >>= writeIORef ref+getDate = id getCurrentGMTDate :: IO GMTDate #ifdef WINDOWS
Network/Wai/Handler/Warp/FdCache.hs view
@@ -23,14 +23,13 @@ ) where import Control.Applicative ((<$>), (<*>))-import Control.Concurrent (threadDelay)-import Control.Exception (bracket, mask_)+import Control.Exception (bracket) import Data.Hashable (hash) import Network.Wai.Handler.Warp.IORef import Network.Wai.Handler.Warp.MultiMap-import Network.Wai.Handler.Warp.Thread import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd) import System.Posix.Types (Fd)+import Control.Reaper ---------------------------------------------------------------- @@ -68,19 +67,10 @@ type FdCache = MMap Hash FdEntry -- | Mutable Fd cacher.-newtype MutableFdCache = MutableFdCache (IORef FdCache)+type MutableFdCache = Reaper FdCache (Hash, FdEntry) fdCache :: MutableFdCache -> IO FdCache-fdCache (MutableFdCache ref) = readIORef ref--swapWithNew :: IORef FdCache -> IO FdCache-swapWithNew ref = atomicModifyIORef' ref $ \t -> (empty, t)--update :: MutableFdCache -> (FdCache -> FdCache) -> IO ()-update (MutableFdCache ref) = update' ref--update' :: IORef FdCache -> (FdCache -> FdCache) -> IO ()-update' ref f = atomicModifyIORef' ref $ \t -> (f t, ())+fdCache mfc = reaperRead mfc look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry) look mfc path key = searchWith key check <$> fdCache mfc@@ -106,17 +96,18 @@ -- The first argument is a cache duration in second. initialize :: Int -> IO (Maybe MutableFdCache) initialize 0 = return Nothing-initialize duration = do- ref' <- forkIOwithBreakableForever empty $ \ref -> do- threadDelay duration- clean ref- return (Just (MutableFdCache ref'))+initialize duration = Just <$> mkReaper defaultReaperSettings+ { reaperAction = clean+ , reaperDelay = duration+ , reaperCons = uncurry insert+ , reaperNull = isEmpty+ , reaperEmpty = empty+ } -clean :: IORef FdCache -> IO ()-clean ref = do- old <- swapWithNew ref+clean :: FdCache -> IO (FdCache -> FdCache)+clean old = do new <- pruneWith old prune- update' ref (merge new)+ return $ merge new prune :: t -> Some FdEntry -> IO [(t, Some FdEntry)] prune k v@(One (FdEntry _ fd mst)) = status mst >>= prune'@@ -138,8 +129,8 @@ terminate :: Maybe MutableFdCache -> IO () terminate Nothing = return ()-terminate (Just (MutableFdCache ref)) = mask_ $ do- !t <- breakForever ref+terminate (Just mfc) = do+ !t <- reaperStop mfc mapM_ closeIt $ toList t where closeIt (_, FdEntry _ fd _) = closeFd fd@@ -153,7 +144,7 @@ key = hash path getFd' Nothing = do ent@(FdEntry _ fd mst) <- newFdEntry path- update mfc (insert key ent)+ reaperAdd mfc (key, ent) return (fd, refresh mst) getFd' (Just (FdEntry _ fd mst)) = do refresh mst
Network/Wai/Handler/Warp/MultiMap.hs view
@@ -72,7 +72,7 @@ ---------------------------------------------------------------- -- | O(1)-isEmpty :: (Eq k, Eq v) => MMap k v -> Bool+isEmpty :: MMap k v -> Bool isEmpty Leaf = True isEmpty _ = False
− Network/Wai/Handler/Warp/Thread.hs
@@ -1,28 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--module Network.Wai.Handler.Warp.Thread (- forkIOwithBreakableForever- , breakForever- ) where--import Control.Concurrent (forkIO)-import Control.Exception (handle, throw, mask_, Exception)-import Control.Monad (void, forever)-import Data.IORef-import Data.Typeable--data BreakForever = BreakForever deriving (Show, Typeable)--instance Exception BreakForever--forkIOwithBreakableForever :: a -> (IORef a -> IO ()) -> IO (IORef a)-forkIOwithBreakableForever ini action = do- ref <- newIORef ini- void . forkIO . handle stopPropagation . forever . mask_ $ action ref- return ref--stopPropagation :: BreakForever -> IO ()-stopPropagation _ = return ()--breakForever :: IORef a -> IO a-breakForever ref = atomicModifyIORef ref $ \x -> (throw BreakForever, x)
Network/Wai/Handler/Warp/Timeout.hs view
@@ -49,19 +49,19 @@ import GHC.Exts (mkWeak#) import GHC.IO (IO (IO)) #endif-import Control.Concurrent (threadDelay, myThreadId)+import Control.Concurrent (myThreadId) import qualified Control.Exception as E import GHC.Weak (Weak (..)) import Network.Wai.Handler.Warp.IORef (IORef) import qualified Network.Wai.Handler.Warp.IORef as I-import Network.Wai.Handler.Warp.Thread import System.Mem.Weak (deRefWeak) import Data.Typeable (Typeable)+import Control.Reaper ---------------------------------------------------------------- -- | A timeout manager-newtype Manager = Manager (IORef [Handle])+type Manager = Reaper [Handle] Handle -- | An action to be performed on timeout. type TimeoutAction = IO ()@@ -79,23 +79,20 @@ -- | Creating timeout manager which works every N micro seconds -- where N is the first argument. initialize :: Int -> IO Manager-initialize timeout = do- ref' <- forkIOwithBreakableForever [] $ \ref -> do- threadDelay timeout- old <- I.atomicModifyIORef' ref (\x -> ([], x))- merge <- prune old id- I.atomicModifyIORef' ref (\new -> (merge new, ()))- return $ Manager ref'+initialize timeout = mkReaper defaultReaperSettings+ { reaperAction = mkListAction prune+ , reaperDelay = timeout+ } where- prune [] front = return front- prune (m@(Handle onTimeout iactive):rest) front = do+ prune m@(Handle onTimeout iactive) = do state <- I.atomicModifyIORef' iactive (\x -> (inactivate x, x)) case state of Inactive -> do onTimeout `E.catch` ignoreAll- prune rest front- Canceled -> prune rest front- _ -> prune rest (front . (:) m)+ return Nothing+ Canceled -> return Nothing+ _ -> return $ Just m+ inactivate Active = Inactive inactivate x = x @@ -103,9 +100,7 @@ -- | Stopping timeout manager. stopManager :: Manager -> IO ()-stopManager (Manager ref) = E.mask_ $ do- !handles <- breakForever ref- mapM_ fire handles+stopManager mgr = E.mask_ (reaperStop mgr >>= mapM_ fire) where fire (Handle onTimeout _) = onTimeout `E.catch` ignoreAll @@ -116,10 +111,10 @@ -- | Registering a timeout action. register :: Manager -> TimeoutAction -> IO Handle-register (Manager ref) onTimeout = do+register mgr onTimeout = do iactive <- I.newIORef Active let h = Handle onTimeout iactive- I.atomicModifyIORef' ref (\x -> (h : x, ()))+ reaperAdd mgr h return h -- | Registering a timeout action of killing this thread.
− test/ThreadSpec.hs
@@ -1,26 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module ThreadSpec where--import Control.Concurrent (threadDelay)-import Data.IORef (readIORef, writeIORef, atomicModifyIORef)-import Network.Wai.Handler.Warp.Thread-import Test.Hspec--main :: IO ()-main = hspec spec--spec :: Spec-spec = describe "forkIOwithBreakableForever" $ do- it "can be breakable" $ do- ref' <- forkIOwithBreakableForever True $ \ref -> do- threadDelay 1000- !_ <- atomicModifyIORef ref (\x -> (False, x))- return ()- threadDelay 100000- readIORef ref' `shouldReturn` False- _ <- breakForever ref'- threadDelay 100000- writeIORef ref' True- threadDelay 100000- readIORef ref' `shouldReturn` True
warp.cabal view
@@ -1,5 +1,5 @@ Name: warp-Version: 3.0.0.5+Version: 3.0.0.6 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE@@ -40,6 +40,7 @@ Library Build-Depends: base >= 3 && < 5 , array+ , auto-update >= 0.1.1 && < 0.2 , blaze-builder >= 0.3.3 && < 0.4 , bytestring >= 0.9.1.4 , case-insensitive >= 0.2@@ -75,7 +76,6 @@ Network.Wai.Handler.Warp.Run Network.Wai.Handler.Warp.SendFile Network.Wai.Handler.Warp.Settings- Network.Wai.Handler.Warp.Thread Network.Wai.Handler.Warp.Types Network.Wai.Handler.Warp.Windows Paths_warp@@ -114,13 +114,13 @@ ResponseHeaderSpec ResponseSpec RunSpec- ThreadSpec Hs-Source-Dirs: test, . Type: exitcode-stdio-1.0 Ghc-Options: -Wall Build-Depends: base >= 4 && < 5 , array+ , auto-update , blaze-builder >= 0.3.3 && < 0.4 , bytestring >= 0.9.1.4 , case-insensitive >= 0.2