Don't explicitly keep track of file size in file store

src/Data/BTree/Alloc/Concurrent/Database.hs

@@ -158,8 +158,7 @@ transact act db
     , ConcurrentHandles
       { concurrentHandlesMain = hnd
       } <- hnds
-    = withLock lock $
-    do
+    = withLock lock $ do
     meta <- liftIO . atomically $ getCurrentMeta db
     let newRevision = concurrentMetaRevision meta + 1
     let wEnv = WriterEnv { writerHnd = hnd
@@ -234,7 +233,7 @@ transactReadOnly act db
       } <- hnds
     = do
     meta <- liftIO . atomically $ do
-        meta <-getCurrentMeta db
+        meta <- getCurrentMeta db
         Map.alter (concurrentMetaRevision meta) addOne readers
         return meta
     v <- evalConcurrentT (act $ concurrentMetaTree meta) (ReaderEnv hnd)

src/Data/BTree/Alloc/Concurrent/Monad.hs

@@ -56,12 +56,11 @@ instance (ConcurrentMetaStoreM hnd m, MonadIO m) => AllocM (ConcurrentT WriterEn
         return nid
       where
         getNid = getFreeNodeId >>= \case
-            Just nid -> return nid
-            Nothing -> do
+            --Just nid -> error "got free node id"
+            _ -> do
                 hnd <- writerHnd <$> get
-                pc  <- lift $ getSize hnd
-                lift $ setSize hnd (pc + 1)
-                return $! NodeId (fromPageCount pc)
+                pid <- lift $ newPageId hnd
+                return $! pageIdToNodeId pid
 
     writeNode nid height n = ConcurrentT $ do
         hnd <- writerHnd <$> get

src/Data/BTree/Store/Binary.hs

@@ -102,13 +102,9 @@ instance (Show fp, Ord fp, Applicative m, Monad m) =>
 
     maxPageSize = return 128
 
-    setSize fp (PageCount n) = do
-        let emptyFile = M.fromList
-                        [ (PageId i, encode EmptyPage)
-                        | i <- [0..n-1]
-                        ]
-            res file  = M.intersection (M.union file emptyFile) emptyFile
-        modify (M.update (Just . res) fp)
+    newPageId hnd = do
+        m <- get >>= lookupFile hnd
+        return $ fromIntegral (M.size m)
 
     getNodePage hnd h key val nid = do
         bs <- get >>= lookupPage hnd (nodeIdToPageId nid)
@@ -122,10 +118,6 @@ instance (Show fp, Ord fp, Applicative m, Monad m) =>
       where
         pg = encode $ NodePage height node
 
-    getSize hnd = do
-        m <- get >>= lookupFile hnd
-        return $ fromIntegral (M.size m)
-
 --------------------------------------------------------------------------------
 
 instance (Ord fp, Show fp, Applicative m, Monad m) =>

src/Data/BTree/Store/Class.hs

@@ -33,11 +33,8 @@ class (Applicative m, Monad m) => StoreM hnd m | m -> hnd where
     {-| The maximum page size the allocator can handle. -}
     maxPageSize  :: m PageSize
 
-    {-| Directly set the amount of available physical pages. -}
-    setSize      :: hnd -> PageCount -> m ()
-
-    {-| Get the amount of physical available pages. -}
-    getSize      :: hnd -> m PageCount
+    {-| Get a new unused fresh 'PageId' from the end of the file. -}
+    newPageId    :: hnd -> m PageId
 
     {-| Read a page and return the actual node and the transaction id when the
        node was written. -}
@@ -62,8 +59,7 @@ instance StoreM hnd m => StoreM hnd (StateT s m) where
     closeHandle  = lift.             closeHandle
     nodePageSize = lift              nodePageSize
     maxPageSize  = lift              maxPageSize
-    setSize      = (lift.).          setSize
-    getSize      = lift.             getSize
+    newPageId    = lift.             newPageId
     getNodePage  = ((((lift.).).).). getNodePage
     putNodePage  = (((lift.).).).    putNodePage
 
@@ -72,8 +68,7 @@ instance StoreM hnd m => StoreM hnd (ReaderT s m) where
     closeHandle  = lift.             closeHandle
     nodePageSize = lift              nodePageSize
     maxPageSize  = lift              maxPageSize
-    setSize      = (lift.).          setSize
-    getSize      = lift.             getSize
+    newPageId    = lift.             newPageId
     getNodePage  = ((((lift.).).).). getNodePage
     putNodePage  = (((lift.).).).    putNodePage
 

src/Data/BTree/Store/File.hs

@@ -65,21 +65,12 @@ encodeAndPad size page
 --
 -- Each file is a 'Handle' opened in 'System.IO.ReadWriteMode' and contains a
 -- collection of physical pages.
-type Files fp = Map fp (Handle, PageCount)
+type Files fp = Map fp Handle
 
-getFileHandle :: (Handle, PageCount) -> Handle
-getFileHandle = fst
-
-getFilePageCount :: (Handle, PageCount) -> PageCount
-getFilePageCount = snd
-
-lookupFile :: (Ord fp, Show fp, MonadError String m)
-           => fp -> Files fp -> m (Handle, PageCount)
-lookupFile fp m = justErrM ("no file for handle " ++ show fp) $ M.lookup fp m
 
 lookupHandle :: (Ord fp, Show fp, Functor m, MonadError String m)
              => fp -> Files fp -> m Handle
-lookupHandle fp m = getFileHandle <$> lookupFile fp m
+lookupHandle fp m = justErrM ("no file for handle " ++ show fp) $ M.lookup fp m
 
 -- | Monad in which on-disk storage operations can take place.
 --
@@ -116,15 +107,9 @@ instance (Applicative m, Monad m, MonadIO m) =>
   where
     openHandle fp = do
         alreadyOpen <- M.member fp <$> get
-        pageSize    <- maxPageSize
         unless alreadyOpen $ do
-            -- Open the file in rw mode
             fh <- liftIO $ openFile fp ReadWriteMode
-
-            -- Calculate the number of pages
-            fs     <- liftIO $ hFileSize fh
-            let pc = fs `quot` fromIntegral pageSize
-            modify $ M.insert fp (fh, fromIntegral pc)
+            modify $ M.insert fp fh
 
     closeHandle fp = do
         fh <- get >>= lookupHandle fp
@@ -137,13 +122,15 @@ instance (Applicative m, Monad m, MonadIO m) =>
 
     maxPageSize = return 512
 
-    getSize fp = do
-        f <- get >>= lookupFile fp
-        return (getFilePageCount f)
+    newPageId fp = do
+        fh <- get >>= lookupHandle fp
+        fs <- liftIO $ hFileSize fh
+        ps <- fromIntegral <$> maxPageSize
 
-    setSize fp pc = do
-        h <- get >>= lookupHandle fp
-        modify (M.insert fp (h, pc))
+        let n = fs `div` ps
+        case fs `rem` ps of
+            0 -> return (fromIntegral n)
+            _ -> return (fromIntegral n + 1)
 
     getNodePage fp height key val nid = do
         h    <- get >>= lookupHandle fp

tests/Integration/WriteOpenRead/Concurrent.hs

@@ -90,25 +90,28 @@ prop_file_backend = forAllM genTestSequence $ \(TestSequence txs) -> do
       , concurrentHandlesMetadata2 = fp </> "meta.md2"
       }
 
