summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorhverr <>2017-09-13 15:05:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-09-13 15:05:00 (GMT)
commit0a6d38275b0facd560cd44f67f71589f533a9a92 (patch)
treed4662f922a1cc245a0e804de5f6f7d5ceeaa306b
parentf083c8dc6bc7f4e2cb836d19ed7f66c26fe35277 (diff)
version 0.2.0.0HEAD0.2.0.0master
-rw-r--r--example/Main.hs146
-rw-r--r--haskey.cabal21
-rw-r--r--src-unix/FileIO.hs11
-rw-r--r--src/Database/Haskey/Alloc/Concurrent.hs3
-rw-r--r--src/Database/Haskey/Alloc/Concurrent/Database.hs184
-rw-r--r--src/Database/Haskey/Alloc/Concurrent/Environment.hs179
-rw-r--r--src/Database/Haskey/Alloc/Concurrent/FreePages/Query.hs124
-rw-r--r--src/Database/Haskey/Alloc/Concurrent/FreePages/Save.hs18
-rw-r--r--src/Database/Haskey/Alloc/Concurrent/Meta.hs40
-rw-r--r--src/Database/Haskey/Alloc/Concurrent/Monad.hs18
-rw-r--r--src/Database/Haskey/Alloc/Transaction.hs13
-rw-r--r--src/Database/Haskey/Store/Class.hs10
-rw-r--r--src/Database/Haskey/Store/File.hs52
-rw-r--r--src/Database/Haskey/Store/InMemory.hs30
-rw-r--r--src/Database/Haskey/Store/Page.hs17
-rw-r--r--tests/Integration.hs4
-rw-r--r--tests/Integration/CreateAndOpen.hs63
-rw-r--r--tests/Integration/WriteOpenRead/Concurrent.hs50
18 files changed, 522 insertions, 461 deletions
diff --git a/example/Main.hs b/example/Main.hs
index 6121c9c..49092d1 100644
--- a/example/Main.hs
+++ b/example/Main.hs
@@ -1,66 +1,136 @@
module Main where
+import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (async, wait)
import Control.Monad (void, replicateM)
+import Control.Monad.Catch (bracket_, finally)
-import Data.BTree.Impure (toList, insertTree)
+import Data.BTree.Impure (Tree, toList, insertTree)
import Data.ByteString (ByteString)
import Data.Int (Int32)
import Data.Text.Encoding (encodeUtf8)
+import qualified Data.BTree.Impure as Tree
import qualified Data.Text as Text
import Database.Haskey.Alloc.Concurrent (ConcurrentDb,
ConcurrentHandles,
concurrentHandles,
+ lockConcurrentDb,
+ unlockConcurrentDb,
openConcurrentDb,
createConcurrentDb,
transact_,
transactReadOnly,
commit_)
-import Database.Haskey.Store.File (FileStoreT, Files, newFileStore,
- runFileStoreT, defFileStoreConfig)
+import Database.Haskey.Store.File (FileStoreT, runFileStoreT, defFileStoreConfig)
+import Database.Haskey.Store.InMemory (MemoryStoreT, MemoryFiles, newEmptyMemoryStore,
+ runMemoryStoreT, defMemoryStoreConfig)
+
+import System.Directory (removeDirectoryRecursive)
+import System.Random (randomIO)
+
+concurrency :: Integral a => a
+concurrency = 100
+
+type Root = Tree Int32 ByteString
main :: IO ()
main = do
- store <- newFileStore
+ inMemoryMain root
+ fileMain root `finally` delRoot
+ where
+ root = "example-database.haskey"
+ delRoot = removeDirectoryRecursive root
+
+inMemoryMain :: FilePath -> IO ()
+inMemoryMain root = do
+ store <- newEmptyMemoryStore
db <- openOrCreate store
- writers <- mapM (async . writer store db) [1..100]
- readers <- replicateM 100 $ async (reader store db)
+ writers <- mapM (async . writer store db) [1..concurrency]
+ readers <- replicateM concurrency . async $ do
+ delay <- randomIO
+ reader store db (delay `rem` 5000)
mapM_ wait writers
mapM_ wait readers
- putStrLn "Done"
+ putStrLn "InMemory: done"
+ where
+ writer :: MemoryFiles FilePath
+ -> ConcurrentDb Root
+ -> Int32
+ -> IO ()
+ writer store db i =
+ runDatabase store $ transact_ tx db
+ where
+ bs = encodeUtf8 $ Text.pack (show i)
+
+ tx tree = insertTree i bs tree >>= commit_
+
+ reader :: MemoryFiles FilePath
+ -> ConcurrentDb Root
+ -> Int
+ -> IO ()
+ reader files db delay = void $ replicateM 10 $ do
+ threadDelay delay
+ runDatabase files $ transactReadOnly toList db
+
+ openOrCreate :: MemoryFiles FilePath
+ -> IO (ConcurrentDb Root)
+ openOrCreate store = runDatabase store $ do
+ maybeDb <- openConcurrentDb handles
+ case maybeDb of
+ Nothing -> createConcurrentDb handles Tree.empty
+ Just db -> return db
+ runDatabase :: MemoryFiles FilePath
+ -> MemoryStoreT FilePath m a
+ -> m a
+ runDatabase files action = runMemoryStoreT action defMemoryStoreConfig files
-writer :: Files FilePath
- -> ConcurrentDb Int32 ByteString
- -> Int32
- -> IO ()
-writer store db i =
- runDatabase store $ transact_ tx db
+ handles :: ConcurrentHandles
+ handles = concurrentHandles root
+
+fileMain :: FilePath -> IO ()
+fileMain root = bracket_ (runDatabase $ lockConcurrentDb handles)
+ (runDatabase $ unlockConcurrentDb handles) $ do
+
+ db <- openOrCreate
+ writers <- mapM (async . writer db) [1..concurrency]
+ readers <- replicateM concurrency . async $ do
+ delay <- randomIO
+ reader db (delay `rem` 5000)
+ mapM_ wait writers
+ mapM_ wait readers
+ putStrLn "File: done"
where
- bs = encodeUtf8 $ Text.pack (show i)
-
- tx tree = insertTree i bs tree >>= commit_
-
-reader :: Files FilePath
- -> ConcurrentDb Int32 ByteString
- -> IO ()
-reader files db = void $ replicateM 100 $ runDatabase files $
- transactReadOnly toList db
-
-openOrCreate :: Files FilePath
- -> IO (ConcurrentDb Int32 ByteString)
-openOrCreate store = runDatabase store $ do
- maybeDb <- openConcurrentDb handles
- case maybeDb of
- Nothing -> createConcurrentDb handles
- Just db -> return db
-
-runDatabase :: Files FilePath
- -> FileStoreT FilePath m a
- -> m a
-runDatabase files action = runFileStoreT action defFileStoreConfig files
-
-handles :: ConcurrentHandles
-handles = concurrentHandles "example-database.haskey"
+ writer :: ConcurrentDb Root
+ -> Int32
+ -> IO ()
+ writer db i =
+ runDatabase $ transact_ tx db
+ where
+ bs = encodeUtf8 $ Text.pack (show i)
+
+ tx tree = insertTree i bs tree >>= commit_
+
+ reader :: ConcurrentDb Root
+ -> Int
+ -> IO ()
+ reader db delay = void $ replicateM 10 $ do
+ threadDelay delay
+ runDatabase $ transactReadOnly toList db
+
+ openOrCreate :: IO (ConcurrentDb Root)
+ openOrCreate = runDatabase $ do
+ maybeDb <- openConcurrentDb handles
+ case maybeDb of
+ Nothing -> createConcurrentDb handles Tree.empty
+ Just db -> return db
+
+ runDatabase :: Monad m
+ => FileStoreT FilePath m a
+ -> m a
+ runDatabase action = runFileStoreT action defFileStoreConfig
+
+ handles :: ConcurrentHandles
+ handles = concurrentHandles root
diff --git a/haskey.cabal b/haskey.cabal
index 272fd40..f2d41b4 100644
--- a/haskey.cabal
+++ b/haskey.cabal
@@ -1,6 +1,6 @@
name: haskey
-version: 0.1.0.1
-synopsis: A transcatoinal, ACID compliant, embeddable key-value store.
+version: 0.2.0.0
+synopsis: A transactional, ACID compliant, embeddable key-value store.
description:
Haskey is a transactional, ACID compliant, embeddable, scalable key-value
store written entirely in Haskell.
@@ -65,7 +65,7 @@ library
exceptions >=0.8.3 && <0.9,
filepath >=1.4 && <2,
focus >=0.1.2 && <0.2,
- haskey-btree >=0.1 && <1,
+ haskey-btree >=0.2 && <1,
list-t >=0.2 && <2,
lz4 >=0.2 && <1,
mtl >=2.1 && <3,
@@ -101,7 +101,7 @@ test-suite haskey-properties
test-framework-hunit >=0.3 && <1,
test-framework-quickcheck2 >=0.3 && <1,
haskey,
- haskey-btree
+ haskey-btree >=0.2 && <1
default-language: Haskell2010
ghc-options: -Wall
@@ -111,6 +111,7 @@ test-suite haskey-integration
main-is: Integration.hs
type: exitcode-stdio-1.0
other-modules:
+ Integration.CreateAndOpen
Integration.WriteOpenRead.Concurrent
Integration.WriteOpenRead.Transactions
@@ -126,17 +127,20 @@ test-suite haskey-integration
temporary >=1.2 && <1.3,
vector >=0.10 && <1,
- QuickCheck >=2 && <3,
+ HUnit >=1.3 && <2,
+ QuickCheck >=2 && <3,
test-framework >=0.8 && <1,
+ test-framework-hunit >=0.3 && <1,
test-framework-quickcheck2 >=0.3 && <1,
haskey,
- haskey-btree
+ haskey-btree >=0.2 && <1
default-language: Haskell2010
ghc-options: -Wall
hs-source-dirs: tests
-executable haskey-example
+test-suite haskey-example
+ type: exitcode-stdio-1.0
hs-source-dirs: example
main-is: Main.hs
build-depends:
@@ -145,6 +149,9 @@ executable haskey-example
haskey-btree,
async >=2.1 && <3,
bytestring >=0.6 && <0.9 || >0.9 && <1,
+ directory >=1.2 && <2,
+ exceptions >=0.8.3 && <0.9,
+ random >=1.1 && <2,
text >=1.2 && <2
ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
diff --git a/src-unix/FileIO.hs b/src-unix/FileIO.hs
index fbd8d58..33bed12 100644
--- a/src-unix/FileIO.hs
+++ b/src-unix/FileIO.hs
@@ -11,9 +11,10 @@ module FileIO (
, seek
, setFileSize
, getFileSize
+ , PrefixLock
+ , prefixLockFromPrefix
, obtainPrefixLock
, releasePrefixLock
- , PrefixLock
) where
import Prelude hiding (read)
@@ -52,6 +53,9 @@ import qualified System.IO.Error as SE
newtype PrefixLock = PrefixLock FilePath
+prefixLockFromPrefix :: FilePath -> PrefixLock
+prefixLockFromPrefix = PrefixLock . (++ ".lock")
+
newtype FHandle = FHandle Fd
-- | Open the specified file in read-write mode.
@@ -99,8 +103,9 @@ close (FHandle fd) = closeFd fd
-- where flags = defaultFileFlags {exclusive = True, trunc = True}
-
-
+-- | Obtain a lock on a file.
+--
+-- Use 'releasePrefixLock' to release the prefix lock.
obtainPrefixLock :: FilePath -> IO PrefixLock
obtainPrefixLock prefix = checkLock fp >> takeLock fp
where fp = prefix ++ ".lock"
diff --git a/src/Database/Haskey/Alloc/Concurrent.hs b/src/Database/Haskey/Alloc/Concurrent.hs
index 42178c3..1ccf210 100644
--- a/src/Database/Haskey/Alloc/Concurrent.hs
+++ b/src/Database/Haskey/Alloc/Concurrent.hs
@@ -7,6 +7,8 @@ module Database.Haskey.Alloc.Concurrent (
-- * Open, close and create databases
, ConcurrentHandles(..)
, concurrentHandles
+, lockConcurrentDb
+, unlockConcurrentDb
, createConcurrentDb
, openConcurrentDb
, closeConcurrentHandles
@@ -18,6 +20,7 @@ module Database.Haskey.Alloc.Concurrent (
, transactReadOnly
-- * Storage requirements
+, Root
, ConcurrentMeta(..)
, ConcurrentMetaStoreM(..)
) where
diff --git a/src/Database/Haskey/Alloc/Concurrent/Database.hs b/src/Database/Haskey/Alloc/Concurrent/Database.hs
index d3ef74a..70df47e 100644
--- a/src/Database/Haskey/Alloc/Concurrent/Database.hs
+++ b/src/Database/Haskey/Alloc/Concurrent/Database.hs
@@ -10,14 +10,13 @@ import Control.Concurrent.STM
import Control.Monad (void, unless)
import Control.Monad.IO.Class
import Control.Monad.Catch (MonadCatch, MonadMask, SomeException,
- catch, mask, onException, bracket)
+ catch, mask, onException, bracket, bracket_)
import Control.Monad.State
import Control.Monad.Trans (lift)
import Data.Proxy (Proxy(..))
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Maybe (fromMaybe)
-import qualified Data.Set as S
import STMContainers.Map (Map)
import qualified STMContainers.Map as Map
@@ -39,15 +38,29 @@ import qualified Database.Haskey.Utils.STM.Map as Map
-- | An active concurrent database.
--
-- This can be shared amongst threads.
-data ConcurrentDb k v = ConcurrentDb
+data ConcurrentDb root = ConcurrentDb
{ concurrentDbHandles :: ConcurrentHandles
, concurrentDbWriterLock :: RLock
, concurrentDbCurrentMeta :: TVar CurrentMetaPage
- , concurrentDbMeta1 :: TVar (ConcurrentMeta k v)
- , concurrentDbMeta2 :: TVar (ConcurrentMeta k v)
+ , concurrentDbMeta1 :: TVar (ConcurrentMeta root)
+ , concurrentDbMeta2 :: TVar (ConcurrentMeta root)
, concurrentDbReaders :: Map TxId Integer
}
+-- | Lock the database.
+--
+-- This needs to be called manually, if you want exclusive access, before
+-- calling either 'createConcurrentDb' or 'openConcurrentDb'
+--
+-- Use 'unlockConcurrentDb' using the 'bracket' pattern to properly unlock the
+-- database.
+lockConcurrentDb :: ConcurrentMetaStoreM m => ConcurrentHandles -> m ()
+lockConcurrentDb = lockHandle . concurrentHandlesRoot
+
+-- | Unlock the database.
+unlockConcurrentDb :: ConcurrentMetaStoreM m => ConcurrentHandles -> m ()
+unlockConcurrentDb = releaseHandle . concurrentHandlesRoot
+
-- | Open all concurrent handles.
openConcurrentHandles :: ConcurrentMetaStoreM m
=> ConcurrentHandles -> m ()
@@ -58,10 +71,14 @@ openConcurrentHandles ConcurrentHandles{..} = do
openHandle concurrentHandlesMetadata2
-- | Open a new concurrent database, with the given handles.
-createConcurrentDb :: (Key k, Value v, MonadIO m, ConcurrentMetaStoreM m)
- => ConcurrentHandles -> m (ConcurrentDb k v)
-createConcurrentDb hnds = do
- openConcurrentHandles hnds
+createConcurrentDb :: (Root root, MonadIO m, MonadMask m, ConcurrentMetaStoreM m)
+ => ConcurrentHandles
+ -> root
+ -> m (ConcurrentDb root)
+createConcurrentDb hnds root =
+ bracket_ (openConcurrentHandles hnds)
+ (closeConcurrentHandles hnds) $ do
+
db <- newConcurrentDb hnds meta0
setCurrentMeta meta0 db
setCurrentMeta meta0 db
@@ -71,21 +88,24 @@ createConcurrentDb hnds = do
concurrentMetaRevision = 0
, concurrentMetaDataNumPages = DataState 0
, concurrentMetaIndexNumPages = IndexState 0
- , concurrentMetaTree = Tree zeroHeight Nothing
+ , concurrentMetaRoot = root
, concurrentMetaDataFreeTree = DataState $ Tree zeroHeight Nothing
, concurrentMetaIndexFreeTree = IndexState $ Tree zeroHeight Nothing
, concurrentMetaOverflowTree = Tree zeroHeight Nothing
- , concurrentMetaDataFreshUnusedPages = DataState S.empty
- , concurrentMetaIndexFreshUnusedPages = IndexState S.empty
+ , concurrentMetaDataCachedFreePages = DataState []
+ , concurrentMetaIndexCachedFreePages = IndexState []
}
-- | Open the an existing database, with the given handles.
-openConcurrentDb :: (Key k, Value v, MonadIO m, MonadMask m, ConcurrentMetaStoreM m)
- => ConcurrentHandles -> m (Maybe (ConcurrentDb k v))
-openConcurrentDb hnds@ConcurrentHandles{..} = do
- openConcurrentHandles hnds
- m1 <- readConcurrentMeta concurrentHandlesMetadata1 Proxy Proxy
- m2 <- readConcurrentMeta concurrentHandlesMetadata2 Proxy Proxy
+openConcurrentDb :: (Root root, MonadIO m, MonadMask m, ConcurrentMetaStoreM m)
+ => ConcurrentHandles
+ -> m (Maybe (ConcurrentDb root))
+openConcurrentDb hnds@ConcurrentHandles{..} =
+ bracket_ (openConcurrentHandles hnds)
+ (closeConcurrentHandles hnds) $ do
+
+ m1 <- readConcurrentMeta concurrentHandlesMetadata1 Proxy
+ m2 <- readConcurrentMeta concurrentHandlesMetadata2 Proxy
maybeDb <- case (m1, m2) of
(Nothing, Nothing) -> return Nothing
(Just m , Nothing) -> Just <$> newConcurrentDb hnds m
@@ -111,10 +131,10 @@ closeConcurrentHandles ConcurrentHandles{..} = do
closeHandle concurrentHandlesMetadata2
-- | Create a new concurrent database with handles and metadata provided.
-newConcurrentDb :: (Key k, Value v, MonadIO m)
+newConcurrentDb :: (Root root, MonadIO m)
=> ConcurrentHandles
- -> ConcurrentMeta k v
- -> m (ConcurrentDb k v)
+ -> ConcurrentMeta root
+ -> m (ConcurrentDb root)
newConcurrentDb hnds meta0 = do
readers <- liftIO Map.newIO
meta <- liftIO $ newTVarIO Meta1
@@ -131,8 +151,9 @@ newConcurrentDb hnds meta0 = do
}
-- | Get the current meta data.
-getCurrentMeta :: (Key k, Value v)
- => ConcurrentDb k v -> STM (ConcurrentMeta k v)
+getCurrentMeta :: Root root
+ => ConcurrentDb root
+ -> STM (ConcurrentMeta root)
getCurrentMeta db
| ConcurrentDb { concurrentDbCurrentMeta = v } <- db
= readTVar v >>= \case
@@ -140,8 +161,10 @@ getCurrentMeta db
Meta2 -> readTVar $ concurrentDbMeta2 db
-- | Write the new metadata, and switch the pointer to the current one.
-setCurrentMeta :: (MonadIO m, ConcurrentMetaStoreM m, Key k, Value v)
- => ConcurrentMeta k v -> ConcurrentDb k v -> m ()
+setCurrentMeta :: (Root root, MonadIO m, ConcurrentMetaStoreM m)
+ => ConcurrentMeta root
+ -> ConcurrentDb root
+ -> m ()
setCurrentMeta new db
| ConcurrentDb
{ concurrentDbCurrentMeta = v
@@ -166,9 +189,10 @@ setCurrentMeta new db
writeTVar (concurrentDbMeta1 db) new
-- | Execute a write transaction, with a result.
-transact :: (MonadIO m, MonadMask m, ConcurrentMetaStoreM m, Key key, Value val)
- => (forall n. (AllocM n, MonadMask n) => Tree key val -> n (Transaction key val a))
- -> ConcurrentDb key val -> m a
+transact :: (MonadIO m, MonadMask m, ConcurrentMetaStoreM m, Root root)
+ => (forall n. (AllocM n, MonadMask n) => root -> n (Transaction root a))
+ -> ConcurrentDb root
+ -> m a
transact act db = withRLock (concurrentDbWriterLock db) $ do
cleanup
transactNow act db
@@ -183,32 +207,38 @@ transact act db = withRLock (concurrentDbWriterLock db) $ do
return (Just meta', ())
-- | Execute a write transaction, without cleaning up old overflow pages.
-transactNow :: (MonadIO m, MonadMask m, ConcurrentMetaStoreM m, Key k, Value v)
- => (forall n. (AllocM n, MonadMask n) => Tree k v -> n (Transaction k v a))
- -> ConcurrentDb k v -> m a
+transactNow :: (MonadIO m, MonadMask m, ConcurrentMetaStoreM m, Root root)
+ => (forall n. (AllocM n, MonadMask n) => root -> n (Transaction root a))
+ -> ConcurrentDb root
+ -> m a
transactNow act db = withRLock (concurrentDbWriterLock db) $
actAndCommit db $ \meta -> do
- tx <- act (concurrentMetaTree meta)
+ tx <- act (concurrentMetaRoot meta)
case tx of
Abort v -> return (Nothing, v)
- Commit tree v ->
- let meta' = meta { concurrentMetaTree = tree } in
+ Commit root v ->
+ let meta' = meta { concurrentMetaRoot = root } in
return (Just meta', v)
-- | Execute a write transaction, without a result.
-transact_ :: (MonadIO m, MonadMask m, ConcurrentMetaStoreM m, Key k, Value v)
- => (forall n. (AllocM n, MonadMask n) => Tree k v -> n (Transaction k v ()))
- -> ConcurrentDb k v -> m ()
+transact_ :: (MonadIO m, MonadMask m, ConcurrentMetaStoreM m, Root root)
+ => (forall n. (AllocM n, MonadMask n) => root -> n (Transaction root ()))
+ -> ConcurrentDb root
+ -> m ()
transact_ act db = void $ transact act db
-- | Execute a read-only transaction.
-transactReadOnly :: (MonadIO m, MonadMask m, ConcurrentMetaStoreM m, Key key, Value val)
- => (forall n. (AllocReaderM n, MonadMask m) => Tree key val -> n a)
- -> ConcurrentDb key val -> m a
-transactReadOnly act db = withRLock (concurrentDbWriterLock db) $
+transactReadOnly :: (MonadIO m, MonadMask m, ConcurrentMetaStoreM m, Root root)
+ => (forall n. (AllocReaderM n, MonadMask n) => root -> n a)
+ -> ConcurrentDb root
+ -> m a
+transactReadOnly act db =
+ bracket_ (openConcurrentHandles hnds)
+ (closeConcurrentHandles hnds) $
+
bracket acquireMeta
releaseMeta $
- \meta -> evalConcurrentT (act $ concurrentMetaTree meta)
+ \meta -> evalConcurrentT (act $ concurrentMetaRoot meta)
(ReaderEnv hnds)
where
hnds = concurrentDbHandles db
@@ -235,11 +265,11 @@ transactReadOnly act db = withRLock (concurrentDbWriterLock db) $
-- | Run a write action that takes the current meta-data and returns new
-- meta-data to be commited, or 'Nothing' if the write transaction should be
-- aborted.
-actAndCommit :: (MonadIO m, MonadMask m, ConcurrentMetaStoreM m, Key k, Value v)
- => ConcurrentDb k v
+actAndCommit :: (MonadIO m, MonadMask m, ConcurrentMetaStoreM m, Root root)
+ => ConcurrentDb root
-> (forall n. (MonadIO n, MonadMask n, ConcurrentMetaStoreM n)
- => ConcurrentMeta k v
- -> ConcurrentT WriterEnv ConcurrentHandles n (Maybe (ConcurrentMeta k v), a)
+ => ConcurrentMeta root
+ -> ConcurrentT WriterEnv ConcurrentHandles n (Maybe (ConcurrentMeta root), a)
)
-> m a
actAndCommit db act
@@ -248,7 +278,9 @@ actAndCommit db act
, concurrentDbWriterLock = lock
, concurrentDbReaders = readers
} <- db
- = withRLock lock $ do
+ = withRLock lock $
+ bracket_ (openConcurrentHandles hnds)
+ (closeConcurrentHandles hnds) $ do
meta <- liftIO . atomically $ getCurrentMeta db
let newRevision = concurrentMetaRevision meta + 1
@@ -259,8 +291,8 @@ actAndCommit db act
readers
(concurrentMetaDataNumPages meta)
(concurrentMetaIndexNumPages meta)
- (concurrentMetaDataFreshUnusedPages meta)
- (concurrentMetaIndexFreshUnusedPages meta)
+ (concurrentMetaDataCachedFreePages meta)
+ (concurrentMetaIndexCachedFreePages meta)
(concurrentMetaDataFreeTree meta)
(concurrentMetaIndexFreeTree meta)
@@ -281,7 +313,7 @@ actAndCommit db act
saveFreePages' 0 IndexState
writerIndexFileState
(\e s -> e { writerIndexFileState = s })
- handleFreedDirtyPages
+ handleCachedFreePages
-- Commit
setCurrentMeta (newMeta { concurrentMetaRevision = newRevision })
@@ -328,7 +360,7 @@ removeNewlyAllocatedOverflows env = do
removeHandle (getOverflowHandle root i)
-- | Update the meta-data from a writer environment
-updateMeta :: WriterEnv ConcurrentHandles -> ConcurrentMeta k v -> ConcurrentMeta k v
+updateMeta :: WriterEnv ConcurrentHandles -> ConcurrentMeta root -> ConcurrentMeta root
updateMeta env m = m {
concurrentMetaDataFreeTree = fileStateFreeTree (writerDataFileState env)
, concurrentMetaIndexFreeTree = fileStateFreeTree (writerIndexFileState env) }
@@ -336,7 +368,7 @@ updateMeta env m = m {
-- | Save the newly free'd overflow pages, for deletion on the next tx.
saveOverflowIds :: (MonadIO m, MonadMask m, ConcurrentMetaStoreM m)
- => StateT (ConcurrentMeta k v, WriterEnv ConcurrentHandles) m ()
+ => StateT (ConcurrentMeta root, WriterEnv ConcurrentHandles) m ()
saveOverflowIds = do
(meta, env) <- get
case map (\(OldOverflow i) ->i) (writerRemovedOverflows env) of
@@ -356,43 +388,17 @@ saveFreePages' :: (MonadIO m, MonadMask m, ConcurrentMetaStoreM m)
-> (forall a. a -> S t a)
-> (forall hnds. WriterEnv hnds -> FileState t)
-> (forall hnds. WriterEnv hnds -> FileState t -> WriterEnv hnds)
- -> StateT (ConcurrentMeta k v, WriterEnv ConcurrentHandles) m ()
+ -> StateT (ConcurrentMeta root, WriterEnv ConcurrentHandles) m ()
saveFreePages' paranoid cons getState setState
{- paranoid >= 100 = error "paranoid: looping!"
| otherwise-}
= do
- -- Saving the free pages
- -- =====================
- --
- -- Saving free pages to the free database is a complicated task. At the
- -- end of a transaction we have 3 types of free pages:
- --
- -- 1. 'DirtyFree': Pages that were freshly allocated from the end of
- -- the dabase file, but are no longer used. These are free'd
- -- by saving them in the metadata. They can freely be used
- -- during this routine.
- --
- -- 2. 'NewlyFreed': Pages that were written by a previous transaction,
- -- but free'd in this transaction. They might still be in use
- -- by an older reader, and can thus not be used anyways.
- --
- -- Note that this list **may grow during this routine**, as
- -- new pages can be free'd.
- --
- -- 3. 'OldFree': Pages that were fetched from the free database while
- -- executing the transaction. Technically, they can be used
- -- during this routine, BUT that would mean the list of
- -- 'OldFree' pages can grow and shrink during the call, which
- -- would complicate the convergence/termination conditions of
- -- this routine. So currently, **we disable the use of these
- -- pages in this routine.**
-
(meta, env) <- get
let tx = writerTxId env
(tree', envWithoutTree) <- lift $
runConcurrentT (saveFreePages tx (getState env)) $
- env { writerReusablePagesOn = False }
+ env { writerQueryFreeTreeOn = False }
let state' = (getState envWithoutTree) { fileStateFreeTree = cons tree' }
let env' = setState envWithoutTree state'
@@ -403,14 +409,14 @@ saveFreePages' paranoid cons getState setState
unless (fileStateNewlyFreedPages state' == fileStateNewlyFreedPages (getState env)) $
saveFreePages' (paranoid + 1) cons getState setState
--- | Handle the dirty pages.
+-- | Handle the cached free pages.
--
--- Save the newly created free dirty pages to the metadata for later use.
+-- Save the cached free pages to the metadata for later use.
--
-- Update the database size.
-handleFreedDirtyPages :: (MonadIO m, MonadMask m, ConcurrentMetaStoreM m)
- => StateT (ConcurrentMeta k v, WriterEnv ConcurrentHandles) m ()
-handleFreedDirtyPages = do
+handleCachedFreePages :: (MonadIO m, MonadMask m, ConcurrentMetaStoreM m)
+ => StateT (ConcurrentMeta root, WriterEnv ConcurrentHandles) m ()
+handleCachedFreePages = do
(meta, env) <- get
let dataEnv = writerDataFileState env
@@ -420,15 +426,15 @@ handleFreedDirtyPages = do
fileStateNewNumPages dataEnv
, concurrentMetaDataFreeTree =
fileStateFreeTree dataEnv
- , concurrentMetaDataFreshUnusedPages =
- fileStateFreedDirtyPages dataEnv
+ , concurrentMetaDataCachedFreePages =
+ fileStateCachedFreePages dataEnv
, concurrentMetaIndexNumPages =
fileStateNewNumPages indexEnv
, concurrentMetaIndexFreeTree =
fileStateFreeTree indexEnv
- , concurrentMetaIndexFreshUnusedPages =
- fileStateFreedDirtyPages indexEnv
+ , concurrentMetaIndexCachedFreePages =
+ fileStateCachedFreePages indexEnv
}
put (meta', env)
diff --git a/src/Database/Haskey/Alloc/Concurrent/Environment.hs b/src/Database/Haskey/Alloc/Concurrent/Environment.hs
index 81f9c74..dd7eaab 100644
--- a/src/Database/Haskey/Alloc/Concurrent/Environment.hs
+++ b/src/Database/Haskey/Alloc/Concurrent/Environment.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
@@ -15,6 +16,7 @@ import Control.Monad.State
import Data.Binary (Binary)
import Data.Set (Set)
+import Data.Typeable (Typeable)
import Data.Word (Word32)
import qualified Data.Binary as B
import qualified Data.Set as S
@@ -33,6 +35,7 @@ data StateType = TypeData
data S (t :: StateType) a where
DataState :: a -> S 'TypeData a
IndexState :: a -> S 'TypeIndex a
+ deriving (Typeable)
deriving instance Show a => Show (S t a)
@@ -70,25 +73,15 @@ data FileState stateType = FileState {
-- 'fileStateNewNumPages' (excluding) are freshly allocated in the
-- ongoing transaction.
- , fileStateFreedDirtyPages :: !(S stateType (Set DirtyFree))
- -- ^ Pages freshly allocated AND free'd in this transaction. Immediately
- -- ready for reuse.
+ , fileStateDirtyPages :: !(Set PageId)
+ -- ^ Pages written to in this transaction.
, fileStateFreeTree :: !(S stateType FreeTree)
-- ^ The root of the free tree, might change during a transaction.
- , fileStateDirtyReusablePages :: !(Set DirtyOldFree)
- -- ^ All pages queried from the free page database for
- -- 'fileStateReusablePagesTxId', and actually used once already.
-
- , fileStateReusablePages :: ![OldFree]
- -- ^ Pages queried from the free pages database and ready for immediate
- -- reuse.
-
- , fileStateReusablePagesTxId :: !(Maybe TxId)
- -- ^ The 'TxId' of the pages in 'fileStateReusablePages', or 'Nothing' if no
- -- pages were queried yet from the free database.
-
+ , fileStateCachedFreePages :: !(S stateType [FreePage])
+ -- ^ All pages that are immediately ready for reuse in this and any
+ -- subsequent transactions.
}
data WriterEnv hnds = WriterEnv
@@ -102,8 +95,8 @@ data WriterEnv hnds = WriterEnv
, writerDataFileState :: FileState 'TypeData
-- ^ State of the file with data/leaf nodes.
- , writerReusablePagesOn :: !Bool
- -- ^ Used to turn of querying the free page database for free pages.
+ , writerQueryFreeTreeOn :: !Bool
+ -- ^ Whether or not querying free pages from the free is enabled.
, writerDirtyOverflows :: !(Set DirtyOverflow)
-- ^ Newly allocated overflow pages in this transaction.
@@ -118,111 +111,81 @@ data WriterEnv hnds = WriterEnv
-- | Create a new writer.
newWriter :: hnd -> TxId -> Map TxId Integer
- -> S 'TypeData PageId -> S 'TypeIndex PageId
- -> S 'TypeData (Set DirtyFree) -> S 'TypeIndex (Set DirtyFree)
- -> S 'TypeData FreeTree -> S 'TypeIndex FreeTree
+ -> S 'TypeData PageId -> S 'TypeIndex PageId
+ -> S 'TypeData [FreePage] -> S 'TypeIndex [FreePage]
+ -> S 'TypeData FreeTree -> S 'TypeIndex FreeTree
-> WriterEnv hnd
newWriter hnd tx readers
numDataPages numIndexPages
- dataDirtyFree indexDirtyFree
+ dataFreePages indexFreePages
dataFreeTree indexFreeTree =
WriterEnv {
writerHnds = hnd
, writerTxId = tx
, writerReaders = readers
- , writerIndexFileState = newFileState numIndexPages indexDirtyFree indexFreeTree
- , writerDataFileState = newFileState numDataPages dataDirtyFree dataFreeTree
+ , writerIndexFileState = newFileState numIndexPages indexFreePages indexFreeTree
+ , writerDataFileState = newFileState numDataPages dataFreePages dataFreeTree
- , writerReusablePagesOn = True
+ , writerQueryFreeTreeOn = True
, writerDirtyOverflows = S.empty
, writerOverflowCounter = 0
, writerRemovedOverflows = []
}
where
- newFileState numPages dirtyFree freeTree = FileState {
+ newFileState numPages freePages freeTree = FileState {
fileStateNewlyFreedPages = []
, fileStateOriginalNumPages = numPages
, fileStateNewNumPages = numPages
- , fileStateFreedDirtyPages = dirtyFree
+ , fileStateDirtyPages = S.empty
+ , fileStateCachedFreePages = freePages
, fileStateFreeTree = freeTree
- , fileStateDirtyReusablePages = S.empty
- , fileStateReusablePages = []
- , fileStateReusablePagesTxId = Nothing
}
--- | Wrapper around 'PageId' indicating it is a fresh page, allocated at the
--- end of the database.
-newtype Fresh = Fresh PageId deriving (Eq, Ord, Show)
-
-- | Wrapper around 'PageId' indicating it is newly free'd and cannot be reused
-- in the same transaction.
newtype NewlyFreed = NewlyFreed PageId deriving (Eq, Ord, Show)
--- | Wrapper around 'PageId' indicating it is a dirty page.
-newtype Dirty = Dirty PageId deriving (Eq, Ord, Show)
-
--- | Wrapper around 'PageId' indicating the page is dirty and free for reuse.
-newtype DirtyFree = DirtyFree PageId deriving (Binary, Eq, Ord, Show)
+-- | Wrapper around 'PageId' indicating it is free and can be reused in any
+-- transaction.
+newtype FreePage = FreePage PageId deriving (Binary, Eq, Ord, Show)
--- | Wrapper around 'PageId' inidcating it was fetched from the free database
--- and is ready for reuse.
-newtype OldFree = OldFree PageId deriving (Eq, Ord, Show)
-
--- | Wrapper around 'PageId' indicating it wa fetched from the free database
--- and is actually dirty.
-newtype DirtyOldFree = DirtyOldFree PageId deriving (Eq, Ord, Show)
-
--- | A sum type repesenting any type of free page, that can immediately be used
--- to write something to.
-data SomeFreePage = FreshFreePage Fresh
- | DirtyFreePage DirtyFree
- | OldFreePage OldFree
-
-getSomeFreePageId :: SomeFreePage -> PageId
-getSomeFreePageId (FreshFreePage (Fresh pid)) = pid
-getSomeFreePageId (DirtyFreePage (DirtyFree pid)) = pid
-getSomeFreePageId (OldFreePage (OldFree pid)) = pid
+-- | Wrapper around 'PageId' indicating that it is dirty, i.e. written to in
+-- this transaction.
+newtype Dirty = Dirty PageId deriving (Eq, Ord, Show)
-- | Try to free a page, given a set of dirty pages.
--
--- If the page was dirty, a 'DirtyFree' page is added to the environment, if
+-- If the page was dirty, a 'FreePage' page is added to the environment, if
-- not a 'NewlyFreed' page is added to the environment.
--
-- Btw, give me lenses...
freePage :: (Functor m, MonadState (WriterEnv hnd) m) => S stateType PageId -> m ()
freePage pid@(DataState pid') = do
dirty' <- dirty pid
- dirtyOldFree' <- dirtyOldFree pid
modify' $ \e ->
e { writerDataFileState =
updateFileState (writerDataFileState e) DataState
- dirty' dirtyOldFree' pid'
+ dirty' pid'
}
freePage pid@(IndexState pid') = do
dirty' <- dirty pid
- dirtyOldFree' <- dirtyOldFree pid
modify' $ \e ->
e { writerIndexFileState =
updateFileState (writerIndexFileState e) IndexState
- dirty' dirtyOldFree' pid'
+ dirty' pid'
}
updateFileState :: FileState t
-> (forall a. a -> S t a)
-> Maybe Dirty
- -> Maybe DirtyOldFree
-> PageId
-> FileState t
-updateFileState e cons dirty' dirtyOldFree' pid' =
+updateFileState e cons dirty' pid' =
if | Just (Dirty p) <- dirty' ->
- e { fileStateFreedDirtyPages =
- cons $ S.insert (DirtyFree p) (getSValue $ fileStateFreedDirtyPages e) }
-
- | Just (DirtyOldFree p) <- dirtyOldFree' ->
- e { fileStateReusablePages =
- OldFree p : fileStateReusablePages e }
+ e { fileStateCachedFreePages =
+ cons $ FreePage p : getSValue (fileStateCachedFreePages e) }
| p <- pid' ->
e { fileStateNewlyFreedPages =
@@ -231,58 +194,42 @@ updateFileState e cons dirty' dirtyOldFree' pid' =
-- | Get a 'Dirty' page, by first proving it is in fact dirty.
dirty :: (Functor m, MonadState (WriterEnv hnd) m) => S stateType PageId -> m (Maybe Dirty)
dirty pid = case pid of
- DataState p -> (page p . fileStateOriginalNumPages . writerDataFileState) <$> get
- IndexState p -> (page p . fileStateOriginalNumPages . writerIndexFileState) <$> get
+ DataState p -> (page p . fileStateDirtyPages . writerDataFileState) <$> get
+ IndexState p -> (page p . fileStateDirtyPages . writerIndexFileState) <$> get
where
- page p origNumPages
- | p >= getSValue origNumPages = Just (Dirty p)
- | otherwise = Nothing
-
--- | Get a 'DirtyOldFree' page, by first proving it is in fact a dirty old free page.
-dirtyOldFree :: (Functor m, MonadState (WriterEnv hnd) m) => S stateType PageId -> m (Maybe DirtyOldFree)
-dirtyOldFree pid = case pid of
- DataState p -> (page p . fileStateDirtyReusablePages . writerDataFileState) <$> get
- IndexState p -> (page p . fileStateDirtyReusablePages . writerIndexFileState) <$> get
- where
- page p dirty'
- | S.member (DirtyOldFree p) dirty' = Just (DirtyOldFree p)
- | otherwise = Nothing
-
+ page p dirtyPages
+ | p `S.member` dirtyPages = Just (Dirty p)
+ | otherwise = Nothing
-- | Touch a fresh page, make it dirty.
--
-- We really need lenses...
-touchPage :: MonadState (WriterEnv hnd) m => S stateType SomeFreePage -> m ()
-touchPage (DataState (DirtyFreePage _)) = return()
-touchPage (IndexState (DirtyFreePage _)) = return ()
-
-touchPage (DataState (FreshFreePage (Fresh pid))) = modify' $ \e ->
- case fileStateNewNumPages (writerDataFileState e) of
- DataState numPages ->
- if numPages < pid + 1
- then e { writerDataFileState = (writerDataFileState e) {
- fileStateNewNumPages = DataState (pid + 1) }
- }
- else e
-touchPage (IndexState (FreshFreePage (Fresh pid))) = modify' $ \e ->
- case fileStateNewNumPages (writerIndexFileState e) of
- IndexState numPages ->
- if numPages < pid + 1
- then e { writerIndexFileState = (writerIndexFileState e) {
- fileStateNewNumPages = IndexState (pid + 1) }
- }
- else e
-
-touchPage (DataState (OldFreePage (OldFree pid))) = modify' $ \e ->
- let s = fileStateDirtyReusablePages (writerDataFileState e) in
- e { writerDataFileState = (writerDataFileState e) {
- fileStateDirtyReusablePages = S.insert (DirtyOldFree pid) s }
- }
-touchPage (IndexState (OldFreePage (OldFree pid))) = modify' $ \e ->
- let s = fileStateDirtyReusablePages (writerIndexFileState e) in
- e { writerIndexFileState = (writerIndexFileState e) {
- fileStateDirtyReusablePages = S.insert (DirtyOldFree pid) s }
- }
+touchPage :: MonadState (WriterEnv hnd) m => S stateType PageId -> m ()
+touchPage (DataState pid) = do
+ modify' $ \e ->
+ let dirtyPages = fileStateDirtyPages (writerDataFileState e) in
+ e { writerDataFileState = (writerDataFileState e) {
+ fileStateDirtyPages = S.insert pid dirtyPages }
+ }
+ modify' $ \e ->
+ let oldNum = getSValue $ fileStateNewNumPages (writerDataFileState e)
+ newNum = max oldNum (pid + 1)
+ in e { writerDataFileState = (writerDataFileState e) {
+ fileStateNewNumPages = DataState newNum }
+ }
+
+touchPage (IndexState pid) = do
+ modify' $ \e ->
+ let dirtyPages = fileStateDirtyPages (writerIndexFileState e) in
+ e { writerIndexFileState = (writerIndexFileState e) {
+ fileStateDirtyPages = S.insert pid dirtyPages }
+ }
+ modify' $ \e ->
+ let oldNum = getSValue $ fileStateNewNumPages (writerIndexFileState e)
+ newNum = max oldNum (pid + 1)
+ in e { writerIndexFileState = (writerIndexFileState e) {
+ fileStateNewNumPages = IndexState newNum }
+ }
-- | Wrapper around 'OverflowId' indicating that it is dirty.
newtype DirtyOverflow = DirtyOverflow OverflowId deriving (Eq, Ord, Show)
diff --git a/src/Database/Haskey/Alloc/Concurrent/FreePages/Query.hs b/src/Database/Haskey/Alloc/Concurrent/FreePages/Query.hs
index 3de3e15..b7ea465 100644
--- a/src/Database/Haskey/Alloc/Concurrent/FreePages/Query.hs
+++ b/src/Database/Haskey/Alloc/Concurrent/FreePages/Query.hs
@@ -11,7 +11,6 @@ import Control.Monad.Trans.Maybe
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NE
-import qualified Data.Set as S
import Data.BTree.Alloc.Class
import Data.BTree.Impure
@@ -26,87 +25,53 @@ import qualified Database.Haskey.Utils.STM.Map as Map
-- | Get a free page.
--
-- First try to get one from the in-memory dirty pages. Then try to get one
--- from the in-memory free page cache stored in 'writerReusablePages'. If that
--- one is empty, actually query one from the free database.
+-- from the in-memory free page cache stored in 'fileStateCachedFreePages'. If
+-- that one is empty, actually query one from the free database.
getFreePageId :: (Functor m, AllocM m, MonadIO m, MonadState (WriterEnv hnd) m)
=> S stateType ()
- -> m (Maybe SomeFreePage)
+ -> m (Maybe PageId)
getFreePageId t =
- runMaybeT $ (DirtyFreePage <$> MaybeT (getFreedDirtyPageId t))
- <|> (OldFreePage <$> MaybeT (getCachedFreePageId t))
- <|> (OldFreePage <$> MaybeT (queryNewFreePageIds t))
-
--- | Get a free'd dirty page.
---
--- Get a free'd dirty page, that is immediately suitable for reuse in the
--- current transaction.
-getFreedDirtyPageId :: (Functor m, MonadState (WriterEnv hnd) m)
- => S stateType ()
- -> m (Maybe DirtyFree)
-getFreedDirtyPageId stateType =
- case stateType of
- DataState () -> do
- s <- writerDataFileState <$> get
- let (pid, s') = query s DataState
- modify' $ \env -> env { writerDataFileState = s' }
- return pid
- IndexState () -> do
- s <- writerIndexFileState <$> get
- let (pid, s') = query s IndexState
- modify' $ \env -> env { writerIndexFileState = s' }
- return pid
- where
- query :: FileState t
- -> (forall a. a -> S t a)
- -> (Maybe DirtyFree, FileState t)
- query env cons =
- case S.minView (getSValue $ fileStateFreedDirtyPages env) of
- Nothing -> (Nothing, env)
- Just (pid, s') ->
- let env' = env { fileStateFreedDirtyPages = cons s' } in
- (Just pid, env')
+ runMaybeT $ MaybeT (getCachedFreePageId t)
+ <|> MaybeT (queryNewFreePageIds t)
-- | Get a cached free page.
--
--- Get a free page from the free database cache stored in 'writerReusablePages'.
+-- Get a free page from the free database cache stored in
+-- 'fileStateCachedFreePages'.
getCachedFreePageId :: (Functor m, MonadState (WriterEnv hnd) m)
=> S stateType ()
- -> m (Maybe OldFree)
+ -> m (Maybe PageId)
getCachedFreePageId stateType =
- ifM (not . writerReusablePagesOn <$> get) (return Nothing) $
case stateType of
DataState () -> do
s <- writerDataFileState <$> get
- let (pid, s') = query s
+ let (pid, s') = query DataState s
modify' $ \env -> env { writerDataFileState = s' }
return pid
IndexState () -> do
s <- writerIndexFileState <$> get
- let (pid, s') = query s
+ let (pid, s') = query IndexState s
modify' $ \env -> env { writerIndexFileState = s' }
return pid
where
- query :: FileState t -> (Maybe OldFree, FileState t)
- query env = case fileStateReusablePages env of
+ query :: (forall a. a -> S t a)
+ -> FileState t
+ -> (Maybe PageId, FileState t)
+ query cons env = case getSValue $ fileStateCachedFreePages env of
[] -> (Nothing, env)
- pid : pageIds ->
- let env' = env { fileStateReusablePages = pageIds } in
+ FreePage pid : pageIds ->
+ let env' = env { fileStateCachedFreePages = cons pageIds } in
(Just pid, env')
-- | Try to get a list of free pages from the free page database, return the
-- first free one for immediate use, and store the rest in the environment.
--
--- This function will delete the lastly used entry from the free database,
--- query a new one, and then update the free page cache in the state.
---
--- This function only works when 'writerReusablePagesOn' is 'True'.
---
--- This function expects 'writerReusablePages' to be empty.
+-- Immediately remove the queried free pages from the free tree.
queryNewFreePageIds :: (AllocM m, MonadIO m, MonadState (WriterEnv hnd) m)
=> S stateType ()
- -> m (Maybe OldFree)
-queryNewFreePageIds stateType = ifM (not . writerReusablePagesOn <$> get) (return Nothing) $
- case stateType of
+ -> m (Maybe PageId)
+queryNewFreePageIds stateType = ifM (not . writerQueryFreeTreeOn <$> get) (return Nothing) $ do
+ flag <- case stateType of
DataState () ->
query DataState
writerDataFileState
@@ -116,39 +81,40 @@ queryNewFreePageIds stateType = ifM (not . writerReusablePagesOn <$> get) (retur
query IndexState
writerIndexFileState
(\e s -> e { writerIndexFileState = s })
+
+ if flag then getFreePageId stateType
+ else return Nothing
where
query :: (AllocM m, MonadIO m, MonadState (WriterEnv hnd) m)
=> (forall a. a -> S t a)
-> (forall h. WriterEnv h -> FileState t)
-> (forall h. WriterEnv h -> FileState t -> WriterEnv h)
- -> m (Maybe OldFree)
+ -> m Bool
query cons getState setState = do
- tree <- gets $ getSValue . fileStateFreeTree . getState
- oldTxId <- gets $ fileStateReusablePagesTxId . getState
-
- -- Delete the previous used 'TxId' from the tree.
- modify' $ \e -> e { writerReusablePagesOn = False }
- tree' <- maybe (return tree) (`deleteSubtree` tree) oldTxId
- modify' $ \e -> e { writerReusablePagesOn = True }
-
- -- Set the new free tree
- modify' $ \e -> setState e $
- (getState e) { fileStateFreeTree = cons tree' }
+ tree <- gets $ getSValue . fileStateFreeTree . getState
-- Lookup the oldest free page
- lookupValidFreePageIds tree' >>= \case
- Nothing -> do
+ lookupValidFreePageIds tree >>= \case
+ Nothing -> return False
+ Just (txId, x :| xs) -> do
+ -- Save them for reuse
+ modify' $ \e ->
+ let s = getState e
+ pids = map FreePage (x:xs)
+ in setState e $
+ s { fileStateCachedFreePages =
+ cons $ pids ++ getSValue (fileStateCachedFreePages s) }
+
+ -- Remove the entry from the tree
+ modify' $ \e -> e { writerQueryFreeTreeOn = False }
+ tree' <- txId `deleteSubtree` tree
+ modify' $ \e -> e { writerQueryFreeTreeOn = True }
+
+ -- Update the tree
modify' $ \e -> setState e $
- (getState e) { fileStateDirtyReusablePages = S.empty
- , fileStateReusablePages = []
- , fileStateReusablePagesTxId = Nothing }
- return Nothing
- Just (txId, pid :| pageIds) -> do
- modify' $ \e -> setState e $
- (getState e) { fileStateDirtyReusablePages = S.empty
- , fileStateReusablePages = map OldFree pageIds
- , fileStateReusablePagesTxId = Just txId }
- return (Just $ OldFree pid)
+ (getState e) { fileStateFreeTree = cons tree' }
+
+ return True
-- | Lookup a list of free pages from the free page database, guaranteed to be old enough.
lookupValidFreePageIds :: (MonadIO m, AllocReaderM m, MonadState (WriterEnv hnd) m)
diff --git a/src/Database/Haskey/Alloc/Concurrent/FreePages/Save.hs b/src/Database/Haskey/Alloc/Concurrent/FreePages/Save.hs
index b708b8b..ec5f81f 100644
--- a/src/Database/Haskey/Alloc/Concurrent/FreePages/Save.hs
+++ b/src/Database/Haskey/Alloc/Concurrent/FreePages/Save.hs
@@ -15,12 +15,11 @@ saveFreePages :: AllocM m
-> FileState t
-> m FreeTree
saveFreePages tx env = saveNewlyFreedPages tx env tree
- >>= saveCachedFreePages env
where
tree = getSValue $ fileStateFreeTree env
-- | Save the newly free pages of the current transaction, as stored by
--- 'writerNewlyFreedPages'.
+-- 'fileStateNewlyFreedPages'.
saveNewlyFreedPages :: AllocM m
=> TxId
-> FileState t
@@ -32,18 +31,3 @@ saveNewlyFreedPages tx env tree =
x:xs -> replaceSubtree tx (x :| xs) tree
where
newlyFreed = map (\(NewlyFreed pid) -> pid) $ fileStateNewlyFreedPages env
-
--- | Save the free apges from the free page cache in
--- 'writerReusablePages' using 'writerReuseablePagesTxId'.
-saveCachedFreePages :: AllocM m
- => FileState t
- -> FreeTree
- -> m FreeTree
-saveCachedFreePages env tree = case fileStateReusablePagesTxId env of
- Nothing -> return tree
- Just k ->
- case freePages of
- [] -> deleteSubtree k tree
- x:xs -> replaceSubtree k (x :| xs) tree
- where
- freePages = map (\(OldFree pid) -> pid) $ fileStateReusablePages env
diff --git a/src/Database/Haskey/Alloc/Concurrent/Meta.hs b/src/Database/Haskey/Alloc/Concurrent/Meta.hs
index f882c33..606ad22 100644
--- a/src/Database/Haskey/Alloc/Concurrent/Meta.hs
+++ b/src/Database/Haskey/Alloc/Concurrent/Meta.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@@ -9,7 +10,7 @@ module Database.Haskey.Alloc.Concurrent.Meta where
import Data.Binary (Binary)
import Data.Proxy (Proxy)
-import Data.Set as Set
+import Data.Typeable (Typeable)
import GHC.Generics (Generic)
@@ -21,41 +22,52 @@ import Database.Haskey.Alloc.Concurrent.FreePages.Tree
import Database.Haskey.Alloc.Concurrent.Overflow
import Database.Haskey.Store
+-- | User-defined data root stored inside 'ConcurrentMeta'.
+--
+-- This can be a user-defined collection of 'Tree' roots.
+class Value root => Root root where
+
+instance (Key k, Value v) => Root (Tree k v) where
+
-- | Data type used to point to the most recent version of the meta data.
data CurrentMetaPage = Meta1 | Meta2
-- | Meta data of the page allocator.
-data ConcurrentMeta k v = ConcurrentMeta {
+--
+-- The @root@ type parameter should be a user-defined collection of 'Tree'
+-- roots, instantiating the 'Root' type class.
+--
+-- To store store a single tree, use @ConcurrentMeta (Tree k v)@.
+data ConcurrentMeta root = ConcurrentMeta {
concurrentMetaRevision :: TxId
, concurrentMetaDataNumPages :: S 'TypeData PageId
, concurrentMetaIndexNumPages :: S 'TypeIndex PageId
- , concurrentMetaTree :: Tree k v
+ , concurrentMetaRoot :: root
, concurrentMetaDataFreeTree :: S 'TypeData FreeTree
, concurrentMetaIndexFreeTree :: S 'TypeIndex FreeTree
, concurrentMetaOverflowTree :: OverflowTree
- , concurrentMetaDataFreshUnusedPages :: S 'TypeData (Set DirtyFree)
- , concurrentMetaIndexFreshUnusedPages :: S 'TypeIndex (Set DirtyFree)
- } deriving (Generic)
+ , concurrentMetaDataCachedFreePages :: S 'TypeData [FreePage]
+ , concurrentMetaIndexCachedFreePages :: S 'TypeIndex [FreePage]
+ } deriving (Generic, Typeable)
-deriving instance (Show k, Show v) => Show (ConcurrentMeta k v)
+deriving instance (Show root) => Show (ConcurrentMeta root)
-instance (Binary k, Binary v) => Binary (ConcurrentMeta k v) where
+instance (Binary root) => Binary (ConcurrentMeta root) where
-- | A class representing the storage requirements of the page allocator.
--
-- A store supporting the page allocator should be an instance of this class.
class StoreM FilePath m => ConcurrentMetaStoreM m where
-- | Write the meta-data structure to a certain page.
- putConcurrentMeta :: (Key k, Value v)
+ putConcurrentMeta :: Root root
=> FilePath
- -> ConcurrentMeta k v
+ -> ConcurrentMeta root
-> m ()
-- | Try to read the meta-data structure from a handle, or return 'Nothing'
-- if the handle doesn't contain a meta page.
- readConcurrentMeta :: (Key k, Value v)
+ readConcurrentMeta :: Root root
=> FilePath
- -> Proxy k
- -> Proxy v
- -> m (Maybe (ConcurrentMeta k v))
+ -> Proxy root
+ -> m (Maybe (ConcurrentMeta root))
diff --git a/src/Database/Haskey/Alloc/Concurrent/Monad.hs b/src/Database/Haskey/Alloc/Concurrent/Monad.hs
index b271564..5c2084c 100644
--- a/src/Database/Haskey/Alloc/Concurrent/Monad.hs
+++ b/src/Database/Haskey/Alloc/Concurrent/Monad.hs
@@ -31,7 +31,8 @@ import qualified Database.Haskey.Store.Class as Store
-- | All necessary database handles.
data ConcurrentHandles = ConcurrentHandles {
- concurrentHandlesData :: FilePath
+ concurrentHandlesRoot :: FilePath
+ , concurrentHandlesData :: FilePath
, concurrentHandlesIndex :: FilePath
, concurrentHandlesMetadata1 :: FilePath
, concurrentHandlesMetadata2 :: FilePath
@@ -41,7 +42,8 @@ data ConcurrentHandles = ConcurrentHandles {
-- | Construct a set of 'ConcurrentHandles' from a root directory.
concurrentHandles :: FilePath -> ConcurrentHandles
concurrentHandles fp = ConcurrentHandles {
- concurrentHandlesData = fp </> "data" </> "data"
+ concurrentHandlesRoot = fp
+ , concurrentHandlesData = fp </> "data" </> "data"
, concurrentHandlesIndex = fp </> "index" </> "index"
, concurrentHandlesMetadata1 = fp </> "meta" </> "1"
, concurrentHandlesMetadata2 = fp </> "meta" </> "2"
@@ -89,7 +91,7 @@ instance
hnd <- getWriterHnd height
pid <- getAndTouchPid
- let nid = pageIdToNodeId (getSomeFreePageId pid)
+ let nid = pageIdToNodeId pid
lift $ putNodePage hnd height nid n
return nid
where
@@ -112,14 +114,12 @@ instance
newTouchedPid = case viewHeight height of
UZero -> do
pid <- fileStateNewNumPages . writerDataFileState <$> get
- let pid' = FreshFreePage . Fresh <$> pid
- touchPage pid'
- return $ getSValue pid'
+ touchPage pid
+ return $ getSValue pid
USucc _ -> do
pid <- fileStateNewNumPages . writerIndexFileState <$> get
- let pid'' = FreshFreePage . Fresh <$> pid
- touchPage pid''
- return $ getSValue pid''
+ touchPage pid
+ return $ getSValue pid
freeNode height nid = case viewHeight height of
diff --git a/src/Database/Haskey/Alloc/Transaction.hs b/src/Database/Haskey/Alloc/Transaction.hs
index 1781a74..4b070a2 100644
--- a/src/Database/Haskey/Alloc/Transaction.hs
+++ b/src/Database/Haskey/Alloc/Transaction.hs
@@ -2,25 +2,24 @@
module Database.Haskey.Alloc.Transaction where
import Data.BTree.Alloc.Class
-import Data.BTree.Impure.Structures
-- | A committed or aborted transaction, with a return value of type @a@.
-data Transaction key val a =
- Commit (Tree key val) a
+data Transaction r a =
+ Commit r a
| Abort a
-- | Commit the new tree and return a computed value.
-commit :: AllocM n => a -> Tree key val -> n (Transaction key val a)
+commit :: AllocM n => a -> r -> n (Transaction r a)
commit v t = return $ Commit t v
-- | Commit the new tree, without return a computed value.
-commit_ :: AllocM n => Tree key val -> n (Transaction key val ())
+commit_ :: AllocM n => r -> n (Transaction r ())
commit_ = commit ()
-- | Abort the transaction and return a computed value.
-abort :: AllocM n => a -> n (Transaction key val a)
+abort :: AllocM n => a -> n (Transaction r a)
abort = return . Abort
-- | Abort the transaction, without returning a computed value.
-abort_ :: AllocM n => n (Transaction key val ())
+abort_ :: AllocM n => n (Transaction r ())
abort_ = return $ Abort ()
diff --git a/src/Database/Haskey/Store/Class.hs b/src/Database/Haskey/Store/Class.hs
index e574b36..12bb4b3 100644
--- a/src/Database/Haskey/Store/Class.hs
+++ b/src/Database/Haskey/Store/Class.hs
@@ -40,6 +40,12 @@ class (Applicative m, Monad m) => StoreM hnd m | m -> hnd where
-- | Open a database handle for reading and writing.
openHandle :: hnd -> m ()
+ -- | Obtain a lock on the given handle, so no other process can access it.
+ lockHandle :: hnd -> m ()
+
+ -- | Release the lock on the given handle, so other processes can access it.
+ releaseHandle :: hnd -> m ()
+
-- | Flush the contents of a handle to disk (or other storage).
flushHandle :: hnd -> m ()
@@ -118,6 +124,8 @@ class (Applicative m, Monad m) => StoreM hnd m | m -> hnd where
instance StoreM hnd m => StoreM hnd (StateT s m) where
openHandle = lift. openHandle
+ lockHandle = lift. lockHandle
+ releaseHandle = lift. releaseHandle
flushHandle = lift. flushHandle
closeHandle = lift. closeHandle
removeHandle = lift. closeHandle
@@ -133,6 +141,8 @@ instance StoreM hnd m => StoreM hnd (StateT s m) where
instance StoreM hnd m => StoreM hnd (ReaderT s m) where
openHandle = lift. openHandle
+ lockHandle = lift. lockHandle
+ releaseHandle = lift. releaseHandle
flushHandle = lift. flushHandle
closeHandle = lift. closeHandle
removeHandle = lift. closeHandle
diff --git a/src/Database/Haskey/Store/File.hs b/src/Database/Haskey/Store/File.hs
index a53ea10..e494116 100644
--- a/src/Database/Haskey/Store/File.hs
+++ b/src/Database/Haskey/Store/File.hs
@@ -13,13 +13,11 @@
module Database.Haskey.Store.File (
-- * Storage
Page(..)
-, Files
, FileStoreConfig(..)
, defFileStoreConfig
, fileStoreConfigWithPageSize
, FileStoreT
, runFileStoreT
-, newFileStore
-- * Binary encoding
, encodeAndPad
@@ -36,13 +34,13 @@ import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Reader
+import Control.Monad.State.Class
+import Control.Monad.Trans.State.Strict ( StateT, evalStateT)
-import Data.Coerce (coerce)
import Data.Map (Map)
import Data.Maybe (fromJust)
import Data.Monoid ((<>))
-import Data.IORef
-import Data.Typeable (Typeable)
+import Data.Typeable (Typeable, cast)
import Data.Word (Word64)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M
@@ -85,22 +83,10 @@ encodeAndPad size page
--
-- Each file is a 'Handle' opened in 'System.IO.ReadWriteMode' and contains a
-- collection of physical pages.
---
--- These files can be safely shared between threads.
-type Files fp = IORef (Map fp IO.FHandle)
-
--- | Access the files.
-get :: MonadIO m => FileStoreT fp m (Map fp IO.FHandle)
-get = FileStoreT . lift $ ask >>= liftIO . readIORef
-
--- | Modify the files.
-modify' :: MonadIO m
- => (Map fp IO.FHandle -> Map fp IO.FHandle)
- -> FileStoreT fp m ()
-modify' f = FileStoreT . lift $ ask >>= liftIO . flip modifyIORef' f
+type Files fp = Map fp IO.FHandle
lookupHandle :: (Functor m, MonadThrow m, Ord fp, Show fp, Typeable fp)
- => fp -> Map fp IO.FHandle -> m IO.FHandle
+ => fp -> Files fp -> m IO.FHandle
lookupHandle fp m = justErrM (FileNotFoundError fp) $ M.lookup fp m
-- | Monad in which on-disk storage operations can take place.
@@ -109,10 +95,10 @@ lookupHandle fp m = justErrM (FileNotFoundError fp) $ M.lookup fp m
-- 'ConcurrentMetaStoreM' making it a storage back-end compatible with the
-- concurrent page allocator.
newtype FileStoreT fp m a = FileStoreT
- { fromFileStoreT :: ReaderT FileStoreConfig (ReaderT (Files fp) m) a
+ { fromFileStoreT :: ReaderT FileStoreConfig (StateT (Files fp) m) a
} deriving (Applicative, Functor, Monad,
MonadIO, MonadThrow, MonadCatch, MonadMask,
- MonadReader FileStoreConfig)
+ MonadReader FileStoreConfig, MonadState (Files fp))
-- | File store configuration.
--
@@ -152,15 +138,11 @@ fileStoreConfigWithPageSize pageSize
-- | Run the storage operations in the 'FileStoreT' monad, given a collection of
-- open files.
-runFileStoreT :: FileStoreT fp m a -- ^ Action
+runFileStoreT :: Monad m
+ => FileStoreT FilePath m a -- ^ Action
-> FileStoreConfig -- ^ Configuration
- -> Files fp -- ^ Open files
-> m a
-runFileStoreT m config = runReaderT (runReaderT (fromFileStoreT m) config)
-
--- | An empty file store, with no open files.
-newFileStore :: IO (Files fp)
-newFileStore = newIORef M.empty
+runFileStoreT m config = evalStateT (runReaderT (fromFileStoreT m) config) M.empty
--------------------------------------------------------------------------------
@@ -172,7 +154,11 @@ instance (Applicative m, Monad m, MonadIO m, MonadThrow m) =>
unless alreadyOpen $ do
liftIO $ createDirectoryIfMissing True (takeDirectory fp)
fh <- liftIO $ IO.openReadWrite fp
- modify' $ M.insert fp fh
+ modify $ M.insert fp fh
+
+ lockHandle = void . liftIO . IO.obtainPrefixLock
+
+ releaseHandle = liftIO . IO.releasePrefixLock . IO.prefixLockFromPrefix
flushHandle fp = do
fh <- get >>= lookupHandle fp
@@ -182,7 +168,7 @@ instance (Applicative m, Monad m, MonadIO m, MonadThrow m) =>
fh <- get >>= lookupHandle fp
liftIO $ IO.flush fh
liftIO $ IO.close fh
- modify' (M.delete fp)
+ modify (M.delete fp)
removeHandle fp =
liftIO $ removeFile fp `catchIOError` \e ->
@@ -264,14 +250,14 @@ instance (Applicative m, Monad m, MonadIO m, MonadCatch m) =>
liftIO $ IO.seek h 0
liftIO $ writeLazyByteString h bs
- readConcurrentMeta fp k v = do
+ readConcurrentMeta fp root = do
fh <- get >>= lookupHandle fp
len <- liftIO $ IO.getFileSize fh
liftIO $ IO.seek fh 0
bs <- liftIO $ readByteString fh (fromIntegral len)
- handle handle' (Just <$> decodeM (concurrentMetaPage k v) bs) >>= \case
- Just (ConcurrentMetaPage meta) -> return $ Just (coerce meta)
+ handle handle' (Just <$> decodeM (concurrentMetaPage root) bs) >>= \case
+ Just (ConcurrentMetaPage meta) -> return $! cast meta
Nothing -> return Nothing
where
handle' (DecodeError _) = return Nothing
diff --git a/src/Database/Haskey/Store/InMemory.hs b/src/Database/Haskey/Store/InMemory.hs
index b9b03e6..138e083 100644
--- a/src/Database/Haskey/Store/InMemory.hs
+++ b/src/Database/Haskey/Store/InMemory.hs
@@ -30,6 +30,7 @@ module Database.Haskey.Store.InMemory (
) where
import Control.Applicative (Applicative, (<$>))
+import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
@@ -37,11 +38,9 @@ import Control.Monad.Reader
import Data.ByteString (ByteString)
import Data.ByteString.Lazy (toStrict)
-import Data.Coerce
-import Data.IORef
import Data.Map (Map)
import Data.Maybe (fromJust)
-import Data.Typeable (Typeable)
+import Data.Typeable (Typeable, cast)
import Data.Word (Word64)
import qualified Data.Map as M
@@ -61,11 +60,11 @@ type MemoryFile = Map PageId ByteString
-- | A collection of 'File's, each associated with a certain @fp@ handle.
--
-- This is shareable amongst multiple threads.
-type MemoryFiles fp = IORef (Map fp MemoryFile)
+type MemoryFiles fp = MVar (Map fp MemoryFile)
-- | Access the files.
get :: MonadIO m => MemoryStoreT fp m (Map fp MemoryFile)
-get = MemoryStoreT . lift $ ask >>= liftIO . readIORef
+get = MemoryStoreT . lift $ ask >>= liftIO . readMVar
-- | Access the files.
gets :: (Functor m, MonadIO m)
@@ -77,7 +76,7 @@ gets f = f <$> get
modify' :: MonadIO m =>
(Map fp MemoryFile -> Map fp MemoryFile)
-> MemoryStoreT fp m ()
-modify' f = MemoryStoreT . lift $ ask >>= liftIO . flip modifyIORef' f
+modify' f = MemoryStoreT . lift $ ask >>= liftIO . flip modifyMVar_ (return . f)
lookupFile :: (MonadThrow m, Ord fp, Show fp, Typeable fp)
=> fp -> Map fp MemoryFile -> m MemoryFile
@@ -145,7 +144,7 @@ runMemoryStoreT m config = runReaderT (runReaderT (fromMemoryStoreT m) config)
-- | Construct a store with an empty database with name of type @hnd@.
newEmptyMemoryStore :: IO (MemoryFiles hnd)
-newEmptyMemoryStore = newIORef M.empty
+newEmptyMemoryStore = newMVar M.empty
--------------------------------------------------------------------------------
@@ -154,7 +153,11 @@ instance (Applicative m, Monad m, MonadIO m, MonadThrow m,
StoreM fp (MemoryStoreT fp m)
where
openHandle fp =
- modify' $ M.insertWith (flip const) fp M.empty
+ modify' $ M.insertWith (\_new old -> old) fp M.empty
+
+ lockHandle _ = return ()
+
+ releaseHandle _ = return ()
flushHandle _ = return ()
@@ -207,11 +210,14 @@ instance (Applicative m, Monad m, MonadIO m, MonadCatch m) =>
where
pg = toStrict . encode $ ConcurrentMetaPage meta
- readConcurrentMeta hnd k v = do
- Just bs <- gets (M.lookup hnd >=> M.lookup 0)
- handle handle' (Just <$> decodeM (concurrentMetaPage k v) bs) >>= \case
- Just (ConcurrentMetaPage meta) -> return . Just $! coerce meta
+ readConcurrentMeta hnd root = do
+ maybeBs <- gets (M.lookup hnd >=> M.lookup 0)
+ case maybeBs of
Nothing -> return Nothing
+ Just bs ->
+ handle handle' (Just <$> decodeM (concurrentMetaPage root) bs) >>= \case
+ Just (ConcurrentMetaPage meta) -> return $! cast meta
+ Nothing -> return Nothing
where
handle' (DecodeError _) = return Nothing
diff --git a/src/Database/Haskey/Store/Page.hs b/src/Database/Haskey/Store/Page.hs
index c6e1ddf..bb5cf5f 100644
--- a/src/Database/Haskey/Store/Page.hs
+++ b/src/Database/Haskey/Store/Page.hs
@@ -70,8 +70,8 @@ instance Binary PageType where
-- | A decoded page, of a certain type @t@ of kind 'PageType'.
data Page (t :: PageType) where
EmptyPage :: Page 'TypeEmpty
- ConcurrentMetaPage :: (Key k, Value v)
- => ConcurrentMeta k v
+ ConcurrentMetaPage :: Root root
+ => ConcurrentMeta root
-> Page 'TypeConcurrentMeta
OverflowPage :: (Value v)
=> v
@@ -230,16 +230,15 @@ overflowPage v = SGet STypeOverflow $ get >>= \case
get' :: (Value v) => Proxy v -> Get v
get' _ = get
-concurrentMetaPage :: (Key k, Value v)
- => Proxy k
- -> Proxy v
+concurrentMetaPage :: Root root
+ => Proxy root
-> SGet 'TypeConcurrentMeta
-concurrentMetaPage k v = SGet STypeConcurrentMeta $ get >>= \ case
- TypeConcurrentMeta -> ConcurrentMetaPage <$> get' k v
+concurrentMetaPage root = SGet STypeConcurrentMeta $ get >>= \ case
+ TypeConcurrentMeta -> ConcurrentMetaPage <$> get' root
x -> fail $ "unexpected " ++ show x ++ " while decoding TypeConcurrentMeta"
where
- get' :: (Key k, Value v) => Proxy k -> Proxy v -> Get (ConcurrentMeta k v)
- get' _ _ = get
+ get' :: Root root => Proxy root -> Get (ConcurrentMeta root)
+ get' _ = get
-- | Exception thrown when decoding of a page fails.
newtype DecodeError = DecodeError String deriving (Show, Typeable)
diff --git a/tests/Integration.hs b/tests/Integration.hs
index 202bd8c..42b5fb8 100644
--- a/tests/Integration.hs
+++ b/tests/Integration.hs
@@ -4,11 +4,13 @@ module Main (main) where
import Test.Framework (Test, defaultMain)
+import qualified Integration.CreateAndOpen
import qualified Integration.WriteOpenRead.Concurrent
tests :: [Test]
tests =
- [ Integration.WriteOpenRead.Concurrent.tests
+ [ Integration.CreateAndOpen.tests
+ , Integration.WriteOpenRead.Concurrent.tests
]
main :: IO ()
diff --git a/tests/Integration/CreateAndOpen.hs b/tests/Integration/CreateAndOpen.hs
new file mode 100644
index 0000000..93c68ed
--- /dev/null
+++ b/tests/Integration/CreateAndOpen.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Integration.CreateAndOpen where
+
+import Test.Framework (Test, testGroup)
+import Test.Framework.Providers.HUnit (testCase)
+import Test.HUnit hiding (Test, Node)
+
+import Control.Applicative ((<$>))
+
+import Data.Binary (Binary)
+import Data.Maybe (fromJust)
+import Data.Typeable (Typeable)
+
+import System.Directory (removeDirectoryRecursive,
+ getTemporaryDirectory, doesDirectoryExist,
+ writable, getPermissions)
+import System.IO.Temp (createTempDirectory)
+
+import Data.BTree.Primitives (Value)
+
+import Database.Haskey.Alloc.Concurrent
+import Database.Haskey.Store.File
+
+tests :: Test
+tests = testGroup "CreateAndOpen"
+ [ testCase "file backend" case_file_backend
+ ]
+
+case_file_backend :: Assertion
+case_file_backend = do
+ exists <- doesDirectoryExist "/var/run/shm"
+ w <- if exists then writable <$> getPermissions "/var/run/shm"
+ else return False
+ tmpDir <- if w then return "/var/run/shm"
+ else getTemporaryDirectory
+ fp <- createTempDirectory tmpDir "db.haskey"
+ let hnds = concurrentHandles fp
+
+ _ <- create hnds
+ root' <- open hnds
+
+ removeDirectoryRecursive fp
+
+ assertEqual "should've read back initial root" (Just root) root'
+ where
+ create :: ConcurrentHandles -> IO (ConcurrentDb TestRoot)
+ create hnds = runFileStoreT (createConcurrentDb hnds root) config
+
+ open :: ConcurrentHandles -> IO (Maybe TestRoot)
+ open hnds = do
+ maybeDb <- runFileStoreT (openConcurrentDb hnds) config
+ case maybeDb of
+ Nothing -> return Nothing
+ Just db -> Just <$> runFileStoreT (transactReadOnly return db) config
+
+ config = fromJust $ fileStoreConfigWithPageSize 256
+
+ root = TestRoot "Hello World!"
+
+newtype TestRoot = TestRoot String deriving (Binary, Eq, Value, Show, Typeable)
+
+instance Root TestRoot where
diff --git a/tests/Integration/WriteOpenRead/Concurrent.hs b/tests/Integration/WriteOpenRead/Concurrent.hs
index 82ce6de..4214178 100644
--- a/tests/Integration/WriteOpenRead/Concurrent.hs
+++ b/tests/Integration/WriteOpenRead/Concurrent.hs
@@ -61,6 +61,8 @@ case_bad_seed = do
gen = (mkQCGen seed, seed)
args = stdArgs { replay = Just gen }
+type Root' = Tree Integer TestValue
+
prop_memory_backend :: PropertyM IO ()
prop_memory_backend = forAllM (genTestSequence False) $ \(TestSequence txs) -> do
files <- run newEmptyMemoryStore
@@ -71,7 +73,7 @@ prop_memory_backend = forAllM (genTestSequence False) $ \(TestSequence txs) -> d
return ()
where
- writeReadTest :: ConcurrentDb Integer TestValue
+ writeReadTest :: ConcurrentDb Root'
-> MemoryFiles String
-> Map Integer TestValue
-> TestTransaction Integer TestValue
@@ -87,8 +89,8 @@ prop_memory_backend = forAllM (genTestSequence False) $ \(TestSequence txs) -> d
++ "\n expectd: " ++ show (M.toList expected)
++ "\n got: " ++ show read'
- create :: MemoryFiles String -> IO (ConcurrentDb Integer TestValue)
- create = runMemoryStoreT (createConcurrentDb hnds) config
+ create :: MemoryFiles String -> IO (ConcurrentDb Root')
+ create = runMemoryStoreT (createConcurrentDb hnds Tree.empty) config
where
hnds = concurrentHandles ""
@@ -109,29 +111,25 @@ prop_file_backend = forAllM (genTestSequence True) $ \(TestSequence txs) -> do
tmpDir <- if w then return "/var/run/shm"
else run getTemporaryDirectory
fp <- run $ createTempDirectory tmpDir "db.haskey"
-
let hnds = concurrentHandles fp
- files <- run newFileStore
- db <- run $ create files hnds
- result <- run . runMaybeT $ foldM (writeReadTest db files)
+
+ db <- run $ create hnds
+ result <- run . runMaybeT $ foldM (writeReadTest db)
M.empty
txs
- _ <- run $ runFileStoreT (closeConcurrentHandles hnds) config files
-
run $ removeDirectoryRecursive fp
assert $ isJust result
where
- writeReadTest :: ConcurrentDb Integer TestValue
- -> Files FilePath
+ writeReadTest :: ConcurrentDb Root'
-> Map Integer TestValue
-> TestTransaction Integer TestValue
-> MaybeT IO (Map Integer TestValue)
- writeReadTest db files m tx = do
- _ <- lift $ void (openAndWrite db files tx) `catch`
+ writeReadTest db m tx = do
+ _ <- lift $ void (openAndWrite db tx) `catch`
\TestException -> return ()
- read' <- lift $ openAndRead db files
+ read' <- lift $ openAndRead db
let expected = fromMaybe m $ testTransactionResult m tx
if read' == M.toList expected
then return expected
@@ -140,22 +138,20 @@ prop_file_backend = forAllM (genTestSequence True) $ \(TestSequence txs) -> do
++ "\n expectd: " ++ show (M.toList expected)
++ "\n got: " ++ show read'
- create :: Files FilePath
- -> ConcurrentHandles
- -> IO (ConcurrentDb Integer TestValue)
- create files hnds = runFileStoreT (createConcurrentDb hnds) config files
+ create :: ConcurrentHandles
+ -> IO (ConcurrentDb Root')
+ create hnds = runFileStoreT (createConcurrentDb hnds Tree.empty) config
+
- openAndRead :: ConcurrentDb Integer TestValue
- -> Files FilePath
+ openAndRead :: ConcurrentDb Root'
-> IO [(Integer, TestValue)]
openAndRead db = runFileStoreT (readAll db) config
- openAndWrite :: ConcurrentDb Integer TestValue
- -> Files FilePath
+ openAndWrite :: ConcurrentDb Root'
-> TestTransaction Integer TestValue
-> IO ()
- openAndWrite db files tx =
- runFileStoreT (void $ writeTransaction tx db) config files
+ openAndWrite db tx =
+ runFileStoreT (void $ writeTransaction tx db) config
config = fromJust $ fileStoreConfigWithPageSize 256
@@ -163,7 +159,7 @@ prop_file_backend = forAllM (genTestSequence True) $ \(TestSequence txs) -> do
writeTransaction :: (MonadIO m, MonadMask m, ConcurrentMetaStoreM m, Key k, Value v)
=> TestTransaction k v
- -> ConcurrentDb k v
+ -> ConcurrentDb (Tree k v)
-> m ()
writeTransaction (TestTransaction txType actions) =
transaction
@@ -177,13 +173,13 @@ writeTransaction (TestTransaction txType actions) =
foldl (>=>) return (map writeAction actions)
>=> commitOrAbort
- commitOrAbort :: (AllocM n, MonadMask n) => Tree key val -> n (Transaction key val ())
+ commitOrAbort :: (AllocM n, MonadMask n) => root -> n (Transaction root ())
commitOrAbort
| TxAbort <- txType = const abort_
| TxCommit <- txType = commit_
readAll :: (MonadIO m, MonadMask m, ConcurrentMetaStoreM m, Key k, Value v)
- => ConcurrentDb k v
+ => ConcurrentDb (Tree k v)
-> m [(k, v)]
readAll = transactReadOnly Tree.toList