{-# LANGUAGE BangPatterns, FlexibleContexts, OverloadedStrings, ScopedTypeVariables, TypeApplications, DataKinds, KindSignatures #-}

-- |
-- Module      : Data.TinyLRU
-- Description : A lightweight, thread-safe, in-memory LRU cache.
-- Copyright   : (c) 2025 Oleksandr Zhabenko
-- License     : MIT
-- Maintainer  : oleksandr.zhabenko@yahoo.com
-- Stability   : experimental
-- Portability : POSIX
--
-- This module provides a simple, thread-safe, and efficient Least Recently Used (LRU)
-- cache. It is built using Software Transactional Memory (STM), making it suitable
-- for concurrent applications.
--
-- The cache supports:
--
-- *  A fixed capacity, with automatic eviction of the least recently used item.
-- *  Time-based expiration (TTL) for each entry.
-- *  Generic key-value storage, with values being 'ToJSON'/'FromJSON' serializable.
-- *  Atomic operations for safe concurrent access.
--
-- A typical use case involves creating a cache, and then using 'access' or
-- 'updateValue' within an 'atomically' block to interact with it.
--
-- == Example Usage
--
-- @
-- import Control.Concurrent.STM
-- import Data.TinyLRU
-- import Data.Text (Text)
-- import System.Clock
--
-- main :: IO ()
-- main = do
--   -- Initialize a cache with a capacity of 100 items.
--   lru <- atomically $ initTinyLRU 100
--
--   -- Add or retrieve a value.
--   let key1 = "my-key" :: Text
--   let value1 = "my-value" :: Text
--   let ttlSeconds = 3600 -- 1 hour
--
--   -- 'access' is a get-or-insert operation.
--   -- On first run, it inserts 'value1' and returns it.
--   -- On subsequent runs, it returns the existing value.
--   now <- getTime Monotonic
--   retrievedValue <- atomically $ access now key1 value1 ttlSeconds lru
--   print retrievedValue -- Should print: Just "my-value"
--
--   -- Explicitly update a value.
--   let newValue = "a-new-value" :: Text
--   updatedValue <- atomically $ updateValue now key1 newValue ttlSeconds lru
--   print updatedValue -- Should print: Just "a-new-value"
--
--   -- Use the cache for rate limiting.
--   let rateLimitKey = "user:123:login-attempts"
--   -- Allow 5 requests per 60 seconds.
--   isAllowed <- atomically $ allowRequestTinyLRU now lru rateLimitKey 5 60
--   if isAllowed
--     then putStrLn "Request allowed."
--     else putStrLn "Rate limit exceeded."
-- @
--

module Data.TinyLRU
  ( -- * Cache Type
    TinyLRUCache(..)
    -- * Core API
  , initTinyLRU
  , access
  , updateValue
  , deleteKey
  , resetTinyLRU
    -- * Rate Limiting
  , allowRequestTinyLRU
    -- * Internals
    -- | These are lower-level components and functions. Most users will not need them directly.
  , LRUList(..)
  , LRUNode(..)
  , isExpired
  , addToFront
  , removeNode
  , moveToFront
  , evictLRU
  , removeNodeFromCache
  , moveToFrontInCache
  ) where

import Control.Concurrent.STM
import StmContainers.Map (Map)
import qualified StmContainers.Map as Map
import Data.Text (Text)
import qualified Data.Text as T
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as BL
import Data.Aeson (FromJSON, ToJSON, encode, decodeStrict)
import System.Clock (TimeSpec(..))
import Data.Maybe (isNothing)
import Control.Monad (when, forM_, foldM)
import qualified ListT

-- | Represents a single node in the LRU cache's doubly-linked list.
-- Each node contains the key, value, expiry time, and pointers to the
-- previous and next nodes.
data LRUNode s = LRUNode
  { forall s. LRUNode s -> Text
nodeKey    :: !Text
    -- ^ The key associated with this cache entry.
  , forall s. LRUNode s -> ByteString
nodeValue  :: !ByteString
    -- ^ The value, stored as a 'ByteString' after JSON encoding.
  , forall s. LRUNode s -> Maybe TimeSpec
nodeExpiry :: !(Maybe TimeSpec)
    -- ^ The absolute expiration time. 'Nothing' means the entry never expires.
  , forall s. LRUNode s -> Maybe (TVar (LRUNode s))
nodePrev   :: !(Maybe (TVar (LRUNode s)))
    -- ^ A transactional variable pointing to the previous node in the list. 'Nothing' if this is the head.
  , forall s. LRUNode s -> Maybe (TVar (LRUNode s))
nodeNext   :: !(Maybe (TVar (LRUNode s)))
    -- ^ A transactional variable pointing to the next node in the list. 'Nothing' if this is the tail.
  }

-- | Represents the doubly-linked list used to track the LRU order.
-- It only stores pointers to the head (most recently used) and
-- tail (least recently used) of the list.
data LRUList s = LRUList
  { forall s. LRUList s -> Maybe (TVar (LRUNode s))
lruHead :: !(Maybe (TVar (LRUNode s)))
    -- ^ A pointer to the most recently used node.
  , forall s. LRUList s -> Maybe (TVar (LRUNode s))
lruTail :: !(Maybe (TVar (LRUNode s)))
    -- ^ A pointer to the least recently used node.
  }

-- | The main data structure for the LRU cache.
-- This is the handle you will use for all cache operations.
data TinyLRUCache s = TinyLRUCache
  { forall s. TinyLRUCache s -> Map Text (TVar (LRUNode s))
lruCache :: !(Map Text (TVar (LRUNode s)))
    -- ^ A transactional hash map for O(1) average time complexity lookups.
    -- Maps keys to their corresponding 'LRUNode's in the list.
  , forall s. TinyLRUCache s -> TVar (LRUList s)
lruList  :: !(TVar (LRUList s))
    -- ^ A transactional variable holding the 'LRUList', which manages the usage order.
  , forall s. TinyLRUCache s -> Int
lruCap   :: !Int
    -- ^ The maximum number of items the cache can hold.
  }

-- | Initializes a new 'TinyLRUCache' with a specified capacity.
-- This function must be run within an 'STM' transaction.
--
-- @
-- lruCache <- atomically $ initTinyLRU 1000
-- @
--
-- @param cap The maximum number of items the cache can hold. Must be > 0.
-- @return An 'STM' action that yields a new, empty 'TinyLRUCache'.
initTinyLRU :: Int -> STM (TinyLRUCache s)
initTinyLRU :: forall s. Int -> STM (TinyLRUCache s)
initTinyLRU Int
cap = do
  Map Text (TVar (LRUNode s))
cache <- forall key value. STM (Map key value)
Map.new
  TVar (LRUList s)
list <- forall a. a -> STM (TVar a)
newTVar forall a b. (a -> b) -> a -> b
$ forall s.
Maybe (TVar (LRUNode s)) -> Maybe (TVar (LRUNode s)) -> LRUList s
LRUList forall a. Maybe a
Nothing forall a. Maybe a
Nothing
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s.
Map Text (TVar (LRUNode s))
-> TVar (LRUList s) -> Int -> TinyLRUCache s
TinyLRUCache Map Text (TVar (LRUNode s))
cache TVar (LRUList s)
list Int
cap

-- | Helper function to calculate the expiry 'TimeSpec' from a TTL in seconds.
mkExpiry :: TimeSpec -> Int -> Maybe TimeSpec
mkExpiry :: TimeSpec -> Int -> Maybe TimeSpec
mkExpiry TimeSpec
now Int
ttl | Int
ttl forall a. Ord a => a -> a -> Bool
<= Int
0 = forall a. Maybe a
Nothing
                 | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TimeSpec -> Int -> TimeSpec
addTTL TimeSpec
now Int
ttl

-- | Checks if a cache node is expired relative to the current time.
--
-- @param now The current 'TimeSpec'.
-- @param node The 'LRUNode' to check.
-- @return 'True' if the node is expired, 'False' otherwise.
isExpired :: TimeSpec -> LRUNode s -> Bool
isExpired :: forall s. TimeSpec -> LRUNode s -> Bool
isExpired TimeSpec
now LRUNode s
node =
  case forall s. LRUNode s -> Maybe TimeSpec
nodeExpiry LRUNode s
node of
    Maybe TimeSpec
Nothing -> Bool
False
    Just TimeSpec
expTime -> TimeSpec
now forall a. Ord a => a -> a -> Bool
>= TimeSpec
expTime

-- | Atomically removes a node from the doubly-linked list.
-- It correctly updates the 'nodePrev' and 'nodeNext' pointers of the
-- neighboring nodes and the list's 'lruHead' and 'lruTail' pointers if necessary.
--
-- @param listTVar The 'TVar' of the 'LRUList' from which to remove the node.
-- @param nodeTVar The 'TVar' of the 'LRUNode' to remove.
removeNode :: TVar (LRUList s) -> TVar (LRUNode s) -> STM ()
removeNode :: forall s. TVar (LRUList s) -> TVar (LRUNode s) -> STM ()
removeNode TVar (LRUList s)
listTVar TVar (LRUNode s)
nodeTVar = do
  LRUNode s
node <- forall a. TVar a -> STM a
readTVar TVar (LRUNode s)
nodeTVar
  let mPrev :: Maybe (TVar (LRUNode s))
mPrev = forall s. LRUNode s -> Maybe (TVar (LRUNode s))
nodePrev LRUNode s
node
      mNext :: Maybe (TVar (LRUNode s))
mNext = forall s. LRUNode s -> Maybe (TVar (LRUNode s))
nodeNext LRUNode s
node

  -- Link neighbour nodes to each other
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (TVar (LRUNode s))
mPrev forall a b. (a -> b) -> a -> b
$ \TVar (LRUNode s)
pRef -> forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (LRUNode s)
pRef (\LRUNode s
p -> LRUNode s
p { nodeNext :: Maybe (TVar (LRUNode s))
nodeNext = Maybe (TVar (LRUNode s))
mNext })
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (TVar (LRUNode s))
mNext forall a b. (a -> b) -> a -> b
$ \TVar (LRUNode s)
nRef -> forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (LRUNode s)
nRef (\LRUNode s
n -> LRUNode s
n { nodePrev :: Maybe (TVar (LRUNode s))
nodePrev = Maybe (TVar (LRUNode s))
mPrev })

  -- Atomically update the list's head and tail pointers
  forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (LRUList s)
listTVar forall a b. (a -> b) -> a -> b
$ \LRUList s
list ->
    let newHead :: Maybe (TVar (LRUNode s))
newHead = if forall s. LRUList s -> Maybe (TVar (LRUNode s))
lruHead LRUList s
list forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just TVar (LRUNode s)
nodeTVar then Maybe (TVar (LRUNode s))
mNext else forall s. LRUList s -> Maybe (TVar (LRUNode s))
lruHead LRUList s
list
        newTail :: Maybe (TVar (LRUNode s))
newTail = if forall s. LRUList s -> Maybe (TVar (LRUNode s))
lruTail LRUList s
list forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just TVar (LRUNode s)
nodeTVar then Maybe (TVar (LRUNode s))
mPrev else forall s. LRUList s -> Maybe (TVar (LRUNode s))
lruTail LRUList s
list
    in LRUList s
list { lruHead :: Maybe (TVar (LRUNode s))
lruHead = Maybe (TVar (LRUNode s))
newHead, lruTail :: Maybe (TVar (LRUNode s))
lruTail = Maybe (TVar (LRUNode s))
newTail }

-- | Creates a new node and adds it to the front (most recently used position)
-- of the cache's linked list.
--
-- @param now The current 'TimeSpec', used for calculating expiry.
-- @param ttl The time-to-live in seconds. A value `<= 0` means it never expires.
-- @param cache The 'TinyLRUCache' instance.
-- @param key The key for the new entry.
-- @param value The 'ByteString' value for the new entry.
-- @return The 'TVar' of the newly created 'LRUNode'.
addToFront :: TimeSpec -> Int -> TinyLRUCache s -> Text -> ByteString -> STM (TVar (LRUNode s))
addToFront :: forall s.
TimeSpec
-> Int
-> TinyLRUCache s
-> Text
-> ByteString
-> STM (TVar (LRUNode s))
addToFront TimeSpec
now Int
ttl TinyLRUCache s
cache Text
key ByteString
value = do
  let expiry :: Maybe TimeSpec
expiry = TimeSpec -> Int -> Maybe TimeSpec
mkExpiry TimeSpec
now Int
ttl
  LRUList s
list <- forall a. TVar a -> STM a
readTVar (forall s. TinyLRUCache s -> TVar (LRUList s)
lruList TinyLRUCache s
cache)
  TVar (LRUNode s)
nodeTVar <- forall a. a -> STM (TVar a)
newTVar forall a b. (a -> b) -> a -> b
$ forall s.
Text
-> ByteString
-> Maybe TimeSpec
-> Maybe (TVar (LRUNode s))
-> Maybe (TVar (LRUNode s))
-> LRUNode s
LRUNode Text
key ByteString
value Maybe TimeSpec
expiry forall a. Maybe a
Nothing (forall s. LRUList s -> Maybe (TVar (LRUNode s))
lruHead LRUList s
list)
  
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall s. LRUList s -> Maybe (TVar (LRUNode s))
lruHead LRUList s
list) forall a b. (a -> b) -> a -> b
$ \TVar (LRUNode s)
oldHeadTVar -> do
    LRUNode s
