graceful (empty) → 0.1.0.0
raw patch · 12 files changed
+791/−0 lines, 12 filesdep +basedep +directorydep +gracefulsetup-changed
Dependencies added: base, directory, graceful, hspec, network, process, stm, unix
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- graceful.cabal +53/−0
- sample/sample.hs +53/−0
- src/Network/Socket/Wrapper.hs +30/−0
- src/System/Posix/Graceful.hs +117/−0
- src/System/Posix/Graceful/Handler.hs +103/−0
- src/System/Posix/Graceful/Worker.hs +64/−0
- test/Spec.hs +1/−0
- test/System/Posix/GracefulSpec.hs +250/−0
- test/double.hs +44/−0
- test/echo.hs +44/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, ++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ graceful.cabal view
@@ -0,0 +1,53 @@+-- Initial graceful.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/++name: graceful+version: 0.1.0.0+synopsis: Library to write graceful shutdown / upgrade service.+description: Library to write graceful shutdown / upgrade service.+license: BSD3+license-file: LICENSE+author: Noriyuki OHKAWA <n.ohkawa@gmail.com>+maintainer: Noriyuki OHKAWA <n.ohkawa@gmail.com>+copyright: Copyright (c) 2013, Noriyuki OHKAWA+category: System+build-type: Simple+cabal-version: >=1.8+tested-with: GHC ==7.4.1, GHC ==7.6.3+extra-source-files:+ sample/sample.hs+ -- test target servers+ test/echo.hs+ test/double.hs++source-repository head+ type: git+ location: https://github.com/notogawa/graceful.git++library+ hs-source-dirs: src+ exposed-modules: System.Posix.Graceful+ ghc-options: -Wall+ other-modules: System.Posix.Graceful.Handler+ System.Posix.Graceful.Worker+ Network.Socket.Wrapper+ build-depends: base >=4.5 && <4.7+ , network >=2.3 && <2.5+ , unix >=2.5 && <2.7+ , stm >=2.3 && <2.5+ , directory >=1.1 && <1.3++test-suite graceful-spec+ hs-source-dirs: test+ type: exitcode-stdio-1.0+ ghc-options: -Wall -threaded+ main-is: Spec.hs+ other-modules: System.Posix.GracefulSpec+ build-depends: base ==4.*+ , graceful+ , hspec >=1.3+ , process+ , network+ , unix+ , stm+ , directory
+ sample/sample.hs view
@@ -0,0 +1,53 @@+import Network+import Network.Socket ( send )+import Control.Concurrent+import Control.Monad+import System.Exit+import System.Posix.Directory+import System.Posix.Files+import System.Posix.IO+import System.Posix.Process+import System.Posix.Signals++import System.Posix.Graceful++main :: IO ()+main = daemonize $ graceful settings worker+ where+ settings = GracefulSettings+ { gracefulSettingsListen = listenOn $ PortNumber 8080+ , gracefulSettingsWorkerCount = 4+ , gracefulSettingsSockFile = "/tmp/sample.sock"+ , gracefulSettingsPidFile = "/tmp/sample.pid"+ , gracefulSettingsBinary = "/tmp/sample"+ }+ worker = GracefulWorker { gracefulWorkerInitialize = return ()+ , gracefulWorkerApplication = application+ , gracefulWorkerFinalize = const $ return ()+ }+ application sock _ = do+ pid <- getProcessID+ let content = shows pid "\n"+ mapM_ (send sock)+ [ "HTTP/1.1 200 OK\r\n"+ , "Connection: close\r\n"+ , "Content-Type: text/plain; charset=utf-8\r\n"+ , "Content-Length: " ++ show (length content) ++ "\r\n"+ , "\r\n"+ , content+ ]++daemonize :: IO () -> IO ()+daemonize application = do+ void $ setFileCreationMask 0+ void $ forkProcess $ do+ void createSession+ void $ forkProcess $ do+ changeWorkingDirectory "/"+ devnull <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags+ let sendTo fd' fd = closeFd fd >> dupTo fd' fd+ mapM_ (sendTo devnull) [ stdInput, stdOutput, stdError ]+ void $ installHandler sigHUP Ignore Nothing+ application+ exitImmediately ExitSuccess+ exitImmediately ExitSuccess
+ src/Network/Socket/Wrapper.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}+-- |+-- Module : Network.Socket.Wrapper+-- Copyright : 2013 Noriyuki OHKAWA+-- License : BSD3+--+-- Maintainer : n.ohkawa@gmail.com+-- Stability : experimental+-- Portability : unknown+--+-- This module wrap Network.Socket deprecated IF.+module Network.Socket.Wrapper+ ( close+ , module Network.Socket+ ) where++import qualified Network.Socket as NS+#if MIN_VERSION_network(2,4,0)+import Network.Socket hiding ( close )+#else+import Network.Socket hiding ( sClose )+#endif++-- | wrap close/sClose+close :: Socket -> IO ()+#if MIN_VERSION_network(2,4,0)+close = NS.close+#else+close = NS.sClose+#endif
+ src/System/Posix/Graceful.hs view
@@ -0,0 +1,117 @@+-- |+-- Module : System.Posix.Graceful+-- Copyright : 2013 Noriyuki OHKAWA+-- License : BSD3+--+-- Maintainer : n.ohkawa@gmail.com+-- Stability : experimental+-- Portability : unknown+--+-- Provides function to make process graceful.+module System.Posix.Graceful+ ( GracefulSettings(..)+ , GracefulWorker(..)+ , graceful+ ) where++import Control.Concurrent ( newEmptyMVar, putMVar, takeMVar )+import Control.Concurrent.STM ( newTVarIO )+import Control.Exception ( IOException, bracket, bracket_, try, throwIO )+import Control.Monad ( replicateM, void, when )+import Network.Socket.Wrapper ( Socket(..), socket, mkSocket+ , connect, close, accept, bindSocket, listen+ , send, recv, sendFd, recvFd, fdSocket, SocketStatus(..)+ , Family(..), SocketType(..), SockAddr(..) )+import System.Directory ( doesFileExist, removeFile, renameFile )+import System.Posix.IO ( dup )+import System.Posix.Process ( getProcessID, forkProcess, executeFile, getProcessStatus )+import System.Posix.Signals ( blockSignals, unblockSignals, fullSignalSet )+import System.Posix.Types ( ProcessID, Fd(Fd) )++import System.Posix.Graceful.Handler+import System.Posix.Graceful.Worker++-- | Server settings+--+-- Since 0.1.0.0+--+data GracefulSettings =+ GracefulSettings+ { gracefulSettingsListen :: IO Socket -- ^ Listen socket+ , gracefulSettingsWorkerCount :: Int -- ^ Prefork worker count+ , gracefulSettingsSockFile :: FilePath -- ^ Unix domain socket file+ , gracefulSettingsPidFile :: FilePath -- ^ The file to which the server records the process id+ , gracefulSettingsBinary :: FilePath -- ^ The binary file to upgrade+ }++-- | Make server application enable shutdown/restart gracefully+--+-- Since 0.1.0.0+--+graceful :: GracefulSettings -> GracefulWorker -> IO ()+graceful settings worker = do+ quit <- newEmptyMVar+ result <- tryIO $ bracket_ (blockSignals fullSignalSet) (unblockSignals fullSignalSet) $ do+ esock <- tryRecvSocket settings+ sock <- either (const $ gracefulSettingsListen settings) return esock+ let launch = launchWorkers (gracefulSettingsWorkerCount settings) $ do+ unblockSignals fullSignalSet+ defaultHandlers+ workerProcess worker sock+ pids <- launch >>= newTVarIO+ resetHandlers HandlerSettings { handlerSettingsProcessIDs = pids+ , handlerSettingsQuitProcess = putMVar quit True+ , handlerSettingsLaunchWorkers = launch+ , handlerSettingsSpawnProcess = spawnProcess settings sock+ }+ writeProcessId settings+ either throwIO (const $ void $ takeMVar quit) result++tryRecvSocket :: GracefulSettings -> IO (Either IOException Socket)+tryRecvSocket settings =+ tryIO $ bracket (socket AF_UNIX Stream 0) close $ \uds -> do+ connect uds $ SockAddrUnix $ gracefulSettingsSockFile settings+ recvSock uds++writeProcessId :: GracefulSettings -> IO ()+writeProcessId settings =+ getProcessID >>= writeFile (gracefulSettingsPidFile settings) . show++clearUnixDomainSocket :: FilePath -> IO ()+clearUnixDomainSocket sockFile = do+ exist <- doesFileExist sockFile+ when exist $ removeFile sockFile++spawnProcess :: GracefulSettings -> Socket -> IO ()+spawnProcess GracefulSettings { gracefulSettingsSockFile = sockFile+ , gracefulSettingsBinary = binary+ , gracefulSettingsPidFile = pidFile+ } sock = do+ exist <- doesFileExist pidFile+ when exist $ renameFile pidFile (pidFile ++ ".old")+ clearUnixDomainSocket sockFile+ bracket (socket AF_UNIX Stream 0) close $ \uds -> do+ bindSocket uds $ SockAddrUnix sockFile+ listen uds 1+ pid <- forkProcess $ executeFile binary False [] Nothing+ bracket (accept uds) (close . fst) $ \(s, _) -> sendSock s sock+ void $ getProcessStatus True False pid++tryIO :: IO a -> IO (Either IOException a)+tryIO = try++sendSock :: Socket -> Socket -> IO ()+sendSock uds sock = do+ Fd fd <- dup $ Fd $ fdSocket sock+ sendFd uds fd+ let MkSocket _ family socktype protocol _ = sock+ void $ send uds $ show (family, socktype, protocol)++recvSock :: Socket -> IO Socket+recvSock uds = do+ fd <- recvFd uds+ (family, socktype, protocol) <- fmap read $ recv uds 2048+ mkSocket fd family socktype protocol Listening++launchWorkers :: Int -> IO () -> IO [ProcessID]+launchWorkers n = replicateM n . forkProcess
+ src/System/Posix/Graceful/Handler.hs view
@@ -0,0 +1,103 @@+-- |+-- Module : System.Posix.Graceful.Handler+-- Copyright : 2013 Noriyuki OHKAWA+-- License : BSD3+--+-- Maintainer : n.ohkawa@gmail.com+-- Stability : experimental+-- Portability : unknown+--+-- Signal handlers+module System.Posix.Graceful.Handler+ ( HandlerSettings(..)+ , resetHandlers+ , defaultHandlers+ ) where++import Control.Concurrent.STM ( atomically, TVar, newTVarIO, readTVar, modifyTVar' )+import Control.Monad ( void, unless )+import System.Exit ( ExitCode(..) )+import System.Posix.Process ( getAnyProcessStatus, exitImmediately )+import System.Posix.Signals ( Signal, signalProcess+ , Handler(..), installHandler, fullSignalSet+ , sigQUIT, sigHUP, sigINT, sigTERM, sigUSR2 )+import System.Posix.Types ( ProcessID )++-- | Signal handler settings+data HandlerSettings =+ HandlerSettings { handlerSettingsProcessIDs :: TVar [ProcessID]+ , handlerSettingsQuitProcess :: IO ()+ , handlerSettingsLaunchWorkers :: IO [ProcessID]+ , handlerSettingsSpawnProcess :: IO ()+ }++-- | Reset handlers by settings+resetHandlers :: HandlerSettings -> IO ()+resetHandlers settings = do+ void $ installHandler sigQUIT (CatchOnce $ handleSIGQUIT settings) (Just fullSignalSet)+ void $ installHandler sigHUP (CatchOnce $ handleSIGHUP settings) (Just fullSignalSet)+ void $ installHandler sigINT (CatchOnce $ handleSIGINT settings) (Just fullSignalSet)+ void $ installHandler sigTERM (CatchOnce $ handleSIGTERM settings) (Just fullSignalSet)+ void $ installHandler sigUSR2 (CatchOnce $ handleSIGUSR2 settings) (Just fullSignalSet)++-- | Set default handlers+defaultHandlers :: IO ()+defaultHandlers = do+ void $ installHandler sigQUIT Default Nothing+ void $ installHandler sigHUP Default Nothing+ void $ installHandler sigINT Default Nothing+ void $ installHandler sigTERM Default Nothing+ void $ installHandler sigUSR2 Default Nothing++broadcastSignal :: HandlerSettings -> Signal -> IO ()+broadcastSignal settings s = do+ pids <- atomically $ readTVar $ handlerSettingsProcessIDs settings+ mapM_ (signalProcess s) pids++waitAllProcess :: HandlerSettings -> IO ()+waitAllProcess settings = do+ status <- getAnyProcessStatus True False+ case status of+ Nothing -> return ()+ Just (pid, _) -> do+ remain <- atomically $ do+ modifyTVar' (handlerSettingsProcessIDs settings) (filter (pid /=))+ readTVar (handlerSettingsProcessIDs settings)+ unless (null remain) $ waitAllProcess settings++shutdownGracefully :: HandlerSettings -> IO ()+shutdownGracefully settings = do+ broadcastSignal settings sigQUIT+ waitAllProcess settings++-- fast shutdown+handleSIGINT :: HandlerSettings -> IO ()+handleSIGINT settings = do+ broadcastSignal settings sigINT+ waitAllProcess settings+ exitImmediately $ ExitFailure 130 -- SIGINT exit code++-- fast shutdown+handleSIGTERM :: HandlerSettings -> IO ()+handleSIGTERM settings = do+ broadcastSignal settings sigTERM+ waitAllProcess settings+ exitImmediately $ ExitFailure 143 -- SIGTERM exit code++-- graceful shutdown+handleSIGQUIT :: HandlerSettings -> IO ()+handleSIGQUIT settings = do+ shutdownGracefully settings+ handlerSettingsQuitProcess settings++-- starting new worker processes, graceful shutdown of old worker processes+handleSIGHUP :: HandlerSettings -> IO ()+handleSIGHUP settings = do+ newpids <- handlerSettingsLaunchWorkers settings >>= newTVarIO+ resetHandlers settings { handlerSettingsProcessIDs = newpids }+ shutdownGracefully settings++handleSIGUSR2 :: HandlerSettings -> IO ()+handleSIGUSR2 settings = do+ handlerSettingsSpawnProcess settings+ resetHandlers settings
+ src/System/Posix/Graceful/Worker.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE ExistentialQuantification #-}+-- |+-- Module : System.Posix.Graceful.Worker+-- Copyright : 2013 Noriyuki OHKAWA+-- License : BSD3+--+-- Maintainer : n.ohkawa@gmail.com+-- Stability : experimental+-- Portability : unknown+--+-- Worker process+module System.Posix.Graceful.Worker+ ( GracefulWorker(..)+ , workerProcess+ ) where++import Control.Concurrent ( forkIO, threadDelay )+import Control.Concurrent.STM ( atomically, newTVarIO, modifyTVar', readTVar )+import Control.Exception ( IOException, bracket, bracket_, finally, try )+import Control.Monad ( void, forever, when )+import Network ( Socket )+import Network.Socket.Wrapper ( close, accept )+import System.Exit ( ExitCode(..) )+import System.Posix.Process ( exitImmediately )+import System.Posix.Signals ( Handler(..), installHandler, sigQUIT )++-- | Worker process settings+--+-- Since 0.1.0.0+--+data GracefulWorker = forall resource .+ GracefulWorker { gracefulWorkerInitialize :: IO resource+ , gracefulWorkerApplication :: Socket -> resource -> IO ()+ , gracefulWorkerFinalize :: resource -> IO ()+ }++tryIO :: IO a -> IO (Either IOException a)+tryIO = try++-- | Worker process action+workerProcess :: GracefulWorker -> Socket -> IO ()+workerProcess GracefulWorker { gracefulWorkerInitialize = initialize+ , gracefulWorkerApplication = application+ , gracefulWorkerFinalize = finalize+ } sock = do+ void $ installHandler sigQUIT (CatchOnce $ close sock) Nothing+ count <- newTVarIO (0 :: Int)+ void $ tryIO $ bracket initialize finalize $ \resource ->+ void $ forever $ do+ (s, _) <- accept sock+ let app = application s resource+ forkIO $ bracket_+ (atomically $ modifyTVar' count succ)+ (atomically $ modifyTVar' count pred)+ (app `finally` close s)+ waitAllAction count+ close sock+ exitImmediately ExitSuccess+ where+ waitAllAction count = do+ active <- atomically $ readTVar count+ when (0 /= active) $ do+ threadDelay 1000+ waitAllAction count
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/System/Posix/GracefulSpec.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE CPP #-}+module System.Posix.GracefulSpec ( spec ) where++import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.List+import Network+import Network.Socket+import System.Cmd+import System.Directory+import System.Exit+import System.Posix.Signals+import System.Posix.Types+import System.Process+import Test.Hspec++spec :: Spec+spec = describe "graceful" $ do+ it "prefork workers" $ run preforkWorkers+ it "restart keep workers > 0" $ run restartKeepWorkers+ it "upgrade keep workers > 0" $ run upgradeKeepWorkers+ it "abort upgrade keep workers > 0" $ run abortUpgradeKeepWorkers+ it "simple access and quit (SIGQUIT)" $ run $ simpleAccessAnd sigQUIT+ it "simple access and stop (SIGINT)" $ run $ simpleAccessAnd sigINT+ it "simple access and stop (SIGTERM)" $ run $ simpleAccessAnd sigTERM+ it "quit (SIGQUIT) while access" $ run quitWhileAccess+ it "stop (SIGINT) while access" $ run $ stopWhileAccess sigINT+ it "stop (SIGTERM) while access" $ run $ stopWhileAccess sigTERM+ it "restart (SIGHUP) while access" $ run restartWhileAccess+ it "upgrade (SIGUSR2) while access" $ run upgradeWhileAccess+ it "abort upgrade while access" $ run abortUpgradeWhileAccess++removeFileIfExist :: FilePath -> IO ()+removeFileIfExist file = do+ exist <- doesFileExist file+ when exist $ removeFile file++waitStandby :: FilePath -> IO ()+waitStandby path = do+ status <- tryIO $ readFile path+ case status of+ Left _err -> threadDelay 1000 >> waitStandby path+ Right _ok -> return ()++waitProcessIncreaseTo :: Int -> IO ()+waitProcessIncreaseTo n = do+ procs <- fmap length ps+ procs `shouldSatisfy` (<= n)+ if procs < n+ then threadDelay 1000 >> waitProcessIncreaseTo n+ else procs `shouldBe` n++waitProcessDecreaseTo :: Int -> IO ()+waitProcessDecreaseTo n = do+ procs <- fmap length ps+ procs `shouldSatisfy` (>= n)+ if procs > n+ then threadDelay 1000 >> waitProcessDecreaseTo n+ else procs `shouldBe` n++run :: IO () -> IO ()+run action = do+ buildAsEchoServer "test/echo.hs"+ let file = "/tmp/echo-server"+ mapM_ (removeFileIfExist . (file ++)) [ ".sock", ".pid" ]+ rawSystem file [] `shouldReturn` ExitSuccess+ waitStandby $ file ++ ".pid"+ action+ waitProcessDecreaseTo 0++kill :: Signal -> IO ()+kill signal = readFile "/tmp/echo-server.pid" >>=+ signalProcess signal . read++killold :: Signal -> IO ()+killold signal = readFile "/tmp/echo-server.pid.old" >>=+ signalProcess signal . read++tryIO :: IO a -> IO (Either IOException a)+tryIO = try++echo :: Socket -> String -> IO String+echo sock str = send sock str >> recv sock (2 * length str)++shouldEcho :: Socket -> String -> Expectation+shouldEcho sock str = echo sock str `shouldReturn` str++shouldDouble :: Socket -> String -> Expectation+shouldDouble sock str = echo sock str `shouldReturn` (str ++ str)++simpleAccess :: IO ()+simpleAccess = access (`shouldEcho` "simpleAccess")++wrapClose :: Socket -> IO ()+#if MIN_VERSION_network(2,4,0)+wrapClose = close+#else+wrapClose = sClose+#endif++access :: (Socket -> IO ()) -> IO ()+access action =+ bracket (socket AF_INET Stream 0) wrapClose $ \sock -> do+ addr <- inet_addr "127.0.0.1"+ connect sock $ SockAddrInet 8080 addr+ action sock+++packageOption :: String+#if __GLASGOW_HASKELL__ < 706+packageOption = "-package-conf"+#else+packageOption = "-package-db"+#endif++buildAsEchoServer :: FilePath -> IO ()+buildAsEchoServer file = do+ removeFileIfExist "/tmp/echo-server"+ (code, _out, _err) <- readProcessWithExitCode "ghc"+ [ "--make", file+ , "-o", "/tmp/echo-server"+ , packageOption, "dist/package.conf.inplace"+ ] ""+ code `shouldBe` ExitSuccess++ps :: IO [ProcessID]+ps = do+ (_code, out, _err) <- readProcessWithExitCode "ps"+ [ "hopid", "-Cecho-server" ] ""+ return $ map read $ words out++simpleAccessAnd :: Signal -> IO ()+simpleAccessAnd s = simpleAccess >> kill s++preforkWorkers :: IO ()+preforkWorkers = do+ fmap length ps `shouldReturn` 5+ kill sigQUIT++restartKeepWorkers :: IO ()+restartKeepWorkers = do+ pids <- ps+ length pids `shouldBe` 5 -- master + 4 worker+ kill sigHUP+ waitProcessDecreaseTo 5+ pids' <- ps+ length pids' `shouldBe` 5 -- master + 4 worker+ length (pids `intersect` pids') `shouldBe` 1 -- restarted workers+ kill sigQUIT++upgradeKeepWorkers :: IO ()+upgradeKeepWorkers = do+ pids <- ps+ length pids `shouldBe` 5 -- master + 4 worker+ kill sigUSR2+ waitProcessIncreaseTo 10+ killold sigQUIT+ waitProcessDecreaseTo 5+ pids' <- ps+ length pids' `shouldBe` 5 -- master + 4 worker+ length (pids `intersect` pids') `shouldBe` 0 -- upgraded master & workers+ kill sigQUIT++abortUpgradeKeepWorkers :: IO ()+abortUpgradeKeepWorkers = do+ pids <- ps+ length pids `shouldBe` 5 -- master + 4 worker+ kill sigUSR2+ waitProcessIncreaseTo 10+ kill sigQUIT+ renameFile "/tmp/echo-server.pid.old" "/tmp/echo-server.pid"+ waitProcessDecreaseTo 5+ pids' <- ps+ length pids' `shouldBe` 5 -- master + 4 worker+ length (pids `intersect` pids') `shouldBe` 5 -- abort upgrade+ kill sigQUIT++left :: Either a b -> Bool+left = either (const True) (const False)++right :: Either a b -> Bool+right = not . left++quitWhileAccess :: IO ()+quitWhileAccess = do+ res <- tryIO $ access $ \sock -> do+ kill sigQUIT+ replicateM_ 100 $ do+ sock `shouldEcho` "quitWhileAccess"+ threadDelay 1000+ res `shouldSatisfy` right++stopWhileAccess :: Signal -> IO ()+stopWhileAccess s = do+ res <- tryIO $ access $ \sock -> do+ kill s+ replicateM_ 100 $ do+ sock `shouldEcho` "stopWhileAccess"+ threadDelay 1000+ res `shouldSatisfy` left++restartWhileAccess :: IO ()+restartWhileAccess = do+ access $ \sock -> do+ kill sigHUP+ replicateM_ 10 $ do+ sock `shouldEcho` "restartWhileAccess"+ threadDelay 1000+ waitProcessDecreaseTo 5+ access $ \sock ->+ replicateM_ 10 $ do+ sock `shouldEcho` "restartWhileAccess"+ threadDelay 1000+ kill sigQUIT++upgradeWhileAccess :: IO ()+upgradeWhileAccess = do+ buildAsEchoServer "test/double.hs"+ access $ \sock -> do+ kill sigUSR2+ replicateM_ 10 $ do+ sock `shouldEcho` "upgradeWhileAccess"+ threadDelay 1000+ waitProcessIncreaseTo 10+ killold sigQUIT+ waitProcessDecreaseTo 5+ access $ \sock ->+ replicateM_ 10 $ do+ sock `shouldDouble` "upgradeWhileAccess"+ threadDelay 1000+ kill sigQUIT++abortUpgradeWhileAccess :: IO ()+abortUpgradeWhileAccess = do+ buildAsEchoServer "test/double.hs"+ access $ \sock -> do+ kill sigUSR2+ replicateM_ 10 $ do+ sock `shouldEcho` "upgradeWhileAccess"+ threadDelay 1000+ waitProcessIncreaseTo 10+ kill sigQUIT+ renameFile "/tmp/echo-server.pid.old" "/tmp/echo-server.pid"+ waitProcessDecreaseTo 5+ access $ \sock ->+ replicateM_ 10 $ do+ sock `shouldEcho` "upgradeWhileAccess"+ threadDelay 1000+ kill sigQUIT
+ test/double.hs view
@@ -0,0 +1,44 @@+import Network+import Network.Socket ( send, recv )+import Control.Concurrent+import Control.Monad+import System.Directory+import System.Exit+import System.Posix.Directory+import System.Posix.Files+import System.Posix.IO+import System.Posix.Process+import System.Posix.Signals++import System.Posix.Graceful++main :: IO ()+main = daemonize $ graceful settings worker+ where+ settings = GracefulSettings+ { gracefulSettingsListen = listenOn $ PortNumber 8080+ , gracefulSettingsWorkerCount = 4+ , gracefulSettingsSockFile = "/tmp/echo-server.sock"+ , gracefulSettingsPidFile = "/tmp/echo-server.pid"+ , gracefulSettingsBinary = "/tmp/echo-server"+ }+ worker = GracefulWorker { gracefulWorkerInitialize = return ()+ , gracefulWorkerApplication = application+ , gracefulWorkerFinalize = const $ return ()+ }+ application sock _ = forever $ recv sock 1024 >>= send sock . (\x -> x ++ x)++daemonize :: IO () -> IO ()+daemonize application = do+ void $ setFileCreationMask 0+ void $ forkProcess $ do+ void createSession+ void $ forkProcess $ do+ changeWorkingDirectory "/"+ devnull <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags+ let sendTo fd' fd = closeFd fd >> dupTo fd' fd+ mapM_ (sendTo devnull) [ stdInput, stdOutput, stdError ]+ void $ installHandler sigHUP Ignore Nothing+ application+ exitImmediately ExitSuccess+ exitImmediately ExitSuccess
+ test/echo.hs view
@@ -0,0 +1,44 @@+import Network+import Network.Socket ( send, recv )+import Control.Concurrent+import Control.Monad+import System.Directory+import System.Exit+import System.Posix.Directory+import System.Posix.Files+import System.Posix.IO+import System.Posix.Process+import System.Posix.Signals++import System.Posix.Graceful++main :: IO ()+main = daemonize $ graceful settings worker+ where+ settings = GracefulSettings+ { gracefulSettingsListen = listenOn $ PortNumber 8080+ , gracefulSettingsWorkerCount = 4+ , gracefulSettingsSockFile = "/tmp/echo-server.sock"+ , gracefulSettingsPidFile = "/tmp/echo-server.pid"+ , gracefulSettingsBinary = "/tmp/echo-server"+ }+ worker = GracefulWorker { gracefulWorkerInitialize = return ()+ , gracefulWorkerApplication = application+ , gracefulWorkerFinalize = const $ return ()+ }+ application sock _ = forever $ recv sock 1024 >>= send sock++daemonize :: IO () -> IO ()+daemonize application = do+ void $ setFileCreationMask 0+ void $ forkProcess $ do+ void createSession+ void $ forkProcess $ do+ changeWorkingDirectory "/"+ devnull <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags+ let sendTo fd' fd = closeFd fd >> dupTo fd' fd+ mapM_ (sendTo devnull) [ stdInput, stdOutput, stdError ]+ void $ installHandler sigHUP Ignore Nothing+ application+ exitImmediately ExitSuccess+ exitImmediately ExitSuccess