Integrate with network and io-sim

Author: bolt12

cabal.project

@@ -14,9 +14,9 @@ repository cardano-haskell-packages
 -- update either of these.
 index-state:
   -- Bump this if you need newer packages from Hackage
-  , hackage.haskell.org 2024-01-28T20:27:47Z
+  , hackage.haskell.org 2024-02-23T10:26:05Z
   -- Bump this if you need newer packages from CHaP
-  , cardano-haskell-packages 2024-01-28T20:24:54Z
+  , cardano-haskell-packages 2024-02-23T10:34:09Z
 
 packages:
   ouroboros-consensus
@@ -31,23 +31,3 @@ tests: true
 benchmarks: true
 
 import: ./asserts.cabal
-
-source-repository-package
-    type: git
-    location: https://github.com/input-output-hk/ouroboros-network/
-    tag: 8ab444850b9d654110cd751a17c21db814bba593
-    subdir: monoidal-synchronisation
-            network-mux
-            ouroboros-network
-            ouroboros-network-api
-            ouroboros-network-framework
-            ouroboros-network-protocols
-            ouroboros-network-testing
-    --sha256: 1vw8r8csa6lq4330bwgddxa4nl2m1pw1ps5y6l7lw2zw3xdlr0hf
-
-source-repository-package
-    type: git
-    location: https://github.com/input-output-hk/io-sim
-    tag: 85d633d6f9c76ffb678b36396c8fd39b2ff7219e
-    subdir: io-sim
-    --sha256: 10f54xg88wq2w7ylg3n33f1yiswd6w4dam7fvl12raiqj0rk21qm

flake.lock

@@ -142,7 +142,7 @@ library
     , nothunks
     , ouroboros-consensus           ^>=0.15
     , ouroboros-consensus-protocol  ^>=0.7
-    , ouroboros-network-api         ^>=0.6.2
+    , ouroboros-network-api         ^>=0.7
     , serialise                     ^>=0.2
     , small-steps
     , sop-core                      ^>=0.5

ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal

@@ -78,17 +78,17 @@ library
     , filepath
     , fs-api                       ^>=0.2
     , hashable
-    , io-classes                   ^>=1.3
+    , io-classes                   ^>=1.4.1
     , mtl
     , ouroboros-consensus          ^>=0.15
-    , ouroboros-network            ^>=0.11
-    , ouroboros-network-api        ^>=0.6
-    , ouroboros-network-framework  ^>=0.11
-    , ouroboros-network-protocols  ^>=0.7
+    , ouroboros-network            ^>=0.12
+    , ouroboros-network-api        ^>=0.7
+    , ouroboros-network-framework  ^>=0.11.1
+    , ouroboros-network-protocols  ^>=0.8
     , random
     , serialise                    ^>=0.2
-    , si-timers                    ^>=1.3
-    , strict-stm                   ^>=1.3
+    , si-timers                    ^>=1.4
+    , strict-stm                   ^>=1.4
     , text
     , time
     , transformers

ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal

@@ -0,0 +1,23 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+-->
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->
+### Non-Breaking
+
+- Integrate with network-packages and io-sim 1.4.1 packages
+- Bump version bounds
+
+<!--
+### Breaking
+
+- A bullet item for the Breaking category.
+
+-->

ouroboros-consensus/changelog.d/20240223_133210_armandoifsantos_integrate.md

@@ -270,30 +270,31 @@ library
     , filelock
     , fs-api                       ^>=0.2
     , hashable
-    , io-classes                   ^>=1.3
+    , io-classes                   ^>=1.4.1
     , measures
     , mtl
     , nothunks                     ^>=0.1.5
-    , ouroboros-network-api        ^>=0.6.2
+    , ouroboros-network-api        ^>=0.7
     , ouroboros-network-mock       ^>=0.1
-    , ouroboros-network-protocols  ^>=0.7
+    , ouroboros-network-protocols  ^>=0.8
     , psqueues                     ^>=0.2.3
     , quiet                        ^>=0.2
     , semialign                    >=1.1
     , serialise                    ^>=0.2
-    , si-timers                    ^>=1.3
+    , si-timers                    ^>=1.4
     , sop-core                     ^>=0.5
     , sop-extras                   ^>=0.1
     , streaming
     , strict-checked-vars          ^>=0.2
     , strict-sop-core              ^>=0.1
-    , strict-stm                   ^>=1.3
+    , strict-stm                   ^>=1.4
     , text
     , these                        ^>=1.2
     , time
     , transformers
     , typed-protocols              ^>=0.1.1
     , vector                       ^>=0.13
