diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs --- a/Annex/AdjustedBranch.hs +++ b/Annex/AdjustedBranch.hs @@ -341,7 +341,7 @@ {- Update the currently checked out adjusted branch, merging the provided - branch into it. Note that the provided branch should be a non-adjusted - branch. -} -mergeToAdjustedBranch :: Branch -> (OrigBranch, Adjustment) -> [Git.Merge.MergeConfig] -> Annex Bool -> Git.Branch.CommitMode -> Annex Bool +mergeToAdjustedBranch :: Branch -> (OrigBranch, Adjustment) -> [Git.Merge.MergeConfig] -> Bool -> Git.Branch.CommitMode -> Annex Bool mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge commitmode = catchBoolIO $ join $ preventCommits go where @@ -402,8 +402,8 @@ -- http://thread.gmane.org/gmane.comp.version-control.git/297237 inRepo $ Git.Command.run [Param "reset", Param "HEAD", Param "--quiet"] showAction $ "Merging into " ++ fromRef (Git.Ref.base origbranch) - merged <- inRepo (Git.Merge.merge' [] tomerge mergeconfig commitmode) - <||> (resolveMerge (Just updatedorig) tomerge True <&&> commitResolvedMerge commitmode) + merged <- autoMergeFrom' tomerge Nothing mergeconfig commitmode True + (const $ resolveMerge (Just updatedorig) tomerge True) if merged then do !mergecommit <- liftIO $ extractSha @@ -439,7 +439,7 @@ -- this commit will be a fast-forward. adjmergecommitff <- commitAdjustedTree' adjtree (BasisBranch mergecommit) [currbranch] showAction "Merging into adjusted branch" - ifM (autoMergeFrom adjmergecommitff (Just currbranch) mergeconfig canresolvemerge commitmode) + ifM (autoMergeFrom adjmergecommitff (Just currbranch) mergeconfig commitmode canresolvemerge) ( reparent adjtree adjmergecommit =<< getcurrentcommit , return False ) diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs --- a/Annex/AutoMerge.hs +++ b/Annex/AutoMerge.hs @@ -1,6 +1,6 @@ {- git-annex automatic merge conflict resolution - - - Copyright 2012-2016 Joey Hess + - Copyright 2012-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -9,11 +9,13 @@ module Annex.AutoMerge ( autoMergeFrom + , autoMergeFrom' , resolveMerge , commitResolvedMerge ) where import Annex.Common +import qualified Annex import qualified Annex.Queue import Annex.CatFile import Annex.Link @@ -36,6 +38,7 @@ import qualified Data.Set as S import qualified Data.Map as M import qualified Data.ByteString.Lazy as L +import qualified Utility.RawFilePath as R {- Merges from a branch into the current branch (which may not exist yet), - with automatic merge conflict resolution. @@ -43,27 +46,49 @@ - Callers should use Git.Branch.changed first, to make sure that - there are changes from the current branch to the branch being merged in. -} -autoMergeFrom :: Git.Ref -> Maybe Git.Ref -> [Git.Merge.MergeConfig] -> Annex Bool -> Git.Branch.CommitMode -> Annex Bool -autoMergeFrom branch currbranch mergeconfig canresolvemerge commitmode = do +autoMergeFrom :: Git.Ref -> Maybe Git.Ref -> [Git.Merge.MergeConfig] -> Git.Branch.CommitMode -> Bool -> Annex Bool +autoMergeFrom branch currbranch mergeconfig commitmode canresolvemerge = + autoMergeFrom' branch currbranch mergeconfig commitmode canresolvemerge resolvemerge + where + resolvemerge old + | canresolvemerge = resolveMerge old branch False + | otherwise = return False + +autoMergeFrom' :: Git.Ref -> Maybe Git.Ref -> [Git.Merge.MergeConfig] -> Git.Branch.CommitMode -> Bool -> (Maybe Git.Ref -> Annex Bool) -> Annex Bool +autoMergeFrom' branch currbranch mergeconfig commitmode willresolvemerge toresolvemerge = do showOutput case currbranch of Nothing -> go Nothing Just b -> go =<< inRepo (Git.Ref.sha b) where go old = do - r <- inRepo (Git.Merge.merge branch mergeconfig commitmode) - <||> (resolvemerge <&&> commitResolvedMerge commitmode) + -- merge.directoryRenames=conflict plus automatic + -- merge conflict resolution results in files in a + -- "renamed" directory getting variant names, + -- so is not a great combination. If the user has + -- explicitly set it, use it, but otherwise when + -- merge conflicts will be resolved, override + -- to merge.directoryRenames=false. + overridedirectoryrenames <- if willresolvemerge + then isNothing . mergeDirectoryRenames + <$> Annex.getGitConfig + else pure False + let f r + | overridedirectoryrenames = r + { Git.gitGlobalOpts = + Param "-c" + : Param "merge.directoryRenames=false" + : Git.gitGlobalOpts r + } + | otherwise = r + r <- inRepo (Git.Merge.merge branch mergeconfig commitmode . f) + <||> (toresolvemerge old <&&> commitResolvedMerge commitmode) -- Merging can cause new associated files to appear -- and the smudge filter will add them to the database. -- To ensure that this process sees those changes, -- close the database if it was open. Database.Keys.closeDb return r - where - resolvemerge = ifM canresolvemerge - ( resolveMerge old branch False - , return False - ) {- Resolves a conflicted merge. It's important that any conflicts be - resolved in a way that itself avoids later merge conflicts, since @@ -145,8 +170,8 @@ -- Both sides of conflict are annexed files (Just keyUs, Just keyThem) | keyUs /= keyThem -> resolveby [keyUs, keyThem] $ do - makeannexlink keyUs LsFiles.valUs - makeannexlink keyThem LsFiles.valThem + makevariantannexlink keyUs LsFiles.valUs + makevariantannexlink keyThem LsFiles.valThem -- cleanConflictCruft can't handle unlocked -- files, so delete here. unless inoverlay $ @@ -162,13 +187,15 @@ else makepointer keyUs file (combinedmodes) return ([keyUs, keyThem], Just file) -- Our side is annexed file, other side is not. + -- Make the annexed file into a variant file and graft in the + -- other file/directory as it was. (Just keyUs, Nothing) -> resolveby [keyUs] $ do graftin them file LsFiles.valThem LsFiles.valThem LsFiles.valUs - makeannexlink keyUs LsFiles.valUs + makevariantannexlink 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 - makeannexlink keyThem LsFiles.valThem + makevariantannexlink keyThem LsFiles.valThem -- Neither side is annexed file; cannot resolve. (Nothing, Nothing) -> return ([], Nothing) where @@ -177,7 +204,7 @@ getkey select = case select (LsFiles.unmergedSha u) of Just sha -> catKey sha - Nothing -> return Nothing + Nothing -> pure Nothing islocked select = select (LsFiles.unmergedTreeItemType u) == Just TreeSymlink @@ -190,7 +217,7 @@ theirmode = fromTreeItemType <$> LsFiles.valThem (LsFiles.unmergedTreeItemType u) - makeannexlink key select + makevariantannexlink key select | islocked select = makesymlink key dest | otherwise = makepointer key dest destmode where @@ -208,8 +235,8 @@ dest' <- toRawFilePath <$> stagefile dest stageSymlink dest' =<< hashSymlink l - replacewithsymlink dest link = withworktree dest $ \f -> - replaceWorkTreeFile f $ makeGitLink link . toRawFilePath + replacewithsymlink dest link = replaceWorkTreeFile dest $ + makeGitLink link . toRawFilePath makepointer key dest destmode = do unless inoverlay $ @@ -224,8 +251,6 @@ Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath (toRawFilePath dest)) - withworktree f a = a f - {- Stage a graft of a directory or file from a branch - and update the work tree. -} graftin b item selectwant selectwant' selectunwant = do @@ -246,7 +271,7 @@ -- And when grafting in anything else vs a symlink, -- the work tree already contains what we want. (_, Just TreeSymlink) -> noop - _ -> ifM (withworktree item (liftIO . doesDirectoryExist)) + _ -> ifM (liftIO $ doesDirectoryExist item) -- a conflict between a file and a directory -- leaves the directory, so since a directory -- is there, it must be what was wanted @@ -256,10 +281,9 @@ -- file content , case selectwant' (LsFiles.unmergedSha u) of Nothing -> noop - Just sha -> withworktree item $ \f -> - replaceWorkTreeFile f $ \tmp -> do - c <- catObject sha - liftIO $ L.writeFile tmp c + Just sha -> replaceWorkTreeFile item $ \tmp -> do + c <- catObject sha + liftIO $ L.writeFile tmp c ) resolveby ks a = do @@ -292,7 +316,7 @@ inks = maybe False (flip S.member ks) matchesresolved is i f | S.member f fs || S.member (conflictCruftBase f) fs = anyM id - [ pure (S.member i is) + [ pure $ either (const False) (`S.member` is) i , inks <$> isAnnexLink (toRawFilePath f) , inks <$> liftIO (isPointerFile (toRawFilePath f)) ] @@ -309,7 +333,7 @@ reuseOldFile srcmap key origfile destfile = do is <- map (inodeCacheToKey Strongly) <$> Database.Keys.getInodeCaches key - liftIO $ go $ mapMaybe (\i -> M.lookup i srcmap) is + liftIO $ go $ mapMaybe (\i -> M.lookup (Right i) srcmap) is where go [] = return False go (f:fs) @@ -329,15 +353,19 @@ , Param "git-annex automatic merge conflict fix" ] -type InodeMap = M.Map InodeCacheKey FilePath +type InodeMap = M.Map (Either FilePath InodeCacheKey) FilePath inodeMap :: Annex ([RawFilePath], IO Bool) -> Annex InodeMap inodeMap getfiles = do (fs, cleanup) <- getfiles fsis <- forM fs $ \f -> do - mi <- withTSDelta (liftIO . genInodeCache f) - return $ case mi of - Nothing -> Nothing - Just i -> Just (inodeCacheToKey Strongly i, fromRawFilePath f) + s <- liftIO $ R.getSymbolicLinkStatus f + let f' = fromRawFilePath f + if isSymbolicLink s + then pure $ Just (Left f', f') + else withTSDelta (\d -> liftIO $ toInodeCache d f' s) + >>= return . \case + Just i -> Just (Right (inodeCacheToKey Strongly i), f') + Nothing -> Nothing void $ liftIO cleanup return $ M.fromList $ catMaybes fsis diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -807,8 +807,15 @@ downloadUrl k p urls file uo = -- Poll the file to handle configurations where an external -- download command is used. - meteredFile file (Just p) k $ - anyM (\u -> Url.download p u file uo) urls + meteredFile file (Just p) k (go urls Nothing) + where + -- Display only one error message, if all the urls fail to + -- download. + go [] (Just err) = warning err >> return False + go [] Nothing = return False + go (u:us) _ = Url.download' p u file uo >>= \case + Right () -> return True + Left err -> go us (Just err) {- Copies a key's content, when present, to a temp file. - This is used to speed up some rsyncs. -} diff --git a/Annex/DirHashes.hs b/Annex/DirHashes.hs --- a/Annex/DirHashes.hs +++ b/Annex/DirHashes.hs @@ -59,7 +59,7 @@ - which do not allow using a directory "XX" when "xx" already exists. - To support that, some git-annex repositories use the lower case-hash. - All special remotes use the lower-case hash for new data, but old data - - may still used the mixed case hash. -} + - may still use the mixed case hash. -} dirHashes :: [HashLevels -> Hasher] dirHashes = [hashDirLower, hashDirMixed] diff --git a/Annex/GitOverlay.hs b/Annex/GitOverlay.hs --- a/Annex/GitOverlay.hs +++ b/Annex/GitOverlay.hs @@ -1,12 +1,10 @@ -{- Temporarily changing the files git uses. +{- Temporarily changing how git-annex runs git commands. - - Copyright 2014-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE CPP #-} - module Annex.GitOverlay ( module Annex.GitOverlay, AltIndexFile(..), @@ -22,13 +20,6 @@ import Git.Env import qualified Annex import qualified Annex.Queue -#ifndef mingw32_HOST_OS -import qualified Utility.LockFile.PidLock as PidF -import qualified Utility.LockPool.PidLock as PidP -import Utility.LockPool (dropLock) -import Utility.Env -import Config -#endif {- Runs an action using a different git index file. -} withIndexFile :: AltIndexFile -> (FilePath -> Annex a) -> Annex a @@ -134,65 +125,3 @@ , Annex.repoqueue = Just q } either E.throw return v - -{- Wrap around actions that may run a git-annex child process. - - - - When pid locking is in use, this tries to take the pid lock, and if - - successful, holds it while running the child process. The action - - is run with the Annex monad modified so git commands are run with - - an env var set, which prevents child git annex processes from t - - rying to take the pid lock themselves. - - - - This way, any locking the parent does will not get in the way of - - the child. The child is assumed to not do any locking that conflicts - - with the parent, but if it did happen to do that, it would be noticed - - when git-annex is used without pid locking. - -} -runsGitAnnexChildProcess :: Annex a -> Annex a -#ifndef mingw32_HOST_OS -runsGitAnnexChildProcess a = pidLockFile >>= \case - Nothing -> a - Just pidlock -> bracket (setup pidlock) cleanup (go pidlock) - where - setup pidlock = liftIO $ PidP.tryLock pidlock - - cleanup (Just h) = liftIO $ dropLock h - cleanup Nothing = return () - - go _ Nothing = a - go pidlock (Just _h) = do - v <- liftIO $ PidF.pidLockEnv pidlock - let addenv g = do - g' <- liftIO $ addGitEnv g v "1" - return (g', ()) - let rmenv oldg g - | any (\(k, _) -> k == v) (fromMaybe [] (Git.gitEnv oldg)) = g - | otherwise = - let e' = case Git.gitEnv g of - Just e -> Just (delEntry v e) - Nothing -> Nothing - in g { Git.gitEnv = e' } - withAltRepo addenv rmenv (const a) -#else -runsGitAnnexChildProcess a = a -#endif - -runsGitAnnexChildProcess' :: Git.Repo -> (Git.Repo -> IO a) -> Annex a -#ifndef mingw32_HOST_OS -runsGitAnnexChildProcess' r a = pidLockFile >>= \case - Nothing -> liftIO $ a r - Just pidlock -> liftIO $ bracket (setup pidlock) cleanup (go pidlock) - where - setup pidlock = PidP.tryLock pidlock - - cleanup (Just h) = dropLock h - cleanup Nothing = return () - - go _ Nothing = a r - go pidlock (Just _h) = do - v <- PidF.pidLockEnv pidlock - r' <- addGitEnv r v "1" - a r' -#else -runsGitAnnexChildProcess' r a = liftIO $ a r -#endif diff --git a/Annex/Import.hs b/Annex/Import.hs --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -35,6 +35,7 @@ import Annex.Export import Annex.RemoteTrackingBranch import Annex.HashObject +import Annex.Transfer import Command import Backend import Types.Key @@ -411,8 +412,13 @@ const runimport dodownload cidmap db (loc, (cid, sz)) largematcher = do + f <- locworktreefile loc + let af = AssociatedFile (Just f) let downloader tmpfile p = do - k <- Remote.retrieveExportWithContentIdentifier ia loc cid tmpfile (mkkey loc tmpfile largematcher) p + k <- Remote.retrieveExportWithContentIdentifier + ia loc cid tmpfile + (mkkey f tmpfile largematcher) + p case keyGitSha k of Nothing -> do ok <- moveAnnex k tmpfile @@ -431,16 +437,17 @@ warning (show e) return Nothing checkDiskSpaceToGet tmpkey Nothing $ - withTmp tmpkey $ \tmpfile -> - metered Nothing tmpkey $ - const (rundownload tmpfile) + notifyTransfer Download af $ + download (Remote.uuid remote) tmpkey af stdRetry $ \p -> + withTmp tmpkey $ \tmpfile -> + metered (Just p) tmpkey $ + const (rundownload tmpfile) where tmpkey = importKey cid sz - + ia = Remote.importActions remote - mkkey loc tmpfile largematcher = do - f <- fromRepo $ fromTopFilePath $ locworktreefilename loc + mkkey f tmpfile largematcher = do matcher <- largematcher (fromRawFilePath f) let mi = MatchingFile FileInfo { matchFile = f @@ -458,10 +465,11 @@ fst <$> genKey ks nullMeterUpdate backend else gitShaKey <$> hashFile tmpfile - locworktreefilename loc = asTopFilePath $ case importtreeconfig of - ImportTree -> fromImportLocation loc - ImportSubTree subdir _ -> - getTopFilePath subdir P. fromImportLocation loc + locworktreefile loc = fromRepo $ fromTopFilePath $ asTopFilePath $ + case importtreeconfig of + ImportTree -> fromImportLocation loc + ImportSubTree subdir _ -> + getTopFilePath subdir P. fromImportLocation loc getcidkey cidmap db cid = liftIO $ CIDDb.getContentIdentifierKeys db rs cid >>= \case diff --git a/Annex/Init.hs b/Annex/Init.hs --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -37,7 +37,6 @@ import Annex.WorkTree import Annex.Fixup import Annex.Path -import Annex.GitOverlay import Config import Config.Files import Config.Smudge @@ -327,18 +326,18 @@ - The enabling is done in a child process to avoid it using stdio. -} autoEnableSpecialRemotes :: Annex () -autoEnableSpecialRemotes = runsGitAnnexChildProcess $ do +autoEnableSpecialRemotes = do rp <- fromRawFilePath <$> fromRepo Git.repoPath - cmd <- liftIO programPath - liftIO $ withNullHandle $ \nullh -> do - let p = (proc cmd - [ "init" - , "--autoenable" - ]) + withNullHandle $ \nullh -> gitAnnexChildProcess + [ "init" + , "--autoenable" + ] + (\p -> p { std_out = UseHandle nullh , std_err = UseHandle nullh , std_in = UseHandle nullh , cwd = Just rp } - withCreateProcess p $ \_ _ _ pid -> void $ waitForProcess pid + ) + (\_ _ _ pid -> void $ waitForProcess pid) remotesChanged diff --git a/Annex/Link.hs b/Annex/Link.hs --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -30,7 +30,7 @@ import Git.Config import Annex.HashObject import Annex.InodeSentinal -import Annex.GitOverlay +import Annex.PidLock import Utility.FileMode import Utility.InodeCache import Utility.Tmp.Dir @@ -218,7 +218,7 @@ [ Param "-c" , Param $ "core.safecrlf=" ++ boolConfig False ] } - runsGitAnnexChildProcess' r'' $ \r''' -> + runsGitAnnexChildProcessViaGit' r'' $ \r''' -> liftIO $ Git.UpdateIndex.refreshIndex r''' $ \feed -> forM_ l $ \(f', checkunmodified) -> whenM checkunmodified $ diff --git a/Annex/LockPool/PosixOrPid.hs b/Annex/LockPool/PosixOrPid.hs --- a/Annex/LockPool/PosixOrPid.hs +++ b/Annex/LockPool/PosixOrPid.hs @@ -1,7 +1,7 @@ {- Wraps Utility.LockPool, making pid locks be used when git-annex is so - configured. - - - Copyright 2015 Joey Hess + - Copyright 2015-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -31,6 +31,7 @@ import Utility.LockPool.STM (LockFile) import Utility.LockFile.LockStatus import Config (pidLockFile) +import Messages (warning) import System.Posix @@ -72,9 +73,8 @@ go Nothing = liftIO posixlock go (Just pidlock) = do timeout <- annexPidLockTimeout <$> Annex.getGitConfig - liftIO $ do - dummyPosixLock m f - Pid.waitLock timeout pidlock + liftIO $ dummyPosixLock m f + Pid.waitLock timeout pidlock warning tryPidLock :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle) -> Annex (Maybe LockHandle) tryPidLock m f posixlock = debugLocks $ liftIO . go =<< pidLockFile diff --git a/Annex/Path.hs b/Annex/Path.hs --- a/Annex/Path.hs +++ b/Annex/Path.hs @@ -1,15 +1,16 @@ {- git-annex program path - - - Copyright 2013 Joey Hess + - Copyright 2013-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Path where -import Common +import Annex.Common import Config.Files import Utility.Env +import Annex.PidLock import System.Environment (getExecutablePath) @@ -45,3 +46,19 @@ cannotFindProgram = do f <- programFile giveup $ "cannot find git-annex program in PATH or in " ++ f + +{- Runs a git-annex child process. + - + - Like runsGitAnnexChildProcessViaGit, when pid locking is in use, + - this takes the pid lock, while running it, and sets an env var + - that prevents the child process trying to take the pid lock, + - to avoid it deadlocking. + -} +gitAnnexChildProcess + :: [String] + -> (CreateProcess -> CreateProcess) + -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) + -> Annex a +gitAnnexChildProcess ps f a = do + cmd <- liftIO programPath + pidLockChildProcess cmd ps f a diff --git a/Annex/Perms.hs b/Annex/Perms.hs --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -9,6 +9,7 @@ FileMode, setAnnexFilePerm, setAnnexDirPerm, + resetAnnexFilePerm, annexFileMode, createAnnexDirectory, createWorkTreeDirectory, @@ -42,23 +43,49 @@ {- Sets appropriate file mode for a file or directory in the annex, - other than the content files and content directory. Normally, - - use the default mode, but with core.sharedRepository set, + - don't change the mode, but with core.sharedRepository set, - allow the group to write, etc. -} setAnnexPerm :: Bool -> FilePath -> Annex () -setAnnexPerm isdir file = unlessM crippledFileSystem $ +setAnnexPerm = setAnnexPerm' Nothing + +setAnnexPerm' :: Maybe ([FileMode] -> FileMode -> FileMode) -> Bool -> FilePath -> Annex () +setAnnexPerm' modef isdir file = unlessM crippledFileSystem $ withShared $ liftIO . go where - go GroupShared = void $ tryIO $ modifyFileMode file $ addModes $ + go GroupShared = void $ tryIO $ modifyFileMode file $ modef' $ groupSharedModes ++ if isdir then [ ownerExecuteMode, groupExecuteMode ] else [] - go AllShared = void $ tryIO $ modifyFileMode file $ addModes $ + go AllShared = void $ tryIO $ modifyFileMode file $ modef' $ readModes ++ [ ownerWriteMode, groupWriteMode ] ++ if isdir then executeModes else [] - go _ = noop + go _ = case modef of + Nothing -> noop + Just f -> void $ tryIO $ + modifyFileMode file $ f [] + modef' = fromMaybe addModes modef +resetAnnexFilePerm :: FilePath -> Annex () +resetAnnexFilePerm = resetAnnexPerm False + +{- Like setAnnexPerm, but ignores the current mode of the file entirely, + - and sets the same mode that the umask would result in when creating a + - new file. + - + - Useful eg, after creating a temporary file with locked down modes, + - which is going to be moved to a non-temporary location and needs + - usual modes. + -} +resetAnnexPerm :: Bool -> FilePath -> Annex () +resetAnnexPerm isdir file = unlessM crippledFileSystem $ do + defmode <- liftIO defaultFileMode + let modef moremodes _oldmode = addModes moremodes defmode + setAnnexPerm' (Just modef) isdir file + {- Gets the appropriate mode to use for creating a file in the annex - - (other than content files, which are locked down more). -} + - (other than content files, which are locked down more). The umask is not + - taken into account; this is for use with actions that create the file + - and apply the umask automatically. -} annexFileMode :: Annex FileMode annexFileMode = withShared $ return . go where diff --git a/Annex/PidLock.hs b/Annex/PidLock.hs new file mode 100644 --- /dev/null +++ b/Annex/PidLock.hs @@ -0,0 +1,127 @@ +{- Pid locking support. + - + - Copyright 2014-2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.PidLock where + +import Annex.Common +import Annex.GitOverlay +import Git +import Git.Env +#ifndef mingw32_HOST_OS +import qualified Utility.LockFile.PidLock as PidF +import qualified Utility.LockPool.PidLock as PidP +import Utility.LockPool (dropLock) +import Utility.Env +import Config +#endif + +{- When pid locking is in use, this tries to take the pid lock (unless + - the process already has it), and if successful, holds it while + - running the child process. The child process is run with an env var + - set, which prevents it from trying to take the pid lock itself. + - + - This way, any locking the parent does will not get in the way of + - the child. The child is assumed to not do any locking that conflicts + - with the parent, but if it did happen to do that, it would be noticed + - when git-annex is used without pid locking. + - + - If another process is already holding the pid lock, the child process + - is still run, but without setting the env var, so it can try to take the + - pid lock itself, and fail however is appropriate for it in that + - situation. + -} +pidLockChildProcess + :: FilePath + -> [String] + -> (CreateProcess -> CreateProcess) + -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) + -> Annex a +pidLockChildProcess cmd ps f a = do + let p = f (proc cmd ps) + let gonopidlock = withCreateProcess p a +#ifndef mingw32_HOST_OS + pidLockFile >>= liftIO . \case + Nothing -> gonopidlock + Just pidlock -> bracket + (setup pidlock) + cleanup + (go gonopidlock p pidlock) + where + setup pidlock = PidP.tryLock pidlock + + cleanup (Just h) = dropLock h + cleanup Nothing = return () + + go gonopidlock _ _ Nothing = gonopidlock + go _ p pidlock (Just _h) = do + v <- PidF.pidLockEnv pidlock + baseenv <- case env p of + Nothing -> getEnvironment + Just baseenv -> pure baseenv + let p' = p { env = Just ((v, PidF.pidLockEnvValue) : baseenv) } + withCreateProcess p' a +#else + gonopidlock +#endif + +{- Wrap around actions that may run a git-annex child process via a git + - command. + - + - This is like pidLockChildProcess, but rather than running a process + - itself, it runs the action with a modified Annex state that passes the + - necessary env var. + -} +runsGitAnnexChildProcessViaGit :: Annex a -> Annex a +#ifndef mingw32_HOST_OS +runsGitAnnexChildProcessViaGit a = pidLockFile >>= \case + Nothing -> a + Just pidlock -> bracket (setup pidlock) cleanup (go pidlock) + where + setup pidlock = liftIO $ PidP.tryLock pidlock + + cleanup (Just h) = liftIO $ dropLock h + cleanup Nothing = return () + + go _ Nothing = a + go pidlock (Just _h) = do + v <- liftIO $ PidF.pidLockEnv pidlock + let addenv g = do + g' <- liftIO $ addGitEnv g v PidF.pidLockEnvValue + return (g', ()) + let rmenv oldg g + | any (\(k, _) -> k == v) (fromMaybe [] (Git.gitEnv oldg)) = g + | otherwise = + let e' = case Git.gitEnv g of + Just e -> Just (delEntry v e) + Nothing -> Nothing + in g { Git.gitEnv = e' } + withAltRepo addenv rmenv (const a) +#else +runsGitAnnexChildProcessViaGit a = a +#endif + +runsGitAnnexChildProcessViaGit' :: Git.Repo -> (Git.Repo -> IO a) -> Annex a +#ifndef mingw32_HOST_OS +runsGitAnnexChildProcessViaGit' r a = pidLockFile >>= \case + Nothing -> liftIO $ a r + Just pidlock -> liftIO $ bracket (setup pidlock) cleanup (go pidlock) + where + setup pidlock = PidP.tryLock pidlock + + cleanup (Just h) = dropLock h + cleanup Nothing = return () + + go _ Nothing = a r + go pidlock (Just _h) = do + v <- PidF.pidLockEnv pidlock + r' <- addGitEnv r v PidF.pidLockEnvValue + a r' +#else +runsGitAnnexChildProcessViaGit' r a = liftIO $ a r +#endif diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -1,6 +1,6 @@ {- git-annex transfers - - - Copyright 2012-2019 Joey Hess + - Copyright 2012-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -81,7 +81,6 @@ runTransfer' :: Observable v => Bool -> Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v runTransfer' ignorelock t afile retrydecider transferaction = enteringStage TransferStage $ debugLocks $ checkSecureHashes t $ do - shouldretry <- retrydecider info <- liftIO $ startTransferInfo afile (meter, tfile, createtfile, metervar) <- mkProgressUpdater t info mode <- annexFileMode @@ -91,7 +90,7 @@ showNote "transfer already in progress, or unable to take transfer lock" return observeFailure else do - v <- retry shouldretry info metervar $ transferaction meter + v <- retry 0 info metervar (transferaction meter) liftIO $ cleanup tfile lck if observeBool v then removeFailedTransfer t @@ -142,21 +141,25 @@ dropLock lockhandle void $ tryIO $ removeFile lck #endif - retry shouldretry oldinfo metervar run = tryNonAsync run >>= \case - Right v - | observeBool v -> return v - | otherwise -> checkretry - Left e -> do - warning (show e) - checkretry + + retry numretries oldinfo metervar run = + tryNonAsync run >>= \case + Right v + | observeBool v -> return v + | otherwise -> checkretry + Left e -> do + warning (show e) + checkretry where checkretry = do b <- getbytescomplete metervar let newinfo = oldinfo { bytesComplete = Just b } - ifM (shouldretry oldinfo newinfo) - ( retry shouldretry newinfo metervar run + let !numretries' = succ numretries + ifM (retrydecider numretries' oldinfo newinfo) + ( retry numretries' newinfo metervar run , return observeFailure ) + getbytescomplete metervar | transferDirection t == Upload = liftIO $ readMVar metervar @@ -189,45 +192,57 @@ where variety = fromKey keyVariety (transferKey t) -type RetryDecider = Annex (TransferInfo -> TransferInfo -> Annex Bool) +type NumRetries = Integer -{- The first RetryDecider will be checked first; only if it says not to - - retry will the second one be checked. -} +type RetryDecider = NumRetries -> TransferInfo -> TransferInfo -> Annex Bool + +{- Both retry deciders are checked together, so if one chooses to delay, + - it will always take effect. -} combineRetryDeciders :: RetryDecider -> RetryDecider -> RetryDecider -combineRetryDeciders a b = do - ar <- a - br <- b - return $ \old new -> ar old new <||> br old new +combineRetryDeciders a b = \n old new -> do + ar <- a n old new + br <- b n old new + return (ar || br) noRetry :: RetryDecider -noRetry = pure $ \_ _ -> pure False +noRetry _ _ _ = pure False stdRetry :: RetryDecider stdRetry = combineRetryDeciders forwardRetry configuredRetry -{- Retries a transfer when it fails, as long as the failed transfer managed - - to send some data. -} +{- Keep retrying failed transfers, as long as forward progress is being + - made. + - + - Up to a point -- while some remotes can resume where the previous + - transfer left off, and so it would make sense to keep retrying forever, + - other remotes restart each transfer from the beginning, and so even if + - forward progress is being made, it's not real progress. So, retry a + - maximum of 5 times by default. + -} forwardRetry :: RetryDecider -forwardRetry = pure $ \old new -> pure $ - fromMaybe 0 (bytesComplete old) < fromMaybe 0 (bytesComplete new) +forwardRetry numretries old new + | fromMaybe 0 (bytesComplete old) < fromMaybe 0 (bytesComplete new) = + (numretries <=) <$> maybe globalretrycfg pure remoteretrycfg + | otherwise = return False + where + globalretrycfg = fromMaybe 5 . annexForwardRetry + <$> Annex.getGitConfig + remoteretrycfg = remoteAnnexRetry =<< + (Remote.gitconfig <$> transferRemote new) {- Retries a number of times with growing delays in between when enabled - by git configuration. -} configuredRetry :: RetryDecider -configuredRetry = debugLocks $ do - retrycounter <- liftIO $ newMVar 0 - return $ \_old new -> do - (maxretries, Seconds initretrydelay) <- getcfg $ - Remote.gitconfig <$> transferRemote new - retries <- liftIO $ modifyMVar retrycounter $ - \n -> return (n + 1, n + 1) - if retries < maxretries - then do - let retrydelay = Seconds (initretrydelay * 2^(retries-1)) - showSideAction $ "Delaying " ++ show (fromSeconds retrydelay) ++ "s before retrying." - liftIO $ threadDelaySeconds retrydelay - return True - else return False +configuredRetry numretries _old new = do + (maxretries, Seconds initretrydelay) <- getcfg $ + Remote.gitconfig <$> transferRemote new + if numretries < maxretries + then do + let retrydelay = Seconds (initretrydelay * 2^(numretries-1)) + showSideAction $ "Delaying " ++ show (fromSeconds retrydelay) ++ "s before retrying." + liftIO $ threadDelaySeconds retrydelay + return True + else return False where globalretrycfg = fromMaybe 0 . annexRetry <$> Annex.getGitConfig diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -159,8 +159,10 @@ let keyline = authorizedKeysLine gitannexshellonly dir pubkey sshdir <- sshDir let keyfile = sshdir "authorized_keys" - ls <- lines <$> readFileStrict keyfile - viaTmp writeSshConfig keyfile $ unlines $ filter (/= keyline) ls + tryWhenExists (lines <$> readFileStrict keyfile) >>= \case + Just ls -> viaTmp writeSshConfig keyfile $ + unlines $ filter (/= keyline) ls + Nothing -> noop {- Implemented as a shell command, so it can be run on remote servers over - ssh. diff --git a/Assistant/WebApp/Configurators/AWS.hs b/Assistant/WebApp/Configurators/AWS.hs --- a/Assistant/WebApp/Configurators/AWS.hs +++ b/Assistant/WebApp/Configurators/AWS.hs @@ -5,18 +5,16 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-} module Assistant.WebApp.Configurators.AWS where import Assistant.WebApp.Common import Assistant.WebApp.MakeRemote -#ifdef WITH_S3 import qualified Remote.S3 as S3 import Logs.Remote import qualified Remote import qualified Types.Remote as Remote -#endif import qualified Remote.Glacier as Glacier import qualified Remote.Helper.AWS as AWS import Types.Remote (RemoteConfig) @@ -120,7 +118,6 @@ getAddS3R = postAddS3R postAddS3R :: Handler Html -#ifdef WITH_S3 postAddS3R = awsConfigurator $ do defcreds <- liftAnnex previouslyUsedAWSCreds ((result, form), enctype) <- liftH $ @@ -136,15 +133,11 @@ , (Proposed "chunk", Proposed "1MiB") ] _ -> $(widgetFile "configurators/adds3") -#else -postAddS3R = giveup "S3 not supported by this build" -#endif getAddGlacierR :: Handler Html getAddGlacierR = postAddGlacierR postAddGlacierR :: Handler Html -#ifdef WITH_S3 postAddGlacierR = glacierConfigurator $ do defcreds <- liftAnnex previouslyUsedAWSCreds ((result, form), enctype) <- liftH $ @@ -158,12 +151,8 @@ , (Proposed "datacenter", Proposed $ T.unpack $ datacenter input) ] _ -> $(widgetFile "configurators/addglacier") -#else -postAddGlacierR = giveup "S3 not supported by this build" -#endif getEnableS3R :: UUID -> Handler Html -#ifdef WITH_S3 getEnableS3R uuid = do m <- liftAnnex readRemoteLog isia <- case M.lookup uuid m of @@ -174,16 +163,9 @@ if isia then redirect $ EnableIAR uuid else postEnableS3R uuid -#else -getEnableS3R = postEnableS3R -#endif postEnableS3R :: UUID -> Handler Html -#ifdef WITH_S3 postEnableS3R uuid = awsConfigurator $ enableAWSRemote S3.remote uuid -#else -postEnableS3R _ = giveup "S3 not supported by this build" -#endif getEnableGlacierR :: UUID -> Handler Html getEnableGlacierR = postEnableGlacierR @@ -192,7 +174,6 @@ postEnableGlacierR = glacierConfigurator . enableAWSRemote Glacier.remote enableAWSRemote :: RemoteType -> UUID -> Widget -#ifdef WITH_S3 enableAWSRemote remotetype uuid = do defcreds <- liftAnnex previouslyUsedAWSCreds ((result, form), enctype) <- liftH $ @@ -207,9 +188,6 @@ description <- liftAnnex $ T.pack <$> Remote.prettyUUID uuid $(widgetFile "configurators/enableaws") -#else -enableAWSRemote _ _ = giveup "S3 not supported by this build" -#endif makeAWSRemote :: SpecialRemoteMaker -> RemoteType -> StandardGroup -> AWSCreds -> RemoteName -> RemoteConfig -> Handler () makeAWSRemote maker remotetype defaultgroup (AWSCreds ak sk) name config = @@ -228,10 +206,8 @@ where bucket = maybe "" fromProposedAccepted $ M.lookup (Accepted "bucket") c -#ifdef WITH_S3 previouslyUsedAWSCreds :: Annex (Maybe CredPair) previouslyUsedAWSCreds = getM gettype [S3.remote, Glacier.remote] where gettype t = previouslyUsedCredPair AWS.creds t $ not . S3.configIA . Remote.config -#endif diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} module Assistant.WebApp.Configurators.Edit where @@ -19,10 +19,8 @@ import Assistant.Sync import Assistant.Alert import qualified Assistant.WebApp.Configurators.AWS as AWS -#ifdef WITH_S3 import qualified Assistant.WebApp.Configurators.IA as IA import qualified Remote.S3 as S3 -#endif import qualified Remote import qualified Types.Remote as Remote import Remote.List.Util @@ -256,14 +254,10 @@ getRepoInfo :: Maybe Remote.Remote -> Remote.RemoteConfig -> Widget getRepoInfo (Just r) c = case fromProposedAccepted <$> M.lookup typeField c of Just "S3" -> do -#ifdef WITH_S3 pc <- liftAnnex $ parsedRemoteConfig S3.remote c if S3.configIA pc then IA.getRepoInfo c else AWS.getRepoInfo c -#else - AWS.getRepoInfo c -#endif Just t | t /= "git" -> [whamlet|#{t} remote|] _ -> getGitRepoInfo =<< liftAnnex (Remote.getRepo r) diff --git a/Assistant/WebApp/Configurators/IA.hs b/Assistant/WebApp/Configurators/IA.hs --- a/Assistant/WebApp/Configurators/IA.hs +++ b/Assistant/WebApp/Configurators/IA.hs @@ -5,13 +5,12 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-} module Assistant.WebApp.Configurators.IA where import Assistant.WebApp.Common import qualified Assistant.WebApp.Configurators.AWS as AWS -#ifdef WITH_S3 import qualified Remote.S3 as S3 import qualified Remote.Helper.AWS as AWS import Assistant.WebApp.MakeRemote @@ -20,7 +19,6 @@ import Types.StandardGroups import Logs.Remote import Assistant.Gpg -#endif import Types.Remote (RemoteConfig) import qualified Annex.Url as Url import Creds @@ -106,11 +104,9 @@ <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds) <*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds) -#ifdef WITH_S3 previouslyUsedIACreds :: Annex (Maybe CredPair) previouslyUsedIACreds = previouslyUsedCredPair AWS.creds S3.remote $ S3.configIA . Remote.config -#endif accessKeyIDFieldWithHelp :: Maybe Text -> MkAForm Text accessKeyIDFieldWithHelp = AWS.accessKeyIDField help @@ -124,7 +120,6 @@ getAddIAR = postAddIAR postAddIAR :: Handler Html -#ifdef WITH_S3 postAddIAR = iaConfigurator $ do defcreds <- liftAnnex previouslyUsedIACreds ((result, form), enctype) <- liftH $ @@ -149,21 +144,13 @@ AWS.makeAWSRemote initSpecialRemote S3.remote PublicGroup (extractCreds input) name $ M.fromList $ configureEncryption NoEncryption : c _ -> $(widgetFile "configurators/addia") -#else -postAddIAR = giveup "S3 not supported by this build" -#endif getEnableIAR :: UUID -> Handler Html getEnableIAR = postEnableIAR postEnableIAR :: UUID -> Handler Html -#ifdef WITH_S3 postEnableIAR = iaConfigurator . enableIARemote -#else -postEnableIAR _ = giveup "S3 not supported by this build" -#endif -#ifdef WITH_S3 enableIARemote :: UUID -> Widget enableIARemote uuid = do defcreds <- liftAnnex previouslyUsedIACreds @@ -179,7 +166,6 @@ description <- liftAnnex $ T.pack <$> Remote.prettyUUID uuid $(widgetFile "configurators/enableia") -#endif {- Convert a description into a bucket item name, which will also be - used as the repository name, and the preferreddir. @@ -205,9 +191,4 @@ |] where bucket = maybe "" fromProposedAccepted $ M.lookup (Accepted "bucket") c -#ifdef WITH_S3 url = S3.iaItemUrl bucket -#else - url = case bucket of - _ -> "" -#endif diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs --- a/Assistant/WebApp/Configurators/WebDAV.hs +++ b/Assistant/WebApp/Configurators/WebDAV.hs @@ -5,13 +5,12 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE CPP, TemplateHaskell, OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} module Assistant.WebApp.Configurators.WebDAV where import Assistant.WebApp.Common import Creds -#ifdef WITH_WEBDAV import qualified Remote.WebDAV as WebDAV import Assistant.WebApp.MakeRemote import qualified Remote @@ -25,7 +24,6 @@ import Types.ProposedAccepted import qualified Data.Map as M -#endif import qualified Data.Text as T import Network.URI @@ -54,7 +52,6 @@ getEnableWebDAVR :: UUID -> Handler Html getEnableWebDAVR = postEnableWebDAVR postEnableWebDAVR :: UUID -> Handler Html -#ifdef WITH_WEBDAV postEnableWebDAVR uuid = do m <- liftAnnex readRemoteLog let c = fromJust $ M.lookup uuid m @@ -83,11 +80,7 @@ description <- liftAnnex $ T.pack <$> Remote.prettyUUID uuid $(widgetFile "configurators/enablewebdav") -#else -postEnableWebDAVR _ = giveup "WebDAV not supported by this build" -#endif -#ifdef WITH_WEBDAV makeWebDavRemote :: SpecialRemoteMaker -> RemoteName -> CredPair -> RemoteConfig -> Handler () makeWebDavRemote maker name creds c = setupCloudRemote TransferGroup Nothing $ @@ -101,7 +94,6 @@ samehost r = case urlHost =<< WebDAV.configUrl (config r) of Nothing -> False Just h -> h == hostname -#endif urlHost :: String -> Maybe String urlHost url = uriRegName <$> (uriAuthority =<< parseURI url) diff --git a/Assistant/WebApp/RepoList.hs b/Assistant/WebApp/RepoList.hs --- a/Assistant/WebApp/RepoList.hs +++ b/Assistant/WebApp/RepoList.hs @@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings, CPP #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-} module Assistant.WebApp.RepoList where @@ -179,13 +179,9 @@ findinfo m g u = case fromProposedAccepted <$> getconfig (Accepted "type") of Just "rsync" -> val True EnableRsyncR Just "directory" -> val False EnableDirectoryR -#ifdef WITH_S3 Just "S3" -> val True EnableS3R -#endif Just "glacier" -> val True EnableGlacierR -#ifdef WITH_WEBDAV Just "webdav" -> val True EnableWebDAVR -#endif Just "gcrypt" -> -- Skip gcrypt repos on removable drives; -- handled separately. diff --git a/Backend/External.hs b/Backend/External.hs --- a/Backend/External.hs +++ b/Backend/External.hs @@ -132,13 +132,13 @@ withExternalAddon st whenunavail $ \p -> do sendMessage p req let loop = receiveResponse p responsehandler - (Just . handleAsyncMessage loop) + (Just . handleExceptionalMessage loop) loop where - handleAsyncMessage _ (ERROR err) = do + handleExceptionalMessage _ (ERROR err) = do warning ("external special remote error: " ++ err) whenunavail - handleAsyncMessage loop (DEBUG msg) = do + handleExceptionalMessage loop (DEBUG msg) = do liftIO $ debugM "external" msg loop @@ -174,9 +174,9 @@ receiveResponse :: ExternalAddonProcess -> ResponseHandler a - -> (AsyncMessage -> Maybe (Annex a)) + -> (ExceptionalMessage -> Maybe (Annex a)) -> Annex a -receiveResponse p handleresponse handleasync = +receiveResponse p handleresponse handleexceptional = go =<< liftIO (catchMaybeIO $ hGetLine $ externalReceive p) where go Nothing = protocolError False "" @@ -188,9 +188,9 @@ Just callback -> callback >>= \case Result a -> return a GetNextMessage handleresponse' -> - receiveResponse p handleresponse' handleasync - Nothing -> case Proto.parseMessage s :: Maybe AsyncMessage of - Just msg -> maybe (protocolError True s) id (handleasync msg) + receiveResponse p handleresponse' handleexceptional + Nothing -> case Proto.parseMessage s :: Maybe ExceptionalMessage of + Just msg -> maybe (protocolError True s) id (handleexceptional msg) Nothing -> protocolError False s protocolError parsed s = giveup $ "external backend protocol error, unexpectedly received \"" ++ s ++ "\" " ++ @@ -321,7 +321,7 @@ | PROGRESS BytesProcessed deriving (Show) -data AsyncMessage +data ExceptionalMessage = ERROR ErrorMsg | DEBUG String deriving (Show) @@ -338,11 +338,11 @@ serialize (ProtocolVersion n) = show n deserialize = ProtocolVersion <$$> readish -instance Proto.Sendable AsyncMessage where +instance Proto.Sendable ExceptionalMessage where formatMessage (ERROR err) = ["ERROR", Proto.serialize err] formatMessage (DEBUG msg) = ["DEBUG", Proto.serialize msg] -instance Proto.Receivable AsyncMessage where +instance Proto.Receivable ExceptionalMessage where parseCommand "ERROR" = Proto.parse1 ERROR parseCommand "DEBUG" = Proto.parse1 DEBUG parseCommand _ = Proto.parseFail diff --git a/BuildFlags.hs b/BuildFlags.hs --- a/BuildFlags.hs +++ b/BuildFlags.hs @@ -31,16 +31,6 @@ #else #warning Building without local pairing. #endif -#ifdef WITH_S3 - , "S3" -#else -#warning Building without S3. -#endif -#ifdef WITH_WEBDAV - , "WebDAV" -#else -#warning Building without WebDAV. -#endif #ifdef WITH_INOTIFY , "Inotify" #endif @@ -69,6 +59,8 @@ -- listed. , "Feeds" , "Testsuite" + , "S3" + , "WebDAV" ] -- Not a complete list, let alone a listing transitive deps, but only @@ -81,12 +73,8 @@ , ("http-client", VERSION_http_client) , ("persistent-sqlite", VERSION_persistent_sqlite) , ("cryptonite", VERSION_cryptonite) -#ifdef WITH_S3 , ("aws", VERSION_aws) -#endif -#ifdef WITH_WEBDAV , ("DAV", VERSION_DAV) -#endif #ifdef WITH_TORRENTPARSER , ("torrent", VERSION_torrent) #endif diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,4 +1,48 @@ -git-annex (8.20200810) upstream; urgency=medium +git-annex (8.20200908) upstream; urgency=medium + + * Added httpalso special remote, which is useful for accessing + content stored on other remotes that is published by http. + * The external special remote protocol got an ASYNC extension. + This can be used by an external special remote to let a single process + perform concurrent actions, rather than multiple processes being + started, when that is more efficient. + * Retry transfers to exporttree=yes remotes same as for other remotes. + * import: Retry downloads that fail, same as is done for downloads generally. + * Limit retrying of failed transfers when forward progress is being made + to 5, to avoid some unusual edge cases where too much retrying could + result in far more data transfer than makes sense. + * Exposed annex.forward-retry git config, to configure the forward retry + behavior that git-annex has had for a long time. + * sync, assistant, merge: When merge.directoryRenames is not set, + default it it to "false", which works better with automatic merge + conflict resolution than git's ususual default of "conflict". + (This is not done when automatic merge conflict resolution is disabled.) + * resolvemerge: Improve cleanup of cruft left in the working tree + by a conflicted merge. + * Support git remotes where .git is a file, not a directory, + eg when --separate-git-dir was used. + * Fixed several cases where files were created without file mode bits + that the umask would usually set. This included exports to the + directory special remote, torrent files used by the bittorrent special + remote, hooks written by git-annex init, and some log files in .git/annex/ + * Fix reversion in 7.20190322 that made addurl --file not be honored + when youtube-dl was used to download media. + * Fix reversion in 8.20200617 that made annex.pidlock being enabled + result in some commands stalling, particularly those needing to + autoinit. + * Display warning when external special remote does not start up + properly, or is not usable. + * Display a message when git-annex has to wait for a pid lock file + held by another process. + * test: Stop gpg-agent daemons that are started for the test framework's + gpg key. + * Removed the S3 and WebDAV build flags so these special remotes are + always supported. + * stack.yaml: Updated to lts-16.10. + + -- Joey Hess Tue, 08 Sep 2020 14:20:11 -0400 + +git-annex (8.20200814) upstream; urgency=medium * Added support for external backend programs. So if you want a hash that git-annex doesn't support, or something stranger, you can write a diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -286,7 +286,7 @@ <> help "match files the repository wants to drop" <> hidden ) - , globalSetter Limit.addAccessedWithin $ option (str >>= parseDuration) + , globalSetter Limit.addAccessedWithin $ option (eitherReader parseDuration) ( long "accessedwithin" <> metavar paramTime <> help "match files accessed within a time interval" @@ -403,7 +403,7 @@ timeLimitOption :: [GlobalOption] timeLimitOption = - [ globalSetter Limit.addTimeLimit $ option (str >>= parseDuration) + [ globalSetter Limit.addTimeLimit $ option (eitherReader parseDuration) ( long "time-limit" <> short 'T' <> metavar paramTime <> help "stop after the specified amount of time" <> hidden diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -304,8 +304,6 @@ urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing downloader f p = Url.withUrlOptions $ downloadUrl urlkey p [url] f go Nothing = return Nothing - -- If we downloaded a html file, try to use youtube-dl to - -- extract embedded media. go (Just tmp) = ifM (pure (not (rawOption o)) <&&> liftIO (isHtml <$> readFile tmp)) ( tryyoutubedl tmp , normalfinish tmp @@ -314,21 +312,15 @@ showDestinationFile file createWorkTreeDirectory (parentDir file) Just <$> finishDownloadWith addunlockedmatcher tmp webUUID url file - tryyoutubedl tmp - -- Ask youtube-dl what filename it will download - -- first, and check if that is already an annexed file, - -- to avoid unnecessary work in that case. - | otherwise = youtubeDlFileNameHtmlOnly url >>= \case - Right dest -> ifAnnexed (toRawFilePath dest) - (alreadyannexed dest) - (dl dest) - Left _ -> normalfinish tmp - -- Ask youtube-dl what filename it will download - -- fist, so it's only used when the file contains embedded - -- media. - | isJust (fileOption o) = youtubeDlFileNameHtmlOnly url >>= \case - Right _ -> dl file - Left _ -> normalfinish tmp + -- Ask youtube-dl what filename it will download first, + -- so it's only used when the file contains embedded media. + tryyoutubedl tmp = youtubeDlFileNameHtmlOnly url >>= \case + Right mediafile -> + let f = youtubeDlDestFile o file mediafile + in ifAnnexed (toRawFilePath f) + (alreadyannexed f) + (dl f) + Left _ -> normalfinish tmp where dl dest = withTmpWorkDir mediakey $ \workdir -> do let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . nukeFile) @@ -467,12 +459,15 @@ let key = Backend.URL.fromUrl url (Url.urlSize urlinfo) nodownloadWeb' addunlockedmatcher url key file usemedia mediafile = do - let dest = if isJust (fileOption o) - then file - else takeFileName mediafile + let dest = youtubeDlDestFile o file mediafile let mediaurl = setDownloader url YoutubeDownloader let mediakey = Backend.URL.fromUrl mediaurl Nothing nodownloadWeb' addunlockedmatcher mediaurl mediakey dest + +youtubeDlDestFile :: DownloadOptions -> FilePath -> FilePath -> FilePath +youtubeDlDestFile o destfile mediafile + | isJust (fileOption o) = destfile + | otherwise = takeFileName mediafile nodownloadWeb' :: AddUnlockedMatcher -> URLString -> Key -> FilePath -> Annex (Maybe Key) nodownloadWeb' addunlockedmatcher url key file = checkCanAdd file $ do diff --git a/Command/Assistant.hs b/Command/Assistant.hs --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -39,7 +39,7 @@ ( long "autostart" <> help "start in known repositories" ) - <*> optional (option (str >>= parseDuration) + <*> optional (option (eitherReader parseDuration) ( long "startdelay" <> metavar paramNumber <> help "delay before running startup scan" )) diff --git a/Command/Expire.hs b/Command/Expire.hs --- a/Command/Expire.hs +++ b/Command/Expire.hs @@ -103,8 +103,8 @@ return (Just r, parsetime now t) parsetime _ "never" = Nothing parsetime now s = case parseDuration s of - Nothing -> giveup $ "bad expire time: " ++ s - Just d -> Just (now - durationToPOSIXTime d) + Right d -> Just (now - durationToPOSIXTime d) + Left e -> giveup $ "bad expire time: " ++ e parseActivity :: MonadFail m => String -> m Activity parseActivity s = case readish s of diff --git a/Command/Export.hs b/Command/Export.hs --- a/Command/Export.hs +++ b/Command/Export.hs @@ -281,9 +281,7 @@ sent <- tryNonAsync $ case ek of AnnexKey k -> ifM (inAnnex k) ( notifyTransfer Upload af $ - -- Using noRetry here because interrupted - -- exports cannot be resumed. - upload (uuid r) k af noRetry $ \pm -> do + upload (uuid r) k af stdRetry $ \pm -> do let rollback = void $ performUnexport r db [ek] loc sendAnnex k rollback $ \f -> diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -81,7 +81,7 @@ ( long "more" <> short 'm' <> help "continue an incremental fsck" ) - <|> (ScheduleIncrementalO <$> option (str >>= parseDuration) + <|> (ScheduleIncrementalO <$> option (eitherReader parseDuration) ( long "incremental-schedule" <> metavar paramTime <> help "schedule incremental fscking" )) diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -65,7 +65,6 @@ import Annex.Export import Annex.TaggedPush import Annex.CurrentBranch -import Annex.GitOverlay import qualified Database.Export as Export import Utility.Bloom import Utility.OptParse @@ -269,13 +268,13 @@ ] merge :: CurrBranch -> [Git.Merge.MergeConfig] -> SyncOptions -> Git.Branch.CommitMode -> Git.Branch -> Annex Bool -merge currbranch mergeconfig o commitmode tomerge = case currbranch of - (Just b, Just adj) -> mergeToAdjustedBranch tomerge (b, adj) mergeconfig canresolvemerge commitmode - (b, _) -> autoMergeFrom tomerge b mergeconfig canresolvemerge commitmode - where - canresolvemerge = if resolveMergeOverride o +merge currbranch mergeconfig o commitmode tomerge = do + canresolvemerge <- if resolveMergeOverride o then getGitConfigVal annexResolveMerge else return False + case currbranch of + (Just b, Just adj) -> mergeToAdjustedBranch tomerge (b, adj) mergeconfig canresolvemerge commitmode + (b, _) -> autoMergeFrom tomerge b mergeconfig commitmode canresolvemerge syncBranch :: Git.Branch -> Git.Branch syncBranch = Git.Ref.underBase "refs/heads/synced" . fromAdjustedBranch @@ -515,10 +514,12 @@ postpushupdate repo = case Git.repoWorkTree repo of Nothing -> return True Just wt -> ifM needemulation - ( runsGitAnnexChildProcess $ liftIO $ do - p <- programPath - boolSystem' p [Param "post-receive"] - (\cp -> cp { cwd = Just (fromRawFilePath wt) }) + ( gitAnnexChildProcess ["post-receive"] + (\cp -> cp { cwd = Just (fromRawFilePath wt) }) + (\_ _ _ pid -> waitForProcess pid >>= return . \case + ExitSuccess -> True + _ -> False + ) , return True ) where diff --git a/Git/Construct.hs b/Git/Construct.hs --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -1,6 +1,6 @@ {- Construction of Git Repo objects - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -73,7 +73,7 @@ , ret (takeDirectory canondir) ) | otherwise = ifM (doesDirectoryExist dir) - ( ret dir + ( gitDirFile dir >>= maybe (ret dir) (pure . newFrom) -- git falls back to dir.git when dir doesn't -- exist, as long as dir didn't end with a -- path separator @@ -198,7 +198,7 @@ checkForRepo :: FilePath -> IO (Maybe RepoLocation) checkForRepo dir = check isRepo $ - check gitDirFile $ + check (gitDirFile dir) $ check isBareRepo $ return Nothing where @@ -217,21 +217,25 @@ 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 - then Just $ Local - { gitdir = toRawFilePath $ absPathFrom dir $ - drop (length gitdirprefix) c - , worktree = Just (toRawFilePath dir) - } - else Nothing - where - gitdirprefix = "gitdir: " gitSignature file = doesFileExist $ dir file + +-- git-submodule, git-worktree, and --separate-git-dir +-- make .git be a file pointing to the real git directory. +-- Detect that, and return a RepoLocation with gitdir pointing +-- to the real git directory. +gitDirFile :: FilePath -> IO (Maybe RepoLocation) +gitDirFile dir = do + c <- firstLine <$> + catchDefaultIO "" (readFile $ dir ".git") + return $ if gitdirprefix `isPrefixOf` c + then Just $ Local + { gitdir = toRawFilePath $ absPathFrom dir $ + drop (length gitdirprefix) c + , worktree = Just (toRawFilePath dir) + } + else Nothing + where + gitdirprefix = "gitdir: " newFrom :: RepoLocation -> Repo newFrom l = Repo diff --git a/Git/Merge.hs b/Git/Merge.hs --- a/Git/Merge.hs +++ b/Git/Merge.hs @@ -22,9 +22,9 @@ data MergeConfig = MergeNonInteractive - -- ^ avoids recent git's interactive merge + -- ^ avoids interactive merge | MergeUnrelatedHistories - -- ^ avoids recent git's prevention of merging unrelated histories + -- ^ avoids git's prevention of merging unrelated histories deriving (Eq) merge :: Ref -> [MergeConfig] -> CommitMode -> Repo -> IO Bool diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -202,6 +202,7 @@ else withOtherTmp $ \othertmp -> do withTmpFileIn othertmp "torrent" $ \f h -> do liftIO $ hClose h + resetAnnexFilePerm f ok <- Url.withUrlOptions $ Url.download nullMeterUpdate u f when ok $ diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -31,6 +31,7 @@ import Types.Import import qualified Remote.Directory.LegacyChunked as Legacy import Annex.Content +import Annex.Perms import Annex.UUID import Backend import Types.KeySource @@ -436,6 +437,7 @@ liftIO $ withMeteredFile src p (L.hPut tmph) liftIO $ hFlush tmph liftIO $ hClose tmph + resetAnnexFilePerm tmpf liftIO (getFileStatus tmpf) >>= liftIO . mkContentIdentifier tmpf >>= \case Nothing -> giveup "unable to generate content identifier" Just newcid -> do diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -6,13 +6,15 @@ -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} module Remote.External (remote) where import Remote.External.Types +import Remote.External.AsyncExtension import qualified Annex import Annex.Common -import Annex.ExternalAddonProcess +import qualified Annex.ExternalAddonProcess as AddonProcess import Types.Remote import Types.Export import Types.CleanupActions @@ -194,7 +196,7 @@ -- responding to INITREMOTE need to be applied to -- the RemoteConfig. changes <- withExternalState external $ - liftIO . atomically . readTVar . externalConfigChanges + liftIO . atomically . readTMVar . externalConfigChanges return (changes c') gitConfigSpecialRemote u c'' [("externaltype", externaltype)] @@ -396,7 +398,7 @@ loop loop = receiveMessage st external responsehandler (\rreq -> Just $ handleRemoteRequest rreq >> loop) - (\msg -> Just $ handleAsyncMessage msg >> loop) + (\msg -> Just $ handleExceptionalMessage msg >> loop) handleRemoteRequest (PROGRESS bytesprocessed) = maybe noop (\a -> liftIO $ a bytesprocessed) mp @@ -406,28 +408,28 @@ send $ VALUE $ fromRawFilePath $ hashDirLower def k handleRemoteRequest (SETCONFIG setting value) = liftIO $ atomically $ do - modifyTVar' (externalConfig st) $ \(ParsedRemoteConfig m c) -> - let m' = M.insert - (Accepted setting) - (RemoteConfigValue (PassedThrough value)) - m - c' = M.insert - (Accepted setting) - (Accepted value) - c - in ParsedRemoteConfig m' c' - modifyTVar' (externalConfigChanges st) $ \f -> - M.insert (Accepted setting) (Accepted value) . f + ParsedRemoteConfig m c <- takeTMVar (externalConfig st) + let !m' = M.insert + (Accepted setting) + (RemoteConfigValue (PassedThrough value)) + m + let !c' = M.insert + (Accepted setting) + (Accepted value) + c + putTMVar (externalConfig st) (ParsedRemoteConfig m' c') + f <- takeTMVar (externalConfigChanges st) + let !f' = M.insert (Accepted setting) (Accepted value) . f + putTMVar (externalConfigChanges st) f' handleRemoteRequest (GETCONFIG setting) = do value <- maybe "" fromProposedAccepted . (M.lookup (Accepted setting)) . unparsedRemoteConfig - <$> liftIO (atomically $ readTVar $ externalConfig st) + <$> liftIO (atomically $ readTMVar $ externalConfig st) send $ VALUE value handleRemoteRequest (SETCREDS setting login password) = case (externalUUID external, externalGitConfig external) of (Just u, Just gc) -> do - let v = externalConfig st - pc <- liftIO $ atomically $ readTVar v + pc <- liftIO $ atomically $ takeTMVar (externalConfig st) pc' <- setRemoteCredPair' pc encryptionAlreadySetup gc (credstorage setting u) (Just (login, password)) @@ -436,13 +438,14 @@ (unparsedRemoteConfig pc') (unparsedRemoteConfig pc) void $ liftIO $ atomically $ do - _ <- swapTVar v pc' - modifyTVar' (externalConfigChanges st) $ \f -> - M.union configchanges . f + putTMVar (externalConfig st) pc' + f <- takeTMVar (externalConfigChanges st) + let !f' = M.union configchanges . f + putTMVar (externalConfigChanges st) f' _ -> senderror "cannot send SETCREDS here" handleRemoteRequest (GETCREDS setting) = case (externalUUID external, externalGitConfig external) of (Just u, Just gc) -> do - c <- liftIO $ atomically $ readTVar $ externalConfig st + c <- liftIO $ atomically $ readTMVar $ externalConfig st creds <- fromMaybe ("", "") <$> getRemoteCredPair c gc (credstorage setting u) send $ CREDS (fst creds) (snd creds) @@ -487,7 +490,7 @@ handleRemoteRequest (INFO msg) = showInfo msg handleRemoteRequest (VERSION _) = senderror "too late to send VERSION" - handleAsyncMessage (ERROR err) = giveup $ "external special remote error: " ++ err + handleExceptionalMessage (ERROR err) = giveup $ "external special remote error: " ++ err send = sendMessage st senderror = sendMessage st . ERROR @@ -503,15 +506,27 @@ withurl mk uri = handleRemoteRequest $ mk $ setDownloader (show uri) OtherDownloader -sendMessage :: Sendable m => ExternalState -> m -> Annex () -sendMessage st m = liftIO $ do - protocolDebug (externalAddonProcess st) True line +sendMessage :: (Sendable m, ToAsyncWrapped m) => ExternalState -> m -> Annex () +sendMessage st m = liftIO $ externalSend st m + +sendMessageAddonProcess :: Sendable m => AddonProcess.ExternalAddonProcess -> m -> IO () +sendMessageAddonProcess p m = do + AddonProcess.protocolDebug p True line hPutStrLn h line hFlush h where + h = AddonProcess.externalSend p line = unwords $ formatMessage m - h = externalSend (externalAddonProcess st) +receiveMessageAddonProcess :: AddonProcess.ExternalAddonProcess -> IO (Maybe String) +receiveMessageAddonProcess p = do + v <- catchMaybeIO $ hGetLine $ AddonProcess.externalReceive p + maybe noop (AddonProcess.protocolDebug p False) v + return v + +shutdownAddonProcess :: AddonProcess.ExternalAddonProcess -> Bool -> IO () +shutdownAddonProcess = AddonProcess.externalShutdown + {- A response handler can yeild a result, or it can request that another - message be consumed from the external. -} data ResponseHandlerResult a @@ -532,30 +547,30 @@ -> External -> ResponseHandler a -> (RemoteRequest -> Maybe (Annex a)) - -> (AsyncMessage -> Maybe (Annex a)) + -> (ExceptionalMessage -> Maybe (Annex a)) -> Annex a -receiveMessage st external handleresponse handlerequest handleasync = - go =<< liftIO (catchMaybeIO $ hGetLine $ externalReceive $ externalAddonProcess st) +receiveMessage st external handleresponse handlerequest handleexceptional = + go =<< liftIO (externalReceive st) where - go Nothing = protocolError False "" - go (Just s) = do - liftIO $ protocolDebug (externalAddonProcess st) False s - case parseMessage s :: Maybe Response of - Just resp -> case handleresponse resp of - Nothing -> protocolError True s - Just callback -> callback >>= \case - Result a -> return a - GetNextMessage handleresponse' -> - receiveMessage st external handleresponse' handlerequest handleasync - Nothing -> case parseMessage s :: Maybe RemoteRequest of - Just req -> maybe (protocolError True s) id (handlerequest req) - Nothing -> case parseMessage s :: Maybe AsyncMessage of - Just msg -> maybe (protocolError True s) id (handleasync msg) - Nothing -> protocolError False s - protocolError parsed s = giveup $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\" " ++ - if parsed - then "(command not allowed at this time)" - else "(unable to parse command)" + go Nothing = protocolError False "" + go (Just s) = case parseMessage s :: Maybe Response of + Just resp -> case handleresponse resp of + Nothing -> protocolError True s + Just callback -> callback >>= \case + Result a -> return a + GetNextMessage handleresponse' -> + receiveMessage st external handleresponse' handlerequest handleexceptional + Nothing -> case parseMessage s :: Maybe RemoteRequest of + Just req -> maybe (protocolError True s) id (handlerequest req) + Nothing -> case parseMessage s :: Maybe ExceptionalMessage of + Just msg -> maybe (protocolError True s) id (handleexceptional msg) + Nothing -> protocolError False s + protocolError parsed s = do + warning $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\" " ++ + if parsed + then "(command not allowed at this time)" + else "(unable to parse command)" + giveup "unable to use special remote due to protocol error" {- While the action is running, the ExternalState provided to it will not - be available to any other calls. @@ -571,7 +586,7 @@ withExternalState :: External -> (ExternalState -> Annex a) -> Annex a withExternalState external a = do st <- get - r <- a st `onException` liftIO (externalShutdown (externalAddonProcess st) True) + r <- a st `onException` liftIO (externalShutdown st True) put st -- only when no exception is thrown return r where @@ -590,37 +605,69 @@ put st = liftIO $ atomically $ modifyTVar' v (st:) {- Starts an external remote process running, and checks VERSION and - - exchanges EXTENSIONS. -} + - exchanges EXTENSIONS. + - + - When the ASYNC extension is negotiated, a single process is used, + - and this constructs a external state that communicates with a thread + - that relays to it. + -} startExternal :: External -> Annex ExternalState -startExternal external = do +startExternal external = + liftIO (atomically $ takeTMVar (externalAsync external)) >>= \case + UncheckedExternalAsync -> do + (st, extensions) <- startExternal' external + `onException` store UncheckedExternalAsync + if asyncExtensionEnabled extensions + then do + relay <- liftIO $ runRelayToExternalAsync external st + st' <- liftIO $ asyncRelayExternalState relay + store (ExternalAsync relay) + return st' + else do + store NoExternalAsync + return st + v@NoExternalAsync -> do + store v + fst <$> startExternal' external + v@(ExternalAsync relay) -> do + store v + liftIO $ asyncRelayExternalState relay + where + store = liftIO . atomically . putTMVar (externalAsync external) + +startExternal' :: External -> Annex (ExternalState, ExtensionList) +startExternal' external = do pid <- liftIO $ atomically $ do n <- succ <$> readTVar (externalLastPid external) writeTVar (externalLastPid external) n return n - startExternalAddonProcess basecmd pid >>= \case - Left (ProgramFailure err) -> giveup err - Left (ProgramNotInstalled err) -> + AddonProcess.startExternalAddonProcess basecmd pid >>= \case + Left (AddonProcess.ProgramFailure err) -> do + unusable err + Left (AddonProcess.ProgramNotInstalled err) -> case (lookupName (unparsedRemoteConfig (externalDefaultConfig external)), remoteAnnexReadOnly <$> externalGitConfig external) of - (Just rname, Just True) -> giveup $ unlines + (Just rname, Just True) -> unusable $ unlines [ err , "This remote has annex-readonly=true, and previous versions of" , "git-annex would tried to download from it without" , "installing " ++ basecmd ++ ". If you want that, you need to set:" , "git config remote." ++ rname ++ ".annex-externaltype readonly" ] - _ -> giveup err + _ -> unusable err Right p -> do - cv <- liftIO $ newTVarIO $ externalDefaultConfig external - ccv <- liftIO $ newTVarIO id - pv <- liftIO $ newTVarIO Unprepared + cv <- liftIO $ newTMVarIO $ externalDefaultConfig external + ccv <- liftIO $ newTMVarIO id + pv <- liftIO $ newTMVarIO Unprepared let st = ExternalState - { externalAddonProcess = p + { externalSend = sendMessageAddonProcess p + , externalReceive = receiveMessageAddonProcess p + , externalShutdown = shutdownAddonProcess p , externalPrepared = pv , externalConfig = cv , externalConfigChanges = ccv } - startproto st - return st + extensions <- startproto st + return (st, extensions) where basecmd = "git-annex-remote-" ++ externalType external startproto st = do @@ -632,19 +679,29 @@ -- It responds with a EXTENSIONS_RESPONSE; that extensions -- list is reserved for future expansion. UNSUPPORTED_REQUEST -- is also accepted. - receiveMessage st external + exwanted <- receiveMessage st external (\resp -> case resp of - EXTENSIONS_RESPONSE _ -> result () - UNSUPPORTED_REQUEST -> result () + EXTENSIONS_RESPONSE l -> result l + UNSUPPORTED_REQUEST -> result mempty _ -> Nothing ) (const Nothing) (const Nothing) + case filter (`notElem` fromExtensionList supportedExtensionList) (fromExtensionList exwanted) of + [] -> return exwanted + exrest -> unusable $ unwords $ + [ basecmd + , "requested extensions that this version of git-annex does not support:" + ] ++ exrest + unusable msg = do + warning msg + giveup ("unable to use external special remote " ++ basecmd) + stopExternal :: External -> Annex () stopExternal external = liftIO $ do l <- atomically $ swapTVar (externalState external) [] - mapM_ (flip (externalShutdown . externalAddonProcess) False) l + mapM_ (flip externalShutdown False) l checkVersion :: ExternalState -> RemoteRequest -> Maybe (Annex ()) checkVersion st (VERSION v) = Just $ @@ -659,10 +716,12 @@ - the error message. -} checkPrepared :: ExternalState -> External -> Annex () checkPrepared st external = do - v <- liftIO $ atomically $ readTVar $ externalPrepared st + v <- liftIO $ atomically $ takeTMVar $ externalPrepared st case v of - Prepared -> noop - FailedPrepare errmsg -> giveup errmsg + Prepared -> setprepared Prepared + FailedPrepare errmsg -> do + setprepared (FailedPrepare errmsg) + giveup errmsg Unprepared -> handleRequest' st external PREPARE Nothing $ \resp -> case resp of @@ -675,8 +734,8 @@ giveup errmsg' _ -> Nothing where - setprepared status = liftIO $ atomically $ void $ - swapTVar (externalPrepared st) status + setprepared status = liftIO $ atomically $ + putTMVar (externalPrepared st) status respErrorMessage :: String -> String -> String respErrorMessage req err diff --git a/Remote/External/AsyncExtension.hs b/Remote/External/AsyncExtension.hs new file mode 100644 --- /dev/null +++ b/Remote/External/AsyncExtension.hs @@ -0,0 +1,123 @@ +{- External remote protocol async extension. + - + - Copyright 2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} + +module Remote.External.AsyncExtension (runRelayToExternalAsync) where + +import Common +import Messages +import Remote.External.Types +import Utility.SimpleProtocol as Proto + +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Concurrent.STM.TBMChan +import qualified Data.Map.Strict as M + +-- | Starts a thread that will handle all communication with the external +-- process. The input ExternalState communicates directly with the external +-- process. +runRelayToExternalAsync :: External -> ExternalState -> IO ExternalAsyncRelay +runRelayToExternalAsync external st = do + jidmap <- newTVarIO M.empty + sendq <- newSendQueue + nextjid <- newTVarIO (JobId 1) + void $ async $ sendloop st sendq + void $ async $ receiveloop external st jidmap sendq + return $ ExternalAsyncRelay $ do + receiveq <- newReceiveQueue + jid <- atomically $ do + jid@(JobId n) <- readTVar nextjid + let !jid' = JobId (succ n) + writeTVar nextjid jid' + modifyTVar' jidmap $ M.insert jid receiveq + return jid + return $ ExternalState + { externalSend = \msg -> + atomically $ writeTBMChan sendq + (toAsyncWrapped msg, jid) + , externalReceive = atomically (readTBMChan receiveq) + -- This shuts down the whole relay. + , externalShutdown = shutdown external st sendq + -- These three TMVars are shared amoung all + -- ExternalStates that use this relay; they're + -- common state about the external process. + , externalPrepared = externalPrepared st + , externalConfig = externalConfig st + , externalConfigChanges = externalConfigChanges st + } + +type ReceiveQueue = TBMChan String + +type SendQueue = TBMChan (AsyncWrapped, JobId) + +type JidMap = TVar (M.Map JobId ReceiveQueue) + +newReceiveQueue :: IO ReceiveQueue +newReceiveQueue = newTBMChanIO 10 + +newSendQueue :: IO SendQueue +newSendQueue = newTBMChanIO 10 + +receiveloop :: External -> ExternalState -> JidMap -> SendQueue -> IO () +receiveloop external st jidmap sendq = externalReceive st >>= \case + Just l -> case parseMessage l :: Maybe AsyncMessage of + Just (AsyncMessage jid msg) -> + M.lookup jid <$> readTVarIO jidmap >>= \case + Just c -> do + atomically $ writeTBMChan c msg + receiveloop external st jidmap sendq + Nothing -> protoerr "unknown job number" + Nothing -> case parseMessage l :: Maybe ExceptionalMessage of + Just _ -> do + -- ERROR is relayed to all listeners + m <- readTVarIO jidmap + forM_ (M.elems m) $ \c -> + atomically $ writeTBMChan c l + receiveloop external st jidmap sendq + Nothing -> protoerr "unexpected non-async message" + Nothing -> closeandshutdown + where + protoerr s = do + warningIO $ "async external special remote protocol error: " ++ s + closeandshutdown + + closeandshutdown = do + shutdown external st sendq True + m <- atomically $ readTVar jidmap + forM_ (M.elems m) (atomically . closeTBMChan) + +sendloop :: ExternalState -> SendQueue -> IO () +sendloop st sendq = atomically (readTBMChan sendq) >>= \case + Just (wrappedmsg, jid) -> do + case wrappedmsg of + AsyncWrappedRemoteResponse msg -> + externalSend st $ wrapjid msg jid + AsyncWrappedRequest msg -> + externalSend st $ wrapjid msg jid + AsyncWrappedExceptionalMessage msg -> + externalSend st msg + AsyncWrappedAsyncMessage msg -> + externalSend st msg + sendloop st sendq + Nothing -> return () + where + wrapjid msg jid = AsyncMessage jid $ unwords $ Proto.formatMessage msg + +shutdown :: External -> ExternalState -> SendQueue -> Bool -> IO () +shutdown external st sendq b = do + r <- atomically $ do + r <- tryTakeTMVar (externalAsync external) + putTMVar (externalAsync external) + UncheckedExternalAsync + return r + case r of + Just (ExternalAsync _) -> externalShutdown st b + _ -> noop + atomically $ closeTBMChan sendq diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -5,7 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, RankNTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Remote.External.Types ( @@ -14,7 +15,11 @@ ExternalType, ExternalState(..), PrepareStatus(..), + ExtensionList(..), supportedExtensionList, + asyncExtensionEnabled, + ExternalAsync(..), + ExternalAsyncRelay(..), Proto.parseMessage, Proto.Sendable(..), Proto.Receivable(..), @@ -25,7 +30,11 @@ Response(..), RemoteRequest(..), RemoteResponse(..), + ExceptionalMessage(..), AsyncMessage(..), + AsyncWrapped(..), + ToAsyncWrapped(..), + JobId(..), ErrorMsg, Setting, Description, @@ -34,7 +43,6 @@ ) where import Annex.Common -import Annex.ExternalAddonProcess import Types.StandardGroups (PreferredContentExpression) import Utility.Metered (BytesProcessed(..)) import Types.Transfer (Direction(..)) @@ -50,6 +58,7 @@ import Control.Concurrent.STM import Network.URI import Data.Char +import Text.Read data External = External { externalType :: ExternalType @@ -61,6 +70,7 @@ , externalDefaultConfig :: ParsedRemoteConfig , externalGitConfig :: Maybe RemoteGitConfig , externalRemoteStateHandle :: Maybe RemoteStateHandle + , externalAsync :: TMVar ExternalAsync } newExternal :: ExternalType -> Maybe UUID -> ParsedRemoteConfig -> Maybe RemoteGitConfig -> Maybe RemoteStateHandle -> Annex External @@ -72,26 +82,45 @@ <*> pure c <*> pure gc <*> pure rs + <*> atomically (newTMVar UncheckedExternalAsync) type ExternalType = String data ExternalState = ExternalState - { externalAddonProcess :: ExternalAddonProcess - , externalPrepared :: TVar PrepareStatus - , externalConfig :: TVar ParsedRemoteConfig - , externalConfigChanges :: TVar (RemoteConfig -> RemoteConfig) + { externalSend :: forall t. (Proto.Sendable t, ToAsyncWrapped t) => t -> IO () + , externalReceive :: IO (Maybe String) + , externalShutdown :: Bool -> IO () + , externalPrepared :: TMVar PrepareStatus + , externalConfig :: TMVar ParsedRemoteConfig + , externalConfigChanges :: TMVar (RemoteConfig -> RemoteConfig) } type PID = Int -- List of extensions to the protocol. -newtype ExtensionList = ExtensionList [String] - deriving (Show) +newtype ExtensionList = ExtensionList { fromExtensionList :: [String] } + deriving (Show, Monoid, Semigroup) --- When adding a new RemoteRequest, also add it to the list here. supportedExtensionList :: ExtensionList -supportedExtensionList = ExtensionList ["INFO"] +supportedExtensionList = ExtensionList ["INFO", asyncExtension] +asyncExtension :: String +asyncExtension = "ASYNC" + +asyncExtensionEnabled :: ExtensionList -> Bool +asyncExtensionEnabled l = asyncExtension `elem` fromExtensionList l + +-- When the async extension is in use, a single external process +-- is started and used for all requests. +data ExternalAsync + = ExternalAsync ExternalAsyncRelay + | NoExternalAsync + | UncheckedExternalAsync + +data ExternalAsyncRelay = ExternalAsyncRelay + { asyncRelayExternalState :: IO ExternalState + } + data PrepareStatus = Unprepared | Prepared | FailedPrepare ErrorMsg -- The protocol does not support keys with spaces in their names; @@ -323,17 +352,47 @@ formatMessage (CREDS login password) = [ "CREDS", Proto.serialize login, Proto.serialize password ] -- Messages that can be sent at any time by either git-annex or the remote. -data AsyncMessage +data ExceptionalMessage = ERROR ErrorMsg deriving (Show) -instance Proto.Sendable AsyncMessage where +instance Proto.Sendable ExceptionalMessage where formatMessage (ERROR err) = [ "ERROR", Proto.serialize err ] -instance Proto.Receivable AsyncMessage where +instance Proto.Receivable ExceptionalMessage where parseCommand "ERROR" = Proto.parse1 ERROR parseCommand _ = Proto.parseFail +data AsyncMessage = AsyncMessage JobId WrappedMsg + +instance Proto.Receivable AsyncMessage where + parseCommand "J" = Proto.parse2 AsyncMessage + parseCommand _ = Proto.parseFail + +instance Proto.Sendable AsyncMessage where + formatMessage (AsyncMessage jid msg) = ["J", Proto.serialize jid, msg] + +data AsyncWrapped + = AsyncWrappedRemoteResponse RemoteResponse + | AsyncWrappedRequest Request + | AsyncWrappedExceptionalMessage ExceptionalMessage + | AsyncWrappedAsyncMessage AsyncMessage + +class ToAsyncWrapped t where + toAsyncWrapped :: t -> AsyncWrapped + +instance ToAsyncWrapped RemoteResponse where + toAsyncWrapped = AsyncWrappedRemoteResponse + +instance ToAsyncWrapped Request where + toAsyncWrapped = AsyncWrappedRequest + +instance ToAsyncWrapped ExceptionalMessage where + toAsyncWrapped = AsyncWrappedExceptionalMessage + +instance ToAsyncWrapped AsyncMessage where + toAsyncWrapped = AsyncWrappedAsyncMessage + -- Data types used for parameters when communicating with the remote. -- All are serializable. type ErrorMsg = String @@ -341,9 +400,16 @@ type Description = String type ProtocolVersion = Int type Size = Maybe Integer +type WrappedMsg = String +newtype JobId = JobId Integer + deriving (Eq, Ord, Show) supportedProtocolVersions :: [ProtocolVersion] supportedProtocolVersions = [1] + +instance Proto.Serializable JobId where + serialize (JobId n) = show n + deserialize = JobId <$$> readMaybe instance Proto.Serializable Direction where serialize Upload = "STORE" diff --git a/Remote/HttpAlso.hs b/Remote/HttpAlso.hs new file mode 100644 --- /dev/null +++ b/Remote/HttpAlso.hs @@ -0,0 +1,223 @@ +{- HttpAlso remote (readonly). + - + - Copyright 2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Remote.HttpAlso (remote) where + +import Annex.Common +import Types.Remote +import Types.ProposedAccepted +import Types.Export +import Remote.Helper.Messages +import Remote.Helper.ExportImport +import Remote.Helper.Special +import qualified Git +import Config.Cost +import Config +import Logs.Web +import Creds +import Messages.Progress +import Utility.Metered +import qualified Annex.Url as Url +import Annex.SpecialRemote.Config + +import Data.Either +import qualified Data.Map as M +import System.FilePath.Posix as P +import Control.Concurrent.STM + +remote :: RemoteType +remote = RemoteType + { typename = "httpalso" + , enumerate = const (findSpecialRemotes "httpalso") + , generate = gen + , configParser = mkRemoteConfigParser + [ optionalStringParser urlField + (FieldDesc "(required) url to the remote content") + ] + , setup = httpAlsoSetup + , exportSupported = exportIsSupported + , importSupported = importUnsupported + } + +urlField :: RemoteConfigField +urlField = Accepted "url" + +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u rc gc rs = do + c <- parsedRemoteConfig remote rc + cst <- remoteCost gc expensiveRemoteCost + let url = getRemoteConfigValue urlField c + ll <- liftIO newLearnedLayout + return $ Just $ this url ll c cst + where + this url ll c cst = Remote + { uuid = u + , cost = cst + , name = Git.repoDescribe r + , storeKey = cannotModify + , retrieveKeyFile = downloadKey url ll + , retrieveKeyFileCheap = Nothing + -- HttpManagerRestricted is used here, so this is + -- secure. + , retrievalSecurityPolicy = RetrievalAllKeysSecure + , removeKey = cannotModify + , lockContent = Nothing + , checkPresent = checkKey url ll (this url ll c cst) + , checkPresentCheap = False + , exportActions = ExportActions + { storeExport = cannotModify + , retrieveExport = retriveExportHttpAlso url + , removeExport = cannotModify + , checkPresentExport = checkPresentExportHttpAlso url + , removeExportDirectory = Nothing + , renameExport = cannotModify + } + , importActions = importUnsupported + , whereisKey = Nothing + , remoteFsck = Nothing + , repairRepo = Nothing + , config = c + , gitconfig = gc + , localpath = Nothing + , getRepo = return r + , readonly = True + , appendonly = False + , availability = GloballyAvailable + , remotetype = remote + , mkUnavailable = return Nothing + , getInfo = return [] + , claimUrl = Nothing + , checkUrl = Nothing + , remoteStateHandle = rs + } + +cannotModify :: a +cannotModify = giveup "httpalso special remote is read only" + +httpAlsoSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) +httpAlsoSetup _ Nothing _ _ _ = + error "Must use --sameas when initializing a httpalso remote." +httpAlsoSetup _ (Just u) _ c gc = do + _url <- maybe (giveup "Specify url=") + (return . fromProposedAccepted) + (M.lookup urlField c) + (c', _encsetup) <- encryptionSetup c gc + gitConfigSpecialRemote u c' [("httpalso", "true")] + return (c', u) + +downloadKey :: Maybe URLString -> LearnedLayout -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification +downloadKey baseurl ll key _af dest p = do + downloadAction dest p key (keyUrlAction baseurl ll key) + return UnVerified + +retriveExportHttpAlso :: Maybe URLString -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex () +retriveExportHttpAlso baseurl key loc dest p = + downloadAction dest p key (exportLocationUrlAction baseurl loc) + +downloadAction :: FilePath -> MeterUpdate -> Key -> ((URLString -> Annex (Either String ())) -> Annex (Either String ())) -> Annex () +downloadAction dest p key run = + Url.withUrlOptions $ \uo -> + meteredFile dest (Just p) key $ + run (\url -> Url.download' p url dest uo) + >>= either giveup (const (return ())) + +checkKey :: Maybe URLString -> LearnedLayout -> Remote -> Key -> Annex Bool +checkKey baseurl ll r key = do + showChecking r + isRight <$> keyUrlAction baseurl ll key (checkKey' key) + +checkKey' :: Key -> URLString -> Annex (Either String ()) +checkKey' key url = ifM (Url.withUrlOptions $ Url.checkBoth url (fromKey keySize key)) + ( return (Right ()) + , return (Left "content not found") + ) + +checkPresentExportHttpAlso :: Maybe URLString -> Key -> ExportLocation -> Annex Bool +checkPresentExportHttpAlso baseurl key loc = + isRight <$> exportLocationUrlAction baseurl loc (checkKey' key) + +type LearnedLayout = TVar (Maybe [Key -> URLString]) + +newLearnedLayout :: IO LearnedLayout +newLearnedLayout = newTVarIO Nothing + +-- Learns which layout the special remote uses, so the once any +-- action on an url succeeds, subsequent calls will continue to use that +-- layout (or related layouts). +keyUrlAction + :: Maybe URLString + -> LearnedLayout + -> Key + -> (URLString -> Annex (Either String ())) + -> Annex (Either String ()) +keyUrlAction (Just baseurl) ll key downloader = + liftIO (readTVarIO ll) >>= \case + Just learned -> go Nothing False [learned] + Nothing -> go Nothing True (supportedLayouts baseurl) + where + go err learn [] = go' err learn [] [] + go err learn (layouts:rest) = go' err learn layouts [] >>= \case + Right () -> return (Right ()) + Left err' -> go (Just err') learn rest + + go' (Just err) _ [] _ = pure (Left err) + go' Nothing _ [] _ = error "internal" + go' _err learn (layout:rest) prevs = + downloader (layout key) >>= \case + Right () -> do + when learn $ do + let learned = layout:prevs++rest + liftIO $ atomically $ + writeTVar ll (Just learned) + return (Right ()) + Left err -> go' (Just err) learn rest (layout:prevs) +keyUrlAction Nothing _ _ _ = noBaseUrlError + +exportLocationUrlAction + :: Maybe URLString + -> ExportLocation + -> (URLString -> Annex (Either String ())) + -> Annex (Either String ()) +exportLocationUrlAction (Just baseurl) loc a = + a (baseurl P. fromRawFilePath (fromExportLocation loc)) +exportLocationUrlAction Nothing _ _ = noBaseUrlError + +-- cannot normally happen +noBaseUrlError :: Annex a +noBaseUrlError = giveup "no url configured for httpalso special remote" + +-- Different ways that keys can be laid out in the special remote, +-- with the more common first. +-- +-- This is a nested list, because a single remote may use more than one +-- layout. In particular, old versions of git-annex used hashDirMixed +-- for some special remotes, before switching to hashDirLower for new data. +-- So, when learning the layout, both need to be tried. +supportedLayouts :: URLString -> [[Key -> URLString]] +supportedLayouts baseurl = + -- Layout used for bare git-annex repos, and for many + -- special remotes like directory. + [ [ \k -> mkurl k (hashDirLower (HashLevels 2)) P. kf k + -- Layout used for non-bare git-annex repos, and for some old + -- special remotes. + , \k -> mkurl k (hashDirMixed (HashLevels 2)) P. kf k + ] + -- Special remotes that do not need hash directories. + , [ \k -> baseurl P. kf k ] + -- Layouts without a key directory, used by some special remotes. + , [ \k -> mkurl k (hashDirLower def) + , \k -> mkurl k (hashDirMixed def) + ] + -- Layouts with only 1 level of hash directory, + -- rather than the default 2. + , [ \k -> mkurl k (hashDirLower (HashLevels 1)) + , \k -> mkurl k (hashDirMixed (HashLevels 1)) + ] + ] + where + mkurl k hasher = baseurl P. fromRawFilePath (hasher k) P. kf k + kf k = fromRawFilePath (keyFile k) diff --git a/Remote/List.hs b/Remote/List.hs --- a/Remote/List.hs +++ b/Remote/List.hs @@ -5,8 +5,6 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE CPP #-} - module Remote.List where import qualified Data.Map as M @@ -25,22 +23,19 @@ import qualified Remote.Git import qualified Remote.GCrypt import qualified Remote.P2P -#ifdef WITH_S3 import qualified Remote.S3 -#endif import qualified Remote.Bup import qualified Remote.Directory import qualified Remote.Rsync import qualified Remote.Web import qualified Remote.BitTorrent -#ifdef WITH_WEBDAV import qualified Remote.WebDAV -#endif import qualified Remote.Adb import qualified Remote.Tahoe import qualified Remote.Glacier import qualified Remote.Ddar import qualified Remote.GitLFS +import qualified Remote.HttpAlso import qualified Remote.Hook import qualified Remote.External @@ -49,22 +44,19 @@ [ Remote.Git.remote , Remote.GCrypt.remote , Remote.P2P.remote -#ifdef WITH_S3 , Remote.S3.remote -#endif , Remote.Bup.remote , Remote.Directory.remote , Remote.Rsync.remote , Remote.Web.remote , Remote.BitTorrent.remote -#ifdef WITH_WEBDAV , Remote.WebDAV.remote -#endif , Remote.Adb.remote , Remote.Tahoe.remote , Remote.Glacier.remote , Remote.Ddar.remote , Remote.GitLFS.remote + , Remote.HttpAlso.remote , Remote.Hook.remote , Remote.External.remote ] diff --git a/Types/Crypto.hs b/Types/Crypto.hs --- a/Types/Crypto.hs +++ b/Types/Crypto.hs @@ -36,7 +36,6 @@ -- XXX ideally, this would be a locked memory region data Cipher = Cipher String | MacOnlyCipher String - deriving (Show) -- XXXDO NOT COMMIT data StorableCipher = EncryptedCipher String EncryptedCipherVariant KeyIds diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -114,6 +114,7 @@ , annexAddUnlocked :: Configurable (Maybe String) , annexSecureHashesOnly :: Bool , annexRetry :: Maybe Integer + , annexForwardRetry :: Maybe Integer , annexRetryDelay :: Maybe Seconds , annexAllowedUrlSchemes :: S.Set Scheme , annexAllowedIPAddresses :: String @@ -129,6 +130,7 @@ , receiveDenyCurrentBranch :: DenyCurrentBranch , gcryptId :: Maybe String , gpgCmd :: GpgCmd + , mergeDirectoryRenames :: Maybe String } extractGitConfig :: ConfigSource -> Git.Repo -> GitConfig @@ -177,7 +179,7 @@ , annexFsckNudge = getbool (annexConfig "fscknudge") True , annexAutoUpgrade = toAutoUpgrade $ getmaybe (annexConfig "autoupgrade") - , annexExpireUnused = maybe Nothing Just . parseDuration + , annexExpireUnused = either (const Nothing) Just . parseDuration <$> getmaybe (annexConfig "expireunused") , annexSecureEraseCommand = getmaybe (annexConfig "secure-erase-command") , annexGenMetaData = getbool (annexConfig "genmetadata") False @@ -196,6 +198,7 @@ fmap Just $ getmaybe (annexConfig "addunlocked") , annexSecureHashesOnly = getbool (annexConfig "securehashesonly") False , annexRetry = getmayberead (annexConfig "retry") + , annexForwardRetry = getmayberead (annexConfig "forward-retry") , annexRetryDelay = Seconds <$> getmayberead (annexConfig "retrydelay") , annexAllowedUrlSchemes = S.fromList $ map mkScheme $ @@ -221,6 +224,7 @@ , receiveDenyCurrentBranch = getDenyCurrentBranch r , gcryptId = getmaybe "core.gcrypt-id" , gpgCmd = mkGpgCmd (getmaybe "gpg.program") + , mergeDirectoryRenames = getmaybe "directoryrenames" } where getbool k d = fromMaybe d $ getmaybebool k @@ -295,6 +299,7 @@ , remoteAnnexSpeculatePresent :: Bool , remoteAnnexBare :: Maybe Bool , remoteAnnexRetry :: Maybe Integer + , remoteAnnexForwardRetry :: Maybe Integer , remoteAnnexRetryDelay :: Maybe Seconds , remoteAnnexAllowUnverifiedDownloads :: Bool , remoteAnnexConfigUUID :: Maybe UUID @@ -356,6 +361,7 @@ , remoteAnnexSpeculatePresent = getbool "speculate-present" False , remoteAnnexBare = getmaybebool "bare" , remoteAnnexRetry = getmayberead "retry" + , remoteAnnexForwardRetry = getmayberead "forward-retry" , remoteAnnexRetryDelay = Seconds <$> getmayberead "retrydelay" , remoteAnnexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $ diff --git a/Types/ScheduledActivity.hs b/Types/ScheduledActivity.hs --- a/Types/ScheduledActivity.hs +++ b/Types/ScheduledActivity.hs @@ -46,16 +46,15 @@ parseScheduledActivity s = case words s of ("fsck":"self":d:rest) -> qualified $ ScheduledSelfFsck <$> parseSchedule (unwords rest) - <*> getduration d + <*> parseDuration d ("fsck":u:d:rest) -> qualified $ ScheduledRemoteFsck <$> pure (toUUID u) <*> parseSchedule (unwords rest) - <*> getduration d + <*> parseDuration d _ -> qualified $ Left "unknown activity" where qualified (Left e) = Left $ e ++ " in \"" ++ s ++ "\"" qualified v = v - getduration d = maybe (Left $ "failed to parse duration \""++d++"\"") Right (parseDuration d) fromScheduledActivities :: [ScheduledActivity] -> String fromScheduledActivities = intercalate "; " . map fromScheduledActivity diff --git a/Upgrade.hs b/Upgrade.hs --- a/Upgrade.hs +++ b/Upgrade.hs @@ -15,7 +15,6 @@ import Config import Annex.Path import Annex.Version -import Annex.GitOverlay import Types.RepoVersion #ifndef mingw32_HOST_OS import qualified Upgrade.V0 @@ -104,13 +103,16 @@ -- upgrading a git repo other than the current repo. upgraderemote = do rp <- fromRawFilePath <$> fromRepo Git.repoPath - cmd <- liftIO programPath - runsGitAnnexChildProcess $ liftIO $ boolSystem' cmd - [ Param "upgrade" - , Param "--quiet" - , Param "--autoonly" + gitAnnexChildProcess + [ "upgrade" + , "--quiet" + , "--autoonly" ] (\p -> p { cwd = Just rp }) + (\_ _ _ pid -> waitForProcess pid >>= return . \case + ExitSuccess -> True + _ -> False + ) upgradingRemote :: Annex Bool upgradingRemote = isJust <$> fromRepo Git.remoteName diff --git a/Utility/Directory.hs b/Utility/Directory.hs --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -110,16 +110,16 @@ onrename (Left e) | isPermissionError e = rethrow | isDoesNotExistError e = rethrow - | otherwise = viaTmp mv dest "" + | otherwise = viaTmp mv dest () where rethrow = throwM e - mv tmp _ = do - -- copyFile is likely not as optimised as - -- the mv command, so we'll use the command. - -- - -- But, while Windows has a "mv", it does not seem very - -- reliable, so use copyFile there. + mv tmp () = do + -- copyFile is likely not as optimised as + -- the mv command, so we'll use the command. + -- + -- But, while Windows has a "mv", it does not seem very + -- reliable, so use copyFile there. #ifndef mingw32_HOST_OS -- If dest is a directory, mv would move the file -- into it, which is not desired. @@ -145,11 +145,10 @@ (Right s) -> return $ isDirectory s #endif -{- Removes a file, which may or may not exist, and does not have to - - be a regular file. +{- Removes a file (or symlink), which may or may not exist. - - Note that an exception is thrown if the file exists but - - cannot be removed. -} + - cannot be removed, or if its a directory. -} nukeFile :: FilePath -> IO () nukeFile file = void $ tryWhenExists go where diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -1,11 +1,12 @@ {- File mode utilities. - - - Copyright 2010-2017 Joey Hess + - Copyright 2010-2020 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.FileMode ( module Utility.FileMode, @@ -16,11 +17,7 @@ import Control.Monad import System.PosixCompat.Types import System.PosixCompat.Files -#ifndef mingw32_HOST_OS -import System.Posix.Files (symbolicLinkMode) -import Control.Monad.IO.Class (liftIO) -#endif -import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Class import Foreign (complement) import Control.Monad.Catch @@ -96,14 +93,6 @@ checkMode :: FileMode -> FileMode -> Bool checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor - -{- Checks if a file mode indicates it's a symlink. -} -isSymLink :: FileMode -> Bool -#ifdef mingw32_HOST_OS -isSymLink _ = False -#else -isSymLink = checkMode symbolicLinkMode -#endif {- Checks if a file has any executable bits set. -} isExecutable :: FileMode -> Bool diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -416,7 +416,7 @@ , return Nothing ) where - var = "GNUPGHOME" + var = "GNUPGHOME" setup = do orig <- getEnv var @@ -431,9 +431,16 @@ [testSecretKey, testKey] return orig - cleanup (Just (Just v)) = setEnv var v True - cleanup (Just Nothing) = unsetEnv var - cleanup Nothing = return () + cleanup (Just (Just v)) = stopgpgagent >> setEnv var v True + cleanup (Just Nothing) = stopgpgagent >> unsetEnv var + cleanup Nothing = stopgpgagent + + -- Recent versions of gpg automatically start gpg-agent, or perhaps + -- other daemons. Stop them when done. This only affects + -- daemons started for the GNUPGHOME that was used. + -- Older gpg may not support this, so ignore failure. + stopgpgagent = whenM (inPath "gpgconf") $ + void $ boolSystem "gpgconf" [Param "--kill", Param "all"] go (Just _) = Just <$> a go Nothing = return Nothing diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs --- a/Utility/HumanTime.hs +++ b/Utility/HumanTime.hs @@ -19,7 +19,6 @@ import Utility.PartialPrelude import Utility.QuickCheck -import Control.Monad.Fail as Fail (MonadFail(..)) import qualified Data.Map as M import Data.Time.Clock import Data.Time.Clock.POSIX (POSIXTime) @@ -45,8 +44,8 @@ daysToDuration i = Duration $ i * dsecs {- Parses a human-input time duration, of the form "5h", "1m", "5h1m", etc -} -parseDuration :: MonadFail m => String -> m Duration -parseDuration = maybe parsefail (return . Duration) . go 0 +parseDuration :: String -> Either String Duration +parseDuration d = maybe parsefail (Right . Duration) $ go 0 d where go n [] = return n go n s = do @@ -56,7 +55,7 @@ u <- M.lookup c unitmap go (n + num * u) rest _ -> return $ n + num - parsefail = Fail.fail "duration parse error; expected eg \"5m\" or \"1h5m\"" + parsefail = Left $ "failed to parse duration \"" ++ d ++ "\" (expected eg \"5m\" or \"1h5m\")" fromDuration :: Duration -> String fromDuration Duration { durationSeconds = d } @@ -102,4 +101,4 @@ arbitrary = Duration <$> nonNegative arbitrary prop_duration_roundtrips :: Duration -> Bool -prop_duration_roundtrips d = parseDuration (fromDuration d) == Just d +prop_duration_roundtrips d = parseDuration (fromDuration d) == Right d diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs --- a/Utility/LockFile/PidLock.hs +++ b/Utility/LockFile/PidLock.hs @@ -15,6 +15,7 @@ checkLocked, checkSaneLock, pidLockEnv, + pidLockEnvValue, ) where import Utility.PartialPrelude @@ -37,6 +38,8 @@ import System.Posix.Types import System.Posix.Files import System.Posix.Process +import Control.Monad +import Control.Monad.IO.Class (liftIO, MonadIO) import Data.Maybe import Data.List import Network.BSD @@ -239,19 +242,24 @@ -- | Waits as necessary to take a lock. -- --- Uses a 1 second wait-loop. +-- Uses a 1 second wait-loop, retrying until a timeout. -- --- May wait until timeout if the lock file is stale and is on a network file --- system, or on a system where the side lock cannot be taken. -waitLock :: Seconds -> LockFile -> IO LockHandle -waitLock (Seconds timeout) lockfile = go timeout +-- After the first second waiting, runs the callback to display a message, +-- so the user knows why it's stalled. +waitLock :: MonadIO m => Seconds -> LockFile -> (String -> m ()) -> m LockHandle +waitLock (Seconds timeout) lockfile displaymessage = go timeout where go n - | n > 0 = maybe (threadDelaySeconds (Seconds 1) >> go (pred n)) return - =<< tryLock lockfile + | n > 0 = liftIO (tryLock lockfile) >>= \case + Nothing -> do + when (n == pred timeout) $ + displaymessage $ "waiting for pid lock file " ++ lockfile ++ " which is held by another process (or may be stale)" + liftIO $ threadDelaySeconds (Seconds 1) + go (pred n) + Just lckh -> return lckh | otherwise = do - hPutStrLn stderr $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ lockfile - giveup $ "Gave up waiting for possibly stale pid lock file " ++ lockfile + displaymessage $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ lockfile + giveup $ "Gave up waiting for pid lock file " ++ lockfile dropLock :: LockHandle -> IO () dropLock (LockHandle lockfile _ sidelock) = do @@ -293,3 +301,6 @@ pidLockEnv lockfile = do abslockfile <- absPath lockfile return $ "PIDLOCK_" ++ filter legalInEnvVar abslockfile + +pidLockEnvValue :: String +pidLockEnvValue = "1" diff --git a/Utility/LockPool/LockHandle.hs b/Utility/LockPool/LockHandle.hs --- a/Utility/LockPool/LockHandle.hs +++ b/Utility/LockPool/LockHandle.hs @@ -1,6 +1,6 @@ {- Handles for lock pools. - - - Copyright 2015 Joey Hess + - Copyright 2015-2020 Joey Hess - - License: BSD-2-clause -} @@ -23,7 +23,8 @@ import Utility.DebugLocks import Control.Concurrent.STM -import Control.Exception +import Control.Monad.Catch +import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Applicative import Prelude @@ -47,27 +48,39 @@ -- Take a lock, by first updating the lock pool, and then taking the file -- lock. If taking the file lock fails for any reason, take care to -- release the lock in the lock pool. -makeLockHandle :: P.LockPool -> LockFile -> (P.LockPool -> LockFile -> STM P.LockHandle) -> (LockFile -> IO FileLockOps) -> IO LockHandle +makeLockHandle + :: (MonadIO m, MonadMask m) + => P.LockPool + -> LockFile + -> (P.LockPool -> LockFile -> STM P.LockHandle) + -> (LockFile -> m FileLockOps) + -> m LockHandle makeLockHandle pool file pa fa = bracketOnError setup cleanup go where - setup = debugLocks $ atomically (pa pool file) - cleanup ph = debugLocks $ P.releaseLock ph - go ph = mkLockHandle ph =<< fa file + setup = debugLocks $ liftIO $ atomically (pa pool file) + cleanup ph = debugLocks $ liftIO $ P.releaseLock ph + go ph = liftIO . mkLockHandle ph =<< fa file -tryMakeLockHandle :: P.LockPool -> LockFile -> (P.LockPool -> LockFile -> STM (Maybe P.LockHandle)) -> (LockFile -> IO (Maybe FileLockOps)) -> IO (Maybe LockHandle) +tryMakeLockHandle + :: (MonadIO m, MonadMask m) + => P.LockPool + -> LockFile + -> (P.LockPool -> LockFile -> STM (Maybe P.LockHandle)) + -> (LockFile -> m (Maybe FileLockOps)) + -> m (Maybe LockHandle) tryMakeLockHandle pool file pa fa = bracketOnError setup cleanup go where - setup = atomically (pa pool file) + setup = liftIO $ atomically (pa pool file) cleanup Nothing = return () - cleanup (Just ph) = P.releaseLock ph + cleanup (Just ph) = liftIO $ P.releaseLock ph go Nothing = return Nothing go (Just ph) = do mfo <- fa file case mfo of Nothing -> do - cleanup (Just ph) + liftIO $ cleanup (Just ph) return Nothing - Just fo -> Just <$> mkLockHandle ph fo + Just fo -> liftIO $ Just <$> mkLockHandle ph fo mkLockHandle :: P.LockHandle -> FileLockOps -> IO LockHandle mkLockHandle ph fo = do diff --git a/Utility/LockPool/PidLock.hs b/Utility/LockPool/PidLock.hs --- a/Utility/LockPool/PidLock.hs +++ b/Utility/LockPool/PidLock.hs @@ -1,6 +1,6 @@ {- Pid locks, using lock pools. - - - Copyright 2015 Joey Hess + - Copyright 2015-2020 Joey Hess - - License: BSD-2-clause -} @@ -27,16 +27,23 @@ import System.IO import System.Posix import Data.Maybe +import Control.Monad.Catch +import Control.Monad.IO.Class import Control.Applicative import Prelude -- Takes a pid lock, blocking until the lock is available or the timeout. -waitLock :: Seconds -> LockFile -> IO LockHandle -waitLock timeout file = makeLockHandle P.lockPool file +waitLock + :: (MonadIO m, MonadMask m) + => Seconds + -> LockFile + -> (String -> m ()) + -> m LockHandle +waitLock timeout file displaymessage = makeLockHandle P.lockPool file -- LockShared for STM lock, because a pid lock can be the top-level -- lock with various other STM level locks gated behind it. (\p f -> P.waitTakeLock p f LockShared) - (\f -> mk <$> F.waitLock timeout f) + (\f -> mk <$> F.waitLock timeout f displaymessage) -- Tries to take a pid lock, but does not block. tryLock :: LockFile -> IO (Maybe LockHandle) diff --git a/Utility/Process.hs b/Utility/Process.hs --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -207,7 +207,6 @@ #if MIN_VERSION_process(1,6,4) cleanupProcess = Utility.Process.Shim.cleanupProcess #else -#warning building with process-1.6.3; some timeout features may not work well cleanupProcess (mb_stdin, mb_stdout, mb_stderr, pid) = do -- Unlike the real cleanupProcess, this does not wait -- for the process to finish in the background, so if diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -61,6 +61,8 @@ -- | Run a system command, and returns True or False if it succeeded or failed. -- +-- (Throws an exception if the command is not found.) +-- -- This and other command running functions in this module log the commands -- run at debug level, using System.Log.Logger. boolSystem :: FilePath -> [CommandParam] -> IO Bool diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -1,6 +1,6 @@ {- Temporary files. - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2020 Joey Hess - - License: BSD-2-clause -} @@ -24,12 +24,18 @@ import Utility.Exception import Utility.FileSystemEncoding +import Utility.FileMode type Template = String {- Runs an action like writeFile, writing to a temp file first and - then moving it into place. The temp file is stored in the same - - directory as the final file to avoid cross-device renames. -} + - directory as the final file to avoid cross-device renames. + - + - While this uses a temp file, the file will end up with the same + - mode as it would when using writeFile, unless the writer action changes + - it. + -} viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> v -> m ()) -> FilePath -> v -> m () viaTmp a file content = bracketIO setup cleanup use where @@ -42,6 +48,11 @@ _ <- tryIO $ hClose h tryIO $ removeFile tmpfile use (tmpfile, h) = do + -- Make mode the same as if the file were created usually, + -- not as a temp file. (This may fail on some filesystems + -- that don't support file modes well, so ignore + -- exceptions.) + _ <- liftIO $ tryIO $ setFileMode tmpfile =<< defaultFileMode liftIO $ hClose h a tmpfile content liftIO $ rename tmpfile file @@ -54,7 +65,11 @@ withTmpFileIn tmpdir template a {- Runs an action with a tmp file located in the specified directory, - - then removes the file. -} + - then removes the file. + - + - Note that the tmp file will have a file mode that only allows the + - current user to access it. + -} withTmpFileIn :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a withTmpFileIn tmpdir template a = bracket create remove use where diff --git a/doc/git-annex-resolvemerge.mdwn b/doc/git-annex-resolvemerge.mdwn --- a/doc/git-annex-resolvemerge.mdwn +++ b/doc/git-annex-resolvemerge.mdwn @@ -8,15 +8,27 @@ # DESCRIPTION -Resolves a conflicted merge, by adding both conflicting versions of the -file to the tree, using variants of their filename. This is done +Automatically resolves a conflicted merge. This is done automatically when using `git annex sync` or `git annex merge`. +When two trees being merged contain conflicting versions of an annexed +file, the merge conflict will be resolved by adding both versions to the +tree, using variants of the filename. + +When one tree modified the file, and the other tree deleted the file, +the merge conflict will be resolved by adding the modified file using a +variant of the filename, leaving the original filename deleted. + +When the merge conflict involves a file that is annexed in one +tree, but is not annexed in the other tree, it is +resolved by keeping the non-annexed file as-is, and adding the annexed +version using a variant of the filename. + Note that only merge conflicts that involve one or more annexed files are resolved. Merge conflicts between two files that are not annexed will not be automatically resolved. -# EXAMPLE +# EXAMPLES Suppose Alice commits a change to annexed file `foo`, and Bob commits a different change to the same file `foo`. @@ -34,6 +46,14 @@ The user can then examine the two variants of the file, and either merge the two changes into a single file, or rename one of them back to `foo` and delete the other. + +Now suppose Alice commits a change to annexed file `bar`, while Bob commits +a deletion of the same file `bar`. Merging will fail. Running +`git annex resolvemerge` in this situation will resolve the merge conflict +by making a file with a name like `bar.variant-421f` containing Alice's +version. The `bar` file remains deleted. The user can later examine the +variant of the file and either rename it back to `bar`, or decide to delete +it too. # SEE ALSO diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -1102,6 +1102,8 @@ will automatically set annex.hardlink and mark the repository as untrusted. + When `annex.thin` is also set, setting `annex.hardlink` has no effect. + * `annex.thin` Set this to `true` to make unlocked files be a hard link to their content @@ -1184,14 +1186,15 @@ the other node is holding a pid lock. Caveat emptor. * `annex.pidlocktimeout` + + git-annex will wait up to this many seconds for the pid lock + file to go away, and will then abort if it cannot continue. Default: 300 When using pid lock files, it's possible for a stale lock file to get left behind by previous run of git-annex that crashed or was interrupted. This is mostly avoided, but can occur especially when using a network - file system. - - git-annex will wait up to this many seconds for the pid lock - file to go away, and will then abort if it cannot continue. Default: 300 + file system. This timeout prevents git-annex waiting forever in such a + situation. * `annex.cachecreds` @@ -1353,10 +1356,17 @@ * `remote..annex-retry`, `annex.retry` - Configure retries of failed transfers on a per-remote and general - basis, respectively. The value is the number of retries that can be - made of the same transfer. (default 0) + Number of times a transfer that fails can be retried. (default 0) +* `remote..annex-forward-retry`, `annex.forward-retry` + + If a transfer made some forward progress before failing, + this allows it to be retried even when `annex.retry` does not. + The value is the maximum number of times to do that. (default 5) + + When both `annex.retry` and this are set, the maximum number of + retries is the larger of the two. + * `remote..annex-retry-delay`, `annex.retry-delay` Number of seconds to delay before the first retry of a transfer. @@ -1543,6 +1553,11 @@ Normally this is automatically set up by `git annex initremote`. It is set to "true" if this is a git-lfs remote. + +* `remote..annex-httpalso` + + Used to identify httpalso special remotes. + Normally this is automatically set up by `git annex initremote`. * `remote..annex-externaltype` 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: 8.20200810 +Version: 8.20200908 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess @@ -250,12 +250,6 @@ templates/controlmenu.hamlet templates/notifications/longpolling.julius -Flag S3 - Description: Enable S3 support - -Flag WebDAV - Description: Enable WebDAV support - Flag Assistant Description: Enable git-annex assistant and watch command @@ -378,7 +372,9 @@ tasty (>= 0.7), tasty-hunit, tasty-quickcheck, - tasty-rerun + tasty-rerun, + aws (>= 0.20), + DAV (>= 1.0) CC-Options: -Wall GHC-Options: -Wall -fno-warn-tabs -Wincomplete-uni-patterns Default-Language: Haskell98 @@ -427,22 +423,6 @@ else Other-Modules: Utility.HttpManagerRestricted - if flag(S3) - Build-Depends: aws (>= 0.20) - CPP-Options: -DWITH_S3 - Other-Modules: Remote.S3 - - if flag(WebDAV) - Build-Depends: DAV (>= 1.0) - CPP-Options: -DWITH_WEBDAV - Other-Modules: - Remote.WebDAV - Remote.WebDAV.DavLocation - - if flag(S3) || flag(WebDAV) - Other-Modules: - Remote.Helper.Http - if flag(Assistant) && ! os(solaris) && ! os(gnu) Build-Depends: mountpoints CPP-Options: -DWITH_ASSISTANT @@ -675,6 +655,7 @@ Annex.NumCopies Annex.Path Annex.Perms + Annex.PidLock Annex.Queue Annex.ReplaceFile Annex.RemoteTrackingBranch @@ -961,6 +942,7 @@ Remote.Directory Remote.Directory.LegacyChunked Remote.External + Remote.External.AsyncExtension Remote.External.Types Remote.GCrypt Remote.Git @@ -973,19 +955,24 @@ Remote.Helper.ExportImport Remote.Helper.Git Remote.Helper.Hooks + Remote.Helper.Http Remote.Helper.Messages Remote.Helper.P2P Remote.Helper.ReadOnly Remote.Helper.Special Remote.Helper.Ssh + Remote.HttpAlso Remote.Hook Remote.List Remote.List.Util Remote.P2P Remote.Rsync Remote.Rsync.RsyncUrl + Remote.S3 Remote.Tahoe Remote.Web + Remote.WebDAV + Remote.WebDAV.DavLocation RemoteDaemon.Common RemoteDaemon.Core RemoteDaemon.Transport diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -3,30 +3,29 @@ production: true assistant: true pairing: true - s3: true - webdav: true torrentparser: true webapp: true magicmime: false dbus: false debuglocks: false benchmark: false - networkbsd: false + networkbsd: true gitlfs: true httpclientrestricted: true packages: - '.' extra-deps: - - IfElse-0.85 - - aws-0.21.1 - - bloomfilter-2.0.1.0 - - filepath-bytestring-1.4.2.1.6 - - sandi-0.5 - - tasty-rerun-1.1.17 - - torrent-10000.1.1 - - git-lfs-1.1.0 - - http-client-restricted-0.0.2 - - http-client-0.5.14 +- IfElse-0.85 +- aws-0.22 +- bloomfilter-2.0.1.0 +- filepath-bytestring-1.4.2.1.6 +- git-lfs-1.1.0 +- http-client-restricted-0.0.3 +- network-multicast-0.3.2 +- sandi-0.5 +- torrent-10000.1.1 +- bencode-0.6.1.1 +- network-3.1.0.1 explicit-setup-deps: git-annex: true -resolver: lts-14.27 +resolver: lts-16.10