Docker: improved posix signal proxying

fixes #547
commercialhaskell · Nov 30, 2015 · 52944d2 · 52944d2
1 parent 159c10a
commit 52944d2
Show file tree

Hide file tree

Showing 2 changed files with 21 additions and 13 deletions.
diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs
@@ -19,6 +19,7 @@ module Stack.Docker
   ) where
 
 import           Control.Applicative
+import           Control.Concurrent (threadDelay)
 import           Control.Concurrent.MVar.Lifted (MVar,modifyMVar_,newMVar)
 import           Control.Exception.Lifted
 import           Control.Monad
@@ -330,10 +331,14 @@ runContainerAndExit getCmdArgs
      before
 #ifndef WINDOWS
      runInBase <- liftBaseWith $ \run -> return (void . run)
-     oldHandlers <- forM ([sigINT | not keepStdinOpen] ++ [sigTERM]) $ \sig -> do
-       let sigHandler = do
-             runInBase (readProcessNull Nothing envOverride "docker"
-                                        ["kill","--signal=" ++ show sig,containerID])
+     oldHandlers <- forM ([sigINT,sigABRT,sigHUP,sigPIPE,sigTERM,sigUSR1,sigUSR2]) $ \sig -> do
+       let sigHandler = runInBase $ do
+             readProcessNull Nothing envOverride "docker"
+                             ["kill","--signal=" ++ show sig,containerID]
+             when (sig `elem` [sigTERM,sigABRT]) $ do
+               -- Give the container 30 seconds to exit gracefully, then send a sigKILL to force it
+               liftIO $ threadDelay 30000000
+               readProcessNull Nothing envOverride "docker" ["kill",containerID]
        oldHandler <- liftIO $ installHandler sig (Catch sigHandler) Nothing
        return (sig, oldHandler)
 #endif
@@ -344,16 +349,19 @@ runContainerAndExit getCmdArgs
                          ,["-a" | not (dockerDetach docker)]
                          ,["-i" | keepStdinOpen]
                          ,[containerID]])
-     e <- try (callProcess'
-                 (if keepStdinOpen then id else (\cp -> cp { delegate_ctlc = False }))
-                 cmd
-                 )
+     e <- finally
+         (try $ callProcess'
+             (\cp -> cp { delegate_ctlc = False })
+             cmd)
+         (do unless (dockerPersist docker || dockerDetach docker) $
+               catch
+                 (readProcessNull Nothing envOverride "docker" ["rm","-f",containerID])
+                 (\(_::ReadProcessException) -> return ())
 #ifndef WINDOWS
-     forM_ oldHandlers $ \(sig,oldHandler) ->
-       liftIO $ installHandler sig oldHandler Nothing
+             forM_ oldHandlers $ \(sig,oldHandler) ->
+               liftIO $ installHandler sig oldHandler Nothing
 #endif
-     unless (dockerPersist docker || dockerDetach docker)
-            (readProcessNull Nothing envOverride "docker" ["rm","-f",containerID])
+         )
      case e of
        Left (ProcessExitedUnsuccessfully _ ec) -> liftIO (exitWith ec)
        Right () -> do after

diff --git a/src/System/Process/Read.hs b/src/System/Process/Read.hs
@@ -179,7 +179,7 @@ tryProcessStdout wd menv name args =
 
 -- | Produce a strict 'S.ByteString' from the stdout of a process.
 --
--- Throws a 'ProcessExitedUnsuccessfully' exception if the  process fails.
+-- Throws a 'ReadProcessException' exception if the  process fails.
 readProcessStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
                   => Maybe (Path Abs Dir) -- ^ Optional directory to run in
                   -> EnvOverride