aboutsummaryrefslogtreecommitdiff
path: root/Annex/Link.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2013-02-17 15:05:55 -0400
committerGravatar Joey Hess <joey@kitenet.net>2013-02-17 16:43:14 -0400
commit6d8b95d6bf0d7b5666efc02379fe55e8d02e1ebe (patch)
treeb93747a1bad6f2ca2456d4ac95d5cf177855f98d /Annex/Link.hs
parent898a39429f750bd05898df9a4b8dae371ddc9d68 (diff)
fully support core.symlinks=false in all relevant symlink handling code
Refactored annex link code into nice clean new library. Audited and dealt with calls to createSymbolicLink. Remaining calls are all safe, because: Annex/Link.hs: ( liftIO $ createSymbolicLink linktarget file only when core.symlinks=true Assistant/WebApp/Configurators/Local.hs: createSymbolicLink link link test if symlinks can be made Command/Fix.hs: liftIO $ createSymbolicLink link file command only works in indirect mode Command/FromKey.hs: liftIO $ createSymbolicLink link file command only works in indirect mode Command/Indirect.hs: liftIO $ createSymbolicLink l f refuses to run if core.symlinks=false Init.hs: createSymbolicLink f f2 test if symlinks can be made Remote/Directory.hs: go [file] = catchBoolIO $ createSymbolicLink file f >> return True fast key linking; catches failure to make symlink and falls back to copy Remote/Git.hs: liftIO $ catchBoolIO $ createSymbolicLink loc file >> return True ditto Upgrade/V1.hs: liftIO $ createSymbolicLink link f v1 repos could not be on a filesystem w/o symlinks Audited and dealt with calls to readSymbolicLink. Remaining calls are all safe, because: Annex/Link.hs: ( liftIO $ catchMaybeIO $ readSymbolicLink file only when core.symlinks=true Assistant/Threads/Watcher.hs: ifM ((==) (Just link) <$> liftIO (catchMaybeIO $ readSymbolicLink file)) code that fixes real symlinks when inotify sees them It's ok to not fix psdueo-symlinks. Assistant/Threads/Watcher.hs: mlink <- liftIO (catchMaybeIO $ readSymbolicLink file) ditto Command/Fix.hs: stopUnless ((/=) (Just link) <$> liftIO (catchMaybeIO $ readSymbolicLink file)) $ do command only works in indirect mode Upgrade/V1.hs: getsymlink = takeFileName <$> readSymbolicLink file v1 repos could not be on a filesystem w/o symlinks Audited and dealt with calls to isSymbolicLink. (Typically used with getSymbolicLinkStatus, but that is just used because getFileStatus is not as robust; it also works on pseudolinks.) Remaining calls are all safe, because: Assistant/Threads/SanityChecker.hs: | isSymbolicLink s -> addsymlink file ms only handles staging of symlinks that were somehow not staged (might need to be updated to support pseudolinks, but this is only a belt-and-suspenders check anyway, and I've never seen the code run) Command/Add.hs: if isSymbolicLink s || not (isRegularFile s) avoids adding symlinks to the annex, so not relevant Command/Indirect.hs: | isSymbolicLink s -> void $ flip whenAnnexed f $ only allowed on systems that support symlinks Command/Indirect.hs: whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do ditto Seek.hs:notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f used to find unlocked files, only relevant in indirect mode Utility/FSEvents.hs: | Files.isSymbolicLink s = runhook addSymlinkHook $ Just s Utility/FSEvents.hs: | Files.isSymbolicLink s -> Utility/INotify.hs: | Files.isSymbolicLink s -> Utility/INotify.hs: checkfiletype Files.isSymbolicLink addSymlinkHook f Utility/Kqueue.hs: | Files.isSymbolicLink s = callhook addSymlinkHook (Just s) change all above are lower-level, not relevant Audited and dealt with calls to isSymLink. Remaining calls are all safe, because: Annex/Direct.hs: | isSymLink (getmode item) = This is looking at git diff-tree objects, not files on disk Command/Unused.hs: | isSymLink (LsTree.mode l) = do This is looking at git ls-tree, not file on disk Utility/FileMode.hs:isSymLink :: FileMode -> Bool Utility/FileMode.hs:isSymLink = checkMode symbolicLinkMode low-level Done!!
Diffstat (limited to 'Annex/Link.hs')
-rw-r--r--Annex/Link.hs74
1 files changed, 74 insertions, 0 deletions
diff --git a/Annex/Link.hs b/Annex/Link.hs
new file mode 100644
index 000000000..f35c069ee
--- /dev/null
+++ b/Annex/Link.hs
@@ -0,0 +1,74 @@
+{- 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
+
+{- 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, get the link
+ - target by looking inside the file. (Only return at first 8k of the file,
+ - more than enough for any symlink target.)
+ -
+ - Returns Nothing if the file is not a symlink, or not a link to annex
+ - content.
+ -}
+getAnnexLinkTarget :: FilePath -> Annex (Maybe String)
+getAnnexLinkTarget file = do
+ v <- ifM (coreSymlinks <$> Annex.getGitConfig)
+ ( liftIO $ catchMaybeIO $ readSymbolicLink file
+ , liftIO $ catchMaybeIO $ take 8192 <$> readFile file
+ )
+ case v of
+ Nothing -> return Nothing
+ Just l
+ | isLinkToAnnex l -> return v
+ | otherwise -> return Nothing
+
+{- 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.
+ -}
+makeAnnexLink :: String -> FilePath -> Annex ()
+makeAnnexLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
+ ( liftIO $ createSymbolicLink linktarget file
+ , liftIO $ writeFile file linktarget
+ )
+
+{- Creates a link on disk, and additionally stages it in git. -}
+addAnnexLink :: String -> FilePath -> Annex ()
+addAnnexLink linktarget file = do
+ makeAnnexLink linktarget file
+ stageSymlink file =<< hashSymlink linktarget
+
+{- Injects a symlink target into git, returning its Sha. -}
+hashSymlink :: String -> Annex Sha
+hashSymlink linktarget = inRepo $ Git.HashObject.hashObject BlobObject 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)