{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Crypto.ProtocolMagic (
  ProtocolMagicId (..),
  ProtocolMagic,
  AProtocolMagic (..),
  RequiresNetworkMagic (..),
  getProtocolMagic,
  getProtocolMagicId,
)
where

import Cardano.Ledger.Binary (
  Annotated (..),
  DecCBOR (..),
  EncCBOR (..),
  FromCBOR (..),
  ToCBOR (..),
  decodeTag,
  encodeTag,
  fromByronCBOR,
  toByronCBOR,
 )
import Cardano.Prelude
import Control.Monad.Fail (fail)
import Data.Aeson ((.:), (.=))
import qualified Data.Aeson as A
import NoThunks.Class (NoThunks)
import Text.JSON.Canonical (FromJSON (..), JSValue (..), ToJSON (..), expected)

-- | Magic number which should differ for different clusters. It's
--   defined here, because it's used for signing. It also used for other
--   things (e. g. it's part of a serialized block).
--
-- mhueschen: As part of CO-353 I am adding `getRequiresNetworkMagic` in
-- order to pipe configuration to functions which must generate & verify
-- Addresses (which now must be aware of `NetworkMagic`).
type AProtocolMagic :: Type -> Type
data AProtocolMagic a = AProtocolMagic
  { forall a. AProtocolMagic a -> Annotated ProtocolMagicId a
getAProtocolMagicId :: !(Annotated ProtocolMagicId a)
  , forall a. AProtocolMagic a -> RequiresNetworkMagic
getRequiresNetworkMagic :: !RequiresNetworkMagic
  }
  deriving (AProtocolMagic a -> AProtocolMagic a -> Bool
forall a. Eq a => AProtocolMagic a -> AProtocolMagic a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AProtocolMagic a -> AProtocolMagic a -> Bool
$c/= :: forall a. Eq a => AProtocolMagic a -> AProtocolMagic a -> Bool
== :: AProtocolMagic a -> AProtocolMagic a -> Bool
$c== :: forall a. Eq a => AProtocolMagic a -> AProtocolMagic a -> Bool
Eq, Int -> AProtocolMagic a -> ShowS
forall a. Show a => Int -> AProtocolMagic a -> ShowS
forall a. Show a => [AProtocolMagic a] -> ShowS
forall a. Show a => AProtocolMagic a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AProtocolMagic a] -> ShowS
$cshowList :: forall a. Show a => [AProtocolMagic a] -> ShowS
show :: AProtocolMagic a -> String
$cshow :: forall a. Show a => AProtocolMagic a -> String
showsPrec :: Int -> AProtocolMagic a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> AProtocolMagic a -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (AProtocolMagic a) x -> AProtocolMagic a
forall a x. AProtocolMagic a -> Rep (AProtocolMagic a) x
$cto :: forall a x. Rep (AProtocolMagic a) x -> AProtocolMagic a
$cfrom :: forall a x. AProtocolMagic a -> Rep (AProtocolMagic a) x
Generic, forall a. NFData a => AProtocolMagic a -> ()
forall a. (a -> ()) -> NFData a
rnf :: AProtocolMagic a -> ()
$crnf :: forall a. NFData a => AProtocolMagic a -> ()
NFData, forall a.
NoThunks a =>
Context -> AProtocolMagic a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Proxy (AProtocolMagic a) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (AProtocolMagic a) -> String
$cshowTypeOf :: forall a. NoThunks a => Proxy (AProtocolMagic a) -> String
wNoThunks :: Context -> AProtocolMagic a -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall a.
NoThunks a =>
Context -> AProtocolMagic a -> IO (Maybe ThunkInfo)
noThunks :: Context -> AProtocolMagic a -> IO (Maybe ThunkInfo)
$cnoThunks :: forall a.
NoThunks a =>
Context -> AProtocolMagic a -> IO (Maybe ThunkInfo)
NoThunks)

type ProtocolMagic :: Type
type ProtocolMagic = AProtocolMagic ()

type ProtocolMagicId :: Type
newtype ProtocolMagicId = ProtocolMagicId
  { ProtocolMagicId -> Word32
unProtocolMagicId :: Word32
  }
  deriving (Int -> ProtocolMagicId -> ShowS
[ProtocolMagicId] -> ShowS
ProtocolMagicId -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProtocolMagicId] -> ShowS
$cshowList :: [ProtocolMagicId] -> ShowS
show :: ProtocolMagicId -> String
$cshow :: ProtocolMagicId -> String
showsPrec :: Int -> ProtocolMagicId -> ShowS
$cshowsPrec :: Int -> ProtocolMagicId -> ShowS
Show, ProtocolMagicId -> ProtocolMagicId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProtocolMagicId -> ProtocolMagicId -> Bool
$c/= :: ProtocolMagicId -> ProtocolMagicId -> Bool
== :: ProtocolMagicId -> ProtocolMagicId -> Bool
$c== :: ProtocolMagicId -> ProtocolMagicId -> Bool
Eq, forall x. Rep ProtocolMagicId x -> ProtocolMagicId
forall x. ProtocolMagicId -> Rep ProtocolMagicId x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ProtocolMagicId x -> ProtocolMagicId
$cfrom :: forall x. ProtocolMagicId -> Rep ProtocolMagicId x
Generic)
  deriving newtype (Typeable ProtocolMagicId
Proxy ProtocolMagicId -> Text
forall s. Decoder s ProtocolMagicId
forall a.
Typeable a
-> (forall s. Decoder s a)
-> (forall s. Proxy a -> Decoder s ())
-> (Proxy a -> Text)
-> DecCBOR a
forall s. Proxy ProtocolMagicId -> Decoder s ()
label :: Proxy ProtocolMagicId -> Text
$clabel :: Proxy ProtocolMagicId -> Text
dropCBOR :: forall s. Proxy ProtocolMagicId -> Decoder s ()
$cdropCBOR :: forall s. Proxy ProtocolMagicId -> Decoder s ()
decCBOR :: forall s. Decoder s ProtocolMagicId
$cdecCBOR :: forall s. Decoder s ProtocolMagicId
DecCBOR, Typeable ProtocolMagicId
ProtocolMagicId -> Encoding
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [ProtocolMagicId] -> Size
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy ProtocolMagicId -> Size
forall a.
Typeable a
-> (a -> Encoding)
-> ((forall t. EncCBOR t => Proxy t -> Size) -> Proxy a -> Size)
-> ((forall t. EncCBOR t => Proxy t -> Size) -> Proxy [a] -> Size)
-> EncCBOR a
encodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [ProtocolMagicId] -> Size
$cencodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [ProtocolMagicId] -> Size
encodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy ProtocolMagicId -> Size
$cencodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy ProtocolMagicId -> Size
encCBOR :: ProtocolMagicId -> Encoding
$cencCBOR :: ProtocolMagicId -> Encoding
EncCBOR, Typeable ProtocolMagicId
Proxy ProtocolMagicId -> Text
forall s. Decoder s ProtocolMagicId
forall a.
Typeable a
-> (forall s. Decoder s a) -> (Proxy a -> Text) -> FromCBOR a
label :: Proxy ProtocolMagicId -> Text
$clabel :: Proxy ProtocolMagicId -> Text
fromCBOR :: forall s. Decoder s ProtocolMagicId
$cfromCBOR :: forall s. Decoder s ProtocolMagicId
FromCBOR, Typeable ProtocolMagicId
ProtocolMagicId -> Encoding
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [ProtocolMagicId] -> Size
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy ProtocolMagicId -> Size
forall a.
Typeable a
-> (a -> Encoding)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy [a] -> Size)
-> ToCBOR a
encodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [ProtocolMagicId] -> Size
$cencodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [ProtocolMagicId] -> Size
encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy ProtocolMagicId -> Size
$cencodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy ProtocolMagicId -> Size
toCBOR :: ProtocolMagicId -> Encoding
$ctoCBOR :: ProtocolMagicId -> Encoding
ToCBOR)
  deriving anyclass (ProtocolMagicId -> ()
forall a. (a -> ()) -> NFData a
rnf :: ProtocolMagicId -> ()
$crnf :: ProtocolMagicId -> ()
NFData, Context -> ProtocolMagicId -> IO (Maybe ThunkInfo)
Proxy ProtocolMagicId -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy ProtocolMagicId -> String
$cshowTypeOf :: Proxy ProtocolMagicId -> String
wNoThunks :: Context -> ProtocolMagicId -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ProtocolMagicId -> IO (Maybe ThunkInfo)
noThunks :: Context -> ProtocolMagicId -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> ProtocolMagicId -> IO (Maybe ThunkInfo)
NoThunks)

