content: {-# LANGUAGE FlexibleContexts #-}
  
  module Cardano.Cluster.Environment
      (
      -- * Environment
        Env
      , Artifact(..)
      , prepareEnvironment
  
      -- * State Directory
      , withStateDirectory
  
      -- * System Start
      , withSystemStart
  
      -- * Demo Configurations
      , demoTopologyBehindNAT
      , demoTopologyStatic
      , demoTLSConfiguration
      ) where
  
  import qualified Prelude
  import           Universum hiding (keys, (%~), (.~), _2)
  
  import           Control.Lens (Field2 (..), at, (%~), (.~), (?~))
  import           Data.Aeson (object, (.=))
  import qualified Data.Aeson as Aeson
  import qualified Data.Aeson.Types as Aeson
  import qualified Data.ByteString.Char8 as B8
  import qualified Data.ByteString.Lazy as BL
  import           Data.List ((!!))
  import           Data.Map (Map, (!))
  import qualified Data.Map.Strict as Map
  import           Data.Maybe (fromJust)
  import qualified Data.Text as T
  import           Data.Time (addUTCTime, defaultTimeLocale, formatTime,
                       getCurrentTime)
  import           Formatting (bprint, build, sformat, (%))
  import qualified Formatting.Buildable
  import           Network.TLS (PrivKey (PrivKeyRSA))
  import           System.Directory (createDirectoryIfMissing)
  import           System.FilePath (takeDirectory, (</>))
  import           System.IO.Temp (withSystemTempDirectory)
  
  import           Cardano.Cluster.Util (getsModify, indexedForM_, nextNtwrkAddr,
                       ntwrkAddrToNodeAddr, ntwrkAddrToString, rotations,
                       unsafeBoolFromString, unsafeElemIndex,
                       unsafeNetworkAddressFromString, unsafeSeverityFromString,
                       (|>))
  import           Cardano.Node.Manager (Manager, mkHttpsManagerSettings,
                       newManager)
  import           Cardano.X509.Configuration (CertConfiguration (..),
                       CertDescription (..), DirConfiguration (..),
                       ServerConfiguration (..), TLSConfiguration (..),
                       fromConfiguration, genCertificate)
  import           Data.X509.Extra (CertificateChain (..), genRSA256KeyPair,
                       isClientCertificate, writeCertificate, writeCredentials)
  import           Network.Broadcast.OutboundQueue (MaxBucketSize (..))
  import           Pos.Chain.Genesis (GeneratedSecrets (..), RichSecrets (..),
                       configGeneratedSecretsThrow, poorSecretToEncKey)
  import           Pos.Core.NetworkAddress (NetworkAddress)
  import           Pos.Infra.Network.DnsDomains (DnsDomains (..))
  import           Pos.Infra.Network.Types (NodeName (..), NodeType (..))
  import           Pos.Infra.Network.Yaml (AllStaticallyKnownPeers (..),
                       NodeMetadata (..), NodeRegion (..), NodeRoutes (..),
                       Topology (..))
  import           Pos.Launcher.Configuration (ConfigurationOptions (..),
                       withConfigurations)
  import           Pos.Util.Log.LoggerConfig (LoggerConfig)
  import           Pos.Util.Trace (noTrace)
  import           Pos.Util.UserSecret (UserSecret, defaultUserSecret,
                       mkGenesisWalletUserSecret, usKeys, usPath, usPrimKey,
                       usVss, usWallet)
  import qualified Pos.Util.UserSecret as UserSecret
  import           Pos.Util.Wlog.Compatibility (usingNamedPureLogger)
  import           Pos.Web.Types (TlsParams (..))
  
  
  -- | Simple Type-Alias for readability. This mimics the actual ENV but in a pure
  -- way. And bonus, we can use all sort of lenses and traversals on that!
  type Env = Map String String
  
  
  -- | Get Temporary Working / State Directory to work with.
  --
  -- use STATE_DIR as a directory if it's given,
  -- otherwise, create a new system-level temp directory.
  withStateDirectory
      :: Maybe FilePath     -- ^ A state directory, if Nothing, picks a random temp one
      -> (FilePath -> IO a) -- ^ Action to run with the state directory
      -> IO a
  withStateDirectory mdir cb =
      case mdir of
          Nothing ->
              withSystemTempDirectory "cardano-sl-cluster" cb
  
          Just dir ->
              cb dir
  
  
  -- | Get the local system time and hydrate the underlying environment.
  --
  -- Note that the system should be started "ahead" such that nodes can get
  -- started once turned on.
  withSystemStart
      :: Env             -- ^ The underlying environment
      -> IO Env
  withSystemStart env = do
      systemStart <-
          formatTime defaultTimeLocale "%s" . addUTCTime 14 <$> getCurrentTime
      return
          (env & at "SYSTEM_START" ?~ systemStart)
  
  
  -- A type to present environment artifact generated by @prepareEnvironment@
  data Artifact a eff = Artifact
      { getArtifact        :: a
      , initializeArtifact :: IO eff
      }
  
  -- Small alias for readability
  type Genesis = ()
  
  
  
  -- | Setup the environment for the node. This is where we assign default values
  -- to mandatory arguments and constructs the related configurations (topology,
  -- logging, tls, ...).
  --
  -- It returns actions that can be ran at a higher level to create and get those
  -- configurations as well as a modified ENV which has been hydrated with
  -- everything needed by the node to start.
  prepareEnvironment
      :: (NodeName, NodeType)     -- ^ Related node identifier
      -> [(NodeName, NodeType)]   -- ^ All nodes, including the related one
      -> FilePath                 -- ^ Node State / Working directory
      -> Env                      -- ^ ENVironment context with user-defined ENV vars
      -> ( ( Artifact Genesis ()
           , Artifact Topology ()
           , Artifact LoggerConfig ()
           , Artifact TlsParams Manager
           )
           , Env
         )
  prepareEnvironment node@(NodeName nodeIdT, nodeType) nodes stateDir = runState $ do
      modify withDefaultEnvironment
      genesis  <- getsModify prepareGenesis
      topology <- getsModify prepareTopology
      logger   <- getsModify prepareLogger
      tls      <- getsModify prepareTLS
      return (genesis, topology, logger, tls)
    where
      nodeId :: String
      nodeId = T.unpack nodeIdT
  
      cIndex :: Int
      cIndex = unsafeElemIndex node nodes
  
      (nodeNames :: [NodeName], nodeTypes :: [NodeType]) = unzip nodes
  
      nodeAddrs :: Env -> [(Maybe NetworkAddress, NetworkAddress)]
      nodeAddrs env = flip evalState (0, 0, 0) $ forM nodeTypes $ \typ -> do
          (c, r, w) <- get
          case typ of
              NodeCore ->
                  put (c + 1, r, w + 1) >> return (Just $ nextNtwrkAddr c addr, nextNtwrkAddr w waddr)
              NodeRelay ->
                  put (c, r + 1, w + 1) >> return (Just $ nextNtwrkAddr (r + 100) addr, nextNtwrkAddr w waddr)
              NodeEdge ->
                  put (c, r, w + 1) >> return (Nothing, nextNtwrkAddr w waddr)
        where
          -- NOTE Safe when called after 'withDefaultEnvironment'
          addr :: NetworkAddress
          addr = unsafeNetworkAddressFromString (env ! "LISTEN")
  
          -- NOTE Safe when called after 'withDefaultEnvironment'
          waddr :: NetworkAddress
          waddr = unsafeNetworkAddressFromString (env ! "NODE_API_ADDRESS")
  
      failT :: MonadFail m => Text -> m a
      failT = fail . toString
  
      withDefaultEnvironment :: Env -> Env
      withDefaultEnvironment env = env
          & at "CONFIGURATION_FILE" %~ (|> "lib/configuration.yaml")
          & at "CONFIGURATION_KEY"  %~ (|> "default")
          & at "DB_PATH"            ?~ (stateDir </> "db" </> nodeId)
          & at "LISTEN"             %~ (|> "127.0.0.1:3000")
          & at "LOG_SEVERITY"       %~ (|> "Debug")
          & at "NODE_ID"            ?~ nodeId
          & at "REBUILD_DB"         %~ (|> "True")
          & at "NO_CLIENT_AUTH"     %~ (|> "False")
          & at "NODE_API_ADDRESS"   %~ (|> "127.0.0.1:8080")
  
      -- | Generate secrets keys from a genesis configuration
      -- NOTE 'genesis-key' and 'keyfile' can't be overidden by ENV vars
      prepareGenesis :: Env -> (Artifact Genesis (), Env)
      prepareGenesis env =
          let
              keysPath :: FilePath
              keysPath =
                  stateDir </> "generated-keys"
  
              configOpts :: ConfigurationOptions
              configOpts = ConfigurationOptions
                  { cfoFilePath    = env ! "CONFIGURATION_FILE"
                  , cfoKey         = toText (env ! "CONFIGURATION_KEY")
                  , cfoSystemStart = Just 0
                  , cfoSeed        = Nothing
                  }
  
              getGeneratedSecrets :: ConfigurationOptions -> IO GeneratedSecrets
              getGeneratedSecrets opts = fst <$>
                  ( usingNamedPureLogger "_"
                      $ withConfigurations noTrace Nothing Nothing False opts
                      $ \config _ _ _ -> configGeneratedSecretsThrow config
                  )
  
              writeUserSecret :: UserSecret -> IO ()
              writeUserSecret secret = do
                  createDirectoryIfMissing True (takeDirectory $ secret ^. usPath)
                  UserSecret.writeRaw secret
  
              initGenesis :: IO ()
              initGenesis = do
                  gs <- getGeneratedSecrets configOpts
  
                  let nRich = length $ gsRichSecrets gs
                  let nCore = length $ filter isCoreNode nodes
                  when (nRich < nCore) $ throwM (NotEnoughCoreNodes nRich nCore)
  
                  indexedForM_ (gsDlgIssuersSecrets gs) $ \(sk, i) -> writeUserSecret $ defaultUserSecret
                      & usPrimKey ?~ sk
                      & usPath    .~ keysPath </> "dlg-issuers" </> (show i <> ".key")
  
                  indexedForM_ (gsRichSecrets gs) $ \(rs, i) -> writeUserSecret $ defaultUserSecret
                      & usPrimKey ?~ rsPrimaryKey rs
                      & usVss     ?~ rsVssKeyPair rs
                      & usPath    .~ keysPath </> "rich" </> (show i <> ".key")
  
                  indexedForM_ (gsPoorSecrets gs) $ \(ps, i) -> do
                      writeUserSecret $ defaultUserSecret
                          & usKeys    %~ (poorSecretToEncKey ps :)
                          & usWallet  ?~ mkGenesisWalletUserSecret (poorSecretToEncKey ps)
                          & usPath    .~ keysPath </> "poor" </> (show i <> ".key")
  
              irrelevant =
                  "Attempted to initialize genesis environment for a non-core node. \
                  \This is seemingly irrelevant: only core nodes do validation and \
                  \require such environment."
  
          in
              case nodeType of
                  NodeCore ->
                      ( Artifact () initGenesis
                      , env & at "KEYFILE" ?~ keysPath </> "rich" </> (show cIndex <> ".key")
                      )
  
                  _ ->
                      ( Artifact (error irrelevant) (failT irrelevant)
                      , env
                      )
  
      -- | Create the 'Topology' of the given node
      -- NOTE: The topology can't be overriden by ENV vars.
      prepareTopology :: Env -> (Artifact Topology (), Env)
      prepareTopology env =
          let
              topologyPath :: FilePath
              topologyPath =
                  stateDir </> "topology" </> T.unpack nodeIdT <> ".json"
  
              (listenAddrs :: [Maybe NetworkAddress], apiAddrs :: [NetworkAddress]) =
                  unzip $ nodeAddrs env
  
              topology :: Topology
              topology =
                  case nodeType of
                      NodeEdge -> demoTopologyBehindNAT
                          $ map (\(a, _, Just c) -> (a, c)) -- Safe, no edges
                          $ filter isRelayNode
                          $ zip3 nodeNames nodeTypes listenAddrs
  
                      _ -> demoTopologyStatic
                          $ map (\(a, b, Just c) -> (a, b, c)) -- Safe, no edges
                          $ filter (not . isEdgeNode)
                          $ zip3 nodeNames nodeTypes listenAddrs
  
              initTopology :: IO ()
              initTopology = do
                  createDirectoryIfMissing True (takeDirectory topologyPath)
                  BL.writeFile topologyPath (Aeson.encode topology)
          in
              ( Artifact topology initTopology
              , env
                  & at "LISTEN"             .~ (ntwrkAddrToString <$> listenAddrs !! cIndex)
                  & at "TOPOLOGY"           ?~ topologyPath
                  & at "NODE_API_ADDRESS"   ?~ (ntwrkAddrToString $ apiAddrs !! cIndex)
                  & at "NODE_DOC_ADDRESS"   ?~ (ntwrkAddrToString $ nextNtwrkAddr 100 (apiAddrs !! cIndex))
              )
  
  
      -- | Create a 'LoggerConfig' for the given node
      -- NOTE: The 'LoggerConfig' can't be overriden by ENV vars, however,
      -- the severity can be adjusted with an extra env var 'LOG_SEVERITY'
      prepareLogger :: Env -> (Artifact LoggerConfig (), Env)
      prepareLogger env =
          let
              loggerConfigPath =
                  stateDir </> "logs" </> nodeId <> ".json"
  
              logFilePath =
                  stateDir </> "logs" </> nodeId <> ".log.pub"
  
              logSeverity =
                  -- NOTE Safe when called after 'withDefaultEnvironment'
                  unsafeSeverityFromString (env ! "LOG_SEVERITY")
  
              -- NOTE 1:
              -- Unfortunately, it appears that JSON instances of types from
              -- 'Pos.Util.Log.LoggerConfig' don't have the roundtrip property.
              -- Therefore, trying to parse a file generated from encoding a
              -- 'LoggerType' is hopeless.
              -- The representations don't match.
              loggerConfigJSON = object
                  [ "rotation" .= object
                      [ "logLimit"  .= (104857600 :: Word64)
                      , "keepFiles" .= (1 :: Word)
                      ]
                  , "loggerTree" .= object
                      [ "severity" .= logSeverity
                      , "files"    .= [ logFilePath ]
                      ]
                  ]
  
              -- NOTE 'fromJust' is safe because we are making a valid JSON by hand.
              loggerConfig =
                  fromJust $ Aeson.parseMaybe Aeson.parseJSON $ loggerConfigJSON
  
              initLoggerConfig = do
                  createDirectoryIfMissing True (takeDirectory loggerConfigPath)
                  BL.writeFile loggerConfigPath (Aeson.encode loggerConfigJSON)
          in
              ( Artifact loggerConfig initLoggerConfig
              , env
                  & at "LOG_CONFIG"   ?~ loggerConfigPath
                  & at "LOG_SEVERITY" .~ Nothing
              )
  
      -- | Create TLS Certificates configurations
      -- NOTE: The TLS configurations & certs can't be overriden by ENV vars.
      prepareTLS :: Env -> (Artifact TlsParams Manager, Env)
      prepareTLS env =
          let
              noClientAuth =
                  -- NOTE Safe when called after 'withDefaultEnvironment'
                  unsafeBoolFromString (env ! "NO_CLIENT_AUTH")
  
              (_, (host, port)) =
                  nodeAddrs env !! cIndex
  
              tlsBasePath =
                  stateDir </> "tls" </> nodeId
  
              tlsParams = TlsParams
                  { tpCertPath   = tlsBasePath </> "server.crt"
                  , tpKeyPath    = tlsBasePath </> "server.key"
                  , tpCaPath     = tlsBasePath </> "ca.crt"
                  , tpClientAuth = not noClientAuth
                  }
  
              (tlsConf, dirConf) =
                  demoTLSConfiguration tlsBasePath
  
              initTLSEnvironment = do
                  keys <- genRSA256KeyPair
                  let (ca, cs) = fromConfiguration tlsConf dirConf genRSA256KeyPair keys
                  (_, caCert) <- genCertificate ca
                  -- NOTE Safe since we know there's at least one client cert
                  clients <- forM cs $ \c -> do
                      createDirectoryIfMissing True (certOutDir c)
                      (key, cert) <- genCertificate c
                      writeCredentials (certOutDir c </> certFilename c) (key, cert)
                      writeCertificate (certOutDir c </> certFilename ca) caCert
  
                      if isClientCertificate cert then do
                          let credentials = (CertificateChain [cert], PrivKeyRSA key)
                          let serverId = (B8.unpack host, B8.pack $ show port)
                          Just <$> newManager (mkHttpsManagerSettings serverId [caCert] credentials)
                      else
                          return Nothing
                  return $ Prelude.head $ catMaybes clients
          in
              ( Artifact tlsParams initTLSEnvironment
              , env
                  & at "TLSCERT" ?~ tpCertPath tlsParams
                  & at "TLSKEY"  ?~ tpKeyPath tlsParams
                  & at "TLSCA"   ?~ tpCaPath tlsParams
              )
  
  
  -- | Demo TLS Configuration
  demoTLSConfiguration
      :: FilePath -- ^ Directory to output TLS stuff
      -> (TLSConfiguration, DirConfiguration)
  demoTLSConfiguration dir =
      ( TLSConfiguration
          { tlsCa = CertConfiguration
              { certOrganization = "IOHK - Demo"
              , certCommonName   = "Root Self-Signed CA"
              , certExpiryDays   = 365
              }
          , tlsServer = ServerConfiguration
              { serverAltNames      = "localhost" :| [ "127.0.0.1" ]
              , serverConfiguration = CertConfiguration
                  { certOrganization = "IOHK - Demo"
                  , certCommonName   = "Server Certificate"
                  , certExpiryDays   = 365
                  }
              }
          , tlsClients = pure CertConfiguration
              { certOrganization = "IOHK - Demo"
              , certCommonName   = "Client Certificate"
              , certExpiryDays   = 365
              }
          }
      , DirConfiguration
          { outDirServer  = dir
          , outDirClients = dir
          , outDirCA      = Just dir
          }
      )
  
  
  demoTopologyStatic
      :: [(NodeName, NodeType, NetworkAddress)] -- List of all static peers
      -> Topology
  demoTopologyStatic =
      TopologyStatic . mkStaticRoutes
    where
      mkStaticRoutes
          :: [(NodeName, NodeType, NetworkAddress)]
          -> AllStaticallyKnownPeers
      mkStaticRoutes =
          AllStaticallyKnownPeers . Map.fromList . map mkStaticPeer . rotations
  
      mkStaticPeer
          :: ((NodeName, NodeType, NetworkAddress), [(NodeName, NodeType, NetworkAddress)])
          -> (NodeName, NodeMetadata)
      mkStaticPeer ((peerId, peerType, peerAddr), routes) =
          (peerId, mkStaticMetadata peerType peerAddr (mkRoutes routes))
  
      mkRoutes
          :: [(NodeName, NodeType, NetworkAddress)]
          -> NodeRoutes
      mkRoutes =
          NodeRoutes . map (pure . (^. _1))
  
      mkStaticMetadata
          :: NodeType
          -> NetworkAddress
          -> NodeRoutes
          -> NodeMetadata
      mkStaticMetadata nType (addr, port) routes = NodeMetadata
          { nmType       = nType
          , nmRegion     = NodeRegion "undefined"
          , nmRoutes     = routes
          , nmSubscribe  = DnsDomains []
          , nmValency    = 1
          , nmFallbacks  = 1
          , nmAddress    = ntwrkAddrToNodeAddr (addr, port)
          , nmKademlia   = False
          , nmPublicDNS  = False
          , nmMaxSubscrs = BucketSizeUnlimited
          }
  
  
  -- | Create a default topology file structure for the corresponding node behind NAT
  -- (typically, edge nodes)
  demoTopologyBehindNAT
      :: [(NodeName, NetworkAddress)] -- List of relays it is connected to
      -> Topology
  demoTopologyBehindNAT =
      TopologyBehindNAT 1 1 . mkRelays
    where
      mkRelays
          :: [(NodeName, NetworkAddress)]
          -> DnsDomains a
      mkRelays =
          DnsDomains . pure . map (ntwrkAddrToNodeAddr . snd)
  
  
  --
  -- (Internal) Helpers
  --
  
  data NotEnoughCoreNodes = NotEnoughCoreNodes
      { nKeys  :: Int
      , nNodes :: Int
      } deriving (Show)
  
  instance Exception NotEnoughCoreNodes where
      displayException = toString . sformat build
  
  instance Buildable NotEnoughCoreNodes where
      build e = bprint
          ("not enough rich keys ("%build%" keys) in provided configuration \
          \to cover for all Core nodes (" %build%" nodes).")
          (nKeys e)
          (nNodes e)
  
  
  -- | Tell whether a tuple identifies a Core node
  isCoreNode
      :: Field2 t t NodeType NodeType
      => t
      -> Bool
  isCoreNode =
      (== NodeCore) . (^. _2)
  
  
  -- | Tell whether a tuple identifies a Relay node
  isRelayNode
      :: Field2 t t NodeType NodeType
      => t
      -> Bool
  isRelayNode =
      (== NodeRelay) . (^. _2)
  
  
  -- | Tell whether a tuple identifies an Edge node
  isEdgeNode
      :: Field2 t t NodeType NodeType
      => t
      -> Bool
  isEdgeNode =
      (== NodeEdge) . (^. _2)
  