module Data.Cache.Vault
( Cache, newCache
, Key, mintLabeledKey, mintUniqKey
, insert, delete, reset, lookup
)
where
import Control.Concurrent.STM (atomically)
import Data.IORef
import Data.Time
import Data.Typeable
import GHC.Exts
import GHC.Fingerprint
import Prelude hiding (lookup)
import System.IO.Unsafe (unsafePerformIO)
import Unsafe.Coerce (unsafeCoerce)
import qualified Data.Text as T
import qualified StmContainers.Map as M
type KeyRepr = T.Text
data CacheEntry
= CacheEntry
{ CacheEntry -> Maybe UTCTime
ceValidUntil :: Maybe UTCTime
, CacheEntry -> Any
ceValue :: Any
}
newtype Cache
= Cache { Cache -> Map KeyRepr CacheEntry
_unCache :: M.Map KeyRepr CacheEntry }
newtype Key a
= Key { Key a -> KeyRepr
unKey :: KeyRepr }
deriving (Int -> Key a -> ShowS
[Key a] -> ShowS
Key a -> String
(Int -> Key a -> ShowS)
-> (Key a -> String) -> ([Key a] -> ShowS) -> Show (Key a)
forall a. Int -> Key a -> ShowS
forall a. [Key a] -> ShowS
forall a. Key a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Key a] -> ShowS
$cshowList :: forall a. [Key a] -> ShowS
show :: Key a -> String
$cshow :: forall a. Key a -> String
showsPrec :: Int -> Key a -> ShowS
$cshowsPrec :: forall a. Int -> Key a -> ShowS
Show, Key a -> Key a -> Bool
(Key a -> Key a -> Bool) -> (Key a -> Key a -> Bool) -> Eq (Key a)
forall a. Key a -> Key a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Key a -> Key a -> Bool
$c/= :: forall a. Key a -> Key a -> Bool
== :: Key a -> Key a -> Bool
$c== :: forall a. Key a -> Key a -> Bool
Eq)
keyCounter :: IORef Int
keyCounter :: IORef Int
keyCounter =
IO (IORef Int) -> IORef Int
forall a. IO a -> a
unsafePerformIO (IO (IORef Int) -> IORef Int) -> IO (IORef Int) -> IORef Int
forall a b. (a -> b) -> a -> b
$ Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
{-# NOINLINE keyCounter #-}
mintUniqKey :: IO (Key a)
mintUniqKey :: IO (Key a)
mintUniqKey =
IORef Int -> (Int -> (Int, Key a)) -> IO (Key a)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
keyCounter ((Int -> (Int, Key a)) -> IO (Key a))
-> (Int -> (Int, Key a)) -> IO (Key a)
forall a b. (a -> b) -> a -> b
$ \Int
ctr ->
( Int
ctr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
, KeyRepr -> Key a
forall a. KeyRepr -> Key a
Key (KeyRepr -> Key a) -> KeyRepr -> Key a
forall a b. (a -> b) -> a -> b
$ KeyRepr
"uniq/" KeyRepr -> KeyRepr -> KeyRepr
forall a. Semigroup a => a -> a -> a
<> String -> KeyRepr
T.pack (Int -> String
forall a. Show a => a -> String
show Int
ctr)
)
mintLabeledKey :: forall a. Typeable a => T.Text -> Key a
mintLabeledKey :: KeyRepr -> Key a
mintLabeledKey KeyRepr
label =
KeyRepr -> Key a
forall a. KeyRepr -> Key a
Key (KeyRepr -> Key a) -> KeyRepr -> Key a
forall a b. (a -> b) -> a -> b
$ KeyRepr
"label/" KeyRepr -> KeyRepr -> KeyRepr
forall a. Semigroup a => a -> a -> a
<> KeyRepr
label KeyRepr -> KeyRepr -> KeyRepr
forall a. Semigroup a => a -> a -> a
<> KeyRepr
"/" KeyRepr -> KeyRepr -> KeyRepr
forall a. Semigroup a => a -> a -> a
<> KeyRepr
typeSig
where
typeSig :: KeyRepr
typeSig =
let (Fingerprint Word64
x1 Word64
x2) =
TypeRep -> Fingerprint
typeRepFingerprint (Proxy (Proxy a) -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy (Proxy a)
forall k (t :: k). Proxy t
Proxy :: Proxy (Proxy a)))
in String -> KeyRepr
T.pack (String -> KeyRepr) -> String -> KeyRepr
forall a b. (a -> b) -> a -> b
$ Word64 -> String
forall a. Show a => a -> String
show Word64
x1 String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"." String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a. Show a => a -> String
show Word64
x2
newCache :: IO Cache
newCache :: IO Cache
newCache =
Map KeyRepr CacheEntry -> Cache
Cache (Map KeyRepr CacheEntry -> Cache)
-> IO (Map KeyRepr CacheEntry) -> IO Cache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map KeyRepr CacheEntry)
forall key value. IO (Map key value)
M.newIO
insert :: Key a -> Maybe UTCTime -> a -> Cache -> IO ()
insert :: Key a -> Maybe UTCTime -> a -> Cache -> IO ()
insert Key a
k Maybe UTCTime
t a
v (Cache Map KeyRepr CacheEntry
ref) =
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ CacheEntry -> KeyRepr -> Map KeyRepr CacheEntry -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert CacheEntry
val KeyRepr
key Map KeyRepr CacheEntry
ref
where
val :: CacheEntry
val =
CacheEntry :: Maybe UTCTime -> Any -> CacheEntry
CacheEntry
{ ceValidUntil :: Maybe UTCTime
ceValidUntil = Maybe UTCTime
t
, ceValue :: Any
ceValue = a -> Any
forall a b. a -> b
unsafeCoerce a
v
}
key :: KeyRepr
key = Key a -> KeyRepr
forall a. Key a -> KeyRepr
unKey Key a
k
delete :: Key a -> Cache -> IO ()
delete :: Key a -> Cache -> IO ()
delete Key a
k (Cache Map KeyRepr CacheEntry
ref) =
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ KeyRepr -> Map KeyRepr CacheEntry -> STM ()
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM ()
M.delete (Key a -> KeyRepr
forall a. Key a -> KeyRepr
unKey Key a
k) Map KeyRepr CacheEntry
ref
reset :: Cache -> IO ()
reset :: Cache -> IO ()
reset (Cache Map KeyRepr CacheEntry
ref) =
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Map KeyRepr CacheEntry -> STM ()
forall key value. Map key value -> STM ()
M.reset Map KeyRepr CacheEntry
ref
lookup :: UTCTime -> Key a -> Cache -> IO (Maybe a)
lookup :: UTCTime -> Key a -> Cache -> IO (Maybe a)
lookup UTCTime
now Key a
k (Cache Map KeyRepr CacheEntry
ref) =
do Maybe CacheEntry
entry <-
STM (Maybe CacheEntry) -> IO (Maybe CacheEntry)
forall a. STM a -> IO a
atomically (STM (Maybe CacheEntry) -> IO (Maybe CacheEntry))
-> STM (Maybe CacheEntry) -> IO (Maybe CacheEntry)
forall a b. (a -> b) -> a -> b
$ KeyRepr -> Map KeyRepr CacheEntry -> STM (Maybe CacheEntry)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
M.lookup (Key a -> KeyRepr
forall a. Key a -> KeyRepr
unKey Key a
k) Map KeyRepr CacheEntry
ref
case Maybe CacheEntry
entry of
Maybe CacheEntry
Nothing -> Maybe a -> IO (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
Just CacheEntry
e ->
case CacheEntry -> Maybe UTCTime
ceValidUntil CacheEntry
e of
Just UTCTime
validUntil | UTCTime
validUntil UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
now -> Maybe a -> IO (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
Maybe UTCTime
_ -> Maybe a -> IO (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Any -> a
forall a b. a -> b
unsafeCoerce (CacheEntry -> Any
ceValue CacheEntry
e))