Merge pull request #4855 from input-output-hk/jordan/remove-cli-node-…

…dependency Remove cardano-cli's dependency on cardano-node
IntersectMBO · Feb 8, 2023 · 75dfd53 · 75dfd53
2 parents c8862fe + c30bba7
commit 75dfd53
Show file tree

Hide file tree

Showing 3 changed files with 121 additions and 34 deletions.
diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal
@@ -163,6 +163,8 @@ executable cardano-cli
 
 test-suite cardano-cli-test
   import:               project-config
+                      , maybe-Win32
+                      , maybe-unix
 
   hs-source-dirs:       test
   main-is:              cardano-cli-test.hs
@@ -174,7 +176,6 @@ test-suite cardano-cli-test
                       , cardano-api
                       , cardano-api:gen
                       , cardano-cli
-                      , cardano-node
                       , cardano-prelude
                       , cardano-slotting ^>= 0.1
                       , containers
@@ -187,6 +188,7 @@ test-suite cardano-cli-test
                       , text
                       , time
                       , transformers
+                      , transformers-except
                       , yaml
 
   other-modules:        Test.Config.Mainnet

diff --git a/cardano-cli/test/Test/Cli/FilePermissions.hs b/cardano-cli/test/Test/Cli/FilePermissions.hs
@@ -1,14 +1,31 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 
+#if !defined(mingw32_HOST_OS)
+#define UNIX
+#endif
+
 module Test.Cli.FilePermissions
   ( tests
   ) where
 
-import           Cardano.Prelude
+import           Prelude
+
+import           Control.Monad
+import           Control.Monad.IO.Class
+import           Control.Monad.Trans.Except
+import           Control.Monad.Trans.Except.Extra
+import           Data.Text (Text)
+import qualified Data.Text as Text
 
+#ifdef UNIX
+import           System.Posix.Files
+import           System.Posix.Types (FileMode)
+#else
+import           System.Win32.File
+#endif
 
-import           Cardano.Node.Run (checkVRFFilePermissions)
 import           Hedgehog (Property, discover, success)
 import qualified Hedgehog
 import qualified Hedgehog.Extras.Test.Base as H
@@ -40,6 +57,65 @@ prop_createVRFSigningKeyFilePermissions =
             \file with the wrong permissions: " <> show err
       Right () -> success
 
+data VRFPrivateKeyFilePermissionError
+  = OtherPermissionsExist !FilePath
+  | GroupPermissionsExist !FilePath
+  | GenericPermissionsExist !FilePath
+  deriving Show
+
+renderVRFPrivateKeyFilePermissionError :: VRFPrivateKeyFilePermissionError -> Text
+renderVRFPrivateKeyFilePermissionError err =
+  case err of
+    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."
+    GenericPermissionsExist fp ->
+      "VRF private key file at: " <> Text.pack fp
+      <> "has \"generic\" file permissions. Please remove all \"generic\" file permissions."
+
+
+-- | Make sure the VRF private key file is readable only
+-- by the current process owner the node is running under.
+checkVRFFilePermissions :: FilePath -> ExceptT VRFPrivateKeyFilePermissionError IO ()
+#ifdef UNIX
+checkVRFFilePermissions 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)
+  -- Check the the VRF private key file does not give read/write/exec permissions to any group.
+  when (hasGroupPermissions fm)
+       (left $ GroupPermissionsExist vrfPrivKey)
+ where
+  hasPermission :: FileMode -> FileMode -> Bool
+  hasPermission fModeA fModeB = fModeA `intersectFileModes` fModeB /= nullFileMode
+
+  hasOtherPermissions :: FileMode -> Bool
+  hasOtherPermissions fm' = fm' `hasPermission` otherModes
+
+  hasGroupPermissions :: FileMode -> Bool
+  hasGroupPermissions fm' = fm' `hasPermission` groupModes
+#else
+checkVRFFilePermissions 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
+  -- https://docs.microsoft.com/en-us/windows/win32/secauthz/standard-access-rights
+  -- https://docs.microsoft.com/en-us/windows/win32/secauthz/generic-access-rights
+  -- https://docs.microsoft.com/en-us/windows/win32/secauthz/access-mask
+  when (attribs `hasPermission` genericPermissions)
+       (left $ GenericPermissionsExist vrfPrivKey)
+ where
+  genericPermissions = gENERIC_ALL .|. gENERIC_READ .|. gENERIC_WRITE .|. gENERIC_EXECUTE
+  hasPermission fModeA fModeB = fModeA .&. fModeB /= gENERIC_NONE
+#endif
+
+
 -- -----------------------------------------------------------------------------
 
 tests :: IO Bool

diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs
@@ -19,15 +19,24 @@ module Cardano.Node.Run
   ) where
 
 import qualified Cardano.Api as Api
-import           Cardano.Prelude hiding (ByteString, STM, atomically, show, take, trace)
-import           Data.IP (toSockAddr)
-import           Prelude (String, id, show)
+import           Prelude
 
+import           Control.Concurrent
 import           Control.Concurrent.Class.MonadSTM.Strict
-import           Control.Monad.Trans.Except.Extra (left)
+import           Control.Exception
+import           Control.Monad
+import           Control.Monad.IO.Class (liftIO)
+import           Control.Monad.Trans.Except
+import           Control.Monad.Trans.Except.Extra
 import           "contra-tracer" Control.Tracer
+import           Data.Either
+import           Data.IP (toSockAddr)
+import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
-import           Data.Text (breakOn, pack, take)
+import           Data.Maybe
+import           Data.Monoid
+import           Data.Proxy
+import           Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import           Data.Time.Clock (getCurrentTime)
@@ -37,6 +46,7 @@ import           Network.HostName (getHostName)
 import           Network.Socket (Socket)
 import           System.Directory (canonicalizePath, createDirectoryIfMissing, makeAbsolute)
 import           System.Environment (lookupEnv)
+import           System.Exit
 
 #ifdef UNIX
 import           GHC.Weak (deRefWeak)
@@ -61,12 +71,23 @@ import           Cardano.Node.Configuration.NodeAddress
 import           Cardano.Node.Configuration.POM (NodeConfiguration (..),
                    PartialNodeConfiguration (..), SomeNetworkP2PMode (..),
                    defaultPartialNodeConfiguration, makeNodeConfiguration, parseNodeConfigurationFP)
+import           Cardano.Node.Configuration.Socket (SocketOrSocketInfo (..),
+                   gatherConfiguredSockets, getSocketOrSocketInfoAddr)
+import qualified Cardano.Node.Configuration.Topology as TopologyNonP2P
+import           Cardano.Node.Configuration.TopologyP2P
+import qualified Cardano.Node.Configuration.TopologyP2P as TopologyP2P
+import           Cardano.Node.Handlers.Shutdown
+import           Cardano.Node.Protocol (mkConsensusProtocol)
+import           Cardano.Node.Protocol.Types
+import           Cardano.Node.Queries
 import           Cardano.Node.Startup
+import           Cardano.Node.TraceConstraints (TraceConstraints)
 import           Cardano.Node.Tracing.API
 import           Cardano.Node.Tracing.StateRep (NodeState (NodeKernelOnline))
 import           Cardano.Node.Tracing.Tracers.Startup (getStartupInfo)
 import           Cardano.Node.Types
 import           Cardano.Tracing.Config (TraceOptions (..), TraceSelection (..))
+import           Cardano.Tracing.Tracers
 
 import qualified Ouroboros.Consensus.Config as Consensus
 import           Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode (..))
@@ -87,18 +108,6 @@ import           Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPo
 import           Ouroboros.Network.Subscription (DnsSubscriptionTarget (..),
                    IPSubscriptionTarget (..))
 