instance A.ToJSON ProtocolMagicId where
  toJSON :: ProtocolMagicId -> Value
toJSON = forall a. ToJSON a => a -> Value
A.toJSON forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ProtocolMagicId -> Word32
unProtocolMagicId

instance A.FromJSON ProtocolMagicId where
  parseJSON :: Value -> Parser ProtocolMagicId
parseJSON Value
v = Word32 -> ProtocolMagicId
ProtocolMagicId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
A.parseJSON Value
v

getProtocolMagicId :: AProtocolMagic a -> ProtocolMagicId
getProtocolMagicId :: forall a. AProtocolMagic a -> ProtocolMagicId
getProtocolMagicId = forall b a. Annotated b a -> b
unAnnotated forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. AProtocolMagic a -> Annotated ProtocolMagicId a
getAProtocolMagicId

-- mhueschen: For backwards-compatibility reasons, I redefine this function
-- in terms of the two record accessors.
getProtocolMagic :: AProtocolMagic a -> Word32
getProtocolMagic :: forall a. AProtocolMagic a -> Word32
getProtocolMagic = ProtocolMagicId -> Word32
unProtocolMagicId forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. AProtocolMagic a -> ProtocolMagicId
getProtocolMagicId

instance A.ToJSON ProtocolMagic where
  toJSON :: ProtocolMagic -> Value
toJSON (AProtocolMagic (Annotated (ProtocolMagicId Word32
ident) ()) RequiresNetworkMagic
rnm) =
    [Pair] -> Value
A.object [Key
"pm" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word32
ident, Key
"requiresNetworkMagic" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RequiresNetworkMagic
rnm]

instance A.FromJSON ProtocolMagic where
  parseJSON :: Value -> Parser ProtocolMagic
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"ProtocolMagic" forall a b. (a -> b) -> a -> b
$ \Object
o ->
    forall a.
Annotated ProtocolMagicId a
-> RequiresNetworkMagic -> AProtocolMagic a
AProtocolMagic
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o
      forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"pm"
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o
      forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"requiresNetworkMagic"

-- Canonical JSON instances
instance Monad m => ToJSON m ProtocolMagicId where
  toJSON :: ProtocolMagicId -> m JSValue
toJSON (ProtocolMagicId Word32
ident) = forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON Word32
ident

instance MonadError SchemaError m => FromJSON m ProtocolMagicId where
  fromJSON :: JSValue -> m ProtocolMagicId
fromJSON JSValue
v = Word32 -> ProtocolMagicId
ProtocolMagicId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
v

--------------------------------------------------------------------------------
-- RequiresNetworkMagic
--------------------------------------------------------------------------------

-- | Bool-isomorphic flag indicating whether we're on testnet
-- or mainnet/staging.
type RequiresNetworkMagic :: Type
data RequiresNetworkMagic
  = RequiresNoMagic
  | RequiresMagic
  deriving (Int -> RequiresNetworkMagic -> ShowS
[RequiresNetworkMagic] -> ShowS
RequiresNetworkMagic -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RequiresNetworkMagic] -> ShowS
$cshowList :: [RequiresNetworkMagic] -> ShowS
show :: RequiresNetworkMagic -> String
$cshow :: RequiresNetworkMagic -> String
showsPrec :: Int -> RequiresNetworkMagic -> ShowS
$cshowsPrec :: Int -> RequiresNetworkMagic -> ShowS
Show, RequiresNetworkMagic -> RequiresNetworkMagic -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RequiresNetworkMagic -> RequiresNetworkMagic -> Bool
$c/= :: RequiresNetworkMagic -> RequiresNetworkMagic -> Bool
== :: RequiresNetworkMagic -> RequiresNetworkMagic -> Bool
$c== :: RequiresNetworkMagic -> RequiresNetworkMagic -> Bool
Eq, forall x. Rep RequiresNetworkMagic x -> RequiresNetworkMagic
forall x. RequiresNetworkMagic -> Rep RequiresNetworkMagic x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RequiresNetworkMagic x -> RequiresNetworkMagic
$cfrom :: forall x. RequiresNetworkMagic -> Rep RequiresNetworkMagic x
Generic, RequiresNetworkMagic -> ()
forall a. (a -> ()) -> NFData a
rnf :: RequiresNetworkMagic -> ()
$crnf :: RequiresNetworkMagic -> ()
NFData, Context -> RequiresNetworkMagic -> IO (Maybe ThunkInfo)
Proxy RequiresNetworkMagic -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy RequiresNetworkMagic -> String
$cshowTypeOf :: Proxy RequiresNetworkMagic -> String
wNoThunks :: Context -> RequiresNetworkMagic -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> RequiresNetworkMagic -> IO (Maybe ThunkInfo)
noThunks :: Context -> RequiresNetworkMagic -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> RequiresNetworkMagic -> IO (Maybe ThunkInfo)
NoThunks)

