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, removeFile)
data FSDatabase r = FSDatabase
{
initialised :: Bool,
mainDir :: FilePath,
archiveDir :: FilePath
} deriving Show
instance Database (FSDatabase r) where
type DBRecord (FSDatabase r) = r
keys = keysIn mainDir
archivedKeys = keysIn archiveDir
lookup k = k `lookupIn` mainDir
lookupInArchive k = k `lookupIn` archiveDir
store r = do
initIfNeeded
writeRecord2 mainDir r
delete name = do
initIfNeeded
fileExists <- liftIO $ doesFileExist name
when fileExists $ liftIO $ removeFile name
keysIn
:: (FSDatabase r -> FilePath) -> StateT (FSDatabase r) IO [String]
keysIn x = do
initIfNeeded
d <- gets x
files <- liftIO $ getDirectoryContents d
return $ filter isRecordFileName files
lookupIn
:: DS.Serialize r =>
String
-> (FSDatabase r -> FilePath)
-> StateT (FSDatabase r) IO (Either String r)
lookupIn k x = do
initIfNeeded
d <- gets x
let f = d ++ '/':k
liftIO $ readRecord3 f
mkFSDatabase :: FilePath -> FSDatabase r
mkFSDatabase d = FSDatabase False d (d ++ "/archive")
initIfNeeded :: StateT (FSDatabase r) IO ()
initIfNeeded = do
isInitialised <- gets initialised
unless isInitialised $ modifyLift initialise
initialise :: FSDatabase r -> IO (FSDatabase r)
initialise u = do
createDirectoryIfMissing True (mainDir u)
createDirectoryIfMissing True (archiveDir u)
return u { initialised=True }
readRecord3 :: DS.Serialize r => FilePath -> IO (Either String r)
readRecord3 f = do
x <- readFile f
return $ DS.decode x
writeRecord3 :: (Record r, DS.Serialize r) => FilePath -> r -> IO ()
writeRecord3 f a = do
let x = DS.encode a
writeFile f x
writeRecord2 :: (Record r, DS.Serialize r) =>
(FSDatabase r -> FilePath) -> r -> StateT (FSDatabase r) IO ()
writeRecord2 dirGetter r = do
d <- gets dirGetter
let f = d ++ '/':key r
liftIO $ writeRecord3 f r
isRecordFileName :: String -> Bool
isRecordFileName s =
s `notElem` [ "archive", ".", ".." ]