Skip to content
Permalink
Browse files

Add: Support for `Signable` constraints.

This is needed concretely for adding `SignTag`s to cardano-sl era signatures.
Unfortunately it invades quite a lot of the system.
  • Loading branch information...
nc6 committed May 15, 2019
1 parent 34e7dc8 commit 3d721240ce0bf1e9a2aa1a5b5372b50883adcd66
@@ -1,4 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -121,6 +121,7 @@ chainSyncClient
, Ord up
, Condense hdr, Condense (ChainHash hdr)
, BlockProtocol blk ~ BlockProtocol hdr
, SupportedPreHeader (BlockProtocol hdr) (PreHeader hdr)
, Serialise (PreHeader hdr)
)
=> Tracer m String
@@ -10,10 +10,21 @@ module Ouroboros.Consensus.Crypto.DSIGN.Cardano
, VerKeyDSIGN(..)
, SignKeyDSIGN(..)
, SigDSIGN(..)
, HasSignTag(..)
) where

import Cardano.Binary
import Cardano.Crypto
( ProtocolMagicId
, SignTag
, PublicKey
, Signature
, SecretKey
, keyGen
, toPublic
, signEncoded
, verifySignature
)
import Data.Coerce (coerce)
import Data.Function (on)
import GHC.Generics (Generic)
@@ -24,8 +35,8 @@ import Ouroboros.Consensus.Util.Condense
pm :: ProtocolMagicId
pm = undefined

st :: SignTag
st = undefined
class HasSignTag a where
signTag :: a -> SignTag

data CardanoDSIGN

@@ -40,6 +51,8 @@ instance DSIGNAlgorithm CardanoDSIGN where
newtype SigDSIGN CardanoDSIGN = SigCardanoDSIGN (Signature Encoding)
deriving (Show, Eq, Generic)

type Signable CardanoDSIGN = HasSignTag

encodeVerKeyDSIGN (VerKeyCardanoDSIGN pk) = toCBOR pk
decodeVerKeyDSIGN = VerKeyCardanoDSIGN <$> fromCBOR

@@ -54,9 +67,10 @@ instance DSIGNAlgorithm CardanoDSIGN where
deriveVerKeyDSIGN (SignKeyCardanoDSIGN sk) = VerKeyCardanoDSIGN $ toPublic sk

signDSIGN toEnc a (SignKeyCardanoDSIGN sk) = do
return $ SigCardanoDSIGN $ signEncoded pm st sk (toEnc a)
return $ SigCardanoDSIGN $ signEncoded pm (signTag a) sk (toEnc a)

verifyDSIGN toEnc (VerKeyCardanoDSIGN vk) a (SigCardanoDSIGN sig) = verifySignature toEnc pm st vk a $ coerce sig
verifyDSIGN toEnc (VerKeyCardanoDSIGN vk) a (SigCardanoDSIGN sig)
= verifySignature toEnc pm (signTag a) vk a $ coerce sig