oldHead <- forall a. TVar a -> STM a
readTVar TVar (LRUNode s)
oldHeadTVar
    forall a. TVar a -> a -> STM ()
writeTVar TVar (LRUNode s)
oldHeadTVar LRUNode s
oldHead { nodePrev :: Maybe (TVar (LRUNode s))
nodePrev = forall a. a -> Maybe a
Just TVar (LRUNode s)
nodeTVar }

  let newTail :: Maybe (TVar (LRUNode s))
newTail = if forall a. Maybe a -> Bool
isNothing (forall s. LRUList s -> Maybe (TVar (LRUNode s))
lruTail LRUList s
list) then forall a. a -> Maybe a
Just TVar (LRUNode s)
nodeTVar else forall s. LRUList s -> Maybe (TVar (LRUNode s))
lruTail LRUList s
list
  forall a. TVar a -> a -> STM ()
writeTVar (forall s. TinyLRUCache s -> TVar (LRUList s)
lruList TinyLRUCache s
cache) (forall s.
Maybe (TVar (LRUNode s)) -> Maybe (TVar (LRUNode s)) -> LRUList s
LRUList (forall a. a -> Maybe a
Just TVar (LRUNode s)
nodeTVar) Maybe (TVar (LRUNode s))
newTail)
  
  forall (m :: * -> *) a. Monad m => a -> m a
