diff options
| -rw-r--r-- | Database/Fsck.hs | 29 | ||||
| -rw-r--r-- | Database/Handle.hs | 33 | ||||
| -rw-r--r-- | Locations.hs | 8 |
3 files changed, 50 insertions, 20 deletions
diff --git a/Database/Fsck.hs b/Database/Fsck.hs index 5301109bc..92c814cf1 100644 --- a/Database/Fsck.hs +++ b/Database/Fsck.hs @@ -21,7 +21,8 @@ module Database.Fsck ( import Database.Types import qualified Database.Handle as H import Locations -import Utility.Directory +import Utility.PosixFiles +import Utility.Exception import Annex import Types.Key import Types.UUID @@ -34,6 +35,7 @@ import Control.Monad import Control.Monad.IfElse import Control.Monad.IO.Class (liftIO) import System.Directory +import System.FilePath import Data.Maybe import Control.Applicative @@ -56,20 +58,27 @@ Fscked newPass :: UUID -> Annex Bool newPass u = isJust <$> tryExclusiveLock (gitAnnexFsckDbLock u) go where - go = liftIO. nukeFile =<< fromRepo (gitAnnexFsckDb u) + go = liftIO . void . tryIO . removeDirectoryRecursive + =<< fromRepo (gitAnnexFsckDbDir u) {- Opens the database, creating it atomically if it doesn't exist yet. -} openDb :: UUID -> Annex FsckHandle openDb u = do - db <- fromRepo (gitAnnexFsckDb u) + dbdir <- fromRepo (gitAnnexFsckDbDir u) + let db = dbdir </> "db" unlessM (liftIO $ doesFileExist db) $ do - let newdb = db ++ ".new" - h <- liftIO $ H.openDb newdb - void $ liftIO $ H.commitDb h $ - void $ runMigrationSilent migrateFsck - liftIO $ H.closeDb h - setAnnexFilePerm newdb - liftIO $ renameFile newdb db + let tmpdbdir = dbdir ++ ".tmp" + let tmpdb = tmpdbdir </> "db" + liftIO $ do + createDirectoryIfMissing True tmpdbdir + h <- H.initDb tmpdb $ void $ + runMigrationSilent migrateFsck + H.closeDb h + setAnnexDirPerm tmpdbdir + setAnnexFilePerm tmpdb + liftIO $ do + void $ tryIO $ removeDirectoryRecursive dbdir + rename tmpdbdir dbdir lockFileShared =<< fromRepo (gitAnnexFsckDbLock u) h <- liftIO $ H.openDb db return $ FsckHandle h u diff --git a/Database/Handle.hs b/Database/Handle.hs index 0a426d454..578bea31d 100644 --- a/Database/Handle.hs +++ b/Database/Handle.hs @@ -9,6 +9,7 @@ module Database.Handle ( DbHandle, + initDb, openDb, queryDb, closeDb, @@ -22,6 +23,7 @@ import Utility.Exception import Messages import Database.Persist.Sqlite +import qualified Database.Sqlite as Sqlite import Control.Monad import Control.Monad.IO.Class (liftIO) import Control.Concurrent @@ -33,6 +35,29 @@ import qualified Data.Text as T - the database. It has a MVar which Jobs are submitted to. -} data DbHandle = DbHandle (Async ()) (MVar Job) (MVar DbQueue) +{- Ensures that the database is initialized. Pass the migration action for + - the database. + - + - The database is put into WAL mode, to prevent readers from blocking + - writers, and prevent a writer from blocking readers. + -} +initDb :: FilePath -> SqlPersistM () -> IO DbHandle +initDb db migration = do + enableWAL db + h <- openDb db + either throwIO (const $ return ()) =<< commitDb h migration + return h + +enableWAL :: FilePath -> IO () +enableWAL db = do + conn <- Sqlite.open (T.pack db) + stmt <- Sqlite.prepare conn (T.pack "PRAGMA journal_mode=WAL;") + void $ Sqlite.step stmt + void $ Sqlite.finalize stmt + Sqlite.close conn + +{- Opens the database, but does not perform any migrations. Only use + - if the database is known to exist and have the right tables. -} openDb :: FilePath -> IO DbHandle openDb db = do jobs <- newEmptyMVar @@ -120,12 +145,8 @@ queueDb h@(DbHandle _ _ qvar) maxsz a = do then do r <- commitDb h qa' case r of - Left e -> do - print ("commit deferred", e) - enqueue 0 - Right _ -> do - print "commit made" - putMVar qvar emptyDbQueue + Left e -> enqueue 0 + Right _ -> putMVar qvar emptyDbQueue else enqueue sz' {- If flushing the queue fails, this could be because there is another diff --git a/Locations.hs b/Locations.hs index 41e0c4201..18238d86d 100644 --- a/Locations.hs +++ b/Locations.hs @@ -29,7 +29,7 @@ module Locations ( gitAnnexBadLocation, gitAnnexUnusedLog, gitAnnexFsckState, - gitAnnexFsckDb, + gitAnnexFsckDbDir, gitAnnexFsckDbLock, gitAnnexFsckResultsLog, gitAnnexScheduleState, @@ -229,9 +229,9 @@ gitAnnexFsckDir u r = gitAnnexDir r </> "fsck" </> fromUUID u gitAnnexFsckState :: UUID -> Git.Repo -> FilePath gitAnnexFsckState u r = gitAnnexFsckDir u r </> "state" -{- Database used to record fsck info. -} -gitAnnexFsckDb :: UUID -> Git.Repo -> FilePath -gitAnnexFsckDb u r = gitAnnexFsckDir u r </> "fsck.db" +{- Directory containing database used to record fsck info. -} +gitAnnexFsckDbDir :: UUID -> Git.Repo -> FilePath +gitAnnexFsckDbDir u r = gitAnnexFsckDir u r </> "db" {- Lock file for the fsck database. -} gitAnnexFsckDbLock :: UUID -> Git.Repo -> FilePath |