------------------------------------------------------------------------
-- |
-- Module      :  ALife.Creatur.Database.CachedFileSystemInternal
-- Copyright   :  (c) 2014-2021 Amy de Buitléir
-- License     :  BSD-style
-- Maintainer  :  amy@nualeargais.ie
-- Stability   :  experimental
-- Portability :  portable
--
-- A module containing private CachedFileSystem internals.
-- Most developers should use CachedFileSystem instead.
-- This module is subject to change without notice.
--
------------------------------------------------------------------------
{-# LANGUAGE TypeFamilies, FlexibleContexts, ScopedTypeVariables #-}
module ALife.Creatur.Database.CachedFileSystemInternal where

import Prelude hiding (readFile, writeFile, lookup)

import ALife.Creatur.Database (Database(..), DBRecord, Record,
  SizedRecord, delete, key, keys, store, size)
import qualified ALife.Creatur.Database.FileSystem as FS
import ALife.Creatur.Util (stateMap)
import Control.Monad (when)
import Control.Monad.State (StateT, get, gets, modify)

-- | A simple database where each record is stored in a separate file, 
--   and the name of the file is the record's key.
data CachedFSDatabase r = CachedFSDatabase
  {
    CachedFSDatabase r -> FSDatabase r
database :: FS.FSDatabase r,
    CachedFSDatabase r -> [r]
cache :: [r],
    CachedFSDatabase r -> Int
maxCacheSize :: Int
  } deriving (Int -> CachedFSDatabase r -> ShowS
[CachedFSDatabase r] -> ShowS
CachedFSDatabase r -> String
(Int -> CachedFSDatabase r -> ShowS)
-> (CachedFSDatabase r -> String)
-> ([CachedFSDatabase r] -> ShowS)
-> Show (CachedFSDatabase r)
forall r. Show r => Int -> CachedFSDatabase r -> ShowS
forall r. Show r => [CachedFSDatabase r] -> ShowS
forall r. Show r => CachedFSDatabase r -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CachedFSDatabase r] -> ShowS
$cshowList :: forall r. Show r => [CachedFSDatabase r] -> ShowS
show :: CachedFSDatabase r -> String
$cshow :: forall r. Show r => CachedFSDatabase r -> String
showsPrec :: Int -> CachedFSDatabase r -> ShowS
$cshowsPrec :: forall r. Show r => Int -> CachedFSDatabase r -> ShowS
Show, CachedFSDatabase r -> CachedFSDatabase r -> Bool
(CachedFSDatabase r -> CachedFSDatabase r -> Bool)
-> (CachedFSDatabase r -> CachedFSDatabase r -> Bool)
-> Eq (CachedFSDatabase r)
forall r. Eq r => CachedFSDatabase r -> CachedFSDatabase r -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CachedFSDatabase r -> CachedFSDatabase r -> Bool
$c/= :: forall r. Eq r => CachedFSDatabase r -> CachedFSDatabase r -> Bool
== :: CachedFSDatabase r -> CachedFSDatabase r -> Bool
$c== :: forall r. Eq r => CachedFSDatabase r -> CachedFSDatabase r -> Bool
Eq)

instance (SizedRecord r) => Database (CachedFSDatabase r) where
  type DBRecord (CachedFSDatabase r) = r

  keys :: StateT (CachedFSDatabase r) IO [String]
keys = StateT (FSDatabase r) IO [String]
-> StateT (CachedFSDatabase r) IO [String]
forall (m :: * -> *) r a.
Monad m =>
StateT (FSDatabase r) m a -> StateT (CachedFSDatabase r) m a
withFSDB StateT (FSDatabase r) IO [String]
forall d. Database d => StateT d IO [String]
keys

  numRecords :: StateT (CachedFSDatabase r) IO Int
numRecords = StateT (FSDatabase r) IO Int -> StateT (CachedFSDatabase r) IO Int
forall (m :: * -> *) r a.
Monad m =>
StateT (FSDatabase r) m a -> StateT (CachedFSDatabase r) m a
withFSDB StateT (FSDatabase r) IO Int
forall d. Database d => StateT d IO Int
numRecords
  
  archivedKeys :: StateT (CachedFSDatabase r) IO [String]
