diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal
index c7e8542a2b..58e220c9a1 100644
--- a/ouroboros-consensus/ouroboros-consensus.cabal
+++ b/ouroboros-consensus/ouroboros-consensus.cabal
@@ -201,8 +201,10 @@ library
     Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Types
     Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API
     Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert
+    Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasVote
     Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound
     Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert
+    Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasVote
     Ouroboros.Consensus.MiniProtocol.Util
     Ouroboros.Consensus.MiniProtocol.Util.Idling
     Ouroboros.Consensus.Node.GsmState
@@ -281,6 +283,9 @@ library
     Ouroboros.Consensus.Storage.PerasCertDB
     Ouroboros.Consensus.Storage.PerasCertDB.API
     Ouroboros.Consensus.Storage.PerasCertDB.Impl
+    Ouroboros.Consensus.Storage.PerasVoteDB
+    Ouroboros.Consensus.Storage.PerasVoteDB.API
+    Ouroboros.Consensus.Storage.PerasVoteDB.Impl
     Ouroboros.Consensus.Storage.Serialisation
     Ouroboros.Consensus.Storage.VolatileDB
     Ouroboros.Consensus.Storage.VolatileDB.API
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
index a1a468ee8b..1da3f66811 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
@@ -10,31 +11,51 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-partial-fields #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
 
 module Ouroboros.Consensus.Block.SupportsPeras
   ( PerasRoundNo (..)
   , onPerasRoundNo
+  , PerasVoteStake (..)
   , PerasWeight (..)
   , BlockSupportsPeras (..)
   , PerasCert (..)
+  , PerasVote (..)
+  , PerasVoteTarget
   , PerasCfg (..)
   , ValidatedPerasCert (..)
+  , ValidatedPerasVote (..)
   , makePerasCfg
+  , HasId (..)
   , HasPerasCertRound (..)
   , HasPerasCertBoostedBlock (..)
   , HasPerasCertBoost (..)
+  , HasPerasVoteRound (..)
+  , HasPerasVoteVotedBlock (..)
+  , HasPerasVoteVoterId (..)
+  , HasPerasVoteTarget (..)
 
     -- * Ouroboros Peras round length
   , PerasRoundLength (..)
   , defaultPerasRoundLength
   ) where
 
+import qualified Cardano.Binary as KeyHash
+import Cardano.Ledger.Core (KeyHash, KeyRole (StakePool))
 import Codec.Serialise (Serialise (..))
 import Codec.Serialise.Decoding (decodeListLenOf)
 import Codec.Serialise.Encoding (encodeListLen)
+import Control.Applicative ((<|>))
 import Data.Coerce (coerce)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (isNothing)
 import Data.Monoid (Sum (..))
 import Data.Proxy (Proxy (..))
+import Data.Set (Set)
+import qualified Data.Set as Set
 import Data.Word (Word64)
 import GHC.Generics (Generic)
 import NoThunks.Class
@@ -44,11 +65,41 @@ import Ouroboros.Consensus.Util
 import Ouroboros.Consensus.Util.Condense
 import Quiet (Quiet (..))
 
+class
+  ( Ord (IdOf a)
+  , Eq (IdOf a)
+  , Show (IdOf a)
+  , NoThunks (IdOf a)
+  , Serialise (IdOf a)
+  ) =>
+  HasId a
+  where
+  type IdOf a
+  getId :: a -> IdOf a
+
+instance HasId perasObj => HasId (WithArrivalTime perasObj) where
+  type IdOf (WithArrivalTime perasObj) = IdOf perasObj
+  getId = getId . forgetArrivalTime
+
 newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64}
   deriving Show via Quiet PerasRoundNo
   deriving stock Generic
   deriving newtype (Enum, Eq, Ord, Num, Bounded, NoThunks, Serialise)
 
+newtype PerasVoteStake = PerasVoteStake {unPerasVoteStake :: Rational}
+  deriving Show via Quiet PerasVoteStake
+  deriving stock Generic
+  deriving newtype (Enum, Eq, Ord, Num, Fractional, NoThunks, Serialise)
+  deriving Semigroup via Sum Rational
+  deriving Monoid via Sum Rational
+
+data PerasVoteStakeDistr
+getPerasVoteStakeOf :: PerasVoteStakeDistr -> VoterId -> PerasVoteStake
+getPerasVoteStakeOf = undefined
+
+-- | TODO: what is the proper underlying type?
+type VoterId = KeyHash 'StakePool
+
 instance Condense PerasRoundNo where
   condense = show . unPerasRoundNo
 
@@ -75,6 +126,11 @@ instance Condense PerasWeight where
 boostPerCert :: PerasWeight
 boostPerCert = PerasWeight 15
 
