Skip to content

Commit 6529a63

Browse files
bolt12bolt12
committed
Integrate with network and io-sim
1 parent ca23fa5 commit 6529a63

File tree

7 files changed

+56
-73
lines changed

7 files changed

+56
-73
lines changed

‎cabal.project‎

Lines changed: 2 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -14,9 +14,9 @@ repository cardano-haskell-packages
1414
-- update either of these.
1515
index-state:
1616
-- Bump this if you need newer packages from Hackage
17-
, hackage.haskell.org 2024-01-28T20:27:47Z
17+
, hackage.haskell.org 2024-02-23T10:26:05Z
1818
-- Bump this if you need newer packages from CHaP
19-
, cardano-haskell-packages 2024-01-28T20:24:54Z
19+
, cardano-haskell-packages 2024-02-23T10:34:09Z
2020

2121
packages:
2222
ouroboros-consensus
@@ -31,23 +31,3 @@ tests: true
3131
benchmarks: true
3232

3333
import: ./asserts.cabal
34-
35-
source-repository-package
36-
type: git
37-
location: https://github.com/input-output-hk/ouroboros-network/
38-
tag: 8ab444850b9d654110cd751a17c21db814bba593
39-
subdir: monoidal-synchronisation
40-
network-mux
41-
ouroboros-network
42-
ouroboros-network-api
43-
ouroboros-network-framework
44-
ouroboros-network-protocols
45-
ouroboros-network-testing
46-
--sha256: 1vw8r8csa6lq4330bwgddxa4nl2m1pw1ps5y6l7lw2zw3xdlr0hf
47-
48-
source-repository-package
49-
type: git
50-
location: https://github.com/input-output-hk/io-sim
51-
tag: 85d633d6f9c76ffb678b36396c8fd39b2ff7219e
52-
subdir: io-sim
53-
--sha256: 10f54xg88wq2w7ylg3n33f1yiswd6w4dam7fvl12raiqj0rk21qm

‎flake.lock‎

Lines changed: 6 additions & 6 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -142,7 +142,7 @@ library
142142
, nothunks
143143
, ouroboros-consensus ^>=0.15
144144
, ouroboros-consensus-protocol ^>=0.7
145-
, ouroboros-network-api ^>=0.6.2
145+
, ouroboros-network-api ^>=0.7
146146
, serialise ^>=0.2
147147
, small-steps
148148
, sop-core ^>=0.5

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

Lines changed: 7 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -78,17 +78,17 @@ library
7878
, filepath
7979
, fs-api ^>=0.2
8080
, hashable
81-
, io-classes ^>=1.3
81+
, io-classes ^>=1.4.1
8282
, mtl
8383
, ouroboros-consensus ^>=0.15
84-
, ouroboros-network ^>=0.11
85-
, ouroboros-network-api ^>=0.6
86-
, ouroboros-network-framework ^>=0.11
87-
, ouroboros-network-protocols ^>=0.7
84+
, ouroboros-network ^>=0.12
85+
, ouroboros-network-api ^>=0.7
86+
, ouroboros-network-framework ^>=0.11.1
87+
, ouroboros-network-protocols ^>=0.8
8888
, random
8989
, serialise ^>=0.2
90-
, si-timers ^>=1.3
91-
, strict-stm ^>=1.3
90+
, si-timers ^>=1.4
91+
, strict-stm ^>=1.4
9292
, text
9393
, time
9494
, transformers

‎ouroboros-consensus/ouroboros-consensus.cabal‎

Lines changed: 7 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -270,30 +270,31 @@ library
270270
, filelock
271271
, fs-api ^>=0.2
272272
, hashable
273-
, io-classes ^>=1.3
273+
, io-classes ^>=1.4.1
274274
, measures
275275
, mtl
276276
, nothunks ^>=0.1.5
277-
, ouroboros-network-api ^>=0.6.2
277+
, ouroboros-network-api ^>=0.7
278278
, ouroboros-network-mock ^>=0.1
279-
, ouroboros-network-protocols ^>=0.7
279+
, ouroboros-network-protocols ^>=0.8
280280
, psqueues ^>=0.2.3
281281
, quiet ^>=0.2
282282
, semialign >=1.1
283283
, serialise ^>=0.2
284-
, si-timers ^>=1.3
284+
, si-timers ^>=1.4
285285
, sop-core ^>=0.5
286286
, sop-extras ^>=0.1
287287
, streaming
288288
, strict-checked-vars ^>=0.2
289289
, strict-sop-core ^>=0.1
290-
, strict-stm ^>=1.3
290+
, strict-stm ^>=1.4
291291
, text
292292
, these ^>=1.2
293293
, time
294294
, transformers
295295
, typed-protocols ^>=0.1.1
296296
, vector ^>=0.13
297+
, primitive
297298