archivedKeys = StateT (FSDatabase r) IO [String]
-> StateT (CachedFSDatabase r) IO [String]
forall (m :: * -> *) r a.
Monad m =>
StateT (FSDatabase r) m a -> StateT (CachedFSDatabase r) m a
withFSDB StateT (FSDatabase r) IO [String]
forall d. Database d => StateT d IO [String]
archivedKeys

  lookup :: String
-> StateT
     (CachedFSDatabase r)
     IO
     (Either String (DBRecord (CachedFSDatabase r)))
lookup String
k = do
    Maybe r
x <- String -> StateT (CachedFSDatabase r) IO (Maybe r)
forall r.
Record r =>
String -> StateT (CachedFSDatabase r) IO (Maybe r)
fromCache String
k
    case Maybe r
x of
      Just r
r  -> Either String r -> StateT (CachedFSDatabase r) IO (Either String r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String r
 -> StateT (CachedFSDatabase r) IO (Either String r))
-> Either String r
-> StateT (CachedFSDatabase r) IO (Either String r)
forall a b. (a -> b) -> a -> b
$ r -> Either String r
forall a b. b -> Either a b
Right r
r
      Maybe r
Nothing -> do
        Either String r
y <- StateT (FSDatabase r) IO (Either String r)
-> StateT (CachedFSDatabase r) IO (Either String r)
forall (m :: * -> *) r a.
Monad m =>
StateT (FSDatabase r) m a -> StateT (CachedFSDatabase r) m a
withFSDB (String
-> StateT
     (FSDatabase r) IO (Either String (DBRecord (FSDatabase r)))
forall d.
(Database d, Serialize (DBRecord d)) =>
String -> StateT d IO (Either String (DBRecord d))
lookup String
k)
        case Either String r
y of
          Right r
r -> do
            r -> StateT (CachedFSDatabase r) IO ()
forall r. SizedRecord r => r -> StateT (CachedFSDatabase r) IO ()
addToCache r
r
            Either String r -> StateT (CachedFSDatabase r) IO (Either String r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String r
 -> StateT (CachedFSDatabase r) IO (Either String r))
-> Either String r
-> StateT (CachedFSDatabase r) IO (Either String r)
forall a b. (a -> b) -> a -> b
$ r -> Either String r
forall a b. b -> Either a b
Right r
r
          Left String
s  -> Either String r -> StateT (CachedFSDatabase r) IO (Either String r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String r
 -> StateT (CachedFSDatabase r) IO (Either String r))
-> Either String r
-> StateT (CachedFSDatabase r) IO (Either String r)
forall a b. (a -> b) -> a -> b
$ String -> Either String r
forall a b. a -> Either a b
Left String
s

  lookupInArchive :: String
-> StateT
     (CachedFSDatabase r)
     IO
     (Either String (DBRecord (CachedFSDatabase r)))
lookupInArchive String
k = StateT (FSDatabase r) IO (Either String r)
-> StateT (CachedFSDatabase r) IO (Either String r)
forall (m :: * -> *) r a.
Monad m =>
StateT (FSDatabase r) m a -> StateT (CachedFSDatabase r) m a
withFSDB (String
-> StateT
     (FSDatabase r) IO (Either String (DBRecord (FSDatabase r)))
forall d.
(Database d, Serialize (DBRecord d)) =>
String -> StateT d IO (Either String (DBRecord d))
lookupInArchive String
k)
  -- only the main dir is cached

  store :: DBRecord (CachedFSDatabase r) -> StateT (CachedFSDatabase r) IO ()
store DBRecord (CachedFSDatabase r)
r = do
    r -> StateT (CachedFSDatabase r) IO ()
forall r. SizedRecord r => r -> StateT (CachedFSDatabase r) IO ()
addToCache r
DBRecord (CachedFSDatabase r)
r
    StateT (FSDatabase r) IO () -> StateT (CachedFSDatabase r) IO ()
forall (m :: * -> *) r a.
Monad m =>
StateT (FSDatabase r) m a -> StateT (CachedFSDatabase r) m a
withFSDB (DBRecord (FSDatabase r) -> StateT (FSDatabase r) IO ()
forall d.
(Database d, Record (DBRecord d), Serialize (DBRecord d)) =>
DBRecord d -> StateT d IO ()
store DBRecord (FSDatabase r)
DBRecord (CachedFSDatabase r)
r :: StateT (FS.FSDatabase r) IO ())

  delete :: String -> StateT (CachedFSDatabase r) IO ()