return TVar (LRUNode s)
nodeTVar

-- | Moves an existing node to the front of the linked list, marking it as the
-- most recently used. This is a core operation for the LRU logic.
--
-- @param listTVar The 'TVar' of the 'LRUList'.
-- @param nodeTVar The 'TVar' of the 'LRUNode' to move.
moveToFront :: TVar (LRUList s) -> TVar (LRUNode s) -> STM ()
moveToFront :: forall s. TVar (LRUList s) -> TVar (LRUNode s) -> STM ()
moveToFront TVar (LRUList s)
listTVar TVar (LRUNode s)
nodeTVar = do
  LRUList s
list <- forall a. TVar a -> STM a
readTVar TVar (LRUList s)
listTVar
  -- Only move if it's not already the head
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall s. LRUList s -> Maybe (TVar (LRUNode s))
lruHead LRUList s
list forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just TVar (LRUNode s)
nodeTVar) forall a b. (a -> b) -> a -> b
$ do
    forall s. TVar (LRUList s) -> TVar (LRUNode s) -> STM ()
removeNode TVar (LRUList s)
listTVar TVar (LRUNode s)
nodeTVar
    LRUNode s
node <- forall a. TVar a -> STM a
readTVar TVar (LRUNode s)
nodeTVar
    LRUList s