+-- | TODO: this may become a Ledger protocol parameter
+-- see https://github.com/tweag/cardano-peras/issues/119
+quorumThreshold :: PerasVoteStake
+quorumThreshold = PerasVoteStake 0.75
+
 -- TODO using 'Validated' for extra safety? Or some @.Unsafe@ module?
 data ValidatedPerasCert blk = ValidatedPerasCert
   { vpcCert :: !(PerasCert blk)
@@ -83,6 +139,39 @@ data ValidatedPerasCert blk = ValidatedPerasCert
   deriving stock (Show, Eq, Ord, Generic)
   deriving anyclass NoThunks
 
+instance
+  ( HasId (PerasCert blk)
+  , Ord (IdOf (PerasCert blk))
+  , Eq (IdOf (PerasCert blk))
+  , Show (IdOf (PerasCert blk))
+  , NoThunks (IdOf (PerasCert blk))
+  , Serialise (IdOf (PerasCert blk))
+  ) =>
+  HasId (ValidatedPerasCert blk)
+  where
+  type IdOf (ValidatedPerasCert blk) = IdOf (PerasCert blk)
+  getId = getId . vpcCert
+
+data ValidatedPerasVote blk = ValidatedPerasVote
+  { vpvVote :: !(PerasVote blk)
+  , vpvVoteStake :: !PerasVoteStake
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass NoThunks
+
+instance
+  ( HasId (PerasVote blk)
+  , Ord (IdOf (PerasVote blk))
+  , Eq (IdOf (PerasVote blk))
+  , Show (IdOf (PerasVote blk))
+  , NoThunks (IdOf (PerasVote blk))
+  , Serialise (IdOf (PerasVote blk))
+  ) =>
+  HasId (ValidatedPerasVote blk)
+  where
+  type IdOf (ValidatedPerasVote blk) = IdOf (PerasVote blk)
+  getId = getId . vpvVote
+
 {-------------------------------------------------------------------------------
   Ouroboros Peras round length
 -------------------------------------------------------------------------------}
@@ -108,21 +197,40 @@ class
 
   data PerasCert blk
 
+  data PerasVote blk
+
   data PerasValidationErr blk
 
+  data PerasForgeErr blk
+
   validatePerasCert ::
     PerasCfg blk ->
     PerasCert blk ->
     Either (PerasValidationErr blk) (ValidatedPerasCert blk)
 
+  validatePerasVote ::
+    PerasCfg blk ->
+    PerasVote blk ->
+    PerasVoteStakeDistr ->
+    Either (PerasValidationErr blk) (ValidatedPerasVote blk)
+
+  forgePerasCert ::
+    PerasCfg blk ->
+    PerasVoteTarget blk ->
+    [ValidatedPerasVote blk] ->
+    Either (PerasForgeErr blk) (ValidatedPerasCert blk)
+
+type PerasVoteTarget blk = (PerasRoundNo, Point blk)
+
 -- TODO: degenerate instance for all blks to get things to compile
 -- see https://github.com/tweag/cardano-peras/issues/73
 instance StandardHash blk => BlockSupportsPeras blk where
-  newtype PerasCfg blk = PerasCfg
+  data PerasCfg blk = PerasCfg
     { -- TODO: eventually, this will come from the
       -- protocol parameters from the ledger state
       -- see https://github.com/tweag/cardano-peras/issues/119
       perasCfgWeightBoost :: PerasWeight
+    , perasCfgQuorumThreshold :: PerasVoteStake
     }
     deriving stock (Show, Eq)
 
@@ -133,12 +241,25 @@ instance StandardHash blk => BlockSupportsPeras blk where
     deriving stock (Generic, Eq, Ord, Show)
     deriving anyclass NoThunks
 
+  data PerasVote blk = PerasVote
+    { pvVoteRound :: PerasRoundNo
+    , pvVotedBlock :: Point blk
+    , pvVoteVoterId :: VoterId
+    }
+    deriving stock (Generic, Eq, Ord, Show)
+    deriving anyclass NoThunks
+
   -- TODO: enrich with actual error types
   -- see https://github.com/tweag/cardano-peras/issues/120
   data PerasValidationErr blk
     = PerasValidationErr
     deriving stock (Show, Eq)
 
+  data PerasForgeErr blk
+    = PerasForgeErrMismatchedTarget
+    | PerasForgeErrInsufficientVotes
+    deriving stock (Show, Eq)
+
   -- TODO: perform actual validation against all
   -- possible 'PerasValidationErr' variants
   -- see https://github.com/tweag/cardano-peras/issues/120
@@ -149,9 +270,50 @@ instance StandardHash blk => BlockSupportsPeras blk where
         , vpcCertBoost = perasCfgWeightBoost cfg
         }
 
+  validatePerasVote _cfg vote stakeDistr =
+    let stake = getPerasVoteStakeOf stakeDistr (pvVoteVoterId vote)
+     in Right (ValidatedPerasVote{vpvVote = vote, vpvVoteStake = stake})
+
+  forgePerasCert cfg target votes =
+    let allMatchTarget = all (\v -> getPerasVoteTarget v == target) votes
+        hasSufficientStake =
+          let totalStake = mconcat (map vpvVoteStake votes)
+           in totalStake >= perasCfgQuorumThreshold cfg
+     in if not allMatchTarget
+          then Left PerasForgeErrMismatchedTarget
+          else
+            if not hasSufficientStake
+              then Left PerasForgeErrInsufficientVotes
+              else
+                Right
+                  ValidatedPerasCert
+                    { vpcCert =
+                        PerasCert
+                          { pcCertRound = fst target
+                          , pcCertBoostedBlock = snd target
+                          }
+                    , vpcCertBoost = perasCfgWeightBoost cfg
+                    }
+
+instance HasId (PerasCert blk) where
+  type IdOf (PerasCert blk) = PerasRoundNo
+  getId = pcCertRound
+
+-- TODO: Orphan instance
+instance Serialise (KeyHash 'StakePool) where
+  encode = KeyHash.toCBOR
+  decode = KeyHash.fromCBOR
+
+instance HasId (PerasVote blk) where
+  type IdOf (PerasVote blk) = (PerasRoundNo, VoterId)
+  getId vote = (pvVoteRound vote, pvVoteVoterId vote)
+
 instance ShowProxy blk => ShowProxy (PerasCert blk) where
   showProxy _ = "PerasCert " <> showProxy (Proxy @blk)
 
+instance ShowProxy blk => ShowProxy (PerasVote blk) where
+  showProxy _ = "PerasVote " <> showProxy (Proxy @blk)
+
 instance Serialise (HeaderHash blk) => Serialise (PerasCert blk) where
   encode PerasCert{pcCertRound, pcCertBoostedBlock} =
     encodeListLen 2
@@ -163,6 +325,19 @@ instance Serialise (HeaderHash blk) => Serialise (PerasCert blk) where
     pcCertBoostedBlock <- decode
     pure $ PerasCert{pcCertRound, pcCertBoostedBlock}
 
+instance Serialise (HeaderHash blk) => Serialise (PerasVote blk) where
+  encode PerasVote{pvVoteRound, pvVotedBlock, pvVoteVoterId} =
+    encodeListLen 3
+      <> encode pvVoteRound
+      <> encode pvVotedBlock
+      <> KeyHash.toCBOR pvVoteVoterId
+  decode = do
+    decodeListLenOf 3
+    pvVoteRound <- decode
+    pvVotedBlock <- decode
+    pvVoteVoterId <- KeyHash.fromCBOR
+    pure $ PerasVote{pvVoteRound, pvVotedBlock, pvVoteVoterId}
+
 -- | Derive a 'PerasCfg' from a 'BlockConfig'
 --
 -- TODO: this currently doesn't depend on 'BlockConfig' at all, but likely will
@@ -172,6 +347,7 @@ makePerasCfg :: Maybe (BlockConfig blk) -> PerasCfg blk
 makePerasCfg _ =
   PerasCfg
     { perasCfgWeightBoost = boostPerCert
+    , perasCfgQuorumThreshold = quorumThreshold
     }
 
 -- | Extract the certificate round from a Peras certificate container
@@ -218,3 +394,51 @@ instance
   HasPerasCertBoost (WithArrivalTime cert)
   where
   getPerasCertBoost = getPerasCertBoost . forgetArrivalTime
+
+class HasPerasVoteRound vote where
+  getPerasVoteRound :: vote -> PerasRoundNo
+instance HasPerasVoteRound (PerasVote blk) where
+  getPerasVoteRound = pvVoteRound
+instance HasPerasVoteRound (ValidatedPerasVote blk) where
+  getPerasVoteRound = getPerasVoteRound . vpvVote
+instance
+  HasPerasVoteRound vote =>
+  HasPerasVoteRound (WithArrivalTime vote)
+  where
+  getPerasVoteRound = getPerasVoteRound . forgetArrivalTime
+
+class HasPerasVoteVotedBlock vote blk | vote -> blk where
+  getPerasVoteVotedBlock :: vote -> Point blk
+instance HasPerasVoteVotedBlock (PerasVote blk) blk where
+  getPerasVoteVotedBlock = pvVotedBlock
+instance HasPerasVoteVotedBlock (ValidatedPerasVote blk) blk where
+  getPerasVoteVotedBlock = getPerasVoteVotedBlock . vpvVote
+instance
+  HasPerasVoteVotedBlock vote blk =>
+  HasPerasVoteVotedBlock (WithArrivalTime vote) blk
+  where
+  getPerasVoteVotedBlock = getPerasVoteVotedBlock . forgetArrivalTime
+
+class HasPerasVoteVoterId vote where
+  getPerasVoteVoterId :: vote -> VoterId
+instance HasPerasVoteVoterId (PerasVote blk) where
+  getPerasVoteVoterId = pvVoteVoterId
+instance HasPerasVoteVoterId (ValidatedPerasVote blk) where
+  getPerasVoteVoterId = getPerasVoteVoterId . vpvVote
+instance
+  HasPerasVoteVoterId vote =>
+  HasPerasVoteVoterId (WithArrivalTime vote)
+  where
+  getPerasVoteVoterId = getPerasVoteVoterId . forgetArrivalTime
+
+class HasPerasVoteTarget vote blk | vote -> blk where
+  getPerasVoteTarget :: vote -> PerasVoteTarget blk
+instance HasPerasVoteTarget (PerasVote blk) blk where
+  getPerasVoteTarget vote = (pvVoteRound vote, pvVotedBlock vote)
+instance HasPerasVoteTarget (ValidatedPerasVote blk) blk where
+  getPerasVoteTarget vote = getPerasVoteTarget (vpvVote vote)
+instance
+  HasPerasVoteTarget vote blk =>
+  HasPerasVoteTarget (WithArrivalTime vote) blk
+  where
+  getPerasVoteTarget = getPerasVoteTarget . forgetArrivalTime
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs
new file mode 100644
index 0000000000..8845a2e33c
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs
@@ -0,0 +1 @@
+module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasVote () where
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasVote.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasVote.hs
new file mode 100644
index 0000000000..1efadd943c
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasVote.hs
@@ -0,0 +1,54 @@
+-- | This module defines type aliases for the ObjectDiffusion protocol applied
+-- to PerasVote diffusion.
+module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasVote
+  ( TracePerasVoteDiffusionInbound
+  , TracePerasVoteDiffusionOutbound
+  , PerasVotePoolReader
+  , PerasVotePoolWriter
+  , PerasVoteDiffusionInboundPipelined
+  , PerasVoteDiffusionOutbound
+  , PerasVoteDiffusion
+  , PerasVoteDiffusionInboundState
+  , PerasVoteDiffusionInboundHandle
+  , PerasVoteDiffusionInboundHandleCollection
+  ) where
+
+import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1.State
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound
+import Ouroboros.Consensus.Storage.PerasVoteDB.API
+import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound (ObjectDiffusionInboundPipelined)
+import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (ObjectDiffusionOutbound)
+import Ouroboros.Network.Protocol.ObjectDiffusion.Type (ObjectDiffusion)
+
+type TracePerasVoteDiffusionInbound blk =
+  TraceObjectDiffusionInbound PerasRoundNo (PerasVote blk)
+
+type TracePerasVoteDiffusionOutbound blk =
+  TraceObjectDiffusionOutbound PerasRoundNo (PerasVote blk)
+
+type PerasVotePoolReader blk m =
+  ObjectPoolReader PerasRoundNo (PerasVote blk) PerasVoteTicketNo m
+
+type PerasVotePoolWriter blk m =
+  ObjectPoolWriter PerasRoundNo (PerasVote blk) m
+
+type PerasVoteDiffusionInboundPipelined blk m a =
+  ObjectDiffusionInboundPipelined PerasRoundNo (PerasVote blk) m a
+
+type PerasVoteDiffusionOutbound blk m a =
+  ObjectDiffusionOutbound PerasRoundNo (PerasVote blk) m a
+
+type PerasVoteDiffusion blk =
+  ObjectDiffusion PerasRoundNo (PerasVote blk)
+
+type PerasVoteDiffusionInboundState blk =
+  ObjectDiffusionInboundState blk
+
+type PerasVoteDiffusionInboundHandle m blk =
+  ObjectDiffusionInboundHandle m blk
+
+type PerasVoteDiffusionInboundHandleCollection peer m blk =
+  ObjectDiffusionInboundHandleCollection peer m blk
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs
index 6a4fc87229..8b69597daa 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -36,6 +37,8 @@ module Ouroboros.Consensus.Node.Serialisation
   , Some (..)
   ) where
 
+import qualified Cardano.Binary as KeyHash
+import Cardano.Ledger.Core
 import Codec.CBOR.Decoding (Decoder, decodeListLenOf)
 import Codec.CBOR.Encoding (Encoding, encodeListLen)
 import Codec.Serialise (Serialise (decode, encode))
@@ -206,6 +209,22 @@ instance ConvertRawHash blk => SerialiseNodeToNode blk (PerasCert blk) where
     pcCertRound <- decodeNodeToNode ccfg version
     pcCertBoostedBlock <- decodeNodeToNode ccfg version
     pure $ PerasCert pcCertRound pcCertBoostedBlock
+instance ConvertRawHash blk => SerialiseNodeToNode blk (PerasVote blk) where
+  -- Consistent with the 'Serialise' instance for 'PerasVote' defined in Ouroboros.Consensus.Block.SupportsPeras
+  encodeNodeToNode ccfg version PerasVote{..} =
+    encodeListLen 2
+      <> encodeNodeToNode ccfg version pvVoteRound
+      <> encodeNodeToNode ccfg version pvVotedBlock
+  decodeNodeToNode ccfg version = do
+    decodeListLenOf 3
+    pvVoteRound <- decodeNodeToNode ccfg version
+    pvVotedBlock <- decodeNodeToNode ccfg version
+    pvVoteStakePoolId <- decodeNodeToNode ccfg version
+    pure $ PerasVote pvVoteRound pvVotedBlock pvVoteStakePoolId
+
+instance SerialiseNodeToNode blk (KeyHash 'StakePool) where
+  encodeNodeToNode _ccfg _version = KeyHash.toCBOR
+  decodeNodeToNode _ccfg _version = KeyHash.fromCBOR
 
 deriving newtype instance
   SerialiseNodeToClient blk (GenTxId blk) =>
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB.hs
new file mode 100644
index 0000000000..b30ffb2526
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB.hs
@@ -0,0 +1 @@
+module Ouroboros.Consensus.Storage.PerasVoteDB () where
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs
new file mode 100644
index 0000000000..602f733cec
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Ouroboros.Consensus.Storage.PerasVoteDB.API
+  ( PerasVoteDB (..)
+  , AddPerasVoteResult (..)
+
+    -- * 'PerasVoteSnapshot'
+  , PerasVoteSnapshot (..)
+  , PerasVoteTicketNo
+  , zeroPerasVoteTicketNo
+  ) where
+
+import Data.Map (Map)
+import Data.Word (Word64)
+import GHC.Generics (Generic)
+import NoThunks.Class
+import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime)
+import Ouroboros.Consensus.Util.MonadSTM.NormalForm
+  ( MonadSTM (STM)
+  )
+
+data PerasVoteDB m blk = PerasVoteDB
+  { addVote :: WithArrivalTime (ValidatedPerasVote blk) -> m (AddPerasVoteResult blk)
+  -- ^ Add a Peras vote to the database. The result indicates whether
+  -- the vote was actually added, or if it was already present.
+  , getVoteSnapshot :: STM m (PerasVoteSnapshot blk)
+  -- ^ Interface to read the known votes, mostly for diffusion
+  , getForgedCertForRound :: PerasRoundNo -> STM m (Maybe (ValidatedPerasCert blk))
+  -- ^ Get the certificate if quorum was reached for the given round.
+  , garbageCollect :: PerasRoundNo -> m ()
+  -- ^ Garbage-collect state strictly older than the given slot number.
+  , closeDB :: m ()
+  }
+  deriving NoThunks via OnlyCheckWhnfNamed "PerasVoteDB" (PerasVoteDB m blk)
+
+data AddPerasVoteResult blk
+  = PerasVoteAlreadyInDB
+  | AddedPerasVoteButDidntGenerateNewCert
+  | AddedPerasVoteAndGeneratedNewCert (ValidatedPerasCert blk)
+  deriving stock (Generic, Eq, Ord, Show)
+  deriving anyclass NoThunks
+
+data PerasVoteSnapshot blk = PerasVoteSnapshot
+  { containsVote :: IdOf (PerasVote blk) -> Bool
+  , getVotesAfter ::
+      PerasVoteTicketNo ->
+      Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
+  -- ^ Get votes after the given ticket number (excluded).
+  -- The result is a map of ticket numbers to validated votes.
+  }
+
+-- | A sequence number, incremented every time we receive a new vote.
+newtype PerasVoteTicketNo = PerasVoteTicketNo Word64
+  deriving stock Show
+  deriving newtype (Eq, Ord, Enum, NoThunks)
+
+zeroPerasVoteTicketNo :: PerasVoteTicketNo
+zeroPerasVoteTicketNo = PerasVoteTicketNo 0
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs
new file mode 100644
index 0000000000..38a8dabc28
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs
@@ -0,0 +1,716 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-partial-fields #-}
+
+module Ouroboros.Consensus.Storage.PerasVoteDB.Impl
+  ( -- * Opening
+    PerasVoteDbArgs (..)
+  , defaultArgs
+  , openDB
+
+    -- * Trace types
+  , TraceEvent (..)
+
+    -- * Exceptions
+  , PerasVoteDbError (..)
+  ) where
+
+import Cardano.Prelude (Word64)
+import Control.Tracer (Tracer, nullTracer, traceWith)
+import Data.Data (Typeable)
+import Data.Foldable qualified as Foldable
+import Data.Functor.Compose (Compose (..))
+import Data.Kind (Type)
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as Map
+import Data.Maybe (fromMaybe)
+import Data.Set (Set)
+import Data.Set qualified as Set
+import GHC.Generics (Generic)
+import NoThunks.Class
+import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.BlockchainTime (WithArrivalTime (forgetArrivalTime))
+import Ouroboros.Consensus.Storage.PerasVoteDB.API
+import Ouroboros.Consensus.Util.Args
+import Ouroboros.Consensus.Util.CallStack
+import Ouroboros.Consensus.Util.IOLike
+import Ouroboros.Consensus.Util.STM
+
+-- | Tally of votes for a given target (round number and block point).
+data PerasTargetVoteTally blk = PerasTargetVoteTally
+  { ptvtTarget :: !(PerasVoteTarget blk)
+  , ptvtVotes :: !(Map (IdOf (PerasVote blk)) (WithArrivalTime (ValidatedPerasVote blk)))
+  , ptvtTotalStake :: !PerasVoteStake
+  }
+  deriving stock (Generic, Eq, Ord, Show)
+  deriving anyclass NoThunks
+
+instance HasPerasVoteTarget (PerasTargetVoteTally blk) blk where
+  getPerasVoteTarget = ptvtTarget
+
+instance HasPerasVoteRound (PerasTargetVoteTally blk) where
+  getPerasVoteRound = fst . getPerasVoteTarget
+
+instance HasPerasVoteVotedBlock (PerasTargetVoteTally blk) blk where
+  getPerasVoteVotedBlock = snd . getPerasVoteTarget
+
+freshTargetVoteTally :: PerasVoteTarget blk -> PerasTargetVoteTally blk
+freshTargetVoteTally target =
+  PerasTargetVoteTally
+    { ptvtTarget = target
+    , ptvtVotes = Map.empty
+    , ptvtTotalStake = PerasVoteStake 0
+    }
+
+-- | Check whether the given target vote tally's stake is above quorum.
+voteTallyAboveQuorum ::
+  PerasCfg blk ->
+  PerasTargetVoteTally blk ->
+  Bool
+voteTallyAboveQuorum PerasCfg{perasCfgQuorumThreshold} ptvt =
+  ptvtTotalStake ptvt >= perasCfgQuorumThreshold
+
+-- | Add a vote to an existing target tally if it isn't already present,
+-- and update the stake accordingly.
+-- PRECONDITION: the vote's target must match the tally's target.
+updateTargetVoteTally ::
+  StandardHash blk =>
+  WithArrivalTime (ValidatedPerasVote blk) ->
+  PerasTargetVoteTally blk ->
+  PerasTargetVoteTally blk
+updateTargetVoteTally
+  vote
+  ptvt@PerasTargetVoteTally
+    { ptvtTarget
+    , ptvtVotes
+    , ptvtTotalStake
+    } =
+    if getPerasVoteTarget vote /= ptvtTarget
+      then error "updatePerasVoteTally: vote target does not match tally target"
+      else
+        let (pvaVotes', pvaTotalStake') =
+              case Map.insertLookupWithKey
+                (\_k old _new -> old)
+                (getId vote)
+                vote
+                ptvtVotes of
+                (Nothing, votes') ->
+                  -- key was NOT present → inserted and stake updated
+                  (votes', ptvtTotalStake + vpvVoteStake (forgetArrivalTime vote))
+                (Just _, _) ->
+                  -- key WAS already present → votes and stake unchanged
+                  (ptvtVotes, ptvtTotalStake)
+         in ptvt{ptvtVotes = pvaVotes', ptvtTotalStake = pvaTotalStake'}
+
+-------------------------------------------------------------------------------
+
+-- | Indicate the current status of the target w.r.t the voting process.
+data PerasTargetVoteStatus
+  = Candidate
+  | Winner
+  | Loser
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving anyclass NoThunks
+
+-- | Voting state for a given target.
+-- We indicate at type level the status of the target w.r.t the voting process.
+data PerasTargetVoteState blk (status :: PerasTargetVoteStatus) where
+  PerasTargetVoteCandidate ::
+    !(PerasTargetVoteTally blk) ->
+    PerasTargetVoteState blk 'Candidate
+  PerasTargetVoteLoser ::
+    !(PerasTargetVoteTally blk) ->
+    PerasTargetVoteState blk 'Loser
+  PerasTargetVoteWinner ::
+    !(PerasTargetVoteTally blk) ->
+    -- | Number of extra votes received since the target was elected winner /
+    -- the cert was forged.
+    !Word64 ->
+    !(ValidatedPerasCert blk) ->
+    PerasTargetVoteState blk 'Winner
+
+deriving stock instance
+  ( Eq (PerasTargetVoteTally blk)
+  , Eq (ValidatedPerasCert blk)
+  ) =>
+  Eq (PerasTargetVoteState blk status)
+
+deriving stock instance
+  ( Ord (PerasTargetVoteTally blk)
+  , Ord (ValidatedPerasCert blk)
+  ) =>
+  Ord (PerasTargetVoteState blk status)
+
+deriving stock instance
+  ( Show (PerasTargetVoteTally blk)
+  , Show (ValidatedPerasCert blk)
+  ) =>
+  Show (PerasTargetVoteState blk status)
+
+instance
+  ( NoThunks (PerasTargetVoteTally blk)
+  , NoThunks (ValidatedPerasCert blk)
+  ) =>
+  NoThunks (PerasTargetVoteState blk status)
+  where
+  -- avoid the Generic-based default
+  showTypeOf _ = "PerasTargetVoteState"
+
+  -- we can just delegate wNoThunks to our custom noThunks
+  wNoThunks = noThunks
+
+  noThunks ctx (PerasTargetVoteCandidate tally) =
+    noThunks ctx tally
+  noThunks ctx (PerasTargetVoteLoser tally) =
+    noThunks ctx tally
+  noThunks ctx (PerasTargetVoteWinner tally w cert) =
+    noThunks ctx (tally, w, cert)
+
+instance HasPerasVoteTarget (PerasTargetVoteState blk status) blk where
+  getPerasVoteTarget = getPerasVoteTarget . ptvsVoteTally
+
+instance HasPerasVoteRound (PerasTargetVoteState blk status) where
+  getPerasVoteRound = getPerasVoteRound . ptvsVoteTally
+
+instance HasPerasVoteVotedBlock (PerasTargetVoteState blk status) blk where
+  getPerasVoteVotedBlock = getPerasVoteVotedBlock . ptvsVoteTally
+
+ptvsVoteTally :: PerasTargetVoteState blk status -> PerasTargetVoteTally blk
+ptvsVoteTally = \case
+  PerasTargetVoteCandidate tally -> tally
+  PerasTargetVoteLoser tally -> tally
+  PerasTargetVoteWinner tally _ _ -> tally
+
+freshCandidateVoteState :: PerasVoteTarget blk -> PerasTargetVoteState blk 'Candidate
+freshCandidateVoteState target =
+  PerasTargetVoteCandidate (freshTargetVoteTally target)
+
+freshLoserVoteState :: PerasVoteTarget blk -> PerasTargetVoteState blk 'Loser
+freshLoserVoteState target =
+  PerasTargetVoteLoser (freshTargetVoteTally target)
+
+-- | Convert a 'Candidate' state to a 'Loser' state. This function is called on
+-- all candidates (except the winner) once a winner is elected.
+candidateToLoser ::
+  PerasCfg blk ->
+  PerasTargetVoteState blk 'Candidate ->
+  PerasTargetVoteState blk 'Loser
+candidateToLoser cfg (PerasTargetVoteCandidate tally) =
+  if voteTallyAboveQuorum cfg tally
+    then error "candidateToLoser: candidate is above quorum"
+    else PerasTargetVoteLoser tally
+
+-- | Add a vote to an existing target vote state if it isn't already present
+-- PRECONDITION: the vote's target must match the underlying tally's target.
+--
+-- May fail if the candidate is elected winner but forging the certificate fails.
+updateCandidateVoteState ::
+  StandardHash blk =>
+  PerasCfg blk ->
+  WithArrivalTime (ValidatedPerasVote blk) ->
+  PerasTargetVoteState blk 'Candidate ->
+  Either
+    (PerasForgeErr blk)
+    (Either (PerasTargetVoteState blk 'Candidate) (PerasTargetVoteState blk 'Winner))
+updateCandidateVoteState cfg vote oldState =
+  let newVoteTally = updateTargetVoteTally vote (ptvsVoteTally oldState)
+      voteList = forgetArrivalTime <$> Map.elems (ptvtVotes newVoteTally)
+   in if voteTallyAboveQuorum cfg newVoteTally
+        then case forgePerasCert cfg (ptvtTarget newVoteTally) voteList of
+          Left err -> Left $ err
+          Right cert -> Right $ Right $ PerasTargetVoteWinner newVoteTally 0 cert
+        else Right $ Left $ PerasTargetVoteCandidate newVoteTally
+
+-- | Add a vote to an existing target vote state if it isn't already present
+-- PRECONDITION: the vote's target must match the underlying tally's target.
+--
+-- May fail if the loser goes above quorum by adding the vote.
+updateLoserVoteState ::
+  StandardHash blk =>
+  PerasCfg blk ->
+  WithArrivalTime (ValidatedPerasVote blk) ->
+  PerasTargetVoteState blk 'Loser ->
+  Either (PerasTargetVoteState blk 'Loser) (PerasTargetVoteState blk 'Loser)
+updateLoserVoteState cfg vote oldState =
+  let newVoteTally = updateTargetVoteTally vote (ptvsVoteTally oldState)
+      aboveQuorum = voteTallyAboveQuorum cfg newVoteTally
+   in if aboveQuorum
+        then Left $ PerasTargetVoteLoser newVoteTally
+        else Right $ PerasTargetVoteLoser newVoteTally
+
+-- | Add a vote to an existing target vote state if it isn't already present
+-- PRECONDITION: the vote's target must match the underlying tally's target.
+updateWinnerVoteState ::
+  StandardHash blk =>
+  WithArrivalTime (ValidatedPerasVote blk) ->
+  PerasTargetVoteState blk 'Winner ->
+  PerasTargetVoteState blk 'Winner
+updateWinnerVoteState vote oldState =
+  let newVoteTally = updateTargetVoteTally vote (ptvsVoteTally oldState)
+      (PerasTargetVoteWinner _ extraCertCount cert) = oldState
+   in PerasTargetVoteWinner newVoteTally (extraCertCount + 1) cert
+
+-------------------------------------------------------------------------------
+
+-- | Current vote state for a given round.
+data PerasRoundVoteState blk
+  = PerasRoundVoteStateQuorumNotReached
+      { prvsRoundNo :: !PerasRoundNo
+      , prvsCandidateStates :: !(Map (Point blk) (PerasTargetVoteState blk 'Candidate))
+      }
+  | PerasRoundVoteStateQuorumReachedAlready
+      { prvsRoundNo :: !PerasRoundNo
+      , prvsLoserStates :: !(Map (Point blk) (PerasTargetVoteState blk 'Loser))
+      , prvsWinnerState :: !(PerasTargetVoteState blk 'Winner)
+      }
+  deriving stock (Generic, Eq, Ord, Show)
+  deriving anyclass NoThunks
+
+instance HasPerasVoteRound (PerasRoundVoteState blk) where
+  getPerasVoteRound = prvsRoundNo
+
+-- | Get the certificate if quorum was reached for the given round.
+prvsMaybeCert :: PerasRoundVoteState blk -> Maybe (ValidatedPerasCert blk)
+prvsMaybeCert = \case
+  PerasRoundVoteStateQuorumNotReached{} -> Nothing
+  PerasRoundVoteStateQuorumReachedAlready{prvsWinnerState = PerasTargetVoteWinner _ _ cert} ->
+    Just cert
+
+freshRoundVoteState ::
+  PerasRoundNo ->
+  PerasRoundVoteState blk
+freshRoundVoteState roundNo =
+  PerasRoundVoteStateQuorumNotReached
+    { prvsRoundNo = roundNo
+    , prvsCandidateStates = Map.empty
+    }
+
+data UpdateRoundVoteStateError blk
+  = RoundVoteStateLoserAboveQuorum (PerasTargetVoteState blk 'Winner) (PerasTargetVoteState blk 'Loser)
+  | RoundVoteStateForgingCertError (PerasForgeErr blk)
+
+-- | Add a vote to an existing round aggregate.
+-- PRECONDITION: the vote's round must match the aggregate's round.
+--
+-- May fail if the state transition is invalid (e.g., a loser going above
+-- quorum) or if forging the certificate fails.
+updatePerasRoundVoteState ::
+  forall blk.
+  StandardHash blk =>
+  WithArrivalTime (ValidatedPerasVote blk) ->
+  PerasCfg blk ->
+  PerasRoundVoteState blk ->
+  Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
+updatePerasRoundVoteState vote cfg roundState =
+  if getPerasVoteRound vote /= getPerasVoteRound roundState
+    then error "updatePerasRoundVoteTallys: vote round does not match aggregate round"
+    else case roundState of
+      PerasRoundVoteStateQuorumNotReached{prvsCandidateStates} ->
+        let oldCandidateState =
+              Map.findWithDefault
+                (freshCandidateVoteState (getPerasVoteTarget vote))
+                (getPerasVoteVotedBlock vote)
+                prvsCandidateStates
+         in case updateCandidateVoteState cfg vote oldCandidateState of
+              Left err -> Left $ RoundVoteStateForgingCertError err
+              Right (Left newCandidateState) ->
+                let prvsCandidateStates' =
+                      Map.insert
+                        (getPerasVoteVotedBlock vote)
+                        newCandidateState
+                        prvsCandidateStates
+                 in Right $
+                      PerasRoundVoteStateQuorumNotReached
+                        { prvsRoundNo = prvsRoundNo roundState
+                        , prvsCandidateStates = prvsCandidateStates'
+                        }
+              Right (Right winnerState) ->
+                let winnerPoint = getPerasVoteVotedBlock winnerState
+                    loserStates = candidateToLoser cfg <$> (Map.delete winnerPoint prvsCandidateStates)
+                 in Right $
+                      PerasRoundVoteStateQuorumReachedAlready
+                        { prvsRoundNo = prvsRoundNo roundState
+                        , prvsLoserStates = loserStates
+                        , prvsWinnerState = winnerState
+                        }
+      state@PerasRoundVoteStateQuorumReachedAlready{prvsLoserStates, prvsWinnerState} ->
+        let votePoint = getPerasVoteVotedBlock vote
+            winnerPoint = getPerasVoteVotedBlock prvsWinnerState
+
+            updateMaybeLoser ::
+              Maybe (PerasTargetVoteState blk 'Loser) ->
+              Either (PerasTargetVoteState blk 'Loser) (PerasTargetVoteState blk 'Loser)
+            updateMaybeLoser mState =
+              updateLoserVoteState cfg vote (fromMaybe (freshLoserVoteState (getPerasVoteTarget vote)) mState)
+         in if votePoint == winnerPoint
+              then Right $ state{prvsWinnerState = updateWinnerVoteState vote prvsWinnerState}
+              else case Map.alterF (\mState -> Just <$> updateMaybeLoser mState) votePoint prvsLoserStates of
+                Left newLoserStateAboveQuorum ->
+                  Left $ RoundVoteStateLoserAboveQuorum prvsWinnerState newLoserStateAboveQuorum
+                Right prvsLoserStates' ->
+                  Right $ state{prvsLoserStates = prvsLoserStates'}
+
+-- | Updates the round vote states map with the given vote.
+-- A new entry is created if necessary (i.e., if there is no existing state for
+-- the vote's round).
+--
+-- May fail if the state transition is invalid (e.g., a loser going above
+-- quorum) or if forging the certificate fails.
+updatePerasRoundVoteStates ::
+  forall blk.
+  StandardHash blk =>
+  WithArrivalTime (ValidatedPerasVote blk) ->
+  PerasCfg blk ->
+  Map PerasRoundNo (PerasRoundVoteState blk) ->
+  Either
+    (UpdateRoundVoteStateError blk)
+    (PerasRoundVoteState blk, Map PerasRoundNo (PerasRoundVoteState blk))
+updatePerasRoundVoteStates vote cfg =
+  -- We use the Functor instance of `Compose (Either e) ((,) s)` ≅ `λt. Either e (s, t)` in `Map.alterF`
+  -- That way, we can return both the updated map and the updated leaf in one pass,
+  -- and still handle errors.
+  getCompose
+    . Map.alterF
+      (\mState -> Just <$> updateMaybeRoundState mState)
+      (getPerasVoteRound vote)
+ where
+  updateMaybeRoundState ::
+    Maybe (PerasRoundVoteState blk) ->
+    Compose
+      (Either (UpdateRoundVoteStateError blk))
+      ((,) (PerasRoundVoteState blk))
+      (PerasRoundVoteState blk)
+  updateMaybeRoundState mRoundState = Compose $
+    case updatePerasRoundVoteState
+      vote
+      cfg
+      (fromMaybe (freshRoundVoteState (getPerasVoteRound vote)) mRoundState) of
+      Left err -> Left err
+      Right newRoundState -> Right (newRoundState, newRoundState)
+
+{------------------------------------------------------------------------------
+  Opening the database
+------------------------------------------------------------------------------}
+
+type PerasVoteDbArgs :: (Type -> Type) -> (Type -> Type) -> Type -> Type
+data PerasVoteDbArgs f m blk = PerasVoteDbArgs
+  { pvdbaTracer :: Tracer m (TraceEvent blk)
+  , pvdbaPerasCfg :: HKD f (PerasCfg blk)
+  }
+
+defaultArgs :: Applicative m => Incomplete PerasVoteDbArgs m blk
+defaultArgs =
+  PerasVoteDbArgs
+    { pvdbaTracer = nullTracer
+    , pvdbaPerasCfg = noDefault
+    }
+
+openDB ::
+  forall m blk.
+  ( IOLike m
+  , StandardHash blk
+  , Typeable blk
+  ) =>
+  Complete PerasVoteDbArgs m blk ->
+  m (PerasVoteDB m blk)
+openDB args@PerasVoteDbArgs{pvdbaPerasCfg} = do
+  pvdbPerasVoteStateVar <-
+    newTVarWithInvariantIO
+      (either Just (const Nothing) . invariantForPerasVoteState)
+      initialPerasVoteState
+  let env =
+        PerasVoteDbEnv
+          { pvdbTracer
+          , pvdbPerasVoteStateVar
+          }
+  h <- PerasVoteDbHandle <$> newTVarIO (PerasVoteDbOpen env)
+  traceWith pvdbTracer OpenedPerasVoteDB
+  pure
+    PerasVoteDB
+      { addVote = getEnv1 h (implAddVote pvdbaPerasCfg)
+      , getVoteSnapshot = getEnvSTM h implGetVoteSnapshot
+      , getForgedCertForRound = getEnvSTM1 h implForgedCertForRound
+      , garbageCollect = getEnv1 h implGarbageCollect
+      , closeDB = implCloseDB h
+      }
+ where
+  PerasVoteDbArgs
+    { pvdbaTracer = pvdbTracer
+    } = args
+
+{-------------------------------------------------------------------------------
+  Database state
+-------------------------------------------------------------------------------}
+
+newtype PerasVoteDbHandle m blk = PerasVoteDbHandle (StrictTVar m (PerasVoteDbState m blk))
+
+data PerasVoteDbState m blk
+  = PerasVoteDbOpen !(PerasVoteDbEnv m blk)
+  | PerasVoteDbClosed
+  deriving stock Generic
+  deriving anyclass NoThunks
+
+data PerasVoteDbEnv m blk = PerasVoteDbEnv
+  { pvdbTracer :: !(Tracer m (TraceEvent blk))
+  , pvdbPerasVoteStateVar :: !(StrictTVar m (WithFingerprint (PerasVoteState blk)))
+  -- ^ The 'RoundNo's of all votes currently in the db.
+  }
+  deriving NoThunks via OnlyCheckWhnfNamed "PerasVoteDbEnv" (PerasVoteDbEnv m blk)
+
+getEnv ::
+  forall m r blk.
+  (IOLike m, HasCallStack, StandardHash blk, Typeable blk) =>
+  PerasVoteDbHandle m blk ->
+  (PerasVoteDbEnv m blk -> m r) ->
+  m r
+getEnv (PerasVoteDbHandle varState) f =
+  readTVarIO varState >>= \case
+    PerasVoteDbOpen env -> f env
+    PerasVoteDbClosed -> throwIO $ ClosedDBError @blk prettyCallStack
+
+getEnv1 ::
+  (IOLike m, HasCallStack, StandardHash blk, Typeable blk) =>
+  PerasVoteDbHandle m blk ->
+  (PerasVoteDbEnv m blk -> a -> m r) ->
+  a ->
+  m r
+getEnv1 h f a = getEnv h (\env -> f env a)
+
+getEnvSTM ::
+  forall m r blk.
+  (IOLike m, HasCallStack, StandardHash blk, Typeable blk) =>
+  PerasVoteDbHandle m blk ->
+  (PerasVoteDbEnv m blk -> STM m r) ->
+  STM m r
+getEnvSTM (PerasVoteDbHandle varState) f =
+  readTVar varState >>= \case
+    PerasVoteDbOpen env -> f env
+    PerasVoteDbClosed -> throwIO $ ClosedDBError @blk prettyCallStack
+
+getEnvSTM1 ::
+  (IOLike m, HasCallStack, StandardHash blk, Typeable blk) =>
+  PerasVoteDbHandle m blk ->
+  (PerasVoteDbEnv m blk -> a -> STM m r) ->
+  a ->
+  STM m r
+getEnvSTM1 h f a = getEnvSTM h (\env -> f env a)
+
+{-------------------------------------------------------------------------------
+  API implementation
+-------------------------------------------------------------------------------}
+
+implCloseDB :: IOLike m => PerasVoteDbHandle m blk -> m ()
+implCloseDB (PerasVoteDbHandle varState) =
+  atomically (swapTVar varState PerasVoteDbClosed) >>= \case
+    PerasVoteDbOpen PerasVoteDbEnv{pvdbTracer} -> do
+      traceWith pvdbTracer ClosedPerasVoteDB
+    -- DB was already closed.
+    PerasVoteDbClosed -> pure ()
+
+-- TODO: we will need to update this method with non-trivial validation logic
+-- see https://github.com/tweag/cardano-peras/issues/120
+implAddVote ::
+  ( IOLike m
+  , StandardHash blk
+  , Typeable blk
+  ) =>
+  PerasCfg blk ->
+  PerasVoteDbEnv m blk ->
+  WithArrivalTime (ValidatedPerasVote blk) ->
+  m (AddPerasVoteResult blk)
+implAddVote
+  perasCfg
+  PerasVoteDbEnv
+    { pvdbTracer
+    , pvdbPerasVoteStateVar
+    }
+  vote = do
+    let voteId = getId vote
+        voteTarget = getPerasVoteTarget vote
+        voteStake = vpvVoteStake (forgetArrivalTime vote)
+
+    traceWith pvdbTracer $ AddingPerasVote voteTarget voteId voteStake
+
+    res <- atomically $ do
+      WithFingerprint
+        PerasVoteState
+          { pvsVoteIds
+          , pvsRoundVoteStates
+          , pvsVotesByTicket
+          , pvsLastTicketNo
+          }
+        fp <-
+        readTVar pvdbPerasVoteStateVar
+
+      if Set.member voteId pvsVoteIds
+        then pure PerasVoteAlreadyInDB
+        else do
+          let pvsVoteIds' = Set.insert voteId pvsVoteIds
+              pvsLastTicketNo' = succ pvsLastTicketNo
+              pvsVotesByTicket' = Map.insert pvsLastTicketNo' vote pvsVotesByTicket
+              fp' = succ fp
+          (res, pvsRoundVoteStates') <- case updatePerasRoundVoteStates vote perasCfg pvsRoundVoteStates of
+            Left (RoundVoteStateLoserAboveQuorum winnerState loserState) ->
+              throwSTM $
+                EquivocatingCertError
+                  (getPerasVoteRound vote)
+                  (getPerasVoteVotedBlock winnerState, vpvVoteStake (forgetArrivalTime vote))
+                  (getPerasVoteVotedBlock loserState, vpvVoteStake (forgetArrivalTime vote))
+            Left (RoundVoteStateForgingCertError err) ->
+              throwSTM $ ForgingCertError err
+            Right
+              ( PerasRoundVoteStateQuorumReachedAlready{prvsWinnerState = PerasTargetVoteWinner _ 0 cert}
+                , pvsRoundVoteStates'
+                ) ->
+              pure (AddedPerasVoteAndGeneratedNewCert cert, pvsRoundVoteStates')
+            Right (_, pvsRoundVoteStates') ->
+              pure (AddedPerasVoteButDidntGenerateNewCert, pvsRoundVoteStates')
+          writeTVar pvdbPerasVoteStateVar $
+            WithFingerprint
+              PerasVoteState
+                { pvsVoteIds = pvsVoteIds'
+                , pvsRoundVoteStates = pvsRoundVoteStates'
+                , pvsVotesByTicket = pvsVotesByTicket'
+                , pvsLastTicketNo = pvsLastTicketNo'
+                }
+              fp'
+          pure res
+
+    case res of
+      PerasVoteAlreadyInDB -> traceWith pvdbTracer $ IgnoredVoteAlreadyInDB voteId
+      AddedPerasVoteButDidntGenerateNewCert -> traceWith pvdbTracer $ AddedPerasVote voteId
+      AddedPerasVoteAndGeneratedNewCert newCert -> do
+        traceWith pvdbTracer $ AddedPerasVote voteId
+        traceWith pvdbTracer $ GeneratedPerasCert newCert
+    pure res
+
+implGetVoteSnapshot ::
+  IOLike m =>
+  PerasVoteDbEnv m blk -> STM m (PerasVoteSnapshot blk)
+implGetVoteSnapshot PerasVoteDbEnv{pvdbPerasVoteStateVar} = do
+  PerasVoteState{pvsVoteIds, pvsVotesByTicket} <- forgetFingerprint <$> readTVar pvdbPerasVoteStateVar
+  pure $
+    PerasVoteSnapshot
+      { containsVote = (`Set.member` pvsVoteIds)
+      , getVotesAfter = \ticketNo ->
+          snd $ Map.split ticketNo pvsVotesByTicket
+      }
+
+implForgedCertForRound ::
+  IOLike m =>
+  PerasVoteDbEnv m blk ->
+  PerasRoundNo ->
+  STM m (Maybe (ValidatedPerasCert blk))
+implForgedCertForRound PerasVoteDbEnv{pvdbPerasVoteStateVar} roundNo = do
+  PerasVoteState{pvsRoundVoteStates} <- forgetFingerprint <$> readTVar pvdbPerasVoteStateVar
+  case Map.lookup roundNo pvsRoundVoteStates of
+    Nothing -> pure Nothing
+    Just aggr -> pure $ prvsMaybeCert aggr
+
+implGarbageCollect ::
+  forall m blk.
+  IOLike m =>
+  PerasVoteDbEnv m blk -> PerasRoundNo -> m ()
+implGarbageCollect PerasVoteDbEnv{pvdbPerasVoteStateVar} roundNo =
+  -- No need to update the 'Fingerprint' as we only remove votes that do
+  -- not matter for comparing interesting chains.
+  atomically $ modifyTVar pvdbPerasVoteStateVar (fmap gc)
+ where
+  gc :: PerasVoteState blk -> PerasVoteState blk
+  gc
+    PerasVoteState
+      { pvsVoteIds
+      , pvsRoundVoteStates
+      , pvsVotesByTicket
+      , pvsLastTicketNo
+      } =
+      let pvsRoundVoteStates' =
+            Map.filterWithKey
+              (\rNo _ -> rNo >= roundNo)
+              pvsRoundVoteStates
+          (pvsVotesByTicket', votesToRemove) = Map.partition (\vote -> getPerasVoteRound vote >= roundNo) pvsVotesByTicket
+          pvsVoteIds' =
+            Foldable.foldl'
+              (\set vote -> Set.delete (getId vote) set)
+              pvsVoteIds
+              votesToRemove
+       in PerasVoteState
+            { pvsVoteIds = pvsVoteIds'
+            , pvsRoundVoteStates = pvsRoundVoteStates'
+            , pvsVotesByTicket = pvsVotesByTicket'
+            , pvsLastTicketNo = pvsLastTicketNo
+            }
+
+{-------------------------------------------------------------------------------
+  Implementation-internal types
+-------------------------------------------------------------------------------}
+
+data PerasVoteState blk = PerasVoteState
+  { pvsVoteIds :: !(Set (IdOf (PerasVote blk)))
+  , pvsRoundVoteStates :: !(Map PerasRoundNo (PerasRoundVoteState blk))
+  , pvsVotesByTicket :: !(Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk)))
+  -- ^ The votes by 'PerasVoteTicketNo'.
+  --
+  -- INVARIANT: In sync with 'pvsRoundVoteStates'.
+  , pvsLastTicketNo :: !PerasVoteTicketNo
+  -- ^ The most recent 'PerasVoteTicketNo' (or 'zeroPerasVoteTicketNo'
+  -- otherwise).
+  }
+  deriving stock (Show, Generic)
+  deriving anyclass NoThunks
+
+initialPerasVoteState :: WithFingerprint (PerasVoteState blk)
+initialPerasVoteState =
+  WithFingerprint
+    PerasVoteState
+      { pvsVoteIds = Set.empty
+      , pvsRoundVoteStates = Map.empty
+      , pvsVotesByTicket = Map.empty
+      , pvsLastTicketNo = zeroPerasVoteTicketNo
+      }
+    (Fingerprint 0)
+
+-- | Check that the fields of 'PerasVoteState' are in sync.
+invariantForPerasVoteState ::
+  WithFingerprint (PerasVoteState blk) -> Either String ()
+invariantForPerasVoteState _pvs =
+  -- TODO
+  pure ()
+
+{-------------------------------------------------------------------------------
+  Trace types
+-------------------------------------------------------------------------------}
+
+data TraceEvent blk
+  = OpenedPerasVoteDB
+  | ClosedPerasVoteDB
+  | AddingPerasVote (PerasVoteTarget blk) (IdOf (PerasVote blk)) PerasVoteStake
+  | AddedPerasVote (IdOf (PerasVote blk))
+  | IgnoredVoteAlreadyInDB (IdOf (PerasVote blk))
+  | GeneratedPerasCert (ValidatedPerasCert blk)
+  deriving stock (Show, Eq, Generic)
+
+{-------------------------------------------------------------------------------
+  Exceptions
+-------------------------------------------------------------------------------}
+
+data PerasVoteDbError blk
+  = ClosedDBError PrettyCallStack
+  | EquivocatingCertError PerasRoundNo (Point blk, PerasVoteStake) (Point blk, PerasVoteStake)
+  | ForgingCertError (PerasForgeErr blk)
+  deriving stock Show
+  deriving anyclass Exception