Print warning on group permissions check for VRF instead of failing to start the node.

cardano-node/cardano-node.cabal

@@ -265,6 +265,7 @@ test-suite cardano-node-test
                       , cardano-protocol-tpraos
                       , cardano-node
                       , cardano-slotting
+                      , contra-tracer
                       , directory
                       , filepath
                       , hedgehog
@@ -279,6 +280,7 @@ test-suite cardano-node-test
                       , ouroboros-network-api
                       , strict-sop-core
                       , text
+                      , trace-dispatcher
                       , transformers
                       , vector
                       , yaml

cardano-node/src/Cardano/Node/Configuration/POM.hs

@@ -45,14 +45,14 @@ import           Ouroboros.Consensus.Node (NodeDatabasePaths (..))
 import qualified Ouroboros.Consensus.Node as Consensus (NetworkP2PMode (..))
 import           Ouroboros.Consensus.Node.Genesis (GenesisConfig, GenesisConfigFlags,
                    defaultGenesisConfigFlags, mkGenesisConfig)
-import qualified Ouroboros.Network.Diffusion.Configuration as Ouroboros
-import           Ouroboros.Network.Mux (ForkPolicy, noBindForkPolicy, responderForkPolicy)
-import qualified Ouroboros.Network.PeerSelection.Governor as PeerSelection
 import           Ouroboros.Consensus.Storage.LedgerDB.Args (QueryBatchSize (..))
 import           Ouroboros.Consensus.Storage.LedgerDB.Snapshots (NumOfDiskSnapshots (..),
                    SnapshotInterval (..))
 import           Ouroboros.Consensus.Storage.LedgerDB.V1.Args (FlushFrequency (..))
 import           Ouroboros.Network.Diffusion.Configuration as Configuration
+import qualified Ouroboros.Network.Diffusion.Configuration as Ouroboros
+import           Ouroboros.Network.Mux (ForkPolicy, noBindForkPolicy, responderForkPolicy)
+import qualified Ouroboros.Network.PeerSelection.Governor as PeerSelection
 
 import           Control.Concurrent (getNumCapabilities)
 import           Control.Monad (unless, void, when)

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

@@ -23,6 +23,7 @@ module Cardano.Node.Run
   ) where
 
 import           Cardano.Api (File (..), FileDirection (..))
+import           Cardano.Api.Internal.Error (displayError)
 import qualified Cardano.Api as Api
 import           System.Random (randomIO)
 
@@ -58,7 +59,7 @@ import           Cardano.Node.Tracing.StateRep (NodeState (NodeKernelOnline))
 import           Cardano.Node.Tracing.Tracers.NodeVersion (getNodeVersion)
 import           Cardano.Node.Tracing.Tracers.Startup (getStartupInfo)
 import           Cardano.Node.Types
-import           Cardano.Prelude (FatalError (..), bool, (:~:) (..))
+import           Cardano.Prelude (FatalError (..), bool, (:~:) (..), stderr, )
 import           Cardano.Tracing.Config (TraceOptions (..), TraceSelection (..))
 import           Cardano.Tracing.Tracers
 
