Cardano.Api → Cardano.Api.Typed and HardForkBlock support

lib/core/src/Cardano/Wallet/Network.hs

@@ -141,18 +141,20 @@ data NetworkLayer m target block = NetworkLayer
         -- ^ Broadcast a transaction to the chain producer
 
     , stakeDistribution
-        :: GetStakeDistribution target m
+        :: GetStakeDistribution target block m
 
     , getAccountBalance
         :: ChimericAccount
         -> ExceptT ErrGetAccountBalance m (Quantity "lovelace" Word64)
+
     , timeInterpreter
         :: TimeInterpreter m
     }
 
 instance Functor m => Functor (NetworkLayer m target) where
     fmap f nl = nl
         { nextBlocks = fmap (fmap f) . nextBlocks nl
+        , stakeDistribution = error "fixme: functor instance"
         }
 
 {-------------------------------------------------------------------------------
@@ -242,7 +244,7 @@ defaultRetryPolicy =
                                  Queries
 -------------------------------------------------------------------------------}
 
-type family GetStakeDistribution target (m :: * -> *) :: *
+type family GetStakeDistribution target block (m :: * -> *) :: *
 
 {-------------------------------------------------------------------------------
                                 Chain Sync

lib/core/src/Cardano/Wallet/Primitive/Slotting.hs

@@ -27,6 +27,9 @@ module Cardano.Wallet.Primitive.Slotting
     -- ** Running queries
     , TimeInterpreter
     , singleEraInterpreter
+    , interpreterFromGenesis
+    , mkTimeInterpreter
+    , MyInterpreter(..)
     , Qry
 
       -- * Legacy api
@@ -64,8 +67,11 @@ import Cardano.Wallet.Primitive.Types
     , unsafeEpochNo
     , wholeRange
     )
+import Control.Exception (throwIO)
 import Control.Monad
     ( ap, liftM )
+import Data.Coerce
+    ( coerce )
 import Data.Functor.Identity
     ( Identity )
 import Data.Generics.Internal.VL.Lens
@@ -82,10 +88,13 @@ import GHC.Generics
     ( Generic )
 import Numeric.Natural
     ( Natural )
-import Ouroboros.Consensus.HardFork.History.EraParams
-    ( EraParams (..), noLowerBoundSafeZone )
+import Ouroboros.Consensus.BlockchainTime.WallClock.Types
+    ( SystemStart (..) )
+import Ouroboros.Consensus.HardFork.History.Qry
+    ( Interpreter, mkInterpreter )
 import Ouroboros.Consensus.HardFork.History.Summary
-    ( Summary (..), neverForksSummary )
+    ( neverForksSummary )
+import Ouroboros.Consensus.Util.CallStack (HasCallStack)
 
 import qualified Cardano.Slotting.Slot as Cardano
 import qualified Ouroboros.Consensus.BlockchainTime.WallClock.Types as Cardano
@@ -196,43 +205,46 @@ slotAtTimeDetailed t = do
 -- We cannot manually specify when the fetching happens.
 --
 -- This may or may not be what we actually want.
-type TimeInterpreter m = forall a. Qry a -> m a
---
--- Interpretation
 --
+-- fixme: this rank-2 type is inconvenient to set up in network layer.
+-- fixme: this is backend-specific code -- it should be moved to the shelley package.
+type TimeInterpreter m = forall a. Qry a -> m a
 
-data Interpreter xs = Interpreter
-    { _iSummary :: Summary xs
-    , _iGenesisStartDate :: StartTime
-    }
+-- | The hardfork query intepreter plus start time information.
+data MyInterpreter xs = MyInterpreter SystemStart (Interpreter xs)
 
 -- | An 'Interpreter' for a single era, where the slotting from
 -- @GenesisParameters@ cannot change.
 --
--- Queries can never fail with @singleEraInterpreter@.
-singleEraInterpreter :: GenesisParameters -> TimeInterpreter Identity
-singleEraInterpreter gp q = either bomb return $ runQuery q int
+-- Queries can never fail with @singleEraInterpreter@. This function will throw
+-- a 'PastHorizonException' if they do.
+singleEraInterpreter :: HasCallStack => GenesisParameters -> TimeInterpreter Identity
+singleEraInterpreter gp = mkTimeInterpreterI gp (mkInterpreter summary)
   where
