e213ef310f
* Fix minor FD leak in journal code. Closes: #754608 * direct: Fix handling of case where a work tree subdirectory cannot be written to due to permissions. * migrate: Avoid re-checksumming when migrating from hashE to hash backend. * uninit: Avoid failing final removal in some direct mode repositories due to file modes. * S3: Deal with AWS ACL configurations that do not allow creating or checking the location of a bucket, but only reading and writing content to it. * resolvemerge: New plumbing command that runs the automatic merge conflict resolver. * Deal with change in git 2.0 that made indirect mode merge conflict resolution leave behind old files. * sync: Fix git sync with local git remotes even when they don't have an annex.uuid set. (The assistant already did so.) * Set gcrypt-publish-participants when setting up a gcrypt repository, to avoid unncessary passphrase prompts. This is a security/usability tradeoff. To avoid exposing the gpg key ids who can decrypt the repository, users can unset gcrypt-publish-participants. * Install nautilus hooks even when ~/.local/share/nautilus/ does not yet exist, since it is not automatically created for Gnome 3 users. * Windows: Move .vbs files out of git\bin, to avoid that being in the PATH, which caused some weird breakage. (Thanks, divB) * Windows: Fix locking issue that prevented the webapp starting (since 5.20140707). # imported from the archive
108 lines
3.2 KiB
Haskell
108 lines
3.2 KiB
Haskell
{- git-annex links to content
|
|
-
|
|
- On file systems that support them, symlinks are used.
|
|
-
|
|
- On other filesystems, git instead stores the symlink target in a regular
|
|
- file.
|
|
-
|
|
- Copyright 2013 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Annex.Link where
|
|
|
|
import Common.Annex
|
|
import qualified Annex
|
|
import qualified Git.HashObject
|
|
import qualified Git.UpdateIndex
|
|
import qualified Annex.Queue
|
|
import Git.Types
|
|
import Git.FilePath
|
|
|
|
type LinkTarget = String
|
|
|
|
{- Checks if a file is a link to a key. -}
|
|
isAnnexLink :: FilePath -> Annex (Maybe Key)
|
|
isAnnexLink file = maybe Nothing (fileKey . takeFileName) <$> getAnnexLinkTarget file
|
|
|
|
{- Gets the link target of a symlink.
|
|
-
|
|
- On a filesystem that does not support symlinks, fall back to getting the
|
|
- link target by looking inside the file.
|
|
-
|
|
- Returns Nothing if the file is not a symlink, or not a link to annex
|
|
- content.
|
|
-}
|
|
getAnnexLinkTarget :: FilePath -> Annex (Maybe LinkTarget)
|
|
getAnnexLinkTarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
|
|
( check readSymbolicLink $
|
|
return Nothing
|
|
, check readSymbolicLink $
|
|
check probefilecontent $
|
|
return Nothing
|
|
)
|
|
where
|
|
check getlinktarget fallback = do
|
|
v <- liftIO $ catchMaybeIO $ getlinktarget file
|
|
case v of
|
|
Just l
|
|
| isLinkToAnnex (fromInternalGitPath l) -> return v
|
|
| otherwise -> return Nothing
|
|
Nothing -> fallback
|
|
|
|
probefilecontent f = withFile f ReadMode $ \h -> do
|
|
fileEncoding h
|
|
-- The first 8k is more than enough to read; link
|
|
-- files are small.
|
|
s <- take 8192 <$> hGetContents h
|
|
-- If we got the full 8k, the file is too large
|
|
if length s == 8192
|
|
then return ""
|
|
else
|
|
-- If there are any NUL or newline
|
|
-- characters, or whitespace, we
|
|
-- certianly don't have a link to a
|
|
-- git-annex key.
|
|
return $ if any (`elem` s) "\0\n\r \t"
|
|
then ""
|
|
else s
|
|
|
|
makeAnnexLink :: LinkTarget -> FilePath -> Annex ()
|
|
makeAnnexLink = makeGitLink
|
|
|
|
{- Creates a link on disk.
|
|
-
|
|
- On a filesystem that does not support symlinks, writes the link target
|
|
- to a file. Note that git will only treat the file as a symlink if
|
|
- it's staged as such, so use addAnnexLink when adding a new file or
|
|
- modified link to git.
|
|
-}
|
|
makeGitLink :: LinkTarget -> FilePath -> Annex ()
|
|
makeGitLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
|
|
( liftIO $ do
|
|
void $ tryIO $ removeFile file
|
|
createSymbolicLink linktarget file
|
|
, liftIO $ writeFile file linktarget
|
|
)
|
|
|
|
{- Creates a link on disk, and additionally stages it in git. -}
|
|
addAnnexLink :: LinkTarget -> FilePath -> Annex ()
|
|
addAnnexLink linktarget file = do
|
|
makeAnnexLink linktarget file
|
|
stageSymlink file =<< hashSymlink linktarget
|
|
|
|
{- Injects a symlink target into git, returning its Sha. -}
|
|
hashSymlink :: LinkTarget -> Annex Sha
|
|
hashSymlink linktarget = inRepo $ Git.HashObject.hashObject BlobObject $
|
|
toInternalGitPath linktarget
|
|
|
|
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. -}
|
|
stageSymlink :: FilePath -> Sha -> Annex ()
|
|
stageSymlink file sha =
|
|
Annex.Queue.addUpdateIndex =<<
|
|
inRepo (Git.UpdateIndex.stageSymlink file sha)
|