list' <- forall a. TVar a -> STM a
readTVar TVar (LRUList s)
listTVar
    let mOldHead :: Maybe (TVar (LRUNode s))
mOldHead = forall s. LRUList s -> Maybe (TVar (LRUNode s))
lruHead LRUList s
list'
    forall a. TVar a -> a -> STM ()
writeTVar TVar (LRUNode s)
nodeTVar LRUNode s
node { nodePrev :: Maybe (TVar (LRUNode s))
nodePrev = forall a. Maybe a
Nothing, nodeNext :: Maybe (TVar (LRUNode s))
nodeNext = Maybe (TVar (LRUNode s))
mOldHead }
    
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (TVar (LRUNode s))
mOldHead forall a b. (a -> b) -> a -> b
$ \TVar (LRUNode s)
oldHeadTVar ->
      forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (LRUNode s)
oldHeadTVar (\LRUNode s
h -> LRUNode s
h { nodePrev :: Maybe (TVar (LRUNode s))
nodePrev = forall a. a -> Maybe a
Just TVar (LRUNode s)
nodeTVar })
    
    let newTail :: Maybe (TVar (LRUNode s))
newTail = if forall a. Maybe a -> Bool
isNothing (forall s. LRUList s -> Maybe (TVar (LRUNode s))
lruTail LRUList s
list') then forall a. a -> Maybe a
Just TVar (LRUNode s)
nodeTVar else forall s. LRUList s -> Maybe (TVar (LRUNode s))
lruTail LRUList s
list'
    forall a. TVar a -> a -> STM ()
writeTVar TVar (LRUList s)
listTVar (forall s.
Maybe (TVar (LRUNode s)) -> Maybe (TVar (LRUNode s)) -> LRUList s
LRUList (forall a. a -> Maybe a
Just TVar (LRUNode s)
nodeTVar) Maybe (TVar (LRUNode s))
newTail)

-- | Evicts the least recently used item from the cache. This involves removing
-- the tail of the linked list and deleting the corresponding entry from the hash map.
--
-- @param cache The 'TinyLRUCache' to perform eviction on.
evictLRU :: TinyLRUCache s -> STM ()
evictLRU :: forall s. TinyLRUCache s -> STM ()
evictLRU TinyLRUCache s
cache = do
  LRUList s
list <- forall a. TVar a -> STM a
readTVar (forall s. TinyLRUCache s -> TVar (LRUList s)
lruList TinyLRUCache s
cache)
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall s. LRUList s -> Maybe (TVar (LRUNode s))
lruTail LRUList s
list) forall a b. (a -> b) -> a -> b
$ \TVar (LRUNode s)
tailTVar -> do
    LRUNode s
node <- forall a. TVar a -> STM a
readTVar TVar (LRUNode s)
tailTVar
    forall key value. Hashable key => key -> Map key value -> STM ()
Map.delete (forall s. LRUNode s -> Text
nodeKey LRUNode s
node) (forall s. TinyLRUCache s -> Map Text (TVar (LRUNode s))
lruCache TinyLRUCache s
cache)
    forall s. TVar (LRUList s) -> TVar (LRUNode s) -> STM ()
removeNode (forall s. TinyLRUCache s -> TVar (LRUList s)
lruList TinyLRUCache s
cache) TVar (LRUNode s)
tailTVar

-- | Helper to add a TTL in seconds to a 'TimeSpec'.
addTTL :: TimeSpec -> Int -> TimeSpec
addTTL :: TimeSpec -> Int -> TimeSpec
addTTL (TimeSpec Int64
s Int64
ns) Int
ttl = Int64 -> Int64 -> TimeSpec
TimeSpec (Int64
s forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Ord a => a -> a -> a
max Int
0 Int
ttl)) Int64
ns