instance ToCBOR RequiresNetworkMagic where
  toCBOR :: RequiresNetworkMagic -> Encoding
toCBOR = forall a. EncCBOR a => a -> Encoding
toByronCBOR

instance FromCBOR RequiresNetworkMagic where
  fromCBOR :: forall s. Decoder s RequiresNetworkMagic
fromCBOR = forall a s. DecCBOR a => Decoder s a
fromByronCBOR

instance EncCBOR RequiresNetworkMagic where
  encCBOR :: RequiresNetworkMagic -> Encoding
encCBOR = \case
    RequiresNetworkMagic
RequiresNoMagic -> Word -> Encoding
encodeTag Word
0
    RequiresNetworkMagic
RequiresMagic -> Word -> Encoding
encodeTag Word
1

instance DecCBOR RequiresNetworkMagic where
  decCBOR :: forall s. Decoder s RequiresNetworkMagic
decCBOR =
    forall s. Decoder s Word
decodeTag forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Word
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return RequiresNetworkMagic
RequiresNoMagic
      Word
1 -> forall (m :: * -> *) a. Monad m => a -> m a
return RequiresNetworkMagic
RequiresMagic
      Word
tag -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"RequiresNetworkMagic: unknown tag " forall a. [a] -> [a] -> [a]
++ forall a b. (Show a, ConvertText String b) => a -> b
show Word
tag

-- Aeson JSON instances
-- N.B @RequiresNetworkMagic@'s ToJSON & FromJSON instances do not round-trip.
-- They should only be used from a parent instance which handles the
-- `requiresNetworkMagic` key.
instance A.ToJSON RequiresNetworkMagic where
  toJSON :: RequiresNetworkMagic -> Value
toJSON RequiresNetworkMagic
RequiresNoMagic = Text -> Value
A.String Text
"RequiresNoMagic"
  toJSON RequiresNetworkMagic
RequiresMagic = Text -> Value
A.String Text
"RequiresMagic"

instance A.FromJSON RequiresNetworkMagic where
  parseJSON :: Value -> Parser RequiresNetworkMagic
parseJSON =
    forall a. String -> (Text -> Parser a) -> Value -> Parser a
A.withText String
"requiresNetworkMagic"
      forall a b. (a -> b) -> a -> b
$ forall e a. Buildable e => Either e a -> Parser a
toAesonError
      forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. \case
        Text
"RequiresNoMagic" -> forall a b. b -> Either a b
Right RequiresNetworkMagic
RequiresNoMagic
        Text
"RequiresMagic" -> forall a b. b -> Either a b
Right RequiresNetworkMagic
RequiresMagic
        Text
"NMMustBeNothing" -> forall a b. b -> Either a b
Right RequiresNetworkMagic
RequiresNoMagic
        Text
"NMMustBeJust" -> forall a b. b -> Either a b
Right RequiresNetworkMagic
RequiresMagic
        Text
other ->
          forall a b. a -> Either a b
Left
            ( Text
"invalid value "
                forall a. Semigroup a => a -> a -> a
<> Text
other
                forall a. Semigroup a => a -> a -> a
<> Text
", acceptable values are RequiresNoMagic | RequiresMagic"
            )

-- Canonical JSON instances
instance Monad m => ToJSON m RequiresNetworkMagic where
  toJSON :: RequiresNetworkMagic -> m JSValue
toJSON RequiresNetworkMagic
RequiresNoMagic = forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSString -> JSValue
JSString JSString
"RequiresNoMagic")
  toJSON RequiresNetworkMagic
RequiresMagic = forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSString -> JSValue
JSString JSString
"RequiresMagic")

instance MonadError SchemaError m => FromJSON m RequiresNetworkMagic where
  fromJSON :: JSValue -> m RequiresNetworkMagic
fromJSON = \case
    JSString JSString
"RequiresNoMagic" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RequiresNetworkMagic
RequiresNoMagic
    JSString JSString
"RequiresMagic" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RequiresNetworkMagic
RequiresMagic
    JSValue
other ->
      forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> Maybe String -> m a
expected String
"RequiresNoMagic | RequiresMagic" (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (Show a, ConvertText String b) => a -> b
show JSValue
other)