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"