-- | Deletes an entry from the cache by its key.
-- This removes the item from both the internal map and the linked list.
--
-- @param key The key of the item to delete.
-- @param cache The 'TinyLRUCache' instance.
deleteKey :: Text -> TinyLRUCache s -> STM ()
deleteKey :: forall s. Text -> TinyLRUCache s -> STM ()
deleteKey Text
key TinyLRUCache s
cache = do
  Maybe (TVar (LRUNode s))
mNodeTVar <- forall key value.
Hashable key =>
key -> Map key value -> STM (Maybe value)
Map.lookup Text
key (forall s. TinyLRUCache s -> Map Text (TVar (LRUNode s))
lruCache TinyLRUCache s
cache)
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (TVar (LRUNode s))
mNodeTVar forall a b. (a -> b) -> a -> b
$ \TVar (LRUNode s)
nodeTVar -> do
    forall key value. Hashable key => key -> Map key value -> STM ()
Map.delete Text
key (forall s. TinyLRUCache s -> Map Text (TVar (LRUNode s))
lruCache TinyLRUCache s
cache)
    forall s. TVar (LRUList s) -> TVar (LRUNode s) -> STM ()
removeNode (forall s. TinyLRUCache s -> TVar (LRUList s)
lruList TinyLRUCache s
cache) TVar (LRUNode s)
nodeTVar

-- | Scans the cache and removes all expired items.
-- This is called automatically by 'access', 'updateValue', and 'allowRequestTinyLRU'.
cleanupExpired :: TimeSpec -> TinyLRUCache s -> STM ()
cleanupExpired :: forall s. TimeSpec -> TinyLRUCache s -> STM ()
cleanupExpired TimeSpec
now TinyLRUCache s
cache = do
  [(Text, TVar (LRUNode s))]
pairs <- forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
ListT.toList forall a b. (a -> b) -> a -> b
$ forall key value. Map key value -> ListT STM (key, value)
Map.listT (forall s. TinyLRUCache s -> Map Text (TVar (LRUNode s))
lruCache TinyLRUCache s
cache)
  [Text]
expired <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\[Text]
acc (Text
k, TVar (LRUNode s)
nodeRef) -> do
                      LRUNode s
node <- forall a. TVar a -> STM a
readTVar TVar (LRUNode s)
nodeRef
                      if forall s. TimeSpec -> LRUNode s -> Bool
isExpired TimeSpec
now LRUNode s
node then forall (m :: * -> *) a. Monad m => a -> m a
return (Text
kforall a. a -> [a] -> [a]
:[Text]
acc) else forall (m :: * -> *) a. Monad m => a -> m a
return [Text]
acc
                   ) [] [(Text, TVar (LRUNode s))]
pairs
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
expired forall a b. (a -> b) -> a -> b
$ \Text
k -> forall s. Text -> TinyLRUCache s -> STM ()
deleteKey Text
k TinyLRUCache s
cache

-- | Accesses a cache entry. This is the primary "get-or-insert" function.
--
-- The logic is as follows:
--
-- 1.  It first cleans up any expired items in the cache.
-- 2.  It looks for the key.
-- 3.  If the key exists and is not expired, it moves the item to the front (as it's now
--     the most recently used) and returns its value wrapped in 'Just'.
-- 4.  If the key does not exist, or if it exists but has expired, it inserts the
--     provided new value. If the cache is full, it evicts the least recently used
--     item before insertion. It then returns the new value wrapped in 'Just'.
-- 5.  If the key is invalid (empty or too long), it returns 'Nothing'.
--
-- @param now The current 'TimeSpec', for expiry checks.
-- @param key The key to look up. Length must be between 1 and 256.
-- @param val The value to insert if the key is not found. It must have 'ToJSON' and 'FromJSON' instances.
-- @param ttl The time-to-live in seconds for the new entry if it's inserted.
-- @param cache The 'TinyLRUCache' instance.
-- @return An 'STM' action that yields 'Just' the value (either existing or newly inserted), or 'Nothing' if the key is invalid.
access :: forall a s. (FromJSON a, ToJSON a) => TimeSpec -> Text -> a -> Int -> TinyLRUCache s -> STM (Maybe a)
access :: forall a s.
(FromJSON a, ToJSON a) =>
TimeSpec -> Text -> a -> Int -> TinyLRUCache s -> STM (Maybe a)
access TimeSpec
now Text
key a
val Int
ttl TinyLRUCache s
cache
  | Text -> Bool
T.null Text
key Bool -> Bool -> Bool
|| Text -> Int
T.length Text
key forall a. Ord a => a -> a -> Bool
> Int
256 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  | Bool
otherwise = do
      forall s. TimeSpec -> TinyLRUCache s -> STM ()
cleanupExpired TimeSpec
now TinyLRUCache s
cache
      Maybe (TVar (LRUNode s))
mNodeTVar <- forall key value.
Hashable key =>
key -> Map key value -> STM (Maybe value)
Map.lookup Text
key (forall s. TinyLRUCache s -> Map Text (TVar (LRUNode s))
lruCache TinyLRUCache s
cache)
      case Maybe (TVar (LRUNode s))
mNodeTVar of
        Just TVar (LRUNode s)
nodeTVar -> do
          -- Key exists - check if expired
          LRUNode s
