------------------------------------------------------------------------
-- |
-- Module      :  ALife.Creatur.Database.FileSystem
-- Copyright   :  (c) 2012-2021 Amy de Buitléir
-- License     :  BSD-style
-- Maintainer  :  amy@nualeargais.ie
-- Stability   :  experimental
-- Portability :  portable
--
-- A ridiculously simple database that stores each record in a
-- separate file. The name of the file is the record's key.
--
------------------------------------------------------------------------
{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
module ALife.Creatur.Database.FileSystem
  (
    FSDatabase,
    mkFSDatabase
  ) where

import Prelude hiding (readFile, writeFile)

import ALife.Creatur.Database (Database(..), DBRecord, Record, 
  delete, key, keys, store)
import ALife.Creatur.Util (modifyLift)
import Control.Monad (unless, when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.State (StateT, gets)
import Data.ByteString as BS (readFile, writeFile)
import qualified Data.Serialize as DS 
  (Serialize, decode, encode)
import System.Directory (createDirectoryIfMissing, doesFileExist, 
  getDirectoryContents, renameFile)

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

instance Database (FSDatabase r) where
  type DBRecord (FSDatabase r) = r

  keys :: StateT (FSDatabase r) IO [FilePath]
keys = (FSDatabase r -> FilePath) -> StateT (FSDatabase r) IO [FilePath]
forall r.
(FSDatabase r -> FilePath) -> StateT (FSDatabase r) IO [FilePath]
keysIn FSDatabase r -> FilePath
forall r. FSDatabase r -> FilePath
mainDir

  numRecords :: StateT (FSDatabase r) IO Int
numRecords = ([FilePath] -> Int)
-> StateT (FSDatabase r) IO [FilePath]
-> StateT (FSDatabase r) IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length StateT (FSDatabase r) IO [FilePath]
forall d. Database d => StateT d IO [FilePath]
keys
  
  archivedKeys :: StateT (FSDatabase r) IO [FilePath]
archivedKeys = (FSDatabase r -> FilePath) -> StateT (FSDatabase r) IO [FilePath]
forall r.
(FSDatabase r -> FilePath) -> StateT (FSDatabase r) IO [FilePath]
keysIn FSDatabase r -> FilePath
forall r. FSDatabase r -> FilePath
archiveDir

  lookup :: FilePath
-> StateT
     (FSDatabase r) IO (Either FilePath (DBRecord (FSDatabase r)))
lookup FilePath
k = FilePath
k FilePath
-> (FSDatabase r -> FilePath)
-> StateT (FSDatabase r) IO (Either FilePath r)
forall r.
Serialize r =>
FilePath
-> (FSDatabase r -> FilePath)
-> StateT (FSDatabase r) IO (Either FilePath r)
`lookupIn` FSDatabase r -> FilePath
forall r. FSDatabase r -> FilePath
mainDir

  lookupInArchive :: FilePath
-> StateT
     (FSDatabase r) IO (Either FilePath (DBRecord (FSDatabase r)))
lookupInArchive FilePath
k = FilePath
k FilePath
-> (FSDatabase r -> FilePath)
-> StateT (FSDatabase r) IO (Either FilePath r)
forall r.
Serialize r =>
FilePath
-> (FSDatabase r -> FilePath)
-> StateT (FSDatabase r) IO (Either FilePath r)
`lookupIn` FSDatabase r -> FilePath
forall r. FSDatabase r -> FilePath
archiveDir

  store :: DBRecord (FSDatabase r) -> StateT (FSDatabase r) IO ()
store DBRecord (FSDatabase r)
r = do
    StateT (FSDatabase r) IO ()
forall r. StateT (FSDatabase r) IO ()
initIfNeeded
    (FSDatabase r -> FilePath) -> r -> StateT (FSDatabase r) IO ()
forall r.
(Record r, Serialize r) =>
(FSDatabase r -> FilePath) -> r -> StateT (FSDatabase r) IO ()
writeRecord2 FSDatabase r -> FilePath
forall r. FSDatabase r -> FilePath
mainDir r
DBRecord (FSDatabase r)
r

  delete :: FilePath -> StateT (FSDatabase r) IO ()
delete FilePath
name = do
    StateT (FSDatabase r) IO ()
forall r. StateT (FSDatabase r) IO ()
initIfNeeded
    FilePath
d1 <-  (FSDatabase r -> FilePath) -> StateT (FSDatabase r) IO FilePath
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FSDatabase r -> FilePath
forall r. FSDatabase r -> FilePath
mainDir
    FilePath
d2 <- (FSDatabase r -> FilePath) -> StateT (FSDatabase r) IO FilePath
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FSDatabase r -> FilePath
forall r. FSDatabase r -> FilePath
archiveDir
    let f1 :: FilePath
f1 = FilePath
d1 FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'/'Char -> ShowS
forall a. a -> [a] -> [a]
:FilePath
name
    let f2 :: FilePath
f2 = FilePath
d2 FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'/'Char -> ShowS
forall a. a -> [a] -> [a]
:FilePath
name
    Bool
fileExists <- IO Bool -> StateT (FSDatabase r) IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> StateT (FSDatabase r) IO Bool)
-> IO Bool -> StateT (FSDatabase r) IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
f1
    Bool -> StateT (FSDatabase r) IO () -> StateT (FSDatabase r) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fileExists (StateT (FSDatabase r) IO () -> StateT (FSDatabase r) IO ())
-> StateT (FSDatabase r) IO () -> StateT (FSDatabase r) IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> StateT (FSDatabase r) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT (FSDatabase r) IO ())
-> IO () -> StateT (FSDatabase r) IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
renameFile FilePath
f1 FilePath
f2

