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 #-}

-- | Mint a globally unique key
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)
  )

-- | Mint a key with a label for a given type. Note that keys
-- with the same label but for different types are different.
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

-- | Create a new cache container.
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 a value into the cache with an optional expiry date.
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 a value from the cache.
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

-- | Purge all values form the cache.
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

-- | Given the current time, lookup a key in the cache.
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))