numerus-closus (empty) → 0.1.0.0
raw patch · 4 files changed
+724/−0 lines, 4 filesdep +basedep +containersdep +hedgehog
Dependencies added: base, containers, hedgehog, hspec, hspec-core, hspec-hedgehog, numerus-closus, time, unbounded-delays
Files
- LICENSE +15/−0
- numerus-closus.cabal +90/−0
- src/Control/NumerusClosus.hs +310/−0
- test/Spec.hs +309/−0
+ LICENSE view
@@ -0,0 +1,15 @@+ISC License++Copyright (c) 2026 Gautier DI FOLCO++Permission to use, copy, modify, and/or distribute this software for any+purpose with or without fee is hereby granted, provided that the above+copyright notice and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY+AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM+LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR+OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR+PERFORMANCE OF THIS SOFTWARE.
+ numerus-closus.cabal view
@@ -0,0 +1,90 @@+cabal-version: 3.0+name: numerus-closus+version: 0.1.0.0+author: Gautier DI FOLCO+maintainer: gautier.difolco@gmail.com+category: Scheduling+build-type: Simple+license: ISC+license-file: LICENSE+synopsis: Simple rate-limiting primitives+description: Simple, composable, pure rate-limiting primitives with scheduling support.+Homepage: https://github.com/blackheaven/numerus-closus+tested-with: GHC==9.6.6, GHC==9.8.4, GHC==9.10.1, GHC==9.12.1++library+ default-language: Haskell2010+ build-depends:+ base == 4.*+ , containers >= 0.7 && < 1+ , time >= 1.9 && < 2+ , unbounded-delays == 0.1.*+ hs-source-dirs: src+ exposed-modules:+ Control.NumerusClosus+ other-modules:+ Paths_numerus_closus+ autogen-modules:+ Paths_numerus_closus+ default-extensions:+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveGeneric+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ FlexibleContexts+ GADTs+ GeneralizedNewtypeDeriving+ KindSignatures+ LambdaCase+ OverloadedStrings+ OverloadedRecordDot+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints++test-suite spec+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules:+ Paths_numerus_closus+ autogen-modules:+ Paths_numerus_closus+ default-extensions:+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveGeneric+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ FlexibleContexts+ GADTs+ GeneralizedNewtypeDeriving+ KindSignatures+ LambdaCase+ OverloadedStrings+ OverloadedRecordDot+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+ build-depends:+ base+ , numerus-closus+ , hedgehog+ , hspec+ , hspec-core+ , hspec-hedgehog+ , time+ default-language: Haskell2010
+ src/Control/NumerusClosus.hs view
@@ -0,0 +1,310 @@+{-# LANGUAGE TupleSections #-}++-- |+-- Module : Control.NumerusClosus+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <gautier.difolco@gmail.com>+-- Stability : Stable+-- Portability : Portable+--+-- Simple, composable, pure rate-limiting primitives supporting finite buckets,+-- fixed windows, sliding windows, and sliding window counters. Includes AND/OR+-- combinators and scheduling helpers.+--+-- > import Control.NumerusClosus+-- > import Data.Time (getCurrentTime)+-- >+-- > main :: IO ()+-- > main = do+-- > now <- getCurrentTime+-- > let rl = fixedWindow 60 5 now -- 5 requests per 60 seconds+-- > result <- schedule rl (putStrLn "Request allowed")+-- > print result+module Control.NumerusClosus+ ( RateLimiter (..),+ NextDebitable (..),++ -- * Base helpers+ alwaysAllow,+ alwaysDeny,++ -- * Strategies+ BucketSize (..),+ finiteBucket,+ fixedWindow,+ slidingWindow,+ slidingWindowCount,+ WindowsCount (..),+ slidingWindowBucketed,++ -- * Combinators+ (.&&),+ (.||),+ allOf,+ anyOf,++ -- * Scheduling+ PositionInTime (..),+ ioPositionInTime,+ schedule,+ scheduleWith,+ loopSchedule,+ loopScheduleWith,+ )+where++import Control.Concurrent.Thread.Delay (delay)+import Control.Monad (mfilter)+import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import qualified Data.Set as Set+import Data.Time (FormatTime, NominalDiffTime, ParseTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime)++-- * Main logic++-- | The core rate limiter type.+-- Given the current time, returns either the next debitable time or a new rate limiter state.+newtype RateLimiter = RateLimiter+ { -- | Function to determine if a request is allowed at a given time.+ debit :: UTCTime -> Either NextDebitable RateLimiter+ }++-- | Represents when the next request can be debited.+data NextDebitable+ = -- | The request will never be debitable again.+ Never+ | -- | The request can be debited from this time onwards.+ DebitableFrom UTCTime+ deriving stock (Eq, Show)++instance Semigroup NextDebitable where+ Never <> _ = Never+ _ <> Never = Never+ DebitableFrom x <> DebitableFrom y = DebitableFrom $ max x y++-- * Base helpers++-- | A rate limiter that always allows requests.+alwaysAllow :: RateLimiter+alwaysAllow =+ RateLimiter+ { debit = const $ Right alwaysAllow+ }++-- | A rate limiter that always denies requests.+alwaysDeny :: RateLimiter+alwaysDeny =+ RateLimiter+ { debit = const $ Left Never+ }++-- * Strategies++-- | The maximum number of requests a bucket can hold.+newtype BucketSize a+ = BucketSize a+ deriving stock (Eq, Ord, Show)+ deriving newtype (Num)++-- | A simple finite bucket that allows exactly @n@ requests.+finiteBucket :: BucketSize Integer -> RateLimiter+finiteBucket (BucketSize n) =+ RateLimiter+ { debit =+ const $+ if n > 0+ then Right $ finiteBucket $ BucketSize (n - 1)+ else Left Never+ }++-- | The size of a time window.+newtype WindowSize = WindowSize NominalDiffTime+ deriving stock (Eq, Ord, Show)+ deriving newtype (Num, Fractional, Real, RealFrac, FormatTime, ParseTime)++-- | A fixed window rate limiter that allows a given number of requests per window.+fixedWindow :: WindowSize -> BucketSize Integer -> UTCTime -> RateLimiter+fixedWindow (WindowSize window) (BucketSize maxBucket) startTime = go maxBucket $ addUTCTime window startTime+ where+ go bucket endTime =+ RateLimiter+ { debit =+ \now ->+ let (refreshedBucket, refreshedEndTime) =+ if now > endTime+ then (maxBucket, addUTCTime (fromIntegral (floor (diffUTCTime now endTime / window) + 1 :: Integer) * window) endTime)+ else (bucket, endTime)+ in if refreshedBucket > 0+ then Right $ go (refreshedBucket - 1) refreshedEndTime+ else Left $ DebitableFrom $ nextTimeUnit refreshedEndTime+ }++-- | A sliding window rate limiter that allows a given number of requests within the sliding window.+slidingWindow :: WindowSize -> BucketSize Int -> RateLimiter+slidingWindow (WindowSize window) (BucketSize maxBucket) = go Set.empty+ where+ go bucket =+ RateLimiter+ { debit =+ \now ->+ let refreshedBucket = snd $ Set.split (addUTCTime ((-1) * window) now) bucket+ in if Set.size refreshedBucket < maxBucket+ then Right $ go $ Set.insert now refreshedBucket+ else Left $ DebitableFrom $ nextTimeUnit $ addUTCTime window $ fromMaybe now $ Set.lookupMin refreshedBucket+ }++-- | The number of sub-windows for bucketed sliding windows.+newtype WindowsCount a+ = WindowsCount a+ deriving stock (Eq, Ord, Show)+ deriving newtype (Num)++-- | Sliding window rate limiter using sub-bucket counters.+-- Divides the window into sub-buckets keyed by request arrival times and sums+-- their counters. This is a bucketed variant rather than the canonical+-- two-window weighted interpolation.+slidingWindowBucketed :: WindowSize -> WindowsCount Int -> BucketSize Integer -> RateLimiter+slidingWindowBucketed (WindowSize window) (WindowsCount windowsCount) (BucketSize maxBucket) = go Map.empty+ where+ bucketWindow = window / fromIntegral windowsCount+ go buckets =+ RateLimiter+ { debit =+ \now ->+ let refreshedBucket =+ Map.restrictKeys buckets $+ snd $+ Set.split (addUTCTime ((-1) * window) now) $+ Map.keysSet buckets+ lastBucket =+ fromMaybe now $+ mfilter (> addUTCTime ((-1) * bucketWindow) now) $+ fst <$> Map.lookupMax refreshedBucket+ in if sum refreshedBucket < maxBucket+ then Right $ go $ Map.alter (Just . maybe 1 (+ 1)) lastBucket refreshedBucket+ else Left $ DebitableFrom $ nextTimeUnit $ addUTCTime window $ maybe now fst $ Map.lookupMin refreshedBucket+ }++-- | Sliding window counter using two-window weighted interpolation.+-- Tracks counters for the current and previous fixed windows, then estimates+-- the request rate as: @prev * (1 - elapsed\/window) + current@.+-- This is the canonical sliding window counter algorithm with O(1) memory.+slidingWindowCount :: WindowSize -> BucketSize Integer -> UTCTime -> RateLimiter+slidingWindowCount (WindowSize window) (BucketSize maxBucket) startTime = go (0 :: Integer) 0 $ addUTCTime window startTime+ where+ go prevCount currentCount windowEnd =+ RateLimiter+ { debit =+ \now ->+ let (refreshedPrev, refreshedCurrent, refreshedEnd) =+ if now > windowEnd+ then+ let windowsElapsed = floor (diffUTCTime now windowEnd / window) :: Integer+ newEnd = addUTCTime (fromIntegral (windowsElapsed + 1) * window) windowEnd+ in if windowsElapsed == 0+ then (currentCount, 0, newEnd)+ else (0, 0, newEnd)+ else (prevCount, currentCount, windowEnd)+ windowStart = addUTCTime ((-1) * window) refreshedEnd+ fraction = realToFrac (diffUTCTime now windowStart) / realToFrac window :: Double+ estimate = fromIntegral refreshedPrev * (1 - fraction) + fromIntegral refreshedCurrent :: Double+ in if estimate < fromIntegral maxBucket+ then Right $ go refreshedPrev (refreshedCurrent + 1) refreshedEnd+ else Left $ DebitableFrom $ nextTimeUnit refreshedEnd+ }++-- | Helper to get the smallest next time unit for debiting.+nextTimeUnit :: UTCTime -> UTCTime+nextTimeUnit = addUTCTime 0.000001++-- * Combinators++-- | AND combinator: allows a request if both rate limiters allow it.+(.&&) :: RateLimiter -> RateLimiter -> RateLimiter+x .&& y =+ RateLimiter+ { debit = \at ->+ case (x.debit at, y.debit at) of+ (Right x', Right y') -> Right $ x' .&& y'+ (Left x', Left y') -> Left $ x' <> y'+ (Left x', _) -> Left x'+ (_, Left y') -> Left y'+ }++infixr 3 .&&++-- | OR combinator: allows a request if either rate limiter allows it.+(.||) :: RateLimiter -> RateLimiter -> RateLimiter+x .|| y =+ RateLimiter+ { debit = \at ->+ case (x.debit at, y.debit at) of+ (Right x', Right y') -> Right $ x' .|| y'+ (Left x', Left y') ->+ Left $+ case (x', y') of+ (Never, Never) -> Never+ (DebitableFrom x'', DebitableFrom y'') -> DebitableFrom $ min x'' y''+ (DebitableFrom x'', _) -> DebitableFrom x''+ (_, DebitableFrom y'') -> DebitableFrom y''+ (Right x', _) -> Right x'+ (_, Right y') -> Right y'+ }++infixr 3 .||++-- | Require all of the given rate limiters to allow the request.+allOf :: NE.NonEmpty RateLimiter -> RateLimiter+allOf = foldl1 (.&&)++-- | Allow the request if any of the given rate limiters allow it.+anyOf :: NE.NonEmpty RateLimiter -> RateLimiter+anyOf = foldl1 (.||)++-- * Scheduling++-- | Fetch the time and compute the delay time.+data PositionInTime m = PositionInTime+ { -- | How to fetch the current time.+ getTime :: m UTCTime,+ -- | How to delay until a specific time.+ delayUntil :: UTCTime -> m ()+ }++-- | Run an IO action if the rate limiter allows it, using the current time.+schedule :: RateLimiter -> IO a -> IO (Either NextDebitable (RateLimiter, a))+schedule = scheduleWith ioPositionInTime++-- | Default time strategy for IO.+ioPositionInTime :: PositionInTime IO+ioPositionInTime = PositionInTime getCurrentTime diffDelay+ where+ diffDelay to = do+ now <- getCurrentTime+ delay $ 0 `max` round (diffUTCTime to now * 1000000)++-- | Run a monadic action if the rate limiter allows it, using a custom time strategy.+scheduleWith :: (Monad m) => PositionInTime m -> RateLimiter -> m a -> m (Either NextDebitable (RateLimiter, a))+scheduleWith pit rl action = do+ now <- pit.getTime+ case rl.debit now of+ Right rl' -> Right . (rl',) <$> action+ Left nd -> return $ Left nd++-- | Repeatedly run an IO action, respecting the rate limiter. Will sleep until the next available slot if rate limited.+loopSchedule :: RateLimiter -> IO a -> IO ()+loopSchedule = loopScheduleWith ioPositionInTime++-- | Repeatedly run a monadic action, respecting the rate limiter and using a custom time strategy. Will sleep until the next available slot if rate limited.+loopScheduleWith :: (Monad m) => PositionInTime m -> RateLimiter -> m a -> m ()+loopScheduleWith pit rl action = go rl+ where+ go rl' = do+ result <- scheduleWith pit rl' action+ case result of+ Right (rl'', _) -> go rl''+ Left Never -> return ()+ Left (DebitableFrom at) -> pit.delayUntil at >> go rl'
+ test/Spec.hs view
@@ -0,0 +1,309 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Control.Monad (replicateM_)+import qualified Control.NumerusClosus as NC+import Control.NumerusClosus ((.&&), (.||))+import Data.Either (isLeft, isRight)+import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.List.NonEmpty as NE+import Data.Time (NominalDiffTime, UTCTime (..), addUTCTime, fromGregorian, secondsToNominalDiffTime)+import qualified Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Test.Hspec (Expectation, Spec, describe, hspec, it, shouldBe, shouldSatisfy)+import Test.Hspec.Hedgehog (PropertyT, forAll, hedgehog, (===))++main :: IO ()+main = hspec spec++baseTime :: UTCTime+baseTime = UTCTime (fromGregorian 2024 1 1) 0++offsetTime :: Int -> UTCTime+offsetTime n = addUTCTime (secondsToNominalDiffTime (fromIntegral n)) baseTime++nextTimeUnit :: UTCTime -> UTCTime+nextTimeUnit = addUTCTime 0.000001++genUTCTime :: Hedgehog.Gen UTCTime+genUTCTime = do+ s <- Gen.integral (Range.linear 0 86400)+ pure $ addUTCTime (secondsToNominalDiffTime (fromIntegral s)) baseTime++debitN :: Int -> UTCTime -> NC.RateLimiter -> Either NC.NextDebitable NC.RateLimiter+debitN 0 _ rl = Right rl+debitN n t rl = case NC.debit rl t of+ Right rl' -> debitN (n - 1) t rl'+ Left nd -> Left nd++debitSequence :: [UTCTime] -> NC.RateLimiter -> Either NC.NextDebitable NC.RateLimiter+debitSequence [] rl = Right rl+debitSequence (t:ts) rl = case NC.debit rl t of+ Right rl' -> debitSequence ts rl'+ Left nd -> Left nd++assertRight :: Either NC.NextDebitable NC.RateLimiter -> Expectation+assertRight (Right _) = pure ()+assertRight (Left nd) = fail $ "Expected Right, got Left " ++ show nd++assertLeftNever :: Either NC.NextDebitable NC.RateLimiter -> Expectation+assertLeftNever (Left NC.Never) = pure ()+assertLeftNever (Left nd) = fail $ "Expected Left Never, got Left " ++ show nd+assertLeftNever (Right _) = fail "Expected Left Never, got Right"++assertLeftDebitableFrom :: UTCTime -> Either NC.NextDebitable NC.RateLimiter -> Expectation+assertLeftDebitableFrom t (Left (NC.DebitableFrom t')) | t == t' = pure ()+assertLeftDebitableFrom t (Left nd) = fail $ "Expected Left (DebitableFrom " ++ show t ++ "), got Left " ++ show nd+assertLeftDebitableFrom _ (Right _) = fail "Expected Left DebitableFrom, got Right"++assertLeftAny :: Either NC.NextDebitable NC.RateLimiter -> Expectation+assertLeftAny (Left _) = pure ()+assertLeftAny (Right _) = fail "Expected Left, got Right"++assertLeftNeverH :: (Hedgehog.MonadTest m) => Either NC.NextDebitable NC.RateLimiter -> m ()+assertLeftNeverH (Left NC.Never) = pure ()+assertLeftNeverH _ = Hedgehog.failure++assertLeftDebitableFromH :: (Hedgehog.MonadTest m) => UTCTime -> Either NC.NextDebitable NC.RateLimiter -> m ()+assertLeftDebitableFromH t (Left (NC.DebitableFrom t')) | t == t' = pure ()+assertLeftDebitableFromH _ _ = Hedgehog.failure++spec :: Spec+spec = do+ describe "Control.NumerusClosus" do+ describe "alwaysAllow" do+ it "debiting always returns Right" do+ assertRight $ NC.debit NC.alwaysAllow baseTime+ assertRight $ debitN 100 baseTime NC.alwaysAllow++ describe "alwaysDeny" do+ it "debiting always returns Left Never" do+ assertLeftNever $ NC.debit NC.alwaysDeny baseTime++ describe "finiteBucket" do+ it "Allows exactly n debits, then denies with Never" do+ let rl = NC.finiteBucket 3+ case debitN 3 baseTime rl of+ Right rl' -> assertLeftNever $ NC.debit rl' baseTime+ Left _ -> fail "should allow 3 debits"++ it "finiteBucket 0 denies immediately" do+ assertLeftNever $ NC.debit (NC.finiteBucket 0) baseTime++ it "finiteBucket 1 allows once then denies" do+ let rl = NC.finiteBucket 1+ case NC.debit rl baseTime of+ Right rl' -> assertLeftNever $ NC.debit rl' baseTime+ Left _ -> fail "should allow 1 debit"++ describe "fixedWindow" do+ let windowSize = 60+ maxBucket = 5 :: Int+ rl = NC.fixedWindow windowSize (fromIntegral maxBucket) baseTime++ it "Allows maxBucket debits within window" do+ assertRight $ debitN maxBucket baseTime rl++ it "Denies after maxBucket debits within same window" do+ case debitN maxBucket baseTime rl of+ Right rl' -> assertLeftDebitableFrom (nextTimeUnit (offsetTime 60)) $ NC.debit rl' baseTime+ Left _ -> fail "should allow maxBucket debits"++ it "Resets after window expires" do+ case debitN maxBucket baseTime rl of+ Right rl' -> assertRight $ NC.debit rl' (offsetTime 61)+ Left _ -> fail "should allow maxBucket debits"++ it "Returns DebitableFrom with correct next window time" do+ case debitN maxBucket baseTime rl of+ Right rl' -> assertLeftDebitableFrom (nextTimeUnit (offsetTime 60)) $ NC.debit rl' (offsetTime 10)+ Left _ -> fail "should allow maxBucket debits"++ describe "slidingWindow" do+ let windowSize = 60+ maxBucket = 3 :: Int+ rl = NC.slidingWindow windowSize (fromIntegral maxBucket)++ it "Allows maxBucket debits within window" do+ assertRight $ debitSequence [offsetTime 1, offsetTime 2, offsetTime 3] rl++ it "Denies when full within window" do+ case debitSequence [offsetTime 1, offsetTime 2, offsetTime 3] rl of+ Right rl' -> assertLeftDebitableFrom (nextTimeUnit (offsetTime 61)) $ NC.debit rl' (offsetTime 10)+ Left _ -> fail "should allow maxBucket debits"++ it "Allows again after oldest entry expires from window" do+ case debitSequence [offsetTime 1, offsetTime 2, offsetTime 3] rl of+ Right rl3 -> do+ assertLeftDebitableFrom (nextTimeUnit (offsetTime 61)) $ NC.debit rl3 (offsetTime 30)+ assertRight $ NC.debit rl3 (offsetTime 61)+ Left _ -> fail "debits failed"++ describe "slidingWindowCount" do+ let windowSize = 60+ maxBucket = 10 :: Int+ rl = NC.slidingWindowCount windowSize (fromIntegral maxBucket) baseTime++ it "Allows within budget" do+ assertRight $ debitN maxBucket baseTime rl++ it "Denies when weighted estimate exceeds budget" do+ case debitN maxBucket baseTime rl of+ Right rl' -> assertLeftAny $ NC.debit rl' baseTime+ Left _ -> fail "should allow maxBucket debits"++ it "Resets after full window elapses" do+ case debitN maxBucket baseTime rl of+ Right rl' -> assertRight $ NC.debit rl' (nextTimeUnit (offsetTime 60))+ Left _ -> fail "should allow maxBucket debits"++ describe "slidingWindowBucketed" do+ let windowSize = 60+ windowCount = 6+ maxBucket = 10 :: Int+ rl = NC.slidingWindowBucketed windowSize windowCount (fromIntegral maxBucket)++ it "Allows within budget" do+ assertRight $ debitN maxBucket baseTime rl++ it "Denies when sum exceeds budget" do+ case debitN maxBucket baseTime rl of+ Right rl' -> assertLeftAny $ NC.debit rl' baseTime+ Left _ -> fail "should allow maxBucket debits"++ describe "(.&&) combinator" do+ let rlAllow = NC.alwaysAllow+ rlDeny = NC.alwaysDeny+ rlFixed = NC.fixedWindow 60 1 baseTime++ it "Both allow -> allows" do+ assertRight $ NC.debit (rlAllow .&& rlAllow) baseTime++ it "One denies -> denies" do+ assertLeftNever $ NC.debit (rlAllow .&& rlDeny) baseTime+ assertLeftNever $ NC.debit (rlDeny .&& rlAllow) baseTime++ it "Both deny -> merges NextDebitable with max (semigroup)" do+ case NC.debit rlFixed baseTime of+ Right rlFixed' -> do+ let rl1 = rlFixed'+ rl2 = NC.alwaysDeny+ assertLeftNever $ NC.debit (rl1 .&& rl2) baseTime+ Left _ -> fail "should allow 1 debit"++ describe "(.||) combinator" do+ let rlAllow = NC.alwaysAllow+ rlDeny = NC.alwaysDeny+ rlFixed = NC.fixedWindow 60 1 baseTime++ it "Both allow -> allows" do+ assertRight $ NC.debit (rlAllow .|| rlAllow) baseTime++ it "One allows -> allows" do+ assertRight $ NC.debit (rlAllow .|| rlDeny) baseTime+ assertRight $ NC.debit (rlDeny .|| rlAllow) baseTime++ it "Both deny -> merges with min of DebitableFrom times" do+ case NC.debit rlFixed baseTime of+ Right rlFixed' -> do+ let rlFixed2 = NC.fixedWindow 120 1 baseTime+ case NC.debit rlFixed2 baseTime of+ Right rlFixed2' ->+ assertLeftDebitableFrom (nextTimeUnit (offsetTime 60)) $ NC.debit (rlFixed' .|| rlFixed2') baseTime+ Left _ -> fail "should allow 1 debit"+ Left _ -> fail "should allow 1 debit"++ it "Both Never -> Never" do+ assertLeftNever $ NC.debit (rlDeny .|| rlDeny) baseTime++ describe "allOf / anyOf" do+ let rlAllow = NC.alwaysAllow+ rlDeny = NC.alwaysDeny++ it "allOf works like folded .&&" do+ assertRight $ NC.debit (NC.allOf (rlAllow :| [rlAllow])) baseTime+ assertLeftNever $ NC.debit (NC.allOf (rlAllow :| [rlDeny])) baseTime++ it "anyOf works like folded .||" do+ assertLeftNever $ NC.debit (NC.anyOf (rlDeny :| [rlDeny])) baseTime+ assertRight $ NC.debit (NC.anyOf (rlDeny :| [rlAllow])) baseTime++ describe "NextDebitable Semigroup" do+ it "Never <> anything = Never" do+ NC.Never <> NC.DebitableFrom baseTime `shouldBe` NC.Never+ NC.DebitableFrom baseTime <> NC.Never `shouldBe` NC.Never++ it "DebitableFrom x <> DebitableFrom y = DebitableFrom (max x y)" do+ let t1 = offsetTime 10+ t2 = offsetTime 20+ NC.DebitableFrom t1 <> NC.DebitableFrom t2 `shouldBe` NC.DebitableFrom t2++ describe "scheduleWith" do+ it "mock PositionInTime pure test" do+ let mockPit = NC.PositionInTime {NC.getTime = pure baseTime, NC.delayUntil = \_ -> pure ()}+ rl = NC.finiteBucket 1+ x <- NC.scheduleWith mockPit rl (pure True)+ case x of+ Right (_, v) -> v `shouldBe` True+ Left _ -> fail "should have worked"++ describe "Properties" do+ it "finiteBucket allows exactly n then denies" $ hedgehog do+ n <- forAll (Gen.integral (Range.linear 0 100))+ let rl = NC.finiteBucket (NC.BucketSize n)+ case debitN (fromIntegral n) baseTime rl of+ Right rl' -> assertLeftNeverH $ NC.debit rl' baseTime+ Left _ -> Hedgehog.failure++ it "alwaysAllow never denies" $ hedgehog do+ n <- forAll (Gen.integral (Range.linear 0 1000))+ case debitN (fromIntegral n) baseTime NC.alwaysAllow of+ Right _ -> pure ()+ Left _ -> Hedgehog.failure++ it "NextDebitable semigroup associativity" $ hedgehog do+ a <- forAll genNextDebitable+ b <- forAll genNextDebitable+ c <- forAll genNextDebitable+ (a <> b) <> c === a <> (b <> c)++ it "NextDebitable semigroup Never absorption" $ hedgehog do+ x <- forAll genNextDebitable+ NC.Never <> x === NC.Never+ x <> NC.Never === NC.Never++ it "fixedWindow allows exactly maxBucket per window" $ hedgehog do+ maxBucket <- forAll (Gen.integral (Range.linear 1 50))+ let rl = NC.fixedWindow 60 (NC.BucketSize maxBucket) baseTime+ case debitN (fromIntegral maxBucket) baseTime rl of+ Right rl' -> assertLeftDebitableFromH (nextTimeUnit (offsetTime 60)) $ NC.debit rl' baseTime+ Left _ -> Hedgehog.failure++ it "(.&&) is at least as restrictive as either operand" $ hedgehog do+ t <- forAll genUTCTime+ let rl1 = NC.finiteBucket 0+ rl2 = NC.alwaysAllow+ assertLeftNeverH $ NC.debit (rl1 .&& rl2) t+ assertLeftNeverH $ NC.debit (rl2 .&& rl1) t++ it "(.||) is at least as permissive as either operand" $ hedgehog do+ t <- forAll genUTCTime+ let rl1 = NC.finiteBucket 0+ rl2 = NC.alwaysAllow+ case NC.debit (rl1 .|| rl2) t of+ Right _ -> pure ()+ Left _ -> Hedgehog.failure+ case NC.debit (rl2 .|| rl1) t of+ Right _ -> pure ()+ Left _ -> Hedgehog.failure++genNextDebitable :: Hedgehog.Gen NC.NextDebitable+genNextDebitable =+ Gen.choice+ [ pure NC.Never+ , NC.DebitableFrom <$> genUTCTime+ ]