f5b642318d
After commit f4bdecc4ec, there is no
longer any distinction between SingleWriter and MultiWriter's handling
of read after write.
Databases that were SingleWriter still have lock files that are used to
prevent multiple writers.
This does make writing to such databases a bit more expensive,
because the MultiWriter code path that is now used opens a second db
connection in order to write to them.
463 lines
16 KiB
Haskell
463 lines
16 KiB
Haskell
{- Sqlite database of information about Keys
|
|
-
|
|
- Copyright 2015-2021 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE BangPatterns #-}
|
|
|
|
module Database.Keys (
|
|
DbHandle,
|
|
closeDb,
|
|
addAssociatedFile,
|
|
getAssociatedFiles,
|
|
getAssociatedFilesIncluding,
|
|
getAssociatedKey,
|
|
removeAssociatedFile,
|
|
storeInodeCaches,
|
|
addInodeCaches,
|
|
getInodeCaches,
|
|
removeInodeCaches,
|
|
removeInodeCache,
|
|
isInodeKnown,
|
|
runWriter,
|
|
) where
|
|
|
|
import qualified Database.Keys.SQL as SQL
|
|
import Database.Types
|
|
import Database.Keys.Handle
|
|
import qualified Database.Queue as H
|
|
import Database.Init
|
|
import Annex.Locations
|
|
import Annex.Common hiding (delete)
|
|
import qualified Annex
|
|
import Annex.LockFile
|
|
import Annex.Content.PointerFile
|
|
import Annex.Content.Presence.LowLevel
|
|
import Annex.Link (Restage(..), maxPointerSz, parseLinkTargetOrPointerLazy)
|
|
import Utility.InodeCache
|
|
import Annex.InodeSentinal
|
|
import Git
|
|
import Git.FilePath
|
|
import Git.Command
|
|
import Git.Types
|
|
import Git.Index
|
|
import Git.Sha
|
|
import Git.CatFile
|
|
import Git.Branch (writeTreeQuiet, update')
|
|
import qualified Git.Ref
|
|
import Config.Smudge
|
|
import qualified Utility.RawFilePath as R
|
|
|
|
import qualified Data.ByteString as S
|
|
import qualified Data.ByteString.Char8 as S8
|
|
import qualified System.FilePath.ByteString as P
|
|
import Control.Concurrent.Async
|
|
|
|
{- Runs an action that reads from the database.
|
|
-
|
|
- If the database is already open, any writes are flushed to it, to ensure
|
|
- consistency.
|
|
-
|
|
- Any queued writes will be flushed before the read.
|
|
-}
|
|
runReader :: Monoid v => (SQL.ReadHandle -> Annex v) -> Annex v
|
|
runReader a = do
|
|
h <- Annex.getRead Annex.keysdbhandle
|
|
withDbState h go
|
|
where
|
|
go DbUnavailable = return (mempty, DbUnavailable)
|
|
go st@(DbOpen qh) = do
|
|
liftIO $ H.flushDbQueue qh
|
|
v <- a (SQL.ReadHandle qh)
|
|
return (v, st)
|
|
go DbClosed = do
|
|
st' <- openDb False DbClosed
|
|
v <- case st' of
|
|
(DbOpen qh) -> a (SQL.ReadHandle qh)
|
|
_ -> return mempty
|
|
return (v, st')
|
|
|
|
runReaderIO :: Monoid v => (SQL.ReadHandle -> IO v) -> Annex v
|
|
runReaderIO a = runReader (liftIO . a)
|
|
|
|
{- Runs an action that writes to the database. Typically this is used to
|
|
- queue changes, which will be flushed at a later point.
|
|
-
|
|
- The database is created if it doesn't exist yet. -}
|
|
runWriter :: (SQL.WriteHandle -> Annex ()) -> Annex ()
|
|
runWriter a = do
|
|
h <- Annex.getRead Annex.keysdbhandle
|
|
withDbState h go
|
|
where
|
|
go st@(DbOpen qh) = do
|
|
v <- a (SQL.WriteHandle qh)
|
|
return (v, st)
|
|
go st = do
|
|
st' <- openDb True st
|
|
v <- case st' of
|
|
DbOpen qh -> a (SQL.WriteHandle qh)
|
|
_ -> error "internal"
|
|
return (v, st')
|
|
|
|
runWriterIO :: (SQL.WriteHandle -> IO ()) -> Annex ()
|
|
runWriterIO a = runWriter (liftIO . a)
|
|
|
|
{- Opens the database, creating it if it doesn't exist yet.
|
|
-
|
|
- Multiple readers and writers can have the database open at the same
|
|
- time. Database.Handle deals with the concurrency issues.
|
|
- The lock is held while opening the database, so that when
|
|
- the database doesn't exist yet, one caller wins the lock and
|
|
- can create it undisturbed.
|
|
-}
|
|
openDb :: Bool -> DbState -> Annex DbState
|
|
openDb _ st@(DbOpen _) = return st
|
|
openDb False DbUnavailable = return DbUnavailable
|
|
openDb forwrite _ = catchPermissionDenied permerr $ withExclusiveLock gitAnnexKeysDbLock $ do
|
|
dbdir <- fromRepo gitAnnexKeysDb
|
|
let db = dbdir P.</> "db"
|
|
dbexists <- liftIO $ R.doesPathExist db
|
|
case dbexists of
|
|
True -> open db
|
|
False -> do
|
|
initDb db SQL.createTables
|
|
open db
|
|
where
|
|
-- If permissions don't allow opening the database, and it's being
|
|
-- opened for read, treat it as if it does not exist.
|
|
permerr e
|
|
| forwrite = throwM e
|
|
| otherwise = return DbUnavailable
|
|
|
|
open db = do
|
|
qh <- liftIO $ H.openDbQueue db SQL.containedTable
|
|
reconcileStaged qh
|
|
return $ DbOpen qh
|
|
|
|
{- Closes the database if it was open. Any writes will be flushed to it.
|
|
-
|
|
- This does not normally need to be called; the database will auto-close
|
|
- when the handle is garbage collected. However, this can be used to
|
|
- force a re-read of the database, in case another process has written
|
|
- data to it.
|
|
-}
|
|
closeDb :: Annex ()
|
|
closeDb = liftIO . closeDbHandle =<< Annex.getRead Annex.keysdbhandle
|
|
|
|
addAssociatedFile :: Key -> TopFilePath -> Annex ()
|
|
addAssociatedFile k f = runWriterIO $ SQL.addAssociatedFile k f
|
|
|
|
{- Note that the files returned were once associated with the key, but
|
|
- some of them may not be any longer. -}
|
|
getAssociatedFiles :: Key -> Annex [TopFilePath]
|
|
getAssociatedFiles = runReaderIO . SQL.getAssociatedFiles
|
|
|
|
{- Include a known associated file along with any recorded in the database. -}
|
|
getAssociatedFilesIncluding :: AssociatedFile -> Key -> Annex [RawFilePath]
|
|
getAssociatedFilesIncluding afile k = do
|
|
g <- Annex.gitRepo
|
|
l <- map (`fromTopFilePath` g) <$> getAssociatedFiles k
|
|
return $ case afile of
|
|
AssociatedFile (Just f) -> f : filter (/= f) l
|
|
AssociatedFile Nothing -> l
|
|
|
|
{- Gets any keys that are on record as having a particular associated file.
|
|
- (Should be one or none but the database doesn't enforce that.) -}
|
|
getAssociatedKey :: TopFilePath -> Annex [Key]
|
|
getAssociatedKey = runReaderIO . SQL.getAssociatedKey
|
|
|
|
removeAssociatedFile :: Key -> TopFilePath -> Annex ()
|
|
removeAssociatedFile k = runWriterIO . SQL.removeAssociatedFile k
|
|
|
|
{- Stats the files, and stores their InodeCaches. -}
|
|
storeInodeCaches :: Key -> [RawFilePath] -> Annex ()
|
|
storeInodeCaches k fs = withTSDelta $ \d ->
|
|
addInodeCaches k . catMaybes
|
|
=<< liftIO (mapM (\f -> genInodeCache f d) fs)
|
|
|
|
addInodeCaches :: Key -> [InodeCache] -> Annex ()
|
|
addInodeCaches k is = runWriterIO $ SQL.addInodeCaches k is
|
|
|
|
{- A key may have multiple InodeCaches; one for the annex object, and one
|
|
- for each pointer file that is a copy of it.
|
|
-
|
|
- When there are no pointer files, the annex object typically does not
|
|
- have its InodeCache recorded either, so the list will be empty.
|
|
-
|
|
- Note that, in repos upgraded from v7, there may be InodeCaches recorded
|
|
- for pointer files, but none recorded for the annex object.
|
|
-}
|
|
getInodeCaches :: Key -> Annex [InodeCache]
|
|
getInodeCaches = runReaderIO . SQL.getInodeCaches
|
|
|
|
{- Remove all inodes cached for a key. -}
|
|
removeInodeCaches :: Key -> Annex ()
|
|
removeInodeCaches = runWriterIO . SQL.removeInodeCaches
|
|
|
|
{- Remove cached inodes, for any key. -}
|
|
removeInodeCache :: InodeCache -> Annex ()
|
|
removeInodeCache = runWriterIO . SQL.removeInodeCache
|
|
|
|
isInodeKnown :: InodeCache -> SentinalStatus -> Annex Bool
|
|
isInodeKnown i s = or <$> runReaderIO ((:[]) <$$> SQL.isInodeKnown i s)
|
|
|
|
{- Looks at staged changes to annexed files, and updates the keys database,
|
|
- so that its information is consistent with the state of the repository.
|
|
-
|
|
- This is run with a lock held, so only one process can be running this at
|
|
- a time.
|
|
-
|
|
- To avoid unncessary work, the index file is statted, and if it's not
|
|
- changed since last time this was run, nothing is done.
|
|
-
|
|
- A tree is generated from the index, and the diff between that tree
|
|
- and the last processed tree is examined for changes.
|
|
-
|
|
- This also cleans up after a race between eg a git mv and git-annex
|
|
- get/drop/similar. If git moves a pointer file between this being run and the
|
|
- get/drop, the moved pointer file won't be updated for the get/drop.
|
|
- The next time this runs, it will see the staged change. It then checks
|
|
- if the pointer file needs to be updated to contain or not contain the
|
|
- annex content.
|
|
-
|
|
- Note: There is a situation where, after this has run, the database can
|
|
- still contain associated files that have been deleted from the index.
|
|
- That happens when addAssociatedFile is used to record a newly
|
|
- added file, but that file then gets removed from the index before
|
|
- this is run. Eg, "git-annex add foo; git rm foo"
|
|
- So when using getAssociatedFiles, have to make sure the file still
|
|
- is an associated file.
|
|
-}
|
|
reconcileStaged :: H.DbQueue -> Annex ()
|
|
reconcileStaged qh = do
|
|
gitindex <- inRepo currentIndexFile
|
|
indexcache <- fromRawFilePath <$> fromRepo gitAnnexKeysDbIndexCache
|
|
withTSDelta (liftIO . genInodeCache gitindex) >>= \case
|
|
Just cur -> readindexcache indexcache >>= \case
|
|
Nothing -> go cur indexcache =<< getindextree
|
|
Just prev -> ifM (compareInodeCaches prev cur)
|
|
( noop
|
|
, go cur indexcache =<< getindextree
|
|
)
|
|
Nothing -> noop
|
|
where
|
|
lastindexref = Ref "refs/annex/last-index"
|
|
|
|
readindexcache indexcache = liftIO $ maybe Nothing readInodeCache
|
|
<$> catchMaybeIO (readFile indexcache)
|
|
|
|
getoldtree = fromMaybe emptyTree <$> inRepo (Git.Ref.sha lastindexref)
|
|
|
|
go cur indexcache (Just newtree) = do
|
|
oldtree <- getoldtree
|
|
when (oldtree /= newtree) $ do
|
|
fastDebug "Database.Keys" "reconcileStaged start"
|
|
g <- Annex.gitRepo
|
|
void $ catstream $ \mdfeeder ->
|
|
void $ updatetodiff g
|
|
(Just (fromRef oldtree))
|
|
(fromRef newtree)
|
|
(procdiff mdfeeder)
|
|
liftIO $ writeFile indexcache $ showInodeCache cur
|
|
-- Storing the tree in a ref makes sure it does not
|
|
-- get garbage collected, and is available to diff
|
|
-- against next time.
|
|
inRepo $ update' lastindexref newtree
|
|
fastDebug "Database.Keys" "reconcileStaged end"
|
|
-- git write-tree will fail if the index is locked or when there is
|
|
-- a merge conflict. To get up-to-date with the current index,
|
|
-- diff --staged with the old index tree. The current index tree
|
|
-- is not known, so not recorded, and the inode cache is not updated,
|
|
-- so the next time git-annex runs, it will diff again, even
|
|
-- if the index is unchanged.
|
|
--
|
|
-- When there is a merge conflict, that will not see the new local
|
|
-- version of the files that are conflicted. So a second diff
|
|
-- is done, with --staged but no old tree.
|
|
go _ _ Nothing = do
|
|
fastDebug "Database.Keys" "reconcileStaged start (in conflict)"
|
|
oldtree <- getoldtree
|
|
g <- Annex.gitRepo
|
|
catstream $ \mdfeeder -> do
|
|
conflicted <- updatetodiff g
|
|
(Just (fromRef oldtree)) "--staged" (procdiff mdfeeder)
|
|
when conflicted $
|
|
void $ updatetodiff g Nothing "--staged"
|
|
(procmergeconflictdiff mdfeeder)
|
|
fastDebug "Database.Keys" "reconcileStaged end"
|
|
|
|
updatetodiff g old new processor = do
|
|
(l, cleanup) <- pipeNullSplit' (diff old new) g
|
|
processor l False
|
|
`finally` void cleanup
|
|
|
|
-- Avoid running smudge clean filter, which would block trying to
|
|
-- access the locked database. git write-tree sometimes calls it,
|
|
-- even though it is not adding work tree files to the index,
|
|
-- and so the filter cannot have an effect on the contents of the
|
|
-- index or on the tree that gets written from it.
|
|
getindextree = inRepo $ \r -> writeTreeQuiet $ r
|
|
{ gitGlobalOpts = gitGlobalOpts r ++ bypassSmudgeConfig }
|
|
|
|
diff old new =
|
|
-- Avoid running smudge clean filter, since we want the
|
|
-- raw output, and it would block trying to access the
|
|
-- locked database. The --raw normally avoids git diff
|
|
-- running them, but older versions of git need this.
|
|
bypassSmudgeConfig ++
|
|
-- Avoid using external diff command, which would be slow.
|
|
-- (The -G option may make it be used otherwise.)
|
|
[ Param "-c", Param "diff.external="
|
|
, Param "diff"
|
|
] ++ maybeToList (Param <$> old) ++
|
|
[ Param new
|
|
, Param "--raw"
|
|
, Param "-z"
|
|
, Param "--no-abbrev"
|
|
-- Optimization: Limit to pointer files and annex symlinks.
|
|
-- This is not perfect. A file could contain with this and not
|
|
-- be a pointer file. And a pointer file that is replaced with
|
|
-- a non-pointer file will match this. This is only a
|
|
-- prefilter so that's ok.
|
|
, Param $ "-G" ++ fromRawFilePath (toInternalGitPath $
|
|
P.pathSeparator `S.cons` objectDir')
|
|
-- Disable rename detection.
|
|
, Param "--no-renames"
|
|
-- Avoid other complications.
|
|
, Param "--ignore-submodules=all"
|
|
, Param "--no-ext-diff"
|
|
]
|
|
|
|
procdiff mdfeeder (info:file:rest) conflicted
|
|
| ":" `S.isPrefixOf` info = case S8.words info of
|
|
(_colonsrcmode:dstmode:srcsha:dstsha:status:[]) -> do
|
|
let conflicted' = status == "U"
|
|
-- avoid removing associated file when
|
|
-- there is a merge conflict
|
|
unless conflicted' $
|
|
send mdfeeder (Ref srcsha) $ \case
|
|
Just oldkey -> do
|
|
liftIO $ SQL.removeAssociatedFile oldkey
|
|
(asTopFilePath file)
|
|
(SQL.WriteHandle qh)
|
|
return True
|
|
Nothing -> return False
|
|
send mdfeeder (Ref dstsha) $ \case
|
|
Just key -> do
|
|
liftIO $ SQL.addAssociatedFile key
|
|
(asTopFilePath file)
|
|
(SQL.WriteHandle qh)
|
|
when (dstmode /= fmtTreeItemType TreeSymlink) $
|
|
reconcilepointerfile (asTopFilePath file) key
|
|
return True
|
|
Nothing -> return False
|
|
procdiff mdfeeder rest
|
|
(conflicted || conflicted')
|
|
_ -> return conflicted -- parse failed
|
|
procdiff _ _ conflicted = return conflicted
|
|
|
|
-- Processing a diff --index when there is a merge conflict.
|
|
-- This diff will have the new local version of a file as the
|
|
-- first sha, and a null sha as the second sha, and we only
|
|
-- care about files that are in conflict.
|
|
procmergeconflictdiff mdfeeder (info:file:rest) conflicted
|
|
| ":" `S.isPrefixOf` info = case S8.words info of
|
|
(_colonmode:_mode:sha:_sha:status:[]) -> do
|
|
send mdfeeder (Ref sha) $ \case
|
|
Just key -> do
|
|
liftIO $ SQL.addAssociatedFile key
|
|
(asTopFilePath file)
|
|
(SQL.WriteHandle qh)
|
|
return True
|
|
Nothing -> return False
|
|
let conflicted' = status == "U"
|
|
procmergeconflictdiff mdfeeder rest
|
|
(conflicted || conflicted')
|
|
_ -> return conflicted -- parse failed
|
|
procmergeconflictdiff _ _ conflicted = return conflicted
|
|
|
|
reconcilepointerfile file key = do
|
|
ics <- liftIO $ SQL.getInodeCaches key (SQL.ReadHandle qh)
|
|
obj <- calcRepo (gitAnnexLocation key)
|
|
mobjic <- withTSDelta (liftIO . genInodeCache obj)
|
|
let addinodecaches k v = liftIO $
|
|
SQL.addInodeCaches k v (SQL.WriteHandle qh)
|
|
-- Like inAnnex, check the annex object is unmodified
|
|
-- when annex.thin is set.
|
|
keypopulated <- ifM (annexThin <$> Annex.getGitConfig)
|
|
( case mobjic of
|
|
Just objic -> isUnmodifiedLowLevel addinodecaches key obj objic ics
|
|
Nothing -> pure False
|
|
, pure (isJust mobjic)
|
|
)
|
|
p <- fromRepo $ fromTopFilePath file
|
|
filepopulated <- sameInodeCache p ics
|
|
case (keypopulated, filepopulated) of
|
|
(True, False) ->
|
|
populatePointerFile (Restage True) key obj p >>= \case
|
|
Nothing -> return ()
|
|
Just ic -> addinodecaches key
|
|
(catMaybes [Just ic, mobjic])
|
|
(False, True) -> depopulatePointerFile key p
|
|
_ -> return ()
|
|
|
|
send :: ((Maybe Key -> Annex a, Ref) -> IO ()) -> Ref -> (Maybe Key -> Annex a) -> IO ()
|
|
send feeder r withk = feeder (withk, r)
|
|
|
|
-- Streaming through git cat-file like this is significantly
|
|
-- faster than using catKey.
|
|
catstream a = do
|
|
g <- Annex.gitRepo
|
|
catObjectMetaDataStream g $ \mdfeeder mdcloser mdreader ->
|
|
catObjectStream g $ \catfeeder catcloser catreader -> do
|
|
feedt <- liftIO $ async $
|
|
a mdfeeder
|
|
`finally` void mdcloser
|
|
proct <- liftIO $ async $
|
|
procthread mdreader catfeeder
|
|
`finally` void catcloser
|
|
dbchanged <- dbwriter False largediff catreader
|
|
-- Flush database changes now
|
|
-- so other processes can see them.
|
|
when dbchanged $
|
|
liftIO $ H.flushDbQueue qh
|
|
() <- liftIO $ wait feedt
|
|
liftIO $ wait proct
|
|
return ()
|
|
where
|
|
procthread mdreader catfeeder = mdreader >>= \case
|
|
Just (ka, Just (sha, size, _type))
|
|
| size < maxPointerSz -> do
|
|
() <- catfeeder (ka, sha)
|
|
procthread mdreader catfeeder
|
|
Just _ -> procthread mdreader catfeeder
|
|
Nothing -> return ()
|
|
|
|
dbwriter dbchanged n catreader = liftIO catreader >>= \case
|
|
Just (ka, content) -> do
|
|
changed <- ka (parseLinkTargetOrPointerLazy =<< content)
|
|
!n' <- countdownToMessage n
|
|
dbwriter (dbchanged || changed) n' catreader
|
|
Nothing -> return dbchanged
|
|
|
|
-- When the diff is large, the scan can take a while,
|
|
-- so let the user know what's going on.
|
|
countdownToMessage n
|
|
| n < 1 = return 0
|
|
| n == 1 = do
|
|
showSideAction "scanning for annexed files"
|
|
return 0
|
|
| otherwise = return (pred n)
|
|
|
|
-- How large is large? Too large and there will be a long
|
|
-- delay before the message is shown; too short and the message
|
|
-- will clutter things up unncessarily. It's uncommon for 1000
|
|
-- files to change in the index, and processing that many files
|
|
-- takes less than half a second, so that seems about right.
|
|
largediff :: Int
|
|
largediff = 1000
|
|
|