@@ -123,7 +124,7 @@ import           Ouroboros.Network.Subscription (DnsSubscriptionTarget (..),
 
 import           Control.Concurrent (killThread, mkWeakThreadId, myThreadId, getNumCapabilities)
 import           Control.Concurrent.Class.MonadSTM.Strict
-import           Control.Exception (try, IOException)
+import           Control.Exception (try, Exception, IOException)
 import qualified Control.Exception as Exception
 import           Control.Monad (forM, forM_, unless, void, when)
 import           Control.Monad.Class.MonadThrow (MonadThrow (..))
@@ -153,6 +154,7 @@ import           Network.HostName (getHostName)
 import           Network.Socket (Socket)
 import           System.Directory (canonicalizePath, createDirectoryIfMissing, makeAbsolute)
 import           System.Environment (lookupEnv)
+import           System.IO (hPutStrLn)
 #ifdef UNIX
 import           GHC.Weak (deRefWeak)
 import           System.Posix.Files
@@ -185,34 +187,24 @@ runNode cmdPc = do
 
     putStrLn $ "Node configuration: " <> show nc
 
-    case shelleyVRFFile $ ncProtocolFiles nc of
-      Just vrfFp -> do vrf <- runExceptT $ checkVRFFilePermissions (File vrfFp)
-                       case vrf of
-                         Left err -> Exception.throwIO err
-                         Right () ->
-                           pure ()
-      Nothing -> pure ()
-
-    eitherSomeProtocol <- runExceptT $ mkConsensusProtocol
-                                         (ncProtocolConfig nc)
-                                         -- TODO: Convert ncProtocolFiles to Maybe as relay nodes
-                                         -- don't need these.
-                                         (Just $ ncProtocolFiles nc)
-
-    p :: SomeConsensusProtocol <-
-      case eitherSomeProtocol of
-        Left err -> Exception.throwIO err
-        Right p  -> pure p
-
-    let networkMagic :: Api.NetworkMagic =
-          case p of
-            SomeConsensusProtocol _ runP ->
-              let ProtocolInfo { pInfoConfig } = fst $ Api.protocolInfo @IO runP
-              in getNetworkMagic $ Consensus.configBlock pInfoConfig
-
-    case p of
-      SomeConsensusProtocol blockType runP ->
-        handleNodeWithTracers cmdPc nc p networkMagic blockType runP
+    case ncProtocolFiles nc of
+      ProtocolFilepaths{shelleyVRFFile=Just vrfFp} ->
+        runThrowExceptT $
+          checkVRFFilePermissions stdoutTracer (File vrfFp)
+      _ -> pure ()
+
+    consensusProtocol <-
+      runThrowExceptT $
+        mkConsensusProtocol
+         (ncProtocolConfig nc)
+         -- TODO: Convert ncProtocolFiles to Maybe as relay nodes
+         -- don't need these.
+         (Just $ ncProtocolFiles nc)
+
+    handleNodeWithTracers cmdPc nc consensusProtocol
+
+runThrowExceptT :: Exception e => ExceptT e IO a -> IO a
+runThrowExceptT act = runExceptT act >>= either Exception.throwIO pure
 
 -- | Workaround to ensure that the main thread throws an async exception on
 -- receiving a SIGTERM signal.
@@ -233,17 +225,13 @@ installSigTermHandler = do
   return ()
 
 handleNodeWithTracers
-  :: ( TraceConstraints blk
-     , Api.Protocol IO blk
-     )
-  => PartialNodeConfiguration
+  :: PartialNodeConfiguration
   -> NodeConfiguration
   -> SomeConsensusProtocol
-  -> Api.NetworkMagic
-  -> Api.BlockType blk
-  -> Api.ProtocolInfoArgs blk
   -> IO ()
-handleNodeWithTracers cmdPc nc0 p networkMagic blockType runP = do
+handleNodeWithTracers cmdPc nc0 p@(SomeConsensusProtocol blockType runP) = do
+  let ProtocolInfo{pInfoConfig} = fst $ Api.protocolInfo @IO runP
+      networkMagic :: Api.NetworkMagic = getNetworkMagic $ Consensus.configBlock pInfoConfig
   -- This IORef contains node kernel structure which holds node kernel.
   -- Used for ledger queries and peer connection status.
   nodeKernelData <- mkNodeKernelData
@@ -913,17 +901,17 @@ canonDbPath NodeConfiguration{ncDatabaseFile = nodeDatabaseFps} =
 
 -- | Make sure the VRF private key file is readable only
 -- by the current process owner the node is running under.
-checkVRFFilePermissions :: File content direction -> ExceptT VRFPrivateKeyFilePermissionError IO ()
+checkVRFFilePermissions :: Tracer IO String -> File content direction -> ExceptT VRFPrivateKeyFilePermissionError IO ()
 #ifdef UNIX
-checkVRFFilePermissions (File vrfPrivKey) = do
+checkVRFFilePermissions tracer (File vrfPrivKey) = do
   fs <- liftIO $ getFileStatus vrfPrivKey
   let fm = fileMode fs
   -- Check the the VRF private key file does not give read/write/exec permissions to others.
-  when (hasOtherPermissions fm)
-       (left $ OtherPermissionsExist vrfPrivKey)
+  when (hasOtherPermissions fm) $
+     left $ OtherPermissionsExist vrfPrivKey
   -- Check the the VRF private key file does not give read/write/exec permissions to any group.
-  when (hasGroupPermissions fm)
-       (left $ GroupPermissionsExist vrfPrivKey)
+  when (hasGroupPermissions fm) $
+     liftIO $ traceWith tracer $ ("WARNING: " <>) .  displayError $ GroupPermissionsExist vrfPrivKey
  where
   hasPermission :: FileMode -> FileMode -> Bool
   hasPermission fModeA fModeB = fModeA `intersectFileModes` fModeB /= nullFileMode
@@ -934,7 +922,7 @@ checkVRFFilePermissions (File vrfPrivKey) = do
   hasGroupPermissions :: FileMode -> Bool
   hasGroupPermissions fm' = fm' `hasPermission` groupModes
 #else
-checkVRFFilePermissions (File vrfPrivKey) = do
+checkVRFFilePermissions _ (File vrfPrivKey) = do
   attribs <- liftIO $ getFileAttributes vrfPrivKey
   -- https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-createfilea
   -- https://docs.microsoft.com/en-us/windows/win32/fileio/file-access-rights-constants

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

@@ -477,10 +477,9 @@ renderVRFPrivateKeyFilePermissionError err =
     OtherPermissionsExist fp ->
       "VRF private key file at: " <> Text.pack fp
       <> " has \"other\" file permissions. Please remove all \"other\" file permissions."
-
     GroupPermissionsExist fp ->
       "VRF private key file at: " <> Text.pack fp
-      <> "has \"group\" file permissions. Please remove all \"group\" file permissions."
+      <> " has \"group\" file permissions. Please remove all \"group\" file permissions."
     GenericPermissionsExist fp ->
       "VRF private key file at: " <> Text.pack fp
-      <> "has \"generic\" file permissions. Please remove all \"generic\" file permissions."
+      <> " has \"generic\" file permissions. Please remove all \"generic\" file permissions."

cardano-node/test/Test/Cardano/Node/FilePermissions.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
 
 {-# OPTIONS_GHC -Wno-unused-imports #-}
 {-# LANGUAGE TypeApplications #-}
@@ -14,7 +15,10 @@ module Test.Cardano.Node.FilePermissions
   ) where
 
 import           Control.Monad.Except
+import           "contra-tracer" Control.Tracer
+import           Control.Tracer.Arrow
 import           Data.Foldable
+import           Data.IORef
 import           System.Directory (removeFile)
 
 import           Cardano.Api
@@ -31,21 +35,21 @@ import           Data.Function (const, ($), (.))
 import qualified Data.List as L
 import           Data.Maybe (Maybe (..))
 import           Data.Semigroup (Semigroup (..))
-import           Hedgehog (Property, PropertyT, property, success)
-import qualified Hedgehog
+import           Hedgehog
 import           Hedgehog.Internal.Property (Group (..), failWith)
 import           System.IO (FilePath, IO)
 import           Text.Show (Show (..))
+import           Cardano.Node.Types (VRFPrivateKeyFilePermissionError (..))
 
 #ifdef UNIX
-import           Cardano.Node.Types (VRFPrivateKeyFilePermissionError (..))
 
 import           System.Posix.Files
 import           System.Posix.IO (closeFd, createFile)
 import           System.Posix.Types (FileMode)
 
 import           Control.Exception (bracket)
-import           Hedgehog (Gen, classify, forAll)
+import           Hedgehog
+import           Hedgehog.Extras
 import qualified Hedgehog.Gen as Gen
 #endif
 
@@ -56,10 +60,10 @@ prop_createVRFFileWithOwnerPermissions :: Property
 prop_createVRFFileWithOwnerPermissions =
   property $ do
     let vrfSign = "vrf-signing-key"
-    vrfSkey <- liftIO $ generateSigningKey AsVrfKey
+    vrfSkey <- evalIO $ generateSigningKey AsVrfKey
     createFileWithOwnerPermissions vrfSign vrfSkey
 
-    fResult <- liftIO . runExceptT $ checkVRFFilePermissions vrfSign
+    fResult <- evalIO . runExceptT $ checkVRFFilePermissions nullTracer vrfSign
     case fResult of
       Left err -> failWith Nothing $ show err
       Right () -> liftIO (removeFile (unFile vrfSign)) >> success
@@ -84,7 +88,7 @@ prop_sanityCheck_checkVRFFilePermissions =
     correctResult <-
       liftIO $ bracket  (createFile (unFile vrfPrivateKeyCorrect) correctPermission)
                         (\h -> closeFd h >> removeFile (unFile vrfPrivateKeyCorrect))
-                        (const . liftIO . runExceptT $ checkVRFFilePermissions vrfPrivateKeyCorrect)
+                        (const . liftIO . runExceptT $ checkVRFFilePermissions nullTracer vrfPrivateKeyCorrect)
     case correctResult of
       Left err ->
         failWith Nothing $ "checkVRFFilePermissions should not have failed with error: "
@@ -105,7 +109,7 @@ prop_sanityCheck_checkVRFFilePermissions =
                             setFileMode (unFile vrfPrivateKeyOther) $ createPermissions oPermissions
                             return h)
                         (\h -> closeFd h >> removeFile (unFile vrfPrivateKeyOther))
-                        (const .liftIO . runExceptT $ checkVRFFilePermissions vrfPrivateKeyOther)
+                        (const .liftIO . runExceptT $ checkVRFFilePermissions nullTracer vrfPrivateKeyOther)
     case otherResult of
       Left (OtherPermissionsExist _) -> success
       Left err ->
@@ -120,6 +124,7 @@ prop_sanityCheck_checkVRFFilePermissions =
     classify "VRF File has one group permission" $ length gPermissions == 1
     classify "VRF File has two group permissions" $ length gPermissions == 2
     classify "VRF File has three group permissions" $ length gPermissions == 3
+    (capturingTracer, messagesIor) <- mkCapturingTracer
     groupResult <-
       -- Creating a file with group permissions appears to not work
       -- it instead creates a file with owner permissions. Therefore we must
@@ -128,14 +133,19 @@ prop_sanityCheck_checkVRFFilePermissions =
                             setFileMode (unFile vrfPrivateKeyGroup) $ createPermissions gPermissions
                             return h)
                         (\h -> closeFd h >> removeFile (unFile vrfPrivateKeyGroup))
