git-annex 8.20200810 → 8.20200908
raw patch · 56 files changed
+1212/−550 lines, 56 files
Files
- Annex/AdjustedBranch.hs +4/−4
- Annex/AutoMerge.hs +60/−32
- Annex/Content.hs +9/−2
- Annex/DirHashes.hs +1/−1
- Annex/GitOverlay.hs +1/−72
- Annex/Import.hs +19/−11
- Annex/Init.hs +8/−9
- Annex/Link.hs +2/−2
- Annex/LockPool/PosixOrPid.hs +4/−4
- Annex/Path.hs +19/−2
- Annex/Perms.hs +33/−6
- Annex/PidLock.hs +127/−0
- Annex/Transfer.hs +53/−38
- Assistant/Ssh.hs +4/−2
- Assistant/WebApp/Configurators/AWS.hs +1/−25
- Assistant/WebApp/Configurators/Edit.hs +1/−7
- Assistant/WebApp/Configurators/IA.hs +1/−20
- Assistant/WebApp/Configurators/WebDAV.hs +1/−9
- Assistant/WebApp/RepoList.hs +1/−5
- Backend/External.hs +11/−11
- BuildFlags.hs +2/−14
- CHANGELOG +45/−1
- CmdLine/GitAnnex/Options.hs +2/−2
- Command/AddUrl.hs +15/−20
- Command/Assistant.hs +1/−1
- Command/Expire.hs +2/−2
- Command/Export.hs +1/−3
- Command/Fsck.hs +1/−1
- Command/Sync.hs +11/−10
- Git/Construct.hs +21/−17
- Git/Merge.hs +2/−2
- Remote/BitTorrent.hs +1/−0
- Remote/Directory.hs +2/−0
- Remote/External.hs +131/−72
- Remote/External/AsyncExtension.hs +123/−0
- Remote/External/Types.hs +79/−13
- Remote/HttpAlso.hs +223/−0
- Remote/List.hs +2/−10
- Types/Crypto.hs +0/−1
- Types/GitConfig.hs +7/−1
- Types/ScheduledActivity.hs +2/−3
- Upgrade.hs +8/−6
- Utility/Directory.hs +9/−10
- Utility/FileMode.hs +3/−14
- Utility/Gpg.hs +11/−4
- Utility/HumanTime.hs +4/−5
- Utility/LockFile/PidLock.hs +20/−9
- Utility/LockPool/LockHandle.hs +24/−11
- Utility/LockPool/PidLock.hs +11/−4
- Utility/Process.hs +0/−1
- Utility/SafeCommand.hs +2/−0
- Utility/Tmp.hs +18/−3
- doc/git-annex-resolvemerge.mdwn +23/−3
- doc/git-annex.mdwn +22/−7
- git-annex.cabal +11/−24
- stack.yaml +13/−14
Annex/AdjustedBranch.hs view
@@ -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 )
Annex/AutoMerge.hs view
@@ -1,6 +1,6 @@ {- git-annex automatic merge conflict resolution -- - Copyright 2012-2016 Joey Hess <id@joeyh.name>+ - Copyright 2012-2020 Joey Hess <id@joeyh.name> - - 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
Annex/Content.hs view
@@ -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. -}
Annex/DirHashes.hs view
@@ -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]
Annex/GitOverlay.hs view
@@ -1,12 +1,10 @@-{- Temporarily changing the files git uses.+{- Temporarily changing how git-annex runs git commands. - - Copyright 2014-2020 Joey Hess <id@joeyh.name> - - 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
Annex/Import.hs view
@@ -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
Annex/Init.hs view
@@ -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
Annex/Link.hs view
@@ -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 $
Annex/LockPool/PosixOrPid.hs view
@@ -1,7 +1,7 @@ {- Wraps Utility.LockPool, making pid locks be used when git-annex is so - configured. -- - Copyright 2015 Joey Hess <id@joeyh.name>+ - Copyright 2015-2020 Joey Hess <id@joeyh.name> - - 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
Annex/Path.hs view
@@ -1,15 +1,16 @@ {- git-annex program path -- - Copyright 2013 Joey Hess <id@joeyh.name>+ - Copyright 2013-2020 Joey Hess <id@joeyh.name> - - 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
Annex/Perms.hs view
@@ -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
+ Annex/PidLock.hs view
@@ -0,0 +1,127 @@+{- Pid locking support.+ -+ - Copyright 2014-2020 Joey Hess <id@joeyh.name>+ -+ - 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
Annex/Transfer.hs view
@@ -1,6 +1,6 @@ {- git-annex transfers -- - Copyright 2012-2019 Joey Hess <id@joeyh.name>+ - Copyright 2012-2020 Joey Hess <id@joeyh.name> - - 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
Assistant/Ssh.hs view
@@ -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.
Assistant/WebApp/Configurators/AWS.hs view
@@ -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
Assistant/WebApp/Configurators/Edit.hs view
@@ -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)
Assistant/WebApp/Configurators/IA.hs view
@@ -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
Assistant/WebApp/Configurators/WebDAV.hs view
@@ -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)
Assistant/WebApp/RepoList.hs view
@@ -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.
Backend/External.hs view
@@ -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
BuildFlags.hs view
@@ -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
CHANGELOG view
@@ -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 <id@joeyh.name> 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
CmdLine/GitAnnex/Options.hs view
@@ -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
Command/AddUrl.hs view
@@ -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
Command/Assistant.hs view
@@ -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" ))
Command/Expire.hs view
@@ -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
Command/Export.hs view
@@ -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 ->
Command/Fsck.hs view
@@ -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" ))
Command/Sync.hs view
@@ -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
Git/Construct.hs view
@@ -1,6 +1,6 @@ {- Construction of Git Repo objects -- - Copyright 2010-2012 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name> - - 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
Git/Merge.hs view
@@ -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
Remote/BitTorrent.hs view
@@ -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 $
Remote/Directory.hs view
@@ -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
Remote/External.hs view
@@ -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 "<EOF>"+ 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
+ Remote/External/AsyncExtension.hs view
@@ -0,0 +1,123 @@+{- External remote protocol async extension.+ - + - Copyright 2020 Joey Hess <id@joeyh.name>+ -+ - 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
Remote/External/Types.hs view
@@ -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"
+ Remote/HttpAlso.hs view
@@ -0,0 +1,223 @@+{- HttpAlso remote (readonly).+ -+ - Copyright 2020 Joey Hess <id@joeyh.name>+ -+ - 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)
Remote/List.hs view
@@ -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 ]
Types/Crypto.hs view
@@ -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
Types/GitConfig.hs view
@@ -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") $
Types/ScheduledActivity.hs view
@@ -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
Upgrade.hs view
@@ -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
Utility/Directory.hs view
@@ -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
Utility/FileMode.hs view
@@ -1,11 +1,12 @@ {- File mode utilities. -- - Copyright 2010-2017 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name> - - 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
Utility/Gpg.hs view
@@ -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
Utility/HumanTime.hs view
@@ -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
Utility/LockFile/PidLock.hs view
@@ -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"
Utility/LockPool/LockHandle.hs view
@@ -1,6 +1,6 @@ {- Handles for lock pools. -- - Copyright 2015 Joey Hess <id@joeyh.name>+ - Copyright 2015-2020 Joey Hess <id@joeyh.name> - - 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
Utility/LockPool/PidLock.hs view
@@ -1,6 +1,6 @@ {- Pid locks, using lock pools. -- - Copyright 2015 Joey Hess <id@joeyh.name>+ - Copyright 2015-2020 Joey Hess <id@joeyh.name> - - 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)
Utility/Process.hs view
@@ -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
Utility/SafeCommand.hs view
@@ -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
Utility/Tmp.hs view
@@ -1,6 +1,6 @@ {- Temporary files. -- - Copyright 2010-2013 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name> - - 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
doc/git-annex-resolvemerge.mdwn view
@@ -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
doc/git-annex.mdwn view
@@ -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.<name>.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.<name>.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.<name>.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.<name>.annex-httpalso`++ Used to identify httpalso special remotes.+ Normally this is automatically set up by `git annex initremote`. * `remote.<name>.annex-externaltype`
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 8.20200810+Version: 8.20200908 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -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
stack.yaml view
@@ -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