delete String
k = do
    String -> StateT (CachedFSDatabase r) IO ()
forall r.
SizedRecord r =>
String -> StateT (CachedFSDatabase r) IO ()
deleteByKeyFromCache String
k
    StateT (FSDatabase r) IO () -> StateT (CachedFSDatabase r) IO ()
forall (m :: * -> *) r a.
Monad m =>
StateT (FSDatabase r) m a -> StateT (CachedFSDatabase r) m a
withFSDB (String -> StateT (FSDatabase r) IO ()
forall d.
(Database d, Serialize (DBRecord d)) =>
String -> StateT d IO ()
delete String
k)

withFSDB 
  :: Monad m
    => StateT (FS.FSDatabase r) m a -> StateT (CachedFSDatabase r) m a
withFSDB :: StateT (FSDatabase r) m a -> StateT (CachedFSDatabase r) m a
withFSDB StateT (FSDatabase r) m a
f = do
  CachedFSDatabase r
d <- StateT (CachedFSDatabase r) m (CachedFSDatabase r)
forall s (m :: * -> *). MonadState s m => m s
get
  (FSDatabase r -> CachedFSDatabase r)
-> (CachedFSDatabase r -> FSDatabase r)
-> StateT (FSDatabase r) m a
-> StateT (CachedFSDatabase r) m a
forall (m :: * -> *) s t a.
Monad m =>
(s -> t) -> (t -> s) -> StateT s m a -> StateT t m a
stateMap (\FSDatabase r
x -> CachedFSDatabase r
d{database :: FSDatabase r
database=FSDatabase r
x}) CachedFSDatabase r -> FSDatabase r
forall r. CachedFSDatabase r -> FSDatabase r
database StateT (FSDatabase r) m a
f

fromCache :: Record r => String -> StateT (CachedFSDatabase r) IO (Maybe r)
fromCache :: String -> StateT (CachedFSDatabase r) IO (Maybe r)
fromCache String
k = do
  [r]
c <- (CachedFSDatabase r -> [r]) -> StateT (CachedFSDatabase r) IO [r]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CachedFSDatabase r -> [r]
forall r. CachedFSDatabase r -> [r]
cache
  let rs :: [r]
rs = (r -> Bool) -> [r] -> [r]
forall a. (a -> Bool) -> [a] -> [a]
filter (\r
r -> r -> String
forall r. Record r => r -> String
key r
r String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k) [r]
c
  Maybe r -> StateT (CachedFSDatabase r) IO (Maybe r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe r -> StateT (CachedFSDatabase r) IO (Maybe r))
-> Maybe r -> StateT (CachedFSDatabase r) IO (Maybe r)
forall a b. (a -> b) -> a -> b
$ if [r] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [r]
rs
             then Maybe r
forall a. Maybe a
Nothing
             else r -> Maybe r
forall a. a -> Maybe a
Just ([r] -> r
forall a. [a] -> a
head [r]
rs)

addToCache :: SizedRecord r => r -> StateT (CachedFSDatabase r) IO ()
addToCache :: r -> StateT (CachedFSDatabase r) IO ()
addToCache r
r = do
  r -> StateT (CachedFSDatabase r) IO ()
forall r. SizedRecord r => r -> StateT (CachedFSDatabase r) IO ()
deleteFromCache r
r
  (CachedFSDatabase r -> CachedFSDatabase r)
-> StateT (CachedFSDatabase r) IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\CachedFSDatabase r
d -> CachedFSDatabase r
d {cache :: [r]
cache=r
rr -> [r] -> [r]
forall a. a -> [a] -> [a]
:CachedFSDatabase r -> [r]
forall r. CachedFSDatabase r -> [r]
cache CachedFSDatabase r
d})
  StateT (CachedFSDatabase r) IO ()
forall r. SizedRecord r => StateT (CachedFSDatabase r) IO ()
trimCache

deleteByKeyFromCache
  :: SizedRecord r
    => String -> StateT (CachedFSDatabase r) IO ()
