diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs index 074e955d7c..e6f2be552f 100644 --- a/Annex/AutoMerge.hs +++ b/Annex/AutoMerge.hs @@ -23,7 +23,7 @@ import qualified Git.Merge import qualified Git.Ref import qualified Git import qualified Git.Branch -import Git.Types (BlobType(..)) +import Git.Types (BlobType(..), fromBlobType) import Git.FilePath import Config import Annex.ReplaceFile @@ -31,6 +31,7 @@ import Annex.VariantFile import qualified Database.Keys import Annex.InodeSentinal import Utility.InodeCache +import Utility.FileMode import qualified Data.Set as S import qualified Data.Map as M @@ -152,12 +153,12 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do -- In either case, keep original filename. if islocked LsFiles.valUs && islocked LsFiles.valThem then makesymlink keyUs file - else makepointer keyUs file + else makepointer keyUs file (combinedmodes) return ([keyUs, keyThem], Just file) -- Our side is annexed file, other side is not. (Just keyUs, Nothing) -> resolveby [keyUs] $ do graftin them file LsFiles.valThem LsFiles.valThem LsFiles.valUs - makeannexlink keyUs LsFiles.valUs + makeannexlink keyUs LsFiles.valUs -- Our side is not annexed file, other side is. (Nothing, Just keyThem) -> resolveby [keyThem] $ do graftin us file LsFiles.valUs LsFiles.valUs LsFiles.valThem @@ -174,11 +175,19 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do islocked select = select (LsFiles.unmergedBlobType u) == Just SymlinkBlob + combinedmodes = case catMaybes [ourmode, theirmode] of + [] -> Nothing + l -> Just (combineModes l) + where + ourmode = fromBlobType <$> LsFiles.valUs (LsFiles.unmergedBlobType u) + theirmode = fromBlobType <$> LsFiles.valThem (LsFiles.unmergedBlobType u) + makeannexlink key select | islocked select = makesymlink key dest - | otherwise = makepointer key dest + | otherwise = makepointer key dest destmode where dest = variantFile file key + destmode = fromBlobType <$> select (LsFiles.unmergedBlobType u) stagefile :: FilePath -> Annex FilePath stagefile f @@ -194,16 +203,16 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do replacewithsymlink dest link = withworktree dest $ \f -> replaceFile f $ makeGitLink link - makepointer key dest = do + makepointer key dest destmode = do unless inoverlay $ unlessM (reuseOldFile unstagedmap key file dest) $ do - r <- linkFromAnnex key dest + r <- linkFromAnnex key dest destmode case r of LinkAnnexFailed -> liftIO $ - writeFile dest (formatPointer key) + writePointerFile dest key destmode _ -> noop dest' <- stagefile dest - stagePointerFile dest' =<< hashPointerFile key + stagePointerFile dest' destmode =<< hashPointerFile key unless inoverlay $ Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath dest) diff --git a/Annex/Content.hs b/Annex/Content.hs index a17098ad7a..c1d6031a7a 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -509,10 +509,11 @@ populatePointerFile :: Key -> FilePath -> FilePath -> Annex () populatePointerFile k obj f = go =<< liftIO (isPointerFile f) where go (Just k') | k == k' = do + destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f liftIO $ nukeFile f - ifM (linkOrCopy k obj f) + ifM (linkOrCopy k obj f destmode) ( thawContent f - , liftIO $ writeFile f (formatPointer k) + , liftIO $ writePointerFile f k destmode ) go _ = return () @@ -523,14 +524,14 @@ data LinkAnnexResult = LinkAnnexOk | LinkAnnexFailed | LinkAnnexNoop linkToAnnex :: Key -> FilePath -> Maybe InodeCache -> Annex LinkAnnexResult linkToAnnex key src srcic = do dest <- calcRepo (gitAnnexLocation key) - modifyContent dest $ linkAnnex To key src srcic dest + modifyContent dest $ linkAnnex To key src srcic dest Nothing {- Makes a destination file be a link or copy from the annex object. -} -linkFromAnnex :: Key -> FilePath -> Annex LinkAnnexResult -linkFromAnnex key dest = do +linkFromAnnex :: Key -> FilePath -> Maybe FileMode -> Annex LinkAnnexResult +linkFromAnnex key dest destmode = do src <- calcRepo (gitAnnexLocation key) srcic <- withTSDelta (liftIO . genInodeCache src) - linkAnnex From key src srcic dest + linkAnnex From key src srcic dest destmode data FromTo = From | To @@ -542,10 +543,12 @@ data FromTo = From | To - the annex object too. 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. + - + - Nothing is done if the destination file already exists. -} -linkAnnex :: FromTo -> Key -> FilePath -> Maybe InodeCache -> FilePath -> Annex LinkAnnexResult -linkAnnex _ _ _ Nothing _ = return LinkAnnexFailed -linkAnnex fromto key src (Just srcic) dest = do +linkAnnex :: FromTo -> Key -> FilePath -> Maybe InodeCache -> FilePath -> Maybe FileMode -> Annex LinkAnnexResult +linkAnnex _ _ _ Nothing _ _ = return LinkAnnexFailed +linkAnnex fromto key src (Just srcic) dest destmode = do mdestic <- withTSDelta (liftIO . genInodeCache dest) case mdestic of Just destic -> do @@ -554,7 +557,7 @@ linkAnnex fromto key src (Just srcic) dest = do then Database.Keys.addInodeCaches key [srcic, destic] else Database.Keys.addInodeCaches key [srcic] return LinkAnnexNoop - Nothing -> ifM (linkOrCopy key src dest) + Nothing -> ifM (linkOrCopy key src dest destmode) ( do thawContent $ case fromto of From -> dest @@ -578,27 +581,38 @@ linkAnnex fromto key src (Just srcic) dest = do liftIO $ nukeFile dest failed -{- Hard links or copies src to dest. Only uses a hard link when annex.thin - - is enabled and when src is not already hardlinked to elsewhere. +{- Hard links or copies src to dest, which must not already exists. + - + - Only uses a hard link when annex.thin is enabled and when src is + - not already hardlinked to elsewhere. + - - Checks disk reserve before copying against the size of the key, - - and will fail if not enough space, or if the dest file already exists. -} -linkOrCopy :: Key -> FilePath -> FilePath -> Annex Bool + - and will fail if not enough space, or if the dest file already exists. + - + - The FileMode, if provided, influences the mode of the dest file. + - In particular, if it has an execute bit set, the dest file's + - execute bit will be set. The mode is not fully copied over because + - git doesn't support file modes beyond execute. + -} +linkOrCopy :: Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool linkOrCopy = linkOrCopy' (annexThin <$> Annex.getGitConfig) -linkOrCopy' :: Annex Bool -> Key -> FilePath -> FilePath -> Annex Bool -linkOrCopy' canhardlink key src dest = catchBoolIO $ - ifM canhardlink - ( hardlink - , copy =<< getstat - ) +linkOrCopy' :: Annex Bool -> Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool +linkOrCopy' canhardlink key src dest destmode + | maybe False isExecutable destmode = copy =<< getstat + | otherwise = catchBoolIO $ + ifM canhardlink + ( hardlink + , copy =<< getstat + ) where hardlink = do s <- getstat if linkCount s > 1 then copy s - else liftIO (createLink src dest >> return True) + else liftIO (createLink src dest >> preserveGitMode dest destmode >> return True) `catchIO` const (copy s) - copy = checkedCopyFile' key src dest + copy = checkedCopyFile' key src dest destmode getstat = liftIO $ getFileStatus src {- Removes the annex object file for a key. Lowlevel. -} @@ -610,18 +624,30 @@ unlinkAnnex key = do liftIO $ nukeFile obj {- Checks disk space before copying. -} -checkedCopyFile :: Key -> FilePath -> FilePath -> Annex Bool -checkedCopyFile key src dest = catchBoolIO $ - checkedCopyFile' key src dest +checkedCopyFile :: Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool +checkedCopyFile key src dest destmode = catchBoolIO $ + checkedCopyFile' key src dest destmode =<< liftIO (getFileStatus src) -checkedCopyFile' :: Key -> FilePath -> FilePath -> FileStatus -> Annex Bool -checkedCopyFile' key src dest s = catchBoolIO $ +checkedCopyFile' :: Key -> FilePath -> FilePath -> Maybe FileMode -> FileStatus -> Annex Bool +checkedCopyFile' key src dest destmode s = catchBoolIO $ ifM (checkDiskSpace' (fromIntegral $ fileSize s) (Just $ takeDirectory dest) key 0 True) - ( liftIO $ copyFileExternal CopyAllMetaData src dest + ( liftIO $ + copyFileExternal CopyAllMetaData src dest + <&&> preserveGitMode dest destmode , return False ) +preserveGitMode :: FilePath -> Maybe FileMode -> IO Bool +preserveGitMode f (Just mode) + | isExecutable mode = catchBoolIO $ do + modifyFileMode f $ addModes executeModes + return True + | otherwise = catchBoolIO $ do + modifyFileMode f $ removeModes executeModes + return True +preserveGitMode _ _ = return True + {- Runs an action to transfer an object's content. - - In some cases, it's possible for the file to change as it's being sent. @@ -729,9 +755,10 @@ removeAnnex (ContentRemovalLock key) = withObjectLoc key remove removedirect Direct.removeInodeCache key resetpointer file = ifM (isUnmodified key file) ( do + mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file secureErase file liftIO $ nukeFile file - liftIO $ writeFile file (formatPointer key) + liftIO $ writePointerFile file key mode -- 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 diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs index 1bf1db146e..95bbff496c 100644 --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -130,7 +130,9 @@ ingestAdd ld@(Just (LockedDown cfg source)) = do ( do l <- calcRepo $ gitAnnexLink f k stageSymlink f =<< hashSymlink l - , stagePointerFile f =<< hashPointerFile k + , do + mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus (contentLocation source) + stagePointerFile f mode =<< hashPointerFile k ) return (Just k) @@ -344,15 +346,19 @@ cachedCurrentBranch = maybe cache (return . Just) addAnnexedFile :: FilePath -> Key -> Maybe FilePath -> Annex () addAnnexedFile file key mtmp = ifM (addUnlocked <&&> not <$> isDirect) ( do - stagePointerFile file =<< hashPointerFile key + mode <- maybe + (pure Nothing) + (\tmp -> liftIO $ catchMaybeIO $ fileMode <$> getFileStatus tmp) + mtmp + stagePointerFile file mode =<< hashPointerFile key Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file) case mtmp of Just tmp -> do moveAnnex key tmp - linkunlocked + linkunlocked mode Nothing -> ifM (inAnnex key) - ( linkunlocked - , writepointer + ( linkunlocked mode + , liftIO $ writePointerFile file key mode ) , do addLink file key Nothing @@ -368,9 +374,9 @@ addAnnexedFile file key mtmp = ifM (addUnlocked <&&> not <$> isDirect) Nothing -> return () ) where - writepointer = liftIO $ writeFile file (formatPointer key) - linkunlocked = do - r <- linkFromAnnex key file + linkunlocked mode = do + r <- linkFromAnnex key file mode case r of - LinkAnnexFailed -> writepointer + LinkAnnexFailed -> liftIO $ + writePointerFile file key mode _ -> return () diff --git a/Annex/Link.hs b/Annex/Link.hs index 44c5678370..af20ae30d6 100644 --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -23,6 +23,7 @@ import qualified Annex.Queue import Git.Types import Git.FilePath import Annex.HashObject +import Utility.FileMode import qualified Data.ByteString.Lazy as L import Data.Int @@ -118,10 +119,19 @@ hashPointerFile :: Key -> Annex Sha hashPointerFile key = hashBlob (formatPointer key) {- Stages a pointer file, using a Sha of its content -} -stagePointerFile :: FilePath -> Sha -> Annex () -stagePointerFile file sha = +stagePointerFile :: FilePath -> Maybe FileMode -> Sha -> Annex () +stagePointerFile file mode sha = Annex.Queue.addUpdateIndex =<< - inRepo (Git.UpdateIndex.stageFile sha FileBlob file) + inRepo (Git.UpdateIndex.stageFile sha blobtype file) + where + blobtype + | maybe False isExecutable mode = ExecutableBlob + | otherwise = FileBlob + +writePointerFile :: FilePath -> Key -> Maybe FileMode -> IO () +writePointerFile file k mode = do + writeFile file (formatPointer k) + maybe noop (setFileMode file) mode {- Parses a symlink target or a pointer file to a Key. - Only looks at the first line, as pointer files can have subsequent diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index 070699cb28..d35bd79a2a 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -378,7 +378,9 @@ handleAdds havelsof delayadd cs = returnWhen (null incomplete) $ do done change mcache file key = liftAnnex $ do logStatus key InfoPresent ifM versionSupportsUnlockedPointers - ( stagePointerFile file =<< hashPointerFile key + ( do + mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file + stagePointerFile file mode =<< hashPointerFile key , do link <- ifM isDirect ( calcRepo $ gitAnnexLink file key diff --git a/Command/Fix.hs b/Command/Fix.hs index d87bea3585..3a153c761d 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -67,7 +67,8 @@ start fixwhat file key = do breakHardLink :: FilePath -> Key -> FilePath -> CommandPerform breakHardLink file key obj = do replaceFile file $ \tmp -> do - unlessM (checkedCopyFile key obj tmp) $ + mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file + unlessM (checkedCopyFile key obj tmp mode) $ error "unable to break hard link" thawContent tmp modifyContent obj $ freezeContent obj @@ -77,7 +78,8 @@ breakHardLink file key obj = do makeHardLink :: FilePath -> Key -> CommandPerform makeHardLink file key = do replaceFile file $ \tmp -> do - r <- linkFromAnnex key tmp + mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file + r <- linkFromAnnex key tmp mode case r of LinkAnnexFailed -> error "unable to make hard link" _ -> noop diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 2e7579b5b3..81618600f0 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -301,12 +301,13 @@ verifyWorkTree key file = do case mk of Just k | k == key -> whenM (inAnnex key) $ do showNote "fixing worktree content" - replaceFile file $ \tmp -> + replaceFile file $ \tmp -> do + mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file ifM (annexThin <$> Annex.getGitConfig) - ( void $ linkFromAnnex key tmp + ( void $ linkFromAnnex key tmp mode , do obj <- calcRepo $ gitAnnexLocation key - void $ checkedCopyFile key obj tmp + void $ checkedCopyFile key obj tmp mode thawContent tmp ) Database.Keys.storeInodeCaches key [file] diff --git a/Command/Lock.hs b/Command/Lock.hs index f002f016ad..1cd50de7bb 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -78,7 +78,7 @@ performNew file key filemodified = do mfc <- withTSDelta (liftIO . genInodeCache file) unlessM (sameInodeCache obj (maybeToList mfc)) $ do modifyContent obj $ replaceFile obj $ \tmp -> do - unlessM (checkedCopyFile key obj tmp) $ + unlessM (checkedCopyFile key obj tmp Nothing) $ error "unable to lock file" Database.Keys.storeInodeCaches key [obj] @@ -92,7 +92,7 @@ performNew file key filemodified = do liftIO $ nukeFile obj case mfile of Just unmodified -> - unlessM (checkedCopyFile key unmodified obj) + unlessM (checkedCopyFile key unmodified obj Nothing) lostcontent Nothing -> lostcontent | otherwise = modifyContent obj $ diff --git a/Command/ReKey.hs b/Command/ReKey.hs index 79c588ccc6..4d20395307 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -61,7 +61,7 @@ linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file) - and vulnerable to corruption. -} ( getViaTmp' DefaultVerify newkey $ \tmp -> unVerified $ do oldobj <- calcRepo (gitAnnexLocation oldkey) - linkOrCopy' (return True) newkey oldobj tmp + linkOrCopy' (return True) newkey oldobj tmp Nothing , do ic <- withTSDelta (liftIO . genInodeCache file) {- The file being rekeyed is itself an unlocked file, so if @@ -69,7 +69,7 @@ linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file) oldobj <- calcRepo (gitAnnexLocation oldkey) v <- tryNonAsync $ modifyContent oldobj $ do replaceFile oldobj $ \tmp -> - unlessM (checkedCopyFile oldkey file tmp) $ + unlessM (checkedCopyFile oldkey file tmp Nothing) $ error "can't lock old key" freezeContent oldobj oldic <- withTSDelta (liftIO . genInodeCache oldobj) @@ -95,9 +95,10 @@ cleanup file oldkey newkey = do liftIO $ removeFile file addLink file newkey Nothing , do + mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file liftIO $ whenM (isJust <$> isPointerFile file) $ - writeFile file (formatPointer newkey) - stagePointerFile file =<< hashPointerFile newkey + writePointerFile file newkey mode + stagePointerFile file mode =<< hashPointerFile newkey Database.Keys.removeAssociatedFile oldkey =<< inRepo (toTopFilePath file) ) diff --git a/Command/Unlock.hs b/Command/Unlock.hs index ac99d5cd3a..2fe1175a8b 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -15,6 +15,7 @@ import Annex.Version import Annex.Link import Annex.ReplaceFile import Utility.CopyFile +import Utility.FileMode cmd :: Command cmd = mkcmd "unlock" "unlock files for modification" @@ -50,16 +51,17 @@ start file key = ifM (isJust <$> isAnnexLink file) performNew :: FilePath -> Key -> CommandPerform performNew dest key = do + destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus dest replaceFile dest $ \tmp -> do - r <- linkFromAnnex key tmp + r <- linkFromAnnex key tmp destmode case r of LinkAnnexOk -> return () _ -> error "unlock failed" - next $ cleanupNew dest key + next $ cleanupNew dest key destmode -cleanupNew :: FilePath -> Key -> CommandCleanup -cleanupNew dest key = do - stagePointerFile dest =<< hashPointerFile key +cleanupNew :: FilePath -> Key -> Maybe FileMode -> CommandCleanup +cleanupNew dest key destmode = do + stagePointerFile dest destmode =<< hashPointerFile key return True startOld :: FilePath -> Key -> CommandStart diff --git a/Upgrade/V5.hs b/Upgrade/V5.hs index 08e9271a0a..e5ca505ac0 100644 --- a/Upgrade/V5.hs +++ b/Upgrade/V5.hs @@ -99,7 +99,7 @@ upgradeDirectWorkTree = do ( writepointer f k , fromdirect f k ) - stagePointerFile f =<< hashPointerFile k + stagePointerFile f Nothing =<< hashPointerFile k Database.Keys.addAssociatedFile k =<< inRepo (toTopFilePath f) return () diff --git a/debian/changelog b/debian/changelog index aa1deb3e4f..e899ab6918 100644 --- a/debian/changelog +++ b/debian/changelog @@ -13,6 +13,7 @@ git-annex (6.20160413) UNRELEASED; urgency=medium * Fix bug in v6 mode that prevented treating unlocked executable files as annexed. If you have such files, run git annex init --version=6 to update the cache after upgrading to this version of git-annex. + * Preserve execute bits of unlocked files in v6 mode. -- Joey Hess Wed, 13 Apr 2016 13:30:32 -0400