keysIn
  :: (FSDatabase r -> FilePath) -> StateT (FSDatabase r) IO [String]
keysIn :: (FSDatabase r -> FilePath) -> StateT (FSDatabase r) IO [FilePath]
keysIn FSDatabase r -> FilePath
x = do
    StateT (FSDatabase r) IO ()
forall r. StateT (FSDatabase r) IO ()
initIfNeeded
    FilePath
d <- (FSDatabase r -> FilePath) -> StateT (FSDatabase r) IO FilePath
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FSDatabase r -> FilePath
x
    [FilePath]
files <- IO [FilePath] -> StateT (FSDatabase r) IO [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> StateT (FSDatabase r) IO [FilePath])
-> IO [FilePath] -> StateT (FSDatabase r) IO [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> IO [FilePath]
getDirectoryContents FilePath
d
    [FilePath] -> StateT (FSDatabase r) IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> StateT (FSDatabase r) IO [FilePath])
-> [FilePath] -> StateT (FSDatabase r) IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
isRecordFileName [FilePath]
files

lookupIn
  :: DS.Serialize r =>
     String
     -> (FSDatabase r -> FilePath)
     -> StateT (FSDatabase r) IO (Either String r)
lookupIn :: FilePath
-> (FSDatabase r -> FilePath)
-> StateT (FSDatabase r) IO (Either FilePath r)
lookupIn FilePath
k FSDatabase r -> FilePath
x = do
    StateT (FSDatabase r) IO ()
forall r. StateT (FSDatabase r) IO ()
initIfNeeded
    FilePath
d <- (FSDatabase r -> FilePath) -> StateT (FSDatabase r) IO FilePath
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FSDatabase r -> FilePath
x
    let f :: FilePath
f = FilePath
d FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'/'Char -> ShowS
forall a. a -> [a] -> [a]
:FilePath
k
    IO (Either FilePath r)
-> StateT (FSDatabase r) IO (Either FilePath r)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either FilePath r)
 -> StateT (FSDatabase r) IO (Either FilePath r))
-> IO (Either FilePath r)
-> StateT (FSDatabase r) IO (Either FilePath r)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Either FilePath r)
forall r. Serialize r => FilePath -> IO (Either FilePath r)
readRecord3 FilePath
f
  
-- | @'mkFSDatabase' d@ (re)creates the FSDatabase in the
--   directory @d@.
mkFSDatabase :: FilePath -> FSDatabase r
mkFSDatabase :: FilePath -> FSDatabase r
mkFSDatabase FilePath
d = Bool -> FilePath -> FilePath -> FSDatabase r
forall r. Bool -> FilePath -> FilePath -> FSDatabase r
FSDatabase Bool
False FilePath
d (FilePath
d FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"/archive")

