pax_global_header00006660000000000000000000000064122527700150014513gustar00rootroot0000000000000052 comment=03d901727f1b275e4168a10f278690b89a03efaf haskell-graceful-0.1.1.3/000077500000000000000000000000001225277001500150645ustar00rootroot00000000000000haskell-graceful-0.1.1.3/LICENSE000066400000000000000000000027701225277001500160770ustar00rootroot00000000000000Copyright (c) 2013, Noriyuki OHKAWA 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 Noriyuki OHKAWA 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. haskell-graceful-0.1.1.3/Setup.hs000066400000000000000000000000561225277001500165210ustar00rootroot00000000000000import Distribution.Simple main = defaultMain haskell-graceful-0.1.1.3/graceful.cabal000066400000000000000000000035261225277001500176460ustar00rootroot00000000000000-- Initial graceful.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ name: graceful version: 0.1.1.3 synopsis: Library to write graceful shutdown / upgrade service. description: Library to write graceful shutdown / upgrade service. license: BSD3 license-file: LICENSE author: Noriyuki OHKAWA maintainer: Noriyuki OHKAWA 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 , filepath haskell-graceful-0.1.1.3/sample/000077500000000000000000000000001225277001500163455ustar00rootroot00000000000000haskell-graceful-0.1.1.3/sample/sample.hs000066400000000000000000000035431225277001500201670ustar00rootroot00000000000000import 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 haskell-graceful-0.1.1.3/src/000077500000000000000000000000001225277001500156535ustar00rootroot00000000000000haskell-graceful-0.1.1.3/src/Network/000077500000000000000000000000001225277001500173045ustar00rootroot00000000000000haskell-graceful-0.1.1.3/src/Network/Socket/000077500000000000000000000000001225277001500205345ustar00rootroot00000000000000haskell-graceful-0.1.1.3/src/Network/Socket/Wrapper.hs000066400000000000000000000012051225277001500225060ustar00rootroot00000000000000{-# 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 haskell-graceful-0.1.1.3/src/System/000077500000000000000000000000001225277001500171375ustar00rootroot00000000000000haskell-graceful-0.1.1.3/src/System/Posix/000077500000000000000000000000001225277001500202415ustar00rootroot00000000000000haskell-graceful-0.1.1.3/src/System/Posix/Graceful.hs000066400000000000000000000111111225277001500223200ustar00rootroot00000000000000-- | -- 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.Environment ( getArgs ) 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 $ do clearUnixDomainSocket sockFile bracket (socket AF_UNIX Stream 0) close $ \uds -> do bindSocket uds $ SockAddrUnix sockFile listen uds 1 args <- getArgs pid <- forkProcess $ executeFile binary False args Nothing bracket (accept uds) (close . fst) $ \(s, _) -> sendSock s sock renameFile pidFile (pidFile ++ ".old") 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 haskell-graceful-0.1.1.3/src/System/Posix/Graceful/000077500000000000000000000000001225277001500217715ustar00rootroot00000000000000haskell-graceful-0.1.1.3/src/System/Posix/Graceful/Handler.hs000066400000000000000000000073311225277001500237060ustar00rootroot00000000000000-- | -- 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 haskell-graceful-0.1.1.3/src/System/Posix/Graceful/Worker.hs000066400000000000000000000042331225277001500236000ustar00rootroot00000000000000{-# 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 haskell-graceful-0.1.1.3/test/000077500000000000000000000000001225277001500160435ustar00rootroot00000000000000haskell-graceful-0.1.1.3/test/Spec.hs000066400000000000000000000000541225277001500172700ustar00rootroot00000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} haskell-graceful-0.1.1.3/test/System/000077500000000000000000000000001225277001500173275ustar00rootroot00000000000000haskell-graceful-0.1.1.3/test/System/Posix/000077500000000000000000000000001225277001500204315ustar00rootroot00000000000000haskell-graceful-0.1.1.3/test/System/Posix/GracefulSpec.hs000066400000000000000000000164301225277001500233340ustar00rootroot00000000000000{-# 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.FilePath import System.Posix.Files 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" confDistDir <- getConfDistDir (code, _out, _err) <- readProcessWithExitCode "ghc" [ "--make", file , "-o", "/tmp/echo-server" , packageOption, confDistDir ++ "/package.conf.inplace" ] "" code `shouldBe` ExitSuccess getConfDistDir :: IO FilePath getConfDistDir = fmap (dirname . dirname . dirname) getModuleFile where dirname = takeDirectory getModuleFile = readSymbolicLink "/proc/self/exe" 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 haskell-graceful-0.1.1.3/test/double.hs000066400000000000000000000030751225277001500176560ustar00rootroot00000000000000import 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 haskell-graceful-0.1.1.3/test/echo.hs000066400000000000000000000030541225277001500173170ustar00rootroot00000000000000import 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