-    bomb x = error $ "singleEraIntepreter: the impossible happened: " <> show x
-    int = flip Interpreter (gp ^. #getGenesisBlockDate)
-        $ neverForksSummary
-        $ EraParams
-            { eraEpochSize =
-                Cardano.EpochSize
-                . fromIntegral
-                . unEpochLength
-                $ gp ^. #getEpochLength
-
-            , eraSlotLength =
-                Cardano.mkSlotLength
-                . unSlotLength
-                $ gp ^. #getSlotLength
-
-            , eraSafeZone =
-                noLowerBoundSafeZone (k * 2)
-            }
-      where
-        k = fromIntegral $ getQuantity $ getEpochStability gp
+    summary = neverForksSummary sz len
+    sz = Cardano.EpochSize $ fromIntegral $ unEpochLength $ gp ^. #getEpochLength
+    len = Cardano.mkSlotLength $ unSlotLength $ gp ^. #getSlotLength
+
+mkTimeInterpreterI :: HasCallStack => GenesisParameters -> Interpreter xs -> TimeInterpreter Identity
+mkTimeInterpreterI gp int q = neverFails $ runQuery (MyInterpreter start int) q
+  where
+    start = coerce (gp ^. #getGenesisBlockDate)
+
+    neverFails = either bomb pure
+    bomb x = error $ "singleEraInterpreter: the impossible happened: " <> show x
+
+interpreterFromGenesis :: GenesisParameters -> TimeInterpreter IO
+interpreterFromGenesis gp = mkTimeInterpreter start (mkInterpreter summary)
+  where
+    summary = neverForksSummary sz len
+    sz = Cardano.EpochSize $ fromIntegral $ unEpochLength $ gp ^. #getEpochLength
+    len = Cardano.mkSlotLength $ unSlotLength $ gp ^. #getSlotLength
+    start = gp ^. #getGenesisBlockDate
+
+mkTimeInterpreter :: StartTime -> Interpreter xs -> TimeInterpreter IO
+mkTimeInterpreter start int = either throwIO pure . runQuery mine
+  where
+    mine = MyInterpreter (coerce start) int
 
 -- | Wrapper around HF.Qry to allow converting times relative to the genesis
 -- block date to absolute ones
@@ -254,11 +266,11 @@ instance Monad Qry where
   return = pure
   (>>=)  = QBind
 
-runQuery :: (Qry a) -> Interpreter xs -> Either HF.PastHorizonException a
-runQuery qry (Interpreter summary (StartTime t0)) = go qry
+runQuery :: HasCallStack => MyInterpreter xs -> Qry a -> Either HF.PastHorizonException a
+runQuery (MyInterpreter systemStart int) = go
   where
     go :: Qry a -> Either HF.PastHorizonException a
-    go (HardForkQry q) = HF.runQuery q summary
+    go (HardForkQry q) = HF.interpretQuery int q
     go (QPure a) =
         return a
     go (QBind x f) = do
@@ -267,11 +279,9 @@ runQuery qry (Interpreter summary (StartTime t0)) = go qry
         pure $ Cardano.fromRelativeTime systemStart rel
     go (UTCTimeToRel utc)
         -- Cardano.toRelativeTime may throw, so we need this guard:
-        | utc < t0 = pure Nothing
+        | utc < getSystemStart systemStart = pure Nothing
         | otherwise = pure $ Just $ Cardano.toRelativeTime systemStart utc
 
-    systemStart = Cardano.SystemStart t0
-
 -- -----------------------------------------------------------------------------
 -- Legacy functions
 -- These only work for a single era. We need to stop using them

lib/core/src/Ouroboros/Network/Client/Wallet.hs

@@ -82,7 +82,7 @@ import Network.TypedProtocol.Pipelined
 import Numeric.Natural
     ( Natural )
 import Ouroboros.Consensus.Ledger.Abstract
-    ( Query (..) )
+    ( Query )
 import Ouroboros.Network.Block
     ( BlockNo (..)
     , HasHeader (..)

lib/shelley/cardano-wallet-shelley.cabal

@@ -36,6 +36,7 @@ library
     , bech32
     , bech32-th
     , binary
+    , byron-spec-ledger
     , bytestring
     , cardano-addresses
     , cardano-api
@@ -55,6 +56,7 @@ library
     , cryptonite
     , directory
     , exceptions
+    , extra
     , filepath
     , fmt
     , generic-lens
@@ -65,6 +67,8 @@ library
     , network-mux
     , optparse-applicative
     , ouroboros-consensus
+    , ouroboros-consensus-byron
+    , ouroboros-consensus-cardano
     , ouroboros-consensus-shelley
     , ouroboros-network
     , ouroboros-network-framework
@@ -85,6 +89,7 @@ library
   hs-source-dirs:
       src
   exposed-modules:
+      Cardano.Wallet.Byron.Compatibility
       Cardano.Wallet.Shelley
       Cardano.Wallet.Shelley.Api.Server
       Cardano.Wallet.Shelley.Compatibility