diff options
author | Joey Hess <joeyh@joeyh.name> | 2015-12-07 13:42:03 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2015-12-07 14:35:37 -0400 |
commit | d71bdba6009d522db726121b17980a3d32919f74 (patch) | |
tree | 7ba7471e865781f8dd0e67b217b9e6fb20de634d | |
parent | 386b62174bcf97b3c319e786130da8ce617dff23 (diff) |
associated files database
-rw-r--r-- | Database/AssociatedFiles.hs | 94 | ||||
-rw-r--r-- | Database/Fsck.hs | 2 | ||||
-rw-r--r-- | Locations.hs | 10 |
3 files changed, 105 insertions, 1 deletions
diff --git a/Database/AssociatedFiles.hs b/Database/AssociatedFiles.hs new file mode 100644 index 000000000..8244f15e8 --- /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 ed00e62d8..b0e56f6c0 100644 --- 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 ba6115155..6082957c7 100644 --- 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 |