packages feed

git-annex 7.20190129 → 7.20190219

raw patch · 39 files changed

+561/−405 lines, 39 filesdep +network-bsddep ~network

Dependencies added: network-bsd

Dependency ranges changed: network

Files

Annex/Fixup.hs view
@@ -1,6 +1,6 @@ {- git-annex repository fixups  -- - Copyright 2013-2018 Joey Hess <id@joeyh.name>+ - Copyright 2013-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -10,6 +10,8 @@ import Git.Types import Git.Config import Types.GitConfig+import Config.Files+import qualified Git import qualified Git.BuildVersion import Utility.Path import Utility.SafeCommand@@ -22,6 +24,7 @@ import System.FilePath import System.PosixCompat.Files import Data.List+import Data.Maybe import Control.Monad import Control.Monad.IfElse import qualified Data.Map as M@@ -80,20 +83,27 @@  - When the filesystem doesn't support symlinks, we cannot make .git  - into a symlink. But we don't need too, since the repo will use direct  - mode.+ -+ - Before making any changes, check if there's a .noannex file+ - in the repo. If that file will prevent git-annex from being used,+ - there's no need to fix up the repository.  -} fixupUnusualRepos :: Repo -> GitConfig -> IO Repo fixupUnusualRepos r@(Repo { location = l@(Local { worktree = Just w, gitdir = d }) }) c-	| needsSubmoduleFixup r = do-		when (coreSymlinks c) $-			(replacedotgit >> unsetcoreworktree)-				`catchNonAsync` \_e -> hPutStrLn stderr-					"warning: unable to convert submodule to form that will work with git-annex"-		return $ r'-			{ config = M.delete "core.worktree" (config r)-			}-	| otherwise = ifM (needsGitLinkFixup r)+	| needsSubmoduleFixup r = ifM notnoannex 		( do 			when (coreSymlinks c) $+				(replacedotgit >> unsetcoreworktree)+					`catchNonAsync` \_e -> hPutStrLn stderr+						"warning: unable to convert submodule to form that will work with git-annex"+			return $ r'+				{ config = M.delete "core.worktree" (config r)+				}+		, return r+		)+	| otherwise = ifM (needsGitLinkFixup r <&&> notnoannex)+		( do+			when (coreSymlinks c) $ 				(replacedotgit >> worktreefixup) 					`catchNonAsync` \_e -> hPutStrLn stderr 						"warning: unable to convert .git file to symlink that will work with git-annex"@@ -131,6 +141,8 @@ 	r' 		| coreSymlinks c = r { location = l { gitdir = dotgit } } 		| otherwise = r++	notnoannex = isNothing <$> noAnnexFileContent (Git.repoWorkTree r) fixupUnusualRepos r _ = return r  needsSubmoduleFixup :: Repo -> Bool
Annex/Init.hs view
@@ -8,7 +8,6 @@ {-# LANGUAGE CPP #-}  module Annex.Init (-	AutoInit(..), 	ensureInitialized, 	isInitialized, 	initialize,@@ -36,6 +35,7 @@ import Annex.Link import Annex.WorkTree import Config+import Config.Files import Config.Smudge import Annex.Direct import qualified Annex.AdjustedBranch as AdjustedBranch@@ -52,22 +52,14 @@ import qualified Utility.LockFile.Posix as Posix #endif -newtype AutoInit = AutoInit Bool--checkCanInitialize :: AutoInit -> Annex a -> Annex a-checkCanInitialize (AutoInit True) a = a-checkCanInitialize (AutoInit False) a = fromRepo Git.repoWorkTree >>= \case+checkCanInitialize :: Annex a -> Annex a+checkCanInitialize a = inRepo (noAnnexFileContent . Git.repoWorkTree) >>= \case 	Nothing -> a-	Just wt -> liftIO (catchMaybeIO (readFile (wt </> ".noannex"))) >>= \case-		Nothing -> a-		Just noannexmsg -> ifM (Annex.getState Annex.force)-			( a-			, do-				warning "Initialization prevented by .noannex file (use --force to override)"-				unless (null noannexmsg) $-					warning noannexmsg-				giveup "Not initialized."-			)+	Just noannexmsg -> do+		warning "Initialization prevented by .noannex file (remove the file to override)"+		unless (null noannexmsg) $+			warning noannexmsg+		giveup "Not initialized."  genDescription :: Maybe String -> Annex UUIDDesc genDescription (Just d) = return $ UUIDDesc $ encodeBS d@@ -80,8 +72,8 @@ 		Right username -> [username, at, hostname, ":", reldir] 		Left _ -> [hostname, ":", reldir] -initialize :: AutoInit -> Maybe String -> Maybe RepoVersion -> Annex ()-initialize ai mdescription mversion = checkCanInitialize ai $ do+initialize :: Maybe String -> Maybe RepoVersion -> Annex ()+initialize mdescription mversion = checkCanInitialize $ do 	{- Has to come before any commits are made as the shared 	 - clone heuristic expects no local objects. -} 	sharedclone <- checkSharedClone@@ -91,7 +83,7 @@ 	ensureCommit $ Annex.Branch.create  	prepUUID-	initialize' (AutoInit True) mversion+	initialize' mversion 	 	initSharedClone sharedclone @@ -100,8 +92,8 @@  -- Everything except for uuid setup, shared clone setup, and initial -- description.-initialize' :: AutoInit -> Maybe RepoVersion -> Annex ()-initialize' ai mversion = checkCanInitialize ai $ do+initialize' :: Maybe RepoVersion -> Annex ()+initialize' mversion = checkCanInitialize  $ do 	checkLockSupport 	checkFifoSupport 	checkCrippledFileSystem@@ -153,7 +145,7 @@ ensureInitialized = getVersion >>= maybe needsinit checkUpgrade   where 	needsinit = ifM Annex.Branch.hasSibling-			( initialize (AutoInit True) Nothing Nothing+			( initialize Nothing Nothing 			, giveup "First run: git-annex init" 			) @@ -302,3 +294,4 @@ 	forM_ l $ \f -> 		maybe noop (`toDirect` f) =<< isAnnexLink f 	void $ liftIO clean+	setDirect True
Annex/Link.hs view
@@ -27,6 +27,7 @@ import qualified Git import Git.Types import Git.FilePath+import Git.Config import Annex.HashObject import Annex.InodeSentinal import Utility.FileMode@@ -203,7 +204,12 @@ 			let updatetmpindex = do 				r' <- Git.Env.addGitEnv r Git.Index.indexEnv  					=<< Git.Index.indexEnvVal tmpindex-				Git.UpdateIndex.refreshIndex r' $ \feed ->+				-- Avoid git warning about CRLF munging.+				let r'' = r' { gitGlobalOpts = gitGlobalOpts r' +++					[ Param "-c"+					, Param $ "core.safecrlf=" ++ boolConfig False+					] }+				Git.UpdateIndex.refreshIndex r'' $ \feed -> 					forM_ l $ \(f', checkunmodified) -> 						whenM checkunmodified $ 							feed f'@@ -290,12 +296,12 @@ isLinkToAnnex :: S.ByteString -> Bool isLinkToAnnex s = p `S.isInfixOf` s #ifdef mingw32_HOST_OS-	-- '/' is still used inside pointer files on Windows, not the native-	-- '\'+	-- '/' is used inside pointer files on Windows, not the native '\' 	|| p' `S.isInfixOf` s #endif   where-	p = toRawFilePath (pathSeparator:objectDir)+	sp = (pathSeparator:objectDir)+	p = toRawFilePath sp #ifdef mingw32_HOST_OS-	p' = toRawFilePath ('/':objectDir)+	p' = toRawFilePath (toInternalGitPath sp) #endif
Annex/Magic.hs view
@@ -41,5 +41,5 @@ #ifdef WITH_MAGICMIME getMagicMimeType m f = Just <$> magicFile m f #else-getMagicMimeType = return Nothing+getMagicMimeType _ _ = return Nothing #endif
Annex/MakeRepo.hs view
@@ -77,7 +77,7 @@  initRepo' :: Maybe String -> Maybe StandardGroup -> Annex () initRepo' desc mgroup = unlessM isInitialized $ do-	initialize (AutoInit False) desc Nothing+	initialize desc Nothing 	u <- getUUID 	maybe noop (defaultStandardGroup u) mgroup 	{- Ensure branch gets committed right away so it is
Annex/Tmp.hs view
@@ -27,8 +27,9 @@ 	addCleanup OtherTmpCleanup cleanupOtherTmp 	tmpdir <- fromRepo gitAnnexTmpOtherDir 	tmplck <- fromRepo gitAnnexTmpOtherLock-	void $ createAnnexDirectory tmpdir-	withSharedLock (const tmplck) (a tmpdir)+	withSharedLock (const tmplck) $ do+		void $ createAnnexDirectory tmpdir+		a tmpdir  -- | Cleans up any tmp files that were left by a previous -- git-annex process that got interrupted or failed to clean up after
Annex/WorkTree.hs view
@@ -1,6 +1,6 @@ {- git-annex worktree files  -- - Copyright 2013-2018 Joey Hess <id@joeyh.name>+ - Copyright 2013-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -36,13 +36,28 @@  - pointer to a key in the original branch.  -} lookupFile :: FilePath -> Annex (Maybe Key)-lookupFile file = isAnnexLink file >>= \case-	Just key -> return (Just key)-	Nothing -> ifM (versionSupportsUnlockedPointers <||> isDirect)-		( ifM (liftIO $ doesFileExist file)+lookupFile = lookupFile' catkeyfile+  where+	catkeyfile file =+		ifM (liftIO $ doesFileExist file) 			( catKeyFile file 			, catKeyFileHidden file =<< getCurrentBranch 			)++lookupFileNotHidden :: FilePath -> Annex (Maybe Key)+lookupFileNotHidden = lookupFile' catkeyfile+  where+	catkeyfile file =+		ifM (liftIO $ doesFileExist file)+			( catKeyFile file+			, return Nothing+			)++lookupFile' :: (FilePath -> Annex (Maybe Key)) -> FilePath -> Annex (Maybe Key)+lookupFile' catkeyfile file = isAnnexLink file >>= \case+	Just key -> return (Just key)+	Nothing -> ifM (versionSupportsUnlockedPointers <||> isDirect)+		( catkeyfile file 		, return Nothing  		)
CHANGELOG view
@@ -1,3 +1,41 @@+git-annex (7.20190219) upstream; urgency=medium++  * init: Fix bug when direct mode needs to be enabled on a crippled+    filesystem, that left the repository in indirect mode.+  * Fix false positive in export conflict detection, that occurred+    when the same tree was exported by multiple clones. Previous fix was+    incomplete.+  * When key-based retrieval from a S3 remote with exporttree=yes appendonly=yes+    fails, fall back to trying to retrieve from the exported tree.+    This allows downloads of files that were exported to such a remote+    before versioning was enabled on it.+  * Fix path separator bug on Windows that completely broke git-annex+    since version 7.20190122.+  * Improved speed of S3 remote by only loading S3 creds once.+  * Display progress bar when getting files from export remotes.+  * Fix race in cleanup of othertmp directory that could result in a failure+    attempting to access it.+  * fromkey: Made idempotent.+  * fromkey: Added --json.+  * fromkey --batch output changed to support using it with --json.+    The old output was not parseable for any useful information, so+    this is not expected to break anything.+  * Avoid performing repository fixups for submodules and git-worktrees+    when there's a .noannex file that will prevent git-annex from being+    used in the repository.+  * init: Don't let --force be used to override a .noannex file,+    instead the user can just delete the file.+  * webdav: Exporting files with '#' or '?' in their name won't work because+    urls get truncated on those. Fail in a better way in this case,+    and avoid failing when removing such files from the export, so+    after the user has renamed the problem files the export will succeed.+  * On Windows, avoid using rsync for local copies, since rsync is not+    always available there.+  * Added NetworkBSD build flag to deal with Network.BSD moving to a new+    package.++ -- Joey Hess <id@joeyh.name>  Tue, 19 Feb 2019 11:12:45 -0400+ git-annex (7.20190129) upstream; urgency=medium    * initremote S3: When configured with versioning=yes, either ask the user
@@ -10,8 +10,8 @@            © 2014 Sören Brunk License: AGPL-3+ -Files: Remote/Git.hs Remote/Helper/Ssh.hs Remote/Adb.hs Remote/External.hs Remote/Extermal/Types.hs-Copyright: © 2011-2018 Joey Hess <id@joeyh.name>+Files: Annex/AdjustedBranch.hs Annex/AdjustedBranch/Name.hs Annex/CurrentBranch.hs Annex/Version.hs Benchmark.hs Logs/File.hs Logs/Line.hs Logs/Smudge.hs Remote/Git.hs Remote/Helper/Ssh.hs Remote/Adb.hs Remote/External.hs Remote/Extermal/Types.hs Types/AdjustedBranch.hs Types/RepoVersion.hs Upgrade/V6.hs+Copyright: © 2011-2019 Joey Hess <id@joeyh.name> License: AGPL-3+  Files: Remote/Ddar.hs
CmdLine/Batch.hs view
@@ -93,15 +93,15 @@ -- to handle them. -- -- File matching options are not checked.-allBatchFiles :: BatchFormat -> (FilePath -> CommandStart) -> Annex ()-allBatchFiles fmt a = batchInput fmt Right $ batchCommandAction . a+batchStart :: BatchFormat -> (String -> CommandStart) -> Annex ()+batchStart fmt a = batchInput fmt Right $ batchCommandAction . a --- Like allBatchFiles, but checks the file matching options+-- Like batchStart, but checks the file matching options -- and skips non-matching files. batchFilesMatching :: BatchFormat -> (FilePath -> CommandStart) -> Annex () batchFilesMatching fmt a = do 	matcher <- getMatcher-	allBatchFiles fmt $ \f ->+	batchStart fmt $ \f -> 		ifM (matcher $ MatchingFile $ FileInfo f f) 			( a f 			, return Nothing
Command/ConfigList.hs view
@@ -45,7 +45,7 @@ 		else ifM (Annex.Branch.hasSibling <||> (isJust <$> Fields.getField Fields.autoInit)) 			( do 				liftIO checkNotReadOnly-				initialize (AutoInit True) Nothing Nothing+				initialize Nothing Nothing 				getUUID 			, return NoUUID 			)
Command/Export.hs view
@@ -28,7 +28,6 @@ import Logs.Location import Logs.Export import Database.Export-import Messages.Progress import Config import Utility.Tmp import Utility.Metered@@ -82,16 +81,15 @@ 		inRepo (Git.Ref.tree (exportTreeish o)) 	withExclusiveLock (gitAnnexExportLock (uuid r)) $ do 		db <- openDb (uuid r)-		ea <- exportActions r-		changeExport r ea db new+		changeExport r db new 		unlessM (Annex.getState Annex.fast) $-			void $ fillExport r ea db new+			void $ fillExport r db new 		closeDb db  -- | Changes what's exported to the remote. Does not upload any new -- files, but does delete and rename files already exported to the remote.-changeExport :: Remote -> ExportActions Annex -> ExportHandle -> Git.Ref -> CommandSeek-changeExport r ea db new = do+changeExport :: Remote -> ExportHandle -> Git.Ref -> CommandSeek+changeExport r db new = do 	old <- getExport (uuid r) 	recordExportBeginning (uuid r) new 	@@ -100,10 +98,10 @@ 	-- temp files. Diff from the incomplete tree to the new tree, 	-- and delete any temp files that the new tree can't use. 	let recover diff = commandAction $-		startRecoverIncomplete r ea db+		startRecoverIncomplete r db 			(Git.DiffTree.srcsha diff) 			(Git.DiffTree.file diff)-	forM_ (concatMap incompleteExportedTreeish old) $ \incomplete ->+	forM_ (incompleteExportedTreeishes old) $ \incomplete -> 		mapdiff recover incomplete new  	-- Diff the old and new trees, and delete or rename to new name all@@ -113,7 +111,7 @@ 	-- When there was an export conflict, this resolves it. 	-- 	-- The ExportTree is also updated here to reflect the new tree.-	case nub (map exportedTreeish old) of+	case exportedTreeishes old of 		[] -> updateExportTree db emptyTree new 		[oldtreesha] -> do 			diffmap <- mkDiffMap oldtreesha new db@@ -123,15 +121,15 @@ 			seekdiffmap $ \(ek, (moldf, mnewf)) -> do 				case (moldf, mnewf) of 					(Just oldf, Just _newf) ->-						startMoveToTempName r ea db oldf ek+						startMoveToTempName r db oldf ek 					(Just oldf, Nothing) ->-						startUnexport' r ea db oldf ek+						startUnexport' r db oldf ek 					_ -> stop 			-- Rename from temp to new files. 			seekdiffmap $ \(ek, (moldf, mnewf)) -> 				case (moldf, mnewf) of 					(Just _oldf, Just newf) ->-						startMoveFromTempName r ea db ek newf+						startMoveFromTempName r db ek newf 					_ -> stop 		ts -> do 			warning "Export conflict detected. Different trees have been exported to the same special remote. Resolving.."@@ -147,7 +145,7 @@ 				-- Don't rename to temp, because the 				-- content is unknown; delete instead. 				mapdiff-					(\diff -> commandAction $ startUnexport r ea db (Git.DiffTree.file diff) (unexportboth diff))+					(\diff -> commandAction $ startUnexport r db (Git.DiffTree.file diff) (unexportboth diff)) 					oldtreesha new 			updateExportTree db emptyTree new 	liftIO $ recordExportTreeCurrent db new@@ -158,7 +156,7 @@ 	c <- Annex.getState Annex.errcounter 	when (c == 0) $ do 		recordExport (uuid r) $ ExportChange-			{ oldTreeish = map exportedTreeish old+			{ oldTreeish = exportedTreeishes old 			, newTreeish = new 			}   where@@ -193,24 +191,24 @@  -- | Upload all exported files that are not yet in the remote, -- Returns True when files were uploaded.-fillExport :: Remote -> ExportActions Annex -> ExportHandle -> Git.Ref -> Annex Bool-fillExport r ea db new = do+fillExport :: Remote -> ExportHandle -> Git.Ref -> Annex Bool+fillExport r db new = do 	(l, cleanup) <- inRepo $ Git.LsTree.lsTree new 	cvar <- liftIO $ newMVar False-	commandActions $ map (startExport r ea db cvar) l+	commandActions $ map (startExport r db cvar) l 	void $ liftIO $ cleanup 	liftIO $ takeMVar cvar -startExport :: Remote -> ExportActions Annex -> ExportHandle -> MVar Bool -> Git.LsTree.TreeItem -> CommandStart-startExport r ea db cvar ti = do+startExport :: Remote -> ExportHandle -> MVar Bool -> Git.LsTree.TreeItem -> CommandStart+startExport r db cvar ti = do 	ek <- exportKey (Git.LsTree.sha ti) 	stopUnless (notrecordedpresent ek) $ do 		showStart ("export " ++ name r) f-		ifM (either (const False) id <$> tryNonAsync (checkPresentExport ea (asKey ek) loc))+		ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) (asKey ek) loc)) 			( next $ next $ cleanupExport r db ek loc False 			, do 				liftIO $ modifyMVar_ cvar (pure . const True)-				next $ performExport r ea db ek af (Git.LsTree.sha ti) loc+				next $ performExport r db ek af (Git.LsTree.sha ti) loc 			)   where 	loc = mkExportLocation f@@ -222,9 +220,9 @@ 		-- will still list it, so also check location tracking. 		<*> (notElem (uuid r) <$> loggedLocations (asKey ek)) -performExport :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> AssociatedFile -> Sha -> ExportLocation -> CommandPerform-performExport r ea db ek af contentsha loc = do-	let storer = storeExport ea+performExport :: Remote -> ExportHandle -> ExportKey -> AssociatedFile -> Sha -> ExportLocation -> CommandPerform+performExport r db ek af contentsha loc = do+	let storer = storeExport (exportActions r) 	sent <- case ek of 		AnnexKey k -> ifM (inAnnex k) 			( notifyTransfer Upload af $@@ -232,22 +230,20 @@ 				-- exports cannot be resumed. 				upload (uuid r) k af noRetry $ \pm -> do 					let rollback = void $-						performUnexport r ea db [ek] loc+						performUnexport r db [ek] loc 					sendAnnex k rollback $ \f ->-						metered Nothing k (return $ Just f) $ \_ m -> do-							let m' = combineMeterUpdate pm m-							storer f k loc m'+						storer f k loc pm 			, do 				showNote "not available" 				return False 			) 		-- Sending a non-annexed file.-		GitKey sha1k -> metered Nothing sha1k (return Nothing) $ \_ m ->+		GitKey sha1k -> 			withTmpFile "export" $ \tmp h -> do 				b <- catObject contentsha 				liftIO $ L.hPut h b 				liftIO $ hClose h-				storer tmp sha1k loc m+				storer tmp sha1k loc nullMeterUpdate 	if sent 		then next $ cleanupExport r db ek loc True 		else stop@@ -259,22 +255,22 @@ 		logChange (asKey ek) (uuid r) InfoPresent 	return True -startUnexport :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> [Git.Sha] -> CommandStart-startUnexport r ea db f shas = do+startUnexport :: Remote -> ExportHandle -> TopFilePath -> [Git.Sha] -> CommandStart+startUnexport r db f shas = do 	eks <- forM (filter (/= nullSha) shas) exportKey 	if null eks 		then stop 		else do 			showStart ("unexport " ++ name r) f'-			next $ performUnexport r ea db eks loc+			next $ performUnexport r db eks loc   where 	loc = mkExportLocation f' 	f' = getTopFilePath f -startUnexport' :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart-startUnexport' r ea db f ek = do+startUnexport' :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart+startUnexport' r db f ek = do 	showStart ("unexport " ++ name r) f'-	next $ performUnexport r ea db [ek] loc+	next $ performUnexport r db [ek] loc   where 	loc = mkExportLocation f' 	f' = getTopFilePath f@@ -284,15 +280,15 @@ -- remote is untrusted, so would not count as a copy anyway. -- Or, an export may be appendonly, and removing a file from it does -- not really remove the content, which must be accessible later on.-performUnexport :: Remote -> ExportActions Annex -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandPerform-performUnexport r ea db eks loc = do-	ifM (allM (\ek -> removeExport ea (asKey ek) loc) eks)-		( next $ cleanupUnexport r ea db eks loc+performUnexport :: Remote -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandPerform+performUnexport r db eks loc = do+	ifM (allM (\ek -> removeExport (exportActions r) (asKey ek) loc) eks)+		( next $ cleanupUnexport r db eks loc 		, stop 		) -cleanupUnexport :: Remote -> ExportActions Annex -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandCleanup-cleanupUnexport r ea db eks loc = do+cleanupUnexport :: Remote -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandCleanup+cleanupUnexport r db eks loc = do 	liftIO $ do 		forM_ eks $ \ek -> 			removeExportedLocation db (asKey ek) loc@@ -308,68 +304,68 @@ 			forM_ eks $ \ek -> 				logChange (asKey ek) (uuid r) InfoMissing 	-	removeEmptyDirectories ea db loc (map asKey eks)+	removeEmptyDirectories r db loc (map asKey eks) -startRecoverIncomplete :: Remote -> ExportActions Annex -> ExportHandle -> Git.Sha -> TopFilePath -> CommandStart-startRecoverIncomplete r ea db sha oldf+startRecoverIncomplete :: Remote -> ExportHandle -> Git.Sha -> TopFilePath -> CommandStart+startRecoverIncomplete r db sha oldf 	| sha == nullSha = stop 	| otherwise = do 		ek <- exportKey sha 		let loc = exportTempName ek 		showStart ("unexport " ++ name r) (fromExportLocation loc) 		liftIO $ removeExportedLocation db (asKey ek) oldloc-		next $ performUnexport r ea db [ek] loc+		next $ performUnexport r db [ek] loc   where 	oldloc = mkExportLocation oldf' 	oldf' = getTopFilePath oldf -startMoveToTempName :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart-startMoveToTempName r ea db f ek = do+startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart+startMoveToTempName r db f ek = do 	showStart ("rename " ++ name r) (f' ++ " -> " ++ fromExportLocation tmploc)-	next $ performRename r ea db ek loc tmploc+	next $ performRename r db ek loc tmploc   where 	loc = mkExportLocation f' 	f' = getTopFilePath f 	tmploc = exportTempName ek -startMoveFromTempName :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> TopFilePath -> CommandStart-startMoveFromTempName r ea db ek f = do+startMoveFromTempName :: Remote -> ExportHandle -> ExportKey -> TopFilePath -> CommandStart+startMoveFromTempName r db ek f = do 	let tmploc = exportTempName ek 	stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $ do 		showStart ("rename " ++ name r) (fromExportLocation tmploc ++ " -> " ++ f')-		next $ performRename r ea db ek tmploc loc+		next $ performRename r db ek tmploc loc   where 	loc = mkExportLocation f' 	f' = getTopFilePath f -performRename :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform-performRename r ea db ek src dest = do-	ifM (renameExport ea (asKey ek) src dest)-		( next $ cleanupRename ea db ek src dest+performRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform+performRename r db ek src dest = do+	ifM (renameExport (exportActions r) (asKey ek) src dest)+		( next $ cleanupRename r db ek src dest 		-- In case the special remote does not support renaming, 		-- unexport the src instead. 		, do 			warning "rename failed; deleting instead"-			performUnexport r ea db [ek] src+			performUnexport r db [ek] src 		) -cleanupRename :: ExportActions Annex -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandCleanup-cleanupRename ea db ek src dest = do+cleanupRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandCleanup+cleanupRename r db ek src dest = do 	liftIO $ do 		removeExportedLocation db (asKey ek) src 		addExportedLocation db (asKey ek) dest 		flushDbQueue db 	if exportDirectories src /= exportDirectories dest-		then removeEmptyDirectories ea db src [asKey ek]+		then removeEmptyDirectories r db src [asKey ek] 		else return True  -- | Remove empty directories from the export. Call after removing an -- exported file, and after calling removeExportLocation and flushing the -- database.-removeEmptyDirectories :: ExportActions Annex -> ExportHandle -> ExportLocation -> [Key] -> Annex Bool-removeEmptyDirectories ea db loc ks+removeEmptyDirectories :: Remote -> ExportHandle -> ExportLocation -> [Key] -> Annex Bool+removeEmptyDirectories r db loc ks 	| null (exportDirectories loc) = return True-	| otherwise = case removeExportDirectory ea of+	| otherwise = case removeExportDirectory (exportActions r) of 		Nothing -> return True 		Just removeexportdirectory -> do 			ok <- allM (go removeexportdirectory)
Command/FromKey.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2010-2018 Joey Hess <id@joeyh.name>+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -12,13 +12,14 @@ import Command import qualified Annex.Queue import Annex.Content+import Annex.WorkTree import qualified Annex import qualified Backend.URL  import Network.URI  cmd :: Command-cmd = notDirect $ notBareRepo $+cmd = notDirect $ notBareRepo $ withGlobalOptions [jsonOptions] $ 	command "fromkey" SectionPlumbing "adds a file using a specific key" 		(paramRepeating (paramPair paramKey paramPath)) 		(seek <$$> optParser)@@ -35,13 +36,25 @@  seek :: FromKeyOptions -> CommandSeek seek o = case (batchOption o, keyFilePairs o) of-	(Batch fmt, _) -> commandAction $ startMass fmt+	(Batch fmt, _) -> seekBatch fmt 	-- older way of enabling batch input, does not support BatchNull-	(NoBatch, []) -> commandAction $ startMass BatchLine+	(NoBatch, []) -> seekBatch BatchLine 	(NoBatch, ps) -> do 		force <- Annex.getState Annex.force 		withPairs (commandAction . start force) ps +seekBatch :: BatchFormat -> CommandSeek+seekBatch fmt = batchInput fmt parse commandAction+  where+	parse s = +		let (keyname, file) = separate (== ' ') s+		in if not (null keyname) && not (null file)+			then Right $ go file (mkKey keyname)+			else Left "Expected pairs of key and filename"+	go file key = do+		showStart "fromkey" file+		next $ perform key file+ start :: Bool -> (String, FilePath) -> CommandStart start force (keyname, file) = do 	let key = mkKey keyname@@ -52,22 +65,6 @@ 	showStart "fromkey" file 	next $ perform key file -startMass :: BatchFormat -> CommandStart-startMass fmt = do-	showStart' "fromkey" (Just "stdin")-	next (massAdd fmt)--massAdd :: BatchFormat -> CommandPerform-massAdd fmt = go True =<< map (separate (== ' ')) <$> batchLines fmt-  where-	go status [] = next $ return status-	go status ((keyname,f):rest) | not (null keyname) && not (null f) = do-		let key = mkKey keyname-		ok <- perform' key f-		let !status' = status && ok-		go status' rest-	go _ _ = giveup "Expected pairs of key and file on stdin, but got something else."- -- From user input to a Key. -- User can input either a serialized key, or an url. --@@ -84,14 +81,20 @@ 		Nothing -> giveup $ "bad key/url " ++ s  perform :: Key -> FilePath -> CommandPerform-perform key file = do-	ok <- perform' key file-	next $ return ok--perform' :: Key -> FilePath -> Annex Bool-perform' key file = do-	link <- calcRepo $ gitAnnexLink file key-	liftIO $ createDirectoryIfMissing True (parentDir file)-	liftIO $ createSymbolicLink link file-	Annex.Queue.addCommand "add" [Param "--"] [file]-	return True+perform key file = lookupFileNotHidden file >>= \case+	Nothing -> ifM (liftIO $ doesFileExist file)+		( hasothercontent+		, do+			link <- calcRepo $ gitAnnexLink file key+			liftIO $ createDirectoryIfMissing True (parentDir file)+			liftIO $ createSymbolicLink link file+			Annex.Queue.addCommand "add" [Param "--"] [file]+			next $ return True+		)+	Just k+		| k == key -> next $ return True+		| otherwise -> hasothercontent+  where+	hasothercontent = do+		warning $ file ++ " already exists with different content"+		next $ return False
Command/Init.hs view
@@ -52,7 +52,7 @@  perform :: InitOptions -> CommandPerform perform os = do-	initialize (AutoInit False)+	initialize 		(if null (initDesc os) then Nothing else Just (initDesc os)) 		(initVersion os) 	Annex.SpecialRemote.autoEnable
Command/Reinit.hs view
@@ -36,6 +36,6 @@ 		then return $ toUUID s 		else Remote.nameToUUID s 	storeUUID u-	initialize' (AutoInit False) Nothing+	initialize' Nothing 	Annex.SpecialRemote.autoEnable 	next $ return True
Command/Sync.hs view
@@ -691,7 +691,6 @@   where 	go r = withExclusiveLock (gitAnnexExportLock (Remote.uuid r)) $ do 		db <- Export.openDb (Remote.uuid r)-		ea <- Remote.exportActions r 		exported <- case remoteAnnexExportTracking (Remote.gitconfig r) of 			Nothing -> nontracking r 			Just b -> do@@ -699,9 +698,9 @@ 				case mcur of 					Nothing -> nontracking r 					Just cur -> do-						Command.Export.changeExport r ea db cur-						return [Exported cur []]-		Export.closeDb db `after` fillexport r ea db exported+						Command.Export.changeExport r db cur+						return [mkExported cur []]+		Export.closeDb db `after` fillexport r db (exportedTreeishes exported) 		 	nontracking r = do 		exported <- getExport (Remote.uuid r)@@ -709,7 +708,7 @@ 		return exported 	 	warnnontracking r exported currb = inRepo (Git.Ref.tree currb) >>= \case-		Just currt | not (any (\ex -> exportedTreeish ex == currt) exported) ->+		Just currt | not (any (== currt) (exportedTreeishes exported)) -> 			showLongNote $ unwords 				[ "Not updating export to " ++ Remote.name r 				, "to reflect changes to the tree, because export"@@ -720,10 +719,9 @@ 		_ -> noop  -	fillexport _ _ _ [] = return False-	fillexport r ea db (Exported { exportedTreeish = t }:[]) =-		Command.Export.fillExport r ea db t-	fillexport r _ _ _ = do+	fillexport _ _ [] = return False+	fillexport r db (t:[]) = Command.Export.fillExport r db t+	fillexport r _ _ = do 		warnExportConflict r 		return False
Command/TestRemote.hs view
@@ -95,7 +95,7 @@  perform :: [Remote] -> [Remote] -> Maybe Remote -> [Key] -> CommandPerform perform rs unavailrs exportr ks = do-	ea <- maybe exportUnsupported Remote.exportActions exportr+	let ea = maybe exportUnsupported Remote.exportActions exportr 	st <- Annex.getState id 	let tests = testGroup "Remote Tests" $ concat 		[ [ testGroup "unavailable remote" (testUnavailable st r (Prelude.head ks)) | r <- unavailrs ]
Command/Upgrade.hs view
@@ -25,6 +25,6 @@ start = do 	showStart' "upgrade" Nothing 	whenM (isNothing <$> getVersion) $ do-		initialize (AutoInit False) Nothing Nothing+		initialize Nothing Nothing 	r <- upgrade False latestVersion 	next $ next $ return r
Config/Files.hs view
@@ -1,6 +1,6 @@ {- git-annex extra config files  -- - Copyright 2012 Joey Hess <id@joeyh.name>+ - Copyright 2012-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -81,3 +81,10 @@ cannotFindProgram = do 	f <- programFile 	giveup $ "cannot find git-annex program in PATH or in the location listed in " ++ f++{- A .noannex file in a git repository prevents git-annex from+ - initializing that repository.. The content of the file is returned. -}+noAnnexFileContent :: Maybe FilePath -> IO (Maybe String)+noAnnexFileContent repoworktree = case repoworktree of+	Nothing -> return Nothing+	Just wt -> catchMaybeIO (readFile (wt </> ".noannex"))
Database/Export.hs view
@@ -216,11 +216,13 @@ 		old <- liftIO $ fromMaybe emptyTree 			<$> getExportTreeCurrent db 		l <- Log.getExport u-		case map Log.exportedTreeish l of+		case Log.exportedTreeishes l of 			[] -> return ExportUpdateSuccess-			(new:[]) | new /= old -> do-				updateExportTree db old new-				liftIO $ recordExportTreeCurrent db new-				liftIO $ flushDbQueue db-				return ExportUpdateSuccess+			(new:[]) +				| new /= old -> do+					updateExportTree db old new+					liftIO $ recordExportTreeCurrent db new+					liftIO $ flushDbQueue db+					return ExportUpdateSuccess+				| new == old -> return ExportUpdateSuccess 			_ts -> return ExportUpdateConflict
Logs/Export.hs view
@@ -1,11 +1,21 @@ {- git-annex export log  -- - Copyright 2017 Joey Hess <id@joeyh.name>+ - Copyright 2017-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -} -module Logs.Export where+module Logs.Export (+	Exported,+	mkExported,+	ExportParticipants,+	ExportChange(..),+	getExport,+	exportedTreeishes,+	incompleteExportedTreeishes,+	recordExport,+	recordExportBeginning,+) where  import qualified Data.Map as M @@ -23,12 +33,29 @@ import qualified Data.Attoparsec.ByteString.Char8 as A8 import Data.ByteString.Builder +-- This constuctor is not itself exported to other modules, to enforce+-- consistent use of exportedTreeishes. data Exported = Exported 	{ exportedTreeish :: Git.Ref 	, incompleteExportedTreeish :: [Git.Ref] 	} 	deriving (Eq, Show) +mkExported :: Git.Ref -> [Git.Ref] -> Exported+mkExported = Exported++-- | Get the list of exported treeishes.+--+-- If the list contains multiple items, there was an export conflict,+-- and different trees were exported to the same special remote.+exportedTreeishes :: [Exported] -> [Git.Ref]+exportedTreeishes = nub . map exportedTreeish++-- | Treeishes that started to be exported, but were not finished.+incompleteExportedTreeishes :: [Exported] -> [Git.Ref]+incompleteExportedTreeishes = concatMap incompleteExportedTreeish++ data ExportParticipants = ExportParticipants 	{ exportFrom :: UUID 	, exportTo :: UUID@@ -41,9 +68,6 @@ 	}  -- | Get what's been exported to a special remote.------ If the list contains multiple items, there was an export conflict,--- and different trees were exported to the same special remote. getExport :: UUID -> Annex [Exported] getExport remoteuuid = nub . mapMaybe get . M.toList . simpleMap  	. parseExportLog
Remote/Adb.hs view
@@ -53,7 +53,7 @@ 		, lockContent = Nothing 		, checkPresent = checkPresentDummy 		, checkPresentCheap = False-		, exportActions = return $ ExportActions+		, exportActions = ExportActions 			{ storeExport = storeExportM serial adir 			, retrieveExport = retrieveExportM serial adir 			, removeExport = removeExportM serial adir
Remote/Directory.hs view
@@ -63,7 +63,7 @@ 			, lockContent = Nothing 			, checkPresent = checkPresentDummy 			, checkPresentCheap = True-			, exportActions = return $ ExportActions+			, exportActions = ExportActions 				{ storeExport = storeExportM dir 				, retrieveExport = retrieveExportM dir 				, removeExport = removeExportM dir
Remote/External.hs view
@@ -75,7 +75,7 @@ 			then checkExportSupported' external 			else return False 		let exportactions = if exportsupported-			then return $ ExportActions+			then ExportActions 				{ storeExport = storeExportM external 				, retrieveExport = retrieveExportM external 				, removeExport = removeExportM external
Remote/Git.hs view
@@ -42,9 +42,7 @@ import qualified CmdLine.GitAnnexShell.Fields as Fields import Logs.Location import Utility.Metered-#ifndef mingw32_HOST_OS import Utility.CopyFile-#endif import Utility.Env import Utility.Batch import Utility.SimpleProtocol@@ -709,20 +707,22 @@ rsyncOrCopyFile :: [CommandParam] -> FilePath -> FilePath -> MeterUpdate -> Annex Bool rsyncOrCopyFile rsyncparams src dest p = #ifdef mingw32_HOST_OS-	dorsync+	-- rsync is only available on Windows in some inatallation methods,+	-- and is not strictly needed here, so don't use it.+	docopy   where #else 	ifM (sameDeviceIds src dest) (docopy, dorsync)   where 	sameDeviceIds a b = (==) <$> getDeviceId a <*> getDeviceId b 	getDeviceId f = deviceID <$> liftIO (getFileStatus $ parentDir f)-	docopy = liftIO $ watchFileSize dest p $-		copyFileExternal CopyTimeStamps src dest-#endif 	dorsync = do 		oh <- mkOutputHandler 		Ssh.rsyncHelper oh (Just p) $ 			rsyncparams ++ [File src, File dest]+#endif+	docopy = liftIO $ watchFileSize dest p $+		copyFileExternal CopyTimeStamps src dest  commitOnCleanup :: Git.Repo -> Remote -> Annex a -> Annex a commitOnCleanup repo r a = go `after` a
Remote/Helper/Export.hs view
@@ -31,8 +31,8 @@ instance HasExportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where 	exportUnsupported = \_ _ -> return False -instance HasExportUnsupported (Annex (ExportActions Annex)) where-	exportUnsupported = return $ ExportActions+instance HasExportUnsupported (ExportActions Annex) where+	exportUnsupported = ExportActions 		{ storeExport = \_ _ _ _ -> do 			warning "store export is unsupported" 			return False@@ -141,11 +141,18 @@ 			-- with content not of the requested key, 			-- the content has to be strongly verified. 			---			-- But, appendonly remotes have a key/value store,-			-- so don't need to use retrieveExport.-			, retrieveKeyFile = if appendonly r-				then retrieveKeyFile r-				else retrieveKeyFileFromExport getexportlocs exportinconflict+			-- appendonly remotes have a key/value store,+			-- so don't need to use retrieveExport. However,+			-- fall back to it if retrieveKeyFile fails.+			, retrieveKeyFile = \k af dest p ->+				let retrieveexport = retrieveKeyFileFromExport getexportlocs exportinconflict k af dest p+				in if appendonly r+					then do+						ret@(ok, _v) <- retrieveKeyFile r k af dest p+						if ok+							then return ret+							else retrieveexport+					else retrieveexport 			, retrieveKeyFileCheap = if appendonly r 				then retrieveKeyFileCheap r 				else \_ _ _ -> return False@@ -175,10 +182,8 @@ 			-- non-export remote) 			, checkPresent = if appendonly r 				then checkPresent r-				else \k -> do-					ea <- exportActions r-					anyM (checkPresentExport ea k)-						=<< getexportlocs k+				else \k -> anyM (checkPresentExport (exportActions r) k)+					=<< getexportlocs k 			-- checkPresent from an export is more expensive 			-- than otherwise, so not cheap. Also, this 			-- avoids things that look at checkPresentCheap and@@ -188,7 +193,7 @@ 			, checkPresentCheap = False 			, mkUnavailable = return Nothing 			, getInfo = do-				ts <- map (fromRef . exportedTreeish)+				ts <- map fromRef . exportedTreeishes 					<$> getExport (uuid r) 				is <- getInfo r 				return (is++[("export", "yes"), ("exportedtree", unwords ts)])@@ -204,9 +209,7 @@ 							, warning "unknown export location" 							) 						return False-					(l:_) -> do-						ea <- exportActions r-						retrieveExport ea k l dest p+					(l:_) -> retrieveExport (exportActions r) k l dest p 			else do 				warning $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (keyVariety k)) ++ " backend" 				return False
Remote/Helper/Special.hs view
@@ -1,6 +1,6 @@ {- helpers for special remotes  -- - Copyright 2011-2018 Joey Hess <id@joeyh.name>+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -157,6 +157,8 @@  -- Modifies a base Remote to support both chunking and encryption, -- which special remotes typically should support.+-- +-- Handles progress displays when displayProgress is set. specialRemote :: RemoteModifier specialRemote c = specialRemote' (specialRemoteCfg c) c @@ -192,6 +194,12 @@ 		, whereisKey = if noChunks (chunkConfig cfg) && not isencrypted 			then whereisKey baser 			else Nothing+		, exportActions = (exportActions baser)+			{ storeExport = \f k l p -> displayprogress p k (Just f) $+				storeExport (exportActions baser) f k l+			, retrieveExport = \k l f p -> displayprogress p k Nothing $+				retrieveExport (exportActions baser) k l f+			} 		} 	cip = cipherKey c (gitconfig baser) 	isencrypted = isJust (extractCipher c)
Remote/Rsync.hs view
@@ -77,7 +77,7 @@ 			, lockContent = Nothing 			, checkPresent = checkPresentDummy 			, checkPresentCheap = False-			, exportActions = return $ ExportActions+			, exportActions = ExportActions 				{ storeExport = storeExportM o 				, retrieveExport = retrieveExportM o 				, removeExport = removeExportM o
Remote/S3.hs view
@@ -33,6 +33,8 @@ import Control.Monad.Catch import Data.IORef import System.Log.Logger+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TVar  import Annex.Common import Types.Remote@@ -56,7 +58,7 @@ import qualified Annex.Url as Url import Utility.DataUnits import Annex.Content-import Annex.Url (withUrlOptions)+import Annex.Url (getUrlOptions, withUrlOptions) import Utility.Url (checkBoth, UrlOptions(..)) import Utility.Env @@ -76,14 +78,15 @@ gen r u c gc = do 	cst <- remoteCost gc expensiveRemoteCost 	info <- extractS3Info c+	hdl <- mkS3HandleVar c gc u 	magic <- liftIO initMagicMimeType-	return $ new cst info magic+	return $ new cst info hdl magic   where-	new cst info magic = Just $ specialRemote c-		(prepareS3Handle this $ store this info magic)-		(prepareS3HandleMaybe this $ retrieve this c info)-		(prepareS3Handle this $ remove info)-		(prepareS3HandleMaybe this $ checkKey this c info)+	new cst info hdl magic = Just $ specialRemote c+		(simplyPrepare $ store hdl this info magic)+		(simplyPrepare $ retrieve hdl this c info)+		(simplyPrepare $ remove hdl this info)+		(simplyPrepare $ checkKey hdl this c info) 		this 	  where 		this = Remote@@ -100,16 +103,15 @@ 			, lockContent = Nothing 			, checkPresent = checkPresentDummy 			, checkPresentCheap = False-			, exportActions = withS3HandleMaybe c gc u $ \mh -> -				return $ ExportActions-					{ storeExport = storeExportS3 u info mh magic-					, retrieveExport = retrieveExportS3 u info mh-					, removeExport = removeExportS3 u info mh-					, checkPresentExport = checkPresentExportS3 u info mh-					-- S3 does not have directories.-					, removeExportDirectory = Nothing-					, renameExport = renameExportS3 u info mh-					}+			, exportActions = ExportActions+				{ storeExport = storeExportS3 hdl this info magic+				, retrieveExport = retrieveExportS3 hdl this info+				, removeExport = removeExportS3 hdl this info+				, checkPresentExport = checkPresentExportS3 hdl this info+				-- S3 does not have directories.+				, removeExportDirectory = Nothing+				, renameExport = renameExportS3 hdl this info+				} 			, whereisKey = Just (getPublicWebUrls u info c) 			, remoteFsck = Nothing 			, repairRepo = Nothing@@ -179,23 +181,13 @@ 			-- special constraints on key names 			M.insert "mungekeys" "ia" defaults 		info <- extractS3Info archiveconfig-		withS3Handle archiveconfig gc u $+		hdl <- mkS3HandleVar archiveconfig gc u+		withS3HandleOrFail u hdl $ 			writeUUIDFile archiveconfig u info 		use archiveconfig --- Sets up a http connection manager for S3 endpoint, which allows--- http connections to be reused across calls to the helper.-prepareS3Handle :: Remote -> (S3Handle -> helper) -> Preparer helper-prepareS3Handle r = resourcePrepare $ const $-	withS3Handle (config r) (gitconfig r) (uuid r)---- Allows for read-only actions, which can be run without a S3Handle.-prepareS3HandleMaybe :: Remote -> (Maybe S3Handle -> helper) -> Preparer helper-prepareS3HandleMaybe r = resourcePrepare $ const $-	withS3HandleMaybe (config r) (gitconfig r) (uuid r)--store :: Remote -> S3Info -> Maybe Magic -> S3Handle -> Storer-store _r info magic h = fileStorer $ \k f p -> do+store :: S3HandleVar -> Remote -> S3Info -> Maybe Magic -> Storer+store mh r info magic = fileStorer $ \k f p -> withS3HandleOrFail (uuid r) mh $ \h -> do 	void $ storeHelper info h magic f (T.pack $ bucketObject info k) p 	-- Store public URL to item in Internet Archive. 	when (isIA info && not (isChunkKey k)) $@@ -203,23 +195,24 @@ 	return True  storeHelper :: S3Info -> S3Handle -> Maybe Magic -> FilePath -> S3.Object -> MeterUpdate -> Annex (Maybe S3VersionID)-storeHelper info h magic f object p = case partSize info of+storeHelper info h magic f object p = liftIO $ case partSize info of 	Just partsz | partsz > 0 -> do-		fsz <- liftIO $ getFileSize f+		fsz <- getFileSize f 		if fsz > partsz 			then multipartupload fsz partsz 			else singlepartupload 	_ -> singlepartupload   where-	singlepartupload = do-		contenttype <- getcontenttype+	singlepartupload = runResourceT $ do+		contenttype <- liftIO getcontenttype 		rbody <- liftIO $ httpBodyStorer f p-		r <- sendS3Handle h $ (putObject info object rbody)+		let req = (putObject info object rbody) 			{ S3.poContentType = encodeBS <$> contenttype }-		return (mkS3VersionID object (S3.porVersionId r))-	multipartupload fsz partsz = do+		vid <- S3.porVersionId <$> sendS3Handle h req+		return (mkS3VersionID object vid)+	multipartupload fsz partsz = runResourceT $ do #if MIN_VERSION_aws(0,16,0)-		contenttype <- getcontenttype+		contenttype <- liftIO getcontenttype 		let startreq = (S3.postInitiateMultipartUpload (bucket info) object) 				{ S3.imuStorageClass = Just (storageClass info) 				, S3.imuMetadata = metaHeaders info@@ -259,29 +252,29 @@ 			(bucket info) object uploadid (zip [1..] etags) 		return (mkS3VersionID object (S3.cmurVersionId r)) #else-		warning $ "Cannot do multipart upload (partsize " ++ show partsz ++ ") of large file (" ++ show fsz ++ "); built with too old a version of the aws library."+		warningIO $ "Cannot do multipart upload (partsize " ++ show partsz ++ ") of large file (" ++ show fsz ++ "); built with too old a version of the aws library." 		singlepartupload #endif-	getcontenttype = liftIO $-		maybe (pure Nothing) (flip getMagicMimeType f) magic+	getcontenttype = maybe (pure Nothing) (flip getMagicMimeType f) magic  {- Implemented as a fileRetriever, that uses conduit to stream the chunks  - out to the file. Would be better to implement a byteRetriever, but  - that is difficult. -}-retrieve :: Remote -> RemoteConfig -> S3Info -> Maybe S3Handle -> Retriever-retrieve r c info (Just h) = fileRetriever $ \f k p ->-	eitherS3VersionID info (uuid r) c k (T.pack $ bucketObject info k) >>= \case-		Left failreason -> do-			warning failreason-			giveup "cannot download content"-		Right loc -> retrieveHelper info h loc f p-retrieve r c info Nothing = fileRetriever $ \f k p ->-	getPublicWebUrls' (uuid r) info c k >>= \case-		Left failreason -> do-			warning failreason-			giveup "cannot download content"-		Right us -> unlessM (downloadUrl k p us f) $-			giveup "failed to download content"+retrieve :: S3HandleVar -> Remote -> RemoteConfig -> S3Info -> Retriever+retrieve hv r c info = fileRetriever $ \f k p -> withS3Handle hv $ \case+	(Just h) -> +		eitherS3VersionID info (uuid r) c k (T.pack $ bucketObject info k) >>= \case+			Left failreason -> do+				warning failreason+				giveup "cannot download content"+			Right loc -> retrieveHelper info h loc f p+	Nothing ->+		getPublicWebUrls' (uuid r) info c k >>= \case+			Left failreason -> do+				warning failreason+				giveup "cannot download content"+			Right us -> unlessM (downloadUrl k p us f) $+				giveup "failed to download content"  retrieveHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> FilePath -> MeterUpdate -> Annex () retrieveHelper info h loc f p = liftIO $ runResourceT $ do@@ -289,42 +282,40 @@ 		Left o -> S3.getObject (bucket info) o 		Right (S3VersionID o vid) -> (S3.getObject (bucket info) o) 			{ S3.goVersionId = Just vid }-	S3.GetObjectResponse { S3.gorResponse = rsp } <- sendS3Handle' h req+	S3.GetObjectResponse { S3.gorResponse = rsp } <- sendS3Handle h req 	Url.sinkResponseFile p zeroBytesProcessed f WriteMode rsp  retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool retrieveCheap _ _ _ = return False -{- Internet Archive doesn't easily allow removing content.- - While it may remove the file, there are generally other files- - derived from it that it does not remove. -}-remove :: S3Info -> S3Handle -> Remover-remove info h k = do+remove :: S3HandleVar -> Remote -> S3Info -> Remover+remove hv r info k = withS3HandleOrFail (uuid r) hv $ \h -> liftIO $ runResourceT $ do 	res <- tryNonAsync $ sendS3Handle h $ 		S3.DeleteObject (T.pack $ bucketObject info k) (bucket info) 	return $ either (const False) (const True) res -checkKey :: Remote -> RemoteConfig -> S3Info -> Maybe S3Handle -> CheckPresent-checkKey r c info (Just h) k = do-	showChecking r-	eitherS3VersionID info (uuid r) c k (T.pack $ bucketObject info k) >>= \case-		Left failreason -> do-			warning failreason-			giveup "cannot check content"-		Right loc -> checkKeyHelper info h loc-checkKey r c info Nothing k = -	getPublicWebUrls' (uuid r) info c k >>= \case-		Left failreason -> do-			warning failreason-			giveup "cannot check content"-		Right us -> do-			showChecking r-			let check u = withUrlOptions $ -				liftIO . checkBoth u (keySize k)-			anyM check us+checkKey :: S3HandleVar -> Remote -> RemoteConfig -> S3Info -> CheckPresent+checkKey hv r c info k = withS3Handle hv $ \case+	Just h -> do+		showChecking r+		eitherS3VersionID info (uuid r) c k (T.pack $ bucketObject info k) >>= \case+			Left failreason -> do+				warning failreason+				giveup "cannot check content"+			Right loc -> checkKeyHelper info h loc+	Nothing ->+		getPublicWebUrls' (uuid r) info c k >>= \case+			Left failreason -> do+				warning failreason+				giveup "cannot check content"+			Right us -> do+				showChecking r+				let check u = withUrlOptions $ +					liftIO . checkBoth u (keySize k)+				anyM check us  checkKeyHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> Annex Bool-checkKeyHelper info h loc = do+checkKeyHelper info h loc = liftIO $ runResourceT $ do #if MIN_VERSION_aws(0,10,0) 	rsp <- go 	return (isJust $ S3.horMetadata rsp)@@ -353,63 +344,68 @@ 			| otherwise = Nothing #endif -storeExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool-storeExportS3 u info (Just h) magic f k loc p = -	catchNonAsync go (\e -> warning (show e) >> return False)+storeExportS3 :: S3HandleVar -> Remote -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool+storeExportS3 hv r info magic f k loc p = withS3Handle hv $ \case+	Just h -> catchNonAsync (go h) (\e -> warning (show e) >> return False)+	Nothing -> do+		warning $ needS3Creds (uuid r)+		return False   where-	go = do+	go h = do 		let o = T.pack $ bucketExportLocation info loc 		storeHelper info h magic f o p-			>>= setS3VersionID info u k+			>>= setS3VersionID info (uuid r) k 		return True-storeExportS3 u _ Nothing _ _ _ _ _ = do-	warning $ needS3Creds u-	return False -retrieveExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool-retrieveExportS3 u info mh _k loc f p =+retrieveExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool+retrieveExportS3 hv r info _k loc f p = 	catchNonAsync go (\e -> warning (show e) >> return False)   where-	go = case mh of+	go = withS3Handle hv $ \case 		Just h -> do 			retrieveHelper info h (Left (T.pack exporturl)) f p 			return True 		Nothing -> case getPublicUrlMaker info of 			Nothing -> do-				warning $ needS3Creds u+				warning $ needS3Creds (uuid r) 				return False 			Just geturl -> Url.withUrlOptions $  				liftIO . Url.download p (geturl exporturl) f 	exporturl = bucketExportLocation info loc -removeExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Key -> ExportLocation -> Annex Bool-removeExportS3 u info (Just h) k loc = checkVersioning info u k $-	catchNonAsync go (\e -> warning (show e) >> return False)+removeExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> Annex Bool+removeExportS3 hv r info k loc = withS3Handle hv $ \case+	Just h -> checkVersioning info (uuid r) k $+		catchNonAsync (go h) (\e -> warning (show e) >> return False)+	Nothing -> do+		warning $ needS3Creds (uuid r)+		return False	   where-	go = do+	go h = liftIO $ runResourceT $ do 		res <- tryNonAsync $ sendS3Handle h $ 			S3.DeleteObject (T.pack $ bucketExportLocation info loc) (bucket info) 		return $ either (const False) (const True) res-removeExportS3 u _ Nothing _ _ = do-	warning $ needS3Creds u-	return False -checkPresentExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Key -> ExportLocation -> Annex Bool-checkPresentExportS3 _u info (Just h) _k loc =-	checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc))-checkPresentExportS3 u info Nothing k loc = case getPublicUrlMaker info of-	Nothing -> do-		warning $ needS3Creds u-		giveup "No S3 credentials configured"-	Just geturl -> withUrlOptions $ liftIO . -		checkBoth (geturl $ bucketExportLocation info loc) (keySize k)+checkPresentExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> Annex Bool+checkPresentExportS3 hv r info k loc = withS3Handle hv $ \case+	Just h -> checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc))+	Nothing -> case getPublicUrlMaker info of+		Just geturl -> withUrlOptions $ liftIO . +			checkBoth (geturl $ bucketExportLocation info loc) (keySize k)+		Nothing -> do+			warning $ needS3Creds (uuid r)+			giveup "No S3 credentials configured"  -- S3 has no move primitive; copy and delete.-renameExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Key -> ExportLocation -> ExportLocation -> Annex Bool-renameExportS3 u info (Just h) k src dest = checkVersioning info u k $ -	catchNonAsync go (\_ -> return False)+renameExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex Bool+renameExportS3 hv r info k src dest = withS3Handle hv $ \case+	Just h -> checkVersioning info (uuid r) k $ +		catchNonAsync (go h) (\_ -> return False)+	Nothing -> do +		warning $ needS3Creds (uuid r)+		return False   where-	go = do+	go h = liftIO $ runResourceT $ do 		let co = S3.copyObject (bucket info) dstobject 			(S3.ObjectId (bucket info) srcobject Nothing) 			S3.CopyMetadata@@ -419,9 +415,6 @@ 		return True 	srcobject = T.pack $ bucketExportLocation info src 	dstobject = T.pack $ bucketExportLocation info dest-renameExportS3 u _ Nothing _ _ _ = do-	warning $ needS3Creds u-	return False  {- Generate the bucket if it does not already exist, including creating the  - UUID file within the bucket.@@ -434,17 +427,19 @@ genBucket c gc u = do 	showAction "checking bucket" 	info <- extractS3Info c-	withS3Handle c gc u $ \h ->+	hdl <- mkS3HandleVar c gc u+	withS3HandleOrFail u hdl $ \h -> 		go info h =<< checkUUIDFile c u info h   where 	go _ _ (Right True) = noop 	go info h _ = do-		v <- tryNonAsync $ sendS3Handle h (S3.getBucket $ bucket info)+		v <- liftIO $ tryNonAsync $ runResourceT $+			sendS3Handle h (S3.getBucket $ bucket info) 		case v of 			Right _ -> noop 			Left _ -> do 				showAction $ "creating bucket in " ++ datacenter-				void $ sendS3Handle h $ +				void $ liftIO $ runResourceT $ sendS3Handle h $  					(S3.putBucket (bucket info)) 						{ S3.pbCannedAcl = acl info 						, S3.pbLocationConstraint = locconstraint@@ -480,7 +475,7 @@ 		Right False -> do 			warning "The bucket already exists, and its annex-uuid file indicates it is used by a different special remote." 			giveup "Cannot reuse this bucket."-		_ -> void $ sendS3Handle h mkobject+		_ -> void $ liftIO $ runResourceT $ sendS3Handle h mkobject   where 	file = T.pack $ uuidFile c 	uuidb = L.fromChunks [T.encodeUtf8 $ T.pack $ fromUUID u]@@ -491,7 +486,7 @@  - and has the specified UUID already. -} checkUUIDFile :: RemoteConfig -> UUID -> S3Info -> S3Handle -> Annex (Either SomeException Bool) checkUUIDFile c u info h = tryNonAsync $ liftIO $ runResourceT $ do-	resp <- tryS3 $ sendS3Handle' h (S3.getObject (bucket info) file)+	resp <- tryS3 $ sendS3Handle h (S3.getObject (bucket info) file) 	case resp of 		Left _ -> return False 		Right r -> do@@ -511,41 +506,26 @@ tryS3 :: ResourceT IO a -> ResourceT IO (Either S3.S3Error a) tryS3 a = (Right <$> a) `catch` (pure . Left) -data S3Handle = S3Handle +data S3Handle = S3Handle 	{ hmanager :: Manager 	, hawscfg :: AWS.Configuration 	, hs3cfg :: S3.S3Configuration AWS.NormalQuery 	} -{- Sends a request to S3 and gets back the response.- - - - Note that pureAws's use of ResourceT is bypassed here;- - the response should be fully processed while the S3Handle- - is still open, eg within a call to withS3Handle.- -}+{- Sends a request to S3 and gets back the response. -} sendS3Handle-	:: (AWS.Transaction req res, AWS.ServiceConfiguration req ~ S3.S3Configuration)-	=> S3Handle -	-> req-	-> Annex res-sendS3Handle h r = liftIO $ runResourceT $ sendS3Handle' h r--sendS3Handle' 	:: (AWS.Transaction r a, AWS.ServiceConfiguration r ~ S3.S3Configuration) 	=> S3Handle 	-> r 	-> ResourceT IO a-sendS3Handle' h r = AWS.pureAws (hawscfg h) (hs3cfg h) (hmanager h) r+sendS3Handle h r = AWS.pureAws (hawscfg h) (hs3cfg h) (hmanager h) r -withS3Handle :: RemoteConfig -> RemoteGitConfig -> UUID -> (S3Handle -> Annex a) -> Annex a-withS3Handle c gc u a = withS3HandleMaybe c gc u $ \mh -> case mh of-	Just h -> a h-	Nothing -> do-		warning $ needS3Creds u-		giveup "No S3 credentials configured"+type S3HandleVar = TVar (Either (Annex (Maybe S3Handle)) (Maybe S3Handle)) -withS3HandleMaybe :: RemoteConfig -> RemoteGitConfig -> UUID -> (Maybe S3Handle -> Annex a) -> Annex a-withS3HandleMaybe c gc u a = do+{- Prepares a S3Handle for later use. Does not connect to S3 or do anything+ - else expensive. -}+mkS3HandleVar :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex S3HandleVar+mkS3HandleVar c gc u = liftIO $ newTVarIO $ Left $ do 	mcreds <- getRemoteCredPair c gc (AWS.creds u) 	case mcreds of 		Just creds -> do@@ -554,12 +534,27 @@ #if MIN_VERSION_aws(0,17,0) 				Nothing #endif-			withUrlOptions $ \ou ->-				a $ Just $ S3Handle (httpManager ou) awscfg s3cfg-		Nothing -> a Nothing+			ou <- getUrlOptions+			return $ Just $ S3Handle (httpManager ou) awscfg s3cfg+		Nothing -> return Nothing   where 	s3cfg = s3Configuration c +withS3Handle :: S3HandleVar -> (Maybe S3Handle -> Annex a) -> Annex a+withS3Handle hv a = liftIO (readTVarIO hv) >>= \case+	Right hdl -> a hdl+	Left mkhdl -> do+		hdl <- mkhdl+		liftIO $ atomically $ writeTVar hv (Right hdl)+		a hdl++withS3HandleOrFail :: UUID -> S3HandleVar -> (S3Handle -> Annex a) -> Annex a+withS3HandleOrFail u hv a = withS3Handle hv $ \case+	Just hdl -> a hdl+	Nothing -> do+		warning $ needS3Creds u+		giveup "No S3 credentials configured"+ needS3Creds :: UUID -> String needS3Creds u = missingCredPairFor "S3" (AWS.creds u) @@ -881,8 +876,10 @@ 	enableversioning b = do #if MIN_VERSION_aws(0,22,0) 		showAction "enabling bucket versioning"-		withS3Handle c gc u $ \h ->-			void $ sendS3Handle h $ S3.putBucketVersioning b S3.VersioningEnabled+		hdl <- mkS3HandleVar c gc u+		withS3HandleOrFail u hdl $ \h ->+			void $ liftIO $ runResourceT $ sendS3Handle h $+				S3.putBucketVersioning b S3.VersioningEnabled #else 		showLongNote $ unlines 			[ "This version of git-annex cannot auto-enable S3 bucket versioning."@@ -911,3 +908,4 @@ 			return False 		_ -> a 	| otherwise = a+
Remote/WebDAV.hs view
@@ -79,14 +79,14 @@ 			, lockContent = Nothing 			, checkPresent = checkPresentDummy 			, checkPresentCheap = False-			, exportActions = withDAVHandle this $ \mh -> return $ ExportActions-				{ storeExport = storeExportDav mh-				, retrieveExport = retrieveExportDav mh-				, checkPresentExport = checkPresentExportDav this mh-				, removeExport = removeExportDav mh+			, exportActions = ExportActions+				{ storeExport = storeExportDav this+				, retrieveExport = retrieveExportDav this+				, checkPresentExport = checkPresentExportDav this+				, removeExport = removeExportDav this 				, removeExportDirectory = Just $-					removeExportDirectoryDav mh-				, renameExport = renameExportDav mh+					removeExportDirectoryDav this+				, renameExport = renameExportDav this 				} 			, whereisKey = Nothing 			, remoteFsck = Nothing@@ -120,8 +120,6 @@ 	c'' <- setRemoteCredPair encsetup c' gc (davCreds u) creds 	return (c'', u) --- Opens a http connection to the DAV server, which will be reused--- each time the helper is called. prepareDAV :: Remote -> (Maybe DavHandle -> helper) -> Preparer helper prepareDAV = resourcePrepare . const . withDAVHandle @@ -195,45 +193,63 @@ 				existsDAV (keyLocation k) 			either giveup return v -storeExportDav :: Maybe DavHandle -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool-storeExportDav mh f k loc p = runExport mh $ \dav -> do-	reqbody <- liftIO $ httpBodyStorer f p-	storeHelper dav (keyTmpLocation k) (exportLocation loc) reqbody-	return True+storeExportDav :: Remote -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool+storeExportDav r f k loc p = case exportLocation loc of+	Right dest -> withDAVHandle r $ \mh -> runExport mh $ \dav -> do+		reqbody <- liftIO $ httpBodyStorer f p+		storeHelper dav (keyTmpLocation k) dest reqbody+		return True+	Left err -> do+		warning err+		return False -retrieveExportDav :: Maybe DavHandle -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool-retrieveExportDav mh  _k loc d p = runExport mh $ \_dav -> do-	retrieveHelper (exportLocation loc) d p-	return True+retrieveExportDav :: Remote -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool+retrieveExportDav r  _k loc d p = case exportLocation loc of+	Right src -> withDAVHandle r $ \mh -> runExport mh $ \_dav -> do+		retrieveHelper src d p+		return True+	Left _err -> return False -checkPresentExportDav :: Remote -> Maybe DavHandle -> Key -> ExportLocation -> Annex Bool-checkPresentExportDav r mh _k loc = case mh of-	Nothing -> giveup $ name r ++ " not configured"-	Just h -> liftIO $ do-		v <- goDAV h $ existsDAV (exportLocation loc)-		either giveup return v+checkPresentExportDav :: Remote -> Key -> ExportLocation -> Annex Bool+checkPresentExportDav r _k loc = case exportLocation loc of+	Right p -> withDAVHandle r $ \case+		Nothing -> giveup $ name r ++ " not configured"+		Just h -> liftIO $ do+			v <- goDAV h $ existsDAV p+			either giveup return v+	Left err -> giveup err -removeExportDav :: Maybe DavHandle -> Key -> ExportLocation -> Annex Bool-removeExportDav mh _k loc = runExport mh $ \_dav ->-	removeHelper (exportLocation loc)+removeExportDav :: Remote -> Key -> ExportLocation -> Annex Bool+removeExportDav r _k loc = case exportLocation loc of+	Right p -> withDAVHandle r $ \mh -> runExport mh $ \_dav ->+		removeHelper p+	-- When the exportLocation is not legal for webdav,+	-- the content is certianly not stored there, so it's ok for+	-- removal to succeed. This allows recovery after failure to store+	-- content there, as the user can rename the problem file and+	-- this will be called to make sure it's gone.+	Left _err -> return True -removeExportDirectoryDav :: Maybe DavHandle -> ExportDirectory -> Annex Bool-removeExportDirectoryDav mh dir = runExport mh $ \_dav -> do+removeExportDirectoryDav :: Remote -> ExportDirectory -> Annex Bool+removeExportDirectoryDav r dir = withDAVHandle r $ \mh -> runExport mh $ \_dav -> do 	let d = fromExportDirectory dir 	debugDav $ "delContent " ++ d 	safely (inLocation d delContentM) 		>>= maybe (return False) (const $ return True) -renameExportDav :: Maybe DavHandle -> Key -> ExportLocation -> ExportLocation -> Annex Bool-renameExportDav Nothing _ _ _ = return False-renameExportDav (Just h) _k src dest-	-- box.com's DAV endpoint has buggy handling of renames,-	-- so avoid renaming when using it.-	| boxComUrl `isPrefixOf` baseURL h = return False-	| otherwise = runExport (Just h) $ \dav -> do-		maybe noop (void . mkColRecursive) (locationParent (exportLocation dest))-		moveDAV (baseURL dav) (exportLocation src) (exportLocation dest)-		return True+renameExportDav :: Remote -> Key -> ExportLocation -> ExportLocation -> Annex Bool+renameExportDav r _k src dest = case (exportLocation src, exportLocation dest) of+	(Right srcl, Right destl) -> withDAVHandle r $ \case+		Just h+			-- box.com's DAV endpoint has buggy handling of renames,+			-- so avoid renaming when using it.+			| boxComUrl `isPrefixOf` baseURL h -> return False+			| otherwise -> runExport (Just h) $ \dav -> do+				maybe noop (void . mkColRecursive) (locationParent destl)+				moveDAV (baseURL dav) srcl destl+				return True+		Nothing -> return False+	_ -> return False  runExport :: Maybe DavHandle -> (DavHandle -> DAVT IO Bool) -> Annex Bool runExport Nothing _ = return False
Remote/WebDAV/DavLocation.hs view
@@ -46,8 +46,14 @@ keyLocation :: Key -> DavLocation keyLocation k = keyDir k ++ keyFile k -exportLocation :: ExportLocation -> DavLocation-exportLocation = fromExportLocation+{- Paths containing # or ? cannot be represented in an url, so fails on+ - those. -}+exportLocation :: ExportLocation -> Either String DavLocation+exportLocation l =+	let p = fromExportLocation l+	in if any (`elem` p) ['#', '?']+		then Left ("Cannot store file containing '#' or '?' on webdav: " ++ p)+		else Right p  {- Where we store temporary data for a key as it's being uploaded. -} keyTmpLocation :: Key -> DavLocation
Test/Framework.hs view
@@ -55,7 +55,7 @@  -- For when git-annex is expected to fail. git_annex_shouldfail :: String -> [String] -> IO Bool-git_annex_shouldfail command params = git_annex' command params >>= \case+git_annex_shouldfail command params = git_annex' command ("-q":params) >>= \case 	Right () -> return False 	Left _ -> return True @@ -67,7 +67,7 @@ 	run = GitAnnex.run dummyTestOptParser 		dummyTestRunner 		dummyBenchmarkGenerator-		(command:"-q":params)+		(command:params) 	dummyTestOptParser = pure mempty 	dummyTestRunner _ = noop 	dummyBenchmarkGenerator _ _ = return noop@@ -124,7 +124,7 @@ 		)   where 	isdirect = annexeval $ do-		Annex.Init.initialize (Annex.Init.AutoInit False) Nothing Nothing+		Annex.Init.initialize Nothing Nothing 		Config.isDirect  checkRepo :: Types.Annex a -> FilePath -> IO a
Types/MetaData.hs view
@@ -335,24 +335,26 @@  {- Avoid putting too many fields in the map; extremely large maps make  - the seriaization test slow due to the sheer amount of data.- - It's unlikely that more than 100 fields of metadata will be used. -}+ - It's unlikely that more than 10 fields of metadata will be used. -} instance Arbitrary MetaData where-	arbitrary = MetaData . M.filterWithKey legal . M.fromList-		<$> resize 10 (listOf arbitrary)+	arbitrary = MetaData . M.fromList <$> resize 10 (listOf arbitrary) 	  where-		legal k _v = legalField $ fromMetaField k  instance Arbitrary MetaValue where 	arbitrary = MetaValue  		<$> arbitrary-		-- Avoid non-ascii metavalues because fully arbitrary+		-- Avoid non-ascii MetaValues because fully arbitrary 		-- strings may not be encoded using the filesystem-		-- encoding, which is norally applied to all input.+		-- encoding, which is normally applied to all input. 		<*> (encodeBS <$> arbitrary `suchThat` all isAscii)  instance Arbitrary MetaField where 	arbitrary = MetaField . CI.mk-		<$> (T.pack <$> arbitrary) `suchThat` legalField+		-- Avoid non-ascii MetaFields because fully arbitrary+		-- strings may not be encoded using the filesystem+		-- encoding, which is normally applied to all input.+		<$> (T.pack <$> arbitrary `suchThat` all isAscii)+			`suchThat` legalField  prop_metadata_sane :: MetaData -> MetaField -> MetaValue -> Bool prop_metadata_sane m f v = and
Types/Remote.hs view
@@ -103,7 +103,7 @@ 	-- operation. 	, checkPresentCheap :: Bool 	-- Some remotes support exports of trees.-	, exportActions :: a (ExportActions a)+	, exportActions :: ExportActions a 	-- Some remotes can provide additional details for whereis. 	, whereisKey :: Maybe (Key -> a [String]) 	-- Some remotes can run a fsck operation on the remote,
Utility/IPAddress.hs view
@@ -11,6 +11,7 @@  import Network.Socket import Data.Word+import Data.Memory.Endian import Control.Applicative import Prelude @@ -67,8 +68,18 @@ 	(0x64,0xff9b,0,0,0,0,a,b) -> Just (toipv4 a b) 	_ -> Nothing   where-	toipv4 a b = htonl $ fromIntegral a * (2^halfipv4bits) + fromIntegral b 	halfipv4bits = 16 :: Word32+	toipv4 a b =+		let n = fromIntegral a * (2^halfipv4bits) + fromIntegral b+		-- HostAddress is in network byte order, but n is using host+		-- byte order so needs to be swapped.+		-- Could just use htonl n, but it's been dropped from the+		-- network library, so work around by manually swapping.+		in case getSystemEndianness of+			LittleEndian ->+				let (b1, b2, b3, b4) = hostAddressToTuple n+				in tupleToHostAddress (b4, b3, b2, b1)+			BigEndian -> n  {- Given a string containing an IP address, make a function that will  - match that address in a SockAddr. Nothing when the address cannot be
doc/git-annex-fromkey.mdwn view
@@ -42,6 +42,11 @@   (Note that for this to be used, you have to explicitly enable batch mode   with `--batch`) +* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.+ # SEE ALSO  [[git-annex]](1)
doc/git-annex.mdwn view
@@ -872,7 +872,8 @@   Maximum length of what is considered a filename extension when adding a   file to a backend that preserves filename extensions. The default length   is 4, which allows extensions like "jpeg". The dot before the extension-  is not counted part of its length.+  is not counted part of its length.  At most two extensions at the end of+  a filename will be preserved, e.g. .gz or .tar.gz .  * `annex.diskreserve`
git-annex.cabal view
@@ -1,7 +1,7 @@ Name: git-annex-Version: 7.20190129+Version: 7.20190219 Cabal-Version: >= 1.8-License: GPL-3+License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name> Author: Joey Hess Stability: Stable@@ -284,6 +284,10 @@ Flag Dbus   Description: Enable dbus support +Flag NetworkBSD+  Description: Build with network-3.0 which split out network-bsd+  Default: True+ source-repository head   type: git   location: git://git-annex.branchable.com/@@ -297,7 +301,6 @@   Main-Is: git-annex.hs   Build-Depends:    base (>= 4.9 && < 5.0),-   network (>= 2.6.3.0),    network-uri (>= 2.6),    optparse-applicative (>= 0.11.0),    containers (>= 0.5.7.1),@@ -391,6 +394,11 @@       process (>= 1.6.2.0)   else     Build-Depends: unix (>= 2.7.2)++  if flag(NetworkBSD)+    Build-Depends: network-bsd, network (>= 3.0.0.0)+  else+    Build-Depends: network (< 3.0.0.0), network (>= 2.6.3.0)    if flag(S3)     Build-Depends: aws (>= 0.9.2)
stack.yaml view
@@ -11,14 +11,17 @@     dbus: false     debuglocks: false     benchmark: false+    networkbsd: false packages: - '.' extra-deps: - IfElse-0.85 - aws-0.20 - bloomfilter-2.0.1.0+- tasty-1.1.0.4 - tasty-rerun-1.1.13 - torrent-10000.1.1+- sandi-0.5 explicit-setup-deps:   git-annex: true-resolver: lts-12.19+resolver: lts-13.6