diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -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 diff --git a/Annex/Fixup.hs b/Annex/Fixup.hs --- a/Annex/Fixup.hs +++ b/Annex/Fixup.hs @@ -1,6 +1,6 @@ {- git-annex repository fixups - - - Copyright 2013, 2015 Joey Hess + - Copyright 2013-2018 Joey Hess - - 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 diff --git a/Annex/Url.hs b/Annex/Url.hs --- a/Annex/Url.hs +++ b/Annex/Url.hs @@ -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 diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -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 diff --git a/Build/BundledPrograms.hs b/Build/BundledPrograms.hs --- a/Build/BundledPrograms.hs +++ b/Build/BundledPrograms.hs @@ -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 diff --git a/Build/Configure.hs b/Build/Configure.hs --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -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] diff --git a/Build/Version.hs b/Build/Version.hs --- a/Build/Version.hs +++ b/Build/Version.hs @@ -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 = [] diff --git a/BuildInfo.hs b/BuildInfo.hs --- a/BuildInfo.hs +++ b/BuildInfo.hs @@ -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" diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 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 diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -27,7 +27,7 @@ Files: Utility/HttpManagerRestricted.hs Copyright: 2018 Joey Hess 2013 Michael Snoyman -License: MIT +License: Expat Files: Utility/* Copyright: 2012-2018 Joey Hess @@ -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 diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -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 diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -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 diff --git a/Command/Unused.hs b/Command/Unused.hs --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -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" diff --git a/Git/Construct.hs b/Git/Construct.hs --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -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 diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -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 diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -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 diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -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" diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -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) diff --git a/Remote/Web.hs b/Remote/Web.hs --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -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 diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -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) diff --git a/Utility/MagicWormhole.hs b/Utility/MagicWormhole.hs --- a/Utility/MagicWormhole.hs +++ b/Utility/MagicWormhole.hs @@ -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" diff --git a/Utility/Url.hs b/Utility/Url.hs --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -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 diff --git a/doc/git-annex-import.mdwn b/doc/git-annex-import.mdwn --- a/doc/git-annex-import.mdwn +++ b/doc/git-annex-import.mdwn @@ -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` diff --git a/doc/git-annex-multicast.mdwn b/doc/git-annex-multicast.mdwn --- a/doc/git-annex-multicast.mdwn +++ b/doc/git-annex-multicast.mdwn @@ -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 diff --git a/doc/git-annex-p2p.mdwn b/doc/git-annex-p2p.mdwn --- a/doc/git-annex-p2p.mdwn +++ b/doc/git-annex-p2p.mdwn @@ -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. diff --git a/doc/git-annex-preferred-content.mdwn b/doc/git-annex-preferred-content.mdwn --- a/doc/git-annex-preferred-content.mdwn +++ b/doc/git-annex-preferred-content.mdwn @@ -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) + + # AUTHOR diff --git a/doc/git-annex-required.mdwn b/doc/git-annex-required.mdwn --- a/doc/git-annex-required.mdwn +++ b/doc/git-annex-required.mdwn @@ -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. diff --git a/doc/git-annex-shell.mdwn b/doc/git-annex-shell.mdwn --- a/doc/git-annex-shell.mdwn +++ b/doc/git-annex-shell.mdwn @@ -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 diff --git a/doc/git-annex-unused.mdwn b/doc/git-annex-unused.mdwn --- a/doc/git-annex-unused.mdwn +++ b/doc/git-annex-unused.mdwn @@ -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` diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 6.20180626 +Version: 6.20180719 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess @@ -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: diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -4,7 +4,6 @@ production: true assistant: true pairing: true - network-uri: true s3: true webdav: true torrentparser: true