diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Api/Genesis.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Api/Genesis.hs new file mode 100644 index 0000000000..9c34258043 --- /dev/null +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Api/Genesis.hs @@ -0,0 +1,482 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Reading genesis files and forging credentials for assembling a Cardano +-- protocol, without depending on @cardano-api@ \/ @cardano-node@. +-- +-- This is the minimal subset of @cardano-node@'s @Cardano.Node.Protocol.*@ +-- modules that the db-tools actually use: a polymorphic genesis-file reader +-- (shared by all the Shelley-based eras), the Byron genesis reader, the Byron +-- and Praos leader-credential loaders and 'genesisHashToPraosNonce'. +module Ouroboros.Consensus.Cardano.Api.Genesis + ( -- * Genesis and credential file locations + GenesisFile (..) + , GenesisHash (..) + , ProtocolFilepaths (..) + + -- * Reading genesis files + , genesisHashToPraosNonce + , readByronGenesis + , readGenesisAny + + -- * Reading leader credentials + , readByronLeaderCredentials + , readShelleyLeaderCredentials + + -- * Errors + , ByronProtocolInstantiationError (..) + , GenesisReadError (..) + , PraosLeaderCredentialsError (..) + ) where + +import qualified Cardano.Chain.Genesis as Byron.Genesis +import qualified Cardano.Chain.UTxO as Byron.UTxO +import qualified Cardano.Crypto.Hash as Crypto +import qualified Cardano.Crypto.Hashing as Byron.Crypto +import Cardano.Crypto.ProtocolMagic (RequiresNetworkMagic) +import Cardano.Ledger.Keys (coerceKeyRole) +import Cardano.Prelude (canonicalDecodePretty) +import Cardano.Protocol.Crypto (StandardCrypto) +import Control.Exception (IOException) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Except.Extra + ( bimapExceptT + , firstExceptT + , handleIOExceptT + , hoistEither + , hoistMaybe + , left + , newExceptT + ) +import Data.Aeson (FromJSON (..), ToJSON, Value (String), eitherDecodeStrict') +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LB +import Data.Maybe (fromMaybe) +import Data.String (IsString) +import Data.Text (Text) +import qualified Data.Text as Text +import Ouroboros.Consensus.Byron.Node + ( ByronLeaderCredentials + , ByronLeaderCredentialsError + , mkByronLeaderCredentials + ) +import Ouroboros.Consensus.Cardano.Api.Keys +import Ouroboros.Consensus.Cardano.Api.Serialise +import Ouroboros.Consensus.Protocol.Praos.Common + ( PraosCanBeLeader (..) + , PraosCredentialsSource (..) + ) +import Ouroboros.Consensus.Shelley.Node + ( Nonce (..) + , ShelleyLeaderCredentials (..) + ) + +-- ---------------------------------------------------------------------------- +-- Genesis and credential file locations +-- + +-- DUPLICATE -- adapted from: cardano-node/src/Cardano/Node/Types.hs + +newtype GenesisFile = GenesisFile + {unGenesisFile :: FilePath} + deriving stock (Eq, Ord) + deriving newtype (IsString, Show) + +instance FromJSON GenesisFile where + parseJSON (String genFp) = pure . GenesisFile $ Text.unpack genFp + parseJSON invalid = + fail $ + "Parsing of GenesisFile failed due to type mismatch. " + <> "Encountered: " + <> show invalid + +newtype GenesisHash = GenesisHash (Crypto.Hash Crypto.Blake2b_256 BS.ByteString) + deriving newtype (Eq, Show, ToJSON, FromJSON) + +data ProtocolFilepaths + = ProtocolFilepaths + { byronCertFile :: !(Maybe FilePath) + , byronKeyFile :: !(Maybe FilePath) + , shelleyKESFile :: !(Maybe FilePath) + , shelleyVRFFile :: !(Maybe FilePath) + , shelleyCertFile :: !(Maybe FilePath) + , shelleyBulkCredsFile :: !(Maybe FilePath) + } + deriving (Eq, Show) + +-- ---------------------------------------------------------------------------- +-- Reading Shelley-based genesis files +-- + +-- DUPLICATE -- adapted from: cardano-node/src/Cardano/Node/Protocol/Shelley.hs + +genesisHashToPraosNonce :: GenesisHash -> Nonce +genesisHashToPraosNonce (GenesisHash h) = Nonce (Crypto.castHash h) + +-- | Read and decode a genesis file in any of the Shelley-based eras (Shelley, +-- Alonzo, Conway, Dijkstra), checking the hash against an optional expected +-- value. The era is selected by the 'FromJSON' instance demanded at the call +-- site. +readGenesisAny :: + FromJSON genesis => + GenesisFile -> + Maybe GenesisHash -> + ExceptT GenesisReadError IO (genesis, GenesisHash) +readGenesisAny (GenesisFile file) mbExpectedGenesisHash = do + content <- + handleIOExceptT (GenesisReadFileError file) $ + BS.readFile file + let genesisHash = GenesisHash (Crypto.hashWith id content) + checkExpectedGenesisHash genesisHash + genesis <- + firstExceptT (GenesisDecodeError file) $ + hoistEither $ + eitherDecodeStrict' content + return (genesis, genesisHash) + where + checkExpectedGenesisHash :: + GenesisHash -> + ExceptT GenesisReadError IO () + checkExpectedGenesisHash actual = + case mbExpectedGenesisHash of + Just expected + | actual /= expected -> + left (GenesisHashMismatch actual expected) + _ -> return () + +readShelleyLeaderCredentials :: + Maybe ProtocolFilepaths -> + ExceptT PraosLeaderCredentialsError IO [ShelleyLeaderCredentials StandardCrypto] +readShelleyLeaderCredentials Nothing = return [] +readShelleyLeaderCredentials (Just pfp) = + -- The set of credentials is a sum total of what comes from the CLI, + -- as well as what's in the bulk credentials file. + (<>) + <$> readLeaderCredentialsSingleton pfp + <*> readLeaderCredentialsBulk pfp + +readLeaderCredentialsSingleton :: + ProtocolFilepaths -> + ExceptT + PraosLeaderCredentialsError + IO + [ShelleyLeaderCredentials StandardCrypto] +-- It's OK to supply none of the files on the CLI +readLeaderCredentialsSingleton + ProtocolFilepaths + { shelleyCertFile = Nothing + , shelleyVRFFile = Nothing + , shelleyKESFile = Nothing + } = pure [] +-- Or to supply all of the files +readLeaderCredentialsSingleton + ProtocolFilepaths + { shelleyCertFile = Just opCertFile + , shelleyVRFFile = Just vrfFile + , shelleyKESFile = Just kesFile + } = do + vrfSKey <- + firstExceptT PraosFileError (newExceptT $ readFileTextEnvelope (AsSigningKey AsVrfKey) vrfFile) + + (opCert, kesSKey) <- opCertKesKeyCheck kesFile opCertFile + + return [mkPraosLeaderCredentials opCert vrfSKey kesSKey] + +-- But not OK to supply some of the files without the others. +readLeaderCredentialsSingleton ProtocolFilepaths{shelleyCertFile = Nothing} = + left OCertNotSpecified +readLeaderCredentialsSingleton ProtocolFilepaths{shelleyVRFFile = Nothing} = + left VRFKeyNotSpecified +readLeaderCredentialsSingleton ProtocolFilepaths{shelleyKESFile = Nothing} = + left KESKeyNotSpecified + +opCertKesKeyCheck :: + -- | KES key + FilePath -> + -- | Operational certificate + FilePath -> + ExceptT PraosLeaderCredentialsError IO (OperationalCertificate, SigningKey UnsoundPureKesKey) +opCertKesKeyCheck kesFile certFile = do + opCert <- + firstExceptT PraosFileError (newExceptT $ readFileTextEnvelope AsOperationalCertificate certFile) + kesSKey <- + firstExceptT + PraosFileError + (newExceptT $ readFileTextEnvelope (AsSigningKey AsUnsoundPureKesKey) kesFile) + let opCertSpecifiedKesKeyhash = verificationKeyHash $ getHotKey opCert + suppliedKesKeyHash = verificationKeyHash $ getVerificationKey kesSKey + -- Specified KES key in operational certificate should match the one + -- supplied to the node. + if suppliedKesKeyHash /= opCertSpecifiedKesKeyhash + then left $ MismatchedKesKey kesFile certFile + else return (opCert, kesSKey) + +data ShelleyCredentials + = ShelleyCredentials + { scCert :: (TextEnvelope, FilePath) + , scVrf :: (TextEnvelope, FilePath) + , scKes :: (TextEnvelope, FilePath) + } + +readLeaderCredentialsBulk :: + ProtocolFilepaths -> + ExceptT PraosLeaderCredentialsError IO [ShelleyLeaderCredentials StandardCrypto] +readLeaderCredentialsBulk ProtocolFilepaths{shelleyBulkCredsFile = mfp} = + mapM parseShelleyCredentials =<< readBulkFile mfp + where + parseShelleyCredentials :: + ShelleyCredentials -> + ExceptT PraosLeaderCredentialsError IO (ShelleyLeaderCredentials StandardCrypto) + parseShelleyCredentials ShelleyCredentials{scCert, scVrf, scKes} = + mkPraosLeaderCredentials + <$> parseEnvelope AsOperationalCertificate scCert + <*> parseEnvelope (AsSigningKey AsVrfKey) scVrf + <*> parseEnvelope (AsSigningKey AsUnsoundPureKesKey) scKes + + readBulkFile :: + Maybe FilePath -> + ExceptT PraosLeaderCredentialsError IO [ShelleyCredentials] + readBulkFile Nothing = pure [] + readBulkFile (Just fp) = do + content <- + handleIOExceptT (CredentialsReadError fp) $ + BS.readFile fp + envelopes <- + firstExceptT (EnvelopeParseError fp) $ + hoistEither $ + eitherDecodeStrict' content + pure $ uncurry mkCredentials <$> zip [0 ..] envelopes + where + mkCredentials :: + Int -> + (TextEnvelope, TextEnvelope, TextEnvelope) -> + ShelleyCredentials + mkCredentials ix (teCert, teVrf, teKes) = + let loc ty = fp <> "." <> show ix <> ty + in ShelleyCredentials + (teCert, loc "cert") + (teVrf, loc "vrf") + (teKes, loc "kes") + +mkPraosLeaderCredentials :: + OperationalCertificate -> + SigningKey VrfKey -> + SigningKey UnsoundPureKesKey -> + ShelleyLeaderCredentials StandardCrypto +mkPraosLeaderCredentials + (OperationalCertificate opcert (StakePoolVerificationKey vkey)) + (VrfSigningKey vrfKey) + (KesSigningKey kesKey) = + ShelleyLeaderCredentials + { shelleyLeaderCredentialsCanBeLeader = + PraosCanBeLeader + { praosCanBeLeaderColdVerKey = coerceKeyRole vkey + , praosCanBeLeaderSignKeyVRF = vrfKey + , praosCanBeLeaderCredentialsSource = PraosCredentialsUnsound opcert kesKey + } + , shelleyLeaderCredentialsLabel = "Shelley" + } + +parseEnvelope :: + HasTextEnvelope a => + AsType a -> + (TextEnvelope, FilePath) -> + ExceptT PraosLeaderCredentialsError IO a +parseEnvelope as (te, loc) = + firstExceptT (PraosFileError . FileError loc) + . hoistEither + $ deserialiseFromTextEnvelope as te + +-- ---------------------------------------------------------------------------- +-- Reading the Byron genesis and credentials +-- + +-- DUPLICATE -- adapted from: cardano-node/src/Cardano/Node/Protocol/Byron.hs + +readByronGenesis :: + GenesisFile -> + Maybe GenesisHash -> + RequiresNetworkMagic -> + ExceptT + ByronProtocolInstantiationError + IO + Byron.Genesis.Config +readByronGenesis (GenesisFile file) mbExpectedGenesisHash ncReqNetworkMagic = do + (genesisData, genesisHash) <- + firstExceptT (ByronGenesisReadError file) $ + Byron.Genesis.readGenesisData file + checkExpectedGenesisHash genesisHash + return + Byron.Genesis.Config + { Byron.Genesis.configGenesisData = genesisData + , Byron.Genesis.configGenesisHash = genesisHash + , Byron.Genesis.configReqNetMagic = ncReqNetworkMagic + , Byron.Genesis.configUTxOConfiguration = Byron.UTxO.defaultUTxOConfiguration + -- TODO: add config support for the UTxOConfiguration if needed + } + where + checkExpectedGenesisHash :: + Byron.Genesis.GenesisHash -> + ExceptT ByronProtocolInstantiationError IO () + checkExpectedGenesisHash actual' = + case mbExpectedGenesisHash of + Just expected + | actual /= expected -> + left (ByronGenesisHashMismatch actual expected) + where + actual = fromByronGenesisHash actual' + _ -> return () + + fromByronGenesisHash :: Byron.Genesis.GenesisHash -> GenesisHash + fromByronGenesisHash (Byron.Genesis.GenesisHash h) = + GenesisHash + . fromMaybe impossible + . Crypto.hashFromBytes + . Byron.Crypto.hashToBytes + $ h + where + impossible = + error "fromByronGenesisHash: old and new crypto libs disagree on hash size" + +readByronLeaderCredentials :: + Byron.Genesis.Config -> + Maybe ProtocolFilepaths -> + ExceptT + ByronProtocolInstantiationError + IO + (Maybe ByronLeaderCredentials) +readByronLeaderCredentials _ Nothing = return Nothing +readByronLeaderCredentials + genesisConfig + ( Just + ProtocolFilepaths + { byronCertFile + , byronKeyFile + } + ) = + case (byronCertFile, byronKeyFile) of + (Nothing, Nothing) -> pure Nothing + (Just _, Nothing) -> left SigningKeyFilepathNotSpecified + (Nothing, Just _) -> left DelegationCertificateFilepathNotSpecified + (Just delegCertFile, Just signingKeyFile) -> do + signingKeyFileBytes <- liftIO $ LB.readFile signingKeyFile + delegCertFileBytes <- liftIO $ LB.readFile delegCertFile + ByronSigningKey signingKey <- + hoistMaybe (SigningKeyDeserialiseFailure signingKeyFile) $ + deserialiseFromRawBytes (AsSigningKey AsByronKey) $ + LB.toStrict signingKeyFileBytes + delegCert <- + firstExceptT (CanonicalDecodeFailure delegCertFile) + . hoistEither + $ canonicalDecodePretty delegCertFileBytes + + bimapExceptT CredentialsError Just + . hoistEither + $ mkByronLeaderCredentials genesisConfig signingKey delegCert "Byron" + +-- ---------------------------------------------------------------------------- +-- Errors +-- + +data GenesisReadError + = GenesisReadFileError !FilePath !IOException + | GenesisHashMismatch !GenesisHash !GenesisHash -- actual, expected + | GenesisDecodeError !FilePath !String + deriving Show + +instance Error GenesisReadError where + displayError (GenesisReadFileError fp err) = + "There was an error reading the genesis file: " + <> fp + <> " Error: " + <> show err + displayError (GenesisHashMismatch actual expected) = + "Wrong genesis file: the actual hash is " + <> show actual + <> ", but the expected genesis hash given in the node " + <> "configuration file is " + <> show expected + displayError (GenesisDecodeError fp err) = + "There was an error parsing the genesis file: " + <> fp + <> " Error: " + <> show err + +data PraosLeaderCredentialsError + = CredentialsReadError !FilePath !IOException + | EnvelopeParseError !FilePath !String + | PraosFileError !(FileError TextEnvelopeError) + | OCertNotSpecified + | VRFKeyNotSpecified + | KESKeyNotSpecified + | MismatchedKesKey + FilePath + -- ^ KES signing key + FilePath + -- ^ Operational certificate + deriving Show + +instance Error PraosLeaderCredentialsError where + displayError (CredentialsReadError fp err) = + "There was an error reading a credentials file: " + <> fp + <> " Error: " + <> show err + displayError (EnvelopeParseError fp err) = + "There was an error parsing a credentials envelope: " + <> fp + <> " Error: " + <> show err + displayError (PraosFileError fileErr) = displayError fileErr + displayError (MismatchedKesKey kesFp certFp) = + "The KES key provided at: " + <> show kesFp + <> " does not match the KES key specified in the operational certificate at: " + <> show certFp + displayError OCertNotSpecified = missingFlagMessage "shelley-operational-certificate" + displayError VRFKeyNotSpecified = missingFlagMessage "shelley-vrf-key" + displayError KESKeyNotSpecified = missingFlagMessage "shelley-kes-key" + +missingFlagMessage :: String -> String +missingFlagMessage flag = + "To create blocks, the --" <> flag <> " must also be specified" + +data ByronProtocolInstantiationError + = CanonicalDecodeFailure !FilePath !Text + | ByronGenesisHashMismatch !GenesisHash !GenesisHash -- actual, expected + | DelegationCertificateFilepathNotSpecified + | ByronGenesisReadError !FilePath !Byron.Genesis.GenesisDataError + | CredentialsError !ByronLeaderCredentialsError + | SigningKeyDeserialiseFailure !FilePath + | SigningKeyFilepathNotSpecified + deriving Show + +instance Error ByronProtocolInstantiationError where + displayError (CanonicalDecodeFailure fp failure) = + "Canonical decode failure in " + <> fp + <> " Canonical failure: " + <> Text.unpack failure + displayError (ByronGenesisHashMismatch actual expected) = + "Wrong Byron genesis file: the actual hash is " + <> show actual + <> ", but the expected Byron genesis hash given in the node configuration " + <> "file is " + <> show expected + displayError DelegationCertificateFilepathNotSpecified = + "Delegation certificate filepath not specified" + displayError (ByronGenesisReadError fp err) = + "There was an error parsing the genesis file: " + <> fp + <> " Error: " + <> show err + -- TODO: Implement ByronLeaderCredentialsError render function in ouroboros-network + displayError (CredentialsError byronLeaderCredentialsError) = + "Byron leader credentials error: " <> show byronLeaderCredentialsError + displayError (SigningKeyDeserialiseFailure fp) = + "Signing key deserialisation error in: " <> fp + displayError SigningKeyFilepathNotSpecified = + "Signing key filepath not specified" diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Api/Keys.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Api/Keys.hs new file mode 100644 index 0000000000..0d6a08581c --- /dev/null +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Api/Keys.hs @@ -0,0 +1,467 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The minimal set of @cardano-api@ key roles that the db-tools need in order +-- to load Praos and Byron forging credentials: the stake-pool cold key (carried +-- by an operational certificate), the VRF key, the (unsound, in-memory) KES key +-- and the Byron payment key. Also defines the 'OperationalCertificate' itself. +-- +-- The serialisation machinery lives in +-- "Ouroboros.Consensus.Cardano.Api.Serialise". +module Ouroboros.Consensus.Cardano.Api.Keys + ( -- * The key interface + Key (..) + + -- * Key roles + , ByronKey + , StakePoolKey + , UnsoundPureKesKey + , VrfKey + + -- * Operational certificates + , OperationalCertificate (..) + , getHotKey + + -- * Data family instances + , AsType (..) + , Hash (..) + , SigningKey (..) + , VerificationKey (..) + ) where + +import qualified Cardano.Chain.Common as Byron +import Cardano.Crypto.DSIGN (SignKeyDSIGN) +import qualified Cardano.Crypto.DSIGN.Class as Crypto +import qualified Cardano.Crypto.Hash.Class as Crypto +import qualified Cardano.Crypto.Hashing as Byron +import qualified Cardano.Crypto.KES.Class as Crypto +import qualified Cardano.Crypto.Signing as Byron +import qualified Cardano.Crypto.Signing as Crypto +import qualified Cardano.Crypto.VRF.Class as Crypto +import qualified Cardano.Crypto.Wallet as Crypto.HD +import Cardano.Ledger.Binary + ( byronProtVer + , fromPlainDecoder + , toPlainDecoder + , toPlainEncoding + ) +import qualified Cardano.Ledger.Binary as CBOR + ( CBORGroup (..) + , shelleyProtVer + , toPlainDecoder + , toPlainEncoding + ) +import Cardano.Ledger.Hashes (HASH) +import Cardano.Ledger.Keys (DSIGN) +import qualified Cardano.Ledger.Keys as Shelley +import Cardano.Protocol.Crypto (Crypto (..), StandardCrypto) +import qualified Cardano.Protocol.TPraos.OCert as Shelley +import qualified Codec.CBOR.Read as CBOR +import qualified Codec.CBOR.Write as CBOR (toStrictByteString) +import qualified Data.ByteString.Lazy as LB +import Data.Kind (Type) +import Data.String (IsString (..)) +import Ouroboros.Consensus.Cardano.Api.Serialise + +-- ---------------------------------------------------------------------------- +-- The key interface +-- + +-- | An interface for cryptographic keys used for signatures with a 'SigningKey' +-- and a 'VerificationKey' key. +-- +-- This interface does not provide actual signing or verifying functions since +-- this API is concerned with the management of keys: deserialising them and +-- relating signing keys, verification keys and their hashes. +class + ( Eq (VerificationKey keyrole) + , Show (VerificationKey keyrole) + , HasTextEnvelope (VerificationKey keyrole) + , HasTextEnvelope (SigningKey keyrole) + ) => + Key keyrole + where + -- | The type of cryptographic verification key, for each key role. + data VerificationKey keyrole :: Type + + -- | The type of cryptographic signing key, for each key role. + data SigningKey keyrole :: Type + + -- | Get the corresponding verification key from a signing key. + getVerificationKey :: SigningKey keyrole -> VerificationKey keyrole + + verificationKeyHash :: VerificationKey keyrole -> Hash keyrole + +instance HasTypeProxy a => HasTypeProxy (VerificationKey a) where + data AsType (VerificationKey a) = AsVerificationKey (AsType a) + proxyToAsType _ = AsVerificationKey (proxyToAsType (Proxy :: Proxy a)) + +instance HasTypeProxy a => HasTypeProxy (SigningKey a) where + data AsType (SigningKey a) = AsSigningKey (AsType a) + proxyToAsType _ = AsSigningKey (proxyToAsType (Proxy :: Proxy a)) + +-- ---------------------------------------------------------------------------- +-- Stake pool keys +-- + +data StakePoolKey + +instance HasTypeProxy StakePoolKey where + data AsType StakePoolKey = AsStakePoolKey + proxyToAsType _ = AsStakePoolKey + +instance Key StakePoolKey where + newtype VerificationKey StakePoolKey + = StakePoolVerificationKey (Shelley.VKey Shelley.StakePool) + deriving stock Eq + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey StakePoolKey) + deriving newtype (EncCBOR, DecCBOR, ToCBOR, FromCBOR) + deriving anyclass SerialiseAsCBOR + + newtype SigningKey StakePoolKey + = StakePoolSigningKey (SignKeyDSIGN DSIGN) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey StakePoolKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass SerialiseAsCBOR + + getVerificationKey :: SigningKey StakePoolKey -> VerificationKey StakePoolKey + getVerificationKey (StakePoolSigningKey sk) = + StakePoolVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) + + verificationKeyHash :: VerificationKey StakePoolKey -> Hash StakePoolKey + verificationKeyHash (StakePoolVerificationKey vkey) = + StakePoolKeyHash (Shelley.hashKey vkey) + +instance SerialiseAsRawBytes (VerificationKey StakePoolKey) where + serialiseToRawBytes (StakePoolVerificationKey (Shelley.VKey vk)) = + Crypto.rawSerialiseVerKeyDSIGN vk + + deserialiseFromRawBytes (AsVerificationKey AsStakePoolKey) bs = + StakePoolVerificationKey . Shelley.VKey + <$> Crypto.rawDeserialiseVerKeyDSIGN bs + +instance SerialiseAsRawBytes (SigningKey StakePoolKey) where + serialiseToRawBytes (StakePoolSigningKey sk) = + Crypto.rawSerialiseSignKeyDSIGN sk + + deserialiseFromRawBytes (AsSigningKey AsStakePoolKey) bs = + StakePoolSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs + +newtype instance Hash StakePoolKey + = StakePoolKeyHash (Shelley.KeyHash Shelley.StakePool) + deriving stock (Eq, Ord) + deriving (Show, IsString) via UsingRawBytesHex (Hash StakePoolKey) + deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash StakePoolKey) + deriving anyclass SerialiseAsCBOR + +instance SerialiseAsRawBytes (Hash StakePoolKey) where + serialiseToRawBytes (StakePoolKeyHash (Shelley.KeyHash vkh)) = + Crypto.hashToBytes vkh + + deserialiseFromRawBytes (AsHash AsStakePoolKey) bs = + StakePoolKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs + +instance HasTextEnvelope (VerificationKey StakePoolKey) where + textEnvelopeType _ = + "StakePoolVerificationKey_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy Shelley.DSIGN + proxy = Proxy + +instance HasTextEnvelope (SigningKey StakePoolKey) where + textEnvelopeType _ = + "StakePoolSigningKey_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy Shelley.DSIGN + proxy = Proxy + +-- ---------------------------------------------------------------------------- +-- KES keys +-- + +data UnsoundPureKesKey + +instance HasTypeProxy UnsoundPureKesKey where + data AsType UnsoundPureKesKey = AsUnsoundPureKesKey + proxyToAsType _ = AsUnsoundPureKesKey + +instance Key UnsoundPureKesKey where + newtype VerificationKey UnsoundPureKesKey + = KesVerificationKey (Crypto.VerKeyKES (KES StandardCrypto)) + deriving stock Eq + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey UnsoundPureKesKey) + deriving newtype (EncCBOR, DecCBOR, ToCBOR, FromCBOR) + deriving anyclass SerialiseAsCBOR + + newtype SigningKey UnsoundPureKesKey + = KesSigningKey (Crypto.UnsoundPureSignKeyKES (KES StandardCrypto)) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey UnsoundPureKesKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (EncCBOR, SerialiseAsCBOR) + + getVerificationKey :: SigningKey UnsoundPureKesKey -> VerificationKey UnsoundPureKesKey + getVerificationKey (KesSigningKey sk) = + KesVerificationKey (Crypto.unsoundPureDeriveVerKeyKES sk) + + verificationKeyHash :: VerificationKey UnsoundPureKesKey -> Hash UnsoundPureKesKey + verificationKeyHash (KesVerificationKey vkey) = + UnsoundPureKesKeyHash (Crypto.hashVerKeyKES vkey) + +instance DecCBOR (SigningKey UnsoundPureKesKey) where + decCBOR = fromPlainDecoder fromCBOR + +instance SerialiseAsRawBytes (VerificationKey UnsoundPureKesKey) where + serialiseToRawBytes (KesVerificationKey vk) = + Crypto.rawSerialiseVerKeyKES vk + + deserialiseFromRawBytes (AsVerificationKey AsUnsoundPureKesKey) bs = + KesVerificationKey + <$> Crypto.rawDeserialiseVerKeyKES bs + +instance SerialiseAsRawBytes (SigningKey UnsoundPureKesKey) where + serialiseToRawBytes (KesSigningKey sk) = + Crypto.rawSerialiseUnsoundPureSignKeyKES sk + + deserialiseFromRawBytes (AsSigningKey AsUnsoundPureKesKey) bs = + KesSigningKey <$> Crypto.rawDeserialiseUnsoundPureSignKeyKES bs + +newtype instance Hash UnsoundPureKesKey + = UnsoundPureKesKeyHash + ( Crypto.Hash + HASH + (Crypto.VerKeyKES (KES StandardCrypto)) + ) + deriving stock (Eq, Ord) + deriving (Show, IsString) via UsingRawBytesHex (Hash UnsoundPureKesKey) + deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash UnsoundPureKesKey) + deriving anyclass SerialiseAsCBOR + +instance SerialiseAsRawBytes (Hash UnsoundPureKesKey) where + serialiseToRawBytes (UnsoundPureKesKeyHash vkh) = + Crypto.hashToBytes vkh + + deserialiseFromRawBytes (AsHash AsUnsoundPureKesKey) bs = + UnsoundPureKesKeyHash <$> Crypto.hashFromBytes bs + +instance HasTextEnvelope (VerificationKey UnsoundPureKesKey) where + textEnvelopeType _ = + "KesVerificationKey_" + <> fromString (Crypto.algorithmNameKES proxy) + where + proxy :: Proxy (KES StandardCrypto) + proxy = Proxy + +instance HasTextEnvelope (SigningKey UnsoundPureKesKey) where + textEnvelopeType _ = + "KesSigningKey_" + <> fromString (Crypto.algorithmNameKES proxy) + where + proxy :: Proxy (KES StandardCrypto) + proxy = Proxy + +-- ---------------------------------------------------------------------------- +-- VRF keys +-- + +data VrfKey + +instance HasTypeProxy VrfKey where + data AsType VrfKey = AsVrfKey + proxyToAsType _ = AsVrfKey + +instance Key VrfKey where + newtype VerificationKey VrfKey + = VrfVerificationKey (Crypto.VerKeyVRF (VRF StandardCrypto)) + deriving stock Eq + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey VrfKey) + deriving newtype (EncCBOR, DecCBOR, ToCBOR, FromCBOR) + deriving anyclass SerialiseAsCBOR + + newtype SigningKey VrfKey + = VrfSigningKey (Crypto.SignKeyVRF (VRF StandardCrypto)) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey VrfKey) + deriving newtype (EncCBOR, DecCBOR, ToCBOR, FromCBOR) + deriving anyclass SerialiseAsCBOR + + getVerificationKey :: SigningKey VrfKey -> VerificationKey VrfKey + getVerificationKey (VrfSigningKey sk) = + VrfVerificationKey (Crypto.deriveVerKeyVRF sk) + + verificationKeyHash :: VerificationKey VrfKey -> Hash VrfKey + verificationKeyHash (VrfVerificationKey vkey) = + VrfKeyHash (Crypto.hashVerKeyVRF vkey) + +instance SerialiseAsRawBytes (VerificationKey VrfKey) where + serialiseToRawBytes (VrfVerificationKey vk) = + Crypto.rawSerialiseVerKeyVRF vk + + deserialiseFromRawBytes (AsVerificationKey AsVrfKey) bs = + VrfVerificationKey <$> Crypto.rawDeserialiseVerKeyVRF bs + +instance SerialiseAsRawBytes (SigningKey VrfKey) where + serialiseToRawBytes (VrfSigningKey sk) = + Crypto.rawSerialiseSignKeyVRF sk + + deserialiseFromRawBytes (AsSigningKey AsVrfKey) bs = + VrfSigningKey <$> Crypto.rawDeserialiseSignKeyVRF bs + +newtype instance Hash VrfKey + = VrfKeyHash + ( Crypto.Hash + HASH + (Crypto.VerKeyVRF (VRF StandardCrypto)) + ) + deriving stock (Eq, Ord) + deriving (Show, IsString) via UsingRawBytesHex (Hash VrfKey) + deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash VrfKey) + deriving anyclass SerialiseAsCBOR + +instance SerialiseAsRawBytes (Hash VrfKey) where + serialiseToRawBytes (VrfKeyHash vkh) = + Crypto.hashToBytes vkh + + deserialiseFromRawBytes (AsHash AsVrfKey) bs = + VrfKeyHash <$> Crypto.hashFromBytes bs + +instance HasTextEnvelope (VerificationKey VrfKey) where + textEnvelopeType _ = "VrfVerificationKey_" <> fromString (Crypto.algorithmNameVRF proxy) + where + proxy :: Proxy (VRF StandardCrypto) + proxy = Proxy + +instance HasTextEnvelope (SigningKey VrfKey) where + textEnvelopeType _ = "VrfSigningKey_" <> fromString (Crypto.algorithmNameVRF proxy) + where + proxy :: Proxy (VRF StandardCrypto) + proxy = Proxy + +-- ---------------------------------------------------------------------------- +-- Byron keys +-- + +-- | Byron-era payment keys. Used for Byron addresses and witnessing +-- transactions that spend from these addresses. +-- +-- These use Ed25519 but with a 32byte \"chaincode\" used in HD derivation. +-- The inclusion of the chaincode is a design mistake but one that cannot +-- be corrected for the Byron era. It is safe to use a zero or random chaincode +-- for new Byron keys. +-- +-- This is a type level tag, used with other interfaces like 'Key'. +data ByronKey + +instance HasTypeProxy ByronKey where + data AsType ByronKey = AsByronKey + proxyToAsType _ = AsByronKey + +instance Key ByronKey where + newtype VerificationKey ByronKey + = ByronVerificationKey Byron.VerificationKey + deriving stock Eq + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey ByronKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass SerialiseAsCBOR + + newtype SigningKey ByronKey + = ByronSigningKey Byron.SigningKey + deriving (Show, IsString) via UsingRawBytesHex (SigningKey ByronKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass SerialiseAsCBOR + + getVerificationKey :: SigningKey ByronKey -> VerificationKey ByronKey + getVerificationKey (ByronSigningKey sk) = + ByronVerificationKey (Byron.toVerification sk) + + verificationKeyHash :: VerificationKey ByronKey -> Hash ByronKey + verificationKeyHash (ByronVerificationKey vkey) = + ByronKeyHash (Byron.hashKey vkey) + +instance HasTextEnvelope (VerificationKey ByronKey) where + textEnvelopeType _ = "PaymentVerificationKeyByron_ed25519_bip32" + +instance HasTextEnvelope (SigningKey ByronKey) where + textEnvelopeType _ = "PaymentSigningKeyByron_ed25519_bip32" + +instance SerialiseAsRawBytes (VerificationKey ByronKey) where + serialiseToRawBytes (ByronVerificationKey (Byron.VerificationKey xvk)) = + Crypto.HD.unXPub xvk + + deserialiseFromRawBytes (AsVerificationKey AsByronKey) bs = + either + (const Nothing) + (Just . ByronVerificationKey . Byron.VerificationKey) + (Crypto.HD.xpub bs) + +instance SerialiseAsRawBytes (SigningKey ByronKey) where + serialiseToRawBytes (ByronSigningKey (Byron.SigningKey xsk)) = + CBOR.toStrictByteString $ encCBORXPrv xsk + where + encCBORXPrv = toPlainEncoding byronProtVer . Crypto.encCBORXPrv + + deserialiseFromRawBytes (AsSigningKey AsByronKey) bs = + either + (const Nothing) + (Just . ByronSigningKey . Byron.SigningKey) + (snd <$> CBOR.deserialiseFromBytes decCBORXPrv (LB.fromStrict bs)) + where + decCBORXPrv = toPlainDecoder Nothing byronProtVer Byron.decCBORXPrv + +newtype instance Hash ByronKey = ByronKeyHash Byron.KeyHash + deriving (Eq, Ord) + deriving (Show, IsString) via UsingRawBytesHex (Hash ByronKey) + deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash ByronKey) + deriving anyclass SerialiseAsCBOR + +instance SerialiseAsRawBytes (Hash ByronKey) where + serialiseToRawBytes (ByronKeyHash (Byron.KeyHash vkh)) = + Byron.abstractHashToBytes vkh + + deserialiseFromRawBytes (AsHash AsByronKey) bs = + ByronKeyHash . Byron.KeyHash <$> Byron.abstractHashFromBytes bs + +-- ---------------------------------------------------------------------------- +-- Operational certificates +-- + +data OperationalCertificate + = OperationalCertificate + !(Shelley.OCert StandardCrypto) + !(VerificationKey StakePoolKey) + deriving (Eq, Show) + deriving anyclass SerialiseAsCBOR + +instance ToCBOR OperationalCertificate where + toCBOR = CBOR.toPlainEncoding CBOR.shelleyProtVer . encCBOR + +instance FromCBOR OperationalCertificate where + fromCBOR = CBOR.toPlainDecoder Nothing CBOR.shelleyProtVer decCBOR + +instance EncCBOR OperationalCertificate where + encCBOR (OperationalCertificate ocert vkey) = + encCBOR (CBOR.CBORGroup ocert, vkey) + +instance DecCBOR OperationalCertificate where + decCBOR = do + (CBOR.CBORGroup ocert, vkey) <- decCBOR + return (OperationalCertificate ocert vkey) + +instance HasTypeProxy OperationalCertificate where + data AsType OperationalCertificate = AsOperationalCertificate + proxyToAsType _ = AsOperationalCertificate + +instance HasTextEnvelope OperationalCertificate where + textEnvelopeType _ = "NodeOperationalCertificate" + +getHotKey :: OperationalCertificate -> VerificationKey UnsoundPureKesKey +getHotKey (OperationalCertificate cert _) = KesVerificationKey $ Shelley.ocertVkHot cert diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Api/Serialise.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Api/Serialise.hs new file mode 100644 index 0000000000..a8d1404514 --- /dev/null +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Api/Serialise.hs @@ -0,0 +1,357 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | A minimal, Consensus-native subset of @cardano-api@'s serialisation +-- machinery, sufficient for the db-tools to read forging credentials and +-- operational certificates from key and certificate files. +-- +-- This provides the 'HasTypeProxy' \/ 'AsType' singleton scheme, raw-bytes and +-- CBOR (de)serialisation classes, the 'TextEnvelope' file format reader and the +-- @deriving via@ helpers used by the key types in +-- "Ouroboros.Consensus.Cardano.Api.Keys". +module Ouroboros.Consensus.Cardano.Api.Serialise + ( -- * Type proxies + HasTypeProxy (..) + , AsType (..) + + -- * Hashes + , Hash + + -- * Raw bytes serialisation + , SerialiseAsRawBytes (..) + , serialiseToRawBytesHex + , serialiseToRawBytesHexText + + -- * CBOR serialisation + , SerialiseAsCBOR (..) + + -- * Errors + , Error (..) + , FileError (..) + + -- * Text envelopes + , TextEnvelope (..) + , TextEnvelopeDescr (..) + , TextEnvelopeError (..) + , TextEnvelopeType (..) + , HasTextEnvelope (..) + , deserialiseFromTextEnvelope + , readFileTextEnvelope + + -- * @deriving via@ helpers + , UsingRawBytes (..) + , UsingRawBytesHex (..) + + -- * Re-exports + , module Cbor + , module Proxy + ) where + +import Cardano.Ledger.Binary as Cbor + ( DecCBOR (..) + , EncCBOR (..) + , FromCBOR (..) + , ToCBOR (..) + ) +import Cardano.Ledger.Binary (DecoderError, fromPlainDecoder) +import qualified Cardano.Ledger.Binary.Plain as CBOR +import Control.Exception (Exception (..), IOException) +import Control.Monad (unless) +import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Trans.Except.Extra + ( firstExceptT + , handleIOExceptT + , hoistEither + ) +import Data.Aeson as Aeson + ( FromJSON (..) + , eitherDecodeStrict' + , withObject + , (.:) + ) +import Data.Aeson.Types + ( FromJSONKey + , ToJSON (..) + , ToJSONKey + ) +import qualified Data.Aeson.Types as Aeson +import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as Base16 (decode, encode) +import qualified Data.ByteString.Char8 as BSC +import Data.Kind (Type) +import Data.Proxy as Proxy (Proxy (..)) +import Data.String (IsString (..)) +import Data.Text as Text (Text) +import qualified Data.Text.Encoding as Text (decodeUtf8, encodeUtf8) +import Data.Typeable (Typeable, tyConName, typeRep, typeRepTyCon) + +-- ---------------------------------------------------------------------------- +-- Type proxies +-- + +-- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/HasTypeProxy.hs + +class HasTypeProxy t where + -- | A family of singleton types used in this API to indicate which type to + -- use where it would otherwise be ambiguous or merely unclear. + -- + -- Values of this type are passed to deserialisation functions for example. + data AsType t + + proxyToAsType :: Proxy t -> AsType t + +-- ---------------------------------------------------------------------------- +-- Hashes +-- + +-- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/Hash.hs + +data family Hash keyrole :: Type + +instance HasTypeProxy a => HasTypeProxy (Hash a) where + data AsType (Hash a) = AsHash (AsType a) + proxyToAsType _ = AsHash (proxyToAsType (Proxy :: Proxy a)) + +-- ---------------------------------------------------------------------------- +-- Raw bytes serialisation +-- + +-- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/SerialiseRaw.hs + +class HasTypeProxy a => SerialiseAsRawBytes a where + serialiseToRawBytes :: a -> ByteString + + deserialiseFromRawBytes :: AsType a -> ByteString -> Maybe a + +serialiseToRawBytesHex :: SerialiseAsRawBytes a => a -> ByteString +serialiseToRawBytesHex = Base16.encode . serialiseToRawBytes + +serialiseToRawBytesHexText :: SerialiseAsRawBytes a => a -> Text +serialiseToRawBytesHexText = Text.decodeUtf8 . serialiseToRawBytesHex + +-- ---------------------------------------------------------------------------- +-- CBOR serialisation +-- + +-- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/SerialiseAsCBOR.hs + +class HasTypeProxy a => SerialiseAsCBOR a where + serialiseToCBOR :: a -> ByteString + deserialiseFromCBOR :: AsType a -> ByteString -> Either CBOR.DecoderError a + + default serialiseToCBOR :: ToCBOR a => a -> ByteString + serialiseToCBOR = CBOR.serialize' + + default deserialiseFromCBOR :: + FromCBOR a => + AsType a -> + ByteString -> + Either CBOR.DecoderError a + deserialiseFromCBOR _proxy = CBOR.decodeFull' + +-- ---------------------------------------------------------------------------- +-- Errors +-- + +-- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/Error.hs + +class Show e => Error e where + displayError :: e -> String + +data FileError e + = FileError FilePath e + | FileIOError FilePath IOException + deriving Show + +instance Error e => Error (FileError e) where + displayError (FileIOError path ioe) = + path ++ ": " ++ displayException ioe + displayError (FileError path e) = + path ++ ": " ++ displayError e + +-- ---------------------------------------------------------------------------- +-- Text envelopes +-- + +-- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/Serialise/TextEnvelope.hs + +newtype TextEnvelopeType = TextEnvelopeType String + deriving (Eq, Show) + deriving newtype (IsString, Semigroup, FromJSON) + +newtype TextEnvelopeDescr = TextEnvelopeDescr String + deriving (Eq, Show) + deriving newtype (IsString, Semigroup, FromJSON) + +-- | A 'TextEnvelope' is a structured envelope for serialised binary values +-- with an external format with a semi-readable textual format. +-- +-- It contains a \"type\" field, e.g. \"PublicKeyByron\" or \"TxSignedShelley\" +-- to indicate the type of the encoded data. This is used as a sanity check +-- and to help readers. +-- +-- It also contains a \"title\" field which is free-form, and could be used +-- to indicate the role or purpose to a reader. +data TextEnvelope = TextEnvelope + { teType :: !TextEnvelopeType + , teDescription :: !TextEnvelopeDescr + , teRawCBOR :: !ByteString + } + deriving (Eq, Show) + +instance HasTypeProxy TextEnvelope where + data AsType TextEnvelope = AsTextEnvelope + proxyToAsType _ = AsTextEnvelope + +instance FromJSON TextEnvelope where + parseJSON = withObject "TextEnvelope" $ \v -> + TextEnvelope + <$> (v .: "type") + <*> (v .: "description") + <*> (parseJSONBase16 =<< v .: "cborHex") + where + parseJSONBase16 v = + either fail return . Base16.decode . Text.encodeUtf8 =<< parseJSON v + +-- | The errors that the pure 'TextEnvelope' parsing\/decoding functions can return. +data TextEnvelopeError + = -- | expected, actual + TextEnvelopeTypeError ![TextEnvelopeType] !TextEnvelopeType + | TextEnvelopeDecodeError !DecoderError + | TextEnvelopeAesonDecodeError !String + deriving (Eq, Show) + +instance Error TextEnvelopeError where + displayError tee = + case tee of + TextEnvelopeTypeError [TextEnvelopeType expType] (TextEnvelopeType actType) -> + "TextEnvelope type error: " + <> " Expected: " + <> expType + <> " Actual: " + <> actType + TextEnvelopeTypeError expTypes (TextEnvelopeType actType) -> + "TextEnvelope type error: " + <> " Expected one of: " + <> mconcat [expType <> ", " | TextEnvelopeType expType <- expTypes] + <> " Actual: " + <> actType + TextEnvelopeAesonDecodeError decErr -> "TextEnvelope aeson decode error: " <> decErr + TextEnvelopeDecodeError decErr -> "TextEnvelope decode error: " <> show decErr + +-- | Check that the \"type\" of the 'TextEnvelope' is as expected. +-- +-- For example, one might check that the type is \"TxSignedShelley\". +expectTextEnvelopeOfType :: TextEnvelopeType -> TextEnvelope -> Either TextEnvelopeError () +expectTextEnvelopeOfType expectedType TextEnvelope{teType = actualType} = + unless (expectedType == actualType) $ + Left (TextEnvelopeTypeError [expectedType] actualType) + +class SerialiseAsCBOR a => HasTextEnvelope a where + textEnvelopeType :: AsType a -> TextEnvelopeType + +deserialiseFromTextEnvelope :: + HasTextEnvelope a => + AsType a -> + TextEnvelope -> + Either TextEnvelopeError a +deserialiseFromTextEnvelope ttoken te = do + expectTextEnvelopeOfType (textEnvelopeType ttoken) te + first TextEnvelopeDecodeError $ + deserialiseFromCBOR ttoken (teRawCBOR te) + +readFileTextEnvelope :: + HasTextEnvelope a => + AsType a -> + FilePath -> + IO (Either (FileError TextEnvelopeError) a) +readFileTextEnvelope ttoken path = + runExceptT $ do + content <- handleIOExceptT (FileIOError path) $ BS.readFile path + firstExceptT (FileError path) $ hoistEither $ do + te <- first TextEnvelopeAesonDecodeError $ Aeson.eitherDecodeStrict' content + deserialiseFromTextEnvelope ttoken te + +-- ---------------------------------------------------------------------------- +-- deriving via helpers +-- + +-- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/Serialise/Raw.hs (SerialiseUsing) + +-- | For use with @deriving via@, to provide 'ToCBOR' and 'FromCBOR' instances, +-- based on the 'SerialiseAsRawBytes' instance. Eg: +-- +-- > deriving (ToCBOR, FromCBOR) via (UsingRawBytes Blah) +newtype UsingRawBytes a = UsingRawBytes a + +instance (SerialiseAsRawBytes a, Typeable a) => ToCBOR (UsingRawBytes a) where + toCBOR (UsingRawBytes x) = toCBOR (serialiseToRawBytes x) + +instance (SerialiseAsRawBytes a, Typeable a) => FromCBOR (UsingRawBytes a) where + fromCBOR = do + bs <- fromCBOR + case deserialiseFromRawBytes ttoken bs of + Just x -> return (UsingRawBytes x) + Nothing -> fail ("cannot deserialise as a " ++ tname) + where + ttoken = proxyToAsType (Proxy :: Proxy a) + tname = (tyConName . typeRepTyCon . typeRep) (Proxy :: Proxy a) + +instance (SerialiseAsRawBytes a, Typeable a) => EncCBOR (UsingRawBytes a) + +instance (SerialiseAsRawBytes a, Typeable a) => DecCBOR (UsingRawBytes a) where + decCBOR = fromPlainDecoder fromCBOR + +-- | For use with @deriving via@, to provide instances for any\/all of 'Show', +-- 'IsString', 'ToJSON', 'FromJSON', 'ToJSONKey', FromJSONKey' using a hex +-- encoding, based on the 'SerialiseAsRawBytes' instance. +-- +-- > deriving (Show, IsString) via (UsingRawBytesHex Blah) +-- > deriving (ToJSON, FromJSON) via (UsingRawBytesHex Blah) +-- > deriving (ToJSONKey, FromJSONKey) via (UsingRawBytesHex Blah) +newtype UsingRawBytesHex a = UsingRawBytesHex a + +instance SerialiseAsRawBytes a => Show (UsingRawBytesHex a) where + show (UsingRawBytesHex x) = show (serialiseToRawBytesHex x) + +instance SerialiseAsRawBytes a => IsString (UsingRawBytesHex a) where + fromString = either error id . deserialiseFromRawBytesBase16 . BSC.pack + +instance SerialiseAsRawBytes a => ToJSON (UsingRawBytesHex a) where + toJSON (UsingRawBytesHex x) = toJSON (serialiseToRawBytesHexText x) + +instance (SerialiseAsRawBytes a, Typeable a) => FromJSON (UsingRawBytesHex a) where + parseJSON = + Aeson.withText tname $ + either fail pure . deserialiseFromRawBytesBase16 . Text.encodeUtf8 + where + tname = (tyConName . typeRepTyCon . typeRep) (Proxy :: Proxy a) + +instance SerialiseAsRawBytes a => ToJSONKey (UsingRawBytesHex a) where + toJSONKey = + Aeson.toJSONKeyText $ \(UsingRawBytesHex x) -> serialiseToRawBytesHexText x + +instance (SerialiseAsRawBytes a, Typeable a) => FromJSONKey (UsingRawBytesHex a) where + fromJSONKey = + Aeson.FromJSONKeyTextParser $ + either fail pure . deserialiseFromRawBytesBase16 . Text.encodeUtf8 + +deserialiseFromRawBytesBase16 :: + SerialiseAsRawBytes a => ByteString -> Either String (UsingRawBytesHex a) +deserialiseFromRawBytesBase16 str = + case Base16.decode str of + Right raw -> case deserialiseFromRawBytes ttoken raw of + Just x -> Right (UsingRawBytesHex x) + Nothing -> Left ("cannot deserialise " ++ show str) + Left msg -> Left ("invalid hex " ++ show str ++ ", " ++ msg) + where + ttoken = proxyToAsType (Proxy :: Proxy a) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Any.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Any.hs deleted file mode 100644 index 5a0250d830..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Any.hs +++ /dev/null @@ -1,164 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - -module Cardano.Api.Any - ( module Cardano.Api.Any - , module Cbor - , module Proxy - ) where - -import Cardano.Ledger.Binary as Cbor - ( DecCBOR (..) - , EncCBOR (..) - , FromCBOR (..) - , ToCBOR (..) - ) -import qualified Cardano.Ledger.Binary.Plain as CBOR -import Control.Exception (Exception (..), IOException, throwIO) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Base16 as Base16 (decode, encode) -import Data.Kind (Constraint, Type) -import Data.Proxy as Proxy (Proxy (..)) -import Data.Text as Text (Text) -import qualified Data.Text.Encoding as Text (decodeUtf8) -import System.IO (Handle) - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/HasTypeProxy.hs - -class HasTypeProxy t where - -- | A family of singleton types used in this API to indicate which type to - -- use where it would otherwise be ambiguous or merely unclear. - -- - -- Values of this type are passed to deserialisation functions for example. - data AsType t - - proxyToAsType :: Proxy t -> AsType t - -data FromSomeType (c :: Type -> Constraint) b where - FromSomeType :: c a => AsType a -> (a -> b) -> FromSomeType c b - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/Hash.hs - -data family Hash keyrole :: Type - -class CastHash roleA roleB where - castHash :: Hash roleA -> Hash roleB - -instance HasTypeProxy a => HasTypeProxy (Hash a) where - data AsType (Hash a) = AsHash (AsType a) - proxyToAsType _ = AsHash (proxyToAsType (Proxy :: Proxy a)) - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/SerialiseRaw.hs - -class HasTypeProxy a => SerialiseAsRawBytes a where - serialiseToRawBytes :: a -> ByteString - - deserialiseFromRawBytes :: AsType a -> ByteString -> Maybe a - -serialiseToRawBytesHex :: SerialiseAsRawBytes a => a -> ByteString -serialiseToRawBytesHex = Base16.encode . serialiseToRawBytes - -serialiseToRawBytesHexText :: SerialiseAsRawBytes a => a -> Text -serialiseToRawBytesHexText = Text.decodeUtf8 . serialiseToRawBytesHex - -deserialiseFromRawBytesHex :: - SerialiseAsRawBytes a => - AsType a -> ByteString -> Maybe a -deserialiseFromRawBytesHex proxy hex = - case Base16.decode hex of - Right raw -> deserialiseFromRawBytes proxy raw - Left _msg -> Nothing - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/SerialiseAsCBOR.hs - -class HasTypeProxy a => SerialiseAsCBOR a where - serialiseToCBOR :: a -> ByteString - deserialiseFromCBOR :: AsType a -> ByteString -> Either CBOR.DecoderError a - - default serialiseToCBOR :: ToCBOR a => a -> ByteString - serialiseToCBOR = CBOR.serialize' - - default deserialiseFromCBOR :: - FromCBOR a => - AsType a -> - ByteString -> - Either CBOR.DecoderError a - deserialiseFromCBOR _proxy = CBOR.decodeFull' - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/Error.hs - -class Show e => Error e where - displayError :: e -> String - -instance Error () where - displayError () = "" - --- | The preferred approach is to use 'Except' or 'ExceptT', but you can if --- necessary use IO exceptions. -throwErrorAsException :: Error e => e -> IO a -throwErrorAsException e = throwIO (ErrorAsException e) - -data ErrorAsException where - ErrorAsException :: Error e => e -> ErrorAsException - -instance Show ErrorAsException where - show (ErrorAsException e) = show e - -instance Exception ErrorAsException where - displayException (ErrorAsException e) = displayError e - -data FileError e - = FileError FilePath e - | FileErrorTempFile - -- | Target path - FilePath - -- | Temporary path - FilePath - Handle - | FileIOError FilePath IOException - deriving Show - -instance Error e => Error (FileError e) where - displayError (FileErrorTempFile targetPath tempPath h) = - "Error creating temporary file at: " - ++ tempPath - ++ "/n" - ++ "Target path: " - ++ targetPath - ++ "/n" - ++ "Handle: " - ++ show h - displayError (FileIOError path ioe) = - path ++ ": " ++ displayException ioe - displayError (FileError path e) = - path ++ ": " ++ displayError e - -instance Error IOException where - displayError = show - ---- WARNING: STUB for Bech32 - -class (HasTypeProxy a, SerialiseAsRawBytes a) => SerialiseAsBech32 a where - -- | The human readable prefix to use when encoding this value to Bech32. - bech32PrefixFor :: a -> Text - - -- | The set of human readable prefixes that can be used for this type. - bech32PrefixesPermitted :: AsType a -> [Text] - --- serialiseToBech32 :: SerialiseAsBech32 a => a -> Text -serialiseToBech32 :: a -> Text -serialiseToBech32 _ = error "serialiseToBech32: stub not implemented" - --- deserialiseFromBech32 :: SerialiseAsBech32 a => AsType a -> Text -> Either Bech32DecodeError a -deserialiseFromBech32 :: AsType a -> Text -> Either Bech32DecodeError a -deserialiseFromBech32 _ _ = error "deserialiseFromBech32: stub not implemented" - -data Bech32DecodeError - -instance Show Bech32DecodeError where - show = const "Bech32DecodeError: stub not implemented" - -instance Error Bech32DecodeError where - displayError = show diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Key.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Key.hs deleted file mode 100644 index d80a781a2c..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Key.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/Key.hs - -module Cardano.Api.Key - ( AsType (AsVerificationKey, AsSigningKey) - , CastSigningKeyRole (..) - , CastVerificationKeyRole (..) - , Key (..) - ) where - -import Cardano.Api.Any -import Cardano.Api.SerialiseTextEnvelope -import qualified Cardano.Crypto.DSIGN.Class as Crypto -import qualified Cardano.Crypto.Seed as Crypto -import Data.Kind (Type) - --- | An interface for cryptographic keys used for signatures with a 'SigningKey' --- and a 'VerificationKey' key. --- --- This interface does not provide actual signing or verifying functions since --- this API is concerned with the management of keys: generating and --- serialising. -class - ( Eq (VerificationKey keyrole) - , Show (VerificationKey keyrole) - , SerialiseAsRawBytes (Hash keyrole) - , HasTextEnvelope (VerificationKey keyrole) - , HasTextEnvelope (SigningKey keyrole) - ) => - Key keyrole - where - -- | The type of cryptographic verification key, for each key role. - data VerificationKey keyrole :: Type - - -- | The type of cryptographic signing key, for each key role. - data SigningKey keyrole :: Type - - -- | Get the corresponding verification key from a signing key. - getVerificationKey :: SigningKey keyrole -> VerificationKey keyrole - - -- | Generate a 'SigningKey' deterministically, given a 'Crypto.Seed'. The - -- required size of the seed is given by 'deterministicSigningKeySeedSize'. - deterministicSigningKey :: AsType keyrole -> Crypto.Seed -> SigningKey keyrole - - deterministicSigningKeySeedSize :: AsType keyrole -> Word - - verificationKeyHash :: VerificationKey keyrole -> Hash keyrole - - -- | Generate a 'SigningKey' using a seed from operating system entropy. - generateSigningKey :: AsType keyrole -> IO (SigningKey keyrole) - generateSigningKey keytype = do - -- - -- For KES we can override this to keep the seed and key in mlocked memory - -- at all times. - -- - seed <- Crypto.readSeedFromSystemEntropy seedSize - return $! deterministicSigningKey keytype seed - where - seedSize = deterministicSigningKeySeedSize keytype - -instance HasTypeProxy a => HasTypeProxy (VerificationKey a) where - data AsType (VerificationKey a) = AsVerificationKey (AsType a) - proxyToAsType _ = AsVerificationKey (proxyToAsType (Proxy :: Proxy a)) - -instance HasTypeProxy a => HasTypeProxy (SigningKey a) where - data AsType (SigningKey a) = AsSigningKey (AsType a) - proxyToAsType _ = AsSigningKey (proxyToAsType (Proxy :: Proxy a)) - --- | Some key roles share the same representation and it is sometimes --- legitimate to change the role of a key. -class CastVerificationKeyRole keyroleA keyroleB where - -- | Change the role of a 'VerificationKey', if the representation permits. - castVerificationKey :: VerificationKey keyroleA -> VerificationKey keyroleB - -class CastSigningKeyRole keyroleA keyroleB where - -- | Change the role of a 'SigningKey', if the representation permits. - castSigningKey :: SigningKey keyroleA -> SigningKey keyroleB diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysByron.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysByron.hs deleted file mode 100644 index f81e639945..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysByron.hs +++ /dev/null @@ -1,308 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/KeysByron.hs - --- | Byron key types and their 'Key' class instances -module Cardano.Api.KeysByron - ( -- * Key types - ByronKey - , ByronKeyLegacy - - -- * Data family instances - , AsType (..) - , Hash (..) - , SigningKey (..) - , VerificationKey (..) - - -- * Legacy format - , ByronKeyFormat (..) - , IsByronKey (..) - , SomeByronSigningKey (..) - , toByronSigningKey - ) where - -import Cardano.Api.Any -import Cardano.Api.Key -import Cardano.Api.KeysShelley -import Cardano.Api.SerialiseTextEnvelope -import Cardano.Api.SerialiseUsing -import qualified Cardano.Chain.Common as Byron -import qualified Cardano.Crypto.DSIGN.Class as Crypto -import qualified Cardano.Crypto.Hashing as Byron -import qualified Cardano.Crypto.Seed as Crypto -import qualified Cardano.Crypto.Signing as Byron -import qualified Cardano.Crypto.Signing as Crypto -import qualified Cardano.Crypto.Wallet as Crypto.HD -import Cardano.Ledger.Binary - ( byronProtVer - , toPlainDecoder - , toPlainEncoding - ) -import Cardano.Prelude (cborError, toCborError) -import qualified Codec.CBOR.Decoding as CBOR -import qualified Codec.CBOR.Read as CBOR -import qualified Codec.CBOR.Write as CBOR (toStrictByteString) -import Control.Monad -import qualified Data.ByteString.Lazy as LB -import Data.String (IsString) -import Data.Text (Text) -import qualified Data.Text as Text - --- | Byron-era payment keys. Used for Byron addresses and witnessing --- transactions that spend from these addresses. --- --- These use Ed25519 but with a 32byte \"chaincode\" used in HD derivation. --- The inclusion of the chaincode is a design mistake but one that cannot --- be corrected for the Byron era. The Shelley era 'PaymentKey's do not include --- a chaincode. It is safe to use a zero or random chaincode for new Byron keys. --- --- This is a type level tag, used with other interfaces like 'Key'. -data ByronKey - -data ByronKeyLegacy - -class IsByronKey key where - byronKeyFormat :: ByronKeyFormat key - -data ByronKeyFormat key where - ByronLegacyKeyFormat :: ByronKeyFormat ByronKeyLegacy - ByronModernKeyFormat :: ByronKeyFormat ByronKey - -data SomeByronSigningKey - = AByronSigningKeyLegacy (SigningKey ByronKeyLegacy) - | AByronSigningKey (SigningKey ByronKey) - -toByronSigningKey :: SomeByronSigningKey -> Byron.SigningKey -toByronSigningKey bWit = - case bWit of - AByronSigningKeyLegacy (ByronSigningKeyLegacy sKey) -> sKey - AByronSigningKey (ByronSigningKey sKey) -> sKey - --- --- Byron key --- - -instance Key ByronKey where - newtype VerificationKey ByronKey - = ByronVerificationKey Byron.VerificationKey - deriving stock Eq - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey ByronKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey ByronKey - = ByronSigningKey Byron.SigningKey - deriving (Show, IsString) via UsingRawBytesHex (SigningKey ByronKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType ByronKey -> Crypto.Seed -> SigningKey ByronKey - deterministicSigningKey AsByronKey seed = - ByronSigningKey (snd (Crypto.runMonadRandomWithSeed seed Byron.keyGen)) - - deterministicSigningKeySeedSize :: AsType ByronKey -> Word - deterministicSigningKeySeedSize AsByronKey = 32 - - getVerificationKey :: SigningKey ByronKey -> VerificationKey ByronKey - getVerificationKey (ByronSigningKey sk) = - ByronVerificationKey (Byron.toVerification sk) - - verificationKeyHash :: VerificationKey ByronKey -> Hash ByronKey - verificationKeyHash (ByronVerificationKey vkey) = - ByronKeyHash (Byron.hashKey vkey) - -instance HasTypeProxy ByronKey where - data AsType ByronKey = AsByronKey - proxyToAsType _ = AsByronKey - -instance HasTextEnvelope (VerificationKey ByronKey) where - textEnvelopeType _ = "PaymentVerificationKeyByron_ed25519_bip32" - -instance HasTextEnvelope (SigningKey ByronKey) where - textEnvelopeType _ = "PaymentSigningKeyByron_ed25519_bip32" - -instance SerialiseAsRawBytes (VerificationKey ByronKey) where - serialiseToRawBytes (ByronVerificationKey (Byron.VerificationKey xvk)) = - Crypto.HD.unXPub xvk - - deserialiseFromRawBytes (AsVerificationKey AsByronKey) bs = - either - (const Nothing) - (Just . ByronVerificationKey . Byron.VerificationKey) - (Crypto.HD.xpub bs) - -instance SerialiseAsRawBytes (SigningKey ByronKey) where - serialiseToRawBytes (ByronSigningKey (Byron.SigningKey xsk)) = - CBOR.toStrictByteString $ encCBORXPrv xsk - where - encCBORXPrv = toPlainEncoding byronProtVer . Crypto.encCBORXPrv - - deserialiseFromRawBytes (AsSigningKey AsByronKey) bs = - either - (const Nothing) - (Just . ByronSigningKey . Byron.SigningKey) - (snd <$> CBOR.deserialiseFromBytes decCBORXPrv (LB.fromStrict bs)) - where - decCBORXPrv = toPlainDecoder Nothing byronProtVer Byron.decCBORXPrv - -newtype instance Hash ByronKey = ByronKeyHash Byron.KeyHash - deriving (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash ByronKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash ByronKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash ByronKey) where - serialiseToRawBytes (ByronKeyHash (Byron.KeyHash vkh)) = - Byron.abstractHashToBytes vkh - - deserialiseFromRawBytes (AsHash AsByronKey) bs = - ByronKeyHash . Byron.KeyHash <$> Byron.abstractHashFromBytes bs - -instance CastVerificationKeyRole ByronKey PaymentExtendedKey where - castVerificationKey (ByronVerificationKey vk) = - PaymentExtendedVerificationKey - (Byron.unVerificationKey vk) - -instance CastVerificationKeyRole ByronKey PaymentKey where - castVerificationKey = - ( castVerificationKey :: - VerificationKey PaymentExtendedKey -> - VerificationKey PaymentKey - ) - . ( castVerificationKey :: - VerificationKey ByronKey -> - VerificationKey PaymentExtendedKey - ) - -instance IsByronKey ByronKey where - byronKeyFormat = ByronModernKeyFormat - --- --- Legacy Byron key --- - -instance Key ByronKeyLegacy where - newtype VerificationKey ByronKeyLegacy - = ByronVerificationKeyLegacy Byron.VerificationKey - deriving stock Eq - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey ByronKeyLegacy) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey ByronKeyLegacy - = ByronSigningKeyLegacy Byron.SigningKey - deriving (Show, IsString) via UsingRawBytesHex (SigningKey ByronKeyLegacy) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType ByronKeyLegacy -> Crypto.Seed -> SigningKey ByronKeyLegacy - deterministicSigningKey _ _ = error "Please generate a non legacy Byron key instead" - - deterministicSigningKeySeedSize :: AsType ByronKeyLegacy -> Word - deterministicSigningKeySeedSize AsByronKeyLegacy = 32 - - getVerificationKey :: SigningKey ByronKeyLegacy -> VerificationKey ByronKeyLegacy - getVerificationKey (ByronSigningKeyLegacy sk) = - ByronVerificationKeyLegacy (Byron.toVerification sk) - - verificationKeyHash :: VerificationKey ByronKeyLegacy -> Hash ByronKeyLegacy - verificationKeyHash (ByronVerificationKeyLegacy vkey) = - ByronKeyHashLegacy (Byron.hashKey vkey) - -instance HasTypeProxy ByronKeyLegacy where - data AsType ByronKeyLegacy = AsByronKeyLegacy - proxyToAsType _ = AsByronKeyLegacy - -instance HasTextEnvelope (VerificationKey ByronKeyLegacy) where - textEnvelopeType _ = "PaymentVerificationKeyByronLegacy_ed25519_bip32" - -instance HasTextEnvelope (SigningKey ByronKeyLegacy) where - textEnvelopeType _ = "PaymentSigningKeyByronLegacy_ed25519_bip32" - -newtype instance Hash ByronKeyLegacy = ByronKeyHashLegacy Byron.KeyHash - deriving (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash ByronKeyLegacy) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash ByronKeyLegacy) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash ByronKeyLegacy) where - serialiseToRawBytes (ByronKeyHashLegacy (Byron.KeyHash vkh)) = - Byron.abstractHashToBytes vkh - - deserialiseFromRawBytes (AsHash AsByronKeyLegacy) bs = - ByronKeyHashLegacy . Byron.KeyHash <$> Byron.abstractHashFromBytes bs - -instance SerialiseAsRawBytes (VerificationKey ByronKeyLegacy) where - serialiseToRawBytes (ByronVerificationKeyLegacy (Byron.VerificationKey xvk)) = - Crypto.HD.unXPub xvk - - deserialiseFromRawBytes (AsVerificationKey AsByronKeyLegacy) bs = - either - (const Nothing) - (Just . ByronVerificationKeyLegacy . Byron.VerificationKey) - (Crypto.HD.xpub bs) - -instance SerialiseAsRawBytes (SigningKey ByronKeyLegacy) where - serialiseToRawBytes (ByronSigningKeyLegacy (Byron.SigningKey xsk)) = - Crypto.HD.unXPrv xsk - - deserialiseFromRawBytes (AsSigningKey AsByronKeyLegacy) bs = - either - (const Nothing) - (Just . ByronSigningKeyLegacy . snd) - (CBOR.deserialiseFromBytes decodeLegacyDelegateKey $ LB.fromStrict bs) - where - -- Stolen from: cardano-sl/binary/src/Pos/Binary/Class/Core.hs - -- \| Enforces that the input size is the same as the decoded one, failing in - -- case it's not. - enforceSize :: Text -> Int -> CBOR.Decoder s () - enforceSize lbl requestedSize = CBOR.decodeListLenCanonical >>= matchSize requestedSize lbl - - -- Stolen from: cardano-sl/binary/src/Pos/Binary/Class/Core.hs - -- \| Compare two sizes, failing if they are not equal. - matchSize :: Int -> Text -> Int -> CBOR.Decoder s () - matchSize requestedSize lbl actualSize = - when (actualSize /= requestedSize) $ - cborError - ( lbl - <> " failed the size check. Expected " - <> Text.pack (show requestedSize) - <> ", found " - <> Text.pack (show actualSize) - ) - - decodeXPrv :: CBOR.Decoder s Crypto.HD.XPrv - decodeXPrv = CBOR.decodeBytesCanonical >>= toCborError . Crypto.HD.xprv - - -- \| Decoder for a Byron/Classic signing key. - -- Lifted from cardano-sl legacy codebase. - decodeLegacyDelegateKey :: CBOR.Decoder s Byron.SigningKey - decodeLegacyDelegateKey = do - enforceSize "UserSecret" 4 - _ <- do - enforceSize "vss" 1 - CBOR.decodeBytes - pkey <- do - enforceSize "pkey" 1 - Byron.SigningKey <$> decodeXPrv - _ <- do - CBOR.decodeListLenIndef - CBOR.decodeSequenceLenIndef (flip (:)) [] reverse CBOR.decodeNull - _ <- do - enforceSize "wallet" 0 - pure pkey - -instance CastVerificationKeyRole ByronKeyLegacy ByronKey where - castVerificationKey (ByronVerificationKeyLegacy vk) = - ByronVerificationKey vk - -instance IsByronKey ByronKeyLegacy where - byronKeyFormat = ByronLegacyKeyFormat diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysPraos.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysPraos.hs deleted file mode 100644 index 10ea879125..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysPraos.hs +++ /dev/null @@ -1,234 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/KeysPraos.hs - --- | Praos consensus key types and their 'Key' class instances -module Cardano.Api.KeysPraos - ( -- * Key types - UnsoundPureKesKey - , VrfKey - - -- * Data family instances - , AsType (..) - , Hash (..) - , SigningKey (..) - , VerificationKey (..) - ) where - -import Cardano.Api.Any -import Cardano.Api.Key -import Cardano.Api.SerialiseTextEnvelope -import Cardano.Api.SerialiseUsing -import qualified Cardano.Crypto.DSIGN.Class as Crypto -import qualified Cardano.Crypto.Hash.Class as Crypto -import qualified Cardano.Crypto.KES.Class as Crypto -import qualified Cardano.Crypto.VRF.Class as Crypto -import Cardano.Ledger.Binary (fromPlainDecoder) -import Cardano.Ledger.Hashes (HASH) -import Cardano.Protocol.Crypto (Crypto (..), StandardCrypto) -import Data.String (IsString (..)) - --- --- KES keys --- - -data UnsoundPureKesKey - -instance HasTypeProxy UnsoundPureKesKey where - data AsType UnsoundPureKesKey = AsUnsoundPureKesKey - proxyToAsType _ = AsUnsoundPureKesKey - -instance Key UnsoundPureKesKey where - newtype VerificationKey UnsoundPureKesKey - = KesVerificationKey (Crypto.VerKeyKES (KES StandardCrypto)) - deriving stock Eq - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey UnsoundPureKesKey) - deriving newtype (EncCBOR, DecCBOR, ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey UnsoundPureKesKey - = KesSigningKey (Crypto.UnsoundPureSignKeyKES (KES StandardCrypto)) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey UnsoundPureKesKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass (EncCBOR, SerialiseAsCBOR) - - -- This loses the mlock safety of the seed, since it starts from a normal in-memory seed. - deterministicSigningKey :: AsType UnsoundPureKesKey -> Crypto.Seed -> SigningKey UnsoundPureKesKey - deterministicSigningKey AsUnsoundPureKesKey = - KesSigningKey . Crypto.unsoundPureGenKeyKES - - deterministicSigningKeySeedSize :: AsType UnsoundPureKesKey -> Word - deterministicSigningKeySeedSize AsUnsoundPureKesKey = - Crypto.seedSizeKES proxy - where - proxy :: Proxy (KES StandardCrypto) - proxy = Proxy - - getVerificationKey :: SigningKey UnsoundPureKesKey -> VerificationKey UnsoundPureKesKey - getVerificationKey (KesSigningKey sk) = - KesVerificationKey (Crypto.unsoundPureDeriveVerKeyKES sk) - - verificationKeyHash :: VerificationKey UnsoundPureKesKey -> Hash UnsoundPureKesKey - verificationKeyHash (KesVerificationKey vkey) = - UnsoundPureKesKeyHash (Crypto.hashVerKeyKES vkey) - -instance DecCBOR (SigningKey UnsoundPureKesKey) where - decCBOR = fromPlainDecoder fromCBOR - -instance SerialiseAsRawBytes (VerificationKey UnsoundPureKesKey) where - serialiseToRawBytes (KesVerificationKey vk) = - Crypto.rawSerialiseVerKeyKES vk - - deserialiseFromRawBytes (AsVerificationKey AsUnsoundPureKesKey) bs = - KesVerificationKey - <$> Crypto.rawDeserialiseVerKeyKES bs - -instance SerialiseAsRawBytes (SigningKey UnsoundPureKesKey) where - serialiseToRawBytes (KesSigningKey sk) = - Crypto.rawSerialiseUnsoundPureSignKeyKES sk - - deserialiseFromRawBytes (AsSigningKey AsUnsoundPureKesKey) bs = - KesSigningKey <$> Crypto.rawDeserialiseUnsoundPureSignKeyKES bs - -instance SerialiseAsBech32 (VerificationKey UnsoundPureKesKey) where - bech32PrefixFor _ = "kes_vk" - bech32PrefixesPermitted _ = ["kes_vk"] - -instance SerialiseAsBech32 (SigningKey UnsoundPureKesKey) where - bech32PrefixFor _ = "kes_sk" - bech32PrefixesPermitted _ = ["kes_sk"] - -newtype instance Hash UnsoundPureKesKey - = UnsoundPureKesKeyHash - ( Crypto.Hash - HASH - (Crypto.VerKeyKES (KES StandardCrypto)) - ) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash UnsoundPureKesKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash UnsoundPureKesKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash UnsoundPureKesKey) where - serialiseToRawBytes (UnsoundPureKesKeyHash vkh) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsUnsoundPureKesKey) bs = - UnsoundPureKesKeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey UnsoundPureKesKey) where - textEnvelopeType _ = - "KesVerificationKey_" - <> fromString (Crypto.algorithmNameKES proxy) - where - proxy :: Proxy (KES StandardCrypto) - proxy = Proxy - -instance HasTextEnvelope (SigningKey UnsoundPureKesKey) where - textEnvelopeType _ = - "KesSigningKey_" - <> fromString (Crypto.algorithmNameKES proxy) - where - proxy :: Proxy (KES StandardCrypto) - proxy = Proxy - --- --- VRF keys --- - -data VrfKey - -instance HasTypeProxy VrfKey where - data AsType VrfKey = AsVrfKey - proxyToAsType _ = AsVrfKey - -instance Key VrfKey where - newtype VerificationKey VrfKey - = VrfVerificationKey (Crypto.VerKeyVRF (VRF StandardCrypto)) - deriving stock Eq - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey VrfKey) - deriving newtype (EncCBOR, DecCBOR, ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey VrfKey - = VrfSigningKey (Crypto.SignKeyVRF (VRF StandardCrypto)) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey VrfKey) - deriving newtype (EncCBOR, DecCBOR, ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType VrfKey -> Crypto.Seed -> SigningKey VrfKey - deterministicSigningKey AsVrfKey seed = - VrfSigningKey (Crypto.genKeyVRF seed) - - deterministicSigningKeySeedSize :: AsType VrfKey -> Word - deterministicSigningKeySeedSize AsVrfKey = - Crypto.seedSizeVRF proxy - where - proxy :: Proxy (VRF StandardCrypto) - proxy = Proxy - - getVerificationKey :: SigningKey VrfKey -> VerificationKey VrfKey - getVerificationKey (VrfSigningKey sk) = - VrfVerificationKey (Crypto.deriveVerKeyVRF sk) - - verificationKeyHash :: VerificationKey VrfKey -> Hash VrfKey - verificationKeyHash (VrfVerificationKey vkey) = - VrfKeyHash (Crypto.hashVerKeyVRF vkey) - -instance SerialiseAsRawBytes (VerificationKey VrfKey) where - serialiseToRawBytes (VrfVerificationKey vk) = - Crypto.rawSerialiseVerKeyVRF vk - - deserialiseFromRawBytes (AsVerificationKey AsVrfKey) bs = - VrfVerificationKey <$> Crypto.rawDeserialiseVerKeyVRF bs - -instance SerialiseAsRawBytes (SigningKey VrfKey) where - serialiseToRawBytes (VrfSigningKey sk) = - Crypto.rawSerialiseSignKeyVRF sk - - deserialiseFromRawBytes (AsSigningKey AsVrfKey) bs = - VrfSigningKey <$> Crypto.rawDeserialiseSignKeyVRF bs - -instance SerialiseAsBech32 (VerificationKey VrfKey) where - bech32PrefixFor _ = "vrf_vk" - bech32PrefixesPermitted _ = ["vrf_vk"] - -instance SerialiseAsBech32 (SigningKey VrfKey) where - bech32PrefixFor _ = "vrf_sk" - bech32PrefixesPermitted _ = ["vrf_sk"] - -newtype instance Hash VrfKey - = VrfKeyHash - ( Crypto.Hash - HASH - (Crypto.VerKeyVRF (VRF StandardCrypto)) - ) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash VrfKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash VrfKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash VrfKey) where - serialiseToRawBytes (VrfKeyHash vkh) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsVrfKey) bs = - VrfKeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey VrfKey) where - textEnvelopeType _ = "VrfVerificationKey_" <> fromString (Crypto.algorithmNameVRF proxy) - where - proxy :: Proxy (VRF StandardCrypto) - proxy = Proxy - -instance HasTextEnvelope (SigningKey VrfKey) where - textEnvelopeType _ = "VrfSigningKey_" <> fromString (Crypto.algorithmNameVRF proxy) - where - proxy :: Proxy (VRF StandardCrypto) - proxy = Proxy diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysShelley.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysShelley.hs deleted file mode 100644 index 10abdafdd8..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysShelley.hs +++ /dev/null @@ -1,1235 +0,0 @@ --- The Shelley ledger uses promoted data kinds which we have to use, but we do --- not export any from this API. We also use them unticked as nature intended. -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/KeysShelley.hs - --- | Shelley key types and their 'Key' class instances -module Cardano.Api.KeysShelley - ( -- * Key types - GenesisDelegateExtendedKey - , GenesisDelegateKey - , GenesisExtendedKey - , GenesisKey - , GenesisUTxOKey - , PaymentExtendedKey - , PaymentKey - , StakeExtendedKey - , StakeKey - , StakePoolKey - - -- * Data family instances - , AsType (..) - , Hash (..) - , SigningKey (..) - , VerificationKey (..) - ) where - -import Cardano.Api.Any -import Cardano.Api.Key -import Cardano.Api.SerialiseTextEnvelope -import Cardano.Api.SerialiseUsing -import Cardano.Crypto.DSIGN (SignKeyDSIGN) -import qualified Cardano.Crypto.DSIGN.Class as Crypto -import qualified Cardano.Crypto.Hash.Class as Crypto -import qualified Cardano.Crypto.Seed as Crypto -import qualified Cardano.Crypto.Wallet as Crypto.HD -import Cardano.Ledger.Keys (DSIGN) -import qualified Cardano.Ledger.Keys as Shelley -import Data.Aeson.Types - ( FromJSON (..) - , ToJSON (..) - , ToJSONKey (..) - , toJSONKeyText - , withText - ) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.Maybe -import Data.String (IsString (..)) -import qualified Data.Text as Text - --- --- Shelley payment keys --- - --- | Shelley-era payment keys. Used for Shelley payment addresses and witnessing --- transactions that spend from these addresses. --- --- This is a type level tag, used with other interfaces like 'Key'. -data PaymentKey - -instance HasTypeProxy PaymentKey where - data AsType PaymentKey = AsPaymentKey - proxyToAsType _ = AsPaymentKey - -instance Key PaymentKey where - newtype VerificationKey PaymentKey - = PaymentVerificationKey (Shelley.VKey Shelley.Payment) - deriving stock Eq - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey PaymentKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey PaymentKey - = PaymentSigningKey (SignKeyDSIGN DSIGN) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey PaymentKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType PaymentKey -> Crypto.Seed -> SigningKey PaymentKey - deterministicSigningKey AsPaymentKey seed = - PaymentSigningKey (Crypto.genKeyDSIGN seed) - - deterministicSigningKeySeedSize :: AsType PaymentKey -> Word - deterministicSigningKeySeedSize AsPaymentKey = - Crypto.seedSizeDSIGN proxy - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - - getVerificationKey :: SigningKey PaymentKey -> VerificationKey PaymentKey - getVerificationKey (PaymentSigningKey sk) = - PaymentVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) - - verificationKeyHash :: VerificationKey PaymentKey -> Hash PaymentKey - verificationKeyHash (PaymentVerificationKey vkey) = - PaymentKeyHash (Shelley.hashKey vkey) - -instance SerialiseAsRawBytes (VerificationKey PaymentKey) where - serialiseToRawBytes (PaymentVerificationKey (Shelley.VKey vk)) = - Crypto.rawSerialiseVerKeyDSIGN vk - - deserialiseFromRawBytes (AsVerificationKey AsPaymentKey) bs = - PaymentVerificationKey . Shelley.VKey - <$> Crypto.rawDeserialiseVerKeyDSIGN bs - -instance SerialiseAsRawBytes (SigningKey PaymentKey) where - serialiseToRawBytes (PaymentSigningKey sk) = - Crypto.rawSerialiseSignKeyDSIGN sk - - deserialiseFromRawBytes (AsSigningKey AsPaymentKey) bs = - PaymentSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs - -instance SerialiseAsBech32 (VerificationKey PaymentKey) where - bech32PrefixFor _ = "addr_vk" - bech32PrefixesPermitted _ = ["addr_vk"] - -instance SerialiseAsBech32 (SigningKey PaymentKey) where - bech32PrefixFor _ = "addr_sk" - bech32PrefixesPermitted _ = ["addr_sk"] - -newtype instance Hash PaymentKey - = PaymentKeyHash (Shelley.KeyHash Shelley.Payment) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash PaymentKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash PaymentKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash PaymentKey) where - serialiseToRawBytes (PaymentKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsPaymentKey) bs = - PaymentKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey PaymentKey) where - textEnvelopeType _ = - "PaymentVerificationKeyShelley_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - -instance HasTextEnvelope (SigningKey PaymentKey) where - textEnvelopeType _ = - "PaymentSigningKeyShelley_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - --- --- Shelley payment extended ed25519 keys --- - --- | Shelley-era payment keys using extended ed25519 cryptographic keys. --- --- They can be used for Shelley payment addresses and witnessing --- transactions that spend from these addresses. --- --- These extended keys are used by HD wallets. So this type provides --- interoperability with HD wallets. The ITN CLI also supported this key type. --- --- The extended verification keys can be converted (via 'castVerificationKey') --- to ordinary keys (i.e. 'VerificationKey' 'PaymentKey') but this is /not/ the --- case for the signing keys. The signing keys can be used to witness --- transactions directly, with verification via their non-extended verification --- key ('VerificationKey' 'PaymentKey'). --- --- This is a type level tag, used with other interfaces like 'Key'. -data PaymentExtendedKey - -instance HasTypeProxy PaymentExtendedKey where - data AsType PaymentExtendedKey = AsPaymentExtendedKey - proxyToAsType _ = AsPaymentExtendedKey - -instance Key PaymentExtendedKey where - newtype VerificationKey PaymentExtendedKey - = PaymentExtendedVerificationKey Crypto.HD.XPub - deriving stock Eq - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey PaymentExtendedKey) - - newtype SigningKey PaymentExtendedKey - = PaymentExtendedSigningKey Crypto.HD.XPrv - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (SigningKey PaymentExtendedKey) - - deterministicSigningKey :: - AsType PaymentExtendedKey -> - Crypto.Seed -> - SigningKey PaymentExtendedKey - deterministicSigningKey AsPaymentExtendedKey seed = - PaymentExtendedSigningKey - (Crypto.HD.generate seedbs BS.empty) - where - (seedbs, _) = Crypto.getBytesFromSeedT 32 seed - - deterministicSigningKeySeedSize :: AsType PaymentExtendedKey -> Word - deterministicSigningKeySeedSize AsPaymentExtendedKey = 32 - - getVerificationKey :: - SigningKey PaymentExtendedKey -> - VerificationKey PaymentExtendedKey - getVerificationKey (PaymentExtendedSigningKey sk) = - PaymentExtendedVerificationKey (Crypto.HD.toXPub sk) - - -- \| We use the hash of the normal non-extended pub key so that it is - -- consistent with the one used in addresses and signatures. - verificationKeyHash :: - VerificationKey PaymentExtendedKey -> - Hash PaymentExtendedKey - verificationKeyHash (PaymentExtendedVerificationKey vk) = - PaymentExtendedKeyHash - . Shelley.KeyHash - . Crypto.castHash - $ Crypto.hashWith Crypto.HD.xpubPublicKey vk - -instance ToCBOR (VerificationKey PaymentExtendedKey) where - toCBOR (PaymentExtendedVerificationKey xpub) = - toCBOR (Crypto.HD.unXPub xpub) - -instance FromCBOR (VerificationKey PaymentExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either - fail - (return . PaymentExtendedVerificationKey) - (Crypto.HD.xpub (bs :: ByteString)) - -instance ToCBOR (SigningKey PaymentExtendedKey) where - toCBOR (PaymentExtendedSigningKey xprv) = - toCBOR (Crypto.HD.unXPrv xprv) - -instance FromCBOR (SigningKey PaymentExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either - fail - (return . PaymentExtendedSigningKey) - (Crypto.HD.xprv (bs :: ByteString)) - -instance SerialiseAsRawBytes (VerificationKey PaymentExtendedKey) where - serialiseToRawBytes (PaymentExtendedVerificationKey xpub) = - Crypto.HD.unXPub xpub - - deserialiseFromRawBytes (AsVerificationKey AsPaymentExtendedKey) bs = - either - (const Nothing) - (Just . PaymentExtendedVerificationKey) - (Crypto.HD.xpub bs) - -instance SerialiseAsRawBytes (SigningKey PaymentExtendedKey) where - serialiseToRawBytes (PaymentExtendedSigningKey xprv) = - Crypto.HD.unXPrv xprv - - deserialiseFromRawBytes (AsSigningKey AsPaymentExtendedKey) bs = - either - (const Nothing) - (Just . PaymentExtendedSigningKey) - (Crypto.HD.xprv bs) - -instance SerialiseAsBech32 (VerificationKey PaymentExtendedKey) where - bech32PrefixFor _ = "addr_xvk" - bech32PrefixesPermitted _ = ["addr_xvk"] - -instance SerialiseAsBech32 (SigningKey PaymentExtendedKey) where - bech32PrefixFor _ = "addr_xsk" - bech32PrefixesPermitted _ = ["addr_xsk"] - -newtype instance Hash PaymentExtendedKey - = PaymentExtendedKeyHash (Shelley.KeyHash Shelley.Payment) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash PaymentExtendedKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash PaymentExtendedKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash PaymentExtendedKey) where - serialiseToRawBytes (PaymentExtendedKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsPaymentExtendedKey) bs = - PaymentExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey PaymentExtendedKey) where - textEnvelopeType _ = "PaymentExtendedVerificationKeyShelley_ed25519_bip32" - -instance HasTextEnvelope (SigningKey PaymentExtendedKey) where - textEnvelopeType _ = "PaymentExtendedSigningKeyShelley_ed25519_bip32" - -instance CastVerificationKeyRole PaymentExtendedKey PaymentKey where - castVerificationKey (PaymentExtendedVerificationKey vk) = - PaymentVerificationKey - . Shelley.VKey - . fromMaybe impossible - . Crypto.rawDeserialiseVerKeyDSIGN - . Crypto.HD.xpubPublicKey - $ vk - where - impossible = - error "castVerificationKey: byron and shelley key sizes do not match!" - --- --- Stake keys --- - -data StakeKey - -instance HasTypeProxy StakeKey where - data AsType StakeKey = AsStakeKey - proxyToAsType _ = AsStakeKey - -instance Key StakeKey where - newtype VerificationKey StakeKey - = StakeVerificationKey (Shelley.VKey Shelley.Staking) - deriving stock Eq - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey StakeKey) - - newtype SigningKey StakeKey - = StakeSigningKey (SignKeyDSIGN DSIGN) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (SigningKey StakeKey) - - deterministicSigningKey :: AsType StakeKey -> Crypto.Seed -> SigningKey StakeKey - deterministicSigningKey AsStakeKey seed = - StakeSigningKey (Crypto.genKeyDSIGN seed) - - deterministicSigningKeySeedSize :: AsType StakeKey -> Word - deterministicSigningKeySeedSize AsStakeKey = - Crypto.seedSizeDSIGN proxy - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - - getVerificationKey :: SigningKey StakeKey -> VerificationKey StakeKey - getVerificationKey (StakeSigningKey sk) = - StakeVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) - - verificationKeyHash :: VerificationKey StakeKey -> Hash StakeKey - verificationKeyHash (StakeVerificationKey vkey) = - StakeKeyHash (Shelley.hashKey vkey) - -instance SerialiseAsRawBytes (VerificationKey StakeKey) where - serialiseToRawBytes (StakeVerificationKey (Shelley.VKey vk)) = - Crypto.rawSerialiseVerKeyDSIGN vk - - deserialiseFromRawBytes (AsVerificationKey AsStakeKey) bs = - StakeVerificationKey . Shelley.VKey - <$> Crypto.rawDeserialiseVerKeyDSIGN bs - -instance SerialiseAsRawBytes (SigningKey StakeKey) where - serialiseToRawBytes (StakeSigningKey sk) = - Crypto.rawSerialiseSignKeyDSIGN sk - - deserialiseFromRawBytes (AsSigningKey AsStakeKey) bs = - StakeSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs - -instance SerialiseAsBech32 (VerificationKey StakeKey) where - bech32PrefixFor _ = "stake_vk" - bech32PrefixesPermitted _ = ["stake_vk"] - -instance SerialiseAsBech32 (SigningKey StakeKey) where - bech32PrefixFor _ = "stake_sk" - bech32PrefixesPermitted _ = ["stake_sk"] - -newtype instance Hash StakeKey - = StakeKeyHash (Shelley.KeyHash Shelley.Staking) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash StakeKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash StakeKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash StakeKey) where - serialiseToRawBytes (StakeKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsStakeKey) bs = - StakeKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey StakeKey) where - textEnvelopeType _ = - "StakeVerificationKeyShelley_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - -instance HasTextEnvelope (SigningKey StakeKey) where - textEnvelopeType _ = - "StakeSigningKeyShelley_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - --- --- Shelley stake extended ed25519 keys --- - --- | Shelley-era stake keys using extended ed25519 cryptographic keys. --- --- They can be used for Shelley stake addresses and witnessing transactions --- that use stake addresses. --- --- These extended keys are used by HD wallets. So this type provides --- interoperability with HD wallets. The ITN CLI also supported this key type. --- --- The extended verification keys can be converted (via 'castVerificationKey') --- to ordinary keys (i.e. 'VerificationKey' 'StakeKey') but this is /not/ the --- case for the signing keys. The signing keys can be used to witness --- transactions directly, with verification via their non-extended verification --- key ('VerificationKey' 'StakeKey'). --- --- This is a type level tag, used with other interfaces like 'Key'. -data StakeExtendedKey - -instance HasTypeProxy StakeExtendedKey where - data AsType StakeExtendedKey = AsStakeExtendedKey - proxyToAsType _ = AsStakeExtendedKey - -instance Key StakeExtendedKey where - newtype VerificationKey StakeExtendedKey - = StakeExtendedVerificationKey Crypto.HD.XPub - deriving stock Eq - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey StakeExtendedKey) - - newtype SigningKey StakeExtendedKey - = StakeExtendedSigningKey Crypto.HD.XPrv - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (SigningKey StakeExtendedKey) - - deterministicSigningKey :: - AsType StakeExtendedKey -> - Crypto.Seed -> - SigningKey StakeExtendedKey - deterministicSigningKey AsStakeExtendedKey seed = - StakeExtendedSigningKey - (Crypto.HD.generate seedbs BS.empty) - where - (seedbs, _) = Crypto.getBytesFromSeedT 32 seed - - deterministicSigningKeySeedSize :: AsType StakeExtendedKey -> Word - deterministicSigningKeySeedSize AsStakeExtendedKey = 32 - - getVerificationKey :: - SigningKey StakeExtendedKey -> - VerificationKey StakeExtendedKey - getVerificationKey (StakeExtendedSigningKey sk) = - StakeExtendedVerificationKey (Crypto.HD.toXPub sk) - - -- \| We use the hash of the normal non-extended pub key so that it is - -- consistent with the one used in addresses and signatures. - verificationKeyHash :: - VerificationKey StakeExtendedKey -> - Hash StakeExtendedKey - verificationKeyHash (StakeExtendedVerificationKey vk) = - StakeExtendedKeyHash - . Shelley.KeyHash - . Crypto.castHash - $ Crypto.hashWith Crypto.HD.xpubPublicKey vk - -instance ToCBOR (VerificationKey StakeExtendedKey) where - toCBOR (StakeExtendedVerificationKey xpub) = - toCBOR (Crypto.HD.unXPub xpub) - -instance FromCBOR (VerificationKey StakeExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either - fail - (return . StakeExtendedVerificationKey) - (Crypto.HD.xpub (bs :: ByteString)) - -instance ToCBOR (SigningKey StakeExtendedKey) where - toCBOR (StakeExtendedSigningKey xprv) = - toCBOR (Crypto.HD.unXPrv xprv) - -instance FromCBOR (SigningKey StakeExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either - fail - (return . StakeExtendedSigningKey) - (Crypto.HD.xprv (bs :: ByteString)) - -instance SerialiseAsRawBytes (VerificationKey StakeExtendedKey) where - serialiseToRawBytes (StakeExtendedVerificationKey xpub) = - Crypto.HD.unXPub xpub - - deserialiseFromRawBytes (AsVerificationKey AsStakeExtendedKey) bs = - either - (const Nothing) - (Just . StakeExtendedVerificationKey) - (Crypto.HD.xpub bs) - -instance SerialiseAsRawBytes (SigningKey StakeExtendedKey) where - serialiseToRawBytes (StakeExtendedSigningKey xprv) = - Crypto.HD.unXPrv xprv - - deserialiseFromRawBytes (AsSigningKey AsStakeExtendedKey) bs = - either - (const Nothing) - (Just . StakeExtendedSigningKey) - (Crypto.HD.xprv bs) - -instance SerialiseAsBech32 (VerificationKey StakeExtendedKey) where - bech32PrefixFor _ = "stake_xvk" - bech32PrefixesPermitted _ = ["stake_xvk"] - -instance SerialiseAsBech32 (SigningKey StakeExtendedKey) where - bech32PrefixFor _ = "stake_xsk" - bech32PrefixesPermitted _ = ["stake_xsk"] - -newtype instance Hash StakeExtendedKey - = StakeExtendedKeyHash (Shelley.KeyHash Shelley.Staking) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash StakeExtendedKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash StakeExtendedKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash StakeExtendedKey) where - serialiseToRawBytes (StakeExtendedKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsStakeExtendedKey) bs = - StakeExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey StakeExtendedKey) where - textEnvelopeType _ = "StakeExtendedVerificationKeyShelley_ed25519_bip32" - -instance HasTextEnvelope (SigningKey StakeExtendedKey) where - textEnvelopeType _ = "StakeExtendedSigningKeyShelley_ed25519_bip32" - -instance CastVerificationKeyRole StakeExtendedKey StakeKey where - castVerificationKey (StakeExtendedVerificationKey vk) = - StakeVerificationKey - . Shelley.VKey - . fromMaybe impossible - . Crypto.rawDeserialiseVerKeyDSIGN - . Crypto.HD.xpubPublicKey - $ vk - where - impossible = - error "castVerificationKey: byron and shelley key sizes do not match!" - --- --- Genesis keys --- - -data GenesisKey - -instance HasTypeProxy GenesisKey where - data AsType GenesisKey = AsGenesisKey - proxyToAsType _ = AsGenesisKey - -instance Key GenesisKey where - newtype VerificationKey GenesisKey - = GenesisVerificationKey (Shelley.VKey Shelley.GenesisRole) - deriving stock Eq - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey GenesisKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey GenesisKey - = GenesisSigningKey (SignKeyDSIGN DSIGN) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey GenesisKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType GenesisKey -> Crypto.Seed -> SigningKey GenesisKey - deterministicSigningKey AsGenesisKey seed = - GenesisSigningKey (Crypto.genKeyDSIGN seed) - - deterministicSigningKeySeedSize :: AsType GenesisKey -> Word - deterministicSigningKeySeedSize AsGenesisKey = - Crypto.seedSizeDSIGN proxy - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - - getVerificationKey :: SigningKey GenesisKey -> VerificationKey GenesisKey - getVerificationKey (GenesisSigningKey sk) = - GenesisVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) - - verificationKeyHash :: VerificationKey GenesisKey -> Hash GenesisKey - verificationKeyHash (GenesisVerificationKey vkey) = - GenesisKeyHash (Shelley.hashKey vkey) - -instance SerialiseAsRawBytes (VerificationKey GenesisKey) where - serialiseToRawBytes (GenesisVerificationKey (Shelley.VKey vk)) = - Crypto.rawSerialiseVerKeyDSIGN vk - - deserialiseFromRawBytes (AsVerificationKey AsGenesisKey) bs = - GenesisVerificationKey . Shelley.VKey - <$> Crypto.rawDeserialiseVerKeyDSIGN bs - -instance SerialiseAsRawBytes (SigningKey GenesisKey) where - serialiseToRawBytes (GenesisSigningKey sk) = - Crypto.rawSerialiseSignKeyDSIGN sk - - deserialiseFromRawBytes (AsSigningKey AsGenesisKey) bs = - GenesisSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs - -newtype instance Hash GenesisKey - = GenesisKeyHash (Shelley.KeyHash Shelley.GenesisRole) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash GenesisKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash GenesisKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash GenesisKey) where - serialiseToRawBytes (GenesisKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsGenesisKey) bs = - GenesisKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey GenesisKey) where - textEnvelopeType _ = - "GenesisVerificationKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - -instance HasTextEnvelope (SigningKey GenesisKey) where - textEnvelopeType _ = - "GenesisSigningKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - --- --- Shelley genesis extended ed25519 keys --- - --- | Shelley-era genesis keys using extended ed25519 cryptographic keys. --- --- These serve the same role as normal genesis keys, but are here to support --- legacy Byron genesis keys which used extended keys. --- --- The extended verification keys can be converted (via 'castVerificationKey') --- to ordinary keys (i.e. 'VerificationKey' 'GenesisKey') but this is /not/ the --- case for the signing keys. The signing keys can be used to witness --- transactions directly, with verification via their non-extended verification --- key ('VerificationKey' 'GenesisKey'). --- --- This is a type level tag, used with other interfaces like 'Key'. -data GenesisExtendedKey - -instance HasTypeProxy GenesisExtendedKey where - data AsType GenesisExtendedKey = AsGenesisExtendedKey - proxyToAsType _ = AsGenesisExtendedKey - -instance Key GenesisExtendedKey where - newtype VerificationKey GenesisExtendedKey - = GenesisExtendedVerificationKey Crypto.HD.XPub - deriving stock Eq - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey GenesisExtendedKey) - - newtype SigningKey GenesisExtendedKey - = GenesisExtendedSigningKey Crypto.HD.XPrv - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (SigningKey GenesisExtendedKey) - - deterministicSigningKey :: - AsType GenesisExtendedKey -> - Crypto.Seed -> - SigningKey GenesisExtendedKey - deterministicSigningKey AsGenesisExtendedKey seed = - GenesisExtendedSigningKey - (Crypto.HD.generate seedbs BS.empty) - where - (seedbs, _) = Crypto.getBytesFromSeedT 32 seed - - deterministicSigningKeySeedSize :: AsType GenesisExtendedKey -> Word - deterministicSigningKeySeedSize AsGenesisExtendedKey = 32 - - getVerificationKey :: - SigningKey GenesisExtendedKey -> - VerificationKey GenesisExtendedKey - getVerificationKey (GenesisExtendedSigningKey sk) = - GenesisExtendedVerificationKey (Crypto.HD.toXPub sk) - - -- \| We use the hash of the normal non-extended pub key so that it is - -- consistent with the one used in addresses and signatures. - verificationKeyHash :: - VerificationKey GenesisExtendedKey -> - Hash GenesisExtendedKey - verificationKeyHash (GenesisExtendedVerificationKey vk) = - GenesisExtendedKeyHash - . Shelley.KeyHash - . Crypto.castHash - $ Crypto.hashWith Crypto.HD.xpubPublicKey vk - -instance ToCBOR (VerificationKey GenesisExtendedKey) where - toCBOR (GenesisExtendedVerificationKey xpub) = - toCBOR (Crypto.HD.unXPub xpub) - -instance FromCBOR (VerificationKey GenesisExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either - fail - (return . GenesisExtendedVerificationKey) - (Crypto.HD.xpub (bs :: ByteString)) - -instance ToCBOR (SigningKey GenesisExtendedKey) where - toCBOR (GenesisExtendedSigningKey xprv) = - toCBOR (Crypto.HD.unXPrv xprv) - -instance FromCBOR (SigningKey GenesisExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either - fail - (return . GenesisExtendedSigningKey) - (Crypto.HD.xprv (bs :: ByteString)) - -instance SerialiseAsRawBytes (VerificationKey GenesisExtendedKey) where - serialiseToRawBytes (GenesisExtendedVerificationKey xpub) = - Crypto.HD.unXPub xpub - - deserialiseFromRawBytes (AsVerificationKey AsGenesisExtendedKey) bs = - either - (const Nothing) - (Just . GenesisExtendedVerificationKey) - (Crypto.HD.xpub bs) - -instance SerialiseAsRawBytes (SigningKey GenesisExtendedKey) where - serialiseToRawBytes (GenesisExtendedSigningKey xprv) = - Crypto.HD.unXPrv xprv - - deserialiseFromRawBytes (AsSigningKey AsGenesisExtendedKey) bs = - either - (const Nothing) - (Just . GenesisExtendedSigningKey) - (Crypto.HD.xprv bs) - -newtype instance Hash GenesisExtendedKey - = GenesisExtendedKeyHash (Shelley.KeyHash Shelley.Staking) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash GenesisExtendedKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash GenesisExtendedKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash GenesisExtendedKey) where - serialiseToRawBytes (GenesisExtendedKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsGenesisExtendedKey) bs = - GenesisExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey GenesisExtendedKey) where - textEnvelopeType _ = "GenesisExtendedVerificationKey_ed25519_bip32" - -instance HasTextEnvelope (SigningKey GenesisExtendedKey) where - textEnvelopeType _ = "GenesisExtendedSigningKey_ed25519_bip32" - -instance CastVerificationKeyRole GenesisExtendedKey GenesisKey where - castVerificationKey (GenesisExtendedVerificationKey vk) = - GenesisVerificationKey - . Shelley.VKey - . fromMaybe impossible - . Crypto.rawDeserialiseVerKeyDSIGN - . Crypto.HD.xpubPublicKey - $ vk - where - impossible = - error "castVerificationKey: byron and shelley key sizes do not match!" - --- --- Genesis delegate keys --- - -data GenesisDelegateKey - -instance HasTypeProxy GenesisDelegateKey where - data AsType GenesisDelegateKey = AsGenesisDelegateKey - proxyToAsType _ = AsGenesisDelegateKey - -instance Key GenesisDelegateKey where - newtype VerificationKey GenesisDelegateKey - = GenesisDelegateVerificationKey (Shelley.VKey Shelley.GenesisDelegate) - deriving stock Eq - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey GenesisDelegateKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey GenesisDelegateKey - = GenesisDelegateSigningKey ((SignKeyDSIGN DSIGN)) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey GenesisDelegateKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType GenesisDelegateKey -> Crypto.Seed -> SigningKey GenesisDelegateKey - deterministicSigningKey AsGenesisDelegateKey seed = - GenesisDelegateSigningKey (Crypto.genKeyDSIGN seed) - - deterministicSigningKeySeedSize :: AsType GenesisDelegateKey -> Word - deterministicSigningKeySeedSize AsGenesisDelegateKey = - Crypto.seedSizeDSIGN proxy - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - - getVerificationKey :: SigningKey GenesisDelegateKey -> VerificationKey GenesisDelegateKey - getVerificationKey (GenesisDelegateSigningKey sk) = - GenesisDelegateVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) - - verificationKeyHash :: VerificationKey GenesisDelegateKey -> Hash GenesisDelegateKey - verificationKeyHash (GenesisDelegateVerificationKey vkey) = - GenesisDelegateKeyHash (Shelley.hashKey vkey) - -instance SerialiseAsRawBytes (VerificationKey GenesisDelegateKey) where - serialiseToRawBytes (GenesisDelegateVerificationKey (Shelley.VKey vk)) = - Crypto.rawSerialiseVerKeyDSIGN vk - - deserialiseFromRawBytes (AsVerificationKey AsGenesisDelegateKey) bs = - GenesisDelegateVerificationKey . Shelley.VKey - <$> Crypto.rawDeserialiseVerKeyDSIGN bs - -instance SerialiseAsRawBytes (SigningKey GenesisDelegateKey) where - serialiseToRawBytes (GenesisDelegateSigningKey sk) = - Crypto.rawSerialiseSignKeyDSIGN sk - - deserialiseFromRawBytes (AsSigningKey AsGenesisDelegateKey) bs = - GenesisDelegateSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs - -newtype instance Hash GenesisDelegateKey - = GenesisDelegateKeyHash (Shelley.KeyHash Shelley.GenesisDelegate) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash GenesisDelegateKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash GenesisDelegateKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash GenesisDelegateKey) where - serialiseToRawBytes (GenesisDelegateKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsGenesisDelegateKey) bs = - GenesisDelegateKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey GenesisDelegateKey) where - textEnvelopeType _ = - "GenesisDelegateVerificationKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - -instance HasTextEnvelope (SigningKey GenesisDelegateKey) where - textEnvelopeType _ = - "GenesisDelegateSigningKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - -instance CastVerificationKeyRole GenesisDelegateKey StakePoolKey where - castVerificationKey (GenesisDelegateVerificationKey (Shelley.VKey vkey)) = - StakePoolVerificationKey (Shelley.VKey vkey) - -instance CastSigningKeyRole GenesisDelegateKey StakePoolKey where - castSigningKey (GenesisDelegateSigningKey skey) = - StakePoolSigningKey skey - --- --- Shelley genesis delegate extended ed25519 keys --- - --- | Shelley-era genesis keys using extended ed25519 cryptographic keys. --- --- These serve the same role as normal genesis keys, but are here to support --- legacy Byron genesis keys which used extended keys. --- --- The extended verification keys can be converted (via 'castVerificationKey') --- to ordinary keys (i.e. 'VerificationKey' 'GenesisKey') but this is /not/ the --- case for the signing keys. The signing keys can be used to witness --- transactions directly, with verification via their non-extended verification --- key ('VerificationKey' 'GenesisKey'). --- --- This is a type level tag, used with other interfaces like 'Key'. -data GenesisDelegateExtendedKey - -instance HasTypeProxy GenesisDelegateExtendedKey where - data AsType GenesisDelegateExtendedKey = AsGenesisDelegateExtendedKey - proxyToAsType _ = AsGenesisDelegateExtendedKey - -instance Key GenesisDelegateExtendedKey where - newtype VerificationKey GenesisDelegateExtendedKey - = GenesisDelegateExtendedVerificationKey Crypto.HD.XPub - deriving stock Eq - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey GenesisDelegateExtendedKey) - - newtype SigningKey GenesisDelegateExtendedKey - = GenesisDelegateExtendedSigningKey Crypto.HD.XPrv - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (SigningKey GenesisDelegateExtendedKey) - - deterministicSigningKey :: - AsType GenesisDelegateExtendedKey -> - Crypto.Seed -> - SigningKey GenesisDelegateExtendedKey - deterministicSigningKey AsGenesisDelegateExtendedKey seed = - GenesisDelegateExtendedSigningKey - (Crypto.HD.generate seedbs BS.empty) - where - (seedbs, _) = Crypto.getBytesFromSeedT 32 seed - - deterministicSigningKeySeedSize :: AsType GenesisDelegateExtendedKey -> Word - deterministicSigningKeySeedSize AsGenesisDelegateExtendedKey = 32 - - getVerificationKey :: - SigningKey GenesisDelegateExtendedKey -> - VerificationKey GenesisDelegateExtendedKey - getVerificationKey (GenesisDelegateExtendedSigningKey sk) = - GenesisDelegateExtendedVerificationKey (Crypto.HD.toXPub sk) - - -- \| We use the hash of the normal non-extended pub key so that it is - -- consistent with the one used in addresses and signatures. - verificationKeyHash :: - VerificationKey GenesisDelegateExtendedKey -> - Hash GenesisDelegateExtendedKey - verificationKeyHash (GenesisDelegateExtendedVerificationKey vk) = - GenesisDelegateExtendedKeyHash - . Shelley.KeyHash - . Crypto.castHash - $ Crypto.hashWith Crypto.HD.xpubPublicKey vk - -instance ToCBOR (VerificationKey GenesisDelegateExtendedKey) where - toCBOR (GenesisDelegateExtendedVerificationKey xpub) = - toCBOR (Crypto.HD.unXPub xpub) - -instance FromCBOR (VerificationKey GenesisDelegateExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either - fail - (return . GenesisDelegateExtendedVerificationKey) - (Crypto.HD.xpub (bs :: ByteString)) - -instance ToCBOR (SigningKey GenesisDelegateExtendedKey) where - toCBOR (GenesisDelegateExtendedSigningKey xprv) = - toCBOR (Crypto.HD.unXPrv xprv) - -instance FromCBOR (SigningKey GenesisDelegateExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either - fail - (return . GenesisDelegateExtendedSigningKey) - (Crypto.HD.xprv (bs :: ByteString)) - -instance SerialiseAsRawBytes (VerificationKey GenesisDelegateExtendedKey) where - serialiseToRawBytes (GenesisDelegateExtendedVerificationKey xpub) = - Crypto.HD.unXPub xpub - - deserialiseFromRawBytes (AsVerificationKey AsGenesisDelegateExtendedKey) bs = - either - (const Nothing) - (Just . GenesisDelegateExtendedVerificationKey) - (Crypto.HD.xpub bs) - -instance SerialiseAsRawBytes (SigningKey GenesisDelegateExtendedKey) where - serialiseToRawBytes (GenesisDelegateExtendedSigningKey xprv) = - Crypto.HD.unXPrv xprv - - deserialiseFromRawBytes (AsSigningKey AsGenesisDelegateExtendedKey) bs = - either - (const Nothing) - (Just . GenesisDelegateExtendedSigningKey) - (Crypto.HD.xprv bs) - -newtype instance Hash GenesisDelegateExtendedKey - = GenesisDelegateExtendedKeyHash (Shelley.KeyHash Shelley.Staking) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash GenesisDelegateExtendedKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash GenesisDelegateExtendedKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash GenesisDelegateExtendedKey) where - serialiseToRawBytes (GenesisDelegateExtendedKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsGenesisDelegateExtendedKey) bs = - GenesisDelegateExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey GenesisDelegateExtendedKey) where - textEnvelopeType _ = "GenesisDelegateExtendedVerificationKey_ed25519_bip32" - -instance HasTextEnvelope (SigningKey GenesisDelegateExtendedKey) where - textEnvelopeType _ = "GenesisDelegateExtendedSigningKey_ed25519_bip32" - -instance CastVerificationKeyRole GenesisDelegateExtendedKey GenesisDelegateKey where - castVerificationKey (GenesisDelegateExtendedVerificationKey vk) = - GenesisDelegateVerificationKey - . Shelley.VKey - . fromMaybe impossible - . Crypto.rawDeserialiseVerKeyDSIGN - . Crypto.HD.xpubPublicKey - $ vk - where - impossible = - error "castVerificationKey: byron and shelley key sizes do not match!" - --- --- Genesis UTxO keys --- - -data GenesisUTxOKey - -instance HasTypeProxy GenesisUTxOKey where - data AsType GenesisUTxOKey = AsGenesisUTxOKey - proxyToAsType _ = AsGenesisUTxOKey - -instance Key GenesisUTxOKey where - newtype VerificationKey GenesisUTxOKey - = GenesisUTxOVerificationKey (Shelley.VKey Shelley.Payment) - deriving stock Eq - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey GenesisUTxOKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey GenesisUTxOKey - = GenesisUTxOSigningKey (SignKeyDSIGN DSIGN) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey GenesisUTxOKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType GenesisUTxOKey -> Crypto.Seed -> SigningKey GenesisUTxOKey - deterministicSigningKey AsGenesisUTxOKey seed = - GenesisUTxOSigningKey (Crypto.genKeyDSIGN seed) - - deterministicSigningKeySeedSize :: AsType GenesisUTxOKey -> Word - deterministicSigningKeySeedSize AsGenesisUTxOKey = - Crypto.seedSizeDSIGN proxy - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - - getVerificationKey :: SigningKey GenesisUTxOKey -> VerificationKey GenesisUTxOKey - getVerificationKey (GenesisUTxOSigningKey sk) = - GenesisUTxOVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) - - verificationKeyHash :: VerificationKey GenesisUTxOKey -> Hash GenesisUTxOKey - verificationKeyHash (GenesisUTxOVerificationKey vkey) = - GenesisUTxOKeyHash (Shelley.hashKey vkey) - -instance SerialiseAsRawBytes (VerificationKey GenesisUTxOKey) where - serialiseToRawBytes (GenesisUTxOVerificationKey (Shelley.VKey vk)) = - Crypto.rawSerialiseVerKeyDSIGN vk - - deserialiseFromRawBytes (AsVerificationKey AsGenesisUTxOKey) bs = - GenesisUTxOVerificationKey . Shelley.VKey - <$> Crypto.rawDeserialiseVerKeyDSIGN bs - -instance SerialiseAsRawBytes (SigningKey GenesisUTxOKey) where - serialiseToRawBytes (GenesisUTxOSigningKey sk) = - Crypto.rawSerialiseSignKeyDSIGN sk - - deserialiseFromRawBytes (AsSigningKey AsGenesisUTxOKey) bs = - GenesisUTxOSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs - -newtype instance Hash GenesisUTxOKey - = GenesisUTxOKeyHash (Shelley.KeyHash Shelley.Payment) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash GenesisUTxOKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash GenesisUTxOKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash GenesisUTxOKey) where - serialiseToRawBytes (GenesisUTxOKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsGenesisUTxOKey) bs = - GenesisUTxOKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey GenesisUTxOKey) where - textEnvelopeType _ = - "GenesisUTxOVerificationKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - -instance HasTextEnvelope (SigningKey GenesisUTxOKey) where - textEnvelopeType _ = - "GenesisUTxOSigningKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - --- TODO: use a different type from the stake pool key, since some operations --- need a genesis key specifically - -instance CastVerificationKeyRole GenesisUTxOKey PaymentKey where - castVerificationKey (GenesisUTxOVerificationKey (Shelley.VKey vkey)) = - PaymentVerificationKey (Shelley.VKey vkey) - -instance CastSigningKeyRole GenesisUTxOKey PaymentKey where - castSigningKey (GenesisUTxOSigningKey skey) = - PaymentSigningKey skey - --- --- stake pool keys --- - -data StakePoolKey - -instance HasTypeProxy StakePoolKey where - data AsType StakePoolKey = AsStakePoolKey - proxyToAsType _ = AsStakePoolKey - -instance Key StakePoolKey where - newtype VerificationKey StakePoolKey - = StakePoolVerificationKey (Shelley.VKey Shelley.StakePool) - deriving stock Eq - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey StakePoolKey) - deriving newtype (EncCBOR, DecCBOR, ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey StakePoolKey - = StakePoolSigningKey (SignKeyDSIGN DSIGN) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey StakePoolKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType StakePoolKey -> Crypto.Seed -> SigningKey StakePoolKey - deterministicSigningKey AsStakePoolKey seed = - StakePoolSigningKey (Crypto.genKeyDSIGN seed) - - deterministicSigningKeySeedSize :: AsType StakePoolKey -> Word - deterministicSigningKeySeedSize AsStakePoolKey = - Crypto.seedSizeDSIGN proxy - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - - getVerificationKey :: SigningKey StakePoolKey -> VerificationKey StakePoolKey - getVerificationKey (StakePoolSigningKey sk) = - StakePoolVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) - - verificationKeyHash :: VerificationKey StakePoolKey -> Hash StakePoolKey - verificationKeyHash (StakePoolVerificationKey vkey) = - StakePoolKeyHash (Shelley.hashKey vkey) - -instance SerialiseAsRawBytes (VerificationKey StakePoolKey) where - serialiseToRawBytes (StakePoolVerificationKey (Shelley.VKey vk)) = - Crypto.rawSerialiseVerKeyDSIGN vk - - deserialiseFromRawBytes (AsVerificationKey AsStakePoolKey) bs = - StakePoolVerificationKey . Shelley.VKey - <$> Crypto.rawDeserialiseVerKeyDSIGN bs - -instance SerialiseAsRawBytes (SigningKey StakePoolKey) where - serialiseToRawBytes (StakePoolSigningKey sk) = - Crypto.rawSerialiseSignKeyDSIGN sk - - deserialiseFromRawBytes (AsSigningKey AsStakePoolKey) bs = - StakePoolSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs - -instance SerialiseAsBech32 (VerificationKey StakePoolKey) where - bech32PrefixFor _ = "pool_vk" - bech32PrefixesPermitted _ = ["pool_vk"] - -instance SerialiseAsBech32 (SigningKey StakePoolKey) where - bech32PrefixFor _ = "pool_sk" - bech32PrefixesPermitted _ = ["pool_sk"] - -newtype instance Hash StakePoolKey - = StakePoolKeyHash (Shelley.KeyHash Shelley.StakePool) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash StakePoolKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash StakePoolKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash StakePoolKey) where - serialiseToRawBytes (StakePoolKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsStakePoolKey) bs = - StakePoolKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs - -instance SerialiseAsBech32 (Hash StakePoolKey) where - bech32PrefixFor _ = "pool" - bech32PrefixesPermitted _ = ["pool"] - -instance ToJSON (Hash StakePoolKey) where - toJSON = toJSON . serialiseToBech32 - -instance ToJSONKey (Hash StakePoolKey) where - toJSONKey = toJSONKeyText serialiseToBech32 - -instance FromJSON (Hash StakePoolKey) where - parseJSON = withText "PoolId" $ \str -> - case deserialiseFromBech32 (AsHash AsStakePoolKey) str of - Left err -> - fail $ - "Error deserialising Hash StakePoolKey: " - <> Text.unpack str - <> " Error: " - <> displayError err - Right h -> pure h - -instance HasTextEnvelope (VerificationKey StakePoolKey) where - textEnvelopeType _ = - "StakePoolVerificationKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - -instance HasTextEnvelope (SigningKey StakePoolKey) where - textEnvelopeType _ = - "StakePoolSigningKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/OperationalCertificate.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/OperationalCertificate.hs deleted file mode 100644 index 979cefa97c..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/OperationalCertificate.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/OperationalCertificate.hs - --- | Operational certificates -module Cardano.Api.OperationalCertificate - ( -- OperationalCertIssueError (..) - OperationalCertificate (..) - , OperationalCertificateIssueCounter (..) - , Shelley.KESPeriod (..) - , getHotKey - , getKesPeriod - , getOpCertCount - -- , issueOperationalCertificate - - -- * Data family instances - , AsType (..) - ) where - -import Cardano.Api.Any -import Cardano.Api.Key -import Cardano.Api.KeysByron -import Cardano.Api.KeysPraos -import Cardano.Api.KeysShelley -import Cardano.Api.SerialiseTextEnvelope -import qualified Cardano.Ledger.Binary as CBOR - ( CBORGroup (..) - , shelleyProtVer - , toPlainDecoder - , toPlainEncoding - ) -import Cardano.Protocol.Crypto (StandardCrypto) -import qualified Cardano.Protocol.TPraos.OCert as Shelley -import Data.Word - --- ---------------------------------------------------------------------------- --- Operational certificates --- - -data OperationalCertificate - = OperationalCertificate - !(Shelley.OCert StandardCrypto) - !(VerificationKey StakePoolKey) - deriving (Eq, Show) - deriving anyclass SerialiseAsCBOR - -data OperationalCertificateIssueCounter - = OperationalCertificateIssueCounter - { opCertIssueCount :: !Word64 - , opCertIssueColdKey :: !(VerificationKey StakePoolKey) -- For consistency checking - } - deriving (Eq, Show) - deriving anyclass SerialiseAsCBOR - -instance ToCBOR OperationalCertificate where - toCBOR = CBOR.toPlainEncoding CBOR.shelleyProtVer . encCBOR - -instance FromCBOR OperationalCertificate where - fromCBOR = CBOR.toPlainDecoder Nothing CBOR.shelleyProtVer decCBOR - -instance ToCBOR OperationalCertificateIssueCounter where - toCBOR = CBOR.toPlainEncoding CBOR.shelleyProtVer . encCBOR - -instance FromCBOR OperationalCertificateIssueCounter where - fromCBOR = CBOR.toPlainDecoder Nothing CBOR.shelleyProtVer decCBOR - -instance EncCBOR OperationalCertificate where - encCBOR (OperationalCertificate ocert vkey) = - encCBOR (CBOR.CBORGroup ocert, vkey) - -instance DecCBOR OperationalCertificate where - decCBOR = do - (CBOR.CBORGroup ocert, vkey) <- decCBOR - return (OperationalCertificate ocert vkey) - -instance EncCBOR OperationalCertificateIssueCounter where - encCBOR (OperationalCertificateIssueCounter counter vkey) = - encCBOR (counter, vkey) - -instance DecCBOR OperationalCertificateIssueCounter where - decCBOR = do - (counter, vkey) <- decCBOR - return (OperationalCertificateIssueCounter counter vkey) - -instance HasTypeProxy OperationalCertificate where - data AsType OperationalCertificate = AsOperationalCertificate - proxyToAsType _ = AsOperationalCertificate - -instance HasTypeProxy OperationalCertificateIssueCounter where - data AsType OperationalCertificateIssueCounter = AsOperationalCertificateIssueCounter - proxyToAsType _ = AsOperationalCertificateIssueCounter - -instance HasTextEnvelope OperationalCertificate where - textEnvelopeType _ = "NodeOperationalCertificate" - -getHotKey :: OperationalCertificate -> VerificationKey UnsoundPureKesKey -getHotKey (OperationalCertificate cert _) = KesVerificationKey $ Shelley.ocertVkHot cert - -getKesPeriod :: OperationalCertificate -> Word -getKesPeriod (OperationalCertificate cert _) = Shelley.unKESPeriod $ Shelley.ocertKESPeriod cert - -getOpCertCount :: OperationalCertificate -> Word64 -getOpCertCount (OperationalCertificate cert _) = Shelley.ocertN cert diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Protocol/Types.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Protocol/Types.hs deleted file mode 100644 index 6d3c693c1c..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Protocol/Types.hs +++ /dev/null @@ -1,134 +0,0 @@ --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/Protocol/Types.hs - -module Cardano.Api.Protocol.Types - ( BlockType (..) - , Protocol (..) - , ProtocolClient (..) - , ProtocolClientInfoArgs (..) - , ProtocolInfoArgs (..) - ) where - -import Cardano.Chain.Slotting (EpochSlots) -import qualified Control.Tracer as Tracer -import Ouroboros.Consensus.Block.Forging (MkBlockForging (..)) -import Ouroboros.Consensus.Byron.ByronHFC (ByronBlockHFC) -import Ouroboros.Consensus.Cardano -import Ouroboros.Consensus.Cardano.Block -import Ouroboros.Consensus.Cardano.Node -import Ouroboros.Consensus.HardFork.Combinator.Embed.Unary -import qualified Ouroboros.Consensus.Ledger.SupportsProtocol as Consensus - ( LedgerSupportsProtocol - ) -import Ouroboros.Consensus.Node.ProtocolInfo - ( ProtocolClientInfo (..) - , ProtocolInfo (..) - ) -import Ouroboros.Consensus.Node.Run (RunNode) -import Ouroboros.Consensus.Protocol.Praos.AgentClient -import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus -import qualified Ouroboros.Consensus.Shelley.Eras as Consensus (ShelleyEra) -import Ouroboros.Consensus.Shelley.HFEras () -import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Consensus - ( ShelleyBlock - ) -import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () -import Ouroboros.Consensus.Shelley.ShelleyHFC (ShelleyBlockHFC) -import Ouroboros.Consensus.Util.IOLike -import System.FS.API (SomeHasFS) - -class (RunNode blk, IOLike m) => Protocol m blk where - data ProtocolInfoArgs m blk - protocolInfo :: - ProtocolInfoArgs m blk -> - m - ( ProtocolInfo blk - , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m blk] - ) - --- | Node client support for each consensus protocol. --- --- This is like 'Protocol' but for clients of the node, so with less onerous --- requirements than to run a node. -class RunNode blk => ProtocolClient blk where - data ProtocolClientInfoArgs blk - protocolClientInfo :: ProtocolClientInfoArgs blk -> ProtocolClientInfo blk - --- | Run PBFT against the Byron ledger -instance IOLike m => Protocol m ByronBlockHFC where - data ProtocolInfoArgs m ByronBlockHFC = ProtocolInfoArgsByron ProtocolParamsByron - protocolInfo (ProtocolInfoArgsByron params) = - pure - ( inject $ protocolInfoByron params - , \_ -> pure . map (MkBlockForging . pure . inject) $ blockForgingByron params - ) - -instance - ( CardanoHardForkConstraints StandardCrypto - , IOLike m - , MonadKESAgent m - ) => - Protocol m (CardanoBlock StandardCrypto) - where - data ProtocolInfoArgs m (CardanoBlock StandardCrypto) - = ProtocolInfoArgsCardano - (SomeHasFS m) - (CardanoProtocolParams StandardCrypto) - - protocolInfo (ProtocolInfoArgsCardano fs paramsCardano) = - protocolInfoCardano fs paramsCardano - -instance ProtocolClient ByronBlockHFC where - data ProtocolClientInfoArgs ByronBlockHFC - = ProtocolClientInfoArgsByron EpochSlots - protocolClientInfo (ProtocolClientInfoArgsByron epochSlots) = - inject $ protocolClientInfoByron epochSlots - -instance CardanoHardForkConstraints StandardCrypto => ProtocolClient (CardanoBlock StandardCrypto) where - data ProtocolClientInfoArgs (CardanoBlock StandardCrypto) - = ProtocolClientInfoArgsCardano EpochSlots - protocolClientInfo (ProtocolClientInfoArgsCardano epochSlots) = - protocolClientInfoCardano epochSlots - -instance - ( IOLike m - , MonadKESAgent m - , Consensus.LedgerSupportsProtocol - ( Consensus.ShelleyBlock - (Consensus.TPraos StandardCrypto) - ShelleyEra - ) - ) => - Protocol m (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) ShelleyEra) - where - data ProtocolInfoArgs m (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) ShelleyEra) - = ProtocolInfoArgsShelley - (SomeHasFS m) - ShelleyGenesis - (ProtocolParamsShelleyBased StandardCrypto) - ProtVer - protocolInfo (ProtocolInfoArgsShelley fs genesis shelleyBasedProtocolParams' protVer) = do - (pinfo, bf) <- protocolInfoShelley fs genesis shelleyBasedProtocolParams' protVer - pure (inject pinfo, injectBlockForging bf) - where - injectBlockForging bf tr = fmap (map inject) (bf tr) - -instance - Consensus.LedgerSupportsProtocol - ( Consensus.ShelleyBlock - (Consensus.TPraos StandardCrypto) - Consensus.ShelleyEra - ) => - ProtocolClient (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) ShelleyEra) - where - data ProtocolClientInfoArgs (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) ShelleyEra) - = ProtocolClientInfoArgsShelley - protocolClientInfo ProtocolClientInfoArgsShelley = - inject protocolClientInfoShelley - -data BlockType blk where - ByronBlockType :: BlockType ByronBlockHFC - ShelleyBlockType :: BlockType (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) ShelleyEra) - CardanoBlockType :: BlockType (CardanoBlock StandardCrypto) - -deriving instance Eq (BlockType blk) -deriving instance Show (BlockType blk) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/SerialiseTextEnvelope.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/SerialiseTextEnvelope.hs deleted file mode 100644 index 086c88557b..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/SerialiseTextEnvelope.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/SerialiseTextEnvelope.hs - --- | TextEnvelope Serialisation -module Cardano.Api.SerialiseTextEnvelope - ( FromSomeType (..) - , HasTextEnvelope (..) - , TextEnvelope (..) - , TextEnvelopeDescr (..) - , TextEnvelopeError (..) - , TextEnvelopeType (..) - , deserialiseFromTextEnvelope - , deserialiseFromTextEnvelopeAnyOf - , readFileTextEnvelope - , readFileTextEnvelopeAnyOf - , readTextEnvelopeFromFile - , readTextEnvelopeOfTypeFromFile - , serialiseToTextEnvelope - - -- * Data family instances - , AsType (..) - ) where - -import Cardano.Api.Any -import Cardano.Ledger.Binary (DecoderError) -import Control.Monad (unless) -import Control.Monad.Trans.Except (ExceptT (..), runExceptT) -import Control.Monad.Trans.Except.Extra - ( firstExceptT - , handleIOExceptT - , hoistEither - ) -import Data.Aeson as Aeson - ( FromJSON (..) - , ToJSON (..) - , eitherDecodeStrict' - , object - , withObject - , (.:) - , (.=) - ) -import Data.Bifunctor (first) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.List as List -import Data.Maybe (fromMaybe) -import Data.String (IsString) -import qualified Data.Text.Encoding as Text - --- ---------------------------------------------------------------------------- --- Text envelopes --- - -newtype TextEnvelopeType = TextEnvelopeType String - deriving (Eq, Show) - deriving newtype (IsString, Semigroup, ToJSON, FromJSON) - -newtype TextEnvelopeDescr = TextEnvelopeDescr String - deriving (Eq, Show) - deriving newtype (IsString, Semigroup, ToJSON, FromJSON) - --- | A 'TextEnvelope' is a structured envelope for serialised binary values --- with an external format with a semi-readable textual format. --- --- It contains a \"type\" field, e.g. \"PublicKeyByron\" or \"TxSignedShelley\" --- to indicate the type of the encoded data. This is used as a sanity check --- and to help readers. --- --- It also contains a \"title\" field which is free-form, and could be used --- to indicate the role or purpose to a reader. -data TextEnvelope = TextEnvelope - { teType :: !TextEnvelopeType - , teDescription :: !TextEnvelopeDescr - , teRawCBOR :: !ByteString - } - deriving (Eq, Show) - -instance HasTypeProxy TextEnvelope where - data AsType TextEnvelope = AsTextEnvelope - proxyToAsType _ = AsTextEnvelope - -instance ToJSON TextEnvelope where - toJSON TextEnvelope{teType, teDescription, teRawCBOR} = - object - [ "type" .= teType - , "description" .= teDescription - , "cborHex" .= Text.decodeUtf8 (Base16.encode teRawCBOR) - ] - -instance FromJSON TextEnvelope where - parseJSON = withObject "TextEnvelope" $ \v -> - TextEnvelope - <$> (v .: "type") - <*> (v .: "description") - <*> (parseJSONBase16 =<< v .: "cborHex") - where - parseJSONBase16 v = - either fail return . Base16.decode . Text.encodeUtf8 =<< parseJSON v - --- | The errors that the pure 'TextEnvelope' parsing\/decoding functions can return. -data TextEnvelopeError - = -- | expected, actual - TextEnvelopeTypeError ![TextEnvelopeType] !TextEnvelopeType - | TextEnvelopeDecodeError !DecoderError - | TextEnvelopeAesonDecodeError !String - deriving (Eq, Show) - -instance Error TextEnvelopeError where - displayError tee = - case tee of - TextEnvelopeTypeError - [TextEnvelopeType expType] - (TextEnvelopeType actType) -> - "TextEnvelope type error: " - <> " Expected: " - <> expType - <> " Actual: " - <> actType - TextEnvelopeTypeError expTypes (TextEnvelopeType actType) -> - "TextEnvelope type error: " - <> " Expected one of: " - <> List.intercalate - ", " - [expType | TextEnvelopeType expType <- expTypes] - <> " Actual: " - <> actType - TextEnvelopeAesonDecodeError decErr -> "TextEnvelope aeson decode error: " <> decErr - TextEnvelopeDecodeError decErr -> "TextEnvelope decode error: " <> show decErr - --- | Check that the \"type\" of the 'TextEnvelope' is as expected. --- --- For example, one might check that the type is \"TxSignedShelley\". -expectTextEnvelopeOfType :: TextEnvelopeType -> TextEnvelope -> Either TextEnvelopeError () -expectTextEnvelopeOfType expectedType TextEnvelope{teType = actualType} = - unless (expectedType == actualType) $ - Left (TextEnvelopeTypeError [expectedType] actualType) - --- ---------------------------------------------------------------------------- --- Serialisation in text envelope format --- - -class SerialiseAsCBOR a => HasTextEnvelope a where - textEnvelopeType :: AsType a -> TextEnvelopeType - - textEnvelopeDefaultDescr :: a -> TextEnvelopeDescr - textEnvelopeDefaultDescr _ = "" - -serialiseToTextEnvelope :: - forall a. - HasTextEnvelope a => - Maybe TextEnvelopeDescr -> a -> TextEnvelope -serialiseToTextEnvelope mbDescr a = - TextEnvelope - { teType = textEnvelopeType ttoken - , teDescription = fromMaybe (textEnvelopeDefaultDescr a) mbDescr - , teRawCBOR = serialiseToCBOR a - } - where - ttoken :: AsType a - ttoken = proxyToAsType Proxy - -deserialiseFromTextEnvelope :: - HasTextEnvelope a => - AsType a -> - TextEnvelope -> - Either TextEnvelopeError a -deserialiseFromTextEnvelope ttoken te = do - expectTextEnvelopeOfType (textEnvelopeType ttoken) te - first TextEnvelopeDecodeError $ - deserialiseFromCBOR ttoken (teRawCBOR te) -- TODO: You have switched from CBOR to JSON - -deserialiseFromTextEnvelopeAnyOf :: - [FromSomeType HasTextEnvelope b] -> - TextEnvelope -> - Either TextEnvelopeError b -deserialiseFromTextEnvelopeAnyOf types te = - case List.find matching types of - Nothing -> - Left (TextEnvelopeTypeError expectedTypes actualType) - Just (FromSomeType ttoken f) -> - first TextEnvelopeDecodeError $ - f <$> deserialiseFromCBOR ttoken (teRawCBOR te) - where - actualType = teType te - expectedTypes = - [ textEnvelopeType ttoken - | FromSomeType ttoken _f <- types - ] - - matching (FromSomeType ttoken _f) = actualType == textEnvelopeType ttoken - -readFileTextEnvelope :: - HasTextEnvelope a => - AsType a -> - FilePath -> - IO (Either (FileError TextEnvelopeError) a) -readFileTextEnvelope ttoken path = - runExceptT $ do - content <- handleIOExceptT (FileIOError path) $ BS.readFile path - firstExceptT (FileError path) $ hoistEither $ do - te <- first TextEnvelopeAesonDecodeError $ Aeson.eitherDecodeStrict' content - deserialiseFromTextEnvelope ttoken te - -readFileTextEnvelopeAnyOf :: - [FromSomeType HasTextEnvelope b] -> - FilePath -> - IO (Either (FileError TextEnvelopeError) b) -readFileTextEnvelopeAnyOf types path = - runExceptT $ do - content <- handleIOExceptT (FileIOError path) $ BS.readFile path - firstExceptT (FileError path) $ hoistEither $ do - te <- first TextEnvelopeAesonDecodeError $ Aeson.eitherDecodeStrict' content - deserialiseFromTextEnvelopeAnyOf types te - -readTextEnvelopeFromFile :: - FilePath -> - IO (Either (FileError TextEnvelopeError) TextEnvelope) -readTextEnvelopeFromFile path = - runExceptT $ do - bs <- - handleIOExceptT (FileIOError path) $ - BS.readFile path - firstExceptT (FileError path . TextEnvelopeAesonDecodeError) - . hoistEither - $ Aeson.eitherDecodeStrict' bs - -readTextEnvelopeOfTypeFromFile :: - TextEnvelopeType -> - FilePath -> - IO (Either (FileError TextEnvelopeError) TextEnvelope) -readTextEnvelopeOfTypeFromFile expectedType path = - runExceptT $ do - te <- ExceptT (readTextEnvelopeFromFile path) - firstExceptT (FileError path) $ - hoistEither $ - expectTextEnvelopeOfType expectedType te - return te diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/SerialiseUsing.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/SerialiseUsing.hs deleted file mode 100644 index f2ef64f07a..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/SerialiseUsing.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/SerialiseUsing.hs - --- | Raw binary serialisation -module Cardano.Api.SerialiseUsing - ( UsingRawBytes (..) - , UsingRawBytesHex (..) - ) where - -import Cardano.Api.Any -import Cardano.Ledger.Binary (fromPlainDecoder) -import Data.Aeson.Types - ( FromJSON - , FromJSONKey - , ToJSON (..) - , ToJSONKey - ) -import qualified Data.Aeson.Types as Aeson -import Data.ByteString (ByteString) -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Char8 as BSC -import Data.String (IsString (..)) -import qualified Data.Text.Encoding as Text -import Data.Typeable (Typeable, tyConName, typeRep, typeRepTyCon) - --- | For use with @deriving via@, to provide 'ToCBOR' and 'FromCBOR' instances, --- based on the 'SerialiseAsRawBytes' instance. Eg: --- --- > deriving (ToCBOR, FromCBOR) via (UsingRawBytes Blah) -newtype UsingRawBytes a = UsingRawBytes a - -instance (SerialiseAsRawBytes a, Typeable a) => ToCBOR (UsingRawBytes a) where - toCBOR (UsingRawBytes x) = toCBOR (serialiseToRawBytes x) - -instance (SerialiseAsRawBytes a, Typeable a) => FromCBOR (UsingRawBytes a) where - fromCBOR = do - bs <- fromCBOR - case deserialiseFromRawBytes ttoken bs of - Just x -> return (UsingRawBytes x) - Nothing -> fail ("cannot deserialise as a " ++ tname) - where - ttoken = proxyToAsType (Proxy :: Proxy a) - tname = (tyConName . typeRepTyCon . typeRep) (Proxy :: Proxy a) - -instance (SerialiseAsRawBytes a, Typeable a) => EncCBOR (UsingRawBytes a) - -instance (SerialiseAsRawBytes a, Typeable a) => DecCBOR (UsingRawBytes a) where - decCBOR = fromPlainDecoder fromCBOR - --- | For use with @deriving via@, to provide instances for any\/all of 'Show', --- 'IsString', 'ToJSON', 'FromJSON', 'ToJSONKey', FromJSONKey' using a hex --- encoding, based on the 'SerialiseAsRawBytes' instance. --- --- > deriving (Show, IsString) via (UsingRawBytesHex Blah) --- > deriving (ToJSON, FromJSON) via (UsingRawBytesHex Blah) --- > deriving (ToJSONKey, FromJSONKey) via (UsingRawBytesHex Blah) -newtype UsingRawBytesHex a = UsingRawBytesHex a - -instance SerialiseAsRawBytes a => Show (UsingRawBytesHex a) where - show (UsingRawBytesHex x) = show (serialiseToRawBytesHex x) - -instance SerialiseAsRawBytes a => IsString (UsingRawBytesHex a) where - fromString = either error id . deserialiseFromRawBytesBase16 . BSC.pack - -instance SerialiseAsRawBytes a => ToJSON (UsingRawBytesHex a) where - toJSON (UsingRawBytesHex x) = toJSON (serialiseToRawBytesHexText x) - -instance (SerialiseAsRawBytes a, Typeable a) => FromJSON (UsingRawBytesHex a) where - parseJSON = - Aeson.withText tname $ - either fail pure . deserialiseFromRawBytesBase16 . Text.encodeUtf8 - where - tname = (tyConName . typeRepTyCon . typeRep) (Proxy :: Proxy a) - -instance SerialiseAsRawBytes a => ToJSONKey (UsingRawBytesHex a) where - toJSONKey = - Aeson.toJSONKeyText $ \(UsingRawBytesHex x) -> serialiseToRawBytesHexText x - -instance (SerialiseAsRawBytes a, Typeable a) => FromJSONKey (UsingRawBytesHex a) where - fromJSONKey = - Aeson.FromJSONKeyTextParser $ - either fail pure . deserialiseFromRawBytesBase16 . Text.encodeUtf8 - -deserialiseFromRawBytesBase16 :: - SerialiseAsRawBytes a => ByteString -> Either String (UsingRawBytesHex a) -deserialiseFromRawBytesBase16 str = - case Base16.decode str of - Right raw -> case deserialiseFromRawBytes ttoken raw of - Just x -> Right (UsingRawBytesHex x) - Nothing -> Left ("cannot deserialise " ++ show str) - Left msg -> Left ("invalid hex " ++ show str ++ ", " ++ msg) - where - ttoken = proxyToAsType (Proxy :: Proxy a) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Alonzo.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Alonzo.hs deleted file mode 100644 index a84605a9d3..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Alonzo.hs +++ /dev/null @@ -1,54 +0,0 @@ --- DUPLICATE -- adapted from: cardano-node/src/Cardano/Node/Protocol/Alonzo.hs - -module Cardano.Node.Protocol.Alonzo - ( AlonzoProtocolInstantiationError (..) - - -- * Reusable parts - , readGenesis - , validateGenesis - ) where - -import Cardano.Api.Any -import qualified Cardano.Ledger.Alonzo.Genesis as Alonzo -import Cardano.Node.Protocol.Shelley - ( GenesisReadError - , readGenesisAny - ) -import Cardano.Node.Types -import Cardano.Prelude -import Prelude (String) - --- --- Alonzo genesis --- - -readGenesis :: - GenesisFile -> - Maybe GenesisHash -> - ExceptT - GenesisReadError - IO - (Alonzo.AlonzoGenesis, GenesisHash) -readGenesis = readGenesisAny - -validateGenesis :: - Alonzo.AlonzoGenesis -> - ExceptT AlonzoProtocolInstantiationError IO () -validateGenesis _ = return () -- TODO alonzo: do the validation - -data AlonzoProtocolInstantiationError - = InvalidCostModelError !FilePath - | CostModelExtractionError !FilePath - | AlonzoCostModelFileError !(FileError ()) - | AlonzoCostModelDecodeError !FilePath !String - deriving Show - -instance Error AlonzoProtocolInstantiationError where - displayError (InvalidCostModelError fp) = - "Invalid cost model: " <> show fp - displayError (CostModelExtractionError fp) = - "Error extracting the cost model at: " <> show fp - displayError (AlonzoCostModelFileError err) = - displayError err - displayError (AlonzoCostModelDecodeError fp err) = - "Error decoding cost model at: " <> show fp <> " Error: " <> err diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Byron.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Byron.hs deleted file mode 100644 index 93c6624553..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Byron.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - --- DUPLICATE -- adapted from: cardano-node/src/Cardano/Node/Protocol/Byron.hs - -module Cardano.Node.Protocol.Byron - ( -- * Errors - ByronProtocolInstantiationError (..) - - -- * Reusable parts - , readGenesis - , readLeaderCredentials - ) where - -import Cardano.Api.Any -import Cardano.Api.KeysByron -import qualified Cardano.Chain.Genesis as Genesis -import qualified Cardano.Chain.UTxO as UTxO -import qualified Cardano.Crypto.Hash as Crypto -import qualified Cardano.Crypto.Hashing as Byron.Crypto -import Cardano.Crypto.ProtocolMagic (RequiresNetworkMagic) -import Cardano.Node.Types -import Cardano.Prelude -import Control.Monad.Trans.Except.Extra - ( bimapExceptT - , firstExceptT - , hoistEither - , hoistMaybe - , left - ) -import qualified Data.ByteString.Lazy as LB -import Data.Text as Text (unpack) -import Ouroboros.Consensus.Cardano -import Prelude hiding (show, (.)) - ------------------------------------------------------------------------------- --- Byron protocol --- - -readGenesis :: - GenesisFile -> - Maybe GenesisHash -> - RequiresNetworkMagic -> - ExceptT - ByronProtocolInstantiationError - IO - Genesis.Config -readGenesis (GenesisFile file) mbExpectedGenesisHash ncReqNetworkMagic = do - (genesisData, genesisHash) <- - firstExceptT (GenesisReadError file) $ - Genesis.readGenesisData file - checkExpectedGenesisHash genesisHash - return - Genesis.Config - { Genesis.configGenesisData = genesisData - , Genesis.configGenesisHash = genesisHash - , Genesis.configReqNetMagic = ncReqNetworkMagic - , Genesis.configUTxOConfiguration = UTxO.defaultUTxOConfiguration - -- TODO: add config support for the UTxOConfiguration if needed - } - where - checkExpectedGenesisHash :: - Genesis.GenesisHash -> - ExceptT ByronProtocolInstantiationError IO () - checkExpectedGenesisHash actual' = - case mbExpectedGenesisHash of - Just expected - | actual /= expected -> - throwError (GenesisHashMismatch actual expected) - where - actual = fromByronGenesisHash actual' - _ -> return () - - fromByronGenesisHash :: Genesis.GenesisHash -> GenesisHash - fromByronGenesisHash (Genesis.GenesisHash h) = - GenesisHash - . fromMaybe impossible - . Crypto.hashFromBytes - . Byron.Crypto.hashToBytes - $ h - where - impossible = - panic "fromByronGenesisHash: old and new crypto libs disagree on hash size" - -readLeaderCredentials :: - Genesis.Config -> - Maybe ProtocolFilepaths -> - ExceptT - ByronProtocolInstantiationError - IO - (Maybe ByronLeaderCredentials) -readLeaderCredentials _ Nothing = return Nothing -readLeaderCredentials - genesisConfig - ( Just - ProtocolFilepaths - { byronCertFile - , byronKeyFile - } - ) = - case (byronCertFile, byronKeyFile) of - (Nothing, Nothing) -> pure Nothing - (Just _, Nothing) -> left SigningKeyFilepathNotSpecified - (Nothing, Just _) -> left DelegationCertificateFilepathNotSpecified - (Just delegCertFile, Just signingKeyFile) -> do - signingKeyFileBytes <- liftIO $ LB.readFile signingKeyFile - delegCertFileBytes <- liftIO $ LB.readFile delegCertFile - ByronSigningKey signingKey <- - hoistMaybe (SigningKeyDeserialiseFailure signingKeyFile) $ - deserialiseFromRawBytes (AsSigningKey AsByronKey) $ - LB.toStrict signingKeyFileBytes - delegCert <- - firstExceptT (CanonicalDecodeFailure delegCertFile) - . hoistEither - $ canonicalDecodePretty delegCertFileBytes - - bimapExceptT CredentialsError Just - . hoistEither - $ mkByronLeaderCredentials genesisConfig signingKey delegCert "Byron" - ------------------------------------------------------------------------------- --- Byron Errors --- - -data ByronProtocolInstantiationError - = CanonicalDecodeFailure !FilePath !Text - | GenesisHashMismatch !GenesisHash !GenesisHash -- actual, expected - | DelegationCertificateFilepathNotSpecified - | GenesisConfigurationError !FilePath !Genesis.ConfigurationError - | GenesisReadError !FilePath !Genesis.GenesisDataError - | CredentialsError !ByronLeaderCredentialsError - | SigningKeyDeserialiseFailure !FilePath - | SigningKeyFilepathNotSpecified - deriving Show - -instance Error ByronProtocolInstantiationError where - displayError (CanonicalDecodeFailure fp failure) = - "Canonical decode failure in " - <> fp - <> " Canonical failure: " - <> Text.unpack failure - displayError (GenesisHashMismatch actual expected) = - "Wrong Byron genesis file: the actual hash is " - <> show actual - <> ", but the expected Byron genesis hash given in the node configuration " - <> "file is " - <> show expected - displayError DelegationCertificateFilepathNotSpecified = - "Delegation certificate filepath not specified" - -- TODO: Implement configuration error render function in cardano-ledger - displayError (GenesisConfigurationError fp genesisConfigError) = - "Genesis configuration error in: " - <> toS fp - <> " Error: " - <> show genesisConfigError - displayError (GenesisReadError fp err) = - "There was an error parsing the genesis file: " - <> toS fp - <> " Error: " - <> show err - -- TODO: Implement ByronLeaderCredentialsError render function in ouroboros-network - displayError (CredentialsError byronLeaderCredentialsError) = - "Byron leader credentials error: " <> show byronLeaderCredentialsError - displayError (SigningKeyDeserialiseFailure fp) = - "Signing key deserialisation error in: " <> toS fp - displayError SigningKeyFilepathNotSpecified = - "Signing key filepath not specified" diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Cardano.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Cardano.hs index c177f1b3a1..f7166cc3fe 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Cardano.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Cardano.hs @@ -12,22 +12,27 @@ module Cardano.Node.Protocol.Cardano , CardanoProtocolInstantiationError (..) ) where -import Cardano.Api.Any (Error (..)) import qualified Cardano.Chain.Update as Byron import qualified Cardano.Ledger.Api.Transition as SL import Cardano.Ledger.BaseTypes import Cardano.Ledger.Dijkstra.PParams -import qualified Cardano.Node.Protocol.Alonzo as Alonzo -import qualified Cardano.Node.Protocol.Byron as Byron -import qualified Cardano.Node.Protocol.Conway as Conway -import Cardano.Node.Protocol.Shelley (readGenesisAny) -import qualified Cardano.Node.Protocol.Shelley as Shelley import Cardano.Node.Types import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Except.Extra (firstExceptT) import Data.Maybe (fromMaybe) import Ouroboros.Consensus.Cardano import qualified Ouroboros.Consensus.Cardano as Consensus +import Ouroboros.Consensus.Cardano.Api.Genesis + ( ByronProtocolInstantiationError + , GenesisReadError + , PraosLeaderCredentialsError + , genesisHashToPraosNonce + , readByronGenesis + , readByronLeaderCredentials + , readGenesisAny + , readShelleyLeaderCredentials + ) +import Ouroboros.Consensus.Cardano.Api.Serialise (Error (..)) import Ouroboros.Consensus.Cardano.Condense () import Ouroboros.Consensus.Cardano.Node (CardanoProtocolParams (..)) import Ouroboros.Consensus.Config (emptyCheckpointsMap) @@ -101,30 +106,30 @@ mkConsensusProtocolCardano files = do byronGenesis <- firstExceptT CardanoProtocolInstantiationErrorByron $ - Byron.readGenesis + readByronGenesis npcByronGenesisFile npcByronGenesisFileHash npcByronReqNetworkMagic byronLeaderCredentials <- firstExceptT CardanoProtocolInstantiationErrorByron $ - Byron.readLeaderCredentials byronGenesis files + readByronLeaderCredentials byronGenesis files (shelleyGenesis, shelleyGenesisHash) <- firstExceptT CardanoProtocolInstantiationShelleyGenesisReadError $ - Shelley.readGenesis + readGenesisAny npcShelleyGenesisFile npcShelleyGenesisFileHash (alonzoGenesis, _alonzoGenesisHash) <- firstExceptT CardanoProtocolInstantiationAlonzoGenesisReadError $ - Alonzo.readGenesis + readGenesisAny npcAlonzoGenesisFile npcAlonzoGenesisFileHash (conwayGenesis, _conwayGenesisHash) <- firstExceptT CardanoProtocolInstantiationConwayGenesisReadError $ - Conway.readGenesis + readGenesisAny npcConwayGenesisFile npcConwayGenesisFileHash @@ -145,7 +150,7 @@ mkConsensusProtocolCardano shelleyLeaderCredentials <- firstExceptT CardanoProtocolInstantiationPraosLeaderCredentialsError $ - Shelley.readLeaderCredentials files + readShelleyLeaderCredentials files let transitionLedgerConfig = SL.mkLatestTransitionConfig shelleyGenesis alonzoGenesis conwayGenesis dijkstraGenesis @@ -179,7 +184,7 @@ mkConsensusProtocolCardano } Consensus.ProtocolParamsShelleyBased { shelleyBasedInitialNonce = - Shelley.genesisHashToPraosNonce + genesisHashToPraosNonce shelleyGenesisHash , shelleyBasedLeaderCredentials = shelleyLeaderCredentials } @@ -275,19 +280,17 @@ emptyDijkstraGenesis = data CardanoProtocolInstantiationError = CardanoProtocolInstantiationErrorByron - Byron.ByronProtocolInstantiationError + ByronProtocolInstantiationError | CardanoProtocolInstantiationShelleyGenesisReadError - Shelley.GenesisReadError + GenesisReadError | CardanoProtocolInstantiationAlonzoGenesisReadError - Shelley.GenesisReadError + GenesisReadError | CardanoProtocolInstantiationConwayGenesisReadError - Shelley.GenesisReadError + GenesisReadError | CardanoProtocolInstantiationDijkstraGenesisReadError - Shelley.GenesisReadError + GenesisReadError | CardanoProtocolInstantiationPraosLeaderCredentialsError - Shelley.PraosLeaderCredentialsError - | CardanoProtocolInstantiationErrorAlonzo - Alonzo.AlonzoProtocolInstantiationError + PraosLeaderCredentialsError deriving Show instance Error CardanoProtocolInstantiationError where @@ -303,5 +306,3 @@ instance Error CardanoProtocolInstantiationError where "Dijkstra related: " <> displayError err displayError (CardanoProtocolInstantiationPraosLeaderCredentialsError err) = displayError err - displayError (CardanoProtocolInstantiationErrorAlonzo err) = - displayError err diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Conway.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Conway.hs deleted file mode 100644 index 72d1e6e5cf..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Conway.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE EmptyDataDeriving #-} - --- TODO DUPLICATE? -- as-if adapted? from: cardano-node/src/Cardano/Node/Protocol/Conway.hs - -module Cardano.Node.Protocol.Conway - ( ConwayProtocolInstantiationError - - -- * Reusable parts - , readGenesis - , validateGenesis - ) where - -import qualified Cardano.Ledger.Conway.Genesis as Conway -import Cardano.Node.Protocol.Shelley - ( GenesisReadError - , readGenesisAny - ) -import Cardano.Node.Types -import Cardano.Prelude - --- --- Conway genesis --- - -readGenesis :: - GenesisFile -> - Maybe GenesisHash -> - ExceptT - GenesisReadError - IO - (Conway.ConwayGenesis, GenesisHash) -readGenesis = readGenesisAny - -validateGenesis :: - Conway.ConwayGenesis -> - ExceptT ConwayProtocolInstantiationError IO () -validateGenesis _ = return () -- TODO conway: do the validation - -data ConwayProtocolInstantiationError - {- TODO - = InvalidCostModelError !FilePath - | CostModelExtractionError !FilePath - | ConwayCostModelFileError !(FileError ()) - | ConwayCostModelDecodeError !FilePath !String - -} - deriving Show - -{- TODO -instance Error ConwayProtocolInstantiationError where - displayError (InvalidCostModelError fp) = - "Invalid cost model: " <> show fp - displayError (CostModelExtractionError fp) = - "Error extracting the cost model at: " <> show fp - displayError (ConwayCostModelFileError err) = - displayError err - displayError (ConwayCostModelDecodeError fp err) = - "Error decoding cost model at: " <> show fp <> " Error: " <> err - --} diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Shelley.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Shelley.hs deleted file mode 100644 index 1e2997df63..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Shelley.hs +++ /dev/null @@ -1,332 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - --- DUPLICATE -- adapted from: cardano-node/src/Cardano/Node/Protocol/Shelley.hs - -module Cardano.Node.Protocol.Shelley - ( -- * Errors - GenesisReadError (..) - , GenesisValidationError (..) - , PraosLeaderCredentialsError (..) - , ShelleyProtocolInstantiationError (..) - - -- * Reusable parts - , genesisHashToPraosNonce - , readGenesis - , readGenesisAny - , readLeaderCredentials - , validateGenesis - ) where - -import Cardano.Api.Any hiding (FileError (..)) -import qualified Cardano.Api.Any as Api (FileError (..)) -import Cardano.Api.Key -import Cardano.Api.KeysPraos as Praos -import Cardano.Api.KeysShelley -import Cardano.Api.OperationalCertificate -import Cardano.Api.SerialiseTextEnvelope -import qualified Cardano.Crypto.Hash.Class as Crypto -import Cardano.Ledger.Keys (coerceKeyRole) -import qualified Cardano.Ledger.Shelley.Genesis as Shelley -import Cardano.Node.Types -import Cardano.Prelude -import Cardano.Protocol.Crypto (StandardCrypto) -import Control.Monad.Trans.Except.Extra - ( firstExceptT - , handleIOExceptT - , hoistEither - , left - , newExceptT - ) -import qualified Data.Aeson as Aeson (FromJSON (..), eitherDecodeStrict') -import qualified Data.ByteString as BS -import qualified Data.Text as T -import Ouroboros.Consensus.Protocol.Praos.Common - ( PraosCanBeLeader (..) - , PraosCredentialsSource (..) - ) -import Ouroboros.Consensus.Shelley.Node - ( Nonce (..) - , ShelleyGenesis (..) - , ShelleyLeaderCredentials (..) - ) -import Prelude (String, id) - ------------------------------------------------------------------------------- --- Shelley protocol --- - -genesisHashToPraosNonce :: GenesisHash -> Nonce -genesisHashToPraosNonce (GenesisHash h) = Nonce (Crypto.castHash h) - -readGenesis :: - GenesisFile -> - Maybe GenesisHash -> - ExceptT - GenesisReadError - IO - (ShelleyGenesis, GenesisHash) -readGenesis = readGenesisAny - -readGenesisAny :: - Aeson.FromJSON genesis => - GenesisFile -> - Maybe GenesisHash -> - ExceptT GenesisReadError IO (genesis, GenesisHash) -readGenesisAny (GenesisFile file) mbExpectedGenesisHash = do - content <- - handleIOExceptT (GenesisReadFileError file) - $ BS.readFile file - let genesisHash = GenesisHash (Crypto.hashWith id content) - checkExpectedGenesisHash genesisHash - genesis <- - firstExceptT (GenesisDecodeError file) - $ hoistEither - $ Aeson.eitherDecodeStrict' content - return (genesis, genesisHash) - where - checkExpectedGenesisHash :: - GenesisHash -> - ExceptT GenesisReadError IO () - checkExpectedGenesisHash actual = - case mbExpectedGenesisHash of - Just expected - | actual /= expected -> - throwError (GenesisHashMismatch actual expected) - _ -> return () - -validateGenesis :: - ShelleyGenesis -> - ExceptT GenesisValidationError IO () -validateGenesis genesis = - firstExceptT GenesisValidationErrors - . hoistEither - $ Shelley.validateGenesis genesis - -readLeaderCredentials :: - Maybe ProtocolFilepaths -> - ExceptT PraosLeaderCredentialsError IO [ShelleyLeaderCredentials StandardCrypto] -readLeaderCredentials Nothing = return [] -readLeaderCredentials (Just pfp) = - -- The set of credentials is a sum total of what comes from the CLI, - -- as well as what's in the bulk credentials file. - (<>) - <$> readLeaderCredentialsSingleton pfp - <*> readLeaderCredentialsBulk pfp - -readLeaderCredentialsSingleton :: - ProtocolFilepaths -> - ExceptT - PraosLeaderCredentialsError - IO - [ShelleyLeaderCredentials StandardCrypto] --- It's OK to supply none of the files on the CLI -readLeaderCredentialsSingleton - ProtocolFilepaths - { shelleyCertFile = Nothing - , shelleyVRFFile = Nothing - , shelleyKESFile = Nothing - } = pure [] --- Or to supply all of the files -readLeaderCredentialsSingleton - ProtocolFilepaths - { shelleyCertFile = Just opCertFile - , shelleyVRFFile = Just vrfFile - , shelleyKESFile = Just kesFile - } = do - vrfSKey <- - firstExceptT FileError (newExceptT $ readFileTextEnvelope (AsSigningKey AsVrfKey) vrfFile) - - (opCert, kesSKey) <- opCertKesKeyCheck kesFile opCertFile - - return [mkPraosLeaderCredentials opCert vrfSKey kesSKey] - --- But not OK to supply some of the files without the others. -readLeaderCredentialsSingleton ProtocolFilepaths{shelleyCertFile = Nothing} = - left OCertNotSpecified -readLeaderCredentialsSingleton ProtocolFilepaths{shelleyVRFFile = Nothing} = - left VRFKeyNotSpecified -readLeaderCredentialsSingleton ProtocolFilepaths{shelleyKESFile = Nothing} = - left KESKeyNotSpecified - -opCertKesKeyCheck :: - -- | KES key - FilePath -> - -- | Operational certificate - FilePath -> - ExceptT PraosLeaderCredentialsError IO (OperationalCertificate, SigningKey UnsoundPureKesKey) -opCertKesKeyCheck kesFile certFile = do - opCert <- - firstExceptT FileError (newExceptT $ readFileTextEnvelope AsOperationalCertificate certFile) - kesSKey <- - firstExceptT - FileError - (newExceptT $ readFileTextEnvelope (AsSigningKey AsUnsoundPureKesKey) kesFile) - let opCertSpecifiedKesKeyhash = verificationKeyHash $ getHotKey opCert - suppliedKesKeyHash = verificationKeyHash $ getVerificationKey kesSKey - -- Specified KES key in operational certificate should match the one - -- supplied to the node. - if suppliedKesKeyHash /= opCertSpecifiedKesKeyhash - then left $ MismatchedKesKey kesFile certFile - else return (opCert, kesSKey) - -data ShelleyCredentials - = ShelleyCredentials - { scCert :: (TextEnvelope, FilePath) - , scVrf :: (TextEnvelope, FilePath) - , scKes :: (TextEnvelope, FilePath) - } - -readLeaderCredentialsBulk :: - ProtocolFilepaths -> - ExceptT PraosLeaderCredentialsError IO [ShelleyLeaderCredentials StandardCrypto] -readLeaderCredentialsBulk ProtocolFilepaths{shelleyBulkCredsFile = mfp} = - mapM parseShelleyCredentials =<< readBulkFile mfp - where - parseShelleyCredentials :: - ShelleyCredentials -> - ExceptT PraosLeaderCredentialsError IO (ShelleyLeaderCredentials StandardCrypto) - parseShelleyCredentials ShelleyCredentials{scCert, scVrf, scKes} = - mkPraosLeaderCredentials - <$> parseEnvelope AsOperationalCertificate scCert - <*> parseEnvelope (AsSigningKey AsVrfKey) scVrf - <*> parseEnvelope (AsSigningKey AsUnsoundPureKesKey) scKes - - readBulkFile :: - Maybe FilePath -> - ExceptT PraosLeaderCredentialsError IO [ShelleyCredentials] - readBulkFile Nothing = pure [] - readBulkFile (Just fp) = do - content <- - handleIOExceptT (CredentialsReadError fp) - $ BS.readFile fp - envelopes <- - firstExceptT (EnvelopeParseError fp) - $ hoistEither - $ Aeson.eitherDecodeStrict' content - pure $ uncurry mkCredentials <$> zip [0 ..] envelopes - where - mkCredentials :: - Int -> - (TextEnvelope, TextEnvelope, TextEnvelope) -> - ShelleyCredentials - mkCredentials ix (teCert, teVrf, teKes) = - let loc ty = fp <> "." <> show ix <> ty - in ShelleyCredentials - (teCert, loc "cert") - (teVrf, loc "vrf") - (teKes, loc "kes") - -mkPraosLeaderCredentials :: - OperationalCertificate -> - SigningKey VrfKey -> - SigningKey UnsoundPureKesKey -> - ShelleyLeaderCredentials StandardCrypto -mkPraosLeaderCredentials - (OperationalCertificate opcert (StakePoolVerificationKey vkey)) - (VrfSigningKey vrfKey) - (KesSigningKey kesKey) = - ShelleyLeaderCredentials - { shelleyLeaderCredentialsCanBeLeader = - PraosCanBeLeader - { praosCanBeLeaderColdVerKey = coerceKeyRole vkey - , praosCanBeLeaderSignKeyVRF = vrfKey - , praosCanBeLeaderCredentialsSource = PraosCredentialsUnsound opcert kesKey - } - , shelleyLeaderCredentialsLabel = "Shelley" - } - -parseEnvelope :: - HasTextEnvelope a => - AsType a -> - (TextEnvelope, String) -> - ExceptT PraosLeaderCredentialsError IO a -parseEnvelope as (te, loc) = - firstExceptT (FileError . Api.FileError loc) - . hoistEither - $ deserialiseFromTextEnvelope as te - ------------------------------------------------------------------------------- --- Errors --- - -data ShelleyProtocolInstantiationError - = GenesisReadError GenesisReadError - | GenesisValidationError GenesisValidationError - | PraosLeaderCredentialsError PraosLeaderCredentialsError - deriving Show - -instance Error ShelleyProtocolInstantiationError where - displayError (GenesisReadError err) = displayError err - displayError (GenesisValidationError err) = displayError err - displayError (PraosLeaderCredentialsError err) = displayError err - -data GenesisReadError - = GenesisReadFileError !FilePath !IOException - | GenesisHashMismatch !GenesisHash !GenesisHash -- actual, expected - | GenesisDecodeError !FilePath !String - deriving Show - -instance Error GenesisReadError where - displayError (GenesisReadFileError fp err) = - "There was an error reading the genesis file: " - <> toS fp - <> " Error: " - <> show err - displayError (GenesisHashMismatch actual expected) = - "Wrong genesis file: the actual hash is " - <> show actual - <> ", but the expected genesis hash given in the node " - <> "configuration file is " - <> show expected - displayError (GenesisDecodeError fp err) = - "There was an error parsing the genesis file: " - <> toS fp - <> " Error: " - <> show err - -newtype GenesisValidationError = GenesisValidationErrors [Shelley.ValidationErr] - deriving Show - -instance Error GenesisValidationError where - displayError (GenesisValidationErrors vErrs) = - T.unpack (unlines (map Shelley.describeValidationErr vErrs)) - -data PraosLeaderCredentialsError - = CredentialsReadError !FilePath !IOException - | EnvelopeParseError !FilePath !String - | FileError !(Api.FileError TextEnvelopeError) - | OCertNotSpecified - | VRFKeyNotSpecified - | KESKeyNotSpecified - | MismatchedKesKey - FilePath - -- KES signing key - FilePath - -- Operational certificate - deriving Show - -instance Error PraosLeaderCredentialsError where - displayError (CredentialsReadError fp err) = - "There was an error reading a credentials file: " - <> toS fp - <> " Error: " - <> show err - displayError (EnvelopeParseError fp err) = - "There was an error parsing a credentials envelope: " - <> toS fp - <> " Error: " - <> show err - displayError (FileError fileErr) = displayError fileErr - displayError (MismatchedKesKey kesFp certFp) = - "The KES key provided at: " - <> show kesFp - <> " does not match the KES key specified in the operational certificate at: " - <> show certFp - displayError OCertNotSpecified = missingFlagMessage "shelley-operational-certificate" - displayError VRFKeyNotSpecified = missingFlagMessage "shelley-vrf-key" - displayError KESKeyNotSpecified = missingFlagMessage "shelley-kes-key" - -missingFlagMessage :: String -> String -missingFlagMessage flag = - "To create blocks, the --" <> flag <> " must also be specified" diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Types.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Types.hs index 8e46c045d3..9fe44ed996 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Types.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Types.hs @@ -1,20 +1,20 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- DUPLICATE -- adapted from: cardano-node/src/Cardano/Node/Types.hs +-- | The node's per-era protocol configuration records, as parsed from a node +-- configuration file. These are the inputs to 'mkConsensusProtocolCardano' in +-- "Cardano.Node.Protocol.Cardano". +-- +-- The reusable genesis\/credential file types ('GenesisFile', 'GenesisHash', +-- 'ProtocolFilepaths') are defined in +-- "Ouroboros.Consensus.Cardano.Api.Genesis" and re-exported here. module Cardano.Node.Types ( -- * Configuration AdjustFilePaths (..) - , ConfigError (..) - , ConfigYamlFilePath (..) - , DbFile (..) , GenesisFile (..) , GenesisHash (..) - , MaxConcurrencyBulkSync (..) - , MaxConcurrencyDeadline (..) , ProtocolFilepaths (..) -- * Consensus protocol configuration @@ -23,106 +23,22 @@ module Cardano.Node.Types , NodeConwayProtocolConfiguration (..) , NodeDijkstraProtocolConfiguration (..) , NodeHardForkProtocolConfiguration (..) - , NodeProtocolConfigurationCardano (..) , NodeShelleyProtocolConfiguration (..) - , VRFPrivateKeyFilePermissionError (..) - , renderVRFPrivateKeyFilePermissionError ) where import qualified Cardano.Chain.Update as Byron import Cardano.Crypto (RequiresNetworkMagic) -import qualified Cardano.Crypto.Hash as Crypto -import Data.Aeson -import Data.String (IsString) -import Data.Text as Text (Text, pack, unpack) import Data.Word (Word16, Word8) import Ouroboros.Consensus.Block.Abstract (EpochNo) - --- | Errors for the cardano-config module. -data ConfigError - = ConfigErrorFileNotFound FilePath - | ConfigErrorNoEKG - deriving Show - --- | Filepath of the configuration yaml file. This file determines --- all the configuration settings required for the cardano node --- (logging, tracing, protocol, slot length etc) -newtype ConfigYamlFilePath = ConfigYamlFilePath - {unConfigPath :: FilePath} - deriving newtype (Eq, Show) - -newtype DbFile = DbFile - {unDB :: FilePath} - deriving newtype (Eq, Show) - -newtype GenesisFile = GenesisFile - {unGenesisFile :: FilePath} - deriving stock (Eq, Ord) - deriving newtype (IsString, Show) - -instance FromJSON GenesisFile where - parseJSON (String genFp) = pure . GenesisFile $ Text.unpack genFp - parseJSON invalid = - fail $ - "Parsing of GenesisFile failed due to type mismatch. " - <> "Encountered: " - <> show invalid - -newtype MaxConcurrencyBulkSync = MaxConcurrencyBulkSync - {unMaxConcurrencyBulkSync :: Word} - deriving stock (Eq, Ord) - deriving newtype (FromJSON, Show) - -newtype MaxConcurrencyDeadline = MaxConcurrencyDeadline - {unMaxConcurrencyDeadline :: Word} - deriving stock (Eq, Ord) - deriving newtype (FromJSON, Show) - -{- --- | Newtype wrapper which provides 'FromJSON' instance for 'DiffusionMode'. --- -newtype NodeDiffusionMode - = NodeDiffusionMode { getDiffusionMode :: DiffusionMode } - deriving newtype Show - -instance FromJSON NodeDiffusionMode where - parseJSON (String str) = - case str of - "InitiatorOnly" - -> pure $ NodeDiffusionMode InitiatorOnlyDiffusionMode - "InitiatorAndResponder" - -> pure $ NodeDiffusionMode InitiatorAndResponderDiffusionMode - _ -> fail "Parsing NodeDiffusionMode failed: can be either 'InitiatorOnly' or 'InitiatorAndResponder'" - parseJSON _ = fail "Parsing NodeDiffusionMode failed" --} +import Ouroboros.Consensus.Cardano.Api.Genesis + ( GenesisFile (..) + , GenesisHash (..) + , ProtocolFilepaths (..) + ) class AdjustFilePaths a where adjustFilePaths :: (FilePath -> FilePath) -> a -> a -data ProtocolFilepaths - = ProtocolFilepaths - { byronCertFile :: !(Maybe FilePath) - , byronKeyFile :: !(Maybe FilePath) - , shelleyKESFile :: !(Maybe FilePath) - , shelleyVRFFile :: !(Maybe FilePath) - , shelleyCertFile :: !(Maybe FilePath) - , shelleyBulkCredsFile :: !(Maybe FilePath) - } - deriving (Eq, Show) - -newtype GenesisHash = GenesisHash (Crypto.Hash Crypto.Blake2b_256 Crypto.ByteString) - deriving newtype (Eq, Show, ToJSON, FromJSON) - -data NodeProtocolConfigurationCardano - = NodeProtocolConfigurationCardano - NodeByronProtocolConfiguration - NodeShelleyProtocolConfiguration - NodeAlonzoProtocolConfiguration - NodeConwayProtocolConfiguration - NodeDijkstraProtocolConfiguration - NodeHardForkProtocolConfiguration - deriving (Eq, Show) - data NodeShelleyProtocolConfiguration = NodeShelleyProtocolConfiguration { npcShelleyGenesisFile :: !GenesisFile @@ -225,16 +141,6 @@ data NodeHardForkProtocolConfiguration } deriving (Eq, Show) -instance AdjustFilePaths NodeProtocolConfigurationCardano where - adjustFilePaths f (NodeProtocolConfigurationCardano pcb pcs pca pcc pcd pch) = - NodeProtocolConfigurationCardano - (adjustFilePaths f pcb) - (adjustFilePaths f pcs) - (adjustFilePaths f pca) - (adjustFilePaths f pcc) - (adjustFilePaths f pcd) - pch - instance AdjustFilePaths NodeByronProtocolConfiguration where adjustFilePaths f @@ -280,25 +186,3 @@ instance AdjustFilePaths GenesisFile where instance AdjustFilePaths a => AdjustFilePaths (Maybe a) where adjustFilePaths f = fmap (adjustFilePaths f) - -data VRFPrivateKeyFilePermissionError - = OtherPermissionsExist FilePath - | GroupPermissionsExist FilePath - | GenericPermissionsExist FilePath - deriving Show - -renderVRFPrivateKeyFilePermissionError :: VRFPrivateKeyFilePermissionError -> Text -renderVRFPrivateKeyFilePermissionError err = - case err of - OtherPermissionsExist fp -> - "VRF private key file at: " - <> Text.pack fp - <> " has \"other\" file permissions. Please remove all \"other\" file permissions." - GroupPermissionsExist fp -> - "VRF private key file at: " - <> Text.pack fp - <> "has \"group\" file permissions. Please remove all \"group\" file permissions." - GenericPermissionsExist fp -> - "VRF private key file at: " - <> Text.pack fp - <> "has \"generic\" file permissions. Please remove all \"generic\" file permissions." diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs index d0dd4c39b9..897ffd8ff5 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs @@ -6,9 +6,9 @@ module Cardano.Tools.DBSynthesizer.Run , synthesize ) where -import Cardano.Api.Any (displayError) import Cardano.Node.Protocol.Cardano (mkConsensusProtocolCardano) import Cardano.Node.Types +import Ouroboros.Consensus.Cardano.Api.Serialise (displayError) import Cardano.Tools.DBSynthesizer.Forging import Cardano.Tools.DBSynthesizer.Orphans () import Cardano.Tools.DBSynthesizer.Types diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index e7cdd6b096..b06dea2b51 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -1312,6 +1312,9 @@ library cardano Ouroboros.Consensus.Byron.Node.Serialisation Ouroboros.Consensus.Byron.Protocol Ouroboros.Consensus.Cardano + Ouroboros.Consensus.Cardano.Api.Genesis + Ouroboros.Consensus.Cardano.Api.Keys + Ouroboros.Consensus.Cardano.Api.Serialise Ouroboros.Consensus.Cardano.Block Ouroboros.Consensus.Cardano.CanHardFork Ouroboros.Consensus.Cardano.Condense @@ -1353,6 +1356,7 @@ library cardano aeson, base, base-deriving-via, + base16-bytestring, bytestring, cardano-base, cardano-binary, @@ -1396,6 +1400,8 @@ library cardano strict-sop-core, text, these, + transformers, + transformers-except, validation >=1.2, library unstable-byronspec @@ -1717,7 +1723,6 @@ library unstable-cardano-tools visibility: public hs-source-dirs: ouroboros-consensus-cardano/src/unstable-cardano-tools exposed-modules: - Cardano.Api.Any Cardano.Node.Types Cardano.Tools.DBAnalyser.Analysis Cardano.Tools.DBAnalyser.Analysis.BenchmarkLedgerOps.FileWriting @@ -1743,25 +1748,12 @@ library unstable-cardano-tools Cardano.Tools.ImmDBServer.MiniProtocols other-modules: - Cardano.Api.Key - Cardano.Api.KeysByron - Cardano.Api.KeysPraos - Cardano.Api.KeysShelley - Cardano.Api.OperationalCertificate - Cardano.Api.SerialiseTextEnvelope - Cardano.Api.SerialiseUsing - Cardano.Node.Protocol.Alonzo - Cardano.Node.Protocol.Byron Cardano.Node.Protocol.Cardano - Cardano.Node.Protocol.Conway - Cardano.Node.Protocol.Shelley build-depends: aeson, base, - base16-bytestring, bytestring, - cardano-crypto, cardano-crypto-class, cardano-crypto-wrapper, cardano-diffusion:cardano-diffusion,