haskey 0.1.0.1 → 0.2.0.0

raw patch · 18 files changed

+515/−454 lines, 18 filesdep +randomdep ~haskey-btreePVP ok

version bump matches the API change (PVP)

Dependencies added: random

Dependency ranges changed: haskey-btree

API changes (from Hackage documentation)

Files

• example/Main.hs +103/−33
• haskey.cabal +14/−7
• src-unix/FileIO.hs +8/−3
• src/Database/Haskey/Alloc/Concurrent.hs +3/−0
• src/Database/Haskey/Alloc/Concurrent/Database.hs +95/−89
• src/Database/Haskey/Alloc/Concurrent/Environment.hs +62/−115
• src/Database/Haskey/Alloc/Concurrent/FreePages/Query.hs +44/−78
• src/Database/Haskey/Alloc/Concurrent/FreePages/Save.hs +1/−17
• src/Database/Haskey/Alloc/Concurrent/Meta.hs +26/−14
• src/Database/Haskey/Alloc/Concurrent/Monad.hs +9/−9
• src/Database/Haskey/Alloc/Transaction.hs +6/−7
• src/Database/Haskey/Store/Class.hs +10/−0
• src/Database/Haskey/Store/File.hs +19/−33
• src/Database/Haskey/Store/InMemory.hs +18/−12
• src/Database/Haskey/Store/Page.hs +8/−9
• tests/Integration.hs +3/−1
• tests/Integration/CreateAndOpen.hs +63/−0
• tests/Integration/WriteOpenRead/Concurrent.hs +23/−27

@@ -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_ -writer :: Files FilePath-       -> ConcurrentDb Int32 ByteString-       -> Int32-       -> IO ()-writer store db i =-    runDatabase store $ transact_ tx db+    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++    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)+    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_+        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+    reader :: ConcurrentDb Root+           -> Int+           -> IO ()+    reader db delay = void $ replicateM 10 $ do+        threadDelay delay+        runDatabase $ 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+    openOrCreate :: IO (ConcurrentDb Root)+    openOrCreate = runDatabase $ do+        maybeDb <- openConcurrentDb handles+        case maybeDb of+            Nothing -> createConcurrentDb handles Tree.empty+            Just db -> return db -runDatabase :: Files FilePath-            -> FileStoreT FilePath m a-            -> m a-runDatabase files action = runFileStoreT action defFileStoreConfig files+    runDatabase :: Monad m+                => FileStoreT FilePath m a+                -> m a+    runDatabase action = runFileStoreT action defFileStoreConfig -handles :: ConcurrentHandles-handles = concurrentHandles "example-database.haskey"+    handles :: ConcurrentHandles+    handles = concurrentHandles root

@@ -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 @@     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-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 @@   main-is:             Integration.hs   type:                exitcode-stdio-1.0   other-modules:+    Integration.CreateAndOpen     Integration.WriteOpenRead.Concurrent     Integration.WriteOpenRead.Transactions @@ -126,17 +127,20 @@     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 @@     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

@@ -11,9 +11,10 @@   , seek   , setFileSize   , getFileSize+  , PrefixLock+  , prefixLockFromPrefix   , obtainPrefixLock   , releasePrefixLock-  , PrefixLock ) where  import Prelude hiding (read)@@ -52,6 +53,9 @@  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 @@ --    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"

@@ -7,6 +7,8 @@   -- * Open, close and create databases , ConcurrentHandles(..) , concurrentHandles+, lockConcurrentDb+, unlockConcurrentDb , createConcurrentDb , openConcurrentDb , closeConcurrentHandles@@ -18,6 +20,7 @@ , transactReadOnly    -- * Storage requirements+, Root , ConcurrentMeta(..) , ConcurrentMetaStoreM(..) ) where