298299
-- GHC 8.10.7 on aarch64-darwin cannot use text-2
299300
build-depends: text >=1.2.5.0 && <2.2
@@ -544,6 +545,7 @@ test-suite consensus-test
544545
, typed-protocols-examples
545546
, unstable-consensus-testlib
546547
, unstable-mock-block
548+
, primitive
547549

548550
test-suite infra-test
549551
import: common-test

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

Lines changed: 29 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -39,7 +39,9 @@ import qualified Codec.CBOR.Read as CBOR.R
3939
import Control.Exception (assert)
4040
import Control.Monad
4141
import Control.Monad.Except
42-
import Control.Monad.ST
42+
import Control.Monad.Primitive
43+
import Control.Monad.ST hiding (stToIO)
44+
import qualified Control.Monad.ST as ST
4345
import qualified Control.Monad.ST.Lazy as ST.Lazy
4446
import Data.ByteString (ByteString)
4547
import qualified Data.ByteString as BS
@@ -67,7 +69,7 @@ data IDecodeIO a =
6769
| Fail !ByteString !CBOR.R.ByteOffset CBOR.R.DeserialiseFailure
6870

6971
fromIDecode :: CBOR.R.IDecode RealWorld a -> IDecodeIO a
70-
fromIDecode (CBOR.R.Partial k) = Partial $ fmap fromIDecode . stToIO . k
72+
fromIDecode (CBOR.R.Partial k) = Partial $ fmap fromIDecode . ST.stToIO . k
7173
fromIDecode (CBOR.R.Done bs off x) = Done bs off x
7274
fromIDecode (CBOR.R.Fail bs off e) = Fail bs off e
7375

@@ -185,27 +187,26 @@ data ReadIncrementalErr =
185187
-- 'withStreamIncrementalOffsets'.
186188
readIncremental :: forall m a. IOLike m
187189
=> SomeHasFS m
188-
-> (forall s . CBOR.D.Decoder s a)
190+
-> CBOR.D.Decoder (PrimState m) a
189191
-> FsPath
190192
-> m (Either ReadIncrementalErr a)
191-
readIncremental = \(SomeHasFS hasFS) decoder fp -> withLiftST $ \liftST -> do
193+
readIncremental = \(SomeHasFS hasFS) decoder fp -> do
192194
withFile hasFS fp ReadMode $ \h ->
193-
go hasFS liftST h =<< liftST (CBOR.R.deserialiseIncremental decoder)
195+
go hasFS h =<< stToIO (CBOR.R.deserialiseIncremental decoder)
194196
where
195197
go :: HasFS m h
196-
-> (forall x. ST s x -> m x)
197198
-> Handle h
198-
-> CBOR.R.IDecode s a
199+
-> CBOR.R.IDecode (PrimState m) a
199200
-> m (Either ReadIncrementalErr a)
200-
go hasFS@HasFS{..} liftST h (CBOR.R.Partial k) = do
201+
go hasFS@HasFS{..} h (CBOR.R.Partial k) = do
201202
bs <- hGetSome h (fromIntegral defaultChunkSize)
202-
dec' <- liftST $ k (checkEmpty bs)
203-
go hasFS liftST h dec'
204-
go _ _ _ (CBOR.R.Done leftover _ a) =
203+
dec' <- stToIO $ k (checkEmpty bs)
204+
go hasFS h dec'
205+
go _ _ (CBOR.R.Done leftover _ a) =
205206
return $ if BS.null leftover
206207
then Right a
207208
else Left $ TrailingBytes leftover
208-
go _ _ _ (CBOR.R.Fail _ _ err) =
209+
go _ _ (CBOR.R.Fail _ _ err) =
209210
return $ Left $ ReadFailed err
210211

