Merge #767

767: Cross-platform clean shutdown mechanism r=dcoutts a=dcoutts

Cross-platform clean shutdown support with `--shutdown-ipc FD` flag

Fixes #726

On Windows there is no standard reliable mechanism to politely ask a process to stop. There is only the brutal TerminateProcess. Using that by default is not great since it means the node always has to revalidate its chain DB on startup.

This adds an ad-hoc mechainsim that Daedalus can use to reliably shut down the node process. The `--shutdown-ipc` flag takes the FD of the read end of an inherited pipe. If provided, the node will monitor that pipe when when the write end of the pipe is closed then the node will initiate a clean shutdown. So Daedalus can explicitly terminate the node by closing the write end of the pipe. If Daedalus terminates uncleanly then the pipe will also be closed and the node will also shut down.

Although this mechanism is needed for Windows, it is also cross-platform so it can be used by Daedalus across all platforms.



Co-authored-by: Duncan Coutts <[email protected]>
Co-authored-by: Kosyrev Serge <[email protected]>

cardano-config/src/Cardano/Config/Logging.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP                 #-}
+{-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE Rank2Types          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -203,8 +204,8 @@ createLoggingFeature ver _ nodeProtocolMode = do
     pure (loggingLayer, cardanoFeature)
  where
   getConfigYaml :: NodeProtocolMode -> ConfigYamlFilePath
-  getConfigYaml (RealProtocolMode (NodeCLI _ _ rConfigFp _ )) = rConfigFp
-  getConfigYaml (MockProtocolMode (NodeMockCLI _ _ mConfigFp _)) = mConfigFp
+  getConfigYaml (RealProtocolMode NodeCLI{configFp}) = configFp
+  getConfigYaml (MockProtocolMode NodeMockCLI{mockConfigFp}) = mockConfigFp
 
 -- | Initialize `LoggingCardanoFeature`
 loggingCardanoFeatureInit :: Text -> LoggingFlag -> LoggingConfiguration -> IO (LoggingLayer, LoggingLayer -> IO ())

cardano-config/src/Cardano/Config/Topology.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 
@@ -47,10 +48,10 @@ nodeAddressToSockAddr (NodeAddress addr port) =
 
 nodeAddressInfo :: NodeProtocolMode -> IO [AddrInfo]
 nodeAddressInfo npm = do
-  (NodeAddress hostAddr port) <-
-    case npm of
-      (RealProtocolMode (NodeCLI _ nodeAddr' _ _)) -> pure nodeAddr'
-      (MockProtocolMode (NodeMockCLI _ nodeAddr' _ _)) -> pure nodeAddr'
+  let NodeAddress hostAddr port =
+        case npm of
+          RealProtocolMode NodeCLI{nodeAddr} -> nodeAddr
+          MockProtocolMode NodeMockCLI{mockNodeAddr} -> mockNodeAddr
   let hints = defaultHints {
                 addrFlags = [AI_PASSIVE, AI_ADDRCONFIG]
               , addrSocketType = Stream
@@ -124,9 +125,9 @@ instance FromJSON NetworkTopology where
 -- other remote peers it will attempt to connect to.
 readTopologyFile :: NodeProtocolMode -> IO (Either Text NetworkTopology)
 readTopologyFile npm = do
-  topo  <- case npm of
-             (RealProtocolMode (NodeCLI mscFp' _ _ _)) -> pure . unTopology $ topFile mscFp'
-             (MockProtocolMode (NodeMockCLI mscFp' _ _ _)) -> pure . unTopology $ topFile mscFp'
+  let topo = case npm of
+               RealProtocolMode NodeCLI{mscFp}         -> unTopology (topFile mscFp)
+               MockProtocolMode NodeMockCLI{mockMscFp} -> unTopology (topFile mockMscFp)
 
   eBs <- Exception.try $ BS.readFile topo
 

cardano-config/src/Cardano/Config/Types.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
 
 module Cardano.Config.Types
     ( CardanoEnvironment (..)
@@ -27,6 +27,7 @@ module Cardano.Config.Types
     , Update (..)
     , ViewMode (..)
     , YamlSocketPath (..)
+    , Fd (..)
     , parseNodeConfiguration
     , parseNodeConfigurationFP
     ) where
@@ -40,6 +41,7 @@ import qualified Data.Text as T
 import           Data.Yaml (decodeFileThrow)
 import           Network.Socket (PortNumber)
 import           System.FilePath ((</>), takeDirectory)
+import           System.Posix.Types (Fd(Fd))
 
 import qualified Cardano.Chain.Update as Update
 import           Cardano.BM.Data.Tracer (TracingVerbosity (..))
@@ -84,6 +86,7 @@ data NodeCLI = NodeCLI
   , nodeAddr :: !NodeAddress
   , configFp :: !ConfigYamlFilePath
   , validateDB :: !Bool
+  , shutdownIPC :: !(Maybe Fd)
   }
 
 data NodeMockCLI = NodeMockCLI
@@ -98,6 +101,15 @@ data NodeMockCLI = NodeMockCLI
 data NodeProtocolMode = MockProtocolMode NodeMockCLI
                       | RealProtocolMode NodeCLI
 
+-- TODO: these types above are currently structured such that we cannot share
+-- anything. Sharing nothing is too little. There are things that are the same
+-- that we can and should share. The code is littered with example where we
+-- select the same bits from both sides.
+--
+-- At the same time, we are not yet taking advantage of the ability to have
+-- different fields for the real vs mock. For example the MiscellaneousFilepaths
+-- is used for both, but mock protocols do not use delegCertFile or signKeyFile.
+
 -- | Filepath of the configuration yaml file. This file determines
 -- all the configuration settings required for the cardano node
 -- (logging, tracing, protocol, slot length etc)
@@ -254,8 +266,11 @@ parseNodeConfigurationFP (ConfigYamlFilePath fp) = do
 parseNodeConfiguration :: NodeProtocolMode -> IO NodeConfiguration
 parseNodeConfiguration npm =
   case npm of
-    MockProtocolMode (NodeMockCLI _ _ cy _) -> parseNodeConfigurationFP cy
-    RealProtocolMode (NodeCLI _ _ cy _) -> parseNodeConfigurationFP cy
+    MockProtocolMode NodeMockCLI{mockConfigFp} ->
+      parseNodeConfigurationFP mockConfigFp
+
+    RealProtocolMode NodeCLI{configFp} ->
+      parseNodeConfigurationFP configFp
 
 -- TODO:  we don't want ByronLegacy in Protocol.  Let's wrap Protocol with another
 -- sum type for cases where it's required.

cardano-node/src/Cardano/Common/Parsers.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 
 {-# OPTIONS_GHC -Wno-all-missed-specialisations #-}
@@ -124,6 +125,7 @@ nodeRealParser = do
   nodeConfigFp <- parseConfigFile
 
   validate <- parseValidateDB
+  shutdownIPC <- parseShutdownIPC
 
   pure NodeCLI
     { mscFp = MiscellaneousFilepaths
@@ -136,6 +138,7 @@ nodeRealParser = do
     , nodeAddr = nAddress
     , configFp = ConfigYamlFilePath nodeConfigFp
     , validateDB = validate
+    , shutdownIPC
     }
 
 parseCLISocketPath :: Text -> Parser (Maybe CLISocketPath)
@@ -249,6 +252,15 @@ parseValidateDB =
       <> help "Validate all on-disk database files"
     )
 
+parseShutdownIPC :: Parser (Maybe Fd)
+parseShutdownIPC =
+    optional $ option (Fd <$> auto) (
+         long "shutdown-ipc"
+      <> metavar "FD"
+      <> help "Shut down the process when this inherited FD reaches EOF"
+      <> hidden
+    )
+
 -- | Flag parser, that returns its argument on success.
 flagParser :: a -> String -> String -> Parser a
 flagParser val opt desc = flag' val $ long opt <> help desc

cardano-node/src/Cardano/Node/Run.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -21,12 +22,9 @@ module Cardano.Node.Run
 where
 
 import           Cardano.Prelude hiding (ByteString, atomically, take, trace)
-import qualified GHC.Base
-import           Prelude (error, unlines)
+import           Prelude (String, error, unlines)
 
-#ifdef UNIX
 import qualified Control.Concurrent.Async as Async
-#endif
 import           Control.Tracer
 import qualified Data.ByteString.Char8 as BSC
 import           Data.Either (partitionEithers)
@@ -39,6 +37,9 @@ import           Data.Version (showVersion)
 import           Network.HostName (getHostName)
 import           Network.Socket (AddrInfo)
 import           System.Directory (canonicalizePath, makeAbsolute)
+import qualified System.IO as IO
+import qualified System.IO.Error  as IO
+import qualified GHC.IO.Handle.FD as IO (fdToHandle)
 
 import           Paths_cardano_node (version)
 #ifdef UNIX
@@ -49,7 +50,8 @@ import           Cardano.BM.Data.BackendKind (BackendKind (..))
 import           Cardano.BM.Data.LogItem (LOContent (..),
                      PrivacyAnnotation (..), mkLOMeta)
 import           Cardano.BM.Data.Tracer (ToLogObject (..),
-                     TracingVerbosity (..))
+                     TracingVerbosity (..), TracingFormatting (..),
+                     severityNotice, trTransformer)
 import           Cardano.BM.Data.Transformers (setHostname)
 import           Cardano.BM.Trace
 
@@ -204,7 +206,8 @@ handleSimpleNode p trace nodeTracers npm onKernel = do
     Left err   -> (putTextLn $ show err) >> exitFailure
     Right addr -> return addr
 
-  Node.run
+  withShutdownHandler npm trace $
+   Node.run
     (consensusTracers nodeTracers)
     (protocolTracers nodeTracers)
     (chainDBTracer nodeTracers)
@@ -258,12 +261,12 @@ handleSimpleNode p trace nodeTracers npm onKernel = do
   createTracers
     :: NodeProtocolMode
     -> Trace IO Text
-    -> Tracer IO GHC.Base.String
+    -> Tracer IO String
     -> Consensus.TopLevelConfig blk
     -> IO ()
   createTracers npm' tr tracer cfg = do
      case npm' of
-       RealProtocolMode (NodeCLI _ rNodeAddr _ runDBValidation) -> do
+       RealProtocolMode NodeCLI{nodeAddr, validateDB} -> do
          eitherTopology <- readTopologyFile npm
          nt <- either
                  (\err -> panic $ "Cardano.Node.Run.readTopologyFile: " <> err)
@@ -278,7 +281,7 @@ handleSimpleNode p trace nodeTracers npm onKernel = do
          traceWith tracer $ unlines
            [ ""
            , "**************************************"
-           , "Host node address: " <> show rNodeAddr
+           , "Host node address: " <> show nodeAddr
            , "My DNS producers are " <> show dnsProducerAddrs
            , "My IP producers are " <> show ipProducerAddrs
            , "**************************************"
@@ -292,9 +295,9 @@ handleSimpleNode p trace nodeTracers npm onKernel = do
          traceNamedObject vTr (meta, LogMessage . pack . showVersion $ version)
          traceNamedObject cTr (meta, LogMessage gitRev)
 
-         when runDBValidation $ traceWith tracer "Performing DB validation"
+         when validateDB $ traceWith tracer "Performing DB validation"
 
-       MockProtocolMode (NodeMockCLI _ mockNodeAddress _ runDBValidation) -> do
+       MockProtocolMode NodeMockCLI{mockNodeAddr, mockValidateDB} -> do
          eitherTopology <- readTopologyFile npm
          nodeid <- nid npm
          (MockNodeTopology nodeSetups) <- either
@@ -307,20 +310,63 @@ handleSimpleNode p trace nodeTracers npm onKernel = do
              producers' = case (List.lookup nodeid producersList) of
                             Just ps ->  ps
                             Nothing -> error $ "handleSimpleNode: own address "
-                                         <> show mockNodeAddress
+                                         <> show mockNodeAddr
                                          <> ", Node Id "
                                          <> show nodeid
                                          <> " not found in topology"
 
          traceWith tracer $ unlines
                                [ ""
                                , "**************************************"
-                               , "I am Node "        <> show mockNodeAddress <> " Id: " <> show nodeid
+                               , "I am Node "        <> show mockNodeAddr
+                                          <> " Id: " <> show nodeid
                                , "My producers are " <> show producers'
                                , "**************************************"
                                ]
 
-         when runDBValidation $ traceWith tracer "Performing DB validation"
+         when mockValidateDB $ traceWith tracer "Performing DB validation"
+
+-- | We provide an optional cross-platform method to politely request shut down.
+--
+-- The parent process passes us the file descriptor number of the read end of a
+-- pipe, via the CLI with @--shutdown-ipc FD@. If the write end gets closed,
+-- either deliberatly by the parent process or automatically because the parent
+-- process itself terminated, then we initiate a clean shutdown.
+--
+withShutdownHandler :: NodeProtocolMode -> Trace IO Text -> IO () -> IO ()
+withShutdownHandler (RealProtocolMode NodeCLI{shutdownIPC = Just (Fd fd)})
+                    trace action =
+    Async.race_ (wrapUninterruptableIO waitForEOF) action
+  where
+    waitForEOF :: IO ()
+    waitForEOF = do
+      hnd <- IO.fdToHandle fd
+      r   <- try $ IO.hGetChar hnd
+      case r of
+        Left e
+          | IO.isEOFError e -> traceWith tracer "received shutdown request"
+          | otherwise       -> throwIO e
+
+        Right _  ->
+          throwIO $ IO.userError "--shutdown-ipc FD does not expect input"
+
+    tracer :: Tracer IO Text
+    tracer = trTransformer TextualRepresentation MaximalVerbosity
+                           (severityNotice trace)
+
+withShutdownHandler _ _ action = action
+
+-- | 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
 
 
 --------------------------------------------------------------------------------
@@ -330,17 +376,18 @@ handleSimpleNode p trace nodeTracers npm onKernel = do
 canonDbPath :: NodeProtocolMode -> IO FilePath
 canonDbPath npm  = do
   dbFp <- case npm of
-            MockProtocolMode (NodeMockCLI mscFp' _ _ _) -> do
+            MockProtocolMode NodeMockCLI{mockMscFp} -> do
+              --TODO: we should eliminate auto-naming here too
               nodeid <- nid npm
-              pure $ (unDB $ dBFile mscFp') <> "-" <> show nodeid
+              pure $ unDB (dBFile mockMscFp) <> "-" <> show nodeid
 
-            RealProtocolMode (NodeCLI mscFp' _ _ _) -> pure . unDB $ dBFile mscFp'
+            RealProtocolMode NodeCLI{mscFp} -> pure . unDB $ dBFile mscFp
 
   canonicalizePath =<< makeAbsolute dbFp
 
 dbValidation :: NodeProtocolMode -> Bool
-dbValidation (MockProtocolMode (NodeMockCLI _ _ _ dbval)) = dbval
-dbValidation (RealProtocolMode (NodeCLI _ _ _ dbval)) = dbval
+dbValidation (MockProtocolMode NodeMockCLI{mockValidateDB}) = mockValidateDB
+dbValidation (RealProtocolMode NodeCLI{validateDB}) = validateDB
 
 createDiffusionArguments
   :: [AddrInfo]
@@ -373,8 +420,8 @@ dnsSubscriptionTarget ra =
 extractMiscFilePaths :: NodeProtocolMode -> MiscellaneousFilepaths
 extractMiscFilePaths npm =
   case npm of
-    MockProtocolMode (NodeMockCLI mMscFp _ _ _) -> mMscFp
-    RealProtocolMode (NodeCLI rMscFp _ _ _) -> rMscFp
+    MockProtocolMode NodeMockCLI{mockMscFp} -> mockMscFp
+    RealProtocolMode NodeCLI{mscFp} -> mscFp
 
 ipSubscriptionTargets :: [NodeAddress] -> IPSubscriptionTarget
 ipSubscriptionTargets ipProdAddrs =

cardano-node/src/Cardano/Node/TUI/LiveView.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE DeriveTraversable     #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE RankNTypes            #-}
 
@@ -546,9 +547,9 @@ initLiveViewState = do
                 }
 
 setTopology :: NFData a => LiveViewBackend blk a -> NodeProtocolMode -> IO ()
-setTopology lvbe (RealProtocolMode (NodeCLI _ nAddress _ _)) =
+setTopology lvbe (RealProtocolMode NodeCLI{nodeAddr}) =
   modifyMVar_ (getbe lvbe) $ \lvs ->
-    return $ lvs { lvsNodeId = pack $ "Port: " <> (show $ naPort nAddress) }
+    return lvs { lvsNodeId = pack $ "Port: " <> show (naPort nodeAddr) }
 setTopology lvbe npm = do
   nc <- parseNodeConfiguration npm
   modifyMVar_ (getbe lvbe) $ \lvs ->