{-# 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, Key (SigningKey), Signature, sign, verify)

-- | 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)
  deriving anyclass ([Signed msg] -> Value
[Signed msg] -> Encoding
Signed msg -> Bool
Signed msg -> Value
Signed msg -> Encoding
(Signed msg -> Value)
-> (Signed msg -> Encoding)
-> ([Signed msg] -> Value)
-> ([Signed msg] -> Encoding)
-> (Signed msg -> Bool)
-> ToJSON (Signed msg)
forall msg. ToJSON msg => [Signed msg] -> Value
forall msg. ToJSON msg => [Signed msg] -> Encoding
forall msg. ToJSON msg => Signed msg -> Bool
forall msg. ToJSON msg => Signed msg -> Value
forall msg. ToJSON msg => Signed msg -> Encoding
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: forall msg. ToJSON msg => Signed msg -> Value
toJSON :: Signed msg -> Value
$ctoEncoding :: forall msg. ToJSON msg => Signed msg -> Encoding
toEncoding :: Signed msg -> Encoding
$ctoJSONList :: forall msg. ToJSON msg => [Signed msg] -> Value
toJSONList :: [Signed msg] -> Value
$ctoEncodingList :: forall msg. ToJSON msg => [Signed msg] -> Encoding
toEncodingList :: [Signed msg] -> Encoding
$comitField :: forall msg. ToJSON msg => Signed msg -> Bool
omitField :: Signed msg -> Bool
ToJSON, Maybe (Signed msg)
Value -> Parser [Signed msg]
Value -> Parser (Signed msg)
(Value -> Parser (Signed msg))
-> (Value -> Parser [Signed msg])
-> Maybe (Signed msg)
-> FromJSON (Signed msg)
forall msg. FromJSON msg => Maybe (Signed msg)
forall msg. FromJSON msg => Value -> Parser [Signed msg]
forall msg. FromJSON msg => Value -> Parser (Signed msg)
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: forall msg. FromJSON msg => Value -> Parser (Signed msg)
parseJSON :: Value -> Parser (Signed msg)
$cparseJSONList :: forall msg. FromJSON msg => Value -> Parser [Signed msg]
parseJSONList :: Value -> Parser [Signed msg]
$comittedField :: forall msg. FromJSON msg => Maybe (Signed msg)
omittedField :: Maybe (Signed msg)
FromJSON)

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)
  deriving anyclass ([Authenticated msg] -> Value
[Authenticated msg] -> Encoding
Authenticated msg -> Bool
Authenticated msg -> Value
Authenticated msg -> Encoding
(Authenticated msg -> Value)
-> (Authenticated msg -> Encoding)
-> ([Authenticated msg] -> Value)
-> ([Authenticated msg] -> Encoding)
-> (Authenticated msg -> Bool)
-> ToJSON (Authenticated msg)
forall msg. ToJSON msg => [Authenticated msg] -> Value
forall msg. ToJSON msg => [Authenticated msg] -> Encoding
forall msg. ToJSON msg => Authenticated msg -> Bool
forall msg. ToJSON msg => Authenticated msg -> Value
forall msg. ToJSON msg => Authenticated msg -> Encoding
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: forall msg. ToJSON msg => Authenticated msg -> Value
toJSON :: Authenticated msg -> Value
$ctoEncoding :: forall msg. ToJSON msg => Authenticated msg -> Encoding
toEncoding :: Authenticated msg -> Encoding
$ctoJSONList :: forall msg. ToJSON msg => [Authenticated msg] -> Value
toJSONList :: [Authenticated msg] -> Value
$ctoEncodingList :: forall msg. ToJSON msg => [Authenticated msg] -> Encoding
toEncodingList :: [Authenticated msg] -> Encoding
$comitField :: forall msg. ToJSON msg => Authenticated msg -> Bool
omitField :: Authenticated msg -> Bool
ToJSON, Maybe (Authenticated msg)
Value -> Parser [Authenticated msg]
Value -> Parser (Authenticated msg)
(Value -> Parser (Authenticated msg))
-> (Value -> Parser [Authenticated msg])
-> Maybe (Authenticated msg)
-> FromJSON (Authenticated msg)
forall msg. FromJSON msg => Maybe (Authenticated msg)
forall msg. FromJSON msg => Value -> Parser [Authenticated msg]
forall msg. FromJSON msg => Value -> Parser (Authenticated msg)
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: forall msg. FromJSON msg => Value -> Parser (Authenticated msg)
parseJSON :: Value -> Parser (Authenticated msg)
$cparseJSONList :: forall msg. FromJSON msg => Value -> Parser [Authenticated msg]
parseJSONList :: Value -> Parser [Authenticated msg]
$comittedField :: forall msg. FromJSON msg => Maybe (Authenticated msg)
omittedField :: Maybe (Authenticated msg)
FromJSON)

instance (Arbitrary msg, SignableRepresentation msg) => Arbitrary (Signed msg) where
  arbitrary :: Gen (Signed msg)
arbitrary = Gen (Signed msg)
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
  shrink :: Signed msg -> [Signed msg]
shrink = Signed msg -> [Signed msg]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink

instance ToCBOR msg => ToCBOR (Signed msg) where
  toCBOR :: Signed msg -> Encoding
toCBOR (Signed msg
msg Signature msg
sig Party
party) = msg -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR msg
msg Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Signature msg -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Signature msg
sig Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Party -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Party
party

instance FromCBOR msg => FromCBOR (Signed msg) where
  fromCBOR :: forall s. Decoder s (Signed msg)
fromCBOR = msg -> Signature msg -> Party -> Signed msg
forall msg. msg -> Signature msg -> Party -> Signed msg
Signed (msg -> Signature msg -> Party -> Signed msg)
-> Decoder s msg
-> Decoder s (Signature msg -> Party -> Signed msg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s msg
forall s. Decoder s msg
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (Signature msg -> Party -> Signed msg)
-> Decoder s (Signature msg) -> Decoder s (Party -> Signed msg)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (Signature msg)
forall s. Decoder s (Signature msg)
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (Party -> Signed msg)
-> Decoder s Party -> Decoder s (Signed msg)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s Party
forall s. Decoder s Party
forall a s. FromCBOR a => Decoder s a
fromCBOR

-- | 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
  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
-> SigningKey HydraKey
-> [Party]
-> NetworkComponent m (Signed inbound) (Signed outbound) a
-> NetworkComponent m (Authenticated inbound) outbound a
withAuthentication Tracer m AuthLog
tracer 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} 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} 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] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
elem Party
party [Party]
parties
      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 = SigningKey HydraKey -> Party
deriveParty SigningKey HydraKey
signingKey

  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 (SigningKey HydraKey -> outbound -> Signature outbound
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign 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}

instance Arbitrary AuthLog where
  arbitrary :: Gen AuthLog
arbitrary = Gen AuthLog
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
  shrink :: AuthLog -> [AuthLog]
shrink = AuthLog -> [AuthLog]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink