Merge pull request #820 from input-output-hk/nfrisby/tidying-miscellany

Minor housekeeping
IntersectMBO · Jul 24, 2019 · 63bd94f · 63bd94f
2 parents f573f70 + 076d52f
commit 63bd94f
Show file tree

Hide file tree

Showing 4 changed files with 34 additions and 8 deletions.
diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime.hs b/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime.hs
@@ -6,6 +6,7 @@
 module Ouroboros.Consensus.BlockchainTime (
     -- * Abstract definition
     BlockchainTime(..)
+  , onLaterSlot
   , onSlot
     -- * Use in testing
   , NumSlots(..)
@@ -27,6 +28,7 @@ module Ouroboros.Consensus.BlockchainTime (
   , SlotNo (..)
   ) where
 
+import           Control.Exception (Exception (..))
 import           Control.Monad (forever, replicateM_, void, when)
 import           Data.Fixed
 import           Data.Time
@@ -59,11 +61,35 @@ data BlockchainTime m = BlockchainTime {
     , onSlotChange   :: (SlotNo -> m ()) -> m ()
     }
 
--- | Execute action on specific slot
-onSlot :: MonadSTM m => BlockchainTime m -> SlotNo -> m () -> m ()
-onSlot BlockchainTime{..} slot act = onSlotChange $ \slot' ->
+-- | Execute action on specific slot.
+--
+-- Discards the action unless the given slot is after the current slot.
+onLaterSlot :: MonadSTM m => BlockchainTime m -> SlotNo -> m () -> m ()
+onLaterSlot BlockchainTime{..} slot act = onSlotChange $ \slot' ->
     when (slot == slot') act
 
+-- | Execute action on specific slot.
+--
+-- If the given slot and current slot are equal,
+-- then this action equals the given action (e.g. runs immediately in the current thread).
+-- If the slot is in the future, it delegates to 'onLaterSlot'.
+-- If the slot is in the past, it raises 'OnSlotTooLate'.
+onSlot :: (MonadSTM m, MonadThrow m) => BlockchainTime m -> SlotNo -> m () -> m ()
+onSlot btime slot@(SlotNo wSlot) m = do
+    now@(SlotNo wNow) <- atomically (getCurrentSlot btime)
+    case compare wSlot wNow of
+        LT -> throwM $ OnSlotTooLate slot now
+        EQ -> m
+        GT -> onLaterSlot btime slot m
+
+data OnSlotException =
+    -- | An action was scheduled via 'onSlot' for a slot in the past.
+    -- First slot is requested, second slot is current as of raising.
+    OnSlotTooLate SlotNo SlotNo
+  deriving (Eq, Show)
+
+instance Exception OnSlotException
+
 {-------------------------------------------------------------------------------
   Use in testing
 -------------------------------------------------------------------------------}

diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/ChainSyncClient.hs b/ouroboros-consensus/test-consensus/Test/Consensus/ChainSyncClient.hs
@@ -275,7 +275,7 @@ runChainSync securityParam maxClockSkew (ClientUpdates clientUpdates)
         atomically $ writeTVar varLastUpdate slot
 
     -- Connect client to server and run the chain sync protocol
-    onSlot btime startSyncingAt $ do
+    onLaterSlot btime startSyncingAt $ do
       -- When updates are planned at the same slot that we start syncing, we
       -- wait until these updates are done before we start syncing.
       when (isJust (Map.lookup startSyncingAt clientUpdates) ||
@@ -309,7 +309,7 @@ runChainSync securityParam maxClockSkew (ClientUpdates clientUpdates)
     -- STM variable to record the final synched candidate chain
     varCandidateChain <- atomically $ newTVar Nothing
 
-    onSlot btime (finalSlot numSlots) $ do
+    onLaterSlot btime (finalSlot numSlots) $ do
       -- Wait a random amount of time after the final slot for the chain sync
       -- to finish
       threadDelay 2000

diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs
@@ -76,11 +76,11 @@ import qualified Ouroboros.Storage.Util.ErrorHandling as EH
 -- we cook up here one using 'NodeChans'.
 --
 data NetworkInterface m peer = NetworkInterface {
-      -- | Like 'Ouroboros.Network.NodeToNode.nodeToNodeConnectTo'
+      -- | Like 'Ouroboros.Network.NodeToNode.connectTo'
       --
       niConnectTo      :: peer -> m ()
 
-      -- | Like 'Ouroboros.Network.NodeToNode.withServerNodeToNode'
+      -- | Like 'Ouroboros.Network.NodeToNode.withServer'
       --
     , niWithServerNode :: forall t.  (Async m () -> m t) -> m t
     }

diff --git a/ouroboros-network/src/Ouroboros/Network/Protocol/BlockFetch/Type.hs b/ouroboros-network/src/Ouroboros/Network/Protocol/BlockFetch/Type.hs
@@ -84,7 +84,7 @@ instance Protocol (BlockFetch block) where
 
 instance (Show block, StandardHash block)
       => Show (Message (BlockFetch block) from to) where
-  show (MsgRequestRange range) = "MsgRequestRange" ++ show range
+  show (MsgRequestRange range) = "MsgRequestRange " ++ show range
   show MsgStartBatch           = "MsgStartBatch"
   show (MsgBlock block)        = "MsgBlock " ++ show block
   show MsgNoBlocks             = "MsgNoBlocks"