@@ -10,14 +10,13 @@ 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 @@ -- | 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 @@     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 @@         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 @@     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 @@         }  -- | 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 @@         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 @@                 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 @@                 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 @@ -- | 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 @@       , 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 @@                                              readers                                              (concurrentMetaDataNumPages meta)                                              (concurrentMetaIndexNumPages meta)-                                             (concurrentMetaDataFreshUnusedPages meta)-                                             (concurrentMetaIndexFreshUnusedPages meta)+                                             (concurrentMetaDataCachedFreePages meta)+                                             (concurrentMetaIndexCachedFreePages meta)                                              (concurrentMetaDataFreeTree meta)                                              (concurrentMetaIndexFreeTree meta) @@ -281,7 +313,7 @@                     saveFreePages' 0 IndexState                                      writerIndexFileState                                      (\e s -> e { writerIndexFileState = s })-                    handleFreedDirtyPages+                    handleCachedFreePages                  -- Commit                 setCurrentMeta (newMeta { concurrentMetaRevision = newRevision })@@ -328,7 +360,7 @@         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 @@  -- | 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 @@                -> (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 @@     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 @@                             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) 

@@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}@@ -15,6 +16,7 @@  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 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 @@     -- '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 @@     , 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 @@  -- | 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' 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+-- | Wrapper around 'PageId' indicating it is free and can be reused in any+-- transaction.+newtype FreePage = FreePage PageId deriving (Binary, Eq, Ord, Show) -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 @@ -- | 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-  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+    DataState p  -> (page p . fileStateDirtyPages . writerDataFileState) <$> get+    IndexState p -> (page p . fileStateDirtyPages . 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 :: 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 (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 (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)

@@ -11,7 +11,6 @@  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 @@ -- | 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 @@             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+        tree <- gets $ getSValue . fileStateFreeTree . 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 }+        -- Lookup the oldest free page+        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) } -        -- Set the new free tree-        modify' $ \e -> setState e $-            (getState e) { fileStateFreeTree = cons tree' }+                -- Remove the entry from the tree+                modify' $ \e -> e { writerQueryFreeTreeOn = False }+                tree' <- txId `deleteSubtree` tree+                modify' $ \e -> e { writerQueryFreeTreeOn = True } -        -- Lookup the oldest free page-        lookupValidFreePageIds tree' >>= \case-            Nothing -> do-                modify' $ \e -> setState e $-                    (getState e) { fileStateDirtyReusablePages = S.empty-                                 , fileStateReusablePages = []-                                 , fileStateReusablePagesTxId = Nothing }-                return Nothing-            Just (txId, pid :| pageIds) -> do+                -- Update the tree                 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)

@@ -15,12 +15,11 @@               -> 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 @@         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

@@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -9,7 +10,7 @@  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.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)) 

@@ -31,7 +31,8 @@  -- | All necessary database handles. data ConcurrentHandles = ConcurrentHandles {-    concurrentHandlesData :: FilePath+    concurrentHandlesRoot :: FilePath+  , concurrentHandlesData :: FilePath   , concurrentHandlesIndex :: FilePath   , concurrentHandlesMetadata1 :: FilePath   , concurrentHandlesMetadata2 :: FilePath@@ -41,7 +42,8 @@ -- | 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 @@         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 @@         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

@@ -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 ()

@@ -40,6 +40,12 @@     -- | 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 @@  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 (ReaderT s m) where     openHandle    = lift.             openHandle+    lockHandle    = lift.             lockHandle+    releaseHandle = lift.             releaseHandle     flushHandle   = lift.             flushHandle     closeHandle   = lift.             closeHandle     removeHandle  = lift.             closeHandle

@@ -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.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 @@ -- -- 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 @@ -- '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 @@  -- | 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,8 +154,12 @@         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         liftIO $ IO.flush fh@@ -182,7 +168,7 @@         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 @@         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

@@ -30,6 +30,7 @@ ) 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 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 @@ -- | 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 @@ 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 @@  -- | 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,8 +153,12 @@     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 ()      closeHandle _ = return ()@@ -207,11 +210,14 @@       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 

@@ -70,8 +70,8 @@ -- | 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 @@     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)

@@ -4,11 +4,13 @@  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 ()

@@ -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

@@ -61,6 +61,8 @@     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 @@     return ()   where -    writeReadTest :: ConcurrentDb Integer TestValue+    writeReadTest :: ConcurrentDb Root'                   -> MemoryFiles String                   -> Map Integer TestValue                   -> TestTransaction Integer TestValue@@ -87,8 +89,8 @@                     ++ "\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 @@     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 @@                     ++ "\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 @@  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 @@         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