deleteByKeyFromCache :: String -> StateT (CachedFSDatabase r) IO ()
deleteByKeyFromCache String
k
  = (CachedFSDatabase r -> CachedFSDatabase r)
-> StateT (CachedFSDatabase r) IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\CachedFSDatabase r
d -> CachedFSDatabase r
d {cache :: [r]
cache=(r -> Bool) -> [r] -> [r]
forall a. (a -> Bool) -> [a] -> [a]
filter (\r
x -> r -> String
forall r. Record r => r -> String
key r
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
k) (CachedFSDatabase r -> [r]
forall r. CachedFSDatabase r -> [r]
cache CachedFSDatabase r
d)})

deleteFromCache
  :: SizedRecord r
    => r -> StateT (CachedFSDatabase r) IO ()
deleteFromCache :: r -> StateT (CachedFSDatabase r) IO ()
deleteFromCache r
r =
  (CachedFSDatabase r -> CachedFSDatabase r)
-> StateT (CachedFSDatabase r) IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\CachedFSDatabase r
d -> CachedFSDatabase r
d {cache :: [r]
cache=(r -> Bool) -> [r] -> [r]
forall a. (a -> Bool) -> [a] -> [a]
filter (\r
x -> r -> String
forall r. Record r => r -> String
key r
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= r -> String
forall r. Record r => r -> String
key r
r) (CachedFSDatabase r -> [r]
forall r. CachedFSDatabase r -> [r]
cache CachedFSDatabase r
d)})

trimCache :: SizedRecord r => StateT (CachedFSDatabase r) IO ()
trimCache :: StateT (CachedFSDatabase r) IO ()
trimCache = do
  Int
m <- (CachedFSDatabase r -> Int) -> StateT (CachedFSDatabase r) IO Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CachedFSDatabase r -> Int
forall r. CachedFSDatabase r -> Int
maxCacheSize
  [r]
xs <- (CachedFSDatabase r -> [r]) -> StateT (CachedFSDatabase r) IO [r]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CachedFSDatabase r -> [r]
forall r. CachedFSDatabase r -> [r]
cache
  Bool
-> StateT (CachedFSDatabase r) IO ()
-> StateT (CachedFSDatabase r) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([r] -> Int
forall r. SizedRecord r => [r] -> Int
listSize [r]
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
m) (StateT (CachedFSDatabase r) IO ()
 -> StateT (CachedFSDatabase r) IO ())
-> StateT (CachedFSDatabase r) IO ()
-> StateT (CachedFSDatabase r) IO ()
forall a b. (a -> b) -> a -> b
$
    (CachedFSDatabase r -> CachedFSDatabase r)
-> StateT (CachedFSDatabase r) IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\CachedFSDatabase r
d -> CachedFSDatabase r
d {cache :: [r]
cache=Int -> [r] -> [r]
forall r. SizedRecord r => Int -> [r] -> [r]
trim Int
m [r]
xs})

trim :: SizedRecord r => Int -> [r] -> [r]
trim :: Int -> [r] -> [r]
trim Int
m [r]
xs = if [r] -> Int
forall r. SizedRecord r => [r] -> Int
listSize [r]
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
m 
              then Int -> [r] -> [r]
forall r. SizedRecord r => Int -> [r] -> [r]
trim Int
m ([r] -> [r]
forall a. [a] -> [a]
init [r]
xs)
              else [r]
xs

listSize :: SizedRecord r => [r] -> Int
listSize :: [r] -> Int
listSize [] = Int
0
listSize [r]
xs = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (r -> Int) -> [r] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map r -> Int
forall r. SizedRecord r => r -> Int
size [r]
xs

-- | @'mkFSDatabase' d@ (re)creates the FSDatabase in the
--   directory @d@.
mkCachedFSDatabase :: FilePath -> Int -> CachedFSDatabase r
mkCachedFSDatabase :: String -> Int -> CachedFSDatabase r
mkCachedFSDatabase String
d Int
s = FSDatabase r -> [r] -> Int -> CachedFSDatabase r
forall r. FSDatabase r -> [r] -> Int -> CachedFSDatabase r
CachedFSDatabase (String -> FSDatabase r
forall r. String -> FSDatabase r
FS.mkFSDatabase String
d) [] Int
s