{-# LANGUAGE DuplicateRecordFields #-}

-- | A `NetworkComponent` that handles authentication of sent and received messages.
--
-- This "middleware" uses `HydraKey` keys for signing own messages and verifying
-- others', providing `Authenticated` messages to consumers.
module Hydra.Network.Authenticate where

import Cardano.Crypto.Util (SignableRepresentation)
import Control.Tracer (Tracer)
import Data.Aeson (Options (tagSingleConstructors), defaultOptions, genericToJSON)
import Data.Aeson qualified as Aeson
import Hydra.Logging (traceWith)
import Hydra.Network (Network (Network, broadcast), NetworkCallback (..), NetworkComponent)
import Hydra.Prelude
import Hydra.Tx (Party (Party, vkey), deriveParty)
import Hydra.Tx.Crypto (HydraKey, Signature, SigningKey, sign, verify)
import Hydra.Tx.Secret (Secret)

-- | Represents a signed message over the network.
-- Becomes valid once its receivers verify it against its other peers
-- verification keys.
-- Messages are signed and turned into authenticated messages before
-- broadcasting them to other peers.
data Signed msg = Signed
  { forall msg. Signed msg -> msg
payload :: msg
  , forall msg. Signed msg -> Signature msg
signature :: Signature msg
  , forall msg. Signed msg -> Party
party :: Party
  }
  deriving stock (Signed msg -> Signed msg -> Bool
(Signed msg -> Signed msg -> Bool)
-> (Signed msg -> Signed msg -> Bool) -> Eq (Signed msg)
forall msg. Eq msg => Signed msg -> Signed msg -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall msg. Eq msg => Signed msg -> Signed msg -> Bool
== :: Signed msg -> Signed msg -> Bool
$c/= :: forall msg. Eq msg => Signed msg -> Signed msg -> Bool
/= :: Signed msg -> Signed msg -> Bool
Eq, Int -> Signed msg -> ShowS
[Signed msg] -> ShowS
Signed msg -> String
(Int -> Signed msg -> ShowS)
-> (Signed msg -> String)
-> ([Signed msg] -> ShowS)
-> Show (Signed msg)
forall msg. Show msg => Int -> Signed msg -> ShowS
forall msg. Show msg => [Signed msg] -> ShowS
forall msg. Show msg => Signed msg -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall msg. Show msg => Int -> Signed msg -> ShowS
showsPrec :: Int -> Signed msg -> ShowS
$cshow :: forall msg. Show msg => Signed msg -> String
show :: Signed msg -> String
$cshowList :: forall msg. Show msg => [Signed msg] -> ShowS
showList :: [Signed msg] -> ShowS
Show, (forall x. Signed msg -> Rep (Signed msg) x)
-> (forall x. Rep (Signed msg) x -> Signed msg)
-> Generic (Signed msg)
forall x. Rep (Signed msg) x -> Signed msg
forall x. Signed msg -> Rep (Signed msg) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall msg x. Rep (Signed msg) x -> Signed msg
forall msg x. Signed msg -> Rep (Signed msg) x
$cfrom :: forall msg x. Signed msg -> Rep (Signed msg) x
from :: forall x. Signed msg -> Rep (Signed msg) x
$cto :: forall msg x. Rep (Signed msg) x -> Signed msg
to :: forall x. Rep (Signed msg) x -> Signed msg
Generic)

data Authenticated msg = Authenticated
  { forall msg. Authenticated msg -> msg
payload :: msg
  , forall msg. Authenticated msg -> Party
party :: Party
  }
  deriving stock (Authenticated msg -> Authenticated msg -> Bool
(Authenticated msg -> Authenticated msg -> Bool)
-> (Authenticated msg -> Authenticated msg -> Bool)
-> Eq (Authenticated msg)
forall msg.
Eq msg =>
Authenticated msg -> Authenticated msg -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall msg.
Eq msg =>
Authenticated msg -> Authenticated msg -> Bool
== :: Authenticated msg -> Authenticated msg -> Bool
$c/= :: forall msg.
Eq msg =>
Authenticated msg -> Authenticated msg -> Bool
/= :: Authenticated msg -> Authenticated msg -> Bool
Eq, Int -> Authenticated msg -> ShowS
[Authenticated msg] -> ShowS
Authenticated msg -> String
(Int -> Authenticated msg -> ShowS)
-> (Authenticated msg -> String)
-> ([Authenticated msg] -> ShowS)
-> Show (Authenticated msg)
forall msg. Show msg => Int -> Authenticated msg -> ShowS
forall msg. Show msg => [Authenticated msg] -> ShowS
forall msg. Show msg => Authenticated msg -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall msg. Show msg => Int -> Authenticated msg -> ShowS
showsPrec :: Int -> Authenticated msg -> ShowS
$cshow :: forall msg. Show msg => Authenticated msg -> String
show :: Authenticated msg -> String
$cshowList :: forall msg. Show msg => [Authenticated msg] -> ShowS
showList :: [Authenticated msg] -> ShowS
Show, (forall x. Authenticated msg -> Rep (Authenticated msg) x)
-> (forall x. Rep (Authenticated msg) x -> Authenticated msg)
-> Generic (Authenticated msg)
forall x. Rep (Authenticated msg) x -> Authenticated msg
forall x. Authenticated msg -> Rep (Authenticated msg) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall msg x. Rep (Authenticated msg) x -> Authenticated msg
forall msg x. Authenticated msg -> Rep (Authenticated msg) x
$cfrom :: forall msg x. Authenticated msg -> Rep (Authenticated msg) x
from :: forall x. Authenticated msg -> Rep (Authenticated msg) x
$cto :: forall msg x. Rep (Authenticated msg) x -> Authenticated msg
to :: forall x. Rep (Authenticated msg) x -> Authenticated msg
Generic)

instance ToCBOR msg => ToCBOR (Signed msg) where
  toCBOR :: Signed msg -> Encoding
toCBOR = Signed msg -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

instance FromCBOR msg => FromCBOR (Signed msg) where
  fromCBOR :: forall s. Decoder s (Signed msg)
fromCBOR = Decoder s (Signed msg)
forall a s. (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR

-- | Middleware used to sign messages before broadcasting them to other peers
-- and verify signed messages upon receiving.
-- Only verified messages are pushed downstream to the internal network for the
-- node to consume and process. Non-verified messages get discarded.
withAuthentication ::
  ( SignableRepresentation inbound
  , ToJSON inbound
  , SignableRepresentation outbound
  ) =>
  Tracer m AuthLog ->
  -- The party signing key
  Secret (SigningKey HydraKey) ->
  -- Other party members
  [Party] ->
  -- The underlying raw network.
  NetworkComponent m (Signed inbound) (Signed outbound) a ->
  -- The node internal authenticated network.
  NetworkComponent m (Authenticated inbound) outbound a
withAuthentication :: forall inbound outbound (m :: * -> *) a.
(SignableRepresentation inbound, ToJSON inbound,
 SignableRepresentation outbound) =>
Tracer m AuthLog
-> Secret (SigningKey HydraKey)
-> [Party]
-> NetworkComponent m (Signed inbound) (Signed outbound) a
-> NetworkComponent m (Authenticated inbound) outbound a
withAuthentication Tracer m AuthLog
tracer Secret (SigningKey HydraKey)
signingKey [Party]
parties NetworkComponent m (Signed inbound) (Signed outbound) a
withRawNetwork NetworkCallback{Authenticated inbound -> m ()
deliver :: Authenticated inbound -> m ()
$sel:deliver:NetworkCallback :: forall msg (m :: * -> *). NetworkCallback msg m -> msg -> m ()
deliver, Connectivity -> m ()
onConnectivity :: Connectivity -> m ()
$sel:onConnectivity:NetworkCallback :: forall msg (m :: * -> *).
NetworkCallback msg m -> Connectivity -> m ()
onConnectivity} Network m outbound -> m a
action = do
  NetworkComponent m (Signed inbound) (Signed outbound) a
withRawNetwork NetworkCallback{$sel:deliver:NetworkCallback :: Signed inbound -> m ()
deliver = Signed inbound -> m ()
checkSignature, Connectivity -> m ()
onConnectivity :: Connectivity -> m ()
$sel:onConnectivity:NetworkCallback :: Connectivity -> m ()
onConnectivity} Network m (Signed outbound) -> m a
authenticate
 where
  checkSignature :: Signed inbound -> m ()
checkSignature (Signed inbound
msg Signature inbound
sig party :: Party
party@Party{$sel:vkey:Party :: Party -> VerificationKey HydraKey
vkey = VerificationKey HydraKey
partyVkey}) =
    if VerificationKey HydraKey -> Signature inbound -> inbound -> Bool
forall a.
SignableRepresentation a =>
VerificationKey HydraKey -> Signature a -> a -> Bool
verify VerificationKey HydraKey
partyVkey Signature inbound
sig inbound
msg Bool -> Bool -> Bool
&& Party
party Party -> [Party] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Party]
allParties
      then Authenticated inbound -> m ()
deliver (Authenticated inbound -> m ()) -> Authenticated inbound -> m ()
forall a b. (a -> b) -> a -> b
$ inbound -> Party -> Authenticated inbound
forall msg. msg -> Party -> Authenticated msg
Authenticated inbound
msg Party
party
      else Tracer m AuthLog -> AuthLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m AuthLog
tracer (inbound -> Signature inbound -> Party -> AuthLog
forall msg signature.
(ToJSON msg, Show signature) =>
msg -> signature -> Party -> AuthLog
mkAuthLog inbound
msg Signature inbound
sig Party
party)

  me :: Party
me = Secret (SigningKey HydraKey) -> Party
deriveParty Secret (SigningKey HydraKey)
signingKey

  allParties :: [Party]
allParties = Party
me Party -> [Party] -> [Party]
forall a. a -> [a] -> [a]
: [Party]
parties

  authenticate :: Network m (Signed outbound) -> m a
authenticate Network{Signed outbound -> m ()
$sel:broadcast:Network :: forall (m :: * -> *) msg. Network m msg -> msg -> m ()
broadcast :: Signed outbound -> m ()
broadcast} =
    Network m outbound -> m a
action (Network m outbound -> m a) -> Network m outbound -> m a
forall a b. (a -> b) -> a -> b
$
      Network
        { $sel:broadcast:Network :: outbound -> m ()
broadcast = \outbound
msg ->
            Signed outbound -> m ()
broadcast (outbound -> Signature outbound -> Party -> Signed outbound
forall msg. msg -> Signature msg -> Party -> Signed msg
Signed outbound
msg (Secret (SigningKey HydraKey) -> outbound -> Signature outbound
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
signingKey outbound
msg) Party
me)
        }

-- | Smart constructor for 'MessageDropped'
mkAuthLog :: (ToJSON msg, Show signature) => msg -> signature -> Party -> AuthLog
mkAuthLog :: forall msg signature.
(ToJSON msg, Show signature) =>
msg -> signature -> Party -> AuthLog
mkAuthLog msg
message signature
signature Party
party =
  MessageDropped
    { $sel:message:MessageDropped :: Text
message = ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ msg -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode msg
message
    , $sel:signature:MessageDropped :: Text
signature = signature -> Text
forall b a. (Show a, IsString b) => a -> b
show signature
signature
    , Party
party :: Party
$sel:party:MessageDropped :: Party
party
    }

data AuthLog = MessageDropped {AuthLog -> Text
message :: Text, AuthLog -> Text
signature :: Text, AuthLog -> Party
party :: Party}
  deriving stock (AuthLog -> AuthLog -> Bool
(AuthLog -> AuthLog -> Bool)
-> (AuthLog -> AuthLog -> Bool) -> Eq AuthLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AuthLog -> AuthLog -> Bool
== :: AuthLog -> AuthLog -> Bool
$c/= :: AuthLog -> AuthLog -> Bool
/= :: AuthLog -> AuthLog -> Bool
Eq, Int -> AuthLog -> ShowS
[AuthLog] -> ShowS
AuthLog -> String
(Int -> AuthLog -> ShowS)
-> (AuthLog -> String) -> ([AuthLog] -> ShowS) -> Show AuthLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AuthLog -> ShowS
showsPrec :: Int -> AuthLog -> ShowS
$cshow :: AuthLog -> String
show :: AuthLog -> String
$cshowList :: [AuthLog] -> ShowS
showList :: [AuthLog] -> ShowS
Show, (forall x. AuthLog -> Rep AuthLog x)
-> (forall x. Rep AuthLog x -> AuthLog) -> Generic AuthLog
forall x. Rep AuthLog x -> AuthLog
forall x. AuthLog -> Rep AuthLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. AuthLog -> Rep AuthLog x
from :: forall x. AuthLog -> Rep AuthLog x
$cto :: forall x. Rep AuthLog x -> AuthLog
to :: forall x. Rep AuthLog x -> AuthLog
Generic)
  deriving anyclass (Maybe AuthLog
Value -> Parser [AuthLog]
Value -> Parser AuthLog
(Value -> Parser AuthLog)
-> (Value -> Parser [AuthLog]) -> Maybe AuthLog -> FromJSON AuthLog
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser AuthLog
parseJSON :: Value -> Parser AuthLog
$cparseJSONList :: Value -> Parser [AuthLog]
parseJSONList :: Value -> Parser [AuthLog]
$comittedField :: Maybe AuthLog
omittedField :: Maybe AuthLog
FromJSON)

-- NOTE: we make an explicit instance here because the default derivation
-- from Generic does not add a tag for single constructor data types or newtypes.
-- Without the tag, the message is pretty cryptic in the logs
instance ToJSON AuthLog where
  toJSON :: AuthLog -> Value
toJSON = Options -> AuthLog -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
defaultOptions{tagSingleConstructors = True}