{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE NoFieldSelectors #-}

module Cardano.Rpc.Server.Config
  ( RpcConfig
  , PartialRpcConfig
  , RpcConfigF (..)
  , RpcEndpoint (..)
  , RpcTlsFiles (..)
  , TlsCertificate
  , TlsPrivateKey
  , defaultRpcListenAddress
  , makeRpcConfig
  , nodeSocketPathToRpcSocketPath
  )
where

import Cardano.Api

import RIO

import Data.IP (IP)
import Data.Monoid
import Network.Socket (PortNumber)
import System.FilePath (takeDirectory, (</>))

import Generic.Data (gmappend, gmempty)

type PartialRpcConfig = RpcConfigF Last

type RpcConfig = RpcConfigF Identity

-- | RPC server configuration, which is a part of cardano-node configuration.
data RpcConfigF m = RpcConfig
  { forall (m :: * -> *). RpcConfigF m -> m Bool
isEnabled :: !(m Bool)
  -- ^ whether the RPC server is enabled
  , forall (m :: * -> *). RpcConfigF m -> m RpcEndpoint
rpcEndpoint :: !(m RpcEndpoint)
  -- ^ endpoint where the RPC server listens
  , forall (m :: * -> *). RpcConfigF m -> m SocketPath
nodeSocketPath :: !(m SocketPath)
  -- ^ cardano-node socket path. Only valid if RPC endpoint is enabled.
  }

deriving instance Show (RpcConfigF Identity)

deriving instance Eq (RpcConfigF Identity)

deriving instance Show (RpcConfigF Last)

deriving instance Eq (RpcConfigF Last)

deriving instance Generic (RpcConfigF Last)

instance Semigroup (RpcConfigF Last) where
  <> :: RpcConfigF Last -> RpcConfigF Last -> RpcConfigF Last
(<>) = RpcConfigF Last -> RpcConfigF Last -> RpcConfigF Last
forall a. (Generic a, Semigroup (Rep a ())) => a -> a -> a
gmappend

instance Monoid (RpcConfigF Last) where
  mempty :: RpcConfigF Last
mempty = RpcConfigF Last
forall a. (Generic a, Monoid (Rep a ())) => a
gmempty

-- | Endpoint the RPC server listens on. Exactly one listener is active at a
-- time.
data RpcEndpoint
  = RpcEndpointUnixSocket !SocketPath
  | -- | IP address and port of the HTTP/2 without TLS (h2c) listener.
    RpcEndpointHttp !IP !PortNumber
  | -- | IP address, port and TLS credential files of the HTTP/2 over TLS
    -- listener.
    RpcEndpointHttps !IP !PortNumber !RpcTlsFiles
  deriving (RpcEndpoint -> RpcEndpoint -> Bool
(RpcEndpoint -> RpcEndpoint -> Bool)
-> (RpcEndpoint -> RpcEndpoint -> Bool) -> Eq RpcEndpoint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RpcEndpoint -> RpcEndpoint -> Bool
== :: RpcEndpoint -> RpcEndpoint -> Bool
$c/= :: RpcEndpoint -> RpcEndpoint -> Bool
/= :: RpcEndpoint -> RpcEndpoint -> Bool
Eq, Int -> RpcEndpoint -> ShowS
[RpcEndpoint] -> ShowS
RpcEndpoint -> String
(Int -> RpcEndpoint -> ShowS)
-> (RpcEndpoint -> String)
-> ([RpcEndpoint] -> ShowS)
-> Show RpcEndpoint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RpcEndpoint -> ShowS
showsPrec :: Int -> RpcEndpoint -> ShowS
$cshow :: RpcEndpoint -> String
show :: RpcEndpoint -> String
$cshowList :: [RpcEndpoint] -> ShowS
showList :: [RpcEndpoint] -> ShowS
Show)

instance Pretty RpcEndpoint where
  pretty :: forall ann. RpcEndpoint -> Doc ann
pretty = \case
    RpcEndpointUnixSocket (File String
socketPath) -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
socketPath
    RpcEndpointHttp IP
host PortNumber
port -> IP -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow IP
host Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> PortNumber -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow PortNumber
port
    RpcEndpointHttps IP
host PortNumber
port RpcTlsFiles
_ -> IP -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow IP
host Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> PortNumber -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow PortNumber
port Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" (TLS)"

-- | TLS credential files for the RPC server, PEM format.
data RpcTlsFiles = RpcTlsFiles
  { RpcTlsFiles -> File TlsCertificate 'In
certificateFile :: !(File TlsCertificate In)
  -- ^ server X.509 certificate
  , RpcTlsFiles -> File TlsPrivateKey 'In
privateKeyFile :: !(File TlsPrivateKey In)
  -- ^ private key matching the certificate
  , RpcTlsFiles -> [File TlsCertificate 'In]
chainCertificateFiles :: ![File TlsCertificate In]
  -- ^ intermediate chain certificates, if any
  }
  deriving (RpcTlsFiles -> RpcTlsFiles -> Bool
(RpcTlsFiles -> RpcTlsFiles -> Bool)
-> (RpcTlsFiles -> RpcTlsFiles -> Bool) -> Eq RpcTlsFiles
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RpcTlsFiles -> RpcTlsFiles -> Bool
== :: RpcTlsFiles -> RpcTlsFiles -> Bool
$c/= :: RpcTlsFiles -> RpcTlsFiles -> Bool
/= :: RpcTlsFiles -> RpcTlsFiles -> Bool
Eq, Int -> RpcTlsFiles -> ShowS
[RpcTlsFiles] -> ShowS
RpcTlsFiles -> String
(Int -> RpcTlsFiles -> ShowS)
-> (RpcTlsFiles -> String)
-> ([RpcTlsFiles] -> ShowS)
-> Show RpcTlsFiles
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RpcTlsFiles -> ShowS
showsPrec :: Int -> RpcTlsFiles -> ShowS
$cshow :: RpcTlsFiles -> String
show :: RpcTlsFiles -> String
$cshowList :: [RpcTlsFiles] -> ShowS
showList :: [RpcTlsFiles] -> ShowS
Show)

-- | Empty content tag for 'File' identifying a TLS certificate file.
data TlsCertificate

-- | Empty content tag for 'File' identifying a TLS private key file.
data TlsPrivateKey

-- | Default IP address the HTTP/2 listener binds to when only a port is configured.
defaultRpcListenAddress :: IP
defaultRpcListenAddress :: IP
defaultRpcListenAddress = IP
"127.0.0.1"

-- | Build RPC Config
--
-- Uses the following defaults if the values are not provided
-- * RPC is disabled
-- * the endpoint is a unix socket, @rpc.sock@, placed in the same path as the node socket
--
-- Validates if the node socket is enabled if RPC is enabled.
makeRpcConfig
  :: MonadError String m
  => PartialRpcConfig
  -> m RpcConfig
makeRpcConfig :: forall (m :: * -> *).
MonadError String m =>
RpcConfigF Last -> m (RpcConfigF Identity)
makeRpcConfig
  RpcConfig
    { isEnabled :: forall (m :: * -> *). RpcConfigF m -> m Bool
isEnabled = Last Maybe Bool
mIsEnabled
    , rpcEndpoint :: forall (m :: * -> *). RpcConfigF m -> m RpcEndpoint
rpcEndpoint = Last Maybe RpcEndpoint
mRpcEndpoint
    , nodeSocketPath :: forall (m :: * -> *). RpcConfigF m -> m SocketPath
nodeSocketPath = Last Maybe SocketPath
mNodeSocketPath
    } = do
    let isEnabled :: Bool
isEnabled = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
mIsEnabled
        -- Default to a non-existing path. Irrelevant when the RPC server is disabled; when enabled, the validation below requires an explicit node socket path.
        nodeSocketPath :: SocketPath
nodeSocketPath = SocketPath -> Maybe SocketPath -> SocketPath
forall a. a -> Maybe a -> a
fromMaybe SocketPath
"./node.socket" Maybe SocketPath
mNodeSocketPath
        rpcEndpoint :: RpcEndpoint
rpcEndpoint = RpcEndpoint -> Maybe RpcEndpoint -> RpcEndpoint
forall a. a -> Maybe a -> a
fromMaybe (SocketPath -> RpcEndpoint
RpcEndpointUnixSocket (SocketPath -> RpcEndpoint) -> SocketPath -> RpcEndpoint
forall a b. (a -> b) -> a -> b
$ SocketPath -> SocketPath
nodeSocketPathToRpcSocketPath SocketPath
nodeSocketPath) Maybe RpcEndpoint
mRpcEndpoint
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isEnabled Bool -> Bool -> Bool
&& Maybe SocketPath -> Bool
forall a. Maybe a -> Bool
isNothing Maybe SocketPath
mNodeSocketPath) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      String -> m ()
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        String
"Configuration error: gRPC endpoint was enabled but node socket file was not specified. Cannot run gRPC server without node socket."
    RpcConfigF Identity -> m (RpcConfigF Identity)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      RpcConfig
        { isEnabled :: Identity Bool
isEnabled = Bool -> Identity Bool
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
isEnabled
        , rpcEndpoint :: Identity RpcEndpoint
rpcEndpoint = RpcEndpoint -> Identity RpcEndpoint
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RpcEndpoint
rpcEndpoint
        , nodeSocketPath :: Identity SocketPath
nodeSocketPath = SocketPath -> Identity SocketPath
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SocketPath
nodeSocketPath
        }

-- | Convert node socket path to a default rpc socket path.
-- By default it's @rpc.sock@ in the same directory as node socket path.
nodeSocketPathToRpcSocketPath :: SocketPath -> SocketPath
nodeSocketPathToRpcSocketPath :: SocketPath -> SocketPath
nodeSocketPathToRpcSocketPath SocketPath
nodeSocketPath = do
  let socketDir :: String
socketDir = ShowS
takeDirectory ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ SocketPath -> String
forall content (direction :: FileDirection).
File content direction -> String
unFile SocketPath
nodeSocketPath
  String -> SocketPath
forall content (direction :: FileDirection).
String -> File content direction
File (String -> SocketPath) -> String -> SocketPath
forall a b. (a -> b) -> a -> b
$ String
socketDir String -> ShowS
</> String
"rpc.sock"