packages feed

git-annex 6.20180509 → 6.20180529

raw patch · 31 files changed

+424/−215 lines, 31 files

Files

Annex/AdjustedBranch.hs view
@@ -91,7 +91,7 @@  ifSymlink :: (TreeItem -> Annex a) -> (TreeItem -> Annex a) -> TreeItem -> Annex a ifSymlink issymlink notsymlink ti@(TreeItem _f m _s)-	| toBlobType m == Just SymlinkBlob = issymlink ti+	| toTreeItemType m == Just TreeSymlink = issymlink ti 	| otherwise = notsymlink ti  noAdjust :: TreeItem -> Annex (Maybe TreeItem)@@ -101,7 +101,7 @@ adjustToPointer ti@(TreeItem f _m s) = catKey s >>= \case 	Just k -> do 		Database.Keys.addAssociatedFile k f-		Just . TreeItem f (fromBlobType FileBlob)+		Just . TreeItem f (fromTreeItemType TreeFile) 			<$> hashPointerFile k 	Nothing -> return (Just ti) @@ -114,7 +114,7 @@ 		absf <- inRepo $ \r -> absPath $ 			fromTopFilePath f r 		linktarget <- calcRepo $ gitannexlink absf k-		Just . TreeItem f (fromBlobType SymlinkBlob)+		Just . TreeItem f (fromTreeItemType TreeSymlink) 			<$> hashSymlink linktarget 	Nothing -> return (Just ti)
Annex/AutoMerge.hs view
@@ -23,7 +23,7 @@ import qualified Git.Ref import qualified Git import qualified Git.Branch-import Git.Types (BlobType(..), fromBlobType)+import Git.Types (TreeItemType(..), fromTreeItemType) import Git.FilePath import Config import Annex.ReplaceFile@@ -185,21 +185,23 @@ 			Just sha -> catKey sha 			Nothing -> return Nothing 	-	islocked select = select (LsFiles.unmergedBlobType u) == Just SymlinkBlob+	islocked select = select (LsFiles.unmergedTreeItemType u) == Just TreeSymlink  	combinedmodes = case catMaybes [ourmode, theirmode] of 		[] -> Nothing 		l -> Just (combineModes l) 	  where-		ourmode = fromBlobType <$> LsFiles.valUs (LsFiles.unmergedBlobType u)-		theirmode = fromBlobType <$> LsFiles.valThem (LsFiles.unmergedBlobType u)+		ourmode = fromTreeItemType+			<$> LsFiles.valUs (LsFiles.unmergedTreeItemType u)+		theirmode = fromTreeItemType+			<$> LsFiles.valThem (LsFiles.unmergedTreeItemType u)  	makeannexlink key select 		| islocked select = makesymlink key dest 		| otherwise = makepointer key dest destmode 	  where 		dest = variantFile file key-		destmode = fromBlobType <$> select (LsFiles.unmergedBlobType u)+		destmode = fromTreeItemType <$> select (LsFiles.unmergedTreeItemType u)  	stagefile :: FilePath -> Annex FilePath 	stagefile f@@ -242,11 +244,11 @@ 			=<< fromRepo (UpdateIndex.lsSubTree b item)  		-- Update the work tree to reflect the graft.-		unless inoverlay $ case (selectwant (LsFiles.unmergedBlobType u), selectunwant (LsFiles.unmergedBlobType u)) of+		unless inoverlay $ case (selectwant (LsFiles.unmergedTreeItemType u), selectunwant (LsFiles.unmergedTreeItemType u)) of 			-- Symlinks are never left in work tree when 			-- there's a conflict with anything else. 			-- So, when grafting in a symlink, we must create it:-			(Just SymlinkBlob, _) -> do+			(Just TreeSymlink, _) -> do 				case selectwant' (LsFiles.unmergedSha u) of 					Nothing -> noop 					Just sha -> do@@ -254,7 +256,7 @@ 						replacewithsymlink item link 			-- And when grafting in anything else vs a symlink, 			-- the work tree already contains what we want.-			(_, Just SymlinkBlob) -> noop+			(_, Just TreeSymlink) -> noop 			_ -> ifM (withworktree item (liftIO . doesDirectoryExist)) 				-- a conflict between a file and a directory 				-- leaves the directory, so since a directory
Annex/Branch.hs view
@@ -463,7 +463,7 @@ 				sha <- Git.HashObject.hashFile h path 				hPutStrLn jlogh file 				streamer $ Git.UpdateIndex.updateIndexLine-					sha FileBlob (asTopFilePath $ fileJournal file)+					sha TreeFile (asTopFilePath $ fileJournal file) 			genstream dir h jh jlogh streamer 	-- Clean up the staged files, as listed in the temp log file. 	-- The temp file is used to avoid needing to buffer all the@@ -573,7 +573,7 @@ 			ChangeFile content' -> do 				sha <- hashBlob content' 				Annex.Queue.addUpdateIndex $ Git.UpdateIndex.pureStreamer $-					Git.UpdateIndex.updateIndexLine sha FileBlob (asTopFilePath file)+					Git.UpdateIndex.updateIndexLine sha TreeFile (asTopFilePath file) 				apply rest file content' trustmap 			PreserveFile -> 				apply rest file content trustmap
Annex/Link.hs view
@@ -120,11 +120,11 @@ stagePointerFile :: FilePath -> Maybe FileMode -> Sha -> Annex () stagePointerFile file mode sha = 	Annex.Queue.addUpdateIndex =<<-		inRepo (Git.UpdateIndex.stageFile sha blobtype file)+		inRepo (Git.UpdateIndex.stageFile sha treeitemtype file)   where-	blobtype-		| maybe False isExecutable mode = ExecutableBlob-		| otherwise = FileBlob+	treeitemtype+		| maybe False isExecutable mode = TreeExecutable+		| otherwise = TreeFile  writePointerFile :: FilePath -> Key -> Maybe FileMode -> IO () writePointerFile file k mode = do
Annex/View.hs view
@@ -19,7 +19,6 @@ import qualified Git.Ref import Git.UpdateIndex import Git.Sha-import Annex.HashObject import Git.Types import Git.FilePath import Annex.WorkTree@@ -29,7 +28,6 @@ import Logs.MetaData import Logs.View import Utility.Glob-import Utility.FileMode import Types.Command import CmdLine.Action @@ -327,8 +325,9 @@ narrowView :: View -> Annex Git.Branch narrowView = applyView' viewedFileReuse getViewedFileMetaData -{- Go through each file in the currently checked out branch.- - If the file is not annexed, skip it, unless it's a dotfile in the top.+{- Go through each staged file.+ - If the file is not annexed, skip it, unless it's a dotfile in the top,+ - or a file in a dotdir in the top.   - Look up the metadata of annexed files, and generate any ViewedFiles,  - and stage them.  -@@ -337,39 +336,32 @@ applyView' :: MkViewedFile -> (FilePath -> MetaData) -> View -> Annex Git.Branch applyView' mkviewedfile getfilemetadata view = do 	top <- fromRepo Git.repoPath-	(l, clean) <- inRepo $ Git.LsFiles.inRepo [top]+	(l, clean) <- inRepo $ Git.LsFiles.stagedDetails [top] 	liftIO . nukeFile =<< fromRepo gitAnnexViewIndex 	uh <- withViewIndex $ inRepo Git.UpdateIndex.startUpdateIndex-	forM_ l $ \f -> do+	forM_ l $ \(f, sha, mode) -> do 		topf <- inRepo (toTopFilePath f)-		go uh topf =<< lookupFile f+		go uh topf sha (toTreeItemType =<< mode) =<< lookupFile f 	liftIO $ do 		void $ stopUpdateIndex uh 		void clean 	genViewBranch view   where 	genviewedfiles = viewedFiles view mkviewedfile -- enables memoization-	go uh topf (Just k) = do++	go uh topf _sha _mode (Just k) = do 		metadata <- getCurrentMetaData k 		let f = getTopFilePath topf 		let metadata' = getfilemetadata f `unionMetaData` metadata 		forM_ (genviewedfiles f metadata') $ \fv -> do 			f' <- fromRepo $ fromTopFilePath $ asTopFilePath fv 			stagesymlink uh f' =<< calcRepo (gitAnnexLink f' k)-	go uh topf Nothing-		| "." `isPrefixOf` getTopFilePath topf = do-			f <- fromRepo $ fromTopFilePath topf-			s <- liftIO $ getSymbolicLinkStatus f-			if isSymbolicLink s-				then stagesymlink uh f =<< liftIO (readSymbolicLink f)-				else do-					sha <- hashFile f-					let blobtype = if isExecutable (fileMode s)-						then ExecutableBlob-						else FileBlob-					liftIO . Git.UpdateIndex.streamUpdateIndex' uh-						=<< inRepo (Git.UpdateIndex.stageFile sha blobtype f)-		| otherwise = noop+	go uh topf (Just sha) (Just treeitemtype) Nothing+		| "." `isPrefixOf` getTopFilePath topf =+			liftIO $ Git.UpdateIndex.streamUpdateIndex' uh $+				pureStreamer $ updateIndexLine sha treeitemtype topf+	go _ _ _ _  _ = noop+ 	stagesymlink uh f linktarget = do 		sha <- hashSymlink linktarget 		liftIO . Git.UpdateIndex.streamUpdateIndex' uh
Annex/WorkTree.hs view
@@ -71,9 +71,9 @@ 				=<< catKey (Git.LsTree.sha i) 	liftIO $ void cleanup   where-	isregfile i = case Git.Types.toBlobType (Git.LsTree.mode i) of-		Just Git.Types.FileBlob -> True-		Just Git.Types.ExecutableBlob -> True+	isregfile i = case Git.Types.toTreeItemType (Git.LsTree.mode i) of+		Just Git.Types.TreeFile -> True+		Just Git.Types.TreeExecutable -> True 		_ -> False 	add i k = do 		let tf = Git.LsTree.file i
Backend/Hash.hs view
@@ -150,25 +150,40 @@ 	| c == '.' = True 	| otherwise = False -{- Upgrade keys that have the \ prefix on their sha due to a bug, or- - that contain non-alphanumeric characters in their extension. -}+{- Upgrade keys that have the \ prefix on their hash due to a bug, or+ - that contain non-alphanumeric characters in their extension.+ -+ - Also, for a while migrate from eg SHA256E to SHA256 resulted in a SHA256+ - key that contained an extension inside its keyName. Upgrade those+ - keys, removing the extension.+ -} needsUpgrade :: Key -> Bool-needsUpgrade key = "\\" `isPrefixOf` keyHash key ||-	any (not . validInExtension) (takeExtensions $ keyName key)+needsUpgrade key = or+	[ "\\" `isPrefixOf` keyHash key+	, any (not . validInExtension) (takeExtensions $ keyName key)+	, not (hasExt (keyVariety key)) && keyHash key /= keyName key+	]  trivialMigrate :: Key -> Backend -> AssociatedFile -> Maybe Key trivialMigrate oldkey newbackend afile 	{- Fast migration from hashE to hash backend. -}-	| migratable && hasExt newvariety = Just $ oldkey+	| migratable && hasExt oldvariety = Just $ oldkey 		{ keyName = keyHash oldkey 		, keyVariety = newvariety 		} 	{- Fast migration from hash to hashE backend. -}-	| migratable && hasExt oldvariety = case afile of+	| migratable && hasExt newvariety = case afile of 		AssociatedFile Nothing -> Nothing 		AssociatedFile (Just file) -> Just $ oldkey 			{ keyName = keyHash oldkey ++ selectExtension file 			, keyVariety = newvariety+			}+	{- Upgrade to fix bad previous migration that created a+	 - non-extension preserving key, with an extension+	 - in its keyName. -}+	| newvariety == oldvariety && not (hasExt oldvariety) &&+		keyHash oldkey /= keyName oldkey = Just $ oldkey+			{ keyName = keyHash oldkey 			} 	| otherwise = Nothing   where
CHANGELOG view
@@ -1,3 +1,33 @@+git-annex (6.20180529) upstream; urgency=medium++  * Prevent haskell http-client from decompressing gzip files, so downloads+    of such files works the same as it used to with wget and curl.+  * Workaround for bug in an old version of cryptonite that broke https+    downloads, by using curl for downloads when git-annex is built with it.+  * view, vadd: Fix crash when a git submodule has a name starting with a dot.+  * Don't allow entering a view with staged or unstaged changes.+  * move: --force was accidentially enabling two unrelated behaviors+    since 6.20180427. The older behavior, which has never been well+    documented and seems almost entirely useless, has been removed.+  * copy: --force no longer does anything.+  * migrate: Fix bug in migration between eg SHA256 and SHA256E, +    that caused the extension to be included in SHA256 keys,+    and omitted from SHA256E keys.+    (Bug introduced in version 6.20170214)+  * migrate: Check for above bug when migrating from SHA256 to SHA256+    (and same for SHA1 to SHA1 etc), and remove the extension that should+    not be in the SHA256 key.+  * fsck: Detect and warn when keys need an upgrade, either to fix up+    from the above migrate bug, or to add missing size information+    (a long ago transition), or because of a few other past key related+    bugs.+  * git-annex-shell: GIT_ANNEX_SHELL_APPENDONLY makes it allow writes,+    but not deletion of annexed content. Note that securing pushes to+    the git repository is left up to the user.+  * setpresentkey: Added --batch support.++ -- Joey Hess <id@joeyh.name>  Tue, 29 May 2018 13:05:26 -0400+ git-annex (6.20180509) upstream; urgency=medium    * The old git-annex Android app is now deprecated in favor of running
CmdLine/GitAnnexShell.hs view
@@ -17,6 +17,7 @@ import CmdLine.GitAnnexShell.Checks import CmdLine.GitAnnexShell.Fields import Remote.GCrypt (getGCryptUUID)+import P2P.Protocol (ServerMode(..))  import qualified Command.ConfigList import qualified Command.InAnnex@@ -30,38 +31,43 @@ import qualified Command.GCryptSetup import qualified Command.P2PStdIO -cmds_readonly :: [Command]-cmds_readonly =-	[ Command.ConfigList.cmd-	, gitAnnexShellCheck Command.InAnnex.cmd-	, gitAnnexShellCheck Command.LockContent.cmd-	, gitAnnexShellCheck Command.SendKey.cmd-	, gitAnnexShellCheck Command.TransferInfo.cmd-	, gitAnnexShellCheck Command.NotifyChanges.cmd-	]+import qualified Data.Map as M -cmds_notreadonly :: [Command]-cmds_notreadonly =-	[ gitAnnexShellCheck Command.RecvKey.cmd-	, gitAnnexShellCheck Command.DropKey.cmd-	, gitAnnexShellCheck Command.Commit.cmd-	, Command.GCryptSetup.cmd+cmdsMap :: M.Map ServerMode [Command]+cmdsMap = M.fromList $ map mk+	[ (ServeReadOnly, readonlycmds)+	, (ServeAppendOnly, appendcmds)+	, (ServeReadWrite, allcmds) 	]+  where+	readonlycmds = +		[ Command.ConfigList.cmd+		, gitAnnexShellCheck Command.InAnnex.cmd+		, gitAnnexShellCheck Command.LockContent.cmd+		, gitAnnexShellCheck Command.SendKey.cmd+		, gitAnnexShellCheck Command.TransferInfo.cmd+		, gitAnnexShellCheck Command.NotifyChanges.cmd+		-- p2pstdio checks the enviroment variables to+		-- determine the security policy to use+		, gitAnnexShellCheck Command.P2PStdIO.cmd+		]+	appendcmds = readonlycmds +++		[ gitAnnexShellCheck Command.RecvKey.cmd+		, gitAnnexShellCheck Command.Commit.cmd+		]+	allcmds =+		[ gitAnnexShellCheck Command.DropKey.cmd+		, Command.GCryptSetup.cmd+		] --- Commands that can operate readonly or not; they use checkNotReadOnly.-cmds_readonly_capable :: [Command]-cmds_readonly_capable =-	[ gitAnnexShellCheck Command.P2PStdIO.cmd-	]+	mk (s, l) = (s, map (adddirparam . noMessages) l)+	adddirparam c = c { cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c } -cmds_readonly_safe :: [Command]-cmds_readonly_safe = cmds_readonly ++ cmds_readonly_capable+cmdsFor :: ServerMode -> [Command]+cmdsFor = fromMaybe [] . flip M.lookup cmdsMap -cmds :: [Command]-cmds = map (adddirparam . noMessages)-	(cmds_readonly ++ cmds_notreadonly ++ cmds_readonly_capable)-  where-	adddirparam c = c { cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c }+cmdsList :: [Command]+cmdsList = concat $ M.elems cmdsMap  globalOptions :: [GlobalOption] globalOptions = @@ -101,17 +107,19 @@ 	| otherwise = external c  builtins :: [String]-builtins = map cmdname cmds+builtins = map cmdname cmdsList  builtin :: String -> String -> [String] -> IO () builtin cmd dir params = do-	unless (cmd `elem` map cmdname cmds_readonly_safe)+	unless (cmd `elem` map cmdname (cmdsFor ServeReadOnly)) 		checkNotReadOnly+	unless (cmd `elem` map cmdname (cmdsFor ServeAppendOnly))+		checkNotAppendOnly 	checkDirectory $ Just dir 	let (params', fieldparams, opts) = partitionParams params 	    rsyncopts = ("RsyncOptions", unwords opts) 	    fields = rsyncopts : filter checkField (parseFields fieldparams)-	dispatch False (cmd : params') cmds globalOptions fields mkrepo+	dispatch False (cmd : params') cmdsList globalOptions fields mkrepo 		"git-annex-shell" 		"Restricted login shell for git-annex only SSH access"   where@@ -161,6 +169,6 @@ 	| otherwise = False  failure :: IO ()-failure = giveup $ "bad parameters\n\n" ++ usage h cmds+failure = giveup $ "bad parameters\n\n" ++ usage h cmdsList   where 	h = "git-annex-shell [-c] command [parameters ...] [option ...]"
CmdLine/GitAnnexShell/Checks.hs view
@@ -26,6 +26,12 @@ checkNotReadOnly :: IO () checkNotReadOnly = checkEnv readOnlyEnv +appendOnlyEnv :: String+appendOnlyEnv = "GIT_ANNEX_SHELL_APPENDONLY"++checkNotAppendOnly :: IO ()+checkNotAppendOnly = checkEnv appendOnlyEnv+ checkEnv :: String -> IO () checkEnv var = checkEnvSet var >>= \case 	False -> noop
Command/DiffDriver.hs view
@@ -85,8 +85,8 @@ 	check rOldFile rOldMode (\r f -> r { rOldFile = f }) req 		>>= check rNewFile rNewMode (\r f -> r { rNewFile = f })   where-	check getfile getmode setfile r = case readBlobType (getmode r) of-		Just SymlinkBlob -> do+	check getfile getmode setfile r = case readTreeItemType (getmode r) of+		Just TreeSymlink -> do 			v <- getAnnexLinkTarget' (getfile r) False 			case fileKey . takeFileName =<< v of 				Nothing -> return r
Command/Fsck.hs view
@@ -129,6 +129,7 @@ 		, verifyWorkTree key file 		, checkKeySize key keystatus ai 		, checkBackend backend key keystatus afile+		, checkKeyUpgrade backend key ai afile 		, checkKeyNumCopies key afile numcopies 		]   where@@ -408,6 +409,31 @@ 			, "); " 			, msg 			]++{- Check for keys that are upgradable.+ -+ - Warns and suggests the user migrate, but does not migrate itself,+ - because migration can cause more disk space to be used, and makes+ - worktree changes that need to be committed.+ -}+checkKeyUpgrade :: Backend -> Key -> ActionItem -> AssociatedFile -> Annex Bool+checkKeyUpgrade backend key ai (AssociatedFile (Just file)) =+	case Types.Backend.canUpgradeKey backend of+		Just a | a key -> do+			warning $ concat+				[ actionItemDesc ai key+				, ": Can be upgraded to an improved key format. "+				, "You can do so by running: git annex migrate --backend="+				, formatKeyVariety (keyVariety key) ++ " "+				, file+				]+			return True+		_ -> return True+checkKeyUpgrade _ _ _ (AssociatedFile Nothing) =+	-- Don't suggest migrating without a filename, because+	-- while possible to do, there is no actual benefit from+	-- doing that in this situation.+	return True  {- Runs the backend specific check on a key's content object.  -
Command/Move.hs view
@@ -186,15 +186,13 @@ 		next $ fromPerform src removewhen key afile  fromOk :: Remote -> Key -> Annex Bool-fromOk src key = go =<< Annex.getState Annex.force+fromOk src key +	| Remote.hasKeyCheap src =+		either (const checklog) return =<< haskey+	| otherwise = checklog   where-	go True = either (const $ return True) return =<< haskey-	go False-		| Remote.hasKeyCheap src =-			either (const expensive) return =<< haskey-		| otherwise = expensive 	haskey = Remote.hasKey src key-	expensive = do+	checklog = do 		u <- getUUID 		remotes <- Remote.keyPossibilities key 		return $ u /= Remote.uuid src && elem src remotes
Command/P2PStdIO.hs view
@@ -26,10 +26,13 @@  start :: UUID -> CommandStart start theiruuid = do-	servermode <- liftIO $ -		Checks.checkEnvSet Checks.readOnlyEnv >>= return . \case-			True -> P2P.ServeReadOnly-			False -> P2P.ServeReadWrite+	servermode <- liftIO $ do+		ro <- Checks.checkEnvSet Checks.readOnlyEnv+		ao <- Checks.checkEnvSet Checks.appendOnlyEnv+		return $ case (ro, ao) of+			(True, _) -> P2P.ServeReadOnly+			(False, True) -> P2P.ServeAppendOnly+			(False, False) -> P2P.ServeReadWrite 	myuuid <- getUUID 	conn <- stdioP2PConnection <$> Annex.gitRepo 	let server = do
Command/SetPresentKey.hs view
@@ -16,19 +16,40 @@ 	command "setpresentkey" SectionPlumbing 		"change records of where key is present" 		(paramPair paramKey (paramPair paramUUID "[1|0]"))-		(withParams seek)+		(seek <$$> optParser) -seek :: CmdParams -> CommandSeek-seek = withWords start+data SetPresentKeyOptions = SetPresentKeyOptions+	{ params :: CmdParams+	, batchOption :: BatchMode+	} -start :: [String] -> CommandStart-start (ks:us:vs:[]) = do+optParser :: CmdParamsDesc -> Parser SetPresentKeyOptions+optParser desc = SetPresentKeyOptions+	<$> cmdParams desc+	<*> parseBatchOption++seek :: SetPresentKeyOptions -> CommandSeek+seek o = case batchOption o of+	Batch -> batchInput+		(parseKeyStatus . words)+		(batchCommandAction . start)+	NoBatch -> either giveup (commandAction . start)+		(parseKeyStatus $ params o)++data KeyStatus = KeyStatus Key UUID LogStatus++parseKeyStatus :: [String] -> Either String KeyStatus+parseKeyStatus (ks:us:vs:[]) = do+	k <- maybe (Left "bad key") Right (file2key ks)+	let u = toUUID us+	s <- maybe (Left "bad value") Right (parseStatus vs)+	return $ KeyStatus k u s+parseKeyStatus _ = Left "Bad input. Expected: key uuid value"++start :: KeyStatus -> CommandStart+start (KeyStatus k u s) = do 	showStartKey "setpresentkey" k (mkActionItem k)-	next $ perform k (toUUID us) s-  where-	k = fromMaybe (giveup "bad key") (file2key ks)-	s = fromMaybe (giveup "bad value") (parseStatus vs)-start _ = giveup "Wrong number of parameters"+	next $ perform k u s  perform :: Key -> UUID -> LogStatus -> CommandPerform perform k u s = next $ do
Command/Status.hs view
@@ -43,8 +43,8 @@ start o locs = do 	(l, cleanup) <- inRepo $ getStatus ps locs 	getstatus <- ifM isDirect-		( return statusDirect-		, return $ \s -> pure (Just s)+		( return (maybe (pure Nothing) statusDirect . simplifiedStatus)+		, return (pure . simplifiedStatus) 		) 	forM_ l $ \s -> maybe noop displayStatus =<< getstatus s 	ifM (liftIO cleanup)@@ -56,10 +56,16 @@ 		Nothing -> [] 		Just s -> [Param $ "--ignore-submodules="++s] +-- Prefer to show unstaged status in this simplified status.+simplifiedStatus :: StagedUnstaged Status -> Maybe Status+simplifiedStatus (StagedUnstaged { unstaged = Just s }) = Just s+simplifiedStatus (StagedUnstaged { staged = Just s }) = Just s+simplifiedStatus _ = Nothing+ displayStatus :: Status -> Annex ()--- renames not shown in this simplified status+-- Renames not shown in this simplified status displayStatus (Renamed _ _) = noop-displayStatus s  = do+displayStatus s = do 	let c = statusChar s 	absf <- fromRepo $ fromTopFilePath (statusFile s) 	f <- liftIO $ relPathCwdToFile absf
Command/View.hs view
@@ -12,6 +12,9 @@ import qualified Git.Command import qualified Git.Ref import qualified Git.Branch+import qualified Git.LsFiles as LsFiles+import Git.FilePath+import Git.Status import Types.View import Annex.View import Logs.View@@ -28,14 +31,43 @@ start [] = giveup "Specify metadata to include in view" start ps = do 	showStart' "view" Nothing-	view <- mkView ps-	go view  =<< currentView+	ifM safeToEnterView+		( do+			view <- mkView ps+			go view  =<< currentView+		, giveup "Not safe to enter view."+		)   where 	go view Nothing = next $ perform view 	go view (Just v) 		| v == view = stop 		| otherwise = giveup "Already in a view. Use the vfilter and vadd commands to further refine this view." +safeToEnterView :: Annex Bool+safeToEnterView = do+	(l, cleanup) <- inRepo $ getStatus [] []+	case filter dangerous l of+		[] -> liftIO cleanup+		_ -> do+			warning "Your uncommitted changes would be lost when entering a view."+			void $ liftIO cleanup+			return False+  where+	dangerous (StagedUnstaged { staged = Nothing, unstaged = Nothing }) = False+	-- Untracked files will not be affected by entering a view,+	-- so are not dangerous.+	dangerous (StagedUnstaged { staged = Just (Untracked _), unstaged = Nothing }) = False+	dangerous (StagedUnstaged { unstaged = Just (Untracked _), staged = Nothing }) = False+	dangerous (StagedUnstaged { unstaged = Just (Untracked _), staged = Just (Untracked _) }) = False+	-- Staged changes would have their modifications either be +	-- lost when entering a view, or committed as part of the view.+	-- Either is dangerous because upon leaving the view; the staged+	-- changes would be lost.+	dangerous (StagedUnstaged { staged = Just _ }) = True+	-- Unstaged changes to annexed files would get lost when entering a+	-- view.+	dangerous (StagedUnstaged { unstaged = Just _ }) = True+ perform :: View -> CommandPerform perform view = do 	showAction "searching"@@ -65,15 +97,21 @@ 	when ok $ do 		setView view 		{- A git repo can easily have empty directories in it,-		 - and this pollutes the view, so remove them. -}-		top <- fromRepo Git.repoPath-		liftIO $ removeemptydirs top+		 - and this pollutes the view, so remove them.+		 - (However, emptry directories used by submodules are not+		 - removed.) -}+		top <- liftIO . absPath =<< fromRepo Git.repoPath+		(l, cleanup) <- inRepo $+			LsFiles.notInRepoIncludingEmptyDirectories False [top]+		forM_ l (removeemptydir top)+		liftIO $ void cleanup 		unlessM (liftIO $ doesDirectoryExist here) $ do 			showLongNote (cwdmissing top) 	return ok   where-	removeemptydirs top = mapM_ (tryIO . removeDirectory)-		=<< dirTreeRecursiveSkipping (".git" `isSuffixOf`) top+	removeemptydir top d = do+		p <- inRepo $ toTopFilePath d+		liftIO $ tryIO $ removeDirectory (top </> getTopFilePath p) 	cwdmissing top = unlines 		[ "This view does not include the subdirectory you are currently in." 		, "Perhaps you should:  cd " ++ top
Git/LsFiles.hs view
@@ -1,6 +1,6 @@ {- git ls-files interface  -- - Copyright 2010,2012 Joey Hess <id@joeyh.name>+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -8,6 +8,7 @@ module Git.LsFiles ( 	inRepo, 	notInRepo,+	notInRepoIncludingEmptyDirectories, 	allFiles, 	deleted, 	modified,@@ -44,10 +45,14 @@  {- Scans for files at the specified locations that are not checked into git. -} notInRepo :: Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)-notInRepo include_ignored l repo = pipeNullSplit params repo+notInRepo = notInRepo' []++notInRepo' :: [CommandParam] -> Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)+notInRepo' ps include_ignored l repo = pipeNullSplit params repo   where 	params = concat 		[ [ Param "ls-files", Param "--others"]+		, ps 		, exclude 		, [ Param "-z", Param "--" ] 		, map File l@@ -56,6 +61,11 @@ 		| include_ignored = [] 		| otherwise = [Param "--exclude-standard"] +{- Scans for files at the specified locations that are not checked into+ - git. Empty directories are included in the result. -}+notInRepoIncludingEmptyDirectories :: Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)+notInRepoIncludingEmptyDirectories = notInRepo' [Param "--directory"]+ {- Finds all files in the specified locations, whether checked into git or  - not. -} allFiles :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)@@ -184,9 +194,9 @@  data Unmerged = Unmerged 	{ unmergedFile :: FilePath-	, unmergedBlobType :: Conflicting BlobType+	, unmergedTreeItemType :: Conflicting TreeItemType 	, unmergedSha :: Conflicting Sha-	} deriving (Show)+	}  {- Returns a list of the files in the specified locations that have  - unresolved merge conflicts.@@ -213,23 +223,23 @@ data InternalUnmerged = InternalUnmerged 	{ isus :: Bool 	, ifile :: FilePath-	, iblobtype :: Maybe BlobType+	, itreeitemtype :: Maybe TreeItemType 	, isha :: Maybe Sha-	} deriving (Show)+	}  parseUnmerged :: String -> Maybe InternalUnmerged parseUnmerged s 	| null file = Nothing 	| otherwise = case words metadata of-		(rawblobtype:rawsha:rawstage:_) -> do+		(rawtreeitemtype:rawsha:rawstage:_) -> do 			stage <- readish rawstage :: Maybe Int 			if stage /= 2 && stage /= 3 				then Nothing 				else do-					blobtype <- readBlobType rawblobtype+					treeitemtype <- readTreeItemType rawtreeitemtype 					sha <- extractSha rawsha 					return $ InternalUnmerged (stage == 2) file-						(Just blobtype) (Just sha)+						(Just treeitemtype) (Just sha) 		_ -> Nothing   where 	(metadata, file) = separate (== '\t') s@@ -239,12 +249,12 @@ reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest   where 	(rest, sibi) = findsib i is-	(blobtypeA, blobtypeB, shaA, shaB)-		| isus i    = (iblobtype i, iblobtype sibi, isha i, isha sibi)-		| otherwise = (iblobtype sibi, iblobtype i, isha sibi, isha i)+	(treeitemtypeA, treeitemtypeB, shaA, shaB)+		| isus i    = (itreeitemtype i, itreeitemtype sibi, isha i, isha sibi)+		| otherwise = (itreeitemtype sibi, itreeitemtype i, isha sibi, isha i) 	new = Unmerged 		{ unmergedFile = ifile i-		, unmergedBlobType = Conflicting blobtypeA blobtypeB+		, unmergedTreeItemType = Conflicting treeitemtypeA treeitemtypeB 		, unmergedSha = Conflicting shaA shaB 		} 	findsib templatei [] = ([], removed templatei)@@ -253,6 +263,6 @@ 		| otherwise = (l:ls, removed templatei) 	removed templatei = templatei 		{ isus = not (isus templatei)-		, iblobtype = Nothing+		, itreeitemtype = Nothing 		, isha = Nothing 		}
Git/Repair.hs view
@@ -396,10 +396,10 @@ 		void cleanup 		return $ map fst3 bad   where-	reinject (file, Just sha, Just mode) = case toBlobType mode of+	reinject (file, Just sha, Just mode) = case toTreeItemType mode of 		Nothing -> return Nothing-		Just blobtype -> Just <$>-			UpdateIndex.stageFile sha blobtype file r+		Just treeitemtype -> Just <$>+			UpdateIndex.stageFile sha treeitemtype file r 	reinject _ = return Nothing  newtype GoodCommits = GoodCommits (S.Set Sha)
Git/Status.hs view
@@ -1,6 +1,6 @@ {- git status interface  -- - Copyright 2015 Joey Hess <id@joeyh.name>+ - Copyright 2015-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -20,6 +20,11 @@ 	| TypeChanged TopFilePath 	| Untracked TopFilePath +data StagedUnstaged a = StagedUnstaged+	{ staged :: Maybe a+	, unstaged :: Maybe a+	}+ statusChar :: Status -> Char statusChar (Modified _) = 'M' statusChar (Deleted _) = 'D'@@ -36,35 +41,32 @@ statusFile (TypeChanged f) = f statusFile (Untracked f) = f -parseStatusZ :: [String] -> [Status]+parseStatusZ :: [String] -> [StagedUnstaged Status] parseStatusZ = go []   where 	go c [] = reverse c 	go c (x:xs) = case x of-		(sindex:sworktree:' ':f) -> -			-- Look at both the index and worktree status,-			-- preferring worktree.-			case cparse sworktree <|> cparse sindex of-				Just mks -> go (mks (asTopFilePath f) : c) xs-				Nothing -> if sindex == 'R'-					-- In -z mode, the name the-					-- file was renamed to comes-					-- first, and the next component-					-- is the old filename.-					then case xs of-						(oldf:xs') -> go (Renamed (asTopFilePath oldf) (asTopFilePath f) : c) xs'-						_ -> go c []-					else go c xs+		(sstaged:sunstaged:' ':f) -> +			case (cparse sstaged f xs, cparse sunstaged f xs) of+				((vstaged, xs1), (vunstaged, xs2)) ->+					let v = StagedUnstaged+						{ staged = vstaged+						, unstaged = vunstaged+						}+					    xs' = fromMaybe xs (xs1 <|> xs2)+					in go (v : c) xs' 		_ -> go c xs -	cparse 'M' = Just Modified-	cparse 'A' = Just Added-	cparse 'D' = Just Deleted-	cparse 'T' = Just TypeChanged-	cparse '?' = Just Untracked-	cparse _ = Nothing+	cparse 'M' f _ = (Just (Modified (asTopFilePath f)), Nothing)+	cparse 'A' f _ = (Just (Added (asTopFilePath f)), Nothing)+	cparse 'D' f _ = (Just (Deleted (asTopFilePath f)), Nothing)+	cparse 'T' f _ = (Just (TypeChanged (asTopFilePath f)), Nothing)+	cparse '?' f _ = (Just (Untracked (asTopFilePath f)), Nothing)+	cparse 'R' f (oldf:xs) =+		(Just (Renamed (asTopFilePath oldf) (asTopFilePath f)), Just xs)+	cparse _ _ _ = (Nothing, Nothing) -getStatus :: [CommandParam] -> [FilePath] -> Repo -> IO ([Status], IO Bool)+getStatus :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedUnstaged Status], IO Bool) getStatus ps fs r = do 	(ls, cleanup) <- pipeNullSplit ps' r 	return (parseStatusZ ls, cleanup)
Git/Types.hs view
@@ -1,6 +1,6 @@ {- git data types  -- - Copyright 2010-2012 Joey Hess <id@joeyh.name>+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -77,32 +77,36 @@ readObjectType "tree" = Just TreeObject readObjectType _ = Nothing -{- Types of blobs. -}-data BlobType = FileBlob | ExecutableBlob | SymlinkBlob+{- Types of items in a tree. -}+data TreeItemType = TreeFile | TreeExecutable | TreeSymlink | TreeSubmodule 	deriving (Eq) -{- Git uses magic numbers to denote the type of a blob. -}-instance Show BlobType where-	show FileBlob = "100644"-	show ExecutableBlob = "100755"-	show SymlinkBlob = "120000"+{- Git uses magic numbers to denote the type of a tree item. -}+readTreeItemType :: String -> Maybe TreeItemType+readTreeItemType "100644" = Just TreeFile+readTreeItemType "100755" = Just TreeExecutable+readTreeItemType "120000" = Just TreeSymlink+readTreeItemType "160000" = Just TreeSubmodule+readTreeItemType _ = Nothing -readBlobType :: String -> Maybe BlobType-readBlobType "100644" = Just FileBlob-readBlobType "100755" = Just ExecutableBlob-readBlobType "120000" = Just SymlinkBlob-readBlobType _ = Nothing+fmtTreeItemType :: TreeItemType -> String+fmtTreeItemType TreeFile = "100644"+fmtTreeItemType TreeExecutable = "100755"+fmtTreeItemType TreeSymlink = "120000"+fmtTreeItemType TreeSubmodule = "160000" -toBlobType :: FileMode -> Maybe BlobType-toBlobType 0o100644 = Just FileBlob-toBlobType 0o100755 = Just ExecutableBlob-toBlobType 0o120000 = Just SymlinkBlob-toBlobType _ = Nothing+toTreeItemType :: FileMode -> Maybe TreeItemType+toTreeItemType 0o100644 = Just TreeFile+toTreeItemType 0o100755 = Just TreeExecutable+toTreeItemType 0o120000 = Just TreeSymlink+toTreeItemType 0o160000 = Just TreeSubmodule+toTreeItemType _ = Nothing -fromBlobType :: BlobType -> FileMode-fromBlobType FileBlob = 0o100644-fromBlobType ExecutableBlob = 0o100755-fromBlobType SymlinkBlob = 0o120000+fromTreeItemType :: TreeItemType -> FileMode+fromTreeItemType TreeFile = 0o100644+fromTreeItemType TreeExecutable = 0o100755+fromTreeItemType TreeSymlink = 0o120000+fromTreeItemType TreeSubmodule = 0o160000  data Commit = Commit 	{ commitTree :: Sha
Git/UnionMerge.hs view
@@ -91,7 +91,7 @@   where 	[_colonmode, _bmode, asha, bsha, _status] = words info 	use sha = return $ Just $-		updateIndexLine sha FileBlob $ asTopFilePath file+		updateIndexLine sha TreeFile $ asTopFilePath file 	-- We don't know how the file is encoded, but need to 	-- split it into lines to union merge. Using the 	-- FileSystemEncoding for this is a hack, but ensures there
Git/UpdateIndex.hs view
@@ -83,14 +83,19 @@  {- Generates a line suitable to be fed into update-index, to add  - a given file with a given sha. -}-updateIndexLine :: Sha -> BlobType -> TopFilePath -> String-updateIndexLine sha filetype file =-	show filetype ++ " blob " ++ fromRef sha ++ "\t" ++ indexPath file+updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> String+updateIndexLine sha treeitemtype file = concat+	[ fmtTreeItemType treeitemtype+	, " blob "+	, fromRef sha+	, "\t"+	, indexPath file+	] -stageFile :: Sha -> BlobType -> FilePath -> Repo -> IO Streamer-stageFile sha filetype file repo = do+stageFile :: Sha -> TreeItemType -> FilePath -> Repo -> IO Streamer+stageFile sha treeitemtype file repo = do 	p <- toTopFilePath file repo-	return $ pureStreamer $ updateIndexLine sha filetype p+	return $ pureStreamer $ updateIndexLine sha treeitemtype p  {- A streamer that removes a file from the index. -} unstageFile :: FilePath -> Repo -> IO Streamer@@ -106,13 +111,13 @@ stageSymlink file sha repo = do 	!line <- updateIndexLine 		<$> pure sha-		<*> pure SymlinkBlob+		<*> pure TreeSymlink 		<*> toTopFilePath file repo 	return $ pureStreamer line  {- A streamer that applies a DiffTreeItem to the index. -} stageDiffTreeItem :: Diff.DiffTreeItem -> Streamer-stageDiffTreeItem d = case toBlobType (Diff.dstmode d) of+stageDiffTreeItem d = case toTreeItemType (Diff.dstmode d) of 	Nothing -> unstageFile' (Diff.file d) 	Just t -> pureStreamer $ updateIndexLine (Diff.dstsha d) t (Diff.file d)
P2P/Protocol.hs view
@@ -411,13 +411,21 @@ 				return ServerContinue 	handler _ = return ServerUnexpected -data ServerMode = ServeReadOnly | ServeReadWrite+data ServerMode+	= ServeReadOnly+	-- ^ Allow reading, but not writing.+	| ServeAppendOnly+	-- ^ Allow reading, and storing new objects, but not deleting objects.+	| ServeReadWrite+	-- ^ Full read and write access.+	deriving (Eq, Ord)  -- | Serve the protocol, with a peer that has authenticated. serveAuthed :: ServerMode -> UUID -> Proto () serveAuthed servermode myuuid = void $ serverLoop handler   where 	readonlyerror = net $ sendMessage (ERROR "this repository is read-only; write access denied")+	appendonlyerror = net $ sendMessage (ERROR "this repository is append-only; removal denied") 	handler (VERSION theirversion) = do 		let v = min theirversion maxProtocolVersion 		net $ setProtocolVersion v@@ -439,22 +447,15 @@ 		ServeReadWrite -> do 			sendSuccess =<< local (removeContent key) 			return ServerContinue+		ServeAppendOnly -> do+			appendonlyerror+			return ServerContinue 		ServeReadOnly -> do 			readonlyerror 			return ServerContinue 	handler (PUT af key) = case servermode of-		ServeReadWrite -> do-			have <- local $ checkContentPresent key-			if have-				then net $ sendMessage ALREADY_HAVE-				else do-					let sizer = tmpContentSize key-					let storer = \o l b v -> unVerified $-						storeContent key af o l b v-					(ok, _v) <- receiveContent Nothing nullMeterUpdate sizer storer PUT_FROM-					when ok $-						local $ setPresent key myuuid-			return ServerContinue+		ServeReadWrite -> handleput af key+		ServeAppendOnly -> handleput af key 		ServeReadOnly -> do 			readonlyerror 			return ServerContinue@@ -467,6 +468,10 @@ 		let goahead = net $ relayService service 		case (servermode, service) of 			(ServeReadWrite, _) -> goahead+			(ServeAppendOnly, UploadPack) -> goahead+			-- git protocol could be used to overwrite+			-- refs or something, so don't allow+			(ServeAppendOnly, ReceivePack) -> readonlyerror 			(ServeReadOnly, UploadPack) -> goahead 			(ServeReadOnly, ReceivePack) -> readonlyerror 		-- After connecting to git, there may be unconsumed data@@ -478,6 +483,19 @@ 		net $ sendMessage (CHANGED refs) 		return ServerContinue 	handler _ = return ServerUnexpected++	handleput af key = do+		have <- local $ checkContentPresent key+		if have+			then net $ sendMessage ALREADY_HAVE+			else do+				let sizer = tmpContentSize key+				let storer = \o l b v -> unVerified $+					storeContent key af o l b v+				(ok, _v) <- receiveContent Nothing nullMeterUpdate sizer storer PUT_FROM+				when ok $+					local $ setPresent key myuuid+		return ServerContinue  sendContent :: Key -> AssociatedFile -> Offset -> MeterUpdate -> Proto Bool sendContent key af offset@(Offset n) p = go =<< local (contentSize key)
Test.hs view
@@ -1402,7 +1402,7 @@ 	check_is_link f what = do 		git_annex_expectoutput "find" ["--include=*", f] [Git.FilePath.toInternalGitPath f] 		l <- annexeval $ Annex.inRepo $ Git.LsTree.lsTreeFiles Git.Ref.headRef [f]-		all (\i -> Git.Types.toBlobType (Git.LsTree.mode i) == Just Git.Types.SymlinkBlob) l+		all (\i -> Git.Types.toTreeItemType (Git.LsTree.mode i) == Just Git.Types.TreeSymlink) l 			@? (what ++ " " ++ f ++ " lost symlink bit after merge: " ++ show l)  {- A v6 unlocked file that conflicts with a locked file should be resolved
Utility/Url.hs view
@@ -90,7 +90,13 @@ 	UrlOptions useragent reqheaders urldownloader applyrequest manager   where 	urldownloader = if null reqparams+#if MIN_VERSION_cryptonite(0,6,0) 		then DownloadWithConduit+#else+		-- Work around for old cryptonite bug that broke tls.+		-- https://github.com/vincenthz/hs-tls/issues/109+		then DownloadWithCurl reqparams+#endif 		else DownloadWithCurl reqparams 	applyrequest = \r -> r { requestHeaders = requestHeaders r ++ addedheaders } 	addedheaders = uaheader ++ otherheaders@@ -278,11 +284,20 @@  	downloadconduit req = catchMaybeIO (getFileSize file) >>= \case 		Nothing -> runResourceT $ do-			resp <- http req (httpManager uo)+			resp <- http req' (httpManager uo) 			if responseStatus resp == ok200 				then store zeroBytesProcessed WriteMode resp 				else showrespfailure resp-		Just sz -> resumeconduit req sz+		Just sz -> resumeconduit req' sz+	  where+		-- Override http-client's default decompression of gzip+		-- compressed files. We want the unmodified file content.+		req' = req+			{ requestHeaders = (hAcceptEncoding, "identity") :+				filter ((/= hAcceptEncoding) . fst)+					(requestHeaders req)+			, decompress = const False+			} 	 	alreadydownloaded sz s h = s == requestedRangeNotSatisfiable416  		&& case lookup hContentRange h of@@ -322,7 +337,8 @@ 			_ -> show he #else 		let msg = case he of-			StatusCodeException status _ _ -> statusMessage status+			StatusCodeException status _ _ -> +				B8.toString (statusMessage status) 			_ -> show he #endif 		hPutStrLn stderr $ "download failed: " ++ msg
doc/git-annex-copy.mdwn view
@@ -46,12 +46,6 @@   already has content. This can be faster, but might skip copying content   to the remote in some cases. -* `--force`--  When copying content from a remote, ignore location tracking information-  and always check if the remote has content. Can be useful if the location-  tracking information is out of date.- * `--all` `-A`    Rather than specifying a filename or path to copy, this option can be
doc/git-annex-move.mdwn view
@@ -69,12 +69,6 @@   already has content. This can be faster, but might skip moving content   to the remote in some cases. -* `--force`--  When moving content from a remote, ignore location tracking information-  and always check if the remote has content. Can be useful if the location-  tracking information is out of date.- * file matching options    The [[git-annex-matching-options]](1)
doc/git-annex-setpresentkey.mdwn view
@@ -14,6 +14,13 @@ Use 1 to indicate the key is present, or 0 to indicate the key is not present. +# OPTIONS++* `--batch`++  Enables batch mode, in which lines are read from stdin.+  The line format is "key uuid [1|0]"+ # SEE ALSO  [[git-annex]](1)
doc/git-annex-shell.mdwn view
@@ -129,7 +129,8 @@  * GIT_ANNEX_SHELL_READONLY -  If set, disallows any command that could modify the repository.+  If set, disallows any action that could modify the git-annex +  repository.    Note that this does not prevent passing commands on to git-shell.   For that, you also need ...@@ -137,6 +138,19 @@ * GIT_ANNEX_SHELL_LIMITED    If set, disallows running git-shell to handle unknown commands.++* GIT_ANNEX_SHELL_APPENDONLY++  If set, allows data to be written to the git-annex repository,+  but does not allow data to be removed from it.++  Note that this does not prevent passing commands on to git-shell,+  so you will have to separately configure git to reject pushes that+  overwrite branches or are otherwise not appends. The git pre-receive+  hook may be useful for accomplishing this.++  It's a good idea to enable annex.securehashesonly in a repository+  that's set up this way.  * GIT_ANNEX_SHELL_DIRECTORY
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 6.20180509+Version: 6.20180529 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name>