node <- forall a. TVar a -> STM a
readTVar TVar (LRUNode s)
nodeTVar
          if forall s. TimeSpec -> LRUNode s -> Bool
isExpired TimeSpec
now LRUNode s
node then do
            -- Expired: delete and re-insert with new value
            forall s. Text -> TinyLRUCache s -> STM ()
deleteKey Text
key TinyLRUCache s
cache
            STM (Maybe a)
insertNew
          else do
            -- Not expired: move to front and return existing value (cache hit)
            forall s. TVar (LRUList s) -> TVar (LRUNode s) -> STM ()
moveToFront (forall s. TinyLRUCache s -> TVar (LRUList s)
lruList TinyLRUCache s
cache) TVar (LRUNode s)
nodeTVar
            case forall a. FromJSON a => ByteString -> Maybe a
decodeStrict (forall s. LRUNode s -> ByteString
nodeValue LRUNode s
node) :: Maybe a of
              Just a
existingVal -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
existingVal)
              Maybe a
Nothing -> do
                -- Corrupt data, replace it
                forall s. Text -> TinyLRUCache s -> STM ()
deleteKey Text
key TinyLRUCache s
cache
                STM (Maybe a)
insertNew
        Maybe (TVar (LRUNode s))
Nothing -> STM (Maybe a)
insertNew
  where
    insertNew :: STM (Maybe a)
insertNew = do
      Int
sz <- forall key value. Map key value -> STM Int
Map.size (forall s. TinyLRUCache s -> Map Text (TVar (LRUNode s))
lruCache TinyLRUCache s
cache)
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
sz forall a. Ord a => a -> a -> Bool
>= forall s. TinyLRUCache s -> Int
lruCap TinyLRUCache s
cache) forall a b. (a -> b) -> a -> b
$ forall s. TinyLRUCache s -> STM ()
evictLRU TinyLRUCache s
cache
      TVar (LRUNode s)
nodeTVar <- forall s.
TimeSpec
-> Int
-> TinyLRUCache s
-> Text
-> ByteString
-> STM (TVar (LRUNode s))
addToFront TimeSpec
now Int
ttl TinyLRUCache s
cache Text
key (ByteString -> ByteString
BL.toStrict (forall a. ToJSON a => a -> ByteString
encode a
val))
      forall key value.
Hashable key =>
value -> key -> Map key value -> STM ()
Map.insert TVar (LRUNode s)
nodeTVar Text
key (forall s. TinyLRUCache s -> Map Text (TVar (LRUNode s))
lruCache TinyLRUCache s
cache)
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
val)

-- | Updates or inserts a cache entry. This is the primary "write" or "upsert" function.
--
-- The logic is as follows:
--
-- 1.  It first cleans up any expired items in the cache.
-- 2.  It looks for the key.
-- 3.  If the key exists, it updates the value and expiry time, and moves it to the front.
-- 4.  If the key does not exist, it inserts the new value. If the cache is full, it
--     evicts the least recently used item first.
-- 5.  If the key is invalid (empty or too long), it returns 'Nothing'.
--
-- Unlike 'access', this function /always/ writes the provided value.
--
-- @param now The current 'TimeSpec', for expiry calculations.
-- @param key The key to update or insert. Length must be between 1 and 256.
-- @param val The new value to write. It must have 'ToJSON' and 'FromJSON' instances.
-- @param ttl The new time-to-live in seconds for the entry.
-- @param cache The 'TinyLRUCache' instance.
-- @return An 'STM' action that yields 'Just' the value that was written, or 'Nothing' if the key is invalid.
updateValue :: forall a s. (FromJSON a, ToJSON a) => TimeSpec -> Text -> a -> Int -> TinyLRUCache s -> STM (Maybe a)
updateValue :: forall a s.
(FromJSON a, ToJSON a) =>
TimeSpec -> Text -> a -> Int -> TinyLRUCache s -> STM (Maybe a)
updateValue TimeSpec
now Text
key a
val Int
ttl TinyLRUCache s
cache
  | Text -> Bool
T.null Text
key Bool -> Bool -> Bool
|| Text -> Int
T.length Text
key forall a. Ord a => a -> a -> Bool
> Int
256 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  | Bool
otherwise = do
      forall s. TimeSpec -> TinyLRUCache s -> STM ()
cleanupExpired TimeSpec
now TinyLRUCache s
cache
      Maybe (TVar (LRUNode s))
mNodeTVar <- forall key value.
Hashable key =>
key -> Map key value -> STM (Maybe value)
Map.lookup Text
key (forall s. TinyLRUCache s -> Map Text (TVar (LRUNode s))
lruCache TinyLRUCache s
cache)
      case Maybe (TVar (LRUNode s))
mNodeTVar of
        Just TVar (LRUNode s)
nodeTVar -> do
          -- Key exists - update the value regardless of expiration
          LRUNode s
node <- forall a. TVar a -> STM a
readTVar TVar (LRUNode s)
nodeTVar
          let newExpiry :: Maybe TimeSpec
