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: ?

3 files changed, 161 insertions, 0 deletions

diff --git a/Database/Fsck.hs b/Database/Fsck.hs
new file mode 100644
index 000000000..f03a4c009
--- /dev/null
+++ b/Database/Fsck.hs
@@ -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
diff --git a/Database/Handle.hs b/Database/Handle.hs
new file mode 100644
index 000000000..c39dcfd2b
--- /dev/null
+++ b/Database/Handle.hs
@@ -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
diff --git a/Database/Types.hs b/Database/Types.hs
new file mode 100644
index 000000000..dee56832b
--- /dev/null
+++ b/Database/Types.hs
@@ -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"