chore: move executable code to src/
src/ now contains all source code - in subdirectories, according to the .cabal component they belong to. This will allow us to put vendored libraries in the same place - and later split our own code into multiple components/libraries as well.
This commit is contained in:
Wolfgang Walther
@@ -0,0 +1,218 @@
|
||||
{-|
|
||||
Module : PostgREST.Cache.Sieve
|
||||
Description : PostgREST cache implementation based on Sieve algorithm.
|
||||
|
||||
This module provides implementation of a mutable cache on Sieve algorithm.
|
||||
-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module PostgREST.Cache.Sieve (
|
||||
Cache
|
||||
, CacheConfig (..)
|
||||
, Discard (..)
|
||||
, alwaysValid
|
||||
, cache
|
||||
, cacheIO
|
||||
, cached
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad.Extra (whileM)
|
||||
import Data.Some
|
||||
import qualified Focus as F
|
||||
import Protolude hiding (elem, head)
|
||||
import qualified StmHamt.SizedHamt as SH
|
||||
|
||||
data ListNode k v (b :: Bool) = ListNode {
|
||||
nextPtr :: NodePtr k v,
|
||||
prevNextPtrPtr :: NodePtrPtr k v,
|
||||
elem :: NodeElem k v b
|
||||
}
|
||||
|
||||
data NodeElem :: Type -> Type -> Bool -> Type where
|
||||
Head :: {
|
||||
entries :: SH.SizedHamt (HamtEntry k v),
|
||||
finger :: NodePtrPtr k v
|
||||
} -> NodeElem k v False
|
||||
Entry :: Hashable k => {
|
||||
visited :: TVar Bool,
|
||||
ekey :: k,
|
||||
entryValue :: v
|
||||
} -> NodeElem k v True
|
||||
|
||||
type HamtEntry k v = ListNode k v True
|
||||
type AnyNode k v = Some (ListNode k v)
|
||||
type NodePtr k v = TVar (AnyNode k v)
|
||||
type NodePtrPtr k v = TVar (NodePtr k v)
|
||||
|
||||
data Discard m v = Refresh (m ()) | Invalid (m v)
|
||||
|
||||
data Cache m k v = (MonadIO m, Hashable k) => Cache (ListNode k v False) (CacheConfig m k v)
|
||||
|
||||
data CacheConfig m k v = CacheConfig {
|
||||
maxSize :: STM Int,
|
||||
load :: k -> m v,
|
||||
requestListener :: Bool -> m (),
|
||||
evictionListener :: k -> v -> m (),
|
||||
validator :: m (k -> v -> Maybe (Discard m v))
|
||||
}
|
||||
|
||||
alwaysValid :: Applicative m => m (k -> v -> Maybe (Discard m v))
|
||||
alwaysValid = pure (const . const Nothing)
|
||||
|
||||
cacheIO :: (MonadIO m, Hashable k) => CacheConfig m k v -> IO (Cache m k v)
|
||||
cacheIO = atomically . cache
|
||||
|
||||
cache :: (MonadIO m, Hashable k) => CacheConfig m k v -> STM (Cache m k v)
|
||||
cache cacheConfig = mdo
|
||||
tail <- newTVar (Some head)
|
||||
entries <- SH.new
|
||||
finger <- newTVar tail
|
||||
head <- ListNode tail <$> newTVar tail <*> pure Head {..}
|
||||
pure $ Cache head cacheConfig
|
||||
|
||||
cached :: Cache m k v -> k -> m v
|
||||
cached (Cache head@ListNode{prevNextPtrPtr=neck, elem=Head{..}} CacheConfig{..}) k = do
|
||||
checkValid <- validator
|
||||
tryMaybe
|
||||
-- Fast path: lookup value, update stats and return the value if found and valid
|
||||
((liftIO . atomically) (lookup checkValid) >>= notify (requestListener . isJust) >>= validate)
|
||||
-- Slow path: load/calculate value and insert it (if still not found)
|
||||
(do
|
||||
value <- load k
|
||||
whileM (not <$> tryInsert value)
|
||||
pure value)
|
||||
where
|
||||
tryMaybe f notFound = f >>= maybe notFound pure
|
||||
|
||||
notify = ((<$) <*>)
|
||||
|
||||
validate = fmap join . traverse (\case
|
||||
-- valid value
|
||||
(Right v) -> pure $ Just v
|
||||
-- refresh value
|
||||
(Left (Refresh act)) -> act $> Nothing
|
||||
-- discard value and return alt result
|
||||
(Left (Invalid res)) -> Just <$> res)
|
||||
|
||||
lookup checkValid = SH.focus focus (ekey . elem) k entries
|
||||
where
|
||||
focus = F.Focus
|
||||
-- not found
|
||||
(pure (Nothing, F.Leave))
|
||||
-- found
|
||||
-- check entry validity
|
||||
(\e@ListNode{elem=Entry{visited, entryValue}} ->
|
||||
maybe
|
||||
-- entry valid
|
||||
(mark visited True $> (Just $ Right entryValue, F.Leave))
|
||||
-- entry invalid
|
||||
-- remove it
|
||||
((removeEntry e $>) . (, F.Remove) . Just . Left)
|
||||
(checkValid k entryValue)
|
||||
)
|
||||
|
||||
mark t b = whenM ((/= b) <$> readTVar t) (writeTVar t b)
|
||||
|
||||
-- perform a single entry eviction and possibly insertion atomically
|
||||
-- returning False if could not insert
|
||||
-- (either because entry currently pointed by the finger was visited
|
||||
-- or because after this entry eviction the cache is still full)
|
||||
-- so that other threads don't have to wait when visiting entries.
|
||||
-- First check if entry is still not in the cache - this time inside transaction.
|
||||
--
|
||||
-- Execute evictionListener if an entry was evicted
|
||||
tryInsert value = do
|
||||
(result, evicted) <- liftIO . atomically $ do
|
||||
-- Use SH.focus to performa a single lookup instead of 2
|
||||
-- we cannot modify Hamt from inside focus
|
||||
-- so if there is any entry to remove
|
||||
-- we need to delete it after
|
||||
(res, evictedKey) <- SH.focus focus (ekey . elem) k entries
|
||||
case evictedKey of
|
||||
(Just Entry{ekey=entryKey, entryValue}) -> do
|
||||
SH.focus F.delete (ekey . elem) entryKey entries
|
||||
pure (res, evictionListener entryKey entryValue)
|
||||
Nothing -> pure (res, pure ())
|
||||
|
||||
evicted $> result
|
||||
where
|
||||
focus = F.Focus (do
|
||||
(hasSpace, evictedKey) <- evictionStep
|
||||
if hasSpace then do
|
||||
entry <- newLinkedEntry value
|
||||
-- done, maybe evicted, insert entry
|
||||
pure ((True, evictedKey), F.Set entry)
|
||||
else
|
||||
-- not done, maybe evicted, don't modify entries
|
||||
pure ((False, evictedKey), F.Leave))
|
||||
-- Entry found case
|
||||
(\ListNode{elem=Entry{visited}} -> do
|
||||
-- mark as visited
|
||||
mark visited True
|
||||
-- done, no evictions, don't modify entries
|
||||
pure ((True, Nothing), F.Leave))
|
||||
|
||||
-- if the cache is full precoesses a single node
|
||||
-- removing it if it is marked as unvisited
|
||||
-- or clearing visited mark
|
||||
-- returns True if there is space in the cache
|
||||
-- puts evictionListener in state if an entry was evicted
|
||||
evictionStep = do
|
||||
currDiff <- liftA2 (-) (SH.size entries) (max 1 <$> maxSize)
|
||||
if currDiff >= 0 then do
|
||||
-- no space in the cache
|
||||
-- need to evict an entry
|
||||
(nextFinger, evictedKey) <- readTVar finger >>= evict
|
||||
writeTVar finger nextFinger
|
||||
-- return if enough space and evicted key if any
|
||||
pure (isJust evictedKey && currDiff == 0, evictedKey)
|
||||
else
|
||||
-- there is space in the cache
|
||||
pure (True, Nothing)
|
||||
|
||||
evict :: TVar (Some (ListNode k v)) -> STM (NodePtr k v, Maybe (NodeElem k v True))
|
||||
evict = readTVar >=> \case
|
||||
(Some e@ListNode{nextPtr, prevNextPtrPtr, elem=elem@Entry{visited}}) -> do
|
||||
ifM (readTVar visited)
|
||||
|
||||
(writeTVar visited False $> (nextPtr, Nothing))
|
||||
|
||||
(unlinkEntry e *> fmap (, Just elem) (readTVar prevNextPtrPtr))
|
||||
-- skip head
|
||||
(Some ListNode{nextPtr, elem=Head{}}) -> evict nextPtr
|
||||
|
||||
unlinkEntry :: HamtEntry k v -> STM ()
|
||||
unlinkEntry (ListNode{nextPtr, prevNextPtrPtr=currPrev}) = do
|
||||
nextEntry <- readTVar nextPtr
|
||||
withSome nextEntry $ \e -> do
|
||||
prevNextPtr <- readTVar currPrev
|
||||
writeTVar (prevNextPtrPtr e) prevNextPtr
|
||||
writeTVar prevNextPtr nextEntry
|
||||
|
||||
newLinkedEntry v = do
|
||||
oldNeckNextPtr <- readTVar neck
|
||||
newNeckNextPtr <- newTVar (Some head)
|
||||
newNeck <- ListNode newNeckNextPtr <$>
|
||||
newTVar oldNeckNextPtr <*>
|
||||
(Entry <$> newTVar False <*> pure k <*> pure v)
|
||||
-- update pointers
|
||||
writeTVar oldNeckNextPtr (Some newNeck)
|
||||
writeTVar neck newNeckNextPtr
|
||||
-- return HAMT entry
|
||||
pure newNeck
|
||||
|
||||
removeEntry = fmap (*>) unlinkEntry <*> adjustFinger
|
||||
|
||||
adjustFinger ListNode{nextPtr, prevNextPtrPtr} =
|
||||
whenM ((nextPtr ==) <$> readTVar finger) $
|
||||
readTVar prevNextPtrPtr >>= writeTVar finger
|
||||
Reference in New Issue
Block a user