instance Ord (VerKeyDSIGN CardanoDSIGN) where
compare = compare `on` show
@@ -1,5 +1,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
@@ -8,6 +10,7 @@
module Ouroboros.Consensus.Crypto.DSIGN.Class
( DSIGNAlgorithm (..)
, SignedDSIGN (..)
, Empty
, signedDSIGN
, verifySignedDSIGN
, encodeSignedDSIGN
@@ -17,9 +20,13 @@ module Ouroboros.Consensus.Crypto.DSIGN.Class
import Codec.Serialise.Encoding (Encoding)
import Codec.CBOR.Decoding (Decoder)
import Crypto.Random (MonadRandom)
import GHC.Exts (Constraint)
import GHC.Generics (Generic)
import Ouroboros.Consensus.Util.Condense

class Empty a
instance Empty a

class ( Show (VerKeyDSIGN v)
, Ord (VerKeyDSIGN v)
, Show (SignKeyDSIGN v)
@@ -34,6 +41,9 @@ class ( Show (VerKeyDSIGN v)
data SignKeyDSIGN v :: *
data SigDSIGN v :: *

type Signable v :: * -> Constraint
type Signable c = Empty

encodeVerKeyDSIGN :: VerKeyDSIGN v -> Encoding
decodeVerKeyDSIGN :: Decoder s (VerKeyDSIGN v)
encodeSignKeyDSIGN :: SignKeyDSIGN v -> Encoding
@@ -43,8 +53,8 @@ class ( Show (VerKeyDSIGN v)

genKeyDSIGN :: MonadRandom m => m (SignKeyDSIGN v)
deriveVerKeyDSIGN :: SignKeyDSIGN v -> VerKeyDSIGN v
signDSIGN :: MonadRandom m => (a -> Encoding) -> a -> SignKeyDSIGN v -> m (SigDSIGN v)
verifyDSIGN :: (a -> Encoding) -> VerKeyDSIGN v -> a -> SigDSIGN v -> Bool
signDSIGN :: (MonadRandom m, Signable v a) => (a -> Encoding) -> a -> SignKeyDSIGN v -> m (SigDSIGN v)
verifyDSIGN :: (Signable v a) => (a -> Encoding) -> VerKeyDSIGN v -> a -> SigDSIGN v -> Bool

newtype SignedDSIGN v a = SignedDSIGN (SigDSIGN v)
deriving (Generic)
@@ -56,11 +66,11 @@ deriving instance DSIGNAlgorithm v => Ord (SignedDSIGN v a)
instance Condense (SigDSIGN v) => Condense (SignedDSIGN v a) where
condense (SignedDSIGN sig) = condense sig

signedDSIGN :: (DSIGNAlgorithm v, MonadRandom m)
signedDSIGN :: (DSIGNAlgorithm v, MonadRandom m, Signable v a)
=> (a -> Encoding) -> a -> SignKeyDSIGN v -> m (SignedDSIGN v a)
signedDSIGN encoder a key = SignedDSIGN <$> signDSIGN encoder a key

verifySignedDSIGN :: DSIGNAlgorithm v
verifySignedDSIGN :: (DSIGNAlgorithm v, Signable v a)
=> (a -> Encoding) -> VerKeyDSIGN v -> a -> SignedDSIGN v a -> Bool
verifySignedDSIGN encoder key a (SignedDSIGN s) = verifyDSIGN encoder key a s

@@ -1,3 +1,4 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
@@ -5,6 +5,7 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Mock key evolving signatures.
module Ouroboros.Consensus.Crypto.KES.Simple
@@ -26,7 +27,12 @@ import Ouroboros.Consensus.Util.Condense

data SimpleKES d

instance DSIGNAlgorithm d => KESAlgorithm (SimpleKES d) where
instance ( DSIGNAlgorithm d
-- TODO We currently don't support other 'Signable' constraints for
-- KES. We could, but it's more stuff to do. So for the moment we fix
-- this here.
, Signable d ~ Empty
) => KESAlgorithm (SimpleKES d) where

newtype VerKeyKES (SimpleKES d) = VerKeySimpleKES (Vector (VerKeyDSIGN d))
deriving Generic
@@ -91,6 +91,7 @@ type DemoProtocolConstraints p = (
, ProtocolLedgerView (Block p)
, SupportedBlock p (SimpleHeader p SimpleBlockMockCrypto)
, HasCreator (Block p)
, SupportedPreHeader p ~ Empty
, Condense (Payload p (SimplePreHeader p SimpleBlockMockCrypto))
, Eq (Payload p (SimplePreHeader p SimpleBlockMockCrypto))
, Serialise (Payload p (SimplePreHeader p SimpleBlockMockCrypto))
@@ -148,7 +148,10 @@ data ExtValidationError b =

deriving instance ProtocolLedgerView b => Show (ExtValidationError b)

applyExtLedgerState :: (LedgerConfigView b, ProtocolLedgerView b)
applyExtLedgerState :: ( LedgerConfigView b
, ProtocolLedgerView b
, SupportedPreHeader (BlockProtocol b) (PreHeader b)
)
=> (PreHeader b -> Encoding) -- Serialiser for the preheader
-> NodeConfig (BlockProtocol b)
-> b
@@ -168,7 +171,10 @@ applyExtLedgerState toEnc cfg b ExtLedgerState{..} = do
applyLedgerBlock (ledgerConfigView cfg) b ledgerState'
return $ ExtLedgerState ledgerState'' ouroborosChainState'

foldExtLedgerState :: (LedgerConfigView b, ProtocolLedgerView b)
foldExtLedgerState :: ( LedgerConfigView b
, ProtocolLedgerView b
, SupportedPreHeader (BlockProtocol b) (PreHeader b)
)
=> (PreHeader b -> Encoding) -- Serialiser for the preheader
-> NodeConfig (BlockProtocol b)
-> [b] -- ^ Blocks to apply, oldest first
@@ -177,7 +183,10 @@ foldExtLedgerState :: (LedgerConfigView b, ProtocolLedgerView b)
foldExtLedgerState toEnc = repeatedlyM . applyExtLedgerState toEnc

-- TODO: This should check stuff like backpointers also
chainExtLedgerState :: (LedgerConfigView b, ProtocolLedgerView b)
chainExtLedgerState :: ( LedgerConfigView b
, ProtocolLedgerView b
, SupportedPreHeader (BlockProtocol b) (PreHeader b)
)
=> (PreHeader b -> Encoding) -- Serialiser for the preheader
-> NodeConfig (BlockProtocol b)
-> Chain b
@@ -186,7 +195,10 @@ chainExtLedgerState :: (LedgerConfigView b, ProtocolLedgerView b)
chainExtLedgerState toEnc cfg = foldExtLedgerState toEnc cfg . toOldestFirst

-- | Validation of an entire chain
verifyChain :: (LedgerConfigView b, ProtocolLedgerView b)
verifyChain :: ( LedgerConfigView b
, ProtocolLedgerView b
, SupportedPreHeader (BlockProtocol b) (PreHeader b)
)
=> (PreHeader b -> Encoding) -- Serialiser for the preheader
-> NodeConfig (BlockProtocol b)
-> ExtLedgerState b
@@ -60,6 +60,7 @@ import Ouroboros.Network.Block
import Ouroboros.Network.Chain (Chain, toOldestFirst)

import Ouroboros.Consensus.Crypto.Hash.Class
import Ouroboros.Consensus.Crypto.DSIGN.Class (Empty)
import Ouroboros.Consensus.Crypto.Hash.MD5 (MD5)
import Ouroboros.Consensus.Crypto.Hash.Short (ShortHash)
import Ouroboros.Consensus.Ledger.Abstract
@@ -319,6 +320,8 @@ forgeBlock :: forall m p c.
, OuroborosTag p
, SimpleBlockCrypto c
, Serialise (Payload p (SimplePreHeader p c))
-- TODO Decide whether we want to fix this constraint here.
, SupportedPreHeader p ~ Empty
)
=> NodeConfig p
-> SlotNo -- ^ Current slot
@@ -451,8 +454,10 @@ instance (BftCrypto c, SimpleBlockCrypto c')
instance (SimpleBlockCrypto c')
=> ProtocolLedgerView (SimpleBlock (ExtNodeConfig (PBftLedgerView PBftMockCrypto) (PBft PBftMockCrypto)) c') where
protocolLedgerView (EncNodeConfig _ pbftParams) _ls = pbftParams

anachronisticProtocolLedgerView = error "TODO"
-- This instance is correct, because the delegation map doesn't change in the
-- node configuration.
anachronisticProtocolLedgerView (EncNodeConfig _ pbftParams) _ _
= Just $ slotUnbounded pbftParams

instance ( PraosCrypto c, SimpleBlockCrypto c')
=> ProtocolLedgerView (SimpleBlock (ExtNodeConfig AddrDist (Praos c)) c') where
@@ -181,6 +181,7 @@ nodeKernel
, HasHeader hdr
, HeaderHash hdr ~ HeaderHash blk
, SupportedBlock (BlockProtocol hdr) hdr
, SupportedPreHeader (BlockProtocol blk) (PreHeader hdr)
, BlockProtocol hdr ~ BlockProtocol blk
, Ord up
, TraceConstraints up blk hdr
@@ -241,6 +242,7 @@ initInternalState
, HeaderHash hdr ~ HeaderHash blk
, ProtocolLedgerView blk
, SupportedBlock (BlockProtocol hdr) hdr
, SupportedPreHeader (BlockProtocol blk) (PreHeader hdr)
, BlockProtocol hdr ~ BlockProtocol blk
, Ord up
, TraceConstraints up blk hdr
@@ -50,6 +50,8 @@ import qualified Ouroboros.Network.AnchoredFragment as AF
import Ouroboros.Network.Block (HasHeader (..), SlotNo (..))
import Ouroboros.Network.Chain (Chain)

-- TODO Better place to put the Empty class?
import Ouroboros.Consensus.Crypto.DSIGN.Class (Empty)
import qualified Ouroboros.Consensus.Util.AnchoredFragment as AF
import Ouroboros.Consensus.Util.Random

@@ -98,10 +100,14 @@ class ( Show (ChainState p)
-- | Blocks that the protocol can run on
type family SupportedBlock p :: * -> Constraint

-- | Constraints on the preheader which can be incorporated into a payload.
type family SupportedPreHeader p :: * -> Constraint
type SupportedPreHeader p = Empty

-- | Construct the ouroboros-specific payload of a block
--
-- Gets the proof that we are the leader and the preheader as arguments.
mkPayload :: (HasNodeState p m, MonadRandom m)
mkPayload :: (SupportedPreHeader p ph, HasNodeState p m, MonadRandom m)
=> (ph -> Encoding)
-> NodeConfig p
-> IsLeader p
@@ -147,7 +153,7 @@ class ( Show (ChainState p)
-> m (Maybe (IsLeader p))

-- | Apply a block
applyChainState :: SupportedBlock p b
applyChainState :: (SupportedBlock p b, SupportedPreHeader p (PreHeader b))
=> (PreHeader b -> Encoding) -- Serialiser for the preheader
-> NodeConfig p
-> LedgerView p -- /Updated/ ledger state
@@ -66,7 +66,7 @@ data BftParams = BftParams {
, bftNumNodes :: Word64
}

instance BftCrypto c => OuroborosTag (Bft c) where
instance (BftCrypto c) => OuroborosTag (Bft c) where
-- | The BFT payload is just the signature
newtype Payload (Bft c) ph = BftPayload {
bftSignature :: SignedDSIGN (BftDSIGN c) ph
@@ -139,8 +139,12 @@ data BftValidationErr = BftInvalidSignature
Crypto models
-------------------------------------------------------------------------------}


-- The equality constraint here is slightly weird; we need it to force GHC to
-- partially apply this constraint in `OuroborosTag` and thus conclude that it
-- can satisfy it universally.
-- | Crypto primitives required by BFT
class (Typeable c, DSIGNAlgorithm (BftDSIGN c)) => BftCrypto c where
class (Typeable c, DSIGNAlgorithm (BftDSIGN c), Signable (BftDSIGN c) ~ Empty) => BftCrypto c where
type family BftDSIGN c :: *

data BftStandardCrypto
@@ -43,6 +43,7 @@ instance (Typeable cfg, OuroborosTag p) => OuroborosTag (ExtNodeConfig cfg p) wh
type ValidationErr (ExtNodeConfig cfg p) = ValidationErr p
type IsLeader (ExtNodeConfig cfg p) = IsLeader p
type SupportedBlock (ExtNodeConfig cfg p) = SupportedBlock p
type SupportedPreHeader (ExtNodeConfig cfg p) = SupportedPreHeader p

--
-- Only type that changes is the node config
@@ -60,6 +60,7 @@ instance (Typeable p, Typeable s, ChainSelection p s) => OuroborosTag (ModChainS
type LedgerView (ModChainSel p s) = LedgerView p
type ValidationErr (ModChainSel p s) = ValidationErr p
type SupportedBlock (ModChainSel p s) = SupportedBlock p
type SupportedPreHeader (ModChainSel p s) = SupportedPreHeader p

mkPayload toEnc (McsNodeConfig cfg) proof ph = McsPayload <$> mkPayload toEnc cfg proof ph

@@ -73,6 +73,7 @@ data PBftLedgerView c = PBftLedgerView

-- ProtocolParameters Map from genesis to delegate keys.
-- Note that this map is injective by construction.
-- TODO Use BiMap here
(Map (PBftVerKeyHash c) (PBftVerKeyHash c))

{-------------------------------------------------------------------------------
@@ -106,7 +107,8 @@ data PBftParams = PBftParams {
, pbftSignatureThreshold :: Double
}

instance (PBftCrypto c, Typeable c) => OuroborosTag (PBft c) where
instance ( PBftCrypto c, Typeable c
) => OuroborosTag (PBft c) where
-- | The BFT payload is just the issuer and signature
data Payload (PBft c) ph = PBftPayload {
pbftIssuer :: VerKeyDSIGN (PBftDSIGN c)
@@ -124,6 +126,7 @@ instance (PBftCrypto c, Typeable c) => OuroborosTag (PBft c) where

type ValidationErr (PBft c) = PBftValidationErr
type SupportedBlock (PBft c) = HasPayload (PBft c)
type SupportedPreHeader (PBft c) = Signable (PBftDSIGN c)
type NodeState (PBft c) = ()

-- | We require two things from the ledger state:
@@ -245,15 +248,15 @@ class ( Typeable c

data PBftMockCrypto

instance PBftCrypto PBftMockCrypto where
instance (Signable MockDSIGN ~ Empty) => PBftCrypto PBftMockCrypto where
type PBftDSIGN PBftMockCrypto = MockDSIGN
type PBftVerKeyHash PBftMockCrypto = VerKeyDSIGN MockDSIGN

hashVerKey = id

data PBftCardanoCrypto

instance PBftCrypto PBftCardanoCrypto where
instance (Signable CardanoDSIGN ~ HasSignTag) => PBftCrypto PBftCardanoCrypto where
type PBftDSIGN PBftCardanoCrypto = CardanoDSIGN
type PBftVerKeyHash PBftCardanoCrypto = CC.Common.StakeholderId

@@ -60,6 +60,7 @@ instance OuroborosTag p => OuroborosTag (TestProtocol p) where
type ChainState (TestProtocol p) = ChainState p
type ValidationErr (TestProtocol p) = ValidationErr p
type SupportedBlock (TestProtocol p) = SupportedBlock p
type SupportedPreHeader (TestProtocol p) = SupportedPreHeader p

mkPayload toEnc (TestNodeConfig cfg _) (proof, stake) ph = do
standardPayload <- mkPayload toEnc cfg proof ph
@@ -32,6 +32,7 @@ openDB :: forall m blk hdr.
, HeaderHash blk ~ HeaderHash hdr
, ProtocolLedgerView blk
, LedgerConfigView blk
, SupportedPreHeader (BlockProtocol blk) (PreHeader blk)
)
=> (PreHeader blk -> Encoding)
-> NodeConfig (BlockProtocol blk)
Oops, something went wrong.

0 comments on commit 3d72124

Please sign in to comment.
You can’t perform that action at this time.