Merge branch 'smudge'

This commit is contained in:
Joey Hess 2015-12-24 19:23:18 -04:00
commit 72e717e14c
Failed to extract signature
76 changed files with 2392 additions and 894 deletions

View file

@ -60,6 +60,7 @@ import Types.NumCopies
import Types.LockCache
import Types.DesktopNotify
import Types.CleanupActions
import qualified Database.Keys.Handle as Keys
#ifdef WITH_QUVI
import Utility.Quvi (QuviVersion)
#endif
@ -134,6 +135,7 @@ data AnnexState = AnnexState
, desktopnotify :: DesktopNotify
, workers :: [Either AnnexState (Async AnnexState)]
, concurrentjobs :: Maybe Int
, keysdbhandle :: Maybe Keys.DbHandle
}
newState :: GitConfig -> Git.Repo -> AnnexState
@ -179,6 +181,7 @@ newState c r = AnnexState
, desktopnotify = mempty
, workers = []
, concurrentjobs = Nothing
, keysdbhandle = Nothing
}
{- Makes an Annex state object for the specified git repo.
@ -193,25 +196,32 @@ new r = do
{- Performs an action in the Annex monad from a starting state,
- returning a new state. -}
run :: AnnexState -> Annex a -> IO (a, AnnexState)
run s a = do
mvar <- newMVar s
run s a = flip run' a =<< newMVar s
run' :: MVar AnnexState -> Annex a -> IO (a, AnnexState)
run' mvar a = do
r <- runReaderT (runAnnex a) mvar
`onException` (flush =<< readMVar mvar)
s' <- takeMVar mvar
flush s'
return (r, s')
where
flush = maybe noop Keys.flushDbQueue . keysdbhandle
{- Performs an action in the Annex monad from a starting state,
- and throws away the new state. -}
eval :: AnnexState -> Annex a -> IO a
eval s a = do
mvar <- newMVar s
runReaderT (runAnnex a) mvar
eval s a = fst <$> run s a
{- Makes a runner action, that allows diving into IO and from inside
- the IO action, running an Annex action. -}
makeRunner :: Annex (Annex a -> IO a)
makeRunner = do
mvar <- ask
return $ \a -> runReaderT (runAnnex a) mvar
return $ \a -> do
(r, s) <- run' mvar a
putMVar mvar s
return r
getState :: (AnnexState -> v) -> Annex v
getState selector = do

View file

@ -25,7 +25,6 @@ import qualified Git.Branch
import Git.Types (BlobType(..))
import Config
import Annex.ReplaceFile
import Git.FileMode
import Annex.VariantFile
import qualified Data.Set as S
@ -135,7 +134,7 @@ resolveMerge' (Just us) them u = do
| select (LsFiles.unmergedBlobType u) == Just SymlinkBlob =
case select' (LsFiles.unmergedSha u) of
Nothing -> return Nothing
Just sha -> catKey sha symLinkMode
Just sha -> catKey sha
| otherwise = return Nothing
makelink key = do
@ -174,7 +173,7 @@ resolveMerge' (Just us) them u = do
case select' (LsFiles.unmergedSha u) of
Nothing -> noop
Just sha -> do
link <- catLink True sha
link <- catSymLinkTarget sha
replacewithlink item link
resolveby a = do

View file

@ -1,6 +1,6 @@
{- git cat-file interface, with handle automatically stored in the Annex monad
-
- Copyright 2011-2013 Joey Hess <id@joeyh.name>
- Copyright 2011-2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@ -16,7 +16,7 @@ module Annex.CatFile (
catKey,
catKeyFile,
catKeyFileHEAD,
catLink,
catSymLinkTarget,
) where
import qualified Data.ByteString.Lazy as L
@ -29,8 +29,8 @@ import qualified Git.CatFile
import qualified Annex
import Git.Types
import Git.FilePath
import Git.FileMode
import qualified Git.Ref
import Annex.Link
catFile :: Git.Branch -> FilePath -> Annex L.ByteString
catFile branch file = do
@ -80,52 +80,17 @@ catFileStop = do
(s { Annex.catfilehandles = M.empty }, Annex.catfilehandles s)
liftIO $ mapM_ Git.CatFile.catFileStop (M.elems m)
{- From the Sha or Ref of a symlink back to the key.
-
- Requires a mode witness, to guarantee that the file is a symlink.
-}
catKey :: Ref -> FileMode -> Annex (Maybe Key)
catKey = catKey' True
catKey' :: Bool -> Sha -> FileMode -> Annex (Maybe Key)
catKey' modeguaranteed sha mode
| isSymLink mode = do
l <- catLink modeguaranteed sha
return $ if isLinkToAnnex l
then fileKey $ takeFileName l
else Nothing
| otherwise = return Nothing
{- From ref to a symlink or a pointer file, get the key. -}
catKey :: Ref -> Annex (Maybe Key)
catKey ref = parseLinkOrPointer <$> catObject ref
{- Gets a symlink target. -}
catLink :: Bool -> Sha -> Annex String
catLink modeguaranteed sha = fromInternalGitPath . decodeBS <$> get
catSymLinkTarget :: Sha -> Annex String
catSymLinkTarget sha = fromInternalGitPath . decodeBS <$> get
where
-- If the mode is not guaranteed to be correct, avoid
-- buffering the whole file content, which might be large.
-- 8192 is enough if it really is a symlink.
get
| modeguaranteed = catObject sha
| otherwise = L.take 8192 <$> catObject sha
{- Looks up the key corresponding to the Ref using the running cat-file.
-
- Currently this always has to look in HEAD, because cat-file --batch
- does not offer a way to specify that we want to look up a tree object
- in the index. So if the index has a file staged not as a symlink,
- and it is a symlink in head, the wrong mode is gotten.
- Also, we have to assume the file is a symlink if it's not yet committed
- to HEAD. For these reasons, modeguaranteed is not set.
-}
catKeyChecked :: Bool -> Ref -> Annex (Maybe Key)
catKeyChecked needhead ref@(Ref r) =
catKey' False ref =<< findmode <$> catTree treeref
where
pathparts = split "/" r
dir = intercalate "/" $ take (length pathparts - 1) pathparts
file = fromMaybe "" $ lastMaybe pathparts
treeref = Ref $ if needhead then "HEAD" ++ dir ++ "/" else dir ++ "/"
findmode = fromMaybe symLinkMode . headMaybe .
map snd . filter (\p -> fst p == file)
-- Avoid buffering the whole file content, which might be large.
-- 8192 is enough if it really is a symlink or pointer file.
get = L.take 8192 <$> catObject sha
{- From a file in the repository back to the key.
-
@ -151,8 +116,8 @@ catKeyChecked needhead ref@(Ref r) =
catKeyFile :: FilePath -> Annex (Maybe Key)
catKeyFile f = ifM (Annex.getState Annex.daemon)
( catKeyFileHEAD f
, catKeyChecked True $ Git.Ref.fileRef f
, catKey $ Git.Ref.fileRef f
)
catKeyFileHEAD :: FilePath -> Annex (Maybe Key)
catKeyFileHEAD f = catKeyChecked False $ Git.Ref.fileFromRef Git.Ref.headRef f
catKeyFileHEAD f = catKey $ Git.Ref.fileFromRef Git.Ref.headRef f

View file

@ -1,6 +1,6 @@
{- git-annex file content managing
-
- Copyright 2010-2014 Joey Hess <id@joeyh.name>
- Copyright 2010-2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@ -24,6 +24,12 @@ module Annex.Content (
withTmp,
checkDiskSpace,
moveAnnex,
populatePointerFile,
linkAnnex,
linkAnnex',
LinkAnnexResult(..),
unlinkAnnex,
checkedCopyFile,
sendAnnex,
prepSendAnnex,
removeAnnex,
@ -38,6 +44,7 @@ module Annex.Content (
dirKeys,
withObjectLoc,
staleKeysPrune,
isUnmodified,
) where
import System.IO.Unsafe (unsafeInterleaveIO)
@ -61,15 +68,19 @@ import Config
import Git.SharedRepository
import Annex.Perms
import Annex.Link
import Annex.Content.Direct
import qualified Annex.Content.Direct as Direct
import Annex.ReplaceFile
import Annex.LockPool
import Messages.Progress
import qualified Types.Remote
import qualified Types.Backend
import qualified Backend
import qualified Database.Keys
import Types.NumCopies
import Annex.UUID
import Annex.InodeSentinal
import Utility.InodeCache
import Utility.PosixFiles
{- Checks if a given key's content is currently present. -}
inAnnex :: Key -> Annex Bool
@ -79,7 +90,10 @@ inAnnex key = inAnnexCheck key $ liftIO . doesFileExist
inAnnexCheck :: Key -> (FilePath -> Annex Bool) -> Annex Bool
inAnnexCheck key check = inAnnex' id False check key
{- Generic inAnnex, handling both indirect and direct mode.
{- inAnnex that performs an arbitrary check of the key's content.
-
- When the content is unlocked, it must also be unmodified, or the bad
- value will be returned.
-
- In direct mode, at least one of the associated files must pass the
- check. Additionally, the file must be unmodified.
@ -88,14 +102,22 @@ inAnnex' :: (a -> Bool) -> a -> (FilePath -> Annex a) -> Key -> Annex a
inAnnex' isgood bad check key = withObjectLoc key checkindirect checkdirect
where
checkindirect loc = do
whenM (fromRepo Git.repoIsUrl) $
error "inAnnex cannot check remote repo"
check loc
r <- check loc
if isgood r
then do
cache <- Database.Keys.getInodeCaches key
if null cache
then return r
else ifM (sameInodeCache loc cache)
( return r
, return bad
)
else return bad
checkdirect [] = return bad
checkdirect (loc:locs) = do
r <- check loc
if isgood r
then ifM (goodContent key loc)
then ifM (Direct.goodContent key loc)
( return r
, checkdirect locs
)
@ -371,7 +393,7 @@ withTmp key action = do
return res
{- Checks that there is disk space available to store a given key,
- in a destination (or the annex) printing a warning if not.
- in a destination directory (or the annex) printing a warning if not.
-
- If the destination is on the same filesystem as the annex,
- checks for any other running downloads, removing the amount of data still
@ -379,7 +401,12 @@ withTmp key action = do
- when doing concurrent downloads.
-}
checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Bool -> Annex Bool
checkDiskSpace destdir key alreadythere samefilesystem = ifM (Annex.getState Annex.force)
checkDiskSpace destdir key = checkDiskSpace' (fromMaybe 1 (keySize key)) destdir key
{- Allows specifying the size of the key, if it's known, which is useful
- as not all keys know their size. -}
checkDiskSpace' :: Integer -> Maybe FilePath -> Key -> Integer -> Bool -> Annex Bool
checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getState Annex.force)
( return True
, do
-- We can't get inprogress and free at the same
@ -392,8 +419,8 @@ checkDiskSpace destdir key alreadythere samefilesystem = ifM (Annex.getState Ann
then sizeOfDownloadsInProgress (/= key)
else pure 0
free <- liftIO . getDiskFree =<< dir
case (free, fromMaybe 1 (keySize key)) of
(Just have, need) -> do
case free of
Just have -> do
reserve <- annexDiskReserve <$> Annex.getGitConfig
let delta = need + reserve - have - alreadythere + inprogress
let ok = delta <= 0
@ -412,7 +439,10 @@ checkDiskSpace destdir key alreadythere samefilesystem = ifM (Annex.getState Ann
{- Moves a key's content into .git/annex/objects/
-
- In direct mode, moves it to the associated file, or files.
- When a key has associated pointer files, the object is hard
- linked (or copied) to the files, and the object file is left thawed.
- In direct mode, moves the object file to the associated file, or files.
-
- What if the key there already has content? This could happen for
- various reasons; perhaps the same content is being annexed again.
@ -440,7 +470,12 @@ moveAnnex key src = withObjectLoc key storeobject storedirect
( alreadyhave
, modifyContent dest $ do
liftIO $ moveFile src dest
freezeContent dest
fs <- Database.Keys.getAssociatedFiles key
if null fs
then freezeContent dest
else do
mapM_ (populatePointerFile key dest) fs
Database.Keys.storeInodeCaches key (dest:fs)
)
storeindirect = storeobject =<< calcRepo (gitAnnexLocation key)
@ -458,21 +493,116 @@ moveAnnex key src = withObjectLoc key storeobject storedirect
v <- isAnnexLink f
if Just key == v
then do
updateInodeCache key src
Direct.updateInodeCache key src
replaceFile f $ liftIO . moveFile src
chmodContent f
forM_ fs $
addContentWhenNotPresent key f
else ifM (goodContent key f)
Direct.addContentWhenNotPresent key f
else ifM (Direct.goodContent key f)
( storedirect' alreadyhave fs
, storedirect' fallback fs
)
alreadyhave = liftIO $ removeFile src
populatePointerFile :: Key -> FilePath -> FilePath -> Annex ()
populatePointerFile k obj f = go =<< isPointerFile f
where
go (Just k') | k == k' = do
liftIO $ nukeFile f
unlessM (linkAnnex'' k obj f) $
liftIO $ writeFile f (formatPointer k)
go _ = return ()
{- Hard links a file into .git/annex/objects/, falling back to a copy
- if necessary. Does nothing if the object file already exists.
-
- Does not lock down the hard linked object, so that the user can modify
- the source file. So, adding an object to the annex this way can
- prevent losing the content if the source file is deleted, but does not
- guard against modifications.
-}
linkAnnex :: Key -> FilePath -> Maybe InodeCache -> Annex LinkAnnexResult
linkAnnex key src srcic = do
dest <- calcRepo (gitAnnexLocation key)
modifyContent dest $ linkAnnex' key src srcic dest
{- Hard links (or copies) src to dest, one of which should be the
- annex object. Updates inode cache for src and for dest when it's
- changed. -}
linkAnnex' :: Key -> FilePath -> Maybe InodeCache -> FilePath -> Annex LinkAnnexResult
linkAnnex' _ _ Nothing _ = return LinkAnnexFailed
linkAnnex' key src (Just srcic) dest =
ifM (liftIO $ doesFileExist dest)
( do
Database.Keys.addInodeCaches key [srcic]
return LinkAnnexNoop
, ifM (linkAnnex'' key src dest)
( do
thawContent dest
-- src could have changed while being copied
-- to dest
mcache <- withTSDelta (liftIO . genInodeCache src)
case mcache of
Just srcic' | compareStrong srcic srcic' -> do
destic <- withTSDelta (liftIO . genInodeCache dest)
Database.Keys.addInodeCaches key $
catMaybes [destic, Just srcic]
return LinkAnnexOk
_ -> do
liftIO $ nukeFile dest
failed
, failed
)
)
where
failed = do
Database.Keys.addInodeCaches key [srcic]
return LinkAnnexFailed
data LinkAnnexResult = LinkAnnexOk | LinkAnnexFailed | LinkAnnexNoop
{- Hard links or copies src to dest. Only uses a hard link if src
- is not already hardlinked to elsewhere. Checks disk reserve before
- copying, and will fail if not enough space, or if the dest file
- already exists. -}
linkAnnex'' :: Key -> FilePath -> FilePath -> Annex Bool
linkAnnex'' key src dest = catchBoolIO $ do
s <- liftIO $ getFileStatus src
let copy = checkedCopyFile' key src dest s
#ifndef mingw32_HOST_OS
if linkCount s > 1
then copy
else liftIO (createLink src dest >> return True)
`catchIO` const copy
#else
copy
#endif
{- Removes the annex object file for a key. Lowlevel. -}
unlinkAnnex :: Key -> Annex ()
unlinkAnnex key = do
obj <- calcRepo $ gitAnnexLocation key
modifyContent obj $ do
secureErase obj
liftIO $ nukeFile obj
{- Checks disk space before copying. -}
checkedCopyFile :: Key -> FilePath -> FilePath -> Annex Bool
checkedCopyFile key src dest = catchBoolIO $
checkedCopyFile' key src dest
=<< liftIO (getFileStatus src)
checkedCopyFile' :: Key -> FilePath -> FilePath -> FileStatus -> Annex Bool
checkedCopyFile' key src dest s = catchBoolIO $
ifM (checkDiskSpace' (fromIntegral $ fileSize s) (Just $ takeDirectory dest) key 0 True)
( liftIO $ copyFileExternal CopyAllMetaData src dest
, return False
)
{- Runs an action to transfer an object's content.
-
- In direct mode, it's possible for the file to change as it's being sent.
- In some cases, it's possible for the file to change as it's being sent.
- If this happens, runs the rollback action and returns False. The
- rollback action should remove the data that was transferred.
-}
@ -492,8 +622,9 @@ sendAnnex key rollback sendobject = go =<< prepSendAnnex key
{- Returns a file that contains an object's content,
- and a check to run after the transfer is complete.
-
- In direct mode, it's possible for the file to change as it's being sent,
- and the check detects this case and returns False.
- When a file is unlocked (or in direct mode), it's possble for its
- content to change as it's being sent. The check detects this case
- and returns False.
-
- Note that the returned check action is, in some cases, run in the
- Annex monad of the remote that is receiving the object, rather than
@ -502,10 +633,23 @@ sendAnnex key rollback sendobject = go =<< prepSendAnnex key
prepSendAnnex :: Key -> Annex (Maybe (FilePath, Annex Bool))
prepSendAnnex key = withObjectLoc key indirect direct
where
indirect f = return $ Just (f, return True)
indirect f = do
cache <- Database.Keys.getInodeCaches key
cache' <- if null cache
-- Since no inode cache is in the database, this
-- object is not currently unlocked. But that could
-- change while the transfer is in progress, so
-- generate an inode cache for the starting
-- content.
then maybeToList <$>
withTSDelta (liftIO . genInodeCache f)
else pure cache
return $ if null cache'
then Nothing
else Just (f, sameInodeCache f cache')
direct [] = return Nothing
direct (f:fs) = do
cache <- recordedInodeCache key
cache <- Direct.recordedInodeCache key
-- check that we have a good file
ifM (sameInodeCache f cache)
( return $ Just (f, sameInodeCache f cache)
@ -520,7 +664,7 @@ prepSendAnnex key = withObjectLoc key indirect direct
withObjectLoc :: Key -> (FilePath -> Annex a) -> ([FilePath] -> Annex a) -> Annex a
withObjectLoc key indirect direct = ifM isDirect
( do
fs <- associatedFiles key
fs <- Direct.associatedFiles key
if null fs
then goindirect
else direct fs
@ -543,6 +687,9 @@ cleanObjectLoc key cleaner = do
<=< catchMaybeIO $ removeDirectory dir
{- Removes a key's file from .git/annex/objects/
-
- When a key has associated pointer files, they are checked for
- modifications, and if unmodified, are reset.
-
- In direct mode, deletes the associated files or files, and replaces
- them with symlinks.
@ -553,16 +700,50 @@ removeAnnex (ContentRemovalLock key) = withObjectLoc key remove removedirect
remove file = cleanObjectLoc key $ do
secureErase file
liftIO $ nukeFile file
removeInodeCache key
mapM_ (void . tryIO . resetpointer)
=<< Database.Keys.getAssociatedFiles key
Database.Keys.removeInodeCaches key
Direct.removeInodeCache key
resetpointer file = ifM (isUnmodified key file)
( do
secureErase file
liftIO $ nukeFile file
liftIO $ writeFile file (formatPointer key)
-- Can't delete the pointer file.
-- If it was a hard link to the annex object,
-- that object might have been frozen as part of the
-- removal process, so thaw it.
, void $ tryIO $ thawContent file
)
removedirect fs = do
cache <- recordedInodeCache key
removeInodeCache key
cache <- Direct.recordedInodeCache key
Direct.removeInodeCache key
mapM_ (resetfile cache) fs
resetfile cache f = whenM (sameInodeCache f cache) $ do
resetfile cache f = whenM (Direct.sameInodeCache f cache) $ do
l <- calcRepo $ gitAnnexLink f key
secureErase f
replaceFile f $ makeAnnexLink l
{- Check if a file contains the unmodified content of the key.
-
- The expensive way to tell is to do a verification of its content.
- The cheaper way is to see if the InodeCache for the key matches the
- file. -}
isUnmodified :: Key -> FilePath -> Annex Bool
isUnmodified key f = go =<< geti
where
go Nothing = return False
go (Just fc) = cheapcheck fc <||> expensivecheck fc
cheapcheck fc = anyM (compareInodeCaches fc)
=<< Database.Keys.getInodeCaches key
expensivecheck fc = ifM (verifyKeyContent AlwaysVerify Types.Remote.UnVerified key f)
-- The file could have been modified while it was
-- being verified. Detect that.
( geti >>= maybe (return False) (compareInodeCaches fc)
, return False
)
geti = withTSDelta (liftIO . genInodeCache f)
{- Runs the secure erase command if set, otherwise does nothing.
- File may or may not be deleted at the end; caller is responsible for
- making sure it's deleted. -}
@ -586,13 +767,14 @@ moveBad key = do
logStatus key InfoMissing
return dest
data KeyLocation = InAnnex | InRepository
data KeyLocation = InAnnex | InRepository | InAnywhere
{- List of keys whose content exists in the specified location.
- InAnnex only lists keys under .git/annex/objects,
- while InRepository, in direct mode, also finds keys located in the
- work tree.
- InAnnex only lists keys with content in .git/annex/objects,
- while InRepository, in direct mode, also finds keys with content
- in the work tree. InAnywhere lists all keys that have directories
- in .git/annex/objects, whether or not the content is present.
-
- Note that InRepository has to check whether direct mode files
- have goodContent.
@ -621,6 +803,11 @@ getKeysPresent keyloc = do
morekeys <- unsafeInterleaveIO a
continue (morekeys++keys) as
inanywhere = case keyloc of
InAnywhere -> True
_ -> False
present _ _ _ | inanywhere = pure True
present _ False d = presentInAnnex d
present s True d = presentDirect s d <||> presentInAnnex d
@ -632,7 +819,8 @@ getKeysPresent keyloc = do
InRepository -> case fileKey (takeFileName d) of
Nothing -> return False
Just k -> Annex.eval s $
anyM (goodContent k) =<< associatedFiles k
anyM (Direct.goodContent k) =<< Direct.associatedFiles k
InAnywhere -> return True
{- In order to run Annex monad actions within unsafeInterleaveIO,
- the current state is taken and reused. No changes made to this

View file

@ -1,12 +1,13 @@
{- git-annex file content managing for direct mode
-
- This is deprecated, and will be removed when direct mode gets removed
- from git-annex.
-
- Copyright 2012-2014 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Annex.Content.Direct (
associatedFiles,
associatedFilesRelative,
@ -20,21 +21,15 @@ module Annex.Content.Direct (
addInodeCache,
writeInodeCache,
compareInodeCaches,
compareInodeCachesWith,
sameInodeCache,
elemInodeCaches,
sameFileStatus,
removeInodeCache,
toInodeCache,
inodesChanged,
createInodeSentinalFile,
addContentWhenNotPresent,
withTSDelta,
getTSDelta,
) where
import Common.Annex
import qualified Annex
import Annex.Perms
import qualified Git
import Utility.Tmp
@ -43,6 +38,7 @@ import Utility.InodeCache
import Utility.CopyFile
import Annex.ReplaceFile
import Annex.Link
import Annex.InodeSentinal
{- Absolute FilePaths of Files in the tree that are associated with a key. -}
associatedFiles :: Key -> Annex [FilePath]
@ -165,14 +161,6 @@ removeInodeCache key = withInodeCacheFile key $ \f ->
withInodeCacheFile :: Key -> (FilePath -> Annex a) -> Annex a
withInodeCacheFile key a = a =<< calcRepo (gitAnnexInodeCache key)
{- Checks if a InodeCache matches the current version of a file. -}
sameInodeCache :: FilePath -> [InodeCache] -> Annex Bool
sameInodeCache _ [] = return False
sameInodeCache file old = go =<< withTSDelta (liftIO . genInodeCache file)
where
go Nothing = return False
go (Just curr) = elemInodeCaches curr old
{- Checks if a FileStatus matches the recorded InodeCache of a file. -}
sameFileStatus :: Key -> FilePath -> FileStatus -> Annex Bool
sameFileStatus key f status = do
@ -183,25 +171,6 @@ sameFileStatus key f status = do
([], Nothing) -> return True
_ -> return False
{- If the inodes have changed, only the size and mtime are compared. -}
compareInodeCaches :: InodeCache -> InodeCache -> Annex Bool
compareInodeCaches x y
| compareStrong x y = return True
| otherwise = ifM inodesChanged
( return $ compareWeak x y
, return False
)
elemInodeCaches :: InodeCache -> [InodeCache] -> Annex Bool
elemInodeCaches _ [] = return False
elemInodeCaches c (l:ls) = ifM (compareInodeCaches c l)
( return True
, elemInodeCaches c ls
)
compareInodeCachesWith :: Annex InodeComparisonType
compareInodeCachesWith = ifM inodesChanged ( return Weakly, return Strongly )
{- Copies the contentfile to the associated file, if the associated
- file has no content. If the associated file does have content,
- even if the content differs, it's left unchanged. -}
@ -212,52 +181,3 @@ addContentWhenNotPresent key contentfile associatedfile = do
replaceFile associatedfile $
liftIO . void . copyFileExternal CopyAllMetaData contentfile
updateInodeCache key associatedfile
{- Some filesystems get new inodes each time they are mounted.
- In order to work on such a filesystem, a sentinal file is used to detect
- when the inodes have changed.
-
- If the sentinal file does not exist, we have to assume that the
- inodes have changed.
-}
inodesChanged :: Annex Bool
inodesChanged = sentinalInodesChanged <$> sentinalStatus
withTSDelta :: (TSDelta -> Annex a) -> Annex a
withTSDelta a = a =<< getTSDelta
getTSDelta :: Annex TSDelta
#ifdef mingw32_HOST_OS
getTSDelta = sentinalTSDelta <$> sentinalStatus
#else
getTSDelta = pure noTSDelta -- optimisation
#endif
sentinalStatus :: Annex SentinalStatus
sentinalStatus = maybe check return =<< Annex.getState Annex.sentinalstatus
where
check = do
sc <- liftIO . checkSentinalFile =<< annexSentinalFile
Annex.changeState $ \s -> s { Annex.sentinalstatus = Just sc }
return sc
{- The sentinal file is only created when first initializing a repository.
- If there are any annexed objects in the repository already, creating
- the file would invalidate their inode caches. -}
createInodeSentinalFile :: Annex ()
createInodeSentinalFile = unlessM (alreadyexists <||> hasobjects) $ do
s <- annexSentinalFile
createAnnexDirectory (parentDir (sentinalFile s))
liftIO $ writeSentinalFile s
where
alreadyexists = liftIO. sentinalFileExists =<< annexSentinalFile
hasobjects = liftIO . doesDirectoryExist =<< fromRepo gitAnnexObjectDir
annexSentinalFile :: Annex SentinalFile
annexSentinalFile = do
sentinalfile <- fromRepo gitAnnexInodeSentinal
sentinalcachefile <- fromRepo gitAnnexInodeSentinalCache
return SentinalFile
{ sentinalFile = sentinalfile
, sentinalCacheFile = sentinalcachefile
}

View file

@ -1,4 +1,7 @@
{- git-annex direct mode
-
- This is deprecated, and will be removed when direct mode gets removed
- from git-annex.
-
- Copyright 2012-2014 Joey Hess <id@joeyh.name>
-
@ -36,6 +39,7 @@ import Annex.VariantFile
import Git.Index
import Annex.Index
import Annex.LockFile
import Annex.InodeSentinal
{- Uses git ls-files to find files that need to be committed, and stages
- them into the index. Returns True if some changes were staged. -}
@ -53,8 +57,8 @@ stageDirect = do
{- Determine what kind of modified or deleted file this is, as
- efficiently as we can, by getting any key that's associated
- with it in git, as well as its stat info. -}
go (file, Just sha, Just mode) = withTSDelta $ \delta -> do
shakey <- catKey sha mode
go (file, Just sha, Just _mode) = withTSDelta $ \delta -> do
shakey <- catKey sha
mstat <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file
mcache <- liftIO $ maybe (pure Nothing) (toInodeCache delta file) mstat
filekey <- isAnnexLink file
@ -107,8 +111,8 @@ preCommitDirect = do
withkey (DiffTree.srcsha diff) (DiffTree.srcmode diff) removeAssociatedFile
withkey (DiffTree.dstsha diff) (DiffTree.dstmode diff) addAssociatedFile
where
withkey sha mode a = when (sha /= nullSha) $ do
k <- catKey sha mode
withkey sha _mode a = when (sha /= nullSha) $ do
k <- catKey sha
case k of
Nothing -> noop
Just key -> void $ a key $
@ -256,16 +260,16 @@ updateWorkTree d oldref force = do
makeabs <- flip fromTopFilePath <$> gitRepo
let fsitems = zip (map (makeabs . DiffTree.file) items) items
forM_ fsitems $
go makeabs DiffTree.srcsha DiffTree.srcmode moveout moveout_raw
go makeabs DiffTree.srcsha moveout moveout_raw
forM_ fsitems $
go makeabs DiffTree.dstsha DiffTree.dstmode movein movein_raw
go makeabs DiffTree.dstsha movein movein_raw
void $ liftIO cleanup
where
go makeabs getsha getmode a araw (f, item)
go makeabs getsha a araw (f, item)
| getsha item == nullSha = noop
| otherwise = void $
tryNonAsync . maybe (araw item makeabs f) (\k -> void $ a item makeabs k f)
=<< catKey (getsha item) (getmode item)
=<< catKey (getsha item)
moveout _ _ = removeDirect
@ -395,7 +399,7 @@ changedDirect oldk f = do
whenM (pure (null locs) <&&> not <$> inAnnex oldk) $
logStatus oldk InfoMissing
{- Enable/disable direct mode. -}
{- Git config settings to enable/disable direct mode. -}
setDirect :: Bool -> Annex ()
setDirect wantdirect = do
if wantdirect

View file

@ -14,7 +14,6 @@ import Limit
import Utility.Matcher
import Types.Group
import Logs.Group
import Logs.Remote
import Annex.UUID
import qualified Annex
import Types.FileMatcher
@ -53,8 +52,8 @@ parsedToMatcher parsed = case partitionEithers parsed of
([], vs) -> Right $ generate vs
(es, _) -> Left $ unwords $ map ("Parse failure: " ++) es
exprParser :: FileMatcher Annex -> FileMatcher Annex -> GroupMap -> M.Map UUID RemoteConfig -> Maybe UUID -> String -> [Either String (Token (MatchFiles Annex))]
exprParser matchstandard matchgroupwanted groupmap configmap mu expr =
exprParser :: FileMatcher Annex -> FileMatcher Annex -> Annex GroupMap -> M.Map UUID RemoteConfig -> Maybe UUID -> String -> [Either String (Token (MatchFiles Annex))]
exprParser matchstandard matchgroupwanted getgroupmap configmap mu expr =
map parse $ tokenizeMatcher expr
where
parse = parseToken
@ -62,12 +61,12 @@ exprParser matchstandard matchgroupwanted groupmap configmap mu expr =
matchgroupwanted
(limitPresent mu)
(limitInDir preferreddir)
groupmap
getgroupmap
preferreddir = fromMaybe "public" $
M.lookup "preferreddir" =<< (`M.lookup` configmap) =<< mu
parseToken :: FileMatcher Annex -> FileMatcher Annex -> MkLimit Annex -> MkLimit Annex -> GroupMap -> String -> Either String (Token (MatchFiles Annex))
parseToken matchstandard matchgroupwanted checkpresent checkpreferreddir groupmap t
parseToken :: FileMatcher Annex -> FileMatcher Annex -> MkLimit Annex -> MkLimit Annex -> Annex GroupMap -> String -> Either String (Token (MatchFiles Annex))
parseToken matchstandard matchgroupwanted checkpresent checkpreferreddir getgroupmap t
| t `elem` tokens = Right $ token t
| t == "standard" = call matchstandard
| t == "groupwanted" = call matchgroupwanted
@ -86,7 +85,7 @@ parseToken matchstandard matchgroupwanted checkpresent checkpreferreddir groupma
, ("largerthan", limitSize (>))
, ("smallerthan", limitSize (<))
, ("metadata", limitMetaData)
, ("inallgroup", limitInAllGroup groupmap)
, ("inallgroup", limitInAllGroup getgroupmap)
]
where
(k, v) = separate (== '=') t
@ -109,9 +108,12 @@ largeFilesMatcher = go =<< annexLargeFiles <$> Annex.getGitConfig
where
go Nothing = return matchAll
go (Just expr) = do
gm <- groupMap
rc <- readRemoteLog
u <- getUUID
-- No need to read remote configs, that's only needed for
-- inpreferreddir, which is used in preferred content
-- expressions but does not make sense in the
-- annex.largefiles expression.
let emptyconfig = M.empty
either badexpr return $
parsedToMatcher $ exprParser matchAll matchAll gm rc (Just u) expr
parsedToMatcher $ exprParser matchAll matchAll groupMap emptyconfig (Just u) expr
badexpr e = error $ "bad annex.largefiles configuration: " ++ e

289
Annex/Ingest.hs Normal file
View file

@ -0,0 +1,289 @@
{- git-annex content ingestion
-
- Copyright 2010-2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Annex.Ingest (
LockedDown(..),
lockDown,
ingest,
finishIngestDirect,
finishIngestUnlocked,
cleanOldKeys,
addLink,
makeLink,
restoreFile,
forceParams,
) where
import Common.Annex
import Types.KeySource
import Backend
import Annex.Content
import Annex.Content.Direct
import Annex.Perms
import Annex.Link
import Annex.MetaData
import Logs.Location
import qualified Annex
import qualified Annex.Queue
import qualified Database.Keys
import Config
import Utility.InodeCache
import Annex.ReplaceFile
import Utility.Tmp
import Utility.CopyFile
import Annex.InodeSentinal
#ifdef WITH_CLIBS
#ifndef __ANDROID__
import Utility.Touch
#endif
#endif
import Control.Exception (IOException)
data LockedDown = LockedDown
{ lockingFile :: Bool
, keySource :: KeySource
}
deriving (Show)
{- The file that's being ingested is locked down before a key is generated,
- to prevent it from being modified in between. This lock down is not
- perfect at best (and pretty weak at worst). For example, it does not
- guard against files that are already opened for write by another process.
- So, the InodeCache can be used to detect any changes that might be made
- to the file after it was locked down.
-
- When possible, the file is hard linked to a temp directory. This guards
- against some changes, like deletion or overwrite of the file, and
- allows lsof checks to be done more efficiently when adding a lot of files.
-
- If lockingfile is True, the file is going to be added in locked mode.
- So, its write bit is removed as part of the lock down.
-
- Lockdown can fail if a file gets deleted, and Nothing will be returned.
-}
lockDown :: Bool -> FilePath -> Annex (Maybe LockedDown)
lockDown lockingfile file = either
(\e -> warning (show e) >> return Nothing)
(return . Just)
=<< lockDown' lockingfile file
lockDown' :: Bool -> FilePath -> Annex (Either IOException LockedDown)
lockDown' lockingfile file = ifM crippledFileSystem
( withTSDelta $ liftIO . tryIO . nohardlink
, tryIO $ do
tmp <- fromRepo gitAnnexTmpMiscDir
createAnnexDirectory tmp
when lockingfile $
freezeContent file
withTSDelta $ \delta -> liftIO $ do
(tmpfile, h) <- openTempFile tmp $
relatedTemplate $ takeFileName file
hClose h
nukeFile tmpfile
withhardlink delta tmpfile `catchIO` const (nohardlink delta)
)
where
nohardlink delta = do
cache <- genInodeCache file delta
return $ LockedDown lockingfile $ KeySource
{ keyFilename = file
, contentLocation = file
, inodeCache = cache
}
withhardlink delta tmpfile = do
createLink file tmpfile
cache <- genInodeCache tmpfile delta
return $ LockedDown lockingfile $ KeySource
{ keyFilename = file
, contentLocation = tmpfile
, inodeCache = cache
}
{- Ingests a locked down file into the annex.
-
- The file may be added to the git repository as a locked or an unlocked
- file. When unlocked, the work tree file is left alone. When locked,
- the work tree file is deleted, in preparation for adding the symlink.
-}
ingest :: Maybe LockedDown -> Annex (Maybe Key, Maybe InodeCache)
ingest Nothing = return (Nothing, Nothing)
ingest (Just (LockedDown lockingfile source)) = withTSDelta $ \delta -> do
backend <- chooseBackend $ keyFilename source
k <- genKey source backend
let src = contentLocation source
ms <- liftIO $ catchMaybeIO $ getFileStatus src
mcache <- maybe (pure Nothing) (liftIO . toInodeCache delta src) ms
case (mcache, inodeCache source) of
(_, Nothing) -> go k mcache ms
(Just newc, Just c) | compareStrong c newc -> go k mcache ms
_ -> failure "changed while it was being added"
where
go (Just (key, _)) mcache (Just s)
| lockingfile = golocked key mcache s
| otherwise = ifM isDirect
( godirect key mcache s
, gounlocked key mcache s
)
go _ _ _ = failure "failed to generate a key"
golocked key mcache s = do
catchNonAsync (moveAnnex key $ contentLocation source)
(restoreFile (keyFilename source) key)
liftIO $ nukeFile $ keyFilename source
populateAssociatedFiles key source
success key mcache s
gounlocked key (Just cache) s = do
-- Remove temp directory hard link first because
-- linkAnnex falls back to copying if a file
-- already has a hard link.
cleanCruft source
cleanOldKeys (keyFilename source) key
r <- linkAnnex key (keyFilename source) (Just cache)
case r of
LinkAnnexFailed -> failure "failed to link to annex"
_ -> do
finishIngestUnlocked' key source
success key (Just cache) s
gounlocked _ _ _ = failure "failed statting file"
godirect key (Just cache) s = do
addInodeCache key cache
finishIngestDirect key source
success key (Just cache) s
godirect _ _ _ = failure "failed statting file"
success k mcache s = do
genMetaData k (keyFilename source) s
return (Just k, mcache)
failure msg = do
warning $ keyFilename source ++ " " ++ msg
cleanCruft source
return (Nothing, Nothing)
finishIngestDirect :: Key -> KeySource -> Annex ()
finishIngestDirect key source = do
void $ addAssociatedFile key $ keyFilename source
cleanCruft source
{- Copy to any other locations using the same key. -}
otherfs <- filter (/= keyFilename source) <$> associatedFiles key
forM_ otherfs $
addContentWhenNotPresent key (keyFilename source)
finishIngestUnlocked :: Key -> KeySource -> Annex ()
finishIngestUnlocked key source = do
cleanCruft source
finishIngestUnlocked' key source
finishIngestUnlocked' :: Key -> KeySource -> Annex ()
finishIngestUnlocked' key source = do
Database.Keys.addAssociatedFile key (keyFilename source)
populateAssociatedFiles key source
{- Copy to any other locations using the same key. -}
populateAssociatedFiles :: Key -> KeySource -> Annex ()
populateAssociatedFiles key source = do
otherfs <- filter (/= keyFilename source) <$> Database.Keys.getAssociatedFiles key
obj <- calcRepo (gitAnnexLocation key)
forM_ otherfs $
populatePointerFile key obj
cleanCruft :: KeySource -> Annex ()
cleanCruft source = when (contentLocation source /= keyFilename source) $
liftIO $ nukeFile $ contentLocation source
-- If a worktree file was was hard linked to an annex object before,
-- modifying the file would have caused the object to have the wrong
-- content. Clean up from that.
cleanOldKeys :: FilePath -> Key -> Annex ()
cleanOldKeys file newkey = do
oldkeys <- filter (/= newkey)
<$> Database.Keys.getAssociatedKey file
mapM_ go oldkeys
where
go key = do
obj <- calcRepo (gitAnnexLocation key)
caches <- Database.Keys.getInodeCaches key
unlessM (sameInodeCache obj caches) $ do
unlinkAnnex key
fs <- filter (/= file)
<$> Database.Keys.getAssociatedFiles key
fs' <- filterM (`sameInodeCache` caches) fs
case fs' of
-- If linkAnnex fails, the associated
-- file with the content is still present,
-- so no need for any recovery.
(f:_) -> do
ic <- withTSDelta (liftIO . genInodeCache f)
void $ linkAnnex key f ic
_ -> lostcontent
where
lostcontent = logStatus key InfoMissing
{- On error, put the file back so it doesn't seem to have vanished.
- This can be called before or after the symlink is in place. -}
restoreFile :: FilePath -> Key -> SomeException -> Annex a
restoreFile file key e = do
whenM (inAnnex key) $ do
liftIO $ nukeFile file
-- The key could be used by other files too, so leave the
-- content in the annex, and make a copy back to the file.
obj <- calcRepo $ gitAnnexLocation key
unlessM (liftIO $ copyFileExternal CopyTimeStamps obj file) $
warning $ "Unable to restore content of " ++ file ++ "; it should be located in " ++ obj
thawContent file
throwM e
{- Creates the symlink to the annexed content, returns the link target. -}
makeLink :: FilePath -> Key -> Maybe InodeCache -> Annex String
makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do
l <- calcRepo $ gitAnnexLink file key
replaceFile file $ makeAnnexLink l
-- touch symlink to have same time as the original file,
-- as provided in the InodeCache
case mcache of
#if defined(WITH_CLIBS) && ! defined(__ANDROID__)
Just c -> liftIO $ touch file (TimeSpec $ inodeCacheToMtime c) False
#else
Just _ -> noop
#endif
Nothing -> noop
return l
{- Creates the symlink to the annexed content, and stages it in git.
-
- As long as the filesystem supports symlinks, we use
- git add, rather than directly staging the symlink to git.
- Using git add is best because it allows the queuing to work
- and is faster (staging the symlink runs hash-object commands each time).
- Also, using git add allows it to skip gitignored files, unless forced
- to include them.
-}
addLink :: FilePath -> Key -> Maybe InodeCache -> Annex ()
addLink file key mcache = ifM (coreSymlinks <$> Annex.getGitConfig)
( do
_ <- makeLink file key mcache
ps <- forceParams
Annex.Queue.addCommand "add" (ps++[Param "--"]) [file]
, do
l <- makeLink file key mcache
addAnnexLink l file
)
{- Parameters to pass to git add, forcing addition of ignored files. -}
forceParams :: Annex [CommandParam]
forceParams = ifM (Annex.getState Annex.force)
( return [Param "-f"]
, return []
)

View file

@ -29,12 +29,12 @@ import Types.TrustLevel
import Annex.Version
import Annex.Difference
import Annex.UUID
import Annex.Link
import Config
import Annex.Direct
import Annex.Content.Direct
import Annex.Environment
import Backend
import Annex.Hook
import Annex.InodeSentinal
import Upgrade
#ifndef mingw32_HOST_OS
import Utility.UserInfo
@ -57,8 +57,8 @@ genDescription Nothing = do
return $ concat [hostname, ":", reldir]
#endif
initialize :: Maybe String -> Annex ()
initialize mdescription = do
initialize :: Maybe String -> Maybe Version -> Annex ()
initialize mdescription mversion = do
{- Has to come before any commits are made as the shared
- clone heuristic expects no local objects. -}
sharedclone <- checkSharedClone
@ -68,7 +68,7 @@ initialize mdescription = do
ensureCommit $ Annex.Branch.create
prepUUID
initialize'
initialize' mversion
initSharedClone sharedclone
@ -77,15 +77,18 @@ initialize mdescription = do
-- Everything except for uuid setup, shared clone setup, and initial
-- description.
initialize' :: Annex ()
initialize' = do
initialize' :: Maybe Version -> Annex ()
initialize' mversion = do
checkLockSupport
checkFifoSupport
checkCrippledFileSystem
unlessM isBare $
hookWrite preCommitHook
setDifferences
setVersion supportedVersion
unlessM (isJust <$> getVersion) $
setVersion (fromMaybe defaultVersion mversion)
whenM versionSupportsUnlockedPointers
configureSmudgeFilter
ifM (crippledFileSystem <&&> not <$> isBare)
( do
enableDirectMode
@ -95,7 +98,7 @@ initialize' = do
, unlessM isBare
switchHEADBack
)
createInodeSentinalFile
createInodeSentinalFile False
uninitialize :: Annex ()
uninitialize = do
@ -114,7 +117,7 @@ ensureInitialized :: Annex ()
ensureInitialized = getVersion >>= maybe needsinit checkUpgrade
where
needsinit = ifM Annex.Branch.hasSibling
( initialize Nothing
( initialize Nothing Nothing
, error "First run: git-annex init"
)

96
Annex/InodeSentinal.hs Normal file
View file

@ -0,0 +1,96 @@
{- git-annex inode sentinal file
-
- Copyright 2012-2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Annex.InodeSentinal where
import Common.Annex
import qualified Annex
import Utility.InodeCache
import Annex.Perms
{- If the sendinal shows the inodes have changed, only the size and mtime
- are compared. -}
compareInodeCaches :: InodeCache -> InodeCache -> Annex Bool
compareInodeCaches x y
| compareStrong x y = return True
| otherwise = ifM inodesChanged
( return $ compareWeak x y
, return False
)
compareInodeCachesWith :: Annex InodeComparisonType
compareInodeCachesWith = ifM inodesChanged ( return Weakly, return Strongly )
{- Checks if one of the provided old InodeCache matches the current
- version of a file. -}
sameInodeCache :: FilePath -> [InodeCache] -> Annex Bool
sameInodeCache _ [] = return False
sameInodeCache file old = go =<< withTSDelta (liftIO . genInodeCache file)
where
go Nothing = return False
go (Just curr) = elemInodeCaches curr old
elemInodeCaches :: InodeCache -> [InodeCache] -> Annex Bool
elemInodeCaches _ [] = return False
elemInodeCaches c (l:ls) = ifM (compareInodeCaches c l)
( return True
, elemInodeCaches c ls
)
{- Some filesystems get new inodes each time they are mounted.
- In order to work on such a filesystem, a sentinal file is used to detect
- when the inodes have changed.
-
- If the sentinal file does not exist, we have to assume that the
- inodes have changed.
-}
inodesChanged :: Annex Bool
inodesChanged = sentinalInodesChanged <$> sentinalStatus
withTSDelta :: (TSDelta -> Annex a) -> Annex a
withTSDelta a = a =<< getTSDelta
getTSDelta :: Annex TSDelta
#ifdef mingw32_HOST_OS
getTSDelta = sentinalTSDelta <$> sentinalStatus
#else
getTSDelta = pure noTSDelta -- optimisation
#endif
sentinalStatus :: Annex SentinalStatus
sentinalStatus = maybe check return =<< Annex.getState Annex.sentinalstatus
where
check = do
sc <- liftIO . checkSentinalFile =<< annexSentinalFile
Annex.changeState $ \s -> s { Annex.sentinalstatus = Just sc }
return sc
{- The sentinal file is only created when first initializing a repository.
- If there are any annexed objects in the repository already, creating
- the file would invalidate their inode caches. -}
createInodeSentinalFile :: Bool -> Annex ()
createInodeSentinalFile evenwithobjects =
unlessM (alreadyexists <||> hasobjects) $ do
s <- annexSentinalFile
createAnnexDirectory (parentDir (sentinalFile s))
liftIO $ writeSentinalFile s
where
alreadyexists = liftIO. sentinalFileExists =<< annexSentinalFile
hasobjects
| evenwithobjects = pure False
| otherwise = liftIO . doesDirectoryExist =<< fromRepo gitAnnexObjectDir
annexSentinalFile :: Annex SentinalFile
annexSentinalFile = do
sentinalfile <- fromRepo gitAnnexInodeSentinal
sentinalcachefile <- fromRepo gitAnnexInodeSentinalCache
return SentinalFile
{ sentinalFile = sentinalfile
, sentinalCacheFile = sentinalcachefile
}

View file

@ -5,7 +5,9 @@
- On other filesystems, git instead stores the symlink target in a regular
- file.
-
- Copyright 2013 Joey Hess <id@joeyh.name>
- Pointer files are used instead of symlinks for unlocked files.
-
- Copyright 2013-2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@ -19,6 +21,9 @@ import qualified Git.UpdateIndex
import qualified Annex.Queue
import Git.Types
import Git.FilePath
import Types.Key
import qualified Data.ByteString.Lazy as L
type LinkTarget = String
@ -105,8 +110,49 @@ hashSymlink' :: Git.HashObject.HashObjectHandle -> LinkTarget -> Annex Sha
hashSymlink' h linktarget = liftIO $ Git.HashObject.hashBlob h $
toInternalGitPath linktarget
{- Stages a symlink to the annex, using a Sha of its target. -}
{- Stages a symlink to an annexed object, using a Sha of its target. -}
stageSymlink :: FilePath -> Sha -> Annex ()
stageSymlink file sha =
Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.stageSymlink file sha)
{- Injects a pointer file content into git, returning its Sha. -}
hashPointerFile :: Key -> Annex Sha
hashPointerFile key = inRepo $ Git.HashObject.hashObject BlobObject $
formatPointer key
{- Stages a pointer file, using a Sha of its content -}
stagePointerFile :: FilePath -> Sha -> Annex ()
stagePointerFile file sha =
Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.stageFile sha FileBlob file)
{- Parses a symlink target or a pointer file to a Key.
- Only looks at the first line, as pointer files can have subsequent
- lines. -}
parseLinkOrPointer :: L.ByteString -> Maybe Key
parseLinkOrPointer = parseLinkOrPointer' . decodeBS . L.take maxsz
where
{- Want to avoid buffering really big files in git into
- memory when reading files that may be pointers.
-
- 8192 bytes is plenty for a pointer to a key.
- Pad some more to allow for any pointer files that might have
- lines after the key explaining what the file is used for. -}
maxsz = 81920
parseLinkOrPointer' :: String -> Maybe Key
parseLinkOrPointer' s = headMaybe (lines (fromInternalGitPath s)) >>= go
where
go l
| isLinkToAnnex l = file2key $ takeFileName l
| otherwise = Nothing
formatPointer :: Key -> String
formatPointer k =
toInternalGitPath (pathSeparator:objectDir </> key2file k) ++ "\n"
{- Checks if a file is a pointer to a key. -}
isPointerFile :: FilePath -> Annex (Maybe Key)
isPointerFile f = liftIO $ catchDefaultIO Nothing $
parseLinkOrPointer <$> L.readFile f

View file

@ -75,7 +75,7 @@ initRepo False _ dir desc mgroup = inDir dir $ do
initRepo' :: Maybe String -> Maybe StandardGroup -> Annex ()
initRepo' desc mgroup = unlessM isInitialized $ do
initialize desc
initialize desc Nothing
u <- getUUID
maybe noop (defaultStandardGroup u) mgroup
{- Ensure branch gets committed right away so it is

View file

@ -15,14 +15,20 @@ import qualified Annex
type Version = String
supportedVersion :: Version
supportedVersion = "5"
defaultVersion :: Version
defaultVersion = "5"
latestVersion :: Version
latestVersion = "6"
supportedVersions :: [Version]
supportedVersions = ["5", "6"]
upgradableVersions :: [Version]
#ifndef mingw32_HOST_OS
upgradableVersions = ["0", "1", "2", "4"]
upgradableVersions = ["0", "1", "2", "4", "5"]
#else
upgradableVersions = ["2", "3", "4"]
upgradableVersions = ["2", "3", "4", "5"]
#endif
autoUpgradeableVersions :: [Version]
@ -34,6 +40,18 @@ versionField = annexConfig "version"
getVersion :: Annex (Maybe Version)
getVersion = annexVersion <$> Annex.getGitConfig
versionSupportsDirectMode :: Annex Bool
versionSupportsDirectMode = go <$> getVersion
where
go (Just "6") = False
go _ = True
versionSupportsUnlockedPointers :: Annex Bool
versionSupportsUnlockedPointers = go <$> getVersion
where
go (Just "6") = True
go _ = False
setVersion :: Version -> Annex ()
setVersion = setConfig versionField

View file

@ -22,7 +22,7 @@ import Git.Sha
import Git.HashObject
import Git.Types
import Git.FilePath
import qualified Backend
import Annex.WorkTree
import Annex.Index
import Annex.Link
import Annex.CatFile
@ -342,7 +342,7 @@ applyView' mkviewedfile getfilemetadata view = do
hasher <- inRepo hashObjectStart
forM_ l $ \f -> do
relf <- getTopFilePath <$> inRepo (toTopFilePath f)
go uh hasher relf =<< Backend.lookupFile f
go uh hasher relf =<< lookupFile f
liftIO $ do
hashObjectStop hasher
void $ stopUpdateIndex uh
@ -413,13 +413,13 @@ withViewChanges addmeta removemeta = do
handleremovals item
| DiffTree.srcsha item /= nullSha =
handlechange item removemeta
=<< catKey (DiffTree.srcsha item) (DiffTree.srcmode item)
=<< catKey (DiffTree.srcsha item)
| otherwise = noop
handleadds makeabs item
| DiffTree.dstsha item /= nullSha =
handlechange item addmeta
=<< ifM isDirect
( catKey (DiffTree.dstsha item) (DiffTree.dstmode item)
( catKey (DiffTree.dstsha item)
-- optimisation
, isAnnexLink $ makeabs $ DiffTree.file item
)

40
Annex/WorkTree.hs Normal file
View file

@ -0,0 +1,40 @@
{- git-annex worktree files
-
- Copyright 2013-2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Annex.WorkTree where
import Common.Annex
import Annex.Link
import Annex.CatFile
import Annex.Version
import Config
{- Looks up the key corresponding to an annexed file,
- by examining what the file links to.
-
- An unlocked file will not have a link on disk, so fall back to
- looking for a pointer to a key in git.
-}
lookupFile :: FilePath -> Annex (Maybe Key)
lookupFile file = do
mkey <- isAnnexLink file
case mkey of
Just key -> makeret key
Nothing -> ifM (versionSupportsUnlockedPointers <||> isDirect)
( maybe (return Nothing) makeret =<< catKeyFile file
, return Nothing
)
where
makeret = return . Just
{- Modifies an action to only act on files that are already annexed,
- and passes the key on to it. -}
whenAnnexed :: (FilePath -> Key -> Annex (Maybe a)) -> FilePath -> Annex (Maybe a)
whenAnnexed a file = ifAnnexed file (a file) (return Nothing)
ifAnnexed :: FilePath -> (Key -> Annex a) -> Annex a -> Annex a
ifAnnexed file yes no = maybe no yes =<< lookupFile file

View file

@ -21,18 +21,21 @@ import Logs.Transfer
import Logs.Location
import qualified Annex.Queue
import qualified Git.LsFiles
import qualified Command.Add
import Utility.ThreadScheduler
import qualified Utility.Lsof as Lsof
import qualified Utility.DirWatcher as DirWatcher
import Types.KeySource
import Config
import Annex.Content
import Annex.Ingest
import Annex.Link
import Annex.CatFile
import Annex.InodeSentinal
import Annex.Version
import qualified Annex
import Utility.InodeCache
import Annex.Content.Direct
import qualified Database.Keys
import qualified Command.Sync
import qualified Git.Branch
@ -52,7 +55,8 @@ commitThread = namedThread "Committer" $ do
=<< annexDelayAdd <$> Annex.getGitConfig
msg <- liftAnnex Command.Sync.commitMsg
waitChangeTime $ \(changes, time) -> do
readychanges <- handleAdds havelsof delayadd changes
readychanges <- handleAdds havelsof delayadd $
simplifyChanges changes
if shouldCommit False time (length readychanges) readychanges
then do
debug
@ -227,12 +231,11 @@ commitStaged msg = do
return ok
{- OSX needs a short delay after a file is added before locking it down,
- when using a non-direct mode repository, as pasting a file seems to
- try to set file permissions or otherwise access the file after closing
- it. -}
- as pasting a file seems to try to set file permissions or otherwise
- access the file after closing it. -}
delayaddDefault :: Annex (Maybe Seconds)
#ifdef darwin_HOST_OS
delayaddDefault = ifM isDirect
delayaddDefault = ifM (isDirect || versionSupportsUnlockedPointers)
( return Nothing
, return $ Just $ Seconds 1
)
@ -249,12 +252,11 @@ delayaddDefault = return Nothing
- for write by some other process, and faster checking with git-ls-files
- that the files are not already checked into git.
-
- When a file is added, Inotify will notice the new symlink. So this waits
- for additional Changes to arrive, so that the symlink has hopefully been
- staged before returning, and will be committed immediately.
-
- OTOH, for kqueue, eventsCoalesce, so instead the symlink is directly
- created and staged.
- When a file is added in locked mode, Inotify will notice the new symlink.
- So this waits for additional Changes to arrive, so that the symlink has
- hopefully been staged before returning, and will be committed immediately.
- (OTOH, for kqueue, eventsCoalesce, so instead the symlink is directly
- created and staged.)
-
- Returns a list of all changes that are ready to be committed.
- Any pending adds that are not ready yet are put back into the ChangeChan,
@ -264,10 +266,13 @@ handleAdds :: Bool -> Maybe Seconds -> [Change] -> Assistant [Change]
handleAdds havelsof delayadd cs = returnWhen (null incomplete) $ do
let (pending, inprocess) = partition isPendingAddChange incomplete
direct <- liftAnnex isDirect
(pending', cleanup) <- if direct
unlocked <- liftAnnex versionSupportsUnlockedPointers
let lockingfiles = not (unlocked || direct)
(pending', cleanup) <- if unlocked || direct
then return (pending, noop)
else findnew pending
(postponed, toadd) <- partitionEithers <$> safeToAdd havelsof delayadd pending' inprocess
(postponed, toadd) <- partitionEithers
<$> safeToAdd lockingfiles havelsof delayadd pending' inprocess
cleanup
unless (null postponed) $
@ -275,10 +280,11 @@ handleAdds havelsof delayadd cs = returnWhen (null incomplete) $ do
returnWhen (null toadd) $ do
added <- addaction toadd $
catMaybes <$> if direct
then adddirect toadd
else forM toadd add
if DirWatcher.eventsCoalesce || null added || direct
catMaybes <$>
if not lockingfiles
then addunlocked direct toadd
else forM toadd (add lockingfiles)
if DirWatcher.eventsCoalesce || null added || unlocked || direct
then return $ added ++ otherchanges
else do
r <- handleAdds havelsof delayadd =<< getChanges
@ -304,52 +310,57 @@ handleAdds havelsof delayadd cs = returnWhen (null incomplete) $ do
| c = return otherchanges
| otherwise = a
add :: Change -> Assistant (Maybe Change)
add change@(InProcessAddChange { keySource = ks }) =
add :: Bool -> Change -> Assistant (Maybe Change)
add lockingfile change@(InProcessAddChange { lockedDown = ld }) =
catchDefaultIO Nothing <~> doadd
where
ks = keySource ld
doadd = sanitycheck ks $ do
(mkey, mcache) <- liftAnnex $ do
showStart "add" $ keyFilename ks
Command.Add.ingest $ Just ks
ingest $ Just $ LockedDown lockingfile ks
maybe (failedingest change) (done change mcache $ keyFilename ks) mkey
add _ = return Nothing
add _ _ = return Nothing
{- In direct mode, avoid overhead of re-injesting a renamed
- file, by examining the other Changes to see if a removed
- file has the same InodeCache as the new file. If so,
- we can just update bookkeeping, and stage the file in git.
{- Avoid overhead of re-injesting a renamed unlocked file, by
- examining the other Changes to see if a removed file has the
- same InodeCache as the new file. If so, we can just update
- bookkeeping, and stage the file in git.
-}
adddirect :: [Change] -> Assistant [Maybe Change]
adddirect toadd = do
addunlocked :: Bool -> [Change] -> Assistant [Maybe Change]
addunlocked isdirect toadd = do
ct <- liftAnnex compareInodeCachesWith
m <- liftAnnex $ removedKeysMap ct cs
m <- liftAnnex $ removedKeysMap isdirect ct cs
delta <- liftAnnex getTSDelta
if M.null m
then forM toadd add
then forM toadd (add False)
else forM toadd $ \c -> do
mcache <- liftIO $ genInodeCache (changeFile c) delta
case mcache of
Nothing -> add c
Nothing -> add False c
Just cache ->
case M.lookup (inodeCacheToKey ct cache) m of
Nothing -> add c
Just k -> fastadd c k
Nothing -> add False c
Just k -> fastadd isdirect c k
fastadd :: Change -> Key -> Assistant (Maybe Change)
fastadd change key = do
let source = keySource change
liftAnnex $ Command.Add.finishIngestDirect key source
fastadd :: Bool -> Change -> Key -> Assistant (Maybe Change)
fastadd isdirect change key = do
let source = keySource $ lockedDown change
liftAnnex $ if isdirect
then finishIngestDirect key source
else finishIngestUnlocked key source
done change Nothing (keyFilename source) key
removedKeysMap :: InodeComparisonType -> [Change] -> Annex (M.Map InodeCacheKey Key)
removedKeysMap ct l = do
removedKeysMap :: Bool -> InodeComparisonType -> [Change] -> Annex (M.Map InodeCacheKey Key)
removedKeysMap isdirect ct l = do
mks <- forM (filter isRmChange l) $ \c ->
catKeyFile $ changeFile c
M.fromList . concat <$> mapM mkpairs (catMaybes mks)
where
mkpairs k = map (\c -> (inodeCacheToKey ct c, k)) <$>
recordedInodeCache k
if isdirect
then recordedInodeCache k
else Database.Keys.getInodeCaches k
failedingest change = do
refill [retryChange change]
@ -358,12 +369,16 @@ handleAdds havelsof delayadd cs = returnWhen (null incomplete) $ do
done change mcache file key = liftAnnex $ do
logStatus key InfoPresent
link <- ifM isDirect
( calcRepo $ gitAnnexLink file key
, Command.Add.link file key mcache
ifM versionSupportsUnlockedPointers
( stagePointerFile file =<< hashPointerFile key
, do
link <- ifM isDirect
( calcRepo $ gitAnnexLink file key
, makeLink file key mcache
)
whenM (pure DirWatcher.eventsCoalesce <||> isDirect) $
stageSymlink file =<< hashSymlink link
)
whenM (pure DirWatcher.eventsCoalesce <||> isDirect) $
stageSymlink file =<< hashSymlink link
showEndOk
return $ Just $ finishedChange change key
@ -401,16 +416,16 @@ handleAdds havelsof delayadd cs = returnWhen (null incomplete) $ do
-
- Check by running lsof on the repository.
-}
safeToAdd :: Bool -> Maybe Seconds -> [Change] -> [Change] -> Assistant [Either Change Change]
safeToAdd _ _ [] [] = return []
safeToAdd havelsof delayadd pending inprocess = do
safeToAdd :: Bool -> Bool -> Maybe Seconds -> [Change] -> [Change] -> Assistant [Either Change Change]
safeToAdd _ _ _ [] [] = return []
safeToAdd lockingfiles havelsof delayadd pending inprocess = do
maybe noop (liftIO . threadDelaySeconds) delayadd
liftAnnex $ do
keysources <- forM pending $ Command.Add.lockDown . changeFile
let inprocess' = inprocess ++ mapMaybe mkinprocess (zip pending keysources)
lockeddown <- forM pending $ lockDown lockingfiles . changeFile
let inprocess' = inprocess ++ mapMaybe mkinprocess (zip pending lockeddown)
openfiles <- if havelsof
then S.fromList . map fst3 . filter openwrite <$>
findopenfiles (map keySource inprocess')
findopenfiles (map (keySource . lockedDown) inprocess')
else pure S.empty
let checked = map (check openfiles) inprocess'
@ -423,17 +438,18 @@ safeToAdd havelsof delayadd pending inprocess = do
allRight $ rights checked
else return checked
where
check openfiles change@(InProcessAddChange { keySource = ks })
| S.member (contentLocation ks) openfiles = Left change
check openfiles change@(InProcessAddChange { lockedDown = ld })
| S.member (contentLocation (keySource ld)) openfiles = Left change
check _ change = Right change
mkinprocess (c, Just ks) = Just InProcessAddChange
mkinprocess (c, Just ld) = Just InProcessAddChange
{ changeTime = changeTime c
, keySource = ks
, lockedDown = ld
}
mkinprocess (_, Nothing) = Nothing
canceladd (InProcessAddChange { keySource = ks }) = do
canceladd (InProcessAddChange { lockedDown = ld }) = do
let ks = keySource ld
warning $ keyFilename ks
++ " still has writers, not adding"
-- remove the hard link

View file

@ -25,7 +25,7 @@ import Utility.ThreadScheduler
import Utility.NotificationBroadcaster
import Utility.Batch
import qualified Git.LsFiles as LsFiles
import qualified Backend
import Annex.WorkTree
import Annex.Content
import Annex.Wanted
import CmdLine.Action
@ -142,7 +142,7 @@ expensiveScan urlrenderer rs = batch <~> do
(unwanted', ts) <- maybe
(return (unwanted, []))
(findtransfers f unwanted)
=<< liftAnnex (Backend.lookupFile f)
=<< liftAnnex (lookupFile f)
mapM_ (enqueue f) ts
scan unwanted' fs

View file

@ -1,6 +1,6 @@
{- git-annex assistant tree watcher
-
- Copyright 2012-2013 Joey Hess <id@joeyh.name>
- Copyright 2012-2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@ -28,7 +28,7 @@ import qualified Annex.Queue
import qualified Git
import qualified Git.UpdateIndex
import qualified Git.LsFiles as LsFiles
import qualified Backend
import Annex.WorkTree
import Annex.Direct
import Annex.Content.Direct
import Annex.CatFile
@ -36,10 +36,15 @@ import Annex.CheckIgnore
import Annex.Link
import Annex.FileMatcher
import Types.FileMatcher
import Annex.Content
import Annex.ReplaceFile
import Annex.Version
import Annex.InodeSentinal
import Git.Types
import Config
import Utility.ThreadScheduler
import Logs.Location
import qualified Database.Keys
#ifndef mingw32_HOST_OS
import qualified Utility.Lsof as Lsof
#endif
@ -88,10 +93,13 @@ runWatcher = do
startup <- asIO1 startupScan
matcher <- liftAnnex largeFilesMatcher
direct <- liftAnnex isDirect
unlocked <- liftAnnex versionSupportsUnlockedPointers
symlinkssupported <- liftAnnex $ coreSymlinks <$> Annex.getGitConfig
addhook <- hook $ if direct
then onAddDirect symlinkssupported matcher
else onAdd matcher
addhook <- hook $ if unlocked
then onAddUnlocked symlinkssupported matcher
else if direct
then onAddDirect symlinkssupported matcher
else onAdd matcher
delhook <- hook onDel
addsymlinkhook <- hook $ onAddSymlink direct
deldirhook <- hook onDelDir
@ -216,15 +224,33 @@ onAdd matcher file filestatus
shouldRestage :: DaemonStatus -> Bool
shouldRestage ds = scanComplete ds || forceRestage ds
onAddUnlocked :: Bool -> FileMatcher Annex -> Handler
onAddUnlocked = onAddUnlocked' False contentchanged Database.Keys.addAssociatedFile samefilestatus
where
samefilestatus key file status = do
cache <- Database.Keys.getInodeCaches key
curr <- withTSDelta $ \delta -> liftIO $ toInodeCache delta file status
case (cache, curr) of
(_, Just c) -> elemInodeCaches c cache
([], Nothing) -> return True
_ -> return False
contentchanged oldkey file = do
Database.Keys.removeAssociatedFile oldkey file
unlessM (inAnnex oldkey) $
logStatus oldkey InfoMissing
{- In direct mode, add events are received for both new files, and
- modified existing files.
-}
onAddDirect :: Bool -> FileMatcher Annex -> Handler
onAddDirect symlinkssupported matcher file fs = do
onAddDirect = onAddUnlocked' True changedDirect (\k f -> void $ addAssociatedFile k f) sameFileStatus
onAddUnlocked' :: Bool -> (Key -> FilePath -> Annex ()) -> (Key -> FilePath -> Annex ()) -> (Key -> FilePath -> FileStatus -> Annex Bool) -> Bool -> FileMatcher Annex -> Handler
onAddUnlocked' isdirect contentchanged addassociatedfile samefilestatus symlinkssupported matcher file fs = do
v <- liftAnnex $ catKeyFile file
case (v, fs) of
(Just key, Just filestatus) ->
ifM (liftAnnex $ sameFileStatus key file filestatus)
ifM (liftAnnex $ samefilestatus key file filestatus)
{- It's possible to get an add event for
- an existing file that is not
- really modified, but it might have
@ -237,13 +263,13 @@ onAddDirect symlinkssupported matcher file fs = do
, noChange
)
, guardSymlinkStandin (Just key) $ do
debug ["changed direct", file]
liftAnnex $ changedDirect key file
debug ["changed", file]
liftAnnex $ contentchanged key file
add matcher file
)
_ -> unlessIgnored file $
guardSymlinkStandin Nothing $ do
debug ["add direct", file]
debug ["add", file]
add matcher file
where
{- On a filesystem without symlinks, we'll get changes for regular
@ -259,9 +285,9 @@ onAddDirect symlinkssupported matcher file fs = do
Just lt -> do
case fileKey $ takeFileName lt of
Nothing -> noop
Just key -> void $ liftAnnex $
addAssociatedFile key file
onAddSymlink' linktarget mk True file fs
Just key -> liftAnnex $
addassociatedfile key file
onAddSymlink' linktarget mk isdirect file fs
{- A symlink might be an arbitrary symlink, which is just added.
- Or, if it is a git-annex symlink, ensure it points to the content
@ -270,7 +296,7 @@ onAddDirect symlinkssupported matcher file fs = do
onAddSymlink :: Bool -> Handler
onAddSymlink isdirect file filestatus = unlessIgnored file $ do
linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file)
kv <- liftAnnex (Backend.lookupFile file)
kv <- liftAnnex (lookupFile file)
onAddSymlink' linktarget kv isdirect file filestatus
onAddSymlink' :: Maybe String -> Maybe Key -> Bool -> Handler
@ -330,13 +356,15 @@ onDel file _ = do
onDel' :: FilePath -> Annex ()
onDel' file = do
whenM isDirect $ do
mkey <- catKeyFile file
case mkey of
Nothing -> noop
Just key -> void $ removeAssociatedFile key file
ifM versionSupportsUnlockedPointers
( withkey $ flip Database.Keys.removeAssociatedFile file
, whenM isDirect $
withkey $ \key -> void $ removeAssociatedFile key file
)
Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.unstageFile file)
where
withkey a = maybe noop a =<< catKeyFile file
{- A directory has been deleted, or moved, so tell git to remove anything
- that was inside it from its cache. Since it could reappear at any time,

View file

@ -1,18 +1,22 @@
{- git-annex assistant change tracking
-
- Copyright 2012-2013 Joey Hess <id@joeyh.name>
- Copyright 2012-2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE BangPatterns #-}
module Assistant.Types.Changes where
import Types.KeySource
import Types.Key
import Utility.TList
import Annex.Ingest
import Control.Concurrent.STM
import Data.Time.Clock
import qualified Data.Set as S
{- An un-ordered pool of Changes that have been noticed and should be
- staged and committed. Changes will typically be in order, but ordering
@ -38,7 +42,7 @@ data Change
}
| InProcessAddChange
{ changeTime ::UTCTime
, keySource :: KeySource
, lockedDown :: LockedDown
}
deriving (Show)
@ -53,7 +57,7 @@ changeInfoKey _ = Nothing
changeFile :: Change -> FilePath
changeFile (Change _ f _) = f
changeFile (PendingAddChange _ f) = f
changeFile (InProcessAddChange _ ks) = keyFilename ks
changeFile (InProcessAddChange _ ld) = keyFilename $ keySource ld
isPendingAddChange :: Change -> Bool
isPendingAddChange (PendingAddChange {}) = True
@ -64,14 +68,33 @@ isInProcessAddChange (InProcessAddChange {}) = True
isInProcessAddChange _ = False
retryChange :: Change -> Change
retryChange (InProcessAddChange time ks) =
PendingAddChange time (keyFilename ks)
retryChange c@(InProcessAddChange time _) =
PendingAddChange time $ changeFile c
retryChange c = c
finishedChange :: Change -> Key -> Change
finishedChange c@(InProcessAddChange { keySource = ks }) k = Change
finishedChange c@(InProcessAddChange {}) k = Change
{ changeTime = changeTime c
, _changeFile = keyFilename ks
, _changeFile = changeFile c
, changeInfo = AddKeyChange k
}
finishedChange c _ = c
{- Combine PendingAddChanges that are for the same file.
- Multiple such often get noticed when eg, a file is opened and then
- closed in quick succession. -}
simplifyChanges :: [Change] -> [Change]
simplifyChanges [c] = [c]
simplifyChanges cl = go cl S.empty []
where
go [] _ l = reverse l
go (c:cs) seen l
| isPendingAddChange c =
if S.member f seen
then go cs seen l
else
let !seen' = S.insert f seen
in go cs seen' (c:l)
| otherwise = go cs seen (c:l)
where
f = changeFile c

View file

@ -9,9 +9,7 @@ module Backend (
list,
orderedList,
genKey,
lookupFile,
getBackend,
isAnnexLink,
chooseBackend,
lookupBackendName,
maybeLookupBackendName,
@ -21,12 +19,9 @@ module Backend (
import Common.Annex
import qualified Annex
import Annex.CheckAttr
import Annex.CatFile
import Annex.Link
import Types.Key
import Types.KeySource
import qualified Types.Backend as B
import Config
-- When adding a new backend, import it here and add it to the list.
import qualified Backend.Hash
@ -78,26 +73,6 @@ genKey' (b:bs) source = do
| c == '\n' = '_'
| otherwise = c
{- Looks up the key corresponding to an annexed file,
- by examining what the file links to.
-
- In direct mode, there is often no link on disk, in which case
- the symlink is looked up in git instead. However, a real link
- on disk still takes precedence over what was committed to git in direct
- mode.
-}
lookupFile :: FilePath -> Annex (Maybe Key)
lookupFile file = do
mkey <- isAnnexLink file
case mkey of
Just key -> makeret key
Nothing -> ifM isDirect
( maybe (return Nothing) makeret =<< catKeyFile file
, return Nothing
)
where
makeret k = return $ Just k
getBackend :: FilePath -> Key -> Annex (Maybe Backend)
getBackend file k = let bname = keyBackendName k in
case maybeLookupBackendName bname of

View file

@ -96,6 +96,7 @@ import qualified Command.Upgrade
import qualified Command.Forget
import qualified Command.Proxy
import qualified Command.DiffDriver
import qualified Command.Smudge
import qualified Command.Undo
import qualified Command.Version
#ifdef WITH_ASSISTANT
@ -201,6 +202,7 @@ cmds testoptparser testrunner =
, Command.Forget.cmd
, Command.Proxy.cmd
, Command.DiffDriver.cmd
, Command.Smudge.cmd
, Command.Undo.cmd
, Command.Version.cmd
#ifdef WITH_ASSISTANT

View file

@ -80,7 +80,7 @@ withFilesInRefs a = mapM_ go
l <- inRepo $ LsTree.lsTree (Git.Ref r)
forM_ l $ \i -> do
let f = getTopFilePath $ LsTree.file i
v <- catKey (Git.Ref $ LsTree.sha i) (LsTree.mode i)
v <- catKey (Git.Ref $ LsTree.sha i)
case v of
Nothing -> noop
Just k -> whenM (matcher $ MatchingKey k) $
@ -115,29 +115,29 @@ withPairs a params = seekActions $ return $ map a $ pairs [] params
pairs c (x:y:xs) = pairs ((x,y):c) xs
pairs _ _ = error "expected pairs"
withFilesToBeCommitted :: (String -> CommandStart) -> CmdParams -> CommandSeek
withFilesToBeCommitted :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek
withFilesToBeCommitted a params = seekActions $ prepFiltered a $
seekHelper LsFiles.stagedNotDeleted params
withFilesUnlocked :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek
withFilesUnlocked = withFilesUnlocked' LsFiles.typeChanged
withFilesOldUnlocked :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek
withFilesOldUnlocked = withFilesOldUnlocked' LsFiles.typeChanged
withFilesUnlockedToBeCommitted :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek
withFilesUnlockedToBeCommitted = withFilesUnlocked' LsFiles.typeChangedStaged
withFilesOldUnlockedToBeCommitted :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek
withFilesOldUnlockedToBeCommitted = withFilesOldUnlocked' LsFiles.typeChangedStaged
{- Unlocked files have changed type from a symlink to a regular file.
{- Unlocked files before v6 have changed type from a symlink to a regular file.
-
- Furthermore, unlocked files used to be a git-annex symlink,
- not some other sort of symlink.
-}
withFilesUnlocked' :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> (FilePath -> CommandStart) -> CmdParams -> CommandSeek
withFilesUnlocked' typechanged a params = seekActions $
withFilesOldUnlocked' :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> (FilePath -> CommandStart) -> CmdParams -> CommandSeek
withFilesOldUnlocked' typechanged a params = seekActions $
prepFiltered a unlockedfiles
where
unlockedfiles = filterM isUnlocked =<< seekHelper typechanged params
unlockedfiles = filterM isOldUnlocked =<< seekHelper typechanged params
isUnlocked :: FilePath -> Annex Bool
isUnlocked f = liftIO (notSymlink f) <&&>
isOldUnlocked :: FilePath -> Annex Bool
isOldUnlocked f = liftIO (notSymlink f) <&&>
(isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f)
{- Finds files that may be modified. -}

View file

@ -18,12 +18,13 @@ module Command (
stopUnless,
whenAnnexed,
ifAnnexed,
lookupFile,
isBareRepo,
module ReExported
) where
import Common.Annex
import qualified Backend
import Annex.WorkTree
import qualified Git
import Types.Command as ReExported
import Types.Option as ReExported
@ -100,13 +101,5 @@ stop = return Nothing
stopUnless :: Annex Bool -> Annex (Maybe a) -> Annex (Maybe a)
stopUnless c a = ifM c ( a , stop )
{- Modifies an action to only act on files that are already annexed,
- and passes the key on to it. -}
whenAnnexed :: (FilePath -> Key -> Annex (Maybe a)) -> FilePath -> Annex (Maybe a)
whenAnnexed a file = ifAnnexed file (a file) (return Nothing)
ifAnnexed :: FilePath -> (Key -> Annex a) -> Annex a -> Annex a
ifAnnexed file yes no = maybe no yes =<< Backend.lookupFile file
isBareRepo :: Annex Bool
isBareRepo = fromRepo Git.repoIsLocalBare

View file

@ -5,35 +5,22 @@
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Command.Add where
import Common.Annex
import Command
import Types.KeySource
import Backend
import Annex.Ingest
import Logs.Location
import Annex.Content
import Annex.Content.Direct
import Annex.Perms
import Annex.Link
import Annex.MetaData
import qualified Annex
import qualified Annex.Queue
#ifdef WITH_CLIBS
#ifndef __ANDROID__
import Utility.Touch
#endif
#endif
import Config
import Utility.InodeCache
import Annex.FileMatcher
import Annex.ReplaceFile
import Utility.Tmp
import Utility.CopyFile
import Control.Exception (IOException)
import Annex.Version
import qualified Database.Keys
cmd :: Command
cmd = notBareRepo $ withGlobalOptions (jobsOption : fileMatchingOptions) $
@ -64,9 +51,9 @@ seek o = allowConcurrentOutput $ do
, startSmall file
)
go $ withFilesNotInGit (not $ includeDotFiles o)
ifM isDirect
ifM (versionSupportsUnlockedPointers <||> isDirect)
( go withFilesMaybeModified
, go withFilesUnlocked
, go withFilesOldUnlocked
)
{- Pass file off to git-add. -}
@ -86,9 +73,6 @@ addFile file = do
Annex.Queue.addCommand "add" (ps++[Param "--"]) [file]
return True
{- The add subcommand annexes a file, generating a key for it using a
- backend, and then moving it into the annex directory and setting up
- the symlink pointing to its content. -}
start :: FilePath -> CommandStart
start file = ifAnnexed file addpresent add
where
@ -103,13 +87,22 @@ start file = ifAnnexed file addpresent add
next $ if isSymbolicLink s
then next $ addFile file
else perform file
addpresent key = ifM isDirect
addpresent key = ifM versionSupportsUnlockedPointers
( do
ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file
case ms of
Just s | isSymbolicLink s -> fixup key
_ -> ifM (goodContent key file) ( stop , add )
, fixup key
_ -> ifM (sameInodeCache file =<< Database.Keys.getInodeCaches key)
( stop, add )
, ifM isDirect
( do
ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file
case ms of
Just s | isSymbolicLink s -> fixup key
_ -> ifM (goodContent key file)
( stop , add )
, fixup key
)
)
fixup key = do
-- the annexed symlink is present but not yet added to git
@ -119,188 +112,14 @@ start file = ifAnnexed file addpresent add
void $ addAssociatedFile key file
next $ next $ cleanup file key Nothing =<< inAnnex key
{- The file that's being added is locked down before a key is generated,
- to prevent it from being modified in between. This lock down is not
- perfect at best (and pretty weak at worst). For example, it does not
- guard against files that are already opened for write by another process.
- So a KeySource is returned. Its inodeCache can be used to detect any
- changes that might be made to the file after it was locked down.
-
- When possible, the file is hard linked to a temp directory. This guards
- against some changes, like deletion or overwrite of the file, and
- allows lsof checks to be done more efficiently when adding a lot of files.
-
- Lockdown can fail if a file gets deleted, and Nothing will be returned.
-}
lockDown :: FilePath -> Annex (Maybe KeySource)
lockDown = either
(\e -> warning (show e) >> return Nothing)
(return . Just)
<=< lockDown'
lockDown' :: FilePath -> Annex (Either IOException KeySource)
lockDown' file = ifM crippledFileSystem
( withTSDelta $ liftIO . tryIO . nohardlink
, tryIO $ do
tmp <- fromRepo gitAnnexTmpMiscDir
createAnnexDirectory tmp
go tmp
)
where
{- In indirect mode, the write bit is removed from the file as part
- of lock down to guard against further writes, and because objects
- in the annex have their write bit disabled anyway.
-
- Freezing the content early also lets us fail early when
- someone else owns the file.
-
- This is not done in direct mode, because files there need to
- remain writable at all times.
-}
go tmp = do
unlessM isDirect $
freezeContent file
withTSDelta $ \delta -> liftIO $ do
(tmpfile, h) <- openTempFile tmp $
relatedTemplate $ takeFileName file
hClose h
nukeFile tmpfile
withhardlink delta tmpfile `catchIO` const (nohardlink delta)
nohardlink delta = do
cache <- genInodeCache file delta
return KeySource
{ keyFilename = file
, contentLocation = file
, inodeCache = cache
}
withhardlink delta tmpfile = do
createLink file tmpfile
cache <- genInodeCache tmpfile delta
return KeySource
{ keyFilename = file
, contentLocation = tmpfile
, inodeCache = cache
}
{- Ingests a locked down file into the annex.
-
- In direct mode, leaves the file alone, and just updates bookkeeping
- information.
-}
ingest :: Maybe KeySource -> Annex (Maybe Key, Maybe InodeCache)
ingest Nothing = return (Nothing, Nothing)
ingest (Just source) = withTSDelta $ \delta -> do
backend <- chooseBackend $ keyFilename source
k <- genKey source backend
let src = contentLocation source
ms <- liftIO $ catchMaybeIO $ getFileStatus src
mcache <- maybe (pure Nothing) (liftIO . toInodeCache delta src) ms
case (mcache, inodeCache source) of
(_, Nothing) -> go k mcache ms
(Just newc, Just c) | compareStrong c newc -> go k mcache ms
_ -> failure "changed while it was being added"
where
go k mcache ms = ifM isDirect
( godirect k mcache ms
, goindirect k mcache ms
)
goindirect (Just (key, _)) mcache ms = do
catchNonAsync (moveAnnex key $ contentLocation source)
(undo (keyFilename source) key)
maybe noop (genMetaData key (keyFilename source)) ms
liftIO $ nukeFile $ keyFilename source
return (Just key, mcache)
goindirect _ _ _ = failure "failed to generate a key"
godirect (Just (key, _)) (Just cache) ms = do
addInodeCache key cache
maybe noop (genMetaData key (keyFilename source)) ms
finishIngestDirect key source
return (Just key, Just cache)
godirect _ _ _ = failure "failed to generate a key"
failure msg = do
warning $ keyFilename source ++ " " ++ msg
when (contentLocation source /= keyFilename source) $
liftIO $ nukeFile $ contentLocation source
return (Nothing, Nothing)
finishIngestDirect :: Key -> KeySource -> Annex ()
finishIngestDirect key source = do
void $ addAssociatedFile key $ keyFilename source
when (contentLocation source /= keyFilename source) $
liftIO $ nukeFile $ contentLocation source
{- Copy to any other locations using the same key. -}
otherfs <- filter (/= keyFilename source) <$> associatedFiles key
forM_ otherfs $
addContentWhenNotPresent key (keyFilename source)
perform :: FilePath -> CommandPerform
perform file = lockDown file >>= ingest >>= go
perform file = do
lockingfile <- not <$> isDirect
lockDown lockingfile file >>= ingest >>= go
where
go (Just key, cache) = next $ cleanup file key cache True
go (Nothing, _) = stop
{- On error, put the file back so it doesn't seem to have vanished.
- This can be called before or after the symlink is in place. -}
undo :: FilePath -> Key -> SomeException -> Annex a
undo file key e = do
whenM (inAnnex key) $ do
liftIO $ nukeFile file
-- The key could be used by other files too, so leave the
-- content in the annex, and make a copy back to the file.
obj <- calcRepo $ gitAnnexLocation key
unlessM (liftIO $ copyFileExternal CopyTimeStamps obj file) $
warning $ "Unable to restore content of " ++ file ++ "; it should be located in " ++ obj
thawContent file
throwM e
{- Creates the symlink to the annexed content, returns the link target. -}
link :: FilePath -> Key -> Maybe InodeCache -> Annex String
link file key mcache = flip catchNonAsync (undo file key) $ do
l <- calcRepo $ gitAnnexLink file key
replaceFile file $ makeAnnexLink l
-- touch symlink to have same time as the original file,
-- as provided in the InodeCache
case mcache of
#if defined(WITH_CLIBS) && ! defined(__ANDROID__)
Just c -> liftIO $ touch file (TimeSpec $ inodeCacheToMtime c) False
#else
Just _ -> noop
#endif
Nothing -> noop
return l
{- Creates the symlink to the annexed content, and stages it in git.
-
- As long as the filesystem supports symlinks, we use
- git add, rather than directly staging the symlink to git.
- Using git add is best because it allows the queuing to work
- and is faster (staging the symlink runs hash-object commands each time).
- Also, using git add allows it to skip gitignored files, unless forced
- to include them.
-}
addLink :: FilePath -> Key -> Maybe InodeCache -> Annex ()
addLink file key mcache = ifM (coreSymlinks <$> Annex.getGitConfig)
( do
_ <- link file key mcache
ps <- forceParams
Annex.Queue.addCommand "add" (ps++[Param "--"]) [file]
, do
l <- link file key mcache
addAnnexLink l file
)
forceParams :: Annex [CommandParam]
forceParams = ifM (Annex.getState Annex.force)
( return [Param "-f"]
, return []
)
cleanup :: FilePath -> Key -> Maybe InodeCache -> Bool -> CommandCleanup
cleanup file key mcache hascontent = do
ifM (isDirect <&&> pure hascontent)

View file

@ -10,7 +10,7 @@ module Command.AddUnused where
import Common.Annex
import Logs.Location
import Command
import qualified Command.Add
import Annex.Ingest
import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused)
import Types.Key
@ -31,7 +31,7 @@ start = startUnused "addunused" perform
perform :: Key -> CommandPerform
perform key = next $ do
logStatus key InfoPresent
Command.Add.addLink file key Nothing
addLink file key Nothing
return True
where
file = "unused." ++ key2file key

View file

@ -14,14 +14,15 @@ import Network.URI
import Common.Annex
import Command
import Backend
import qualified Command.Add
import qualified Annex
import qualified Annex.Queue
import qualified Annex.Url as Url
import qualified Backend.URL
import qualified Remote
import qualified Types.Remote as Remote
import qualified Command.Add
import Annex.Content
import Annex.Ingest
import Annex.UUID
import Logs.Web
import Types.Key
@ -373,7 +374,7 @@ cleanup u url file key mtmp = case mtmp of
when (isJust mtmp) $
logStatus key InfoPresent
setUrlPresent u key url
Command.Add.addLink file key Nothing
addLink file key Nothing
whenM isDirect $ do
void $ addAssociatedFile key file
{- For moveAnnex to work in direct mode, the symlink

View file

@ -46,7 +46,7 @@ findOrGenUUID = do
else ifM (Annex.Branch.hasSibling <||> (isJust <$> Fields.getField Fields.autoInit))
( do
liftIO checkNotReadOnly
initialize Nothing
initialize Nothing Nothing
getUUID
, return NoUUID
)

View file

@ -14,6 +14,7 @@ import qualified Git.LsFiles
import qualified Git.Branch
import Config
import Annex.Direct
import Annex.Version
cmd :: Command
cmd = notBareRepo $ noDaemonRunning $
@ -24,7 +25,10 @@ seek :: CmdParams -> CommandSeek
seek = withNothing start
start :: CommandStart
start = ifM isDirect ( stop , next perform )
start = ifM versionSupportsDirectMode
( ifM isDirect ( stop , next perform )
, error "Direct mode is not suppported by this repository version. Use git-annex unlock instead."
)
perform :: CommandPerform
perform = do

View file

@ -34,6 +34,7 @@ import Utility.HumanTime
import Utility.CopyFile
import Git.FilePath
import Utility.PID
import qualified Database.Keys
#ifdef WITH_DATABASE
import qualified Database.Fsck as FsckDb
@ -118,16 +119,18 @@ start from inc file key = do
go = runFsck inc file key
perform :: Key -> FilePath -> Backend -> NumCopies -> Annex Bool
perform key file backend numcopies = check
-- order matters
[ fixLink key file
, verifyLocationLog key file
, verifyDirectMapping key file
, verifyDirectMode key file
, checkKeySize key
, checkBackend backend key (Just file)
, checkKeyNumCopies key (Just file) numcopies
]
perform key file backend numcopies = do
keystatus <- getKeyStatus key
check
-- order matters
[ fixLink key file
, verifyLocationLog key keystatus file
, verifyDirectMapping key file
, verifyDirectMode key file
, checkKeySize key keystatus
, checkBackend backend key keystatus (Just file)
, checkKeyNumCopies key (Just file) numcopies
]
{- To fsck a remote, the content is retrieved to a tmp file,
- and checked locally. -}
@ -183,19 +186,19 @@ startKey inc key numcopies =
performKey key backend numcopies
performKey :: Key -> Backend -> NumCopies -> Annex Bool
performKey key backend numcopies = check
[ verifyLocationLog key (key2file key)
, checkKeySize key
, checkBackend backend key Nothing
, checkKeyNumCopies key Nothing numcopies
]
performKey key backend numcopies = do
keystatus <- getKeyStatus key
check
[ verifyLocationLog key keystatus (key2file key)
, checkKeySize key keystatus
, checkBackend backend key keystatus Nothing
, checkKeyNumCopies key Nothing numcopies
]
check :: [Annex Bool] -> Annex Bool
check cs = and <$> sequence cs
{- Checks that the file's link points correctly to the content.
-
- In direct mode, there is only a link when the content is not present.
{- Checks that symlinks points correctly to the annexed content.
-}
fixLink :: Key -> FilePath -> Annex Bool
fixLink key file = do
@ -214,19 +217,23 @@ fixLink key file = do
{- Checks that the location log reflects the current status of the key,
- in this repository only. -}
verifyLocationLog :: Key -> String -> Annex Bool
verifyLocationLog key desc = do
present <- inAnnex key
verifyLocationLog :: Key -> KeyStatus -> String -> Annex Bool
verifyLocationLog key keystatus desc = do
obj <- calcRepo $ gitAnnexLocation key
present <- if isKeyUnlocked keystatus
then liftIO (doesFileExist obj)
else inAnnex key
direct <- isDirect
u <- getUUID
{- Since we're checking that a key's file is present, throw
{- Since we're checking that a key's object file is present, throw
- in a permission fixup here too. -}
file <- calcRepo $ gitAnnexLocation key
when (present && not direct) $
freezeContent file
whenM (liftIO $ doesDirectoryExist $ parentDir file) $
freezeContentDir file
when (present && not direct) $ void $ tryIO $
if isKeyUnlocked keystatus
then thawContent obj
else freezeContent obj
whenM (liftIO $ doesDirectoryExist $ parentDir obj) $
freezeContentDir obj
{- In direct mode, modified files will show up as not present,
- but that is expected and not something to do anything about. -}
@ -288,18 +295,16 @@ verifyDirectMode key file = do
{- The size of the data for a key is checked against the size encoded in
- the key's metadata, if available.
-
- Not checked in direct mode, because files can be changed directly.
- Not checked when a file is unlocked, or in direct mode.
-}
checkKeySize :: Key -> Annex Bool
checkKeySize key = ifM isDirect
( return True
, do
file <- calcRepo $ gitAnnexLocation key
ifM (liftIO $ doesFileExist file)
( checkKeySizeOr badContent key file
, return True
)
)
checkKeySize :: Key -> KeyStatus -> Annex Bool
checkKeySize _ KeyUnlocked = return True
checkKeySize key _ = do
file <- calcRepo $ gitAnnexLocation key
ifM (liftIO $ doesFileExist file)
( checkKeySizeOr badContent key file
, return True
)
checkKeySizeRemote :: Key -> Remote -> Maybe FilePath -> Annex Bool
checkKeySizeRemote _ _ Nothing = return True
@ -326,18 +331,26 @@ checkKeySizeOr bad key file = case Types.Key.keySize key of
, msg
]
{- Runs the backend specific check on a key's content.
{- Runs the backend specific check on a key's content object.
-
- When a file is unlocked, it may be a hard link to the object,
- thus when the user modifies the file, the object will be modified and
- not pass the check, and we don't want to find an error in this case.
- So, skip the check if the key is unlocked and modified.
-
- In direct mode this is not done if the file has clearly been modified,
- because modification of direct mode files is allowed. It's still done
- if the file does not appear modified, to catch disk corruption, etc.
-}
checkBackend :: Backend -> Key -> Maybe FilePath -> Annex Bool
checkBackend backend key mfile = go =<< isDirect
checkBackend :: Backend -> Key -> KeyStatus -> Maybe FilePath -> Annex Bool
checkBackend backend key keystatus mfile = go =<< isDirect
where
go False = do
content <- calcRepo $ gitAnnexLocation key
checkBackendOr badContent backend key content
ifM (pure (isKeyUnlocked keystatus) <&&> (not <$> isUnmodified key content))
( nocheck
, checkBackendOr badContent backend key content
)
go True = maybe nocheck checkdirect mfile
checkdirect file = ifM (goodContent key file)
( checkBackendOr' (badContentDirect file) backend key file
@ -582,3 +595,20 @@ withFsckDb (StartIncremental h) a = a h
withFsckDb NonIncremental _ = noop
withFsckDb (ScheduleIncremental _ _ i) a = withFsckDb i a
#endif
data KeyStatus = KeyLocked | KeyUnlocked | KeyMissing
isKeyUnlocked :: KeyStatus -> Bool
isKeyUnlocked KeyUnlocked = True
isKeyUnlocked KeyLocked = False
isKeyUnlocked KeyMissing = False
getKeyStatus :: Key -> Annex KeyStatus
getKeyStatus key = ifM isDirect
( return KeyUnlocked
, catchDefaultIO KeyMissing $ do
obj <- calcRepo $ gitAnnexLocation key
unlocked <- ((> 1) . linkCount <$> liftIO (getFileStatus obj))
<&&> (not . null <$> Database.Keys.getAssociatedFiles key)
return $ if unlocked then KeyUnlocked else KeyLocked
)

View file

@ -20,7 +20,7 @@ import Annex.Content
import Annex.Content.Direct
import Annex.CatFile
import Annex.Init
import qualified Command.Add
import Annex.Ingest
cmd :: Command
cmd = notBareRepo $ noDaemonRunning $
@ -76,7 +76,7 @@ perform = do
return Nothing
| otherwise ->
maybe noop (fromdirect f)
=<< catKey sha mode
=<< catKey sha
_ -> noop
go _ = noop
@ -90,7 +90,7 @@ perform = do
Right _ -> do
l <- calcRepo $ gitAnnexLink f k
liftIO $ createSymbolicLink l f
Left e -> catchNonAsync (Command.Add.undo f k e)
Left e -> catchNonAsync (restoreFile f k e)
warnlocked
showEndOk

View file

@ -10,25 +10,44 @@ module Command.Init where
import Common.Annex
import Command
import Annex.Init
import Annex.Version
import qualified Annex.SpecialRemote
cmd :: Command
cmd = dontCheck repoExists $
command "init" SectionSetup "initialize git-annex"
paramDesc (withParams seek)
paramDesc (seek <$$> optParser)
seek :: CmdParams -> CommandSeek
seek = withWords start
data InitOptions = InitOptions
{ initDesc :: String
, initVersion :: Maybe Version
}
start :: [String] -> CommandStart
start ws = do
showStart "init" description
next $ perform description
where
description = unwords ws
optParser :: CmdParamsDesc -> Parser InitOptions
optParser desc = InitOptions
<$> (unwords <$> cmdParams desc)
<*> optional (option (str >>= parseVersion)
( long "version" <> metavar paramValue
<> help "Override default annex.version"
))
perform :: String -> CommandPerform
perform description = do
initialize $ if null description then Nothing else Just description
parseVersion :: Monad m => String -> m Version
parseVersion v
| v `elem` supportedVersions = return v
| otherwise = fail $ v ++ " is not a currently supported repository version"
seek :: InitOptions -> CommandSeek
seek = commandAction . start
start :: InitOptions -> CommandStart
start os = do
showStart "init" (initDesc os)
next $ perform os
perform :: InitOptions -> CommandPerform
perform os = do
initialize
(if null (initDesc os) then Nothing else Just (initDesc os))
(initVersion os)
Annex.SpecialRemote.autoEnable
next $ return True

View file

@ -1,6 +1,6 @@
{- git-annex command
-
- Copyright 2010 Joey Hess <id@joeyh.name>
- Copyright 2010,2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@ -11,6 +11,16 @@ import Common.Annex
import Command
import qualified Annex.Queue
import qualified Annex
import Annex.Version
import Annex.Content
import Annex.Link
import Annex.InodeSentinal
import Annex.Perms
import Annex.ReplaceFile
import Utility.InodeCache
import qualified Database.Keys
import Annex.Ingest
import Logs.Location
cmd :: Command
cmd = notDirect $ withGlobalOptions annexedMatchingOptions $
@ -19,18 +29,90 @@ cmd = notDirect $ withGlobalOptions annexedMatchingOptions $
paramPaths (withParams seek)
seek :: CmdParams -> CommandSeek
seek ps = do
withFilesUnlocked start ps
withFilesUnlockedToBeCommitted start ps
seek ps = ifM versionSupportsUnlockedPointers
( withFilesInGit (whenAnnexed startNew) ps
, do
withFilesOldUnlocked startOld ps
withFilesOldUnlockedToBeCommitted startOld ps
)
start :: FilePath -> CommandStart
start file = do
startNew :: FilePath -> Key -> CommandStart
startNew file key = ifM (isJust <$> isAnnexLink file)
( stop
, do
showStart "lock" file
go =<< isPointerFile file
)
where
go (Just key')
| key' == key = cont False
| otherwise = errorModified
go Nothing =
ifM (isUnmodified key file)
( cont False
, ifM (Annex.getState Annex.force)
( cont True
, errorModified
)
)
cont = next . performNew file key
performNew :: FilePath -> Key -> Bool -> CommandPerform
performNew file key filemodified = do
lockdown =<< calcRepo (gitAnnexLocation key)
addLink file key
=<< withTSDelta (liftIO . genInodeCache file)
next $ cleanupNew file key
where
lockdown obj = do
ifM (catchBoolIO $ sameInodeCache obj =<< Database.Keys.getInodeCaches key)
( breakhardlink obj
, repopulate obj
)
whenM (liftIO $ doesFileExist obj) $
freezeContent obj
-- It's ok if the file is hard linked to obj, but if some other
-- associated file is, we need to break that link to lock down obj.
breakhardlink obj = whenM (catchBoolIO $ (> 1) . linkCount <$> liftIO (getFileStatus obj)) $ do
mfc <- withTSDelta (liftIO . genInodeCache file)
unlessM (sameInodeCache obj (maybeToList mfc)) $ do
modifyContent obj $ replaceFile obj $ \tmp -> do
unlessM (checkedCopyFile key obj tmp) $
error "unable to lock file; need more free disk space"
Database.Keys.storeInodeCaches key [obj]
-- Try to repopulate obj from an unmodified associated file.
repopulate obj
| filemodified = modifyContent obj $ do
fs <- Database.Keys.getAssociatedFiles key
mfile <- firstM (isUnmodified key) fs
liftIO $ nukeFile obj
case mfile of
Just unmodified ->
unlessM (checkedCopyFile key unmodified obj)
lostcontent
Nothing -> lostcontent
| otherwise = modifyContent obj $
liftIO $ renameFile file obj
lostcontent = logStatus key InfoMissing
cleanupNew :: FilePath -> Key -> CommandCleanup
cleanupNew file key = do
Database.Keys.removeAssociatedFile key file
return True
startOld :: FilePath -> CommandStart
startOld file = do
showStart "lock" file
unlessM (Annex.getState Annex.force) $
error "Locking this file would discard any changes you have made to it. Use 'git annex add' to stage your changes. (Or, use --force to override)"
next $ perform file
unlessM (Annex.getState Annex.force)
errorModified
next $ performOld file
perform :: FilePath -> CommandPerform
perform file = do
performOld :: FilePath -> CommandPerform
performOld file = do
Annex.Queue.addCommand "checkout" [Param "--"] [file]
next $ return True -- no cleanup needed
next $ return True
errorModified :: a
errorModified = error "Locking this file would discard any changes you have made to it. Use 'git annex add' to stage your changes. (Or, use --force to override)"

View file

@ -72,7 +72,7 @@ perform file oldkey oldbackend newbackend = go =<< genkey
go (Just (newkey, knowngoodcontent))
| knowngoodcontent = finish newkey
| otherwise = stopUnless checkcontent $ finish newkey
checkcontent = Command.Fsck.checkBackend oldbackend oldkey $ Just file
checkcontent = Command.Fsck.checkBackend oldbackend oldkey Command.Fsck.KeyLocked $ Just file
finish newkey = stopUnless (Command.ReKey.linkKey oldkey newkey) $
next $ Command.ReKey.cleanup file oldkey newkey
genkey = case maybe Nothing (\fm -> fm oldkey newbackend (Just file)) (fastMigrate oldbackend) of

View file

@ -16,7 +16,9 @@ import qualified Command.Add
import qualified Command.Fix
import Annex.Direct
import Annex.Hook
import Annex.Link
import Annex.View
import Annex.Version
import Annex.View.ViewedFile
import Annex.LockFile
import Logs.View
@ -41,17 +43,22 @@ seek ps = lockPreCommitHook $ ifM isDirect
withWords startDirect ps
runAnnexHook preCommitAnnexHook
, do
ifM (liftIO Git.haveFalseIndex)
ifM (not <$> versionSupportsUnlockedPointers <&&> liftIO Git.haveFalseIndex)
( do
(fs, cleanup) <- inRepo $ Git.typeChangedStaged ps
whenM (anyM isUnlocked fs) $
whenM (anyM isOldUnlocked fs) $
error "Cannot make a partial commit with unlocked annexed files. You should `git annex add` the files you want to commit, and then run git commit."
void $ liftIO cleanup
, do
-- fix symlinks to files being committed
withFilesToBeCommitted (whenAnnexed Command.Fix.start) ps
flip withFilesToBeCommitted ps $ \f ->
maybe stop (Command.Fix.start f)
=<< isAnnexLink f
-- inject unlocked files into the annex
withFilesUnlockedToBeCommitted startIndirect ps
-- (not needed when repo version uses
-- unlocked pointer files)
unlessM versionSupportsUnlockedPointers $
withFilesOldUnlockedToBeCommitted startInjectUnlocked ps
)
runAnnexHook preCommitAnnexHook
-- committing changes to a view updates metadata
@ -64,8 +71,8 @@ seek ps = lockPreCommitHook $ ifM isDirect
)
startIndirect :: FilePath -> CommandStart
startIndirect f = next $ do
startInjectUnlocked :: FilePath -> CommandStart
startInjectUnlocked f = next $ do
unlessM (callCommandAction $ Command.Add.start f) $
error $ "failed to add " ++ f ++ "; canceling commit"
next $ return True

View file

@ -12,7 +12,7 @@ import Command
import qualified Annex
import Types.Key
import Annex.Content
import qualified Command.Add
import Annex.Ingest
import Logs.Web
import Logs.Location
import Utility.CopyFile
@ -70,6 +70,6 @@ cleanup file oldkey newkey = do
-- Update symlink to use the new key.
liftIO $ removeFile file
Command.Add.addLink file newkey Nothing
addLink file newkey Nothing
logStatus newkey InfoPresent
return True

View file

@ -38,6 +38,6 @@ perform s = do
then return $ toUUID s
else Remote.nameToUUID s
storeUUID u
initialize'
initialize' Nothing
Annex.SpecialRemote.autoEnable
next $ return True

115
Command/Smudge.hs Normal file
View file

@ -0,0 +1,115 @@
{- git-annex command
-
- Copyright 2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Command.Smudge where
import Common.Annex
import Command
import Annex.Content
import Annex.Link
import Annex.MetaData
import Annex.FileMatcher
import Annex.InodeSentinal
import Annex.Ingest
import Utility.InodeCache
import Types.KeySource
import Backend
import Logs.Location
import qualified Database.Keys
import qualified Data.ByteString.Lazy as B
cmd :: Command
cmd = noCommit $ noMessages $
command "smudge" SectionPlumbing
"git smudge filter"
paramFile (seek <$$> optParser)
data SmudgeOptions = SmudgeOptions
{ smudgeFile :: FilePath
, cleanOption :: Bool
}
optParser :: CmdParamsDesc -> Parser SmudgeOptions
optParser desc = SmudgeOptions
<$> argument str ( metavar desc )
<*> switch ( long "clean" <> help "clean filter" )
seek :: SmudgeOptions -> CommandSeek
seek o = commandAction $
(if cleanOption o then clean else smudge) (smudgeFile o)
-- Smudge filter is fed git file content, and if it's a pointer to an
-- available annex object, should output its content.
smudge :: FilePath -> CommandStart
smudge file = do
b <- liftIO $ B.hGetContents stdin
case parseLinkOrPointer b of
Nothing -> liftIO $ B.putStr b
Just k -> do
-- A previous unlocked checkout of the file may have
-- led to the annex object getting modified;
-- don't provide such modified content as it
-- will be confusing. inAnnex will detect such
-- modifications.
ifM (inAnnex k)
( do
content <- calcRepo (gitAnnexLocation k)
liftIO $ B.putStr . fromMaybe b
=<< catchMaybeIO (B.readFile content)
, liftIO $ B.putStr b
)
Database.Keys.addAssociatedFile k file
stop
-- Clean filter is fed file content on stdin, decides if a file
-- should be stored in the annex, and outputs a pointer to its
-- injested content.
clean :: FilePath -> CommandStart
clean file = do
b <- liftIO $ B.hGetContents stdin
if isJust (parseLinkOrPointer b)
then liftIO $ B.hPut stdout b
else ifM (shouldAnnex file)
( liftIO . emitPointer =<< ingestLocal file
, liftIO $ B.hPut stdout b
)
stop
shouldAnnex :: FilePath -> Annex Bool
shouldAnnex file = do
matcher <- largeFilesMatcher
checkFileMatcher matcher file
-- TODO: Use main ingest code instead?
ingestLocal :: FilePath -> Annex Key
ingestLocal file = do
backend <- chooseBackend file
ic <- withTSDelta (liftIO . genInodeCache file)
let source = KeySource
{ keyFilename = file
, contentLocation = file
, inodeCache = ic
}
k <- fst . fromMaybe (error "failed to generate a key")
<$> genKey source backend
-- Hard link (or copy) file content to annex object
-- to prevent it from being lost when git checks out
-- a branch not containing this file.
r <- linkAnnex k file ic
case r of
LinkAnnexFailed -> error "Problem adding file to the annex"
LinkAnnexOk -> logStatus k InfoPresent
LinkAnnexNoop -> noop
genMetaData k file
=<< liftIO (getFileStatus file)
cleanOldKeys file k
Database.Keys.addAssociatedFile k file
return k
emitPointer :: Key -> IO ()
emitPointer = putStr . formatPointer

View file

@ -15,12 +15,14 @@ import Config
import qualified Annex
import Annex.Content
import Annex.Content.Direct
import Annex.Version
import qualified Git.Command
import qualified Git.Branch
import qualified Git.Ref
import qualified Git.DiffTree as DiffTree
import Utility.CopyFile
import Command.PreCommit (lockPreCommitHook)
import qualified Database.Keys
cmd :: Command
cmd = withGlobalOptions annexedMatchingOptions $
@ -32,7 +34,7 @@ seek :: CmdParams -> CommandSeek
seek = wrapUnannex . (withFilesInGit $ whenAnnexed start)
wrapUnannex :: Annex a -> Annex a
wrapUnannex a = ifM isDirect
wrapUnannex a = ifM (versionSupportsUnlockedPointers <||> isDirect)
( a
{- Run with the pre-commit hook disabled, to avoid confusing
- behavior if an unannexed file is added back to git as
@ -85,6 +87,7 @@ performIndirect file key = do
cleanupIndirect :: FilePath -> Key -> CommandCleanup
cleanupIndirect file key = do
Database.Keys.removeAssociatedFile key file
src <- calcRepo $ gitAnnexLocation key
ifM (Annex.getState Annex.fast)
( do

View file

@ -72,7 +72,7 @@ perform p = do
f <- mkrel di
whenM isDirect $
maybe noop (`removeDirect` f)
=<< catKey (srcsha di) (srcmode di)
=<< catKey (srcsha di)
liftIO $ nukeFile f
forM_ adds $ \di -> do
@ -80,6 +80,6 @@ perform p = do
inRepo $ Git.run [Param "checkout", Param "--", File f]
whenM isDirect $
maybe noop (`toDirect` f)
=<< catKey (dstsha di) (dstmode di)
=<< catKey (dstsha di)
next $ liftIO cleanup

View file

@ -1,6 +1,6 @@
{- git-annex command
-
- Copyright 2010 Joey Hess <id@joeyh.name>
- Copyright 2010,2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@ -11,6 +11,11 @@ import Common.Annex
import Command
import Annex.Content
import Annex.CatFile
import Annex.Version
import Annex.Link
import Annex.ReplaceFile
import Annex.InodeSentinal
import Utility.InodeCache
import Utility.CopyFile
cmd :: Command
@ -26,14 +31,46 @@ mkcmd n d = notDirect $ withGlobalOptions annexedMatchingOptions $
seek :: CmdParams -> CommandSeek
seek = withFilesInGit $ whenAnnexed start
{- The unlock subcommand replaces the symlink with a copy of the file's
- content. -}
{- Before v6, the unlock subcommand replaces the symlink with a copy of
- the file's content. In v6 and above, it converts the file from a symlink
- to a pointer. -}
start :: FilePath -> Key -> CommandStart
start file key = do
showStart "unlock" file
start file key = ifM (isJust <$> isAnnexLink file)
( do
showStart "unlock" file
ifM (inAnnex key)
( ifM versionSupportsUnlockedPointers
( next $ performNew file key
, startOld file key
)
, do
warning "content not present; cannot unlock"
next $ next $ return False
)
, stop
)
performNew :: FilePath -> Key -> CommandPerform
performNew dest key = do
src <- calcRepo (gitAnnexLocation key)
srcic <- withTSDelta (liftIO . genInodeCache src)
replaceFile dest $ \tmp -> do
r <- linkAnnex' key src srcic tmp
case r of
LinkAnnexOk -> return ()
_ -> error "linkAnnex failed"
next $ cleanupNew dest key
cleanupNew :: FilePath -> Key -> CommandCleanup
cleanupNew dest key = do
stagePointerFile dest =<< hashPointerFile key
return True
startOld :: FilePath -> Key -> CommandStart
startOld file key =
ifM (inAnnex key)
( ifM (isJust <$> catKeyFileHEAD file)
( next $ perform file key
( next $ performOld file key
, do
warning "this has not yet been committed to git; cannot unlock it"
next $ next $ return False
@ -43,8 +80,8 @@ start file key = do
next $ next $ return False
)
perform :: FilePath -> Key -> CommandPerform
perform dest key = ifM (checkDiskSpace Nothing key 0 True)
performOld :: FilePath -> Key -> CommandPerform
performOld dest key = ifM (checkDiskSpace Nothing key 0 True)
( do
src <- calcRepo $ gitAnnexLocation key
tmpdest <- fromRepo $ gitAnnexTmpObjectLocation key

View file

@ -24,7 +24,6 @@ import qualified Git.Branch
import qualified Git.RefLog
import qualified Git.LsFiles as LsFiles
import qualified Git.DiffTree as DiffTree
import qualified Backend
import qualified Remote
import qualified Annex.Branch
import Annex.CatFile
@ -215,7 +214,7 @@ withKeysReferenced' mdir initial a = do
Just dir -> inRepo $ LsFiles.inRepo [dir]
go v [] = return v
go v (f:fs) = do
x <- Backend.lookupFile f
x <- lookupFile f
case x of
Nothing -> go v fs
Just k -> do
@ -266,7 +265,7 @@ withKeysReferencedInGitRef a ref = do
forM_ ts $ tKey lookAtWorkingTree >=> maybe noop a
liftIO $ void clean
where
tKey True = Backend.lookupFile . getTopFilePath . DiffTree.file
tKey True = lookupFile . getTopFilePath . DiffTree.file
tKey False = fileKey . takeFileName . decodeBS <$$>
catFile ref . getTopFilePath . DiffTree.file

View file

@ -13,6 +13,7 @@ import Upgrade
cmd :: Command
cmd = dontCheck repoExists $ -- because an old version may not seem to exist
noDaemonRunning $ -- avoid upgrading repo out from under daemon
command "upgrade" SectionMaintenance "upgrade repository layout"
paramNothing (withParams seek)

View file

@ -50,7 +50,8 @@ showVersion = do
liftIO $ do
showPackageVersion
vinfo "local repository version" $ fromMaybe "unknown" v
vinfo "supported repository version" supportedVersion
vinfo "supported repository versions" $
unwords supportedVersions
vinfo "upgrade supported from repository versions" $
unwords upgradableVersions

View file

@ -90,3 +90,21 @@ setCrippledFileSystem :: Bool -> Annex ()
setCrippledFileSystem b = do
setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b)
Annex.changeGitConfig $ \c -> c { annexCrippledFileSystem = b }
configureSmudgeFilter :: Annex ()
configureSmudgeFilter = do
setConfig (ConfigKey "filter.annex.smudge") "git-annex smudge %f"
setConfig (ConfigKey "filter.annex.clean") "git-annex smudge --clean %f"
lf <- Annex.fromRepo Git.attributesLocal
gf <- Annex.fromRepo Git.attributes
lfs <- readattr lf
gfs <- readattr gf
liftIO $ unless ("filter=annex" `isInfixOf` (lfs ++ gfs)) $ do
createDirectoryIfMissing True (takeDirectory lf)
writeFile lf (lfs ++ "\n" ++ stdattr)
where
readattr = liftIO . catchDefaultIO "" . readFileStrictAnyEncoding
stdattr = unlines
[ "* filter=annex"
, ".* !filter"
]

View file

@ -21,7 +21,7 @@ module Database.Fsck (
) where
import Database.Types
import qualified Database.Handle as H
import qualified Database.Queue as H
import Locations
import Utility.PosixFiles
import Utility.Exception
@ -31,13 +31,12 @@ import Types.Key
import Types.UUID
import Annex.Perms
import Annex.LockFile
import Messages
import Database.Persist.TH
import Database.Esqueleto hiding (Key)
import Data.Time.Clock
data FsckHandle = FsckHandle H.DbHandle UUID
data FsckHandle = FsckHandle H.DbQueue UUID
{- Each key stored in the database has already been fscked as part
- of the latest incremental fsck pass. -}
@ -59,7 +58,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)
@ -77,16 +76,12 @@ openDb u = do
void $ tryIO $ removeDirectoryRecursive dbdir
rename tmpdbdir dbdir
lockFileCached =<< fromRepo (gitAnnexFsckDbLock u)
h <- liftIO $ H.openDb db "fscked"
-- work around https://github.com/yesodweb/persistent/issues/474
liftIO setConsoleEncoding
h <- liftIO $ H.openDbQueue db "fscked"
return $ FsckHandle h u
closeDb :: FsckHandle -> Annex ()
closeDb (FsckHandle h u) = do
liftIO $ H.closeDb h
liftIO $ H.closeDbQueue h
unlockFile =<< fromRepo (gitAnnexFsckDbLock u)
addDb :: FsckHandle -> Key -> IO ()
@ -102,8 +97,9 @@ addDb (FsckHandle h _) k = H.queueDb h checkcommit $
now <- getCurrentTime
return $ diffUTCTime lastcommittime now > 300
{- Doesn't know about keys that were just added with addDb. -}
inDb :: FsckHandle -> Key -> IO Bool
inDb (FsckHandle h _) = H.queryDb h . inDb' . toSKey
inDb (FsckHandle h _) = H.queryDbQueue h . inDb' . toSKey
inDb' :: SKey -> SqlPersistM Bool
inDb' sk = do

View file

@ -11,17 +11,15 @@ module Database.Handle (
DbHandle,
initDb,
openDb,
TableName,
queryDb,
closeDb,
Size,
queueDb,
flushQueueDb,
commitDb,
commitDb',
) where
import Utility.Exception
import Utility.Monad
import Messages
import Utility.FileSystemEncoding
import Database.Persist.Sqlite
import qualified Database.Sqlite as Sqlite
@ -29,22 +27,22 @@ import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception (throwIO)
import Control.Exception (throwIO, BlockedIndefinitelyOnMVar(..))
import qualified Data.Text as T
import Control.Monad.Trans.Resource (runResourceT)
import Control.Monad.Logger (runNoLoggingT)
import Data.List
import Data.Time.Clock
import System.IO
{- 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) (MVar DbQueue)
data DbHandle = DbHandle (Async ()) (MVar Job)
{- Ensures that the database is initialized. Pass the migration action for
- the database.
-
- The database is put into WAL mode, to prevent readers from blocking
- writers, and prevent a writer from blocking readers.
- The database is initialized using WAL mode, to prevent readers
- from blocking writers, and prevent a writer from blocking readers.
-}
initDb :: FilePath -> SqlPersistM () -> IO ()
initDb f migration = do
@ -60,46 +58,110 @@ enableWAL db = do
void $ Sqlite.finalize stmt
Sqlite.close conn
{- Name of a table that should exist once the database is initialized. -}
type TableName = String
{- Opens the database, but does not perform any migrations. Only use
- if the database is known to exist and have the right tables. -}
openDb :: FilePath -> TableName -> IO DbHandle
openDb db tablename = do
jobs <- newEmptyMVar
worker <- async (workerThread (T.pack db) tablename jobs)
q <- newMVar =<< emptyDbQueue
return $ DbHandle worker jobs q
-- work around https://github.com/yesodweb/persistent/issues/474
liftIO setConsoleEncoding
return $ DbHandle worker jobs
{- This is optional; when the DbHandle gets garbage collected it will
- auto-close. -}
closeDb :: DbHandle -> IO ()
closeDb (DbHandle worker jobs) = do
putMVar jobs CloseJob
wait worker
{- Makes a query using the DbHandle. This should not be used to make
- changes to the database!
-
- Note that the action is not run by the calling thread, but by a
- worker thread. Exceptions are propigated to the calling thread.
-
- Only one action can be run at a time against a given DbHandle.
- If called concurrently in the same process, this will block until
- it is able to run.
-}
queryDb :: DbHandle -> SqlPersistM a -> IO a
queryDb (DbHandle _ jobs) a = do
res <- newEmptyMVar
putMVar jobs $ QueryJob $
liftIO . putMVar res =<< tryNonAsync a
(either throwIO return =<< takeMVar res)
`catchNonAsync` (const $ error "sqlite query crashed")
{- Writes a change to the database.
-
- If a database is opened multiple times and there's a concurrent writer,
- the write could fail. Retries repeatedly for up to 10 seconds,
- which should avoid all but the most exceptional problems.
-}
commitDb :: DbHandle -> SqlPersistM () -> IO ()
commitDb h wa = robustly Nothing 100 (commitDb' h wa)
where
robustly :: Maybe SomeException -> Int -> IO (Either SomeException ()) -> IO ()
robustly e 0 _ = error $ "failed to commit changes to sqlite database: " ++ show e
robustly _ n a = do
r <- a
case r of
Right _ -> return ()
Left e -> do
threadDelay 100000 -- 1/10th second
robustly (Just e) (n-1) a
commitDb' :: DbHandle -> SqlPersistM () -> IO (Either SomeException ())
commitDb' (DbHandle _ jobs) a = do
res <- newEmptyMVar
putMVar jobs $ ChangeJob $ \runner ->
liftIO $ putMVar res =<< tryNonAsync (runner a)
takeMVar res
data Job
= QueryJob (SqlPersistM ())
| ChangeJob ((SqlPersistM () -> IO ()) -> IO ())
| CloseJob
type TableName = String
workerThread :: T.Text -> TableName -> MVar Job -> IO ()
workerThread db tablename jobs = catchNonAsync (run loop) showerr
workerThread db tablename jobs =
catchNonAsync (runSqliteRobustly tablename db loop) showerr
where
showerr e = liftIO $ warningIO $
showerr e = hPutStrLn stderr $
"sqlite worker thread crashed: " ++ show e
getjob :: IO (Either BlockedIndefinitelyOnMVar Job)
getjob = try $ takeMVar jobs
loop = do
job <- liftIO $ takeMVar jobs
job <- liftIO getjob
case job of
QueryJob a -> a >> loop
-- Exception is thrown when the MVar is garbage
-- collected, which means the whole DbHandle
-- is not used any longer. Shutdown cleanly.
Left BlockedIndefinitelyOnMVar -> return ()
Right CloseJob -> return ()
Right (QueryJob a) -> a >> loop
-- change is run in a separate database connection
-- since sqlite only supports a single writer at a
-- time, and it may crash the database connection
ChangeJob a -> liftIO (a run) >> loop
CloseJob -> return ()
Right (ChangeJob a) -> liftIO (a (runSqliteRobustly tablename db)) >> loop
-- like runSqlite, but calls settle on the raw sql Connection.
run a = do
conn <- Sqlite.open db
settle conn
runResourceT $ runNoLoggingT $
withSqlConn (wrapConnection conn) $
runSqlConn a
-- like runSqlite, but calls settle on the raw sql Connection.
runSqliteRobustly :: TableName -> T.Text -> (SqlPersistM a) -> IO a
runSqliteRobustly tablename db a = do
conn <- Sqlite.open db
settle conn
runResourceT $ runNoLoggingT $
withSqlConn (wrapConnection conn) $
runSqlConn a
where
-- Work around a bug in sqlite: New database connections can
-- sometimes take a while to become usable; select statements will
-- fail with ErrorBusy for some time. So, loop until a select
@ -121,97 +183,3 @@ workerThread db tablename jobs = catchNonAsync (run loop) showerr
-- This should succeed for any table.
nullselect = T.pack $ "SELECT null from " ++ tablename ++ " limit 1"
{- Makes a query using the DbHandle. This should not be used to make
- changes to the database!
-
- Note that the action is not run by the calling thread, but by a
- worker thread. Exceptions are propigated to the calling thread.
-
- Only one action can be run at a time against a given DbHandle.
- If called concurrently in the same process, this will block until
- it is able to run.
-}
queryDb :: DbHandle -> SqlPersistM a -> IO a
queryDb (DbHandle _ jobs _) a = do
res <- newEmptyMVar
putMVar jobs $ QueryJob $
liftIO . putMVar res =<< tryNonAsync a
(either throwIO return =<< takeMVar res)
`catchNonAsync` (const $ error "sqlite query crashed")
closeDb :: DbHandle -> IO ()
closeDb h@(DbHandle worker jobs _) = do
flushQueueDb h
putMVar jobs CloseJob
wait worker
type Size = Int
type LastCommitTime = UTCTime
{- A queue of actions to perform, with a count of the number of actions
- queued, and a last commit time. -}
data DbQueue = DbQueue Size LastCommitTime (SqlPersistM ())
emptyDbQueue :: IO DbQueue
emptyDbQueue = do
now <- getCurrentTime
return $ DbQueue 0 now (return ())
{- Queues a change to be made to the database. It will be buffered
- to be committed later, unless the commitchecker action returns true.
-
- (Be sure to call closeDb or flushQueueDb to ensure the change
- gets committed.)
-
- Transactions built up by queueDb are sent to sqlite all at once.
- If sqlite fails due to another change being made concurrently by another
- process, the transaction is put back in the queue. This solves
- the sqlite multiple writer problem.
-}
queueDb
:: DbHandle
-> (Size -> LastCommitTime -> IO Bool)
-> SqlPersistM ()
-> IO ()
queueDb h@(DbHandle _ _ qvar) commitchecker a = do
DbQueue sz lastcommittime qa <- takeMVar qvar
let !sz' = sz + 1
let qa' = qa >> a
let enqueue = putMVar qvar
ifM (commitchecker sz' lastcommittime)
( do
r <- commitDb h qa'
case r of
Left _ -> enqueue $ DbQueue sz' lastcommittime qa'
Right _ -> do
now <- getCurrentTime
enqueue $ DbQueue 0 now (return ())
, enqueue $ DbQueue sz' lastcommittime qa'
)
{- If flushing the queue fails, this could be because there is another
- writer to the database. Retry repeatedly for up to 10 seconds. -}
flushQueueDb :: DbHandle -> IO ()
flushQueueDb h@(DbHandle _ _ qvar) = do
DbQueue sz _ qa <- takeMVar qvar
when (sz > 0) $
robustly Nothing 100 (commitDb h qa)
where
robustly :: Maybe SomeException -> Int -> IO (Either SomeException ()) -> IO ()
robustly e 0 _ = error $ "failed to commit changes to sqlite database: " ++ show e
robustly _ n a = do
r <- a
case r of
Right _ -> return ()
Left e -> do
threadDelay 100000 -- 1/10th second
robustly (Just e) (n-1) a
commitDb :: DbHandle -> SqlPersistM () -> IO (Either SomeException ())
commitDb (DbHandle _ jobs _) a = do
res <- newEmptyMVar
putMVar jobs $ ChangeJob $ \runner ->
liftIO $ putMVar res =<< tryNonAsync (runner a)
takeMVar res

237
Database/Keys.hs Normal file
View file

@ -0,0 +1,237 @@
{- Sqlite database of information about Keys
-
- 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.Keys (
DbHandle,
addAssociatedFile,
getAssociatedFiles,
getAssociatedKey,
removeAssociatedFile,
storeInodeCaches,
addInodeCaches,
getInodeCaches,
removeInodeCaches,
AssociatedId,
ContentId,
) where
import Database.Types
import Database.Keys.Handle
import qualified Database.Queue as H
import Locations
import Common hiding (delete)
import Annex
import Types.Key
import Annex.Perms
import Annex.LockFile
import Utility.InodeCache
import Annex.InodeSentinal
import Database.Persist.TH
import Database.Esqueleto hiding (Key)
import Data.Time.Clock
share [mkPersist sqlSettings, mkMigrate "migrateKeysDb"] [persistLowerCase|
Associated
key SKey
file FilePath
KeyFileIndex key file
Content
key SKey
cache SInodeCache
KeyCacheIndex key cache
|]
newtype ReadHandle = ReadHandle H.DbQueue
type Reader v = ReadHandle -> Annex v
{- Runs an action that reads from the database.
-
- If the database doesn't already exist, it's not created; mempty is
- returned instead. This way, when the keys database is not in use,
- there's minimal overhead in checking it.
-
- 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 => Reader v -> Annex v
runReader a = do
h <- getDbHandle
withDbState h go
where
go DbEmpty = return (mempty, DbEmpty)
go st@(DbOpen qh) = do
liftIO $ H.flushDbQueue qh
v <- a (ReadHandle qh)
return (v, st)
go DbClosed = do
st' <- openDb False DbClosed
v <- case st' of
(DbOpen qh) -> a (ReadHandle qh)
_ -> return mempty
return (v, st')
readDb :: SqlPersistM a -> ReadHandle -> Annex a
readDb a (ReadHandle h) = liftIO $ H.queryDbQueue h a
newtype WriteHandle = WriteHandle H.DbQueue
type Writer = WriteHandle -> Annex ()
{- 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 :: Writer -> Annex ()
runWriter a = do
h <- getDbHandle
withDbState h go
where
go st@(DbOpen qh) = do
v <- a (WriteHandle qh)
return (v, st)
go st = do
st' <- openDb True st
v <- case st' of
DbOpen qh -> a (WriteHandle qh)
_ -> error "internal"
return (v, st')
queueDb :: SqlPersistM () -> WriteHandle -> Annex ()
queueDb a (WriteHandle h) = liftIO $ H.queueDb h checkcommit a
where
-- commit queue after 1000 changes or 5 minutes, whichever comes first
checkcommit sz lastcommittime
| sz > 1000 = return True
| otherwise = do
now <- getCurrentTime
return $ diffUTCTime lastcommittime now > 300
{- Gets the handle cached in Annex state; creates a new one if it's not yet
- available, but doesn't open the database. -}
getDbHandle :: Annex DbHandle
getDbHandle = go =<< getState keysdbhandle
where
go (Just h) = pure h
go Nothing = do
h <- liftIO newDbHandle
changeState $ \s -> s { keysdbhandle = Just h }
return h
{- Opens the database, perhaps 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 DbEmpty = return DbEmpty
openDb createdb _ = withExclusiveLock gitAnnexKeysDbLock $ do
dbdir <- fromRepo gitAnnexKeysDb
let db = dbdir </> "db"
dbexists <- liftIO $ doesFileExist db
case (dbexists, createdb) of
(True, _) -> open db
(False, True) -> do
liftIO $ do
createDirectoryIfMissing True dbdir
H.initDb db $ void $
runMigrationSilent migrateKeysDb
setAnnexDirPerm dbdir
setAnnexFilePerm db
open db
(False, False) -> return DbEmpty
where
open db = liftIO $ DbOpen <$> H.openDbQueue db "content"
addAssociatedFile :: Key -> FilePath -> Annex ()
addAssociatedFile k f = runWriter $ addAssociatedFile' k f
addAssociatedFile' :: Key -> FilePath -> Writer
addAssociatedFile' k f = queueDb $ 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 were once associated with the key, but
- some of them may not be any longer. -}
getAssociatedFiles :: Key -> Annex [FilePath]
getAssociatedFiles = runReader . getAssociatedFiles' . toSKey
getAssociatedFiles' :: SKey -> Reader [FilePath]
getAssociatedFiles' sk = readDb $ do
l <- select $ from $ \r -> do
where_ (r ^. AssociatedKey ==. val sk)
return (r ^. AssociatedFile)
return $ map unValue 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 :: FilePath -> Annex [Key]
getAssociatedKey = runReader . getAssociatedKey'
getAssociatedKey' :: FilePath -> Reader [Key]
getAssociatedKey' f = readDb $ do
l <- select $ from $ \r -> do
where_ (r ^. AssociatedFile ==. val f)
return (r ^. AssociatedKey)
return $ map (fromSKey . unValue) l
removeAssociatedFile :: Key -> FilePath -> Annex ()
removeAssociatedFile k = runWriter . removeAssociatedFile' (toSKey k)
removeAssociatedFile' :: SKey -> FilePath -> Writer
removeAssociatedFile' sk f = queueDb $
delete $ from $ \r -> do
where_ (r ^. AssociatedKey ==. val sk &&. r ^. AssociatedFile ==. val f)
{- Stats the files, and stores their InodeCaches. -}
storeInodeCaches :: Key -> [FilePath] -> Annex ()
storeInodeCaches k fs = withTSDelta $ \d ->
addInodeCaches k . catMaybes =<< liftIO (mapM (`genInodeCache` d) fs)
addInodeCaches :: Key -> [InodeCache] -> Annex ()
addInodeCaches k is = runWriter $ addInodeCaches' (toSKey k) is
addInodeCaches' :: SKey -> [InodeCache] -> Writer
addInodeCaches' sk is = queueDb $
forM_ is $ \i -> insertUnique $ Content sk (toSInodeCache i)
{- A key may have multiple InodeCaches; one for the annex object, and one
- for each pointer file that is a copy of it. -}
getInodeCaches :: Key -> Annex [InodeCache]
getInodeCaches = runReader . getInodeCaches' . toSKey
getInodeCaches' :: SKey -> Reader [InodeCache]
getInodeCaches' sk = readDb $ do
l <- select $ from $ \r -> do
where_ (r ^. ContentKey ==. val sk)
return (r ^. ContentCache)
return $ map (fromSInodeCache. unValue) l
removeInodeCaches :: Key -> Annex ()
removeInodeCaches = runWriter . removeInodeCaches' . toSKey
removeInodeCaches' :: SKey -> Writer
removeInodeCaches' sk = queueDb $
delete $ from $ \r -> do
where_ (r ^. ContentKey ==. val sk)

55
Database/Keys/Handle.hs Normal file
View file

@ -0,0 +1,55 @@
{- Handle for the Keys database.
-
- Copyright 2015 Joey Hess <id@joeyh.name>
-:
- Licensed under the GNU GPL version 3 or higher.
-}
module Database.Keys.Handle (
DbHandle,
newDbHandle,
DbState(..),
withDbState,
flushDbQueue,
) where
import qualified Database.Queue as H
import Utility.Exception
import Control.Concurrent
import Control.Monad.IO.Class (liftIO, MonadIO)
-- The MVar is always left full except when actions are run
-- that access the database.
newtype DbHandle = DbHandle (MVar DbState)
-- The database can be closed or open, but it also may have been
-- tried to open (for read) and didn't exist yet.
data DbState = DbClosed | DbOpen H.DbQueue | DbEmpty
newDbHandle :: IO DbHandle
newDbHandle = DbHandle <$> newMVar DbClosed
-- Runs an action on the state of the handle, which can change its state.
-- The MVar is empty while the action runs, which blocks other users
-- of the handle from running.
withDbState
:: (MonadIO m, MonadCatch m)
=> DbHandle
-> (DbState
-> m (v, DbState))
-> m v
withDbState (DbHandle mvar) a = do
st <- liftIO $ takeMVar mvar
go st `onException` (liftIO $ putMVar mvar st)
where
go st = do
(v, st') <- a st
liftIO $ putMVar mvar st'
return v
flushDbQueue :: DbHandle -> IO ()
flushDbQueue (DbHandle mvar) = go =<< readMVar mvar
where
go (DbOpen qh) = H.flushDbQueue qh
go _ = return ()

107
Database/Queue.hs Normal file
View file

@ -0,0 +1,107 @@
{- Persistent sqlite database queues
-
- Copyright 2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE BangPatterns #-}
module Database.Queue (
DbQueue,
initDb,
openDbQueue,
queryDbQueue,
closeDbQueue,
flushDbQueue,
QueueSize,
queueDb,
) where
import Utility.Monad
import Database.Handle
import Database.Persist.Sqlite
import Control.Concurrent
import Data.Time.Clock
{- A DbQueue wraps a DbHandle, adding a queue of writes to perform.
-
- This is efficient when there are frequent writes, but
- reads will not immediately have access to queued writes. -}
data DbQueue = DQ DbHandle (MVar Queue)
{- Opens the database queue, but does not perform any migrations. Only use
- if the database is known to exist and have the right tables; ie after
- running initDb. -}
openDbQueue :: FilePath -> TableName -> IO DbQueue
openDbQueue db tablename = DQ
<$> openDb db tablename
<*> (newMVar =<< emptyQueue)
{- This or flushDbQueue must be called, eg at program exit to ensure
- queued changes get written to the database. -}
closeDbQueue :: DbQueue -> IO ()
closeDbQueue h@(DQ hdl _) = do
flushDbQueue h
closeDb hdl
{- Blocks until all queued changes have been written to the database. -}
flushDbQueue :: DbQueue -> IO ()
flushDbQueue (DQ hdl qvar) = do
q@(Queue sz _ qa) <- takeMVar qvar
if sz > 0
then do
commitDb hdl qa
putMVar qvar =<< emptyQueue
else putMVar qvar q
{- Makes a query using the DbQueue's database connection.
- This should not be used to make changes to the database!
-
- Queries will not return changes that have been recently queued,
- so use with care.
-}
queryDbQueue :: DbQueue -> SqlPersistM a -> IO a
queryDbQueue (DQ hdl _) = queryDb hdl
{- A queue of actions to perform, with a count of the number of actions
- queued, and a last commit time. -}
data Queue = Queue QueueSize LastCommitTime (SqlPersistM ())
type QueueSize = Int
type LastCommitTime = UTCTime
emptyQueue :: IO Queue
emptyQueue = do
now <- getCurrentTime
return $ Queue 0 now (return ())
{- Queues a change to be made to the database. It will be queued
- to be committed later, unless the commitchecker action returns true,
- in which case any previously queued changes are also committed.
-
- Transactions built up by queueDb are sent to sqlite all at once.
- If sqlite fails due to another change being made concurrently by another
- process, the transaction is put back in the queue. This avoids
- the sqlite multiple writer problem.
-}
queueDb
:: DbQueue
-> (QueueSize -> LastCommitTime -> IO Bool)
-> SqlPersistM ()
-> IO ()
queueDb (DQ hdl qvar) commitchecker a = do
Queue sz lastcommittime qa <- takeMVar qvar
let !sz' = sz + 1
let qa' = qa >> a
let enqueue = putMVar qvar
ifM (commitchecker sz' lastcommittime)
( do
r <- commitDb' hdl qa'
case r of
Left _ -> enqueue $ Queue sz' lastcommittime qa'
Right _ -> enqueue =<< emptyQueue
, enqueue $ Queue sz' lastcommittime qa'
)

View file

@ -13,6 +13,7 @@ import Database.Persist.TH
import Data.Maybe
import Types.Key
import Utility.InodeCache
-- A serialized Key
newtype SKey = SKey String
@ -22,6 +23,18 @@ toSKey :: Key -> SKey
toSKey = SKey . key2file
fromSKey :: SKey -> Key
fromSKey (SKey s) = fromMaybe (error $ "bad serialied key " ++ s) (file2key s)
fromSKey (SKey s) = fromMaybe (error $ "bad serialied Key " ++ s) (file2key s)
derivePersistField "SKey"
-- A serialized InodeCache
newtype SInodeCache = I String
deriving (Show, Read)
toSInodeCache :: InodeCache -> SInodeCache
toSInodeCache = I . showInodeCache
fromSInodeCache :: SInodeCache -> InodeCache
fromSInodeCache (I s) = fromMaybe (error $ "bad serialied InodeCache " ++ s) (readInodeCache s)
derivePersistField "SInodeCache"

8
Git.hs
View file

@ -28,6 +28,7 @@ module Git (
repoPath,
localGitDir,
attributes,
attributesLocal,
hookPath,
assertLocal,
adjustPath,
@ -125,8 +126,11 @@ assertLocal repo action
{- Path to a repository's gitattributes file. -}
attributes :: Repo -> FilePath
attributes repo
| repoIsLocalBare repo = repoPath repo ++ "/info/.gitattributes"
| otherwise = repoPath repo ++ "/.gitattributes"
| repoIsLocalBare repo = attributesLocal repo
| otherwise = repoPath repo </> ".gitattributes"
attributesLocal :: Repo -> FilePath
attributesLocal repo = localGitDir repo </> "info" </> "attributes"
{- Path to a given hook script in a repository, only if the hook exists
- and is executable. -}

View file

@ -11,8 +11,8 @@ import Common.Annex
import qualified Annex
import qualified Utility.Matcher
import qualified Remote
import qualified Backend
import Annex.Content
import Annex.WorkTree
import Annex.Action
import Annex.UUID
import Logs.Trust
@ -201,22 +201,22 @@ limitAnything _ _ = return True
{- Adds a limit to skip files not believed to be present in all
- repositories in the specified group. -}
addInAllGroup :: String -> Annex ()
addInAllGroup groupname = do
m <- groupMap
addLimit $ limitInAllGroup m groupname
addInAllGroup groupname = addLimit $ limitInAllGroup groupMap groupname
limitInAllGroup :: GroupMap -> MkLimit Annex
limitInAllGroup m groupname
| S.null want = Right $ const $ const $ return True
| otherwise = Right $ \notpresent -> checkKey $ check notpresent
where
want = fromMaybe S.empty $ M.lookup groupname $ uuidsByGroup m
check notpresent key
limitInAllGroup :: Annex GroupMap -> MkLimit Annex
limitInAllGroup getgroupmap groupname = Right $ \notpresent mi -> do
m <- getgroupmap
let want = fromMaybe S.empty $ M.lookup groupname $ uuidsByGroup m
if S.null want
then return True
-- optimisation: Check if a wanted uuid is notpresent.
| not (S.null (S.intersection want notpresent)) = return False
| otherwise = do
present <- S.fromList <$> Remote.keyLocations key
return $ S.null $ want `S.difference` present
else if not (S.null (S.intersection want notpresent))
then return False
else checkKey (check want) mi
where
check want key = do
present <- S.fromList <$> Remote.keyLocations key
return $ S.null $ want `S.difference` present
{- Adds a limit to skip files not using a specified key-value backend. -}
addInBackend :: String -> Annex ()
@ -277,7 +277,7 @@ addTimeLimit s = do
else return True
lookupFileKey :: FileInfo -> Annex (Maybe Key)
lookupFileKey = Backend.lookupFile . currFile
lookupFileKey = lookupFile . currFile
checkKey :: (Key -> Annex Bool) -> MatchInfo -> Annex Bool
checkKey a (MatchingFile fi) = lookupFileKey fi >>= maybe (return False) a

View file

@ -29,6 +29,8 @@ module Locations (
gitAnnexBadDir,
gitAnnexBadLocation,
gitAnnexUnusedLog,
gitAnnexKeysDb,
gitAnnexKeysDbLock,
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/keys/ contains a database of information about keys. -}
gitAnnexKeysDb :: Git.Repo -> FilePath
gitAnnexKeysDb r = gitAnnexDir r </> "keys"
{- Lock file for the keys database. -}
gitAnnexKeysDbLock :: Git.Repo -> FilePath
gitAnnexKeysDbLock r = gitAnnexKeysDb r ++ "lck"
{- .git/annex/fsck/uuid/ is used to store information about incremental
- fscks. -}
gitAnnexFsckDir :: UUID -> Git.Repo -> FilePath

View file

@ -102,7 +102,7 @@ makeMatcher groupmap configmap groupwantedmap u = go True True
| null (lefts tokens) = generate $ rights tokens
| otherwise = unknownMatcher u
where
tokens = exprParser matchstandard matchgroupwanted groupmap configmap (Just u) expr
tokens = exprParser matchstandard matchgroupwanted (pure groupmap) configmap (Just u) expr
matchstandard
| expandstandard = maybe (unknownMatcher u) (go False False)
(standardPreferredContent <$> getStandardGroup mygroups)
@ -133,7 +133,7 @@ checkPreferredContentExpression expr = case parsedToMatcher tokens of
Left e -> Just e
Right _ -> Nothing
where
tokens = exprParser matchAll matchAll emptyGroupMap M.empty Nothing expr
tokens = exprParser matchAll matchAll (pure emptyGroupMap) M.empty Nothing expr
{- Puts a UUID in a standard group, and sets its preferred content to use
- the standard expression for that group (unless preferred content is

View file

@ -31,7 +31,6 @@ module Messages (
showHeader,
showRaw,
setupConsole,
setConsoleEncoding,
enableDebugOutput,
disableDebugOutput,
debugEnabled,
@ -183,13 +182,6 @@ setupConsole = do
updateGlobalLogger rootLoggerName (setLevel NOTICE . setHandlers [s])
setConsoleEncoding
{- This avoids ghc's output layer crashing on invalid encoded characters in
- filenames when printing them out. -}
setConsoleEncoding :: IO ()
setConsoleEncoding = do
fileEncoding stdout
fileEncoding stderr
{- Log formatter with precision into fractions of a second. -}
preciseLogFormatter :: LogFormatter a
preciseLogFormatter = tfLogFormatter "%F %X%Q" "[$time] $msg"

View file

@ -672,7 +672,7 @@ wantHardLink :: Annex Bool
wantHardLink = (annexHardLink <$> Annex.getGitConfig) <&&> (not <$> isDirect)
-- Copies from src to dest, updating a meter. If the copy finishes
-- successfully, calls a final check action, which must also success, or
-- successfully, calls a final check action, which must also succeed, or
-- returns false.
--
-- If either the remote or local repository wants to use hard links,

147
Test.hs
View file

@ -38,6 +38,7 @@ import Common
import qualified Utility.SafeCommand
import qualified Annex
import qualified Annex.UUID
import qualified Annex.Version
import qualified Backend
import qualified Git.CurrentRepo
import qualified Git.Filename
@ -65,6 +66,7 @@ import qualified Types.Messages
import qualified Config
import qualified Config.Cost
import qualified Crypto
import qualified Annex.WorkTree
import qualified Annex.Init
import qualified Annex.CatFile
import qualified Annex.View
@ -117,18 +119,17 @@ ingredients =
]
tests :: TestTree
tests = testGroup "Tests"
-- Test both direct and indirect mode.
-- Windows is only going to use direct mode, so don't test twice.
[ properties
tests = testGroup "Tests" $ properties :
map (\(d, te) -> withTestMode te (unitTests d)) testmodes
where
testmodes =
[ ("v6", TestMode { forceDirect = False, annexVersion = "6" })
, ("v5", TestMode { forceDirect = False, annexVersion = "5" })
-- Windows will only use direct mode, so don't test twice.
#ifndef mingw32_HOST_OS
, withTestEnv True $ unitTests "(direct)"
, withTestEnv False $ unitTests "(indirect)"
#else
, withTestEnv False $ unitTests ""
, ("v5 direct", TestMode { forceDirect = True, annexVersion = "5" })
]
#endif
]
properties :: TestTree
properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck"
@ -242,8 +243,11 @@ unitTests note = testGroup ("Unit Tests " ++ note)
-- this test case create the main repo
test_init :: Assertion
test_init = innewrepo $ do
git_annex "init" [reponame] @? "init failed"
handleforcedirect
ver <- annexVersion <$> getTestMode
if ver == Annex.Version.defaultVersion
then git_annex "init" [reponame] @? "init failed"
else git_annex "init" [reponame, "--version", ver] @? "init failed"
setupTestMode
where
reponame = "test repo"
@ -294,7 +298,6 @@ test_shared_clone = intmpsharedclonerepo $ do
, "--get"
, "annex.hardlink"
]
print v
v == Just "true\n"
@? "shared clone of repo did not get annex.hardlink set"
@ -534,10 +537,13 @@ test_lock = intmpclonerepoInDirect $ do
annexed_notpresent annexedfile
-- regression test: unlock of newly added, not committed file
-- should fail
-- should fail in v5 mode. In v6 mode, this is allowed.
writeFile "newfile" "foo"
git_annex "add" ["newfile"] @? "add new file failed"
not <$> git_annex "unlock" ["newfile"] @? "unlock failed to fail on newly added, never committed file"
ifM (annexeval Annex.Version.versionSupportsUnlockedPointers)
( git_annex "unlock" ["newfile"] @? "unlock failed on newly added, never committed file in v6 repository"
, not <$> git_annex "unlock" ["newfile"] @? "unlock failed to fail on newly added, never committed file in v5 repository"
)
git_annex "get" [annexedfile] @? "get of file failed"
annexed_present annexedfile
@ -549,12 +555,21 @@ test_lock = intmpclonerepoInDirect $ do
writeFile annexedfile $ content annexedfile ++ "foo"
not <$> git_annex "lock" [annexedfile] @? "lock failed to fail without --force"
git_annex "lock" ["--force", annexedfile] @? "lock --force failed"
-- In v6 mode, the original content of the file is not always
-- preserved after modification, so re-get it.
git_annex "get" [annexedfile] @? "get of file failed after lock --force"
annexed_present annexedfile
git_annex "unlock" [annexedfile] @? "unlock failed"
unannexed annexedfile
changecontent annexedfile
git_annex "add" [annexedfile] @? "add of modified file failed"
runchecks [checklink, checkunwritable] annexedfile
ifM (annexeval Annex.Version.versionSupportsUnlockedPointers)
( do
boolSystem "git" [Param "add", Param annexedfile] @? "add of modified file failed"
runchecks [checkregularfile, checkwritable] annexedfile
, do
git_annex "add" [annexedfile] @? "add of modified file failed"
runchecks [checklink, checkunwritable] annexedfile
)
c <- readFile annexedfile
assertEqual "content of modified file" c (changedcontent annexedfile)
r' <- git_annex "drop" [annexedfile]
@ -580,7 +595,10 @@ test_edit' precommit = intmpclonerepoInDirect $ do
@? "pre-commit failed"
else boolSystem "git" [Param "commit", Param "-q", Param "-m", Param "contentchanged"]
@? "git commit of edited file failed"
runchecks [checklink, checkunwritable] annexedfile
ifM (annexeval Annex.Version.versionSupportsUnlockedPointers)
( runchecks [checkregularfile, checkwritable] annexedfile
, runchecks [checklink, checkunwritable] annexedfile
)
c <- readFile annexedfile
assertEqual "content of modified file" c (changedcontent annexedfile)
not <$> git_annex "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of modified file"
@ -590,8 +608,12 @@ test_partial_commit = intmpclonerepoInDirect $ do
git_annex "get" [annexedfile] @? "get of file failed"
annexed_present annexedfile
git_annex "unlock" [annexedfile] @? "unlock failed"
not <$> boolSystem "git" [Param "commit", Param "-q", Param "-m", Param "test", File annexedfile]
@? "partial commit of unlocked file not blocked by pre-commit hook"
ifM (annexeval Annex.Version.versionSupportsUnlockedPointers)
( boolSystem "git" [Param "commit", Param "-q", Param "-m", Param "test", File annexedfile]
@? "partial commit of unlocked file should be allowed in v6 repository"
, not <$> boolSystem "git" [Param "commit", Param "-q", Param "-m", Param "test", File annexedfile]
@? "partial commit of unlocked file not blocked by pre-commit hook"
)
test_fix :: Assertion
test_fix = intmpclonerepoInDirect $ do
@ -617,9 +639,13 @@ test_direct :: Assertion
test_direct = intmpclonerepoInDirect $ do
git_annex "get" [annexedfile] @? "get of file failed"
annexed_present annexedfile
git_annex "direct" [] @? "switch to direct mode failed"
annexed_present annexedfile
git_annex "indirect" [] @? "switch to indirect mode failed"
ifM (annexeval Annex.Version.versionSupportsUnlockedPointers)
( not <$> git_annex "direct" [] @? "switch to direct mode failed to fail in v6 repository"
, do
git_annex "direct" [] @? "switch to direct mode failed"
annexed_present annexedfile
git_annex "indirect" [] @? "switch to indirect mode failed"
)
test_trust :: Assertion
test_trust = intmpclonerepo $ do
@ -810,7 +836,7 @@ test_unused = intmpclonerepoInDirect $ do
assertEqual ("unused keys differ " ++ desc)
(sort expectedkeys) (sort unusedkeys)
findkey f = do
r <- Backend.lookupFile f
r <- Annex.WorkTree.lookupFile f
return $ fromJust r
test_describe :: Assertion
@ -1056,8 +1082,9 @@ test_nonannexed_file_conflict_resolution :: Assertion
test_nonannexed_file_conflict_resolution = do
check True False
check False False
check True True
check False True
whenM (annexeval Annex.Version.versionSupportsDirectMode) $ do
check True True
check False True
where
check inr1 switchdirect = withtmpclonerepo $ \r1 ->
withtmpclonerepo $ \r2 ->
@ -1106,8 +1133,9 @@ test_nonannexed_symlink_conflict_resolution :: Assertion
test_nonannexed_symlink_conflict_resolution = do
check True False
check False False
check True True
check False True
whenM (annexeval Annex.Version.versionSupportsDirectMode) $ do
check True True
check False True
where
check inr1 switchdirect = withtmpclonerepo $ \r1 ->
withtmpclonerepo $ \r2 ->
@ -1380,7 +1408,7 @@ test_crypto = do
(c,k) <- annexeval $ do
uuid <- Remote.nameToUUID "foo"
rs <- Logs.Remote.readRemoteLog
Just k <- Backend.lookupFile annexedfile
Just k <- Annex.WorkTree.lookupFile annexedfile
return (fromJust $ M.lookup uuid rs, k)
let key = if scheme `elem` ["hybrid","pubkey"]
then Just $ Utility.Gpg.KeyIds [Utility.Gpg.testKeyId]
@ -1505,7 +1533,7 @@ intmpclonerepoInDirect a = intmpclonerepo $
)
where
isdirect = annexeval $ do
Annex.Init.initialize Nothing
Annex.Init.initialize Nothing Nothing
Config.isDirect
checkRepo :: Types.Annex a -> FilePath -> IO a
@ -1584,11 +1612,14 @@ clonerepo old new cfg = do
]
boolSystem "git" cloneparams @? "git clone failed"
configrepo new
indir new $
git_annex "init" ["-q", new] @? "git annex init failed"
indir new $ do
ver <- annexVersion <$> getTestMode
if ver == Annex.Version.defaultVersion
then git_annex "init" ["-q", new] @? "git annex init failed"
else git_annex "init" ["-q", new, "--version", ver] @? "git annex init failed"
unless (bareClone cfg) $
indir new $
handleforcedirect
setupTestMode
return new
configrepo :: FilePath -> IO ()
@ -1599,10 +1630,6 @@ configrepo dir = indir dir $ do
-- avoid signed commits by test suite
boolSystem "git" [Param "config", Param "commit.gpgsign", Param "false"] @? "git config failed"
handleforcedirect :: IO ()
handleforcedirect = whenM ((==) "1" <$> Utility.Env.getEnvDefault "FORCEDIRECT" "") $
git_annex "direct" ["-q"] @? "git annex direct failed"
ensuretmpdir :: IO ()
ensuretmpdir = do
e <- doesDirectoryExist tmpdir
@ -1666,10 +1693,10 @@ checkunwritable f = unlessM (annexeval Config.isDirect) $ do
checkwritable :: FilePath -> Assertion
checkwritable f = do
r <- tryIO $ writeFile f $ content f
case r of
Left _ -> assertFailure $ "unable to modify " ++ f
Right _ -> return ()
s <- getFileStatus f
let mode = fileMode s
unless (mode == mode `unionFileModes` ownerWriteMode) $
assertFailure $ "unable to modify " ++ f
checkdangling :: FilePath -> Assertion
checkdangling f = ifM (annexeval Config.crippledFileSystem)
@ -1684,7 +1711,7 @@ checkdangling f = ifM (annexeval Config.crippledFileSystem)
checklocationlog :: FilePath -> Bool -> Assertion
checklocationlog f expected = do
thisuuid <- annexeval Annex.UUID.getUUID
r <- annexeval $ Backend.lookupFile f
r <- annexeval $ Annex.WorkTree.lookupFile f
case r of
Just k -> do
uuids <- annexeval $ Remote.keyLocations k
@ -1695,7 +1722,7 @@ checklocationlog f expected = do
checkbackend :: FilePath -> Types.Backend -> Assertion
checkbackend file expected = do
b <- annexeval $ maybe (return Nothing) (Backend.getBackend file)
=<< Backend.lookupFile file
=<< Annex.WorkTree.lookupFile file
assertEqual ("backend for " ++ file) (Just expected) b
inlocationlog :: FilePath -> Assertion
@ -1721,11 +1748,16 @@ annexed_present = runchecks
unannexed :: FilePath -> Assertion
unannexed = runchecks [checkregularfile, checkcontent, checkwritable]
withTestEnv :: Bool -> TestTree -> TestTree
withTestEnv forcedirect = withResource prepare release . const
data TestMode = TestMode
{ forceDirect :: Bool
, annexVersion :: String
} deriving (Read, Show)
withTestMode :: TestMode -> TestTree -> TestTree
withTestMode testmode = withResource prepare release . const
where
prepare = do
setTestEnv forcedirect
setTestMode testmode
case tryIngredients [consoleTestReporter] mempty initTests of
Nothing -> error "No tests found!?"
Just act -> unlessM act $
@ -1733,8 +1765,8 @@ withTestEnv forcedirect = withResource prepare release . const
return ()
release _ = cleanup' True tmpdir
setTestEnv :: Bool -> IO ()
setTestEnv forcedirect = do
setTestMode :: TestMode -> IO ()
setTestMode testmode = do
whenM (doesDirectoryExist tmpdir) $
error $ "The temporary directory " ++ tmpdir ++ " already exists; cannot run test suite."
@ -1754,9 +1786,24 @@ setTestEnv forcedirect = do
, ("GIT_COMMITTER_NAME", "git-annex test")
-- force gpg into batch mode for the tests
, ("GPG_BATCH", "1")
, ("FORCEDIRECT", if forcedirect then "1" else "")
, ("TESTMODE", show testmode)
]
getTestMode :: IO TestMode
getTestMode = Prelude.read <$> Utility.Env.getEnvDefault "TESTMODE" ""
setupTestMode :: IO ()
setupTestMode = do
testmode <- getTestMode
when (forceDirect testmode) $
git_annex "direct" ["-q"] @? "git annex direct failed"
whenM (annexeval Annex.Version.versionSupportsUnlockedPointers) $
boolSystem "git"
[ Param "config"
, Param "annex.largefiles"
, Param ("exclude=" ++ ingitfile)
] @? "git config annex.largefiles failed"
changeToTmpDir :: FilePath -> IO ()
changeToTmpDir t = do
topdir <- Utility.Env.getEnvDefault "TOPDIR" (error "TOPDIR not set")
@ -1791,7 +1838,7 @@ sha1annexedfiledup :: String
sha1annexedfiledup = "sha1foodup"
ingitfile :: String
ingitfile = "bar"
ingitfile = "bar.c"
content :: FilePath -> String
content f

View file

@ -9,7 +9,7 @@ module Types.KeySource where
import Utility.InodeCache
{- When content is in the process of being added to the annex,
{- When content is in the process of being ingested into the annex,
- and a Key generated from it, this data type is used.
-
- The contentLocation may be different from the filename
@ -19,7 +19,7 @@ import Utility.InodeCache
- of a different Key.
-
- The inodeCache can be used to detect some types of modifications to
- files that may be made while they're in the process of being added.
- files that may be made while they're in the process of being ingested.
-}
data KeySource = KeySource
{ keyFilename :: FilePath

View file

@ -18,13 +18,14 @@ import qualified Upgrade.V1
import qualified Upgrade.V2
import qualified Upgrade.V3
import qualified Upgrade.V4
import qualified Upgrade.V5
checkUpgrade :: Version -> Annex ()
checkUpgrade = maybe noop error <=< needsUpgrade
needsUpgrade :: Version -> Annex (Maybe String)
needsUpgrade v
| v == supportedVersion = ok
| v `elem` supportedVersions = ok
| v `elem` autoUpgradeableVersions = ifM (upgrade True)
( ok
, err "Automatic upgrade failed!"
@ -40,7 +41,7 @@ upgrade :: Bool -> Annex Bool
upgrade automatic = do
upgraded <- go =<< getVersion
when upgraded $
setVersion supportedVersion
setVersion latestVersion
return upgraded
where
#ifndef mingw32_HOST_OS
@ -53,4 +54,5 @@ upgrade automatic = do
go (Just "2") = Upgrade.V2.upgrade
go (Just "3") = Upgrade.V3.upgrade automatic
go (Just "4") = Upgrade.V4.upgrade automatic
go (Just "5") = Upgrade.V5.upgrade automatic
go _ = return True

View file

@ -54,14 +54,14 @@ upgrade = do
ifM (fromRepo Git.repoIsLocalBare)
( do
moveContent
setVersion supportedVersion
setVersion latestVersion
, do
moveContent
updateSymlinks
moveLocationLogs
Annex.Queue.flush
setVersion supportedVersion
setVersion latestVersion
)
Upgrade.V2.upgrade

104
Upgrade/V5.hs Normal file
View file

@ -0,0 +1,104 @@
{- git-annex v5 -> v6 upgrade support
-
- Copyright 2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Upgrade.V5 where
import Common.Annex
import Config
import Annex.InodeSentinal
import Annex.Link
import Annex.Direct
import Annex.Content
import Annex.WorkTree
import qualified Database.Keys
import qualified Annex.Content.Direct as Direct
import qualified Git
import qualified Git.LsFiles
import qualified Git.Branch
import Git.FileMode
import Utility.InodeCache
upgrade :: Bool -> Annex Bool
upgrade automatic = do
unless automatic $
showAction "v5 to v6"
whenM isDirect $ do
{- Since upgrade from direct mode changes how files
- are represented in git, commit any changes in the
- work tree first. -}
whenM stageDirect $ do
unless automatic $
showAction "committing first"
upgradeDirectCommit automatic
"commit before upgrade to annex.version 6"
setDirect False
upgradeDirectWorkTree
removeDirectCruft
showLongNote "Upgraded repository out of direct mode."
showLongNote "Changes have been staged for all annexed files in this repository; you should run `git commit` to commit these changes."
showLongNote "Any other clones of this repository that use direct mode need to be upgraded now, too."
configureSmudgeFilter
-- Inode sentinal file was only used in direct mode and when
-- locking down files as they were added. In v6, it's used more
-- extensively, so make sure it exists, since old repos that didn't
-- use direct mode may not have created it.
unlessM (isDirect) $
createInodeSentinalFile True
return True
upgradeDirectCommit :: Bool -> String -> Annex ()
upgradeDirectCommit automatic msg =
void $ inRepo $ Git.Branch.commitCommand commitmode
[ Param "-m"
, Param msg
]
where
commitmode = if automatic then Git.Branch.AutomaticCommit else Git.Branch.ManualCommit
{- Walk work tree from top and convert all annex symlinks to pointer files,
- staging them in the index, and updating the work tree files with
- either the content of the object, or the pointer file content. -}
upgradeDirectWorkTree :: Annex ()
upgradeDirectWorkTree = do
top <- fromRepo Git.repoPath
(l, clean) <- inRepo $ Git.LsFiles.stagedDetails [top]
forM_ l go
void $ liftIO clean
where
go (f, Just _sha, Just mode) | isSymLink mode = do
mk <- lookupFile f
case mk of
Nothing -> noop
Just k -> do
ifM (isJust <$> getAnnexLinkTarget f)
( writepointer f k
, fromdirect f k
)
stagePointerFile f =<< hashPointerFile k
Database.Keys.addAssociatedFile k f
return ()
go _ = noop
fromdirect f k = do
-- If linkAnnex fails for some reason, the work tree file
-- still has the content; the annex object file is just
-- not populated with it. Since the work tree file
-- is recorded as an associated file, things will still
-- work that way, it's just not ideal.
ic <- withTSDelta (liftIO . genInodeCache f)
void $ linkAnnex k f ic
writepointer f k = liftIO $ do
nukeFile f
writeFile f (formatPointer k)
{- Remove all direct mode bookkeeping files. -}
removeDirectCruft :: Annex ()
removeDirectCruft = mapM_ go =<< getKeysPresent InAnywhere
where
go k = do
Direct.removeInodeCache k
Direct.removeAssociatedFiles k

View file

@ -19,6 +19,7 @@ module Utility.FileSystemEncoding (
encodeW8NUL,
decodeW8NUL,
truncateFilePath,
setConsoleEncoding,
) where
import qualified GHC.Foreign as GHC
@ -164,3 +165,10 @@ truncateFilePath n = reverse . go [] n . L8.fromString
else go (c:coll) (cnt - x') (L8.drop 1 bs)
_ -> coll
#endif
{- This avoids ghc's output layer crashing on invalid encoded characters in
- filenames when printing them out. -}
setConsoleEncoding :: IO ()
setConsoleEncoding = do
fileEncoding stdout
fileEncoding stderr

View file

@ -1,7 +1,7 @@
{- Caching a file's inode, size, and modification time
- to see when it's changed.
-
- Copyright 2013, 2014 Joey Hess <id@joeyh.name>
- Copyright 2013-2014 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}

21
debian/changelog vendored
View file

@ -1,3 +1,24 @@
git-annex (6.20151225) unstable; urgency=medium
* Added v6 repository mode, but v5 is still the default for now.
* The upgrade to version 6 is not done fully automatically, because
upgrading a direct mode repository to version 6 will prevent old
versions of git-annex from working in other clones of that repository.
* init: --version parameter added to control which supported repository
version to use.
* smudge: New command, used for git smudge filter.
This will replace direct mode.
* init, upgrade: Configure .git/info/attributes to use git-annex as a smudge
filter. Note that this changes the default behavior of git add in a
newly initialized repository; it will add files to the annex.
* unlock, lock: In v6 mode, unlocking a file changes it from a symlink to a
pointer file, and this change can be committed to the git repository.
* add: In v6 mode, adds modified files to the annex.
* assistant: In v6 mode, adds files in unlocked mode, so they can
continue to be modified.
-- Joey Hess <id@joeyh.name> Tue, 08 Dec 2015 11:14:03 -0400
git-annex (5.20151219) UNRELEASED; urgency=medium
* status: On crippled filesystems, was displaying M for all annexed files

View file

@ -9,6 +9,13 @@ understand how to update its working tree.
[[!toc]]
## deprecated
Direct mode is deprecated! Intead, git-annex v6 repositories can simply
have files that are unlocked and thus can be directly accessed and
modified. See [[upgrades]] for details about the transition to v6
repositories.
## enabling (and disabling) direct mode
Normally, git-annex repositories start off in indirect mode. With some

View file

@ -11,12 +11,18 @@ git annex add `[path ...]`
Adds files in the path to the annex. If no path is specified, adds
files from the current directory and below.
Normally, files that are already checked into git, or that git has been
configured to ignore will be silently skipped.
Files that are already checked into git and are unmodified, or that
git has been configured to ignore will be silently skipped.
If annex.largefiles is configured, and does not match a file that is being
added, `git annex add` will behave the same as `git add` and add the
non-large file directly to the git repository, instead of to the annex.
If annex.largefiles is configured, and does not match a file, `git annex
add` will behave the same as `git add` and add the non-large file directly
to the git repository, instead of to the annex.
Large files are added to the annex in locked form, which prevents further
modification of their content unless unlocked by [[git-annex-unlock]](1).
(This is not the case however when a repository is in direct mode.)
To add a file to the annex in unlocked form, `git add` can be used instead
(that only works when the repository has annex.version 6 or higher).
This command can also be used to add symbolic links, both symlinks to
annexed content, and other symlinks.

View file

@ -17,12 +17,18 @@ Note that git commands that operate on the work tree will refuse to
run in direct mode repositories. Use `git annex proxy` to safely run such
commands.
Note that the direct mode/indirect mode distinction is removed in v6
git-annex repositories. In such a repository, you can
use [[git-annex-unlock]](1) to make a file's content be directly present.
# SEE ALSO
[[git-annex]](1)
[[git-annex-indirect]](1)
[[git-annex-unlock]](1)
# AUTHOR
Joey Hess <id@joeyh.name>

View file

@ -11,9 +11,8 @@ git annex indirect
Switches a repository back from direct mode to the default, indirect
mode.
Some systems cannot support git-annex in indirect mode, because they
do not support symbolic links. Repositories on such systems instead
default to using direct mode.
Note that the direct mode/indirect mode distinction is removed in v6
git-annex repositories.
# SEE ALSO

View file

@ -24,6 +24,13 @@ mark it as dead (see [[git-annex-dead]](1)).
This command is entirely safe, although usually pointless, to run inside an
already initialized git-annex repository.
# OPTIONS
* `--version=N`
Force the repository to be initialized using a different annex.version
than the current default.
# SEE ALSO
[[git-annex]](1)

View file

@ -9,7 +9,7 @@ git annex lock `[path ...]`
# DESCRIPTION
Use this to undo an unlock command if you don't want to modify
the files, or have made modifications you want to discard.
the files any longer, or have made modifications you want to discard.
# OPTIONS

View file

@ -12,10 +12,14 @@ This is meant to be called from git's pre-commit hook. `git annex init`
automatically creates a pre-commit hook using this.
Fixes up symlinks that are staged as part of a commit, to ensure they
point to annexed content. Also handles injecting changes to unlocked
files into the annex. When in a view, updates metadata to reflect changes
point to annexed content.
When in a view, updates metadata to reflect changes
made to files in the view.
When in a repository that has not been upgraded to annex.version 6,
also handles injecting changes to unlocked files into the annex.
# SEE ALSO
[[git-annex]](1)

43
doc/git-annex-smudge.mdwn Normal file
View file

@ -0,0 +1,43 @@
# NAME
git-annex smudge - git filter driver for git-annex
# SYNOPSIS
git annex smudge [--clean] file
# DESCRIPTION
This command lets git-annex be used as a git filter driver which lets
annexed files in the git repository to be unlocked at all times, instead
of being symlinks.
When adding a file with `git add`, the annex.largefiles config is
consulted to decide if a given file should be added to git as-is,
or if its content are large enough to need to use git-annex.
The git configuration to use this command as a filter driver is as follows.
This is normally set up for you by git-annex init, so you should
not need to configure it manually.
[filter "annex"]
smudge = git-annex smudge %f
clean = git-annex smudge --clean %f
To make git use that filter driver, it needs to be configured in
the .gitattributes file or in `.git/config/attributes`. The latter
is normally configured when a repository is initialized, with the following
contents:
* filter=annex
.* !filter
# SEE ALSO
[[git-annex]](1)
# AUTHOR
Joey Hess <id@joeyh.name>
Warning: Automatically converted into a man page by mdwn2man. Edit with care.

View file

@ -11,8 +11,16 @@ git annex unlock `[path ...]`
Normally, the content of annexed files is protected from being changed.
Unlocking an annexed file allows it to be modified. This replaces the
symlink for each specified file with a copy of the file's content.
You can then modify it and `git annex add` (or `git commit`) to inject
it back into the annex.
You can then modify it and `git annex add` (or `git commit`) to save your
changes.
In repositories with annex.version 5 or earlier, unlocking a file is local
to the repository, and is temporary. With version 6, unlocking a file
changes how it is stored in the git repository (from a symlink to a pointer
file), so you can commit it like any other change. Also in version 6, you
can use `git add` to add a fie to the annex in unlocked form. This allows
workflows where a file starts out unlocked, is modified as necessary, and
is locked once it reaches its final version.
# OPTIONS

View file

@ -626,6 +626,14 @@ subdirectories).
See [[git-annex-diffdriver]](1) for details.
* `smudge`
This command lets git-annex be used as a git filter driver, allowing
annexed files in the git repository to be unlocked at all times, instead
of being symlinks.
See [[git-annex-smudge]](1) for details.
* `remotedaemon`
Detects when network remotes have received git pushes and fetches from them.

View file

@ -158,7 +158,8 @@ Using git-annex on a crippled filesystem that does not support symlinks.
Data:
* An annex pointer file has as its first line the git-annex key
that it's standing in for. Subsequent lines of the file might
that it's standing in for (prefixed with "annex/objects/", similar to
an annex symlink target). Subsequent lines of the file might
be a message saying that the file's content is not currently available.
An annex pointer file is checked into the git repository the same way
that an annex symlink is checked in.
@ -177,8 +178,8 @@ Configuration:
the annex. Other files are passed through the smudge/clean as-is and
have their contents stored in git.
* annex.direct is repurposed to configure how the assistant adds files.
When set to true, they're added unlocked.
* annex.direct is repurposed to configure how git-annex adds files.
When set to false, it adds symlinks and when true it adds pointer files.
git-annex clean:
@ -232,15 +233,11 @@ git annex lock/unlock:
transition repositories to using pointers, and a cleaner unlock/lock
for repos using symlinks.
unlock will stage a pointer file, and will copy the content of the object
out of .git/annex/objects to the work tree file. (Might want a --hardlink
switch.)
unlock will stage a pointer file, and will link the content of the object
from .git/annex/objects to the work tree file.
lock will replace the current work tree file with the symlink, and stage it.
Note that multiple work tree files could point to the same object.
So, if the link count is > 1, replace the annex object with a copy of
itself to break such a hard link. Always finish by locking down the
permissions of the annex object.
lock will replace the current work tree file with the symlink, and stage it,
and lock down the permissions of the annex object.
#### file map
@ -248,7 +245,8 @@ The file map needs to map from `Key -> [File]`. `File -> Key`
seems useful to have, but in practice is not worthwhile.
Drop and get operations need to know what files in the work tree use a
given key in order to update the work tree.
given key in order to update the work tree. And, we don't want to
overwrite a work tree file if it's been modified when dropping or getting.
git-annex commands that look at annex symlinks to get keys to act on will
need fall back to either consulting the file map, or looking at the staged
@ -275,13 +273,14 @@ In particular:
* Is the smudge filter called at any other time? Seems unlikely but then
there could be situations with a detached work tree or such.
* Does git call any useful hooks when removing a file from the work tree,
or converting it to not be annexed?
or converting it to not be annexed, or for `git mv` of an annexed file?
No!
From this analysis, any file map generated by the smudge/clean filters
is necessary potentially innaccurate. It may list deleted files.
It may or may not reflect current unstaged changes from the work tree.
Follows that any use of the file map needs to verify the info from it,
and throw out bad cached info (updating the map to match reality).
@ -306,17 +305,71 @@ just look at the repo content in the first place..
annex.version changes to 6
Upgrade should be handled automatically.
git config for filter.annex.smudge and filter.annex.clean is set up.
On upgrade, update .gitattributes with a stock configuration, unless
it already mentions "filter=annex".
.gitattributes is updated with a stock configuration,
unless it already mentions "filter=annex".
Upgrading a direct mode repo needs to switch it out of bare mode, and
needs to run `git annex unlock` on all files (or reach the same result).
So will need to stage changes to all annexed files.
When a repo has some clones indirect and some direct, the upgraded repo
will have all files unlocked, necessarily in all clones.
will have all files unlocked, necessarily in all clones. This happens
automatically, because when the direct repos are upgraded that causes the
files to be unlocked, while the indirect upgrades don't touch the files.
#### implementation todo list
* Still a few test suite failues for v6 with locked files.
* Test suite should make pass for v6 with unlocked files.
* Reconcile staged changes into the associated files database, whenever
the database is queried. This is needed to handle eg:
git add largefile
git mv largefile othername
git annex move othername --to foo
# fails to drop content from associated file othername,
# because it doesn't know it has that name
# git commit clears up this mess
* Interaction with shared clones. Should avoid hard linking from/to a
object in a shared clone if either repository has the object unlocked.
(And should avoid unlocking an object if it's hard linked to a shared clone,
but that's already accomplished because it avoids unlocking an object if
it's hard linked at all)
* Make automatic merge conflict resolution work for pointer files.
- Should probably automatically handle merge conflicts between annex
symlinks and pointer files too. Maybe by always resulting in a pointer
file, since the symlinks don't work everwhere.
* Crippled filesystem should cause all files to be transparently unlocked.
Note that this presents problems when dealing with merge conflicts and
when pushing changes committed in such a repo. Ideally, should avoid
committing implicit unlocks, or should prevent such commits leaking out
in pushes.
* Dropping a smudged file causes git status (and git annex status)
to show it as modified, because the timestamp has changed.
Getting a smudged file can also cause this.
Upgrading a direct mode repo also leaves files in this state.
User can use `git add` to clear it up, but better to avoid this,
by updating stat info in the index.
(May need to use libgit2 to do this, cannot find
any plumbing except git-update-index, which is very inneficient for
smudged files.)
* Audit code for all uses of isDirect. These places almost always need
adjusting to support v6, if they haven't already.
* Optimisation: See if the database schema can be improved to speed things
up. Are there enough indexes? getAssociatedKey in particular does a
reverse lookup and might benefit from an index.
* Optimisation: Reads from the Keys database avoid doing anything if the
database doesn't exist. This makes v5 repos, or v6 with all locked files
faster. However, if a v6 repo unlocks and then re-locks a file, its
database will exist, and so this optimisation will no longer apply.
Could try to detect when the database is empty, and remove it or avoid reads.
* Eventually (but not yet), make v6 the default for new repositories.
Note that the assistant forces repos into direct mode; that will need to
be changed then.
* Later still, remove support for direct mode, and enable automatic
v5 to v6 upgrades.
----

View file

@ -43,6 +43,46 @@ conflicts first before upgrading git-annex.
The upgrade events, so far:
## v5 -> v6 (git-annex version 6.x)
The upgrade from v5 to v6 is handled manually. Run `git-annex upgrade`
perform the upgrade.
Warning: All places that a direct mode repository is cloned to should be
running git-annex version 6.x before you upgrade the repository.
This is necessary because the contents of the repository are changed
in the upgrade, and the old version of git-annex won't be able to
access files after the repo is upgraded.
This upgrade does away with the direct mode/indirect mode distinction.
A v6 git-annex repository can have some files locked and other files
unlocked, and all git and git-annex commands can be used on both locked and
unlocked files. (Although for locked files to work, the filesystem
must support symbolic links..)
The behavior of some commands changes in an upgraded repository:
* `git add` will add files to the annex, in unlocked mode, rather than
adding them directly to the git repository. To cause some files to be
added directly to git, you can configure `annex.largefiles`. For
example:
git config annex.largefiles "largerthan=100kb and not (include=*.c or include=*.h)"
* `git annex unlock` and `git annex lock` change how the pointer to
the annexed content is stored in git.
If a repository is only used in indirect mode, you can use git-annex
v5 and v6 in different clones of the same indirect mode repository without
problems.
On upgrade, all files in a direct mode repository will be converted to
unlocked files. The upgrade will stage changes to all annexed files in
the git repository, which you can then commit.
If a repository has some clones using direct mode and some using indirect
mode, all the files will end up unlocked in all clones after the upgrade.
## v4 -> v5 (git-annex version 5.x)
The upgrade from v4 to v5 is handled