+    , primitive
 
   -- GHC 8.10.7 on aarch64-darwin cannot use text-2
   build-depends:   text >=1.2.5.0 && <2.2
@@ -544,6 +545,7 @@ test-suite consensus-test
     , typed-protocols-examples
     , unstable-consensus-testlib
     , unstable-mock-block
+    , primitive
 
 test-suite infra-test
   import:         common-test

ouroboros-consensus/ouroboros-consensus.cabal

@@ -39,7 +39,9 @@ import qualified Codec.CBOR.Read as CBOR.R
 import           Control.Exception (assert)
 import           Control.Monad
 import           Control.Monad.Except
-import           Control.Monad.ST
+import           Control.Monad.Primitive
+import           Control.Monad.ST hiding (stToIO)
+import qualified Control.Monad.ST as ST
 import qualified Control.Monad.ST.Lazy as ST.Lazy
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
@@ -67,7 +69,7 @@ data IDecodeIO a =
   | Fail !ByteString !CBOR.R.ByteOffset CBOR.R.DeserialiseFailure
 
 fromIDecode :: CBOR.R.IDecode RealWorld a -> IDecodeIO a
-fromIDecode (CBOR.R.Partial k)     = Partial $ fmap fromIDecode . stToIO . k
+fromIDecode (CBOR.R.Partial k)     = Partial $ fmap fromIDecode . ST.stToIO . k
 fromIDecode (CBOR.R.Done bs off x) = Done bs off x
 fromIDecode (CBOR.R.Fail bs off e) = Fail bs off e
 
@@ -185,27 +187,26 @@ data ReadIncrementalErr =
 -- 'withStreamIncrementalOffsets'.
 readIncremental :: forall m a. IOLike m
                 => SomeHasFS m
-                -> (forall s . CBOR.D.Decoder s a)
+                -> CBOR.D.Decoder (PrimState m) a
                 -> FsPath
                 -> m (Either ReadIncrementalErr a)
-readIncremental = \(SomeHasFS hasFS) decoder fp -> withLiftST $ \liftST -> do
+readIncremental = \(SomeHasFS hasFS) decoder fp -> do
     withFile hasFS fp ReadMode $ \h ->
-      go hasFS liftST h =<< liftST (CBOR.R.deserialiseIncremental decoder)
+      go hasFS h =<< stToIO (CBOR.R.deserialiseIncremental decoder)
   where
     go :: HasFS m h
-       -> (forall x. ST s x -> m x)
        -> Handle h
-       -> CBOR.R.IDecode s a
+       -> CBOR.R.IDecode (PrimState m) a
        -> m (Either ReadIncrementalErr a)
-    go hasFS@HasFS{..} liftST h (CBOR.R.Partial k) = do
+    go hasFS@HasFS{..} h (CBOR.R.Partial k) = do
         bs   <- hGetSome h (fromIntegral defaultChunkSize)
-        dec' <- liftST $ k (checkEmpty bs)
-        go hasFS liftST h dec'
-    go _ _ _ (CBOR.R.Done leftover _ a) =
+        dec' <- stToIO $ k (checkEmpty bs)
+        go hasFS h dec'
+    go _ _ (CBOR.R.Done leftover _ a) =
         return $ if BS.null leftover
                    then Right a
                    else Left $ TrailingBytes leftover
-    go _ _ _ (CBOR.R.Fail _ _ err) =
+    go _ _ (CBOR.R.Fail _ _ err) =
         return $ Left $ ReadFailed err
 
     checkEmpty :: ByteString -> Maybe ByteString
@@ -227,39 +228,37 @@ readIncremental = \(SomeHasFS hasFS) decoder fp -> withLiftST $ \liftST -> do
 withStreamIncrementalOffsets ::
      forall m h a r. (IOLike m, HasCallStack)
   => HasFS m h
-  -> (forall s . CBOR.D.Decoder s (LBS.ByteString -> a))
+  -> CBOR.D.Decoder (PrimState m) (LBS.ByteString -> a)
   -> FsPath
   -> (Stream (Of (Word64, (Word64, a))) m (Maybe (ReadIncrementalErr, Word64)) -> m r)
   -> m r
 withStreamIncrementalOffsets hasFS@HasFS{..} decoder fp = \k ->