-import           Cardano.Node.Configuration.Socket (SocketOrSocketInfo (..),
-                   gatherConfiguredSockets, getSocketOrSocketInfoAddr)
-import qualified Cardano.Node.Configuration.Topology as TopologyNonP2P
-import           Cardano.Node.Configuration.TopologyP2P
-import qualified Cardano.Node.Configuration.TopologyP2P as TopologyP2P
-import           Cardano.Node.Handlers.Shutdown
-import           Cardano.Node.Protocol (mkConsensusProtocol)
-import           Cardano.Node.Protocol.Types
-import           Cardano.Node.Queries
-import           Cardano.Node.TraceConstraints (TraceConstraints)
-import           Cardano.Tracing.Tracers
-
 {- HLINT ignore "Fuse concatMap/map" -}
 {- HLINT ignore "Redundant <$>" -}
 {- HLINT ignore "Use fewer imports" -}
@@ -115,7 +124,7 @@ runNode cmdPc = do
     configYamlPc <- parseNodeConfigurationFP . getLast $ pncConfigFile cmdPc
 
     nc <- case makeNodeConfiguration $ defaultPartialNodeConfiguration <> configYamlPc <> cmdPc of
-            Left err -> panic $ "Error in creating the NodeConfiguration: " <> Text.pack err
+            Left err -> error $ "Error in creating the NodeConfiguration: " <> err
             Right nc' -> return nc'
 
     putStrLn $ "Node configuration: " <> show nc
@@ -124,7 +133,7 @@ runNode cmdPc = do
       Just vrfFp -> do vrf <- runExceptT $ checkVRFFilePermissions vrfFp
                        case vrf of
                          Left err ->
-                           putTextLn (renderVRFPrivateKeyFilePermissionError err) >> exitFailure
+                           putStrLn (Text.unpack $ renderVRFPrivateKeyFilePermissionError err) >> exitFailure
                          Right () ->
                            pure ()
       Nothing -> pure ()
@@ -214,10 +223,10 @@ handleNodeWithTracers cmdPc nc p networkMagic runP = do
             p
 
           loggingLayer <- case eLoggingLayer of
-            Left err  -> putTextLn (Text.pack $ show err) >> exitFailure
+            Left err  -> print err >> exitFailure
             Right res -> return res
           !trace <- setupTrace loggingLayer
-          let tracer = contramap pack $ toLogObject trace
+          let tracer = contramap Text.pack $ toLogObject trace
           logTracingVerbosity nc tracer
 
           -- Legacy logging infrastructure must trace 'nodeStartTime' and 'nodeBasicInfo'.
@@ -282,14 +291,14 @@ setupTrace
   :: LoggingLayer
   -> IO (Trace IO Text)
 setupTrace loggingLayer = do
-    hn <- maybe hostname (pure . pack) =<< lookupEnv "CARDANO_NODE_LOGGING_HOSTNAME"
-    return $
-        setHostname hn $
-        llAppendName loggingLayer "node" (llBasicTrace loggingLayer)
+   hn <- maybe hostname (return . Text.pack) =<< lookupEnv "CARDANO_NODE_LOGGING_HOSTNAME"
+   return . setHostname hn $
+     llAppendName loggingLayer "node" (llBasicTrace loggingLayer)
   where
-    hostname = do
-      hn0 <- pack <$> getHostName
-      return $ take 8 $ fst $ breakOn "." hn0
+   hostname :: IO Text
+   hostname = do
+     hn0 <- Text.pack <$> getHostName
+     return $ Text.take 8 $ fst $ Text.breakOn "." hn0
 
 {-
 -- TODO: needs to be finished (issue #4362)
@@ -519,11 +528,11 @@ handleSimpleNode runP p2pMode tracers nc onKernel = do
     Signals.Catch $ do
       traceWith (startupTracer tracers) NetworkConfigUpdate
       result <- try $ TopologyP2P.readTopologyFileOrError (startupTracer tracers) nc
-      case result of
-        Left (FatalError err) ->
+      case result :: Either IOException NetworkTopology of
+        Left err ->
           traceWith (startupTracer tracers)
                   $ NetworkConfigUpdateError
-                  $ pack "Error reading topology configuration file:" <> err
+                  $ Text.pack $ "Error reading topology configuration file:" <> show err
         Right nt -> do
           let (localRoots, publicRoots) = producerAddresses nt
           traceWith (startupTracer tracers)