associated files database

diff --git a/Database/AssociatedFiles.hs b/Database/AssociatedFiles.hs
new file mode 100644 (file)
index 0000000..8244f15
--- /dev/null
+++ b/Database/AssociatedFiles.hs
@@ -0,0 +1,94 @@
+{- Sqlite database used for tracking a key's associated files.
+ -
+ - Copyright 2015 Joey Hess <id@joeyh.name>
+ -:
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Database.AssociatedFiles (
+       DbHandle,
+       openDb,
+       closeDb,
+       addDb,
+       getDb,
+       removeDb,
+       AssociatedId,
+) where
+
+import Database.Types
+import qualified Database.Handle as H
+import Locations
+import Common hiding (delete)
+import Annex
+import Types.Key
+import Annex.Perms
+import Annex.LockFile
+import Messages
+
+import Database.Persist.TH
+import Database.Esqueleto hiding (Key)
+
+newtype DbHandle = DbHandle H.DbHandle
+
+share [mkPersist sqlSettings, mkMigrate "migrateAssociated"] [persistLowerCase|
+Associated
+  key SKey
+  file FilePath
+  KeyFileIndex key file
+|]
+
+{- Opens the database, creating it if it doesn't exist yet. -}
+openDb :: Annex DbHandle
+openDb = withExclusiveLock gitAnnexAssociatedFilesDbLock $ do
+       dbdir <- fromRepo gitAnnexAssociatedFilesDb
+       let db = dbdir </> "db"
+       unlessM (liftIO $ doesFileExist db) $ do
+               liftIO $ do
+                       createDirectoryIfMissing True dbdir
+                       H.initDb db $ void $
+                               runMigrationSilent migrateAssociated
+               setAnnexDirPerm dbdir
+               setAnnexFilePerm db
+       h <- liftIO $ H.openDb db "associated"
+
+       -- work around https://github.com/yesodweb/persistent/issues/474
+       liftIO setConsoleEncoding
+
+       return $ DbHandle h
+
+closeDb :: DbHandle -> IO ()
+closeDb (DbHandle h) = H.closeDb h
+
+addDb :: DbHandle -> Key -> FilePath -> IO ()
+addDb (DbHandle h) k f = H.queueDb h (\_ _ -> pure True) $ do
+       -- If the same file was associated with a different key before,
+       -- remove that.
+       delete $ from $ \r -> do
+               where_ (r ^. AssociatedFile ==. val f &&. r ^. AssociatedKey ==. val sk)
+       void $ insertUnique $ Associated sk f
+  where
+       sk = toSKey k
+
+{- Note that the files returned used to be associated with the key, but
+ - some of them may not be any longer. -}
+getDb :: DbHandle -> Key -> IO [FilePath]
+getDb (DbHandle h) = H.queryDb h . getDb' . toSKey
+
+getDb' :: SKey -> SqlPersistM [FilePath]
+getDb' sk = do
+       l <- select $ from $ \r -> do
+               where_ (r ^. AssociatedKey ==. val sk)
+               return (r ^. AssociatedFile)
+       return $ map unValue l
+
+removeDb :: DbHandle -> Key -> FilePath -> IO ()
+removeDb (DbHandle h) k f =  H.queueDb h (\_ _ -> pure True) $
+       delete $ from $ \r -> do
+               where_ (r ^. AssociatedKey ==. val sk &&. r ^. AssociatedFile ==. val f)
+  where
+       sk = toSKey k

diff --git a/Database/Fsck.hs b/Database/Fsck.hs
index ed00e62d80cdbf95f5103b0d80ae936c61ad3cb7..b0e56f6c0de642df49c4fb61f5b889a844bd7770 100644 (file)
--- a/Database/Fsck.hs
+++ b/Database/Fsck.hs
@@ -59,7 +59,7 @@ newPass u = isJust <$> tryExclusiveLock (gitAnnexFsckDbLock u) go
        go = liftIO . void . tryIO . removeDirectoryRecursive
                =<< fromRepo (gitAnnexFsckDbDir u)
 
-{- Opens the database, creating it atomically if it doesn't exist yet. -}
+{- Opens the database, creating it if it doesn't exist yet. -}
 openDb :: UUID -> Annex FsckHandle
 openDb u = do
        dbdir <- fromRepo (gitAnnexFsckDbDir u)

diff --git a/Locations.hs b/Locations.hs
index ba61151554bfa5c1ad089ccc07d34fe26a5bcb93..6082957c741b88f9b67ff52f5463bb8fb9f1a5f0 100644 (file)
--- a/Locations.hs
+++ b/Locations.hs
@@ -29,6 +29,8 @@ module Locations (
        gitAnnexBadDir,
        gitAnnexBadLocation,
        gitAnnexUnusedLog,
+       gitAnnexAssociatedFilesDb,
+       gitAnnexAssociatedFilesDbLock,
        gitAnnexFsckState,
        gitAnnexFsckDbDir,
        gitAnnexFsckDbLock,
@@ -237,6 +239,14 @@ gitAnnexBadLocation key r = gitAnnexBadDir r </> keyFile key
 gitAnnexUnusedLog :: FilePath -> Git.Repo -> FilePath
 gitAnnexUnusedLog prefix r = gitAnnexDir r </> (prefix ++ "unused")
 
+{- .git/annex/map/ contains a database for the associated files map -}
+gitAnnexAssociatedFilesDb :: Git.Repo -> FilePath
+gitAnnexAssociatedFilesDb r = gitAnnexDir r </> "map"
+
+{- Lock file for the associated files map database. -}
+gitAnnexAssociatedFilesDbLock :: Git.Repo -> FilePath
+gitAnnexAssociatedFilesDbLock r = gitAnnexAssociatedFilesDb r ++ "lck"
+
 {- .git/annex/fsck/uuid/ is used to store information about incremental
  - fscks. -}
 gitAnnexFsckDir :: UUID -> Git.Repo -> FilePath