-    _      <- run $ create hnds
-    result <- run . runMaybeT $ foldM (writeReadTest hnds)
+    (Right db, files) <- run $ create hnds
+    result <- run . runMaybeT $ foldM (writeReadTest db files)
                                       M.empty
                                       txs
 
+    _ <- FS.runStoreT (closeConcurrentHandles hnds) files
+
     run $ removeFile (concurrentHandlesMain hnds)
     run $ removeFile (concurrentHandlesMetadata1 hnds)
     run $ removeFile (concurrentHandlesMetadata2 hnds)
     run $ removeDirectory fp
 
     assert $ isJust result
   where
-    writeReadTest :: ConcurrentHandles FilePath
+    writeReadTest :: ConcurrentDb FilePath Integer Integer
+                  -> FS.Files FilePath
                   -> Map Integer Integer
                   -> TestTransaction Integer Integer
                   -> MaybeT IO (Map Integer Integer)
-    writeReadTest hnds m tx = do
-        _     <- lift $ openAndWrite hnds tx
-        read' <- lift $ openAndRead hnds
+    writeReadTest db files m tx = do
+        _     <- lift $ openAndWrite db files tx
+        read' <- lift $ openAndRead db files
         let expected = testTransactionResult m tx
         if read' == M.toList expected
             then return expected
@@ -121,29 +124,24 @@ prop_file_backend = forAllM genTestSequence $ \(TestSequence txs) -> do
            -> IO (Either String (ConcurrentDb FilePath Integer Integer), FS.Files FilePath)
     create hnds = flip FS.runStoreT FS.emptyStore $ do
         openConcurrentHandles hnds
-        db <- createConcurrentDb hnds
-        closeConcurrentHandles hnds
-        return db
+        createConcurrentDb hnds
 
-    openAndRead :: ConcurrentHandles FilePath
+    openAndRead :: ConcurrentDb FilePath Integer Integer
+                -> FS.Files FilePath
                 -> IO [(Integer, Integer)]
-    openAndRead hnds = FS.evalStoreT (do
-        db <- open hnds
-        v  <- readAll db
-        closeConcurrentHandles hnds
-        return v)
-        (FS.emptyStore :: FS.Files FilePath)
+    openAndRead db files = FS.evalStoreT (readAll db) files
         >>= \case
             Left err -> error err
             Right v -> return v
 
-    openAndWrite :: ConcurrentHandles FilePath
+    openAndWrite :: ConcurrentDb FilePath Integer Integer
+                 -> FS.Files FilePath
                  -> TestTransaction Integer Integer
                  -> IO (FS.Files FilePath)
-    openAndWrite hnds tx = flip FS.execStoreT FS.emptyStore $ do
-        db  <- open hnds
-        _   <- writeTransaction tx db
-        closeConcurrentHandles hnds
+    openAndWrite db files tx = FS.runStoreT (writeTransaction tx db >> return ()) files
+        >>= \case
+            (Left err, _)    -> error $ "while writing: " ++ show err
+            (Right _, files') -> return files'
 
     open hnds = fromJust <$> (openConcurrentHandles hnds >> openConcurrentDb hnds)