diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/glue-common.cabal b/glue-common.cabal --- a/glue-common.cabal +++ b/glue-common.cabal @@ -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 diff --git a/src/Glue/Clock.hs b/src/Glue/Clock.hs new file mode 100644 --- /dev/null +++ b/src/Glue/Clock.hs @@ -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) diff --git a/src/Glue/Clock/Virtual.hs b/src/Glue/Clock/Virtual.hs new file mode 100644 --- /dev/null +++ b/src/Glue/Clock/Virtual.hs @@ -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 diff --git a/src/Glue/Failure.hs b/src/Glue/Failure.hs new file mode 100644 --- /dev/null +++ b/src/Glue/Failure.hs @@ -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 diff --git a/test/Glue/ClockSpec.hs b/test/Glue/ClockSpec.hs new file mode 100644 --- /dev/null +++ b/test/Glue/ClockSpec.hs @@ -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 diff --git a/test/Glue/FailureSpec.hs b/test/Glue/FailureSpec.hs new file mode 100644 --- /dev/null +++ b/test/Glue/FailureSpec.hs @@ -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")