glue-common 0.7.0.1 → 0.8.0.0
raw patch · 7 files changed
+366/−2 lines, 7 filesdep +asyncdep +containersdep +transformers
Dependencies added: async, containers, transformers
Files
- CHANGELOG.md +20/−0
- glue-common.cabal +13/−2
- src/Glue/Clock.hs +43/−0
- src/Glue/Clock/Virtual.hs +112/−0
- src/Glue/Failure.hs +56/−0
- test/Glue/ClockSpec.hs +72/−0
- test/Glue/FailureSpec.hs +50/−0
+ CHANGELOG.md view
@@ -0,0 +1,20 @@+# Changelog for glue-common++## 0.8.0.0++- Added `Glue.Clock`: an injectable `Clock` (monotonic `clockNow` in microseconds, `clockSleep`,+ `clockTimeout`) with `systemClock` as the real implementation, plus `remainingUntil` for+ deadline-aware code (#13).+- Added `Glue.Clock.Virtual`: a virtual clock for deterministic tests that only moves when+ `advanceClock` is called and wakes sleepers in deadline order (#13).+- Added `Glue.Failure`: `EitherService` for services that return failures as values, and+ `FailureMode` (`exceptionFailures`, `valueFailures`) so combinators can support both shapes,+ plus `ExceptT` conversions (#6).++## 0.7.0.1++- PVP upper bounds on all dependencies.++## 0.7.0++- Modernised for GHC 9.6 to 9.12, `MonadUnliftIO` throughout and a Nix flake.
glue-common.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: glue-common-version: 0.7.0.1+version: 0.8.0.0 synopsis: Make better services and clients. description: Common types and base functions used in the glue family of libraries. license: BSD-3-Clause@@ -9,6 +9,7 @@ maintainer: github@futurenotfound.com category: Network build-type: Simple+extra-doc-files: CHANGELOG.md tested-with: GHC == 9.6.7, GHC == 9.8.4, GHC == 9.10.3, GHC == 9.12.3 source-repository head@@ -30,10 +31,16 @@ library import: common-options hs-source-dirs: src- exposed-modules: Glue.Types+ exposed-modules:+ Glue.Clock+ Glue.Clock.Virtual+ Glue.Failure+ Glue.Types build-depends: , base >= 4.14 && < 5+ , containers >= 0.6 && < 0.8 , hashable >= 1.3 && < 1.6+ , transformers >= 0.5 && < 0.7 , unliftio >= 0.2 && < 0.3 , unordered-containers >= 0.2 && < 0.3 @@ -43,6 +50,8 @@ hs-source-dirs: test main-is: Main.hs other-modules:+ Glue.ClockSpec+ Glue.FailureSpec Glue.TypesSpec Spec build-tool-depends: hspec-discover:hspec-discover@@ -51,11 +60,13 @@ -rtsopts -with-rtsopts=-N build-depends:+ , async >= 2.2 && < 2.3 , base >= 4.14 && < 5 , glue-common , hashable >= 1.3 && < 1.6 , hspec >= 2.7 && < 2.12 , QuickCheck >= 2.14 && < 2.16 , quickcheck-instances >= 0.3 && < 0.4+ , transformers >= 0.5 && < 0.7 , unliftio >= 0.2 && < 0.3 , unordered-containers >= 0.2 && < 0.3
+ src/Glue/Clock.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-- | Module containing an injectable clock, so that combinators which read the time or sleep+-- can be driven by a virtual clock in tests (see "Glue.Clock.Virtual").+module Glue.Clock+ ( Clock (..)+ , systemClock+ , remainingUntil+ ) where++import Data.Int (Int64)+import GHC.Clock (getMonotonicTimeNSec)+import UnliftIO (MonadUnliftIO, liftIO)+import UnliftIO.Concurrent (threadDelay)+import UnliftIO.Timeout (timeout)++-- | Source of time and sleeping used by the time-dependent combinators.+data Clock m = Clock+ { clockNow :: m Int64+ -- ^ Current monotonic time in microseconds. Only differences between readings are meaningful.+ , clockSleep :: Int -> m ()+ -- ^ Sleep for the given number of microseconds.+ , clockTimeout :: forall b. Int -> m b -> m (Maybe b)+ -- ^ Run an action with a limit in microseconds, as 'UnliftIO.Timeout.timeout' does:+ -- 'Nothing' if the limit passed first, a negative limit meaning no limit.+ }++-- | The real clock, built on 'getMonotonicTimeNSec', 'threadDelay' and 'timeout'.+systemClock :: MonadUnliftIO m => Clock m+systemClock =+ Clock+ { clockNow = liftIO $ fromIntegral . (`div` 1000) <$> getMonotonicTimeNSec+ , clockSleep = threadDelay+ , clockTimeout = timeout+ }++-- | Milliseconds left until a deadline given in the clock's microseconds (never negative),+-- in the shape the retry options use for deadline-aware backoff.+remainingUntil :: Monad m => Clock m -> Int64 -> m (Maybe Int)+remainingUntil clock deadline = do+ now <- clockNow clock+ pure $ Just $ fromIntegral $ max 0 ((deadline - now) `div` 1000)
+ src/Glue/Clock/Virtual.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | A virtual t'Clock' for deterministic tests: time only moves when 'advanceClock' is called,+-- and sleepers are woken in deadline order as it passes them.+--+-- A typical spec starts the code under test, waits for it to block with 'waitForSleepers',+-- then steps time with 'advanceClock' and asserts on what happened.+module Glue.Clock.Virtual+ ( VirtualClock+ , newVirtualClock+ , virtualClock+ , advanceClock+ , virtualNow+ , sleeperCount+ , waitForSleepers+ ) where++import Control.Monad (when)+import Data.Int (Int64)+import qualified Data.Set as S+import Glue.Clock+import UnliftIO (MonadIO, MonadUnliftIO)+import UnliftIO.Async (race)+import UnliftIO.Exception (onException)+import UnliftIO.STM (TVar, atomically, modifyTVar', newTVarIO,+ readTVar, retrySTM, stateTVar, writeTVar)++-- | Virtual time, starting at zero, plus the sleepers waiting on it.+data VirtualClock = VirtualClock+ { vcNow :: TVar Int64+ , vcSleepers :: TVar (S.Set (Int64, Int))+ -- ^ Each sleeper as (deadline, unique id).+ , vcNextId :: TVar Int+ }++-- | Creates a virtual clock at time zero with no sleepers.+newVirtualClock :: MonadIO m => m VirtualClock+newVirtualClock = VirtualClock <$> newTVarIO 0 <*> newTVarIO S.empty <*> newTVarIO 0++-- | A t'Clock' reading from the virtual clock.+virtualClock :: MonadUnliftIO m => VirtualClock -> Clock m+virtualClock vc =+ Clock+ { clockNow = virtualNow vc+ , clockSleep = virtualSleep vc+ , clockTimeout = virtualTimeout vc+ }++-- | The current virtual time in microseconds.+virtualNow :: MonadIO m => VirtualClock -> m Int64+virtualNow vc = atomically $ readTVar (vcNow vc)++-- | The number of threads currently sleeping on the clock.+sleeperCount :: MonadIO m => VirtualClock -> m Int+sleeperCount vc = atomically $ S.size <$> readTVar (vcSleepers vc)++-- | Blocks until at least the given number of threads are sleeping on the clock.+waitForSleepers :: MonadIO m => VirtualClock -> Int -> m ()+waitForSleepers vc n = atomically $ do+ sleepers <- readTVar (vcSleepers vc)+ when (S.size sleepers < n) retrySTM++virtualSleep :: MonadUnliftIO m => VirtualClock -> Int -> m ()+virtualSleep vc us+ | us <= 0 = pure ()+ | otherwise = do+ sleeper <- atomically $ do+ now <- readTVar (vcNow vc)+ uid <- stateTVar (vcNextId vc) (\i -> (i, i + 1))+ let entry = (now + fromIntegral us, uid)+ modifyTVar' (vcSleepers vc) (S.insert entry)+ pure entry+ let remove = atomically $ modifyTVar' (vcSleepers vc) (S.delete sleeper)+ -- Waking and deregistering happen in one transaction, which 'advanceClock' relies on.+ atomically (do+ now <- readTVar (vcNow vc)+ when (now < fst sleeper) retrySTM+ modifyTVar' (vcSleepers vc) (S.delete sleeper))+ `onException` remove++virtualTimeout :: MonadUnliftIO m => VirtualClock -> Int -> m b -> m (Maybe b)+virtualTimeout vc us action+ | us < 0 = Just <$> action+ | us == 0 = pure Nothing+ | otherwise = either (const Nothing) Just <$> race (virtualSleep vc us) action++-- | Moves time forward by the given number of microseconds. Time steps to each sleeper's+-- deadline in order, waiting at each step until every sleeper due by then has woken.+advanceClock :: MonadIO m => VirtualClock -> Int -> m ()+advanceClock vc us = do+ target <- atomically $ (+ fromIntegral us) <$> readTVar (vcNow vc)+ let step = do+ stepped <- atomically $ do+ sleepers <- readTVar (vcSleepers vc)+ case S.lookupMin sleepers of+ Just (deadline, _) | deadline <= target -> do+ now <- readTVar (vcNow vc)+ writeTVar (vcNow vc) (max now deadline)+ pure True+ _ -> do+ writeTVar (vcNow vc) target+ pure False+ when stepped $ do+ atomically $ do+ now <- readTVar (vcNow vc)+ sleepers <- readTVar (vcSleepers vc)+ case S.lookupMin sleepers of+ Just (deadline, _) | deadline <= now -> retrySTM+ _ -> pure ()+ step+ step
+ src/Glue/Failure.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE FlexibleContexts #-}++-- | Module describing how a service signals failure, so that combinators can be written once+-- and used both with services that throw and with services that return failures as values.+--+-- The exception shape treats any synchronous exception as the failure. The value shape treats+-- @Left e@ as the failure; in that shape exceptions are not inspected and propagate unchanged.+-- Asynchronous exceptions always propagate untouched in both shapes.+module Glue.Failure+ ( EitherService+ , FailureMode (..)+ , exceptionFailures+ , valueFailures+ , fromExceptTService+ , toExceptTService+ ) where++import Control.Monad.Trans.Except (ExceptT (..), runExceptT)+import Glue.Types+import UnliftIO (MonadUnliftIO, SomeException)+import UnliftIO.Exception (throwIO, tryAny)++-- | Type alias for a service that returns expected failures as values.+type EitherService m a e b = BasicService m a (Either e b)++-- | How a combinator observes the failure of a call returning @r@.+data FailureMode m r failure = FailureMode+ { observeCall :: m r -> m (Either failure r)+ -- ^ Runs a call, separating its failure (if any) from a successful result.+ , reraise :: failure -> m r+ -- ^ Signals a failure back to the caller in this shape: throws it, or returns it as a value.+ }++-- | Failures are synchronous exceptions; asynchronous exceptions are never caught.+exceptionFailures :: MonadUnliftIO m => FailureMode m b SomeException+exceptionFailures =+ FailureMode+ { observeCall = tryAny+ , reraise = throwIO+ }++-- | Failures are @Left@ values; exceptions are not caught at all.+valueFailures :: Monad m => FailureMode m (Either e b) e+valueFailures =+ FailureMode+ { observeCall = fmap (\r -> either Left (const (Right r)) r)+ , reraise = pure . Left+ }++-- | Converts a service in t'ExceptT' to an 'EitherService'.+fromExceptTService :: (a -> ExceptT e m b) -> EitherService m a e b+fromExceptTService service = runExceptT . service++-- | Converts an 'EitherService' to a service in t'ExceptT'.+toExceptTService :: EitherService m a e b -> a -> ExceptT e m b+toExceptTService service = ExceptT . service
+ test/Glue/ClockSpec.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Glue.ClockSpec (spec) where++import Control.Concurrent.Async (async, poll, wait)+import Data.IORef+import Glue.Clock+import Glue.Clock.Virtual+import Test.Hspec+import Test.QuickCheck++spec :: Spec+spec = do+ describe "systemClock" $ do+ it "Never goes backwards and sleeps at least as long as asked" $ do+ let clock = systemClock :: Clock IO+ start <- clockNow clock+ clockSleep clock 2000+ end <- clockNow clock+ (end - start) `shouldSatisfy` (>= 2000)++ it "Times out actions that run past the limit" $ do+ let clock = systemClock :: Clock IO+ clockTimeout clock 1000 (clockSleep clock 1000000) `shouldReturn` Nothing+ clockTimeout clock 1000000 (pure (5 :: Int)) `shouldReturn` Just 5++ describe "virtualClock" $ do+ it "Only moves when advanced" $+ property $ \(steps :: [NonNegative Int]) -> do+ vc <- newVirtualClock+ mapM_ (advanceClock vc . getNonNegative) steps+ virtualNow vc `shouldReturn` fromIntegral (sum (fmap getNonNegative steps))++ it "Wakes sleepers in deadline order" $ do+ vc <- newVirtualClock+ let clock = virtualClock vc :: Clock IO+ order <- newIORef []+ let sleeper (n :: Int) = clockSleep clock (n * 1000) >> atomicModifyIORef' order (\o -> (o ++ [n], ()))+ threads <- traverse (async . sleeper) [3, 1, 2]+ waitForSleepers vc 3+ advanceClock vc 2000+ readIORef order `shouldReturn` [1, 2]+ sleeperCount vc `shouldReturn` 1+ advanceClock vc 1000+ mapM_ wait threads+ readIORef order `shouldReturn` [1, 2, 3]++ it "Does not wake a sleeper before its deadline" $ do+ vc <- newVirtualClock+ let clock = virtualClock vc :: Clock IO+ sleeping <- async (clockSleep clock 1000)+ waitForSleepers vc 1+ advanceClock vc 999+ poll sleeping >>= (`shouldSatisfy` maybe True (const False))+ advanceClock vc 1+ wait sleeping++ it "Times out exactly at the limit" $ do+ vc <- newVirtualClock+ let clock = virtualClock vc :: Clock IO+ result <- async (clockTimeout clock 5000 (clockSleep clock 10000 >> pure ()))+ waitForSleepers vc 2+ advanceClock vc 5000+ wait result `shouldReturn` Nothing+ sleeperCount vc `shouldReturn` 0++ it "remainingUntil reports milliseconds left, never negative" $ do+ vc <- newVirtualClock+ let clock = virtualClock vc :: Clock IO+ remainingUntil clock 5000 `shouldReturn` Just 5+ advanceClock vc 7000+ remainingUntil clock 5000 `shouldReturn` Just 0
+ test/Glue/FailureSpec.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Glue.FailureSpec (spec) where++import Control.Exception (AsyncException (UserInterrupt))+import qualified Control.Exception as E+import Control.Monad.Trans.Except (runExceptT, throwE)+import Glue.Failure+import Test.Hspec+import Test.QuickCheck+import UnliftIO.Exception (Exception, fromException, throwIO,+ try)++data FailureTestException = FailureTestException+ deriving (Eq, Show)++instance Exception FailureTestException++spec :: Spec+spec = do+ describe "exceptionFailures" $ do+ it "Observes synchronous exceptions as failures" $ do+ result <- observeCall exceptionFailures (throwIO FailureTestException :: IO Int)+ either fromException (const Nothing) result `shouldBe` Just FailureTestException++ it "Passes successes through" $+ property $ \(x :: Int) ->+ fmap (either (const Nothing) Just) (observeCall exceptionFailures (pure x)) `shouldReturn` Just x++ it "Never catches asynchronous exceptions" $+ observeCall exceptionFailures (E.throwIO UserInterrupt :: IO Int) `shouldThrow` (== UserInterrupt)++ describe "valueFailures" $ do+ it "Observes Left as the failure and Right as the success" $+ property $ \(r :: Either String Int) ->+ observeCall valueFailures (pure r) `shouldReturn` either Left (const (Right r)) r++ it "Reraises as a Left value" $+ (reraise valueFailures "bad" :: IO (Either String Int)) `shouldReturn` Left "bad"++ it "Leaves thrown exceptions alone" $ do+ result <- try (observeCall valueFailures (throwIO FailureTestException :: IO (Either String Int)))+ either (\(e :: FailureTestException) -> Just e) (const Nothing) result `shouldBe` Just FailureTestException++ describe "ExceptT conversion" $+ it "Round trips through EitherService" $+ property $ \(x :: Int) -> do+ let service n = if n > 0 then pure n else throwE ("non-positive" :: String)+ fromExceptTService service x `shouldReturn` (if x > 0 then Right x else Left "non-positive")+ runExceptT (toExceptTService (fromExceptTService service) x) `shouldReturn` (if x > 0 then Right x else Left "non-positive")