-                        (const . liftIO . runExceptT $ checkVRFFilePermissions vrfPrivateKeyGroup)
+                        (const . liftIO . runExceptT $ checkVRFFilePermissions capturingTracer vrfPrivateKeyGroup)
     case groupResult of
-      Left (GroupPermissionsExist _) -> success
+      Left (GroupPermissionsExist _) -> do
+        note_ "Group permissions check should not fail"
+        failure
       Left err ->
         failWith Nothing $ "checkVRFFilePermissions should not have failed with error: "
                          <> show err
-      Right () ->
-        failWith Nothing "This should have failed as Group permissions exist"
+      Right () -> do
+        messages <- evalIO $ readIORef messagesIor
+        ["WARNING: VRF private key file at: vrf-private-key-group has \"group\" file permissions. Please remove all \"group\" file permissions."]
+          === messages
+
 
 createPermissions :: [FileMode] -> FileMode
 createPermissions = foldl' unionFileModes (ownerReadMode `unionFileModes` ownerWriteMode)
@@ -151,13 +161,20 @@ genOtherPermissions =
   let oPermissions = [otherReadMode, otherWriteMode, otherExecuteMode]
   in do subSeq <- Gen.filter (not . L.null) $ Gen.subsequence oPermissions
         Gen.frequency [(3, return oPermissions), (12, return subSeq)]