211212
checkEmpty :: ByteString -> Maybe ByteString
@@ -227,39 +228,37 @@ readIncremental = \(SomeHasFS hasFS) decoder fp -> withLiftST $ \liftST -> do
227228
withStreamIncrementalOffsets ::
228229
forall m h a r. (IOLike m, HasCallStack)
229230
=> HasFS m h
230-
-> (forall s . CBOR.D.Decoder s (LBS.ByteString -> a))
231+
-> CBOR.D.Decoder (PrimState m) (LBS.ByteString -> a)
231232
-> FsPath
232233
-> (Stream (Of (Word64, (Word64, a))) m (Maybe (ReadIncrementalErr, Word64)) -> m r)
233234
-> m r
234235
withStreamIncrementalOffsets hasFS@HasFS{..} decoder fp = \k ->
235-
withLiftST $ \liftST ->
236-
withFile hasFS fp ReadMode $ \h -> k $ do
237-
fileSize <- S.lift $ hGetSize h
238-
if fileSize == 0 then
239-
-- If the file is empty, we will immediately get "end of input"
240-
return Nothing
241-
else
242-
S.lift (liftST (CBOR.R.deserialiseIncremental decoder)) >>=
243-
go liftST h 0 Nothing [] fileSize
236+
withFile hasFS fp ReadMode $ \h -> k $ do
237+
fileSize <- S.lift $ hGetSize h
238+
if fileSize == 0 then
239+
-- If the file is empty, we will immediately get "end of input"
240+
return Nothing
241+
else
242+
S.lift (stToIO (CBOR.R.deserialiseIncremental decoder)) >>=
243+
go h 0 Nothing [] fileSize
244244
where
245245
-- TODO stream from HasFS?
246-
go :: (forall x. ST s x -> m x)
247-
-> Handle h
246+
go :: Handle h
248247
-> Word64 -- ^ Offset
249248
-> Maybe ByteString -- ^ Unconsumed bytes from last time
250249
-> [ByteString] -- ^ Chunks pushed for this item (rev order)
251250
-> Word64 -- ^ Total file size
252-
-> CBOR.R.IDecode s (LBS.ByteString -> a)
251+
-> CBOR.R.IDecode (PrimState m) (LBS.ByteString -> a)
253252
-> Stream (Of (Word64, (Word64, a))) m (Maybe (ReadIncrementalErr, Word64))
254-
go liftST h offset mbUnconsumed bss fileSize dec = case dec of
253+
go h offset mbUnconsumed bss fileSize dec = case dec of
255254
CBOR.R.Partial k -> do
256255
-- First use the unconsumed bytes from a previous read before read
257256
-- some more bytes from the file.
258257
bs <- case mbUnconsumed of
259258
Just unconsumed -> return unconsumed
260259
Nothing -> S.lift $ hGetSome h (fromIntegral defaultChunkSize)
261-
dec' <- S.lift $ liftST $ k (checkEmpty bs)
262-
go liftST h offset Nothing (bs:bss) fileSize dec'
260+
dec' <- S.lift $ stToIO $ k (checkEmpty bs)
261+
go h offset Nothing (bs:bss) fileSize dec'
263262

264263
CBOR.R.Done leftover size mkA -> do
265264
let nextOffset = offset + fromIntegral size
@@ -288,8 +287,8 @@ withStreamIncrementalOffsets hasFS@HasFS{..} decoder fp = \k ->
288287
-> return Nothing
289288
-- Some more bytes, so try to read the next @a@.
290289
mbLeftover ->
291-
S.lift (liftST (CBOR.R.deserialiseIncremental decoder)) >>=
292-
go liftST h nextOffset mbLeftover [] fileSize
290+
S.lift (stToIO (CBOR.R.deserialiseIncremental decoder)) >>=
291+
go h nextOffset mbLeftover [] fileSize
293292

294293
CBOR.R.Fail _ _ err -> return $ Just (ReadFailed err, offset)
295294

‎ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -45,6 +45,7 @@ import qualified Control.Monad.Class.MonadTimer as MonadTimer
4545
import Control.Monad.Class.MonadTimer.SI
4646
import Control.Monad.Except (Except, runExcept, throwError)
4747
import Control.Monad.IOSim
48+
import Control.Monad.Primitive
4849
import Control.Monad.Reader (ReaderT (..), lift)
4950
import Control.Tracer
5051
import Data.Fixed
@@ -320,7 +321,7 @@ prop_delayNoClockShift =
320321
-- | Note that that under load, the returned list could be missing certain slots
321322
-- or contain more slots than requested. This means that tests using this
322323
-- function can fail, also see issue #3894.
323-
testOverrideDelay :: forall m. (IOLike m, MonadTime m, MonadDelay (OverrideDelay m))
324+
testOverrideDelay :: forall m. (IOLike m, MonadTime m, MonadDelay (OverrideDelay m), PrimMonad m)
324325
=> SystemStart
325326
-> SlotLength
326327
-> NominalDiffTime
@@ -368,6 +369,7 @@ newtype OverrideDelay m a = OverrideDelay {
368369
, MonadTime
369370
, MonadThread
370371
, MonadFork
372+
, PrimMonad
371373
, MonadST
372374
, MonadEvaluate
373375
)
@@ -557,7 +559,7 @@ instance (MonadAsync m, MonadMask m, MonadThrow (STM m)) => MonadAsync (Override
557559
waitCatchSTM = OverrideDelaySTM . lift . waitCatchSTM . unOverrideDelayAsync
558560
pollSTM = OverrideDelaySTM . lift . pollSTM . unOverrideDelayAsync
559561

560-
instance (IOLike m, MonadDelay (OverrideDelay m)) => IOLike (OverrideDelay m) where
562+
instance (IOLike m, MonadDelay (OverrideDelay m), PrimMonad m) => IOLike (OverrideDelay m) where
561563
forgetSignKeyKES = OverrideDelay . lift . forgetSignKeyKES
562564

563565
overrideDelay :: UTCTime

0 commit comments

Comments
 (0)