initIfNeeded :: StateT (FSDatabase r) IO ()
initIfNeeded :: StateT (FSDatabase r) IO ()
initIfNeeded = do
  Bool
isInitialised <- (FSDatabase r -> Bool) -> StateT (FSDatabase r) IO Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FSDatabase r -> Bool
forall r. FSDatabase r -> Bool
initialised
  Bool -> StateT (FSDatabase r) IO () -> StateT (FSDatabase r) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isInitialised (StateT (FSDatabase r) IO () -> StateT (FSDatabase r) IO ())
-> StateT (FSDatabase r) IO () -> StateT (FSDatabase r) IO ()
forall a b. (a -> b) -> a -> b
$ (FSDatabase r -> IO (FSDatabase r)) -> StateT (FSDatabase r) IO ()
forall (m :: * -> *) s. Monad m => (s -> m s) -> StateT s m ()
modifyLift FSDatabase r -> IO (FSDatabase r)
forall r. FSDatabase r -> IO (FSDatabase r)
initialise

initialise :: FSDatabase r -> IO (FSDatabase r)
initialise :: FSDatabase r -> IO (FSDatabase r)
initialise FSDatabase r
u = do
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FSDatabase r -> FilePath
forall r. FSDatabase r -> FilePath
mainDir FSDatabase r
u)
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FSDatabase r -> FilePath
forall r. FSDatabase r -> FilePath
archiveDir FSDatabase r
u)
  FSDatabase r -> IO (FSDatabase r)
forall (m :: * -> *) a. Monad m => a -> m a
return FSDatabase r
u { initialised :: Bool
initialised=Bool
True }

-- | Read a record from a file.
readRecord3 :: DS.Serialize r => FilePath -> IO (Either String r)
readRecord3 :: FilePath -> IO (Either FilePath r)
readRecord3 FilePath
f = do
  ByteString
x <- FilePath -> IO ByteString
readFile FilePath
f
  Either FilePath r -> IO (Either FilePath r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath r -> IO (Either FilePath r))
-> Either FilePath r -> IO (Either FilePath r)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either FilePath r
forall a. Serialize a => ByteString -> Either FilePath a
DS.decode ByteString
x

-- | Write a record to a file.
writeRecord3 :: (Record r, DS.Serialize r) => FilePath -> r -> IO ()
writeRecord3 :: FilePath -> r -> IO ()
writeRecord3 FilePath
f r
a = do
  let x :: ByteString
x = r -> ByteString
forall a. Serialize a => a -> ByteString
DS.encode r
a
  FilePath -> ByteString -> IO ()
writeFile FilePath
f ByteString
x

writeRecord2 :: (Record r, DS.Serialize r) => 
  (FSDatabase r -> FilePath) -> r -> StateT (FSDatabase r) IO ()
writeRecord2 :: (FSDatabase r -> FilePath) -> r -> StateT (FSDatabase r) IO ()
writeRecord2 FSDatabase r -> FilePath
dirGetter r
r = do
  FilePath
d <- (FSDatabase r -> FilePath) -> StateT (FSDatabase r) IO FilePath
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FSDatabase r -> FilePath
dirGetter
  let f :: FilePath
f = FilePath
d FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'/'Char -> ShowS
forall a. a -> [a] -> [a]
:r -> FilePath
forall r. Record r => r -> FilePath
key r
r
  IO () -> StateT (FSDatabase r) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT (FSDatabase r) IO ())
-> IO () -> StateT (FSDatabase r) IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> r -> IO ()
forall r. (Record r, Serialize r) => FilePath -> r -> IO ()
writeRecord3 FilePath
f r
r
  -- liftIO $ agentId r ++ " archived to " ++ show f     

isRecordFileName :: String -> Bool
isRecordFileName :: FilePath -> Bool
isRecordFileName FilePath
s =
  FilePath
s FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ FilePath
"archive", FilePath
".", FilePath
".." ]