+
+mkCapturingTracer :: MonadIO m => m (Tracer IO String, IORef [String])
+mkCapturingTracer = do
+  messages <- liftIO $ newIORef []
+  let registerMessage :: String -> IO ()
+      registerMessage msg = atomicModifyIORef messages (\msgs -> (msgs <> [msg], ()))
+  pure (Tracer registerMessage, messages)
 #endif
 
 -- -----------------------------------------------------------------------------
 
 tests :: IO Bool
 tests =
-  Hedgehog.checkParallel $ Group "Test.Cardano.Node.FilePermissons"
+  checkParallel $ Group "Test.Cardano.Node.FilePermissons"
 #ifdef UNIX
     [ ("prop_createVRFFileWithOwnerPermissions", prop_createVRFFileWithOwnerPermissions)
     , ("prop_sanityCheck_checkVRFFilePermissions", prop_sanityCheck_checkVRFFilePermissions)

cardano-node/test/Test/Cardano/Node/POM.hs

@@ -15,12 +15,13 @@ import           Cardano.Node.Handlers.Shutdown
 import           Cardano.Node.Types
 import           Cardano.Tracing.Config (PartialTraceOptions (..), defaultPartialTraceConfiguration,
                    partialTraceSelectionToEither)
+import           Ouroboros.Cardano.Network.Diffusion.Configuration (defaultNumberOfBigLedgerPeers)
 import           Ouroboros.Consensus.Node (NodeDatabasePaths (..))
 import qualified Ouroboros.Consensus.Node as Consensus (NetworkP2PMode (..))
 import           Ouroboros.Consensus.Node.Genesis (disableGenesisConfig)
+import           Ouroboros.Consensus.Storage.LedgerDB.Args
 import           Ouroboros.Consensus.Storage.LedgerDB.Snapshots (NumOfDiskSnapshots (..),
                    SnapshotInterval (..))
-import           Ouroboros.Consensus.Storage.LedgerDB.Args
 import           Ouroboros.Network.Block (SlotNo (..))
 import           Ouroboros.Network.Diffusion.Configuration (ConsensusMode (..))
 import           Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..),
@@ -33,7 +34,6 @@ import           Data.Text (Text)
 import           Hedgehog (Property, discover, withTests, (===))
 import qualified Hedgehog
 import           Hedgehog.Internal.Property (evalEither, failWith)
-import Ouroboros.Cardano.Network.Diffusion.Configuration (defaultNumberOfBigLedgerPeers)
 
 
 -- This is a simple test to check that the POM technique is working as intended.

cardano-testnet/test/cardano-testnet-test/files/calculatePlutusScriptCost.json

@@ -7,4 +7,4 @@
         "lovelaceCost": 34,
         "scriptHash": "186e32faa80a26810392fda6d559c7ed4721a65ce1c9d4ef3e1c87b4"
     }
-]
+]