convert incremental fsck to using sqlite database

Did not keep backwards compat for sticky bit records. An incremental fsck
that is already in progress will start over on upgrade to this version.

This is not yet ready for merging. The autobuilders need to have sqlite
installed.

Also, interrupting a fsck --incremental does not commit the database.
So, resuming with fsck --more restarts from beginning.

Memory: Constant during a fsck of tens of thousands of files.
(But, it does seem to buffer whole transation in memory, so
may really scale with number of files.)

CPU: ?
This commit is contained in:
Joey Hess 2015-02-16 15:08:29 -04:00
parent bb242bdd82
commit 91e9146d1b
9 changed files with 185 additions and 177 deletions

71
Database/Fsck.hs Normal file
View file

@ -0,0 +1,71 @@
{- Sqlite database used for incremental fsck.
-
- Copyright 2015 Joey Hess <id@joeyh.name>
-:
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-}
module Database.Fsck (
newPass,
openDb,
H.closeDb,
H.DbHandle,
addDb,
inDb,
FsckedId,
) where
import Database.Types
import qualified Database.Handle as H
import Locations
import Utility.Directory
import Annex
import Types.Key
import Annex.Perms
import Database.Persist.TH
import Database.Esqueleto hiding (Key)
import Control.Monad
import Control.Monad.IfElse
import Control.Monad.IO.Class (liftIO)
import System.Directory
{- Each key stored in the database has already been fscked as part
- of the latest incremental fsck pass. -}
share [mkPersist sqlSettings, mkMigrate "migrateFsck"] [persistLowerCase|
Fscked
key SKey
UniqueKey key
deriving Show
|]
{- The database is removed when starting a new incremental fsck pass. -}
newPass :: Annex ()
newPass = liftIO. nukeFile =<< fromRepo gitAnnexFsckDb
{- Opens the database, creating it atomically if it doesn't exist yet. -}
openDb :: Annex H.DbHandle
openDb = do
db <- fromRepo gitAnnexFsckDb
unlessM (liftIO $ doesFileExist db) $ do
let newdb = db ++ ".new"
h <- liftIO $ H.openDb newdb
void $ liftIO $ H.runDb h $
runMigrationSilent migrateFsck
liftIO $ H.closeDb h
setAnnexFilePerm newdb
liftIO $ renameFile newdb db
liftIO $ H.openDb db
addDb :: H.DbHandle -> Key -> Annex ()
addDb h = void . liftIO . H.runDb h . insert . Fscked . toSKey
inDb :: H.DbHandle -> Key -> Annex Bool
inDb h k = liftIO $ H.runDb h $ do
r <- select $ from $ \r -> do
where_ (r ^. FsckedKey ==. val (toSKey k))
return (r ^. FsckedKey)
return $ not $ null r

63
Database/Handle.hs Normal file
View file

@ -0,0 +1,63 @@
{- Persistent sqlite database handles.
-
- Copyright 2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Database.Handle (
DbHandle,
openDb,
closeDb,
runDb,
) where
import Utility.Exception
import Database.Persist.Sqlite (runSqlite)
import Database.Esqueleto hiding (Key)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception (throwIO)
import qualified Data.Text as T
{- A DbHandle is a reference to a worker thread that communicates with
- the database. It has a MVar which Jobs are submitted to. -}
data DbHandle = DbHandle (Async ()) (MVar Job)
data Job = Job (SqlPersistM ()) | CloseJob
openDb :: FilePath -> IO DbHandle
openDb db = do
jobs <- newEmptyMVar
worker <- async (workerThread db jobs)
return $ DbHandle worker jobs
workerThread :: FilePath -> MVar Job -> IO ()
workerThread db jobs = runSqlite (T.pack db) go
where
go = do
job <- liftIO $ takeMVar jobs
case job of
Job a -> a >> go
CloseJob -> return ()
closeDb :: DbHandle -> IO ()
closeDb (DbHandle worker jobs) = do
putMVar jobs CloseJob
wait worker
{- Runs an action using the DbHandle.
-
- Note that the action is not run by the calling thread, but by a
- worker thread. Exceptions are propigated to the calling thread.
-
- Note that only one action can be run at a time against a given DbHandle.
- If called concurrently, this will block until it is able to run.
-}
runDb :: DbHandle -> SqlPersistM a -> IO a
runDb (DbHandle _ jobs) a = do
res <- newEmptyMVar
putMVar jobs $ Job $ liftIO . putMVar res =<< tryNonAsync a
either throwIO return =<< takeMVar res

27
Database/Types.hs Normal file
View file

@ -0,0 +1,27 @@
{- types for SQL databases
-
- Copyright 2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE TemplateHaskell #-}
module Database.Types where
import Database.Persist.TH
import Data.Maybe
import Types.Key
-- A serialized Key
newtype SKey = SKey String
deriving (Show, Read)
toSKey :: Key -> SKey
toSKey = SKey . key2file
fromSKey :: SKey -> Key
fromSKey (SKey s) = fromMaybe (error $ "bad serialied key " ++ s) (file2key s)
derivePersistField "SKey"