Handle SIGTERM by throwing an asynchronous exception

That's roughly how Ctrl-C (SIGINT) is handled by the GHC
runtime.

This way, killing cabal via SIGTERM will give it a chance to
terminate any running children. Previously, it would exit
directly, leaving children behind to exit on their own.

Author: robx

cabal-install/cabal-install.cabal

@@ -258,7 +258,8 @@ executable cabal
     build-depends:
         cabal-install,
         directory,
-        filepath
+        filepath,
+        signal
 
 -- Small, fast running tests.
 --

cabal-install/main/Main.hs

@@ -163,13 +163,16 @@ import System.IO                ( BufferMode(LineBuffering), hSetBuffering
 import System.Directory         ( doesFileExist, getCurrentDirectory
                                 , withCurrentDirectory)
 import Data.Monoid              (Any(..))
-import Control.Exception        (try)
-
+import Control.Exception        (try, throwTo, asyncExceptionFromException, asyncExceptionToException)
+import qualified System.Signal as Signal
+import Control.Concurrent       (myThreadId)
 
 -- | Entry point
 --
 main :: IO ()
 main = do
+  installTerminationHandler
+
   -- Enable line buffering so that we can get fast feedback even when piped.
   -- This is especially important for CI and build systems.
   hSetBuffering stdout LineBuffering
@@ -181,6 +184,28 @@ main = do
   (args0, args1) <- break (== "--") <$> getArgs
   mainWorker =<< (++ args1) <$> expandResponse args0
 
+-- | Terminated is an asynchronous exception, thrown when
+-- SIGTERM is received. It's to 'kill' what 'UserInterrupt'
+-- is to Ctrl-C.
+data Terminated = Terminated
+
+instance Exception Terminated where
+  toException = asyncExceptionToException
+  fromException = asyncExceptionFromException
+
+instance Show Terminated where
+  show Terminated = "terminated"
+
+-- | Install a signal handler that initiates a controlled shutdown on receiving
+-- SIGTERM by throwing an asynchronous exception at the main thread. Must be
+-- called from the main thread.
+installTerminationHandler :: IO ()
+installTerminationHandler = do
+  mainThreadId <- myThreadId
+  Signal.installHandler
+    Signal.sigTERM
+    (\_ -> throwTo mainThreadId Terminated)
+
 mainWorker :: [String] -> IO ()
 mainWorker args = do
   maybeScriptAndArgs <- case args of