-    withLiftST $ \liftST ->
-      withFile hasFS fp ReadMode $ \h -> k $ do
-        fileSize <- S.lift $ hGetSize h
-        if fileSize == 0 then
-          -- If the file is empty, we will immediately get "end of input"
-          return Nothing
-        else
-          S.lift (liftST (CBOR.R.deserialiseIncremental decoder)) >>=
-            go liftST h 0 Nothing [] fileSize
+    withFile hasFS fp ReadMode $ \h -> k $ do
+      fileSize <- S.lift $ hGetSize h
+      if fileSize == 0 then
+        -- If the file is empty, we will immediately get "end of input"
+        return Nothing
+      else
+        S.lift (stToIO (CBOR.R.deserialiseIncremental decoder)) >>=
+          go h 0 Nothing [] fileSize
   where
     -- TODO stream from HasFS?
-    go :: (forall x. ST s x -> m x)
-       -> Handle h
+    go :: Handle h
        -> Word64                   -- ^ Offset
        -> Maybe ByteString         -- ^ Unconsumed bytes from last time
        -> [ByteString]             -- ^ Chunks pushed for this item (rev order)
        -> Word64                   -- ^ Total file size
-       -> CBOR.R.IDecode s (LBS.ByteString -> a)
+       -> CBOR.R.IDecode (PrimState m) (LBS.ByteString -> a)
        -> Stream (Of (Word64, (Word64, a))) m (Maybe (ReadIncrementalErr, Word64))
-    go liftST h offset mbUnconsumed bss fileSize dec = case dec of
+    go h offset mbUnconsumed bss fileSize dec = case dec of
       CBOR.R.Partial k -> do
         -- First use the unconsumed bytes from a previous read before read
         -- some more bytes from the file.
         bs   <- case mbUnconsumed of
           Just unconsumed -> return unconsumed
           Nothing         -> S.lift $ hGetSome h (fromIntegral defaultChunkSize)
-        dec' <- S.lift $ liftST $ k (checkEmpty bs)
-        go liftST h offset Nothing (bs:bss) fileSize dec'
+        dec' <- S.lift $ stToIO $ k (checkEmpty bs)
+        go h offset Nothing (bs:bss) fileSize dec'
 
       CBOR.R.Done leftover size mkA -> do
         let nextOffset = offset + fromIntegral size
@@ -288,8 +287,8 @@ withStreamIncrementalOffsets hasFS@HasFS{..} decoder fp = \k ->
             -> return Nothing
           -- Some more bytes, so try to read the next @a@.
           mbLeftover ->
-            S.lift (liftST (CBOR.R.deserialiseIncremental decoder)) >>=
-            go liftST h nextOffset mbLeftover [] fileSize
+            S.lift (stToIO (CBOR.R.deserialiseIncremental decoder)) >>=
+            go h nextOffset mbLeftover [] fileSize
 
       CBOR.R.Fail _ _ err -> return $ Just (ReadFailed err, offset)
 

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/CBOR.hs

@@ -45,6 +45,7 @@ import qualified Control.Monad.Class.MonadTimer as MonadTimer
 import           Control.Monad.Class.MonadTimer.SI
 import           Control.Monad.Except (Except, runExcept, throwError)
 import           Control.Monad.IOSim
+import           Control.Monad.Primitive
 import           Control.Monad.Reader (ReaderT (..), lift)
 import           Control.Tracer
 import           Data.Fixed
@@ -320,7 +321,7 @@ prop_delayNoClockShift =
 -- | Note that that under load, the returned list could be missing certain slots
 -- or contain more slots than requested. This means that tests using this
 -- function can fail, also see issue #3894.
-testOverrideDelay :: forall m. (IOLike m, MonadTime m, MonadDelay (OverrideDelay m))
+testOverrideDelay :: forall m. (IOLike m, MonadTime m, MonadDelay (OverrideDelay m), PrimMonad m)
                   => SystemStart
                   -> SlotLength
                   -> NominalDiffTime
@@ -368,6 +369,7 @@ newtype OverrideDelay m a = OverrideDelay {
            , MonadTime
            , MonadThread
            , MonadFork
+           , PrimMonad
            , MonadST
            , MonadEvaluate
            )
@@ -557,7 +559,7 @@ instance (MonadAsync m, MonadMask m, MonadThrow (STM m)) => MonadAsync (Override
   waitCatchSTM = OverrideDelaySTM . lift . waitCatchSTM . unOverrideDelayAsync
   pollSTM      = OverrideDelaySTM . lift . pollSTM . unOverrideDelayAsync
 
-instance (IOLike m, MonadDelay (OverrideDelay m)) => IOLike (OverrideDelay m) where
+instance (IOLike m, MonadDelay (OverrideDelay m), PrimMonad m) => IOLike (OverrideDelay m) where
   forgetSignKeyKES = OverrideDelay . lift . forgetSignKeyKES
 
 overrideDelay :: UTCTime