newExpiry = TimeSpec -> Int -> Maybe TimeSpec
mkExpiry TimeSpec
now Int
ttl
          forall a. TVar a -> a -> STM ()
writeTVar TVar (LRUNode s)
nodeTVar LRUNode s
node { 
            nodeValue :: ByteString
nodeValue = ByteString -> ByteString
BL.toStrict (forall a. ToJSON a => a -> ByteString
encode a
val),
            nodeExpiry :: Maybe TimeSpec
nodeExpiry = Maybe TimeSpec
newExpiry
          }
          forall s. TVar (LRUList s) -> TVar (LRUNode s) -> STM ()
moveToFront (forall s. TinyLRUCache s -> TVar (LRUList s)
lruList TinyLRUCache s
cache) TVar (LRUNode s)
nodeTVar
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
val)
        Maybe (TVar (LRUNode s))
Nothing -> do
          -- Key doesn't exist - insert new
          Int
sz <- forall key value. Map key value -> STM Int
Map.size (forall s. TinyLRUCache s -> Map Text (TVar (LRUNode s))
lruCache TinyLRUCache s
cache)
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
sz forall a. Ord a => a -> a -> Bool
>= forall s. TinyLRUCache s -> Int
lruCap TinyLRUCache s
cache) forall a b. (a -> b) -> a -> b
$ forall s. TinyLRUCache s -> STM ()
evictLRU TinyLRUCache s
cache
          TVar (LRUNode s)
nodeTVar <- forall s.
TimeSpec
-> Int
-> TinyLRUCache s
-> Text
-> ByteString
-> STM (TVar (LRUNode s))
addToFront TimeSpec
now Int
ttl TinyLRUCache s
cache Text
key (ByteString -> ByteString
BL.toStrict (forall a. ToJSON a => a -> ByteString
encode a
val))
          forall key value.
Hashable key =>
value -> key -> Map key value -> STM ()
Map.insert TVar (LRUNode s)
nodeTVar Text
key (forall s. TinyLRUCache s -> Map Text (TVar (LRUNode s))
lruCache TinyLRUCache s
cache)
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
val)

-- | Resets the cache, removing all entries.
--
-- @param cache The 'TinyLRUCache' to reset.
resetTinyLRU :: TinyLRUCache s -> STM ()
resetTinyLRU :: forall s. TinyLRUCache s -> STM ()
resetTinyLRU TinyLRUCache s
cache = do
  forall key value. Map key value -> STM ()
Map.reset (forall s. TinyLRUCache s -> Map Text (TVar (LRUNode s))
lruCache TinyLRUCache s
cache)
  forall a. TVar a -> a -> STM ()
writeTVar (forall s. TinyLRUCache s -> TVar (LRUList s)
lruList TinyLRUCache s
cache) forall a b. (a -> b) -> a -> b
$ forall s.
Maybe (TVar (LRUNode s)) -> Maybe (TVar (LRUNode s)) -> LRUList s
LRUList forall a. Maybe a
Nothing forall a. Maybe a
Nothing

-- | A specialized function for rate limiting. It uses the cache to track the number
-- of requests for a given key within a specific time period.
--
-- The logic is as follows:
--
-- 1.  It looks for the key. The value associated with the key is treated as a counter ('Int').
-- 2.  If the entry for the key exists and is not expired:
--     *   If the counter is less than the 'limit', it increments the counter,
--         refreshes the expiry time, and returns 'True' (request allowed).
--     *   If the counter has reached the 'limit', it does nothing and returns 'False' (request denied).
-- 3.  If the entry does not exist or has expired, it creates a new entry with the
--     counter set to 1 and returns 'True'.
--
-- @param now The current 'TimeSpec'.
-- @param cache The 'TinyLRUCache' instance.
-- @param key The key to identify the entity being rate-limited (e.g., a user ID or IP address).
-- @param limit The maximum number of requests allowed.
-- @param period The time period in seconds for the rate limit window.
-- @return An 'STM' action yielding 'True' if the request is allowed, 'False' otherwise.
allowRequestTinyLRU :: TimeSpec -> TinyLRUCache s -> Text -> Int -> Int -> STM Bool
allowRequestTinyLRU :: forall s.
TimeSpec -> TinyLRUCache s -> Text -> Int -> Int -> STM Bool
allowRequestTinyLRU TimeSpec
now TinyLRUCache s
cache Text
key Int
limit Int
period
  | Text -> Bool
T.null Text
key = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  | Bool
otherwise = do
      forall s. TimeSpec -> TinyLRUCache s -> STM ()
cleanupExpired TimeSpec
now TinyLRUCache s
cache
      Maybe (TVar (LRUNode s))
mNodeTVar <- forall key value.
Hashable key =>
key -> Map key value -> STM (Maybe value)
Map.lookup Text
key (forall s. TinyLRUCache s -> Map Text (TVar (LRUNode s))
lruCache TinyLRUCache s
cache)
      case Maybe (TVar (LRUNode s))
mNodeTVar of
        Just TVar (LRUNode s)
nodeTVar -> do
          LRUNode s
node <- forall a. TVar a -> STM a
readTVar TVar (LRUNode s)
nodeTVar
          if forall s. TimeSpec -> LRUNode s -> Bool
isExpired TimeSpec
now LRUNode s
node then do
            -- Expired: delete old entry and create new one
            forall s. Text -> TinyLRUCache s -> STM ()
deleteKey Text
key TinyLRUCache s
cache
            STM Bool
insertNew
          else do
            -- Not expired: check and update count
            case forall a. FromJSON a => ByteString -> Maybe a
decodeStrict (forall s. LRUNode s -> ByteString
nodeValue LRUNode s
node) :: Maybe Int of
              Just Int
n
                | Int
n forall a. Ord a => a -> a -> Bool
< Int
limit -> do
                    -- Update the value and refresh expiry time
                    let newExpiry :: Maybe TimeSpec
newExpiry = TimeSpec -> Int -> Maybe TimeSpec
mkExpiry TimeSpec
now Int
period
                    forall a. TVar a -> a -> STM ()
writeTVar TVar (LRUNode s)
nodeTVar LRUNode s
node { 
                      nodeValue :: ByteString
nodeValue = ByteString -> ByteString
BL.toStrict (forall a. ToJSON a => a -> ByteString
encode (Int
nforall a. Num a => a -> a -> a
+Int
1)),
                      nodeExpiry :: Maybe TimeSpec
nodeExpiry = Maybe TimeSpec
newExpiry
                    }
                    forall s. TVar (LRUList s) -> TVar (LRUNode s) -> STM ()
moveToFront (forall s. TinyLRUCache s -> TVar (LRUList s)
lruList TinyLRUCache s
cache) TVar (LRUNode s)
nodeTVar
                    forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                | Bool
otherwise -> do
                    forall s. TVar (LRUList s) -> TVar (LRUNode s) -> STM ()
moveToFront (forall s. TinyLRUCache s -> TVar (LRUList s)
lruList TinyLRUCache s
cache) TVar (LRUNode s)
nodeTVar
                    forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False -- Over limit
              Maybe Int
_ -> do
                -- Corrupt data, reset it
                forall s. Text -> TinyLRUCache s -> STM ()
deleteKey Text
key TinyLRUCache s
cache
                STM Bool
insertNew
        Maybe (TVar (LRUNode s))
Nothing -> STM Bool
insertNew
  where
    insertNew :: STM Bool
insertNew = do
      Int
sz <- forall key value. Map key value -> STM Int
Map.size (forall s. TinyLRUCache s -> Map Text (TVar (LRUNode s))
lruCache TinyLRUCache s
cache)
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
sz forall a. Ord a => a -> a -> Bool
>= forall s. TinyLRUCache s -> Int
lruCap TinyLRUCache s
cache) forall a b. (a -> b) -> a -> b
$ forall s. TinyLRUCache s -> STM ()
evictLRU TinyLRUCache s
cache
      TVar (LRUNode s)
nodeTVar <- forall s.
TimeSpec
-> Int
-> TinyLRUCache s
-> Text
-> ByteString
-> STM (TVar (LRUNode s))
addToFront TimeSpec
now Int
period TinyLRUCache s
cache Text
key (ByteString -> ByteString
BL.toStrict (forall a. ToJSON a => a -> ByteString
encode (Int
1 :: Int)))
      forall key value.
Hashable key =>
value -> key -> Map key value -> STM ()
Map.insert TVar (LRUNode s)
nodeTVar Text
key (forall s. TinyLRUCache s -> Map Text (TVar (LRUNode s))
lruCache TinyLRUCache s
cache)
      forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- | Low-level function to remove a node from the cache's list.
-- Alias for 'removeNode'. Most users should use 'deleteKey' instead.
--
-- @param cache The 'TinyLRUCache' instance.
-- @param nodeTVar The 'TVar' of the 'LRUNode' to remove.
removeNodeFromCache :: TinyLRUCache s -> TVar (LRUNode s) -> STM ()
removeNodeFromCache :: forall s. TinyLRUCache s -> TVar (LRUNode s) -> STM ()
removeNodeFromCache TinyLRUCache s
cache = forall s. TVar (LRUList s) -> TVar (LRUNode s) -> STM ()
removeNode (forall s. TinyLRUCache s -> TVar (LRUList s)
lruList TinyLRUCache s
cache)

-- | Low-level function to move a node to the front of the cache's list.
-- Alias for 'moveToFront'. Most users should use 'access' or 'updateValue' which
-- call this internally.
--
-- @param cache The 'TinyLRUCache' instance.
-- @param nodeTVar The 'TVar' of the 'LRUNode' to move.
moveToFrontInCache :: TinyLRUCache s -> TVar (LRUNode s) -> STM ()
moveToFrontInCache :: forall s. TinyLRUCache s -> TVar (LRUNode s) -> STM ()
moveToFrontInCache TinyLRUCache s
cache = forall s. TVar (LRUList s) -> TVar (LRUNode s) -> STM ()
moveToFront (forall s. TinyLRUCache s -> TVar (LRUList s)
lruList TinyLRUCache s
cache)