Skip to content
Browse files

Shutdown cleanly on SIGTERM

We get this for free for SIGINT, but have to do the equiv manually for
SIGTERM. This should fix the problem where the acid state lock files are
not removed on shutdown.
  • Loading branch information...
1 parent 111f389 commit 1648207d97b4d93e210dd794839eef8024fa8c9d @dcoutts dcoutts committed Nov 17, 2013
Showing with 60 additions and 0 deletions.
  1. +56 −0 Distribution/Server/Util/SigTerm.hs
  2. +3 −0 Main.hs
  3. +1 −0 hackage-server.cabal
View
56 Distribution/Server/Util/SigTerm.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE CPP #-}
+#if !(MIN_VERSION_base(4,6,0))
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+#endif
+
+module Distribution.Server.Util.SigTerm (onSigTermCleanShutdown) where
+
+import System.Posix.Signals
+ ( installHandler
+ , Handler(Catch)
+ , softwareTermination
+ )
+import Control.Exception
+ ( AsyncException(UserInterrupt), throwTo )
+import Control.Concurrent
+ ( myThreadId )
+#if MIN_VERSION_base(4,6,0)
+import Control.Concurrent
+ ( mkWeakThreadId )
+#else
+import GHC.Conc.Sync
+ ( ThreadId(..) )
+import GHC.Weak
+ ( Weak(..) )
+import GHC.IO
+ ( IO(IO) )
+import GHC.Exts
+ ( mkWeak#, unsafeCoerce# )
+#endif
+import System.Mem.Weak
+ ( deRefWeak )
+
+-- | On SIGTERM, throw 'UserInterrupt' to the calling thread.
+--
+onSigTermCleanShutdown :: IO ()
+onSigTermCleanShutdown = do
+ wtid <- mkWeakThreadId =<< myThreadId
+ _ <- installHandler softwareTermination
+ (Catch (cleanShutdownHandler wtid))
+ Nothing
+ return ()
+ where
+ cleanShutdownHandler :: Weak ThreadId -> IO ()
+ cleanShutdownHandler wtid = do
+ mtid <- deRefWeak wtid
+ case mtid of
+ Nothing -> return ()
+ Just tid -> throwTo tid UserInterrupt
+
+#if !(MIN_VERSION_base(4,6,0))
+mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)
+mkWeakThreadId t@(ThreadId t#) = IO $ \s ->
+ case mkWeak# t# t (unsafeCoerce# 0#) s of
+ (# s1, w #) -> (# s1, Weak w #)
+#endif
+
View
3 Main.hs
@@ -9,6 +9,7 @@ import Distribution.Server.Framework.Logging
import Distribution.Server.Framework.BackupRestore (equalTarBall, restoreServerBackup)
import Distribution.Server.Framework.BackupDump (dumpServerBackup)
import qualified Distribution.Server.Framework.BlobStorage as BlobStorage
+import Distribution.Server.Util.SigTerm
import Distribution.Text
( display )
@@ -291,6 +292,8 @@ runAction opts = do
checkStaticDir staticDir (flagRunStaticDir opts)
checkTmpDir tmpDir
+ onSigTermCleanShutdown
+
let checkpointHandler server = do
lognotice verbosity "Writing checkpoint..."
Server.checkpoint server
View
1 hackage-server.cabal
@@ -143,6 +143,7 @@ executable hackage-server
Distribution.Server.Util.TextSearch
Distribution.Server.Util.GZip
Distribution.Server.Util.ContentType
+ Distribution.Server.Util.SigTerm
Distribution.Server.Features
Distribution.Server.Features.Core

0 comments on commit 1648207

Please sign in to comment.
Something went wrong with that request. Please try again.