Make the clean shutdown handler simpler

This modifies the clean shutdown handler to use a FD from the command
line, rather than taking stdin.

It also makes the logic even simpler, as shown in
IntersectMBO/cardano-node#767

The command-line arguments are changed
from --shutdown-handler to --shutdown-ipc FD
so that they are identical to cardano-node.

lib/byron/exe/cardano-wallet-byron.hs

@@ -30,7 +30,8 @@ import Cardano.BM.Data.Severity
 import Cardano.BM.Trace
     ( Trace, appendName, logDebug, logError, logInfo, logNotice )
 import Cardano.CLI
-    ( LoggingOptions
+    ( Fd
+    , LoggingOptions
     , cli
     , cmdAddress
     , cmdByronWalletCreate
@@ -51,7 +52,7 @@ import Cardano.CLI
     , loggingTracers
     , runCli
     , setupDirectory
-    , shutdownHandlerFlag
+    , shutdownIPCOption
     , syncToleranceOption
     , tlsOption
     , withLogging
@@ -163,7 +164,7 @@ data ServeArgs = ServeArgs
     , _networkConfiguration :: NetworkConfiguration
     , _database :: Maybe FilePath
     , _syncTolerance :: SyncTolerance
-    , _enableShutdownHandler :: Bool
+    , _shutdownIpc :: Maybe Fd
     , _logging :: LoggingOptions TracerSeverities
     } deriving (Show)
 
@@ -182,7 +183,7 @@ cmdServe = command "serve" $ info (helper <*> helper' <*> cmd) $ mempty
         <*> networkConfigurationOption
         <*> optional databaseOption
         <*> syncToleranceOption
-        <*> shutdownHandlerFlag
+        <*> shutdownIPCOption
         <*> loggingOptions tracerSeveritiesOption
     exec
         :: ServeArgs
@@ -195,11 +196,11 @@ cmdServe = command "serve" $ info (helper <*> helper' <*> cmd) $ mempty
       networkConfig
       databaseDir
       sTolerance
-      enableShutdownHandler
+      shutdownIpc
       logOpt) = do
         withTracers logOpt $ \tr tracers -> do
             installSignalHandlers (logNotice tr MsgSigTerm)
-            withShutdownHandlerMaybe tr enableShutdownHandler $ do
+            void $ withShutdownHandler (trShutdown tr) shutdownIpc $ do
                 logDebug tr $ MsgServeArgs args
 
                 (discriminant, bp, vData, block0)
@@ -226,11 +227,9 @@ cmdServe = command "serve" $ info (helper <*> helper' <*> cmd) $ mempty
     whenJust m fn = case m of
        Nothing -> pure ()
        Just a  -> fn a
-    withShutdownHandlerMaybe :: Trace IO MainLog -> Bool -> IO () -> IO ()
-    withShutdownHandlerMaybe _ False = void
-    withShutdownHandlerMaybe tr True = void . withShutdownHandler trShutdown
-      where
-        trShutdown = trMessage $ contramap (\(n, x) -> (n, fmap MsgShutdownHandler x)) tr
+
+    trShutdown = trMessage . contramap (\(n, x) -> (n, fmap MsgShutdownHandler x))
+
 {-------------------------------------------------------------------------------
                                     Logging
 -------------------------------------------------------------------------------}
@@ -305,4 +304,3 @@ tracerSeveritiesOption = Tracers
         <> value def
         <> metavar "SEVERITY"
         <> internal
-

lib/cli/src/Cardano/CLI.hs

@@ -52,7 +52,7 @@ module Cardano.CLI
     , listenOption
     , nodePortOption
     , nodePortMaybeOption
-    , shutdownHandlerFlag
+    , shutdownIPCOption
     , stateDirOption
     , syncToleranceOption
     , tlsOption
@@ -79,7 +79,6 @@ module Cardano.CLI
     , hoistKeyScheme
     , mapKey
 
-
     -- * Logging
     , withLogging
 
@@ -101,6 +100,9 @@ module Cardano.CLI
     , setupDirectory
     , waitForService
     , WaitForServiceLog (..)
+
+    -- * Re-exports
+    , Fd(Fd)
     ) where
 
 import Prelude hiding
@@ -265,7 +267,6 @@ import Options.Applicative
     , str
     , strOption
     , subparser
-    , switch
     , value
     )
 import Options.Applicative.Help.Pretty
@@ -313,6 +314,8 @@ import System.IO
     , stdin
     , stdout
     )
+import System.Posix.Types
+    ( Fd (Fd) )
 
 import qualified Cardano.BM.Configuration.Model as CM
 import qualified Cardano.BM.Data.BackendKind as CM
@@ -1551,11 +1554,15 @@ sizeOption = optionT $ mempty
     <> value MS_15
     <> showDefaultWith showT
 
--- | [--shutdown-handler]
-shutdownHandlerFlag :: Parser Bool
-shutdownHandlerFlag = switch
-    (  long "shutdown-handler"
-    <> help "Enable the clean shutdown handler (exits when stdin is closed)" )
+-- | [--shutdown-ipc FD]
+shutdownIPCOption :: Parser (Maybe Fd)
+shutdownIPCOption = optional $ option (Fd <$> auto) $ mempty
+      <> long "shutdown-ipc"
+      <> metavar "FD"
+      <> help (mconcat
+          [ "Enable the clean shutdown handler. "
+          , "The program exits when this inherited FD reaches EOF."
+          ])
 
 -- | --state-dir=DIR, default: ~/.cardano-wallet/$backend/$network
 stateDirOption :: FilePath -> Parser (Maybe FilePath)

lib/jormungandr/exe/cardano-wallet-jormungandr.hs

@@ -29,7 +29,8 @@ import Cardano.BM.Data.Severity
 import Cardano.BM.Trace
     ( Trace, appendName, logInfo, logNotice )
 import Cardano.CLI
-    ( LoggingOptions (..)
+    ( Fd
+    , LoggingOptions (..)
     , Port (..)
     , cli
     , cmdAddress
@@ -55,7 +56,7 @@ import Cardano.CLI
     , requireFilePath
     , runCli
     , setupDirectory
-    , shutdownHandlerFlag
+    , shutdownIPCOption
     , stateDirOption
     , syncToleranceOption
     , withLogging
@@ -288,7 +289,7 @@ data ServeArgs = ServeArgs
     , _database :: Maybe FilePath
     , _syncTolerance :: SyncTolerance
     , _block0H :: Hash "Genesis"
-    , _enableShutdownHandler :: Bool
+    , _shutdownIpc :: Maybe Fd
     , _logging :: LoggingOptions TracerSeverities
     } deriving (Show, Eq)
 
@@ -306,15 +307,15 @@ cmdServe = command "serve" $ info (helper <*> helper' <*> cmd) $ mempty
         <*> optional databaseOption
         <*> syncToleranceOption
         <*> genesisHashOption
-        <*> shutdownHandlerFlag
+        <*> shutdownIPCOption
         <*> loggingOptions tracerSeveritiesOption
     exec
         :: ServeArgs
         -> IO ()
-    exec args@(ServeArgs hostPreference listen nodePort databaseDir sTolerance block0H enableShutdownHandler logOpt) = do
+    exec args@(ServeArgs hostPreference listen nodePort databaseDir sTolerance block0H shutdownIPC logOpt) = do
         withTracers logOpt $ \tr tracers -> do
             installSignalHandlers (logNotice tr MsgSigTerm)
-            withShutdownHandlerMaybe tr enableShutdownHandler $ do
+            void $ withShutdownHandler (trShutdown tr) shutdownIPC $ do
                 logInfo tr $ MsgServeArgs args
                 let baseUrl = localhostBaseUrl $ getPort nodePort
                 let cp = JormungandrConnParams block0H baseUrl
@@ -332,12 +333,7 @@ cmdServe = command "serve" $ info (helper <*> helper' <*> cmd) $ mempty
        Nothing -> pure ()
        Just a  -> fn a
 
-    withShutdownHandlerMaybe :: Trace IO MainLog -> Bool -> IO () -> IO ()
-    withShutdownHandlerMaybe _ False = void
-    withShutdownHandlerMaybe tr True = void . withShutdownHandler trShutdown
-      where
-        trShutdown = trMessage
-            $ contramap (second $ fmap MsgShutdownHandler) tr
+    trShutdown = trMessage . contramap (second $ fmap MsgShutdownHandler)
 
 {-------------------------------------------------------------------------------
                                  Options

lib/launcher/cardano-wallet-launcher.cabal

@@ -32,7 +32,6 @@ library
       base
     , aeson
     , async
-    , bytestring
     , code-page
     , contra-tracer
     , extra

lib/launcher/src/Cardano/Startup.hs

@@ -16,7 +16,6 @@ module Cardano.Startup
 
     -- * Clean shutdown
     , withShutdownHandler
-    , withShutdownHandler'
     , installSignalHandlers
 
     -- * Logging
@@ -29,34 +28,26 @@ import Cardano.BM.Data.Severity
     ( Severity (..) )
 import Cardano.BM.Data.Tracer
     ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
-import Control.Concurrent
-    ( forkIO )
 import Control.Concurrent.Async
-    ( race )
-import Control.Concurrent.MVar
-    ( MVar, newEmptyMVar, putMVar, takeMVar )
+    ( async, race, wait )
 import Control.Exception
-    ( IOException, catch, handle, throwIO )
+    ( IOException, try )
 import Control.Tracer
     ( Tracer, traceWith )
 import Data.Either.Extra
     ( eitherToMaybe )
 import Data.Text.Class
     ( ToText (..) )
+import GHC.IO.Handle.FD
+    ( fdToHandle )
 import System.IO
-    ( Handle
-    , hIsOpen
-    , hSetEncoding
-    , mkTextEncoding
-    , stderr
-    , stderr
-    , stdin
-    , stdin
-    , stdout
-    , stdout
-    )
+    ( hGetChar, hSetEncoding, mkTextEncoding, stderr, stdin, stdout )
 import System.IO.CodePage
     ( withCP65001 )
+import System.IO.Error
+    ( isEOFError )
+import System.Posix.Types
+    ( Fd (Fd) )
 
 #ifdef WINDOWS
 import Cardano.Startup.Windows
@@ -66,7 +57,6 @@ import Cardano.Startup.POSIX
     ( installSignalHandlers )
 #endif
 
-import qualified Data.ByteString as BS
 import qualified Data.Text as T
 
 {-------------------------------------------------------------------------------
@@ -90,65 +80,70 @@ setUtf8EncodingHandles = do
                                Shutdown handlers
 -------------------------------------------------------------------------------}
 
--- | Runs the given action with a cross-platform clean shutdown handler.
+-- | Runs the given action with an optional cross-platform clean shutdown
+-- handler.
 --
 -- This is necessary when running cardano-wallet as a subprocess of Daedalus.
 -- For more details, see
 -- <https://github.com/input-output-hk/cardano-launcher/blob/master/docs/windows-clean-shutdown.md>
 --
--- It works simply by reading from 'stdin', which is otherwise unused by the API
--- server. Once end-of-file is reached, it cancels the action, causing the
--- program to shut down.
+-- It works by reading from the given file descriptor. Once end-of-file is
+-- reached, either deliberately by the parent process closing the write end, or
+-- automatically because the parent process itself terminated, it cancels the
+-- action, causing the program to shut down.
 --
--- So, when running @cardano-wallet@ as a subprocess, the parent process should
--- pass a pipe for 'stdin', then close the pipe when it wants @cardano-wallet@
--- to shut down.
-withShutdownHandler :: Tracer IO ShutdownHandlerLog -> IO a -> IO (Maybe a)
-withShutdownHandler tr = withShutdownHandler' tr stdin
-
--- | A variant of 'withShutdownHandler' where the handle to read can be chosen.
-withShutdownHandler' :: Tracer IO ShutdownHandlerLog -> Handle -> IO a -> IO (Maybe a)
-withShutdownHandler' tr h action = do
-    enabled <- hIsOpen h
-    traceWith tr $ MsgShutdownHandler enabled
-    let with
-            | enabled = fmap eitherToMaybe . race readerLoop
-            | otherwise = fmap Just
-    with action
+withShutdownHandler :: Tracer IO ShutdownHandlerLog -> Maybe Fd -> IO a -> IO (Maybe a)
+withShutdownHandler _ Nothing action = Just <$> action
+withShutdownHandler tr (Just (Fd fd)) action = do
+    traceWith tr $ MsgShutdownHandlerEnabled (Fd fd)
+    eitherToMaybe <$> race (wrapUninterruptableIO waitForEOF) action
   where
-    readerLoop = do
-        handle (traceWith tr . MsgShutdownError) readerLoop'
-        traceWith tr MsgShutdownEOF
-    readerLoop' = waitForInput >>= \case
-        "" -> pure () -- eof: stop loop
-        _ -> readerLoop' -- repeat
-    -- Wait indefinitely for input to be available.
-    -- Runs in separate thread so that it does not deadlock on Windows.
-    waitForInput = do
-        v <- newEmptyMVar :: IO (MVar (Either IOException BS.ByteString))
-        _ <- forkIO ((BS.hGet h 1000 >>= putMVar v . Right) `catch` (putMVar v . Left))
-        takeMVar v >>= either throwIO pure
+    waitForEOF :: IO ()
+    waitForEOF = do
+        hnd <- fdToHandle fd
+        r <- try $ hGetChar hnd
+        case r of
+            Left e
+                | isEOFError e -> traceWith tr MsgShutdownEOF
+                | otherwise -> traceWith tr $ MsgShutdownError e
+            Right _  -> traceWith tr MsgShutdownIncorrectUsage
+
+-- | Windows blocking file IO calls like 'hGetChar' are not interruptable by
+-- asynchronous exceptions, as used by async 'cancel' (as of base-4.12).
+--
+-- This wrapper works around that problem by running the blocking IO in a
+-- separate thread. If the parent thread receives an async cancel then it
+-- will return. Note however that in this circumstance the child thread may
+-- continue and remain blocked, leading to a leak of the thread. As such this
+-- is only reasonable to use a fixed number of times for the whole process.
+--
+wrapUninterruptableIO :: IO a -> IO a
+wrapUninterruptableIO action = async action >>= wait
 
 data ShutdownHandlerLog
-    = MsgShutdownHandler Bool
+    = MsgShutdownHandlerEnabled Fd
     | MsgShutdownEOF
     | MsgShutdownError IOException
+    | MsgShutdownIncorrectUsage
     deriving (Show, Eq)
 
 instance ToText ShutdownHandlerLog where
     toText = \case
-        MsgShutdownHandler enabled ->
-            "Cross-platform subprocess shutdown handler is "
-            <> if enabled then "enabled." else "disabled."
+        MsgShutdownHandlerEnabled (Fd fd)->
+            "Cross-platform subprocess shutdown handler is enabled on fd "
+            <> T.pack (show fd) <> "."
         MsgShutdownEOF ->
             "Starting clean shutdown..."
         MsgShutdownError e ->
             "Error waiting for shutdown: " <> T.pack (show e)
             <> ". Shutting down..."
+        MsgShutdownIncorrectUsage ->
+             "--shutdown-ipc FD does not expect input. Shutting down..."
 
 instance HasPrivacyAnnotation ShutdownHandlerLog
 instance HasSeverityAnnotation ShutdownHandlerLog where
     getSeverityAnnotation = \case
-        MsgShutdownHandler _ -> Debug
+        MsgShutdownHandlerEnabled _ -> Debug
         MsgShutdownEOF -> Notice
         MsgShutdownError _ -> Error
+        MsgShutdownIncorrectUsage -> Error