packages feed

git-annex 6.20180626 → 6.20180719

raw patch · 31 files changed

+314/−167 lines, 31 filesdep ~network

Dependency ranges changed: network

Files

Annex/Content.hs view
@@ -1060,8 +1060,12 @@ {- Runs an action, passing it a temporary work directory where  - it can write files while receiving the content of a key.  -+ - Preserves the invariant that the workdir never exists without the+ - content file, by creating an empty content file first.+ -  - On exception, or when the action returns Nothing,- - the temporary work directory is left, so resumes can use it.+ - the temporary work directory is retained (unless+ - empty), so anything in it can be used on resume.  -} withTmpWorkDir :: Key -> (FilePath -> Annex (Maybe a)) -> Annex (Maybe a) withTmpWorkDir key action = do@@ -1078,7 +1082,7 @@ 	res <- action tmpdir 	case res of 		Just _ -> liftIO $ removeDirectoryRecursive tmpdir-		Nothing -> noop+		Nothing -> liftIO $ void $ tryIO $ removeDirectory tmpdir 	return res  {- Finds items in the first, smaller list, that are not
Annex/Fixup.hs view
@@ -1,6 +1,6 @@ {- git-annex repository fixups  -- - Copyright 2013, 2015 Joey Hess <id@joeyh.name>+ - Copyright 2013-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -15,6 +15,8 @@ import Utility.SafeCommand import Utility.Directory import Utility.Exception+import Utility.Monad+import Utility.PartialPrelude  import System.IO import System.FilePath@@ -23,11 +25,13 @@ import Control.Monad import Control.Monad.IfElse import qualified Data.Map as M+import Control.Applicative+import Prelude  fixupRepo :: Repo -> GitConfig -> IO Repo fixupRepo r c = do 	let r' = disableWildcardExpansion r-	r'' <- fixupSubmodule r' c+	r'' <- fixupUnusualRepos r' c 	if annexDirect c 		then return (fixupDirect r'') 		else return r''@@ -56,43 +60,89 @@  {- Submodules have their gitdir containing ".git/modules/", and  - have core.worktree set, and also have a .git file in the top- - of the repo. - -- - We need to unset core.worktree, and change the .git file into a- - symlink to the git directory. This way, annex symlinks will be+ - of the repo. We need to unset core.worktree, and change the .git+ - file into a symlink to the git directory. This way, annex symlinks will be  - of the usual .git/annex/object form, and will consistently work  - whether a repo is used as a submodule or not, and wheverever the  - submodule is mounted.  -+ - git-worktree directories have a .git file.+ - That needs to be converted to a symlink, and .git/annex made a symlink+ - to the main repository's git-annex directory.+ - The worktree shares git config with the main repository, so the same+ - annex uuid and other configuration will be used in the worktree as in+ - the main repository.+ -+ - git clone or init with --separate-git-dir similarly makes a .git file,+ - which in that case points to a different git directory. It's+ - also converted to a symlink so links to .git/annex will work. + -   - When the filesystem doesn't support symlinks, we cannot make .git  - into a symlink. But we don't need too, since the repo will use direct- - mode, In this case, we merely adjust the Repo so that- - symlinks to objects that get checked in will be in the right form.+ - mode.  -}-fixupSubmodule :: Repo -> GitConfig -> IO Repo-fixupSubmodule r@(Repo { location = l@(Local { worktree = Just w, gitdir = d }) }) c+fixupUnusualRepos :: Repo -> GitConfig -> IO Repo+fixupUnusualRepos r@(Repo { location = l@(Local { worktree = Just w, gitdir = d }) }) c 	| needsSubmoduleFixup r = do 		when (coreSymlinks c) $-			replacedotgit+			(replacedotgit >> unsetcoreworktree) 				`catchNonAsync` \_e -> hPutStrLn stderr 					"warning: unable to convert submodule to form that will work with git-annex"-		return $ r-			{ location = if coreSymlinks c-				then l { gitdir = dotgit }-				else l-			, config = M.delete "core.worktree" (config r)+		return $ r'+			{ config = M.delete "core.worktree" (config r) 			}+	| otherwise = ifM (needsGitLinkFixup r)+		( do+			when (coreSymlinks c) $+				(replacedotgit >> worktreefixup)+					`catchNonAsync` \_e -> hPutStrLn stderr+						"warning: unable to convert .git file to symlink that will work with git-annex"+			return r'+		, return r+		)   where 	dotgit = w </> ".git"+ 	replacedotgit = whenM (doesFileExist dotgit) $ do 		linktarget <- relPathDirToFile w d 		nukeFile dotgit 		createSymbolicLink linktarget dotgit+	+	unsetcoreworktree = 		maybe (error "unset core.worktree failed") (\_ -> return ()) 			=<< Git.Config.unset "core.worktree" r-fixupSubmodule r _ = return r+	+	worktreefixup =+		-- git-worktree sets up a "commondir" file that contains+		-- the path to the main git directory.+		-- Using --separate-git-dir does not.+		catchDefaultIO Nothing (headMaybe . lines <$> readFile (d </> "commondir")) >>= \case+			Just gd -> do+				-- Make the worktree's git directory+				-- contain an annex symlink to the main+				-- repository's annex directory.+				let linktarget = gd </> "annex"+				createSymbolicLink linktarget (dotgit </> "annex")+			Nothing -> return () +	-- Repo adjusted, so that symlinks to objects that get checked+	-- in will have the usual path, rather than pointing off to the+	-- real .git directory.+	r'+		| coreSymlinks c = r { location = l { gitdir = dotgit } }+		| otherwise = r+fixupUnusualRepos r _ = return r+ needsSubmoduleFixup :: Repo -> Bool needsSubmoduleFixup (Repo { location = (Local { worktree = Just _, gitdir = d }) }) = 	(".git" </> "modules") `isInfixOf` d needsSubmoduleFixup _ = False++needsGitLinkFixup :: Repo -> IO Bool+needsGitLinkFixup (Repo { location = (Local { worktree = Just wt, gitdir = d }) })+	-- Optimization: Avoid statting .git in the common case; only+	-- when the gitdir is not in the usual place inside the worktree+	-- might .git be a file.+	| wt </> ".git" == d = return False+	| otherwise = doesFileExist (wt </> ".git")+needsGitLinkFixup _ = return False
Annex/Url.hs view
@@ -26,9 +26,9 @@ defaultUserAgent :: U.UserAgent defaultUserAgent = "git-annex/" ++ BuildInfo.packageversion -getUserAgent :: Annex (Maybe U.UserAgent)+getUserAgent :: Annex U.UserAgent getUserAgent = Annex.getState $ -	Just . fromMaybe defaultUserAgent . Annex.useragent+	fromMaybe defaultUserAgent . Annex.useragent  getUrlOptions :: Annex U.UrlOptions getUrlOptions = Annex.getState Annex.urloptions >>= \case@@ -42,7 +42,7 @@ 	mk = do 		(urldownloader, manager) <- checkallowedaddr 		mkUrlOptions-			<$> getUserAgent+			<$> (Just <$> getUserAgent) 			<*> headers 			<*> pure urldownloader 			<*> pure manager
Annex/YoutubeDl.hs view
@@ -28,11 +28,18 @@ import Control.Concurrent.Async  -- youtube-dl is can follow redirects to anywhere, including potentially--- localhost or a private address. So, it's only allowed to be used if the--- user has allowed access to all addresses.+-- localhost or a private address. So, it's only allowed to download+-- content if the user has allowed access to all addresses. youtubeDlAllowed :: Annex Bool youtubeDlAllowed = httpAddressesUnlimited +youtubeDlNotAllowedMessage :: String+youtubeDlNotAllowedMessage = unwords+	[ "youtube-dl could potentially access any address, and the"+	, "configuration of annex.security.allowed-http-addresses"+	, "does not allow that."+	]+ -- Runs youtube-dl in a work directory, to download a single media file -- from the url. Reutrns the path to the media file in the work directory. --@@ -49,7 +56,7 @@ youtubeDl :: URLString -> FilePath -> Annex (Either String (Maybe FilePath)) youtubeDl url workdir = ifM httpAddressesUnlimited 	( withUrlOptions $ youtubeDl' url workdir-	, return (Right Nothing)+	, return $ Left youtubeDlNotAllowedMessage 	)  youtubeDl' :: URLString -> FilePath -> UrlOptions -> Annex (Either String (Maybe FilePath))@@ -119,13 +126,7 @@  -- Download a media file to a destination,  youtubeDlTo :: Key -> URLString -> FilePath -> Annex Bool-youtubeDlTo key url dest = ifM youtubeDlAllowed-	( youtubeDlTo' key url dest-	, return False-	)--youtubeDlTo' :: Key -> URLString -> FilePath -> Annex Bool-youtubeDlTo' key url dest = do+youtubeDlTo key url dest = do 	res <- withTmpWorkDir key $ \workdir -> 		youtubeDl url workdir >>= \case 			Right (Just mediafile) -> do@@ -147,14 +148,20 @@ 		Just bs | isHtmlBs bs -> a 		_ -> return fallback +-- Check if youtube-dl supports downloading content from an url. youtubeDlSupported :: URLString -> Annex Bool-youtubeDlSupported url = either (const False) id <$> youtubeDlCheck url+youtubeDlSupported url = either (const False) id+	<$> withUrlOptions (youtubeDlCheck' url)  -- Check if youtube-dl can find media in an url.+--+-- While this does not download anything, it checks youtubeDlAllowed+-- for symmetry with youtubeDl; the check should not succeed if the+-- download won't succeed. youtubeDlCheck :: URLString -> Annex (Either String Bool) youtubeDlCheck url = ifM youtubeDlAllowed 	( withUrlOptions $ youtubeDlCheck' url-	, return (Right False)+	, return $ Left youtubeDlNotAllowedMessage 	)  youtubeDlCheck' :: URLString -> UrlOptions -> Annex (Either String Bool)@@ -168,10 +175,7 @@ -- -- (This is not always identical to the filename it uses when downloading.) youtubeDlFileName :: URLString -> Annex (Either String FilePath)-youtubeDlFileName url = ifM youtubeDlAllowed-	( withUrlOptions go-	, return nomedia-	)+youtubeDlFileName url = withUrlOptions go   where 	go uo 		| supportedScheme uo url = flip catchIO (pure . Left . show) $@@ -182,10 +186,7 @@ -- Does not check if the url contains htmlOnly; use when that's already -- been verified. youtubeDlFileNameHtmlOnly :: URLString -> Annex (Either String FilePath)-youtubeDlFileNameHtmlOnly url = ifM youtubeDlAllowed-	( withUrlOptions $ youtubeDlFileNameHtmlOnly' url-	, return (Left "no media in url") -	)+youtubeDlFileNameHtmlOnly = withUrlOptions . youtubeDlFileNameHtmlOnly'  youtubeDlFileNameHtmlOnly' :: URLString -> UrlOptions -> Annex (Either String FilePath) youtubeDlFileNameHtmlOnly' url uo
Build/BundledPrograms.hs view
@@ -69,6 +69,8 @@ 	, Just "rsync" #ifndef mingw32_HOST_OS 	, Just "sh"+	-- used by git-annex when available+	, Just "uname" #endif 	, BuildInfo.lsof 	, BuildInfo.gcrypt
Build/Configure.hs view
@@ -1,4 +1,4 @@-{- Checks system configuration and generates SysConfig. -}+{- Checks system configuration and generates Build/SysConfig and Build/Version. -}  {-# OPTIONS_GHC -fno-warn-tabs #-} @@ -12,15 +12,13 @@ import qualified Git.Version import Utility.Directory -import Control.Monad.IfElse import Control.Monad import Control.Applicative import Prelude  tests :: [TestCase] tests =-	[ TestCase "version" (Config "packageversion" . StringConfig <$> getVersion)-	, TestCase "UPGRADE_LOCATION" getUpgradeLocation+	[ TestCase "UPGRADE_LOCATION" getUpgradeLocation 	, TestCase "git" $ testCmd "git" "git --version >/dev/null" 	, TestCase "git version" getGitVersion 	, testCp "cp_a" "-a"@@ -120,9 +118,8 @@ 	case v of 		Just "Android" -> writeSysConfig $ androidConfig config 		_ -> writeSysConfig config+	writeVersion =<< getVersion 	cleanup-	whenM isReleaseBuild $-		cabalSetup "git-annex.cabal"  {- Hard codes some settings to cross-compile for Android. -} androidConfig :: [Config] -> [Config]
Build/Version.hs view
@@ -1,4 +1,4 @@-{- Package version determination, for configure script. -}+{- Package version determination. -}  {-# OPTIONS_GHC -fno-warn-tabs #-} @@ -13,7 +13,6 @@  import Utility.Monad import Utility.Exception-import Utility.Directory  type Version = String @@ -22,26 +21,28 @@ isReleaseBuild :: IO Bool isReleaseBuild = (== Just "1") <$> catchMaybeIO (getEnv "RELEASE_BUILD") -{- Version is usually based on the major version from the changelog, - - plus the date of the last commit, plus the git rev of that commit.+{- Version comes from the CHANGELOG, plus the git rev of the last commit.  - This works for autobuilds, ad-hoc builds, etc.  -  - If git or a git repo is not available, or something goes wrong,- - or this is a release build, just use the version from the changelog. -}+ - or this is a release build, just use the version from the CHANGELOG. -} getVersion :: IO Version getVersion = do 	changelogversion <- getChangelogVersion 	ifM (isReleaseBuild) 		( return changelogversion 		, catchDefaultIO changelogversion $ do-			let major = takeWhile (/= '.') changelogversion-			autoversion <- takeWhile (\c -> isAlphaNum c || c == '-') <$> readProcess "sh"+			gitversion <- takeWhile (\c -> isAlphaNum c) <$> readProcess "sh" 				[ "-c"-				, "git log -n 1 --format=format:'%ci %h'| sed -e 's/-//g' -e 's/ .* /-g/'"+				, "git log -n 1 --format=format:'%h'" 				] ""-			if null autoversion-				then return changelogversion-				else return $ concat [ major, ".", autoversion ]+			return $ if null gitversion+				then changelogversion+				else concat+					[ changelogversion+					, "-g"+					, gitversion+					] 		) 	 getChangelogVersion :: IO Version@@ -52,20 +53,17 @@   where 	middle = drop 1 . init -{- Set up cabal file with version. -}-cabalSetup :: FilePath -> IO ()-cabalSetup cabalfile = do-	version <- takeWhile (\c -> isDigit c || c == '.')-		<$> getChangelogVersion-	cabal <- readFile cabalfile-	writeFile tmpcabalfile $ unlines $ -		map (setfield "Version" version) $-		lines cabal-	renameFile tmpcabalfile cabalfile+writeVersion :: Version -> IO ()+writeVersion = writeFile "Build/Version" . body   where-	tmpcabalfile = cabalfile++".tmp"-	setfield field value s-		| fullfield `isPrefixOf` s = fullfield ++ value-		| otherwise = s-	  where-		fullfield = field ++ ": "+	body ver = unlines $ concat+		[ header+		, ["packageversion :: String"]+		, ["packageversion = \"" ++ ver ++ "\""]+		, footer+		]+	header = [+		  "{- Automatically generated. -}"+		, ""+		]+	footer = []
BuildInfo.hs view
@@ -12,3 +12,5 @@ -- This file is generated by the configure program with the results of its -- probing. #include "Build/SysConfig"+-- This file is automatically generated from the CHANGELOG version+#include "Build/Version"
CHANGELOG view
@@ -1,3 +1,33 @@+git-annex (6.20180719) upstream; urgency=medium++  * Support working trees set up by git-worktree.+  * Improve support for repositories created with --separate-git-dir.+  * Support configuring remote.web.annex-cost and remote.bittorrent.annex-cost+  * addurl: When security configuration prevents downloads with youtube-dl,+    still check if the url is one that it supports, and fail downloading+    it, instead of downloading the raw web page.+  * Send User-Agent and any configured annex.http-headers when downloading+    with http, fixes reversion introduced when switching to http-client.+  * Fix reversion introduced in version 6.20180316 that caused git-annex to+    stop processing files when unable to contact a ssh remote.+  * v6: Work around git bug that runs smudge/clean filters at the top of the+    repository while passing them a relative GIT_WORK_TREE that may point+    outside of the repository, by using GIT_PREFIX to get back to the+    subdirectory where a relative GIT_WORK_TREE is valid.+  * p2p --pair: Fix interception of the magic-wormhole pairing code,+    which since 0.8.2 it has sent to stderr rather than stdout.+  * info: Display uuid and description when a repository is identified by+    uuid, and for "here".+  * unused --from: Allow specifiying a repository by uuid or description.+  * linux standalone: Generate locale files in ~/.cache/git-annex/locales/+    so they're available even when the standalone tarball is installed+    in a directory owned by root. Note that this prevents using the+    standalone bundle in environments where HOME is not writable.+  * Include uname command in standalone builds since git-annex uses it.+  * git-annex.cabal: Fix network version.++ -- Joey Hess <id@joeyh.name>  Thu, 19 Jul 2018 13:53:45 -0400+ git-annex (6.20180626) upstream; urgency=high    Security fix release for CVE-2018-10857 and CVE-2018-10859
@@ -27,7 +27,7 @@ Files: Utility/HttpManagerRestricted.hs Copyright: 2018 Joey Hess <id@joeyh.name>            2013 Michael Snoyman-License: MIT+License: Expat  Files: Utility/* Copyright: 2012-2018 Joey Hess <id@joeyh.name>@@ -53,10 +53,10 @@ Files: static/jquery* Copyright: © 2005-2011 by John Resig, Branden Aaron & Jörn Zaefferer            © 2011 The Dojo Foundation-License: MIT or GPL-2+License: Expat or GPL-2  The full text of version 2 of the GPL is distributed in- /usr/share/common-licenses/GPL-2 on Debian systems. The text of the MIT- license is in the MIT section below.+ /usr/share/common-licenses/GPL-2 on Debian systems. The text of the Expat+ license is in the Expat section below.  Files: static/*/bootstrap* static/*/glyphicons-halflings* Copyright: 2012-2014 Twitter, Inc.@@ -140,7 +140,7 @@  OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF  SUCH DAMAGE.  -License: MIT+License: Expat  Permission is hereby granted, free of charge, to any person obtaining  a copy of this software and associated documentation files (the  "Software"), to deal in the Software without restriction, including
Command/AddUrl.hs view
@@ -283,18 +283,20 @@ 				(dl dest) 			Left _ -> normalfinish tmp 	  where-		dl dest = withTmpWorkDir mediakey $ \workdir ->+		dl dest = withTmpWorkDir mediakey $ \workdir -> do+			let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . nukeFile) 			Transfer.notifyTransfer Transfer.Download url $ 				Transfer.download webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \_p -> 					youtubeDl url workdir >>= \case 						Right (Just mediafile) -> do-							pruneTmpWorkDirBefore tmp (liftIO . nukeFile)+							cleanuptmp 							checkCanAdd dest $ do 								showDestinationFile dest 								addWorkTree webUUID mediaurl dest mediakey (Just mediafile) 								return $ Just mediakey 						Right Nothing -> normalfinish tmp 						Left msg -> do+							cleanuptmp 							warning msg 							return Nothing 		mediaurl = setDownloader url YoutubeDownloader
Command/Info.hs view
@@ -209,13 +209,16 @@ remoteInfo :: InfoOptions -> Remote -> Annex () remoteInfo o r = showCustom (unwords ["info", Remote.name r]) $ do 	i <- map (\(k, v) -> simpleStat k (pure v)) <$> Remote.getInfo r-	l <- selStats (remote_fast_stats r ++ i) (uuid_slow_stats (Remote.uuid r))+	let u = Remote.uuid r+	l <- selStats +		(uuid_fast_stats u ++ remote_fast_stats r ++ i)+		(uuid_slow_stats u) 	evalStateT (mapM_ showStat l) (emptyStatInfo o) 	return True  uuidInfo :: InfoOptions -> UUID -> Annex () uuidInfo o u = showCustom (unwords ["info", fromUUID u]) $ do-	l <- selStats [] ((uuid_slow_stats u))+	l <- selStats (uuid_fast_stats u) (uuid_slow_stats u) 	evalStateT (mapM_ showStat l) (emptyStatInfo o) 	return True @@ -277,17 +280,21 @@ remote_fast_stats :: Remote -> [Stat] remote_fast_stats r = map (\s -> s r) 	[ remote_name-	, remote_description-	, remote_uuid 	, remote_trust 	, remote_cost 	, remote_type 	] +uuid_fast_stats :: UUID -> [Stat]+uuid_fast_stats u = map (\s -> s u)+	[ repo_uuid+	, repo_description+	]+ uuid_slow_stats :: UUID -> [Stat] uuid_slow_stats u = map (\s -> s u)-	[ remote_annex_keys-	, remote_annex_size+	[ repo_annex_keys+	, repo_annex_size 	]  stat :: String -> (String -> StatState String) -> Stat@@ -353,13 +360,11 @@ remote_name :: Remote -> Stat remote_name r = simpleStat "remote" $ pure (Remote.name r) -remote_description :: Remote -> Stat-remote_description r = simpleStat "description" $ lift $-	Remote.prettyUUID (Remote.uuid r)+repo_description :: UUID -> Stat+repo_description = simpleStat "description" . lift . Remote.prettyUUID -remote_uuid :: Remote -> Stat-remote_uuid r = simpleStat "uuid" $ pure $-	fromUUID $ Remote.uuid r+repo_uuid :: UUID -> Stat+repo_uuid = simpleStat "uuid" . pure . fromUUID  remote_trust :: Remote -> Stat remote_trust r = simpleStat "trust" $ lift $@@ -381,12 +386,14 @@ local_annex_size = simpleStat "local annex size" $ 	showSizeKeys =<< cachedPresentData -remote_annex_keys :: UUID -> Stat-remote_annex_keys u = stat "remote annex keys" $ json show $+-- "remote" is in the name for JSON backwards-compatibility+repo_annex_keys :: UUID -> Stat+repo_annex_keys u = stat "remote annex keys" $ json show $ 	countKeys <$> cachedRemoteData u -remote_annex_size :: UUID -> Stat-remote_annex_size u = simpleStat "remote annex size" $+-- "remote" is in the name for JSON backwards-compatibility+repo_annex_size :: UUID -> Stat+repo_annex_size u = simpleStat "remote annex size" $ 	showSizeKeys =<< cachedRemoteData u  known_annex_files :: Bool -> Stat
Command/Unused.hs view
@@ -93,15 +93,15 @@ 		v' <- a v 		chain v' as -checkRemoteUnused :: String -> RefSpec -> CommandPerform-checkRemoteUnused name refspec = go =<< fromJust <$> Remote.byNameWithUUID (Just name)+checkRemoteUnused :: RemoteName -> RefSpec -> CommandPerform+checkRemoteUnused remotename refspec = go =<< Remote.nameToUUID remotename   where-	go r = do+	go u = do 		showAction "checking for unused data"-		_ <- check "" (remoteUnusedMsg r) (remoteunused r) 0+		r <- Remote.byUUID u+		_ <- check "" (remoteUnusedMsg r remotename) (remoteunused u) 0 		next $ return True-	remoteunused r = excludeReferenced refspec-		<=< loggedKeysFor $ Remote.uuid r+	remoteunused u = excludeReferenced refspec =<< loggedKeysFor u  check :: FilePath -> ([(Int, Key)] -> String) -> Annex [Key] -> Int -> Annex Int check file msg a c = do@@ -142,16 +142,14 @@ 	["(To see where data was previously used, try: git log --stat -S'KEY')"] ++ 	mtrailer -remoteUnusedMsg :: Remote -> [(Int, Key)] -> String-remoteUnusedMsg r u = unusedMsg' u-	["Some annexed data on " ++ name ++ " is not used by any files:"]-	[dropMsg $ Just r]-  where-	name = Remote.name r +remoteUnusedMsg :: Maybe Remote -> RemoteName -> [(Int, Key)] -> String+remoteUnusedMsg mr remotename u = unusedMsg' u+	["Some annexed data on " ++ remotename ++ " is not used by any files:"]+	(if isJust mr then [dropMsg (Just remotename)] else []) -dropMsg :: Maybe Remote -> String+dropMsg :: Maybe RemoteName -> String dropMsg Nothing = dropMsg' ""-dropMsg (Just r) = dropMsg' $ " --from " ++ Remote.name r+dropMsg (Just remotename) = dropMsg' $ " --from " ++ remotename dropMsg' :: String -> String dropMsg' s = "\nTo remove unwanted data: git-annex dropunused" ++ s ++ " NUMBER\n"
Git/Construct.hs view
@@ -207,10 +207,19 @@ 		( return $ Just $ LocalUnknown dir 		, return Nothing 		)-	isRepo = checkdir $ gitSignature $ ".git" </> "config"+	isRepo = checkdir $ +		gitSignature (".git" </> "config")+			<||>+		-- A git-worktree lacks .git/config, but has .git/commondir.+		-- (Normally the .git is a file, not a symlink, but it can+		-- be converted to a symlink and git will still work;+		-- this handles that case.)+		gitSignature (".git" </> "gitdir") 	isBareRepo = checkdir $ gitSignature "config" 		<&&> doesDirectoryExist (dir </> "objects") 	gitDirFile = do+		-- git-submodule, git-worktree, and --separate-git-dir+		-- make .git be a file pointing to the real git directory. 		c <- firstLine <$> 			catchDefaultIO "" (readFile $ dir </> ".git") 		return $ if gitdirprefix `isPrefixOf` c
Git/CurrentRepo.hs view
@@ -25,12 +25,20 @@  - directory if necessary to ensure it is within the repository's work  - tree. While not needed for git commands, this is useful for anything  - else that looks for files in the worktree.+ -+ - Also works around a git bug when running some hooks. It+ - runs the hooks in the top of the repository, but if GIT_WORK_TREE+ - was relative, it then points to the wrong directory. In this situation+ - GIT_PREFIX contains the directory that GIT_WORK_TREE (and GIT_DIR)+ - are relative to.  -} get :: IO Repo get = do-	gd <- pathenv "GIT_DIR"+	prefix <- getpathenv "GIT_PREFIX"+	gd <- pathenv "GIT_DIR" prefix 	r <- configure gd =<< fromCwd-	wt <- maybe (worktree $ location r) Just <$> pathenv "GIT_WORK_TREE"+	wt <- maybe (worktree $ location r) Just+		<$> pathenv "GIT_WORK_TREE" prefix 	case wt of 		Nothing -> return r 		Just d -> do@@ -39,13 +47,18 @@ 				setCurrentDirectory d 			return $ addworktree wt r   where-	pathenv s = do+	getpathenv s = do 		v <- getEnv s 		case v of 			Just d -> do 				unsetEnv s-				Just <$> absPath d+				return (Just d) 			Nothing -> return Nothing+	+	pathenv s Nothing = getpathenv s+	pathenv s (Just prefix) = getpathenv s >>= \case+		Nothing -> return Nothing+		Just d -> Just <$> absPath (prefix </> d)  	configure Nothing (Just r) = Git.Config.read r 	configure (Just d) _ = do
Remote/BitTorrent.hs view
@@ -14,6 +14,7 @@ import qualified Annex import qualified Git import qualified Git.Construct+import Config import Config.Cost import Logs.Web import Types.UrlContents@@ -51,10 +52,11 @@ 	return [r]  gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)-gen r _ c gc = +gen r _ c gc = do+	cst <- remoteCost gc expensiveRemoteCost 	return $ Just Remote 		{ uuid = bitTorrentUUID-		, cost = expensiveRemoteCost+		, cost = cst 		, name = Git.repoDescribe r 		, storeKey = uploadKey 		, retrieveKeyFile = downloadKey
Remote/Git.hs view
@@ -395,7 +395,7 @@ 	| Git.repoIsHttp repo = giveup "dropping from http remote not supported" 	| otherwise = commitOnCleanup repo r $ do 		let fallback = Ssh.dropKey repo key-		P2PHelper.remove (Ssh.runProto r connpool False fallback) key+		P2PHelper.remove (Ssh.runProto r connpool (return False) fallback) key  lockKey :: Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r lockKey r st key callback = do@@ -493,7 +493,7 @@ 	| Git.repoIsSsh repo = if forcersync 		then fallback meterupdate 		else P2PHelper.retrieve-			(\p -> Ssh.runProto r connpool (False, UnVerified) (fallback p))+			(\p -> Ssh.runProto r connpool (return (False, UnVerified)) (fallback p)) 			key file dest meterupdate 	| otherwise = giveup "copying from non-ssh, non-http remote not supported"   where@@ -605,7 +605,7 @@ 		) 	| Git.repoIsSsh repo = commitOnCleanup repo r $ 		P2PHelper.store-			(\p -> Ssh.runProto r connpool False (copyremotefallback p))+			(\p -> Ssh.runProto r connpool (return False) (copyremotefallback p)) 			key file meterupdate 		 	| otherwise = giveup "copying to non-ssh repo not supported"
Remote/Helper/Ssh.hs view
@@ -321,8 +321,8 @@  -- Runs a P2P Proto action on a remote when it supports that, -- otherwise the fallback action.-runProto :: Remote -> P2PSshConnectionPool -> a -> Annex a -> P2P.Proto a -> Annex (Maybe a)-runProto r connpool bad fallback proto = Just <$>+runProto :: Remote -> P2PSshConnectionPool -> Annex a -> Annex a -> P2P.Proto a -> Annex (Maybe a)+runProto r connpool badproto fallback proto = Just <$> 	(getP2PSshConnection r connpool >>= maybe fallback go)   where 	go c = do@@ -333,7 +333,7 @@ 				return res 			-- Running the proto failed, either due to a protocol 			-- error or a network error.-			Nothing -> return bad+			Nothing -> badproto  runProtoConn :: P2P.Proto a -> P2PSshConnection -> Annex (P2PSshConnection, Maybe a) runProtoConn _ P2P.ClosedConnection = return (P2P.ClosedConnection, Nothing)
Remote/Web.hs view
@@ -15,6 +15,7 @@ import qualified Git.Construct import Annex.Content import Config.Cost+import Config import Logs.Web import Annex.UUID import Messages.Progress@@ -40,10 +41,11 @@ 	return [r]  gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)-gen r _ c gc = +gen r _ c gc = do+	cst <- remoteCost gc expensiveRemoteCost 	return $ Just Remote 		{ uuid = webUUID-		, cost = expensiveRemoteCost+		, cost = cst 		, name = Git.repoDescribe r 		, storeKey = uploadKey 		, retrieveKeyFile = downloadKey
Utility/FileMode.hs view
@@ -17,7 +17,7 @@ import System.PosixCompat.Types import System.PosixCompat.Files #ifndef mingw32_HOST_OS-import System.Posix.Files+import System.Posix.Files (symbolicLinkMode) import Control.Monad.IO.Class (liftIO) #endif import Control.Monad.IO.Class (MonadIO)
Utility/MagicWormhole.hs view
@@ -34,6 +34,7 @@ import System.IO import System.Exit import Control.Concurrent+import Control.Concurrent.Async import Control.Exception import Data.Char import Data.List@@ -112,21 +113,23 @@ 	-- Work around stupid stdout buffering behavior of python. 	-- See https://github.com/warner/magic-wormhole/issues/108 	environ <- addEntry "PYTHONUNBUFFERED" "1" <$> getEnvironment-	runWormHoleProcess p { env = Just environ} $ \_hin hout ->-		findcode =<< words <$> hGetContents hout+	runWormHoleProcess p { env = Just environ} $ \_hin hout herr -> do+		(inout, inerr) <- findcode hout `concurrently` findcode herr+		return (inout || inerr)   where 	p = wormHoleProcess (Param "send" : ps ++ [File f])-	findcode [] = return False-	findcode (w:ws) = case mkCode w of+	findcode h = findcode' =<< words <$> hGetContents h+	findcode' [] = return False+	findcode' (w:ws) = case mkCode w of 		Just code -> do-			putMVar observer code+			_ <- tryPutMVar observer code 			return True-		Nothing -> findcode ws+		Nothing -> findcode' ws  -- | Receives a file. Once the receive is under way, the Code will be -- read from the CodeProducer, and fed to wormhole on stdin. receiveFile :: FilePath -> CodeProducer -> WormHoleParams -> IO Bool-receiveFile f (CodeProducer producer) ps = runWormHoleProcess p $ \hin _hout -> do+receiveFile f (CodeProducer producer) ps = runWormHoleProcess p $ \hin _hout _herr -> do 	Code c <- readMVar producer 	hPutStrLn hin c 	hFlush hin@@ -142,25 +145,27 @@ wormHoleProcess :: WormHoleParams -> CreateProcess wormHoleProcess = proc "wormhole" . toCommand -runWormHoleProcess :: CreateProcess -> (Handle -> Handle -> IO Bool) ->  IO Bool+runWormHoleProcess :: CreateProcess -> (Handle -> Handle -> Handle -> IO Bool) ->  IO Bool runWormHoleProcess p consumer =  	bracketOnError setup (\v -> cleanup v <&&> return False) go   where 	setup = do-		(Just hin, Just hout, Nothing, pid)+		(Just hin, Just hout, Just herr, pid) 			<- createProcess p 				{ std_in = CreatePipe 				, std_out = CreatePipe+				, std_err = CreatePipe 				}-		return (hin, hout, pid)-	cleanup (hin, hout, pid) = do+		return (hin, hout, herr, pid)+	cleanup (hin, hout, herr, pid) = do 		r <- waitForProcess pid 		hClose hin 		hClose hout+		hClose herr 		return $ case r of 			ExitSuccess -> True 			ExitFailure _ -> False-	go h@(hin, hout, _) = consumer hin hout <&&> cleanup h+	go h@(hin, hout, herr, _) = consumer hin hout herr <&&> cleanup h  isInstalled :: IO Bool isInstalled = inPath "wormhole"
Utility/Url.hs view
@@ -315,7 +315,7 @@  	downloadconduit req = catchMaybeIO (getFileSize file) >>= \case 		Nothing -> runResourceT $ do-			resp <- http req' (httpManager uo)+			resp <- http (applyRequest uo req') (httpManager uo) 			if responseStatus resp == ok200 				then store zeroBytesProcessed WriteMode resp 				else showrespfailure resp
doc/git-annex-import.mdwn view
@@ -56,7 +56,7 @@    Imports files that are not duplicates. Files that are duplicates have   their content reinjected into the annex (similar to-  [[git-annex-reinject]]).+  [[git-annex-reinject]](1)).  * `--force`
doc/git-annex-multicast.mdwn view
@@ -29,7 +29,7 @@   When no files are specified, all annexed files in the current directory   and subdirectories are sent. -  The [[git-annex-matching-options]] can be used to control which files to+  The [[git-annex-matching-options]](1) can be used to control which files to   send. For example:  	git annex multicast send . --not --copies 2
doc/git-annex-p2p.mdwn view
@@ -32,8 +32,12 @@   the repositories, so you will need it installed on both computers that are   being paired. -* `--gen-address`+  This feature was present in a broken form in git-annex versions+  before version 6.20180705. Make sure that a new enough git-annex+  is installed on both computers that are being paired. +* `--gen-addresses`+   Generates addresses that can be used to access this git-annex repository   over the available P2P networks. The address or addresses is output to   stdout. @@ -46,7 +50,7 @@   Sets up a git remote that is accessed over a P2P network.      This will prompt for an address to be entered; you should paste in the-  address that was generated by --gen-address in the remote repository.+  address that was generated by --gen-addresses in the remote repository.    Defaults to making the git remote be named "peer1", "peer2",   etc. This can be overridden with the `--name` option.
doc/git-annex-preferred-content.mdwn view
@@ -159,7 +159,8 @@ * `standard`    git-annex comes with some built-in preferred content expressions, that-  can be used with repositories that are in some [[preferred content/standard groups/]].+  can be used with repositories that are in some standard groups+  such as "client" and "transfer".    When a repository is in exactly one such group, you can use the "standard"   keyword in its preferred content expression, to match whatever content@@ -263,6 +264,8 @@ [[git-annex-wanted]](1)  <https://git-annex.branchable.com/preferred_content/>++<https://git-annex.branchable.com/preferred_content/standard_groups/>  # AUTHOR
doc/git-annex-required.mdwn view
@@ -18,11 +18,10 @@ Without an expression, displays the current required content setting of the repository. -While [[git-annex-wanted]] is just a preference,-[[git-annex-required]] designates content that should really not be-removed. For example a file that is `wanted` can be removed with -`git annex drop`, but if that file is `required`, it would need to be-removed with `git annex drop --force`. +While [[git-annex-wanted]](1) is just a preference, this designates content+that should really not be removed. For example a file that is `wanted` can+be removed with `git annex drop`, but if that file is `required`, it would+need to be removed with `git annex drop --force`.   Also, `git-annex fsck` will warn about required contents that are not present.
doc/git-annex-shell.mdwn view
@@ -168,12 +168,36 @@ To further restrict git-annex-shell to a particular repository,  and fully lock it down to read-only mode: -	command="GIT_ANNEX_SHELL_DIRECTORY=/srv/annex GIT_ANNEX_SHELL_LIMITED=true GIT_ANNEX_SHELL_READONLY=true git-annex-shell -c \"$SSH_ORIGINAL_COMMAND\"",no-agent-forwarding,no-port-forwarding,no-X11-forwarding ssh-rsa AAAAB3NzaC1y[...] user@example.com+	command="GIT_ANNEX_SHELL_DIRECTORY=/srv/annex GIT_ANNEX_SHELL_LIMITED=true GIT_ANNEX_SHELL_READONLY=true git-annex-shell -c \"$SSH_ORIGINAL_COMMAND\"",restrict ssh-rsa AAAAB3NzaC1y[...] user@example.com  Obviously, `ssh-rsa AAAAB3NzaC1y[...] user@example.com` needs to replaced with your SSH key. The above also assumes `git-annex-shell` is available in your `$PATH`, use an absolute path if it is not the-case.+case. Also note how the above uses the `restrict` option instead of an+explicit list of functionality to disallow. This only works in certain+OpenSSH releases, starting from 7.1p2.++To only allow adding new objects to the repository, the+`GIT_ANNEX_SHELL_APPENDONLY` variable can be used as well:++    command="GIT_ANNEX_SHELL_DIRECTORY=/srv/annex GIT_ANNEX_SHELL_APPENDONLY=true git-annex-shell -c \"$SSH_ORIGINAL_COMMAND\"",restrict ssh-rsa AAAAB3NzaC1y[...] user@example.com++This will not keep an attacker from destroying the git history, as+explained above. For this you might want to disallow certain+operations, like branch deletion and force-push, with options from+git-config(1). For example:++    git config receive.denyDeletes true+    git config receive.denyNonFastForwards true++With this configuration, git commits can still remove files, +but they will still be available in the git history and git-annex will+retain their contents. Changes to `git-annex` branch, however, can+negatively impact git-annex's location tracking information and might+cause data loss. To work around this problem, more complex hooks+are required, see for example the `update-paranoid` hook in the git+source distribution.+  # SEE ALSO
doc/git-annex-unused.mdwn view
@@ -24,9 +24,12 @@    Only show unused temp and bad files. -* `--from=remote`+* `--from=repository` -  Check for unused data that is located on a remote.+  Check for unused data that is located in a repository.++  The repository should be specified using the name of a configured remote,+  or the UUID or description of a repository.  * `--used-refspec=+ref:-ref`
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 6.20180626+Version: 6.20180719 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -291,10 +291,6 @@   Description: Enable benchmarking   Default: False -Flag network-uri-  Description: Get Network.URI from the network-uri package-  Default: True- Flag Dbus   Description: Enable dbus support @@ -305,12 +301,14 @@ custom-setup   Setup-Depends: base (>= 4.6), hslogger, split, unix-compat, process,     filepath, exceptions, bytestring, directory, IfElse, data-default,-    utf8-string, Cabal+    utf8-string, transformers, Cabal  Executable git-annex   Main-Is: git-annex.hs   Build-Depends:    base (>= 4.6 && < 5.0),+   network (>= 2.6.3.0),+   network-uri (>= 2.6),    optparse-applicative (>= 0.11.0),     containers (>= 0.5.0.0),    exceptions (>= 0.6),@@ -394,11 +392,6 @@   -- (Only tested on Linux).   if os(Linux)     GHC-Options: -optl-Wl,--as-needed--  if flag(network-uri)-    Build-Depends: network-uri (>= 2.6), network (>= 2.6)-  else-    Build-Depends: network (< 2.6), network (>= 2.4)    if (os(windows))     Build-Depends:
stack.yaml view
@@ -4,7 +4,6 @@     production: true     assistant: true     pairing: true-    network-uri: true     s3: true     webdav: true     torrentparser: true