packages feed

git-annex 6.20171003 → 6.20171018

raw patch · 33 files changed

+209/−105 lines, 33 files

Files

Annex.hs view
@@ -138,6 +138,7 @@ 	, existinghooks :: M.Map Git.Hook.Hook Bool 	, desktopnotify :: DesktopNotify 	, workers :: [Either AnnexState (Async AnnexState)]+	, activekeys :: TVar (M.Map Key ThreadId) 	, activeremotes :: MVar (M.Map (Types.Remote.RemoteA Annex) Integer) 	, keysdbhandle :: Maybe Keys.DbHandle 	, cachedcurrentbranch :: Maybe Git.Branch@@ -147,6 +148,7 @@ newState :: GitConfig -> Git.Repo -> IO AnnexState newState c r = do 	emptyactiveremotes <- newMVar M.empty+	emptyactivekeys <- newTVarIO M.empty 	o <- newMessageState 	sc <- newTMVarIO False 	return $ AnnexState@@ -192,6 +194,7 @@ 		, existinghooks = M.empty 		, desktopnotify = mempty 		, workers = []+		, activekeys = emptyactivekeys 		, activeremotes = emptyactiveremotes 		, keysdbhandle = Nothing 		, cachedcurrentbranch = Nothing
Annex/Ingest.hs view
@@ -128,9 +128,7 @@ 		Just k -> do 			let f = keyFilename source 			if lockingFile cfg-				then do-					liftIO $ nukeFile f-					addLink f k mic+				then addLink f k mic 				else ifM isDirect 					( do 						l <- calcRepo $ gitAnnexLink f k
Assistant/Install.hs view
@@ -107,7 +107,8 @@  	-- KDE 	home <- myHomeDir-	let kdeServiceMenusdir = home </> ".kde" </> "share" </> "kde4" </> "services" </> "ServiceMenus"+	userdata <- userDataDir+	let kdeServiceMenusdir = userdata </> "kservices5" </> "ServiceMenus" 	createDirectoryIfMissing True kdeServiceMenusdir 	writeFile (kdeServiceMenusdir </> "git-annex.desktop") 		(kdeDesktopFile actions)
CHANGELOG view
@@ -1,3 +1,24 @@+git-annex (6.20171018) unstable; urgency=medium++  * add: Replace work tree file atomically on systems supporting hard+    links. Avoids a window where interrupting an add could result in+    the file being moved into the annex, with no symlink yet created.+  * webdav: Avoid unncessisarily creating the collection at the top+    of the repository when storing files there, since that collection+    is created by initremote.+    (This seems to work around some brokenness of the box.com webdav+    server, which caused uploads to be very slow or sometimes fail.)+  * webdav: Make --debug show all webdav operations.+  * get -J/move -J/copy -J/mirror -J/sync -J: Avoid "transfer already in+    progress" errors when two files use the same key.+  * Konqueror desktop file location changed to one used by plasma 5.+    Thanks, Félix Sipma.+  * Avoid repeated checking that files passed on the command line exist.+  * Fix build with aws-0.17.+  * stack.yaml: Update to lts-9.9.++ -- Joey Hess <id@joeyh.name>  Wed, 18 Oct 2017 15:40:06 -0400+ git-annex (6.20171003) unstable; urgency=medium    * webdav: Improve error message for failed request to include the request
CmdLine/Action.hs view
@@ -1,6 +1,6 @@ {- git-annex command-line actions  -- - Copyright 2010-2015 Joey Hess <id@joeyh.name>+ - Copyright 2010-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -18,9 +18,12 @@ import Types.Messages import Remote.List +import Control.Concurrent import Control.Concurrent.Async+import Control.Concurrent.STM import Control.Exception (throwIO) import Data.Either+import qualified Data.Map.Strict as M  #ifdef WITH_CONCURRENTOUTPUT import qualified System.Console.Regions as Regions@@ -177,3 +180,36 @@ #else allowConcurrentOutput = id #endif++{- Ensures that only one thread processes a key at a time.+ - Other threads will block until it's done. -}+onlyActionOn :: Key -> CommandStart -> CommandStart+onlyActionOn k a = onlyActionOn' k run+  where+	run = do+		-- Run whole action, not just start stage, so other threads+		-- block until it's done.+		r <- callCommandAction' a+		case r of+			Nothing -> return Nothing+			Just r' -> return $ Just $ return $ Just $ return r'++onlyActionOn' :: Key -> Annex a -> Annex a+onlyActionOn' k a = go =<< Annex.getState Annex.concurrency+  where+	go NonConcurrent = a+	go (Concurrent _) = do+		tv <- Annex.getState Annex.activekeys+		bracket (setup tv) id (const a)+	setup tv = liftIO $ do+		mytid <- myThreadId+		atomically $ do+			m <- readTVar tv+			case M.lookup k m of+				Just tid+					| tid /= mytid -> retry+					| otherwise -> return (return ())+				Nothing -> do+					writeTVar tv $! M.insert k mytid m+					return $ liftIO $ atomically $+						modifyTVar tv $ M.delete k
CmdLine/Seek.hs view
@@ -32,22 +32,20 @@ import Annex.CatFile import Annex.Content -withFilesInGit :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek-withFilesInGit a params = seekActions $ prepFiltered a $-	seekHelper LsFiles.inRepo params+withFilesInGit :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek+withFilesInGit a l = seekActions $ prepFiltered a $+	seekHelper LsFiles.inRepo l -withFilesInGitNonRecursive :: String -> (FilePath -> CommandStart) -> CmdParams -> CommandSeek-withFilesInGitNonRecursive needforce a params = ifM (Annex.getState Annex.force)-	( withFilesInGit a params-	, if null params+withFilesInGitNonRecursive :: String -> (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek+withFilesInGitNonRecursive needforce a l = ifM (Annex.getState Annex.force)+	( withFilesInGit a l+	, if null l 		then giveup needforce-		else do-			checkFileOrDirectoryExists params-			seekActions $ prepFiltered a (getfiles [] params)+		else seekActions $ prepFiltered a (getfiles [] l) 	)   where 	getfiles c [] = return (reverse c)-	getfiles c (p:ps) = do+	getfiles c ((WorkTreeItem p):ps) = do 		(fs, cleanup) <- inRepo $ LsFiles.inRepo [p] 		case fs of 			[f] -> do@@ -58,24 +56,25 @@ 				getfiles c ps 			_ -> giveup needforce -withFilesNotInGit :: Bool -> (FilePath -> CommandStart) -> CmdParams -> CommandSeek-withFilesNotInGit skipdotfiles a params+withFilesNotInGit :: Bool -> (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek+withFilesNotInGit skipdotfiles a l 	| skipdotfiles = do 		{- dotfiles are not acted on unless explicitly listed -} 		files <- filter (not . dotfile) <$>-			seekunless (null ps && not (null params)) ps+			seekunless (null ps && not (null l)) ps 		dotfiles <- seekunless (null dotps) dotps 		go (files++dotfiles)-	| otherwise = go =<< seekunless False params+	| otherwise = go =<< seekunless False l   where-	(dotps, ps) = partition dotfile params+	(dotps, ps) = partition (\(WorkTreeItem f) -> dotfile f) l 	seekunless True _ = return []-	seekunless _ l = do+	seekunless _ l' = do 		force <- Annex.getState Annex.force 		g <- gitRepo-		liftIO $ Git.Command.leaveZombie <$> LsFiles.notInRepo force l g-	go l = seekActions $ prepFiltered a $-		return $ concat $ segmentPaths params l+		liftIO $ Git.Command.leaveZombie+			<$> LsFiles.notInRepo force (map (\(WorkTreeItem f) -> f) l') g+	go fs = seekActions $ prepFiltered a $+		return $ concat $ segmentPaths (map (\(WorkTreeItem f) -> f) l) fs  withFilesInRefs :: (FilePath -> Key -> CommandStart) -> [Git.Ref] -> CommandSeek withFilesInRefs a = mapM_ go@@ -121,14 +120,14 @@ 	pairs c (x:y:xs) = pairs ((x,y):c) xs 	pairs _ _ = giveup "expected pairs" -withFilesToBeCommitted :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek-withFilesToBeCommitted a params = seekActions $ prepFiltered a $-	seekHelper LsFiles.stagedNotDeleted params+withFilesToBeCommitted :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek+withFilesToBeCommitted a l = seekActions $ prepFiltered a $+	seekHelper LsFiles.stagedNotDeleted l -withFilesOldUnlocked :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek+withFilesOldUnlocked :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek withFilesOldUnlocked = withFilesOldUnlocked' LsFiles.typeChanged -withFilesOldUnlockedToBeCommitted :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek+withFilesOldUnlockedToBeCommitted :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek withFilesOldUnlockedToBeCommitted = withFilesOldUnlocked' LsFiles.typeChangedStaged  {- Unlocked files before v6 have changed type from a symlink to a regular file.@@ -136,23 +135,23 @@  - Furthermore, unlocked files used to be a git-annex symlink,  - not some other sort of symlink.  -}-withFilesOldUnlocked' :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> (FilePath -> CommandStart) -> CmdParams -> CommandSeek-withFilesOldUnlocked' typechanged a params = seekActions $+withFilesOldUnlocked' :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek+withFilesOldUnlocked' typechanged a l = seekActions $ 	prepFiltered a unlockedfiles   where-	unlockedfiles = filterM isOldUnlocked =<< seekHelper typechanged params+	unlockedfiles = filterM isOldUnlocked =<< seekHelper typechanged l  isOldUnlocked :: FilePath -> Annex Bool isOldUnlocked f = liftIO (notSymlink f) <&&>  	(isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f)  {- Finds files that may be modified. -}-withFilesMaybeModified :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek+withFilesMaybeModified :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek withFilesMaybeModified a params = seekActions $ 	prepFiltered a $ seekHelper LsFiles.modified params  withKeys :: (Key -> CommandStart) -> CmdParams -> CommandSeek-withKeys a params = seekActions $ return $ map (a . parse) params+withKeys a l = seekActions $ return $ map (a . parse) l   where 	parse p = fromMaybe (giveup "bad key") $ file2key p @@ -172,8 +171,8 @@ 	:: Maybe KeyOptions 	-> Bool 	-> (Key -> ActionItem -> CommandStart)-	-> (CmdParams -> CommandSeek)-	-> CmdParams+	-> ([WorkTreeItem] -> CommandSeek)+	-> [WorkTreeItem] 	-> CommandSeek withKeyOptions ko auto keyaction = withKeyOptions' ko auto mkkeyaction   where@@ -187,8 +186,8 @@ 	:: Maybe KeyOptions 	-> Bool 	-> Annex (Key -> ActionItem -> Annex ())-	-> (CmdParams -> CommandSeek)-	-> CmdParams+	-> ([WorkTreeItem] -> CommandSeek)+	-> [WorkTreeItem] 	-> CommandSeek withKeyOptions' ko auto mkkeyaction fallbackaction params = do 	bare <- fromRepo Git.repoIsLocalBare@@ -243,17 +242,27 @@ seekActions :: Annex [CommandStart] -> Annex () seekActions gen = mapM_ commandAction =<< gen -seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [FilePath] -> Annex [FilePath]-seekHelper a params = do-	checkFileOrDirectoryExists params-	inRepo $ \g -> concat . concat <$> forM (segmentXargsOrdered params)+seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [WorkTreeItem] -> Annex [FilePath]+seekHelper a l = inRepo $ \g ->+	concat . concat <$> forM (segmentXargsOrdered l') 		(runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g))+  where+	l' = map (\(WorkTreeItem f) -> f) l -checkFileOrDirectoryExists :: [FilePath] -> Annex ()-checkFileOrDirectoryExists ps = forM_ ps $ \p ->-	unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $ do-		toplevelWarning False (p ++ " not found")-		Annex.incError+-- An item in the work tree, which may be a file or a directory.+newtype WorkTreeItem = WorkTreeItem FilePath++-- Many git commands seek work tree items matching some criteria,+-- and silently skip over anything that does not exist. But users expect+-- an error message when one of the files they provided as a command-line+-- parameter doesn't exist, so this checks that each exists.+workTreeItems :: CmdParams -> Annex [WorkTreeItem]+workTreeItems ps = do+	forM_ ps $ \p ->+		unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $ do+			toplevelWarning False (p ++ " not found")+			Annex.incError+	return (map WorkTreeItem ps)  notSymlink :: FilePath -> IO Bool notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f
Command/Add.hs view
@@ -63,7 +63,8 @@ 				giveup "--update --batch is not supported" 			| otherwise -> batchFiles gofile 		NoBatch -> do-			let go a = a gofile (addThese o)+			l <- workTreeItems (addThese o)+			let go a = a gofile l 			unless (updateOnly o) $ 				go (withFilesNotInGit (not $ includeDotFiles o)) 			go withFilesMaybeModified
Command/Copy.hs view
@@ -43,7 +43,7 @@ 			(Command.Move.keyOptions $ moveOptions o) (autoMode o) 			(Command.Move.startKey (moveOptions o) False) 			(withFilesInGit go)-			(Command.Move.moveFiles $ moveOptions o)+			=<< workTreeItems (Command.Move.moveFiles $ moveOptions o)  {- A copy is just a move that does not delete the source file.  - However, auto mode avoids unnecessary copies, and avoids getting or
Command/Drop.hs view
@@ -58,7 +58,7 @@ 		NoBatch -> withKeyOptions (keyOptions o) (autoMode o) 			(startKeys o) 			(withFilesInGit go)-			(dropFiles o)+			=<< workTreeItems (dropFiles o)   where 	go = whenAnnexed $ start o
Command/Find.hs view
@@ -50,7 +50,7 @@  seek :: FindOptions -> CommandSeek seek o = case batchOption o of-	NoBatch -> withFilesInGit go (findThese o)+	NoBatch -> withFilesInGit go =<< workTreeItems (findThese o) 	Batch -> batchFiles go   where 	go = whenAnnexed $ start o
Command/Fix.hs view
@@ -34,7 +34,8 @@ 		( return FixAll 		, return FixSymlinks 		)-	flip withFilesInGit ps $ whenAnnexed $ start fixwhat+	l <- workTreeItems ps+	flip withFilesInGit l $ whenAnnexed $ start fixwhat  data FixWhat = FixSymlinks | FixAll
Command/Fsck.hs view
@@ -93,7 +93,7 @@ 	withKeyOptions (keyOptions o) False 		(\k ai -> startKey from i k ai =<< getNumCopies) 		(withFilesInGit $ whenAnnexed $ start from i)-		(fsckFiles o)+		=<< workTreeItems (fsckFiles o) 	cleanupIncremental i 	void $ tryIO $ recordActivity Fsck u
Command/Get.hs view
@@ -46,7 +46,7 @@ 		NoBatch -> withKeyOptions (keyOptions o) (autoMode o) 			(startKeys from) 			(withFilesInGit go)-			(getFiles o)+			=<< workTreeItems (getFiles o)  start :: GetOptions -> Maybe Remote -> FilePath -> Key -> CommandStart start o from file key = start' expensivecheck from key afile (mkActionItem afile)@@ -62,8 +62,8 @@ 	start' (return True) from key (AssociatedFile Nothing) ai  start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> CommandStart-start' expensivecheck from key afile ai = stopUnless (not <$> inAnnex key) $-	stopUnless expensivecheck $+start' expensivecheck from key afile ai = onlyActionOn key $+	stopUnless (not <$> inAnnex key) $ stopUnless expensivecheck $ 		case from of 			Nothing -> go $ perform key afile 			Just src ->
Command/List.hs view
@@ -44,7 +44,8 @@ seek o = do 	list <- getList o 	printHeader list-	withFilesInGit (whenAnnexed $ start list) (listThese o)+	withFilesInGit (whenAnnexed $ start list)+		=<< workTreeItems (listThese o)  getList :: ListOptions -> Annex [(UUID, RemoteName, TrustLevel)] getList o
Command/Lock.hs view
@@ -29,12 +29,14 @@ 		paramPaths (withParams seek)  seek :: CmdParams -> CommandSeek-seek ps = ifM versionSupportsUnlockedPointers-	( withFilesInGit (whenAnnexed startNew) ps-	, do-		withFilesOldUnlocked startOld ps-		withFilesOldUnlockedToBeCommitted startOld ps-	)+seek ps = do+	l <- workTreeItems ps+	ifM versionSupportsUnlockedPointers+		( withFilesInGit (whenAnnexed startNew) l+		, do+			withFilesOldUnlocked startOld l+			withFilesOldUnlockedToBeCommitted startOld l+		)  startNew :: FilePath -> Key -> CommandStart startNew file key = ifM (isJust <$> isAnnexLink file)
Command/Log.hs view
@@ -91,7 +91,8 @@ 	zone <- liftIO getCurrentTimeZone 	let outputter = mkOutputter m zone o 	case (logFiles o, allOption o) of-		(fs, False) -> withFilesInGit (whenAnnexed $ start o outputter) fs+		(fs, False) -> withFilesInGit (whenAnnexed $ start o outputter) +			=<< workTreeItems fs 		([], True) -> commandAction (startAll o outputter) 		(_, True) -> giveup "Cannot specify both files and --all"
Command/MetaData.hs view
@@ -81,7 +81,7 @@ 		withKeyOptions (keyOptions o) False 			(startKeys c o) 			(seeker $ whenAnnexed $ start c o)-			(forFiles o)+			=<< workTreeItems (forFiles o) 	Batch -> withMessageState $ \s -> case outputType s of 		JSONOutput _ -> batchInput parseJSONInput $ 			commandAction . startBatch
Command/Migrate.hs view
@@ -26,7 +26,7 @@ 		paramPaths (withParams seek)  seek :: CmdParams -> CommandSeek-seek = withFilesInGit $ whenAnnexed start+seek ps = withFilesInGit (whenAnnexed start) =<< workTreeItems ps  start :: FilePath -> Key -> CommandStart start file key = do@@ -74,7 +74,7 @@ 	checkcontent = Command.Fsck.checkBackend oldbackend oldkey Command.Fsck.KeyLocked afile 	finish newkey = ifM (Command.ReKey.linkKey file oldkey newkey) 		( do-			copyMetaData oldkey newkey+			_ <- copyMetaData oldkey newkey 			-- If the old key had some associated urls, record them for 			-- the new key as well. 			urls <- getUrls oldkey
Command/Mirror.hs view
@@ -45,7 +45,7 @@ 	withKeyOptions (keyOptions o) False 		(startKey o (AssociatedFile Nothing)) 		(withFilesInGit $ whenAnnexed $ start o)-		(mirrorFiles o)+		=<< workTreeItems (mirrorFiles o)  start :: MirrorOptions -> FilePath -> Key -> CommandStart start o file k = startKey o afile k (mkActionItem afile)@@ -53,7 +53,7 @@ 	afile = AssociatedFile (Just file)  startKey :: MirrorOptions -> AssociatedFile -> Key -> ActionItem -> CommandStart-startKey o afile key ai = case fromToOptions o of+startKey o afile key ai = onlyActionOn key $ case fromToOptions o of 	ToRemote r -> checkFailedTransferDirection ai Upload $ ifM (inAnnex key) 		( Command.Move.toStart False afile key ai =<< getParsed r 		, do
Command/Move.hs view
@@ -63,7 +63,7 @@ 		NoBatch -> withKeyOptions (keyOptions o) False 			(startKey o True) 			(withFilesInGit go)-			(moveFiles o)+			=<< workTreeItems (moveFiles o)  start :: MoveOptions -> Bool -> FilePath -> Key -> CommandStart start o move f k = start' o move afile k (mkActionItem afile)@@ -74,7 +74,7 @@ startKey o move = start' o move (AssociatedFile Nothing)  start' :: MoveOptions -> Bool -> AssociatedFile -> Key -> ActionItem -> CommandStart-start' o move afile key ai = +start' o move afile key ai = onlyActionOn key $ 	case fromToOptions o of 		Right (FromRemote src) -> 			checkFailedTransferDirection ai Download $
Command/Multicast.hs view
@@ -131,7 +131,7 @@ 		giveup "Sorry, multicast send cannot be done from a direct mode repository." 	 	showStart "generating file list" ""-	fs' <- seekHelper LsFiles.inRepo fs+	fs' <- seekHelper LsFiles.inRepo =<< workTreeItems fs 	matcher <- Limit.getMatcher 	let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f) $ 		liftIO $ hPutStrLn h o
Command/PreCommit.hs view
@@ -49,15 +49,16 @@ 					giveup "Cannot make a partial commit with unlocked annexed files. You should `git annex add` the files you want to commit, and then run git commit." 				void $ liftIO cleanup 			, do+				l <- workTreeItems ps 				-- fix symlinks to files being committed-				flip withFilesToBeCommitted ps $ \f -> +				flip withFilesToBeCommitted l $ \f ->  					maybe stop (Command.Fix.start Command.Fix.FixSymlinks f) 						=<< isAnnexLink f 				-- inject unlocked files into the annex 				-- (not needed when repo version uses 				-- unlocked pointer files) 				unlessM versionSupportsUnlockedPointers $-					withFilesOldUnlockedToBeCommitted startInjectUnlocked ps+					withFilesOldUnlockedToBeCommitted startInjectUnlocked l 			) 		runAnnexHook preCommitAnnexHook 		-- committing changes to a view updates metadata
Command/Sync.hs view
@@ -576,7 +576,10 @@ 	mvar <- liftIO newEmptyMVar 	bloom <- case keyOptions o of 		Just WantAllKeys -> Just <$> genBloomFilter (seekworktree mvar [])-		_ -> seekworktree mvar (contentOfOption o) (const noop) >> pure Nothing+		_ -> do+			l <- workTreeItems (contentOfOption o)+			seekworktree mvar l (const noop)+			pure Nothing 	withKeyOptions' (keyOptions o) False 		(return (seekkeys mvar bloom)) 		(const noop)@@ -606,7 +609,7 @@  - Returns True if any file transfers were made.  -} syncFile :: Either (Maybe (Bloom Key)) (Key -> Annex ()) -> [Remote] -> AssociatedFile -> Key -> Annex Bool-syncFile ebloom rs af k = do+syncFile ebloom rs af k = onlyActionOn' k $ do 	locs <- Remote.keyLocations k 	let (have, lack) = partition (\r -> Remote.uuid r `elem` locs) rs
Command/Unannex.hs view
@@ -30,7 +30,8 @@ 		paramPaths (withParams seek)  seek :: CmdParams -> CommandSeek-seek = wrapUnannex . (withFilesInGit $ whenAnnexed start)+seek ps = wrapUnannex $ +	(withFilesInGit $ whenAnnexed start) =<< workTreeItems ps  wrapUnannex :: Annex a -> Annex a wrapUnannex a = ifM (versionSupportsUnlockedPointers <||> isDirect)
Command/Uninit.hs view
@@ -40,9 +40,10 @@  seek :: CmdParams -> CommandSeek seek ps = do-	withFilesNotInGit False (whenAnnexed startCheckIncomplete) ps+	l <- workTreeItems ps+	withFilesNotInGit False (whenAnnexed startCheckIncomplete) l 	Annex.changeState $ \s -> s { Annex.fast = True }-	withFilesInGit (whenAnnexed Command.Unannex.start) ps+	withFilesInGit (whenAnnexed Command.Unannex.start) l 	finish  {- git annex symlinks that are not checked into git could be left by an
Command/Unlock.hs view
@@ -30,7 +30,7 @@ 	command n SectionCommon d paramPaths (withParams seek)  seek :: CmdParams -> CommandSeek-seek = withFilesInGit $ whenAnnexed start+seek ps = withFilesInGit (whenAnnexed start) =<< workTreeItems ps  {- Before v6, the unlock subcommand replaces the symlink with a copy of  - the file's content. In v6 and above, it converts the file from a symlink
Command/Whereis.hs view
@@ -44,7 +44,7 @@ 			withKeyOptions (keyOptions o) False 				(startKeys m) 				(withFilesInGit go)-				(whereisFiles o)+				=<< workTreeItems (whereisFiles o)  start :: M.Map UUID Remote -> FilePath -> Key -> CommandStart start remotemap file key = startKeys remotemap key (mkActionItem afile)
Logs/Transfer.hs view
@@ -108,7 +108,6 @@ 			-- due to permissions problems, races, etc. 			void $ tryIO $ do 				mode <- annexFileMode-				let lck = transferLockFile tfile 				r <- tryLockExclusive (Just mode) lck 				case r of 					Just lockhandle -> liftIO $ do
Remote/S3.hs view
@@ -497,6 +497,9 @@ 		Just creds -> do 			awscreds <- liftIO $ genCredentials creds 			let awscfg = AWS.Configuration AWS.Timestamp awscreds debugMapper+#if MIN_VERSION_aws(0,17,0)+				Nothing+#endif 			bracketIO (newManager managerSettings) closeManager $ \mgr ->  				a $ Just $ S3Handle mgr awscfg s3cfg 		Nothing -> a Nothing
Remote/WebDAV.hs view
@@ -20,6 +20,8 @@ import Network.HTTP.Types import System.IO.Error import Control.Monad.Catch+import Control.Monad.IO.Class (MonadIO)+import System.Log.Logger (debugM)  import Annex.Common import Types.Remote@@ -130,12 +132,14 @@ storeHelper :: DavHandle -> DavLocation -> DavLocation -> RequestBody -> DAVT IO () storeHelper dav tmp dest reqbody = do 	maybe noop (void . mkColRecursive) (locationParent tmp)+	debugDav $ "putContent " ++ tmp 	inLocation tmp $ 		putContentM' (contentType, reqbody) 	finalizeStore dav tmp dest  finalizeStore :: DavHandle -> DavLocation -> DavLocation -> DAVT IO () finalizeStore dav tmp dest = do+	debugDav $ "delContent " ++ dest 	inLocation dest $ void $ safely $ delContentM 	maybe noop (void . mkColRecursive) (locationParent dest) 	moveDAV (baseURL dav) tmp dest@@ -150,8 +154,10 @@ 	goDAV dav $ retrieveHelper (keyLocation k) d p  retrieveHelper :: DavLocation -> FilePath -> MeterUpdate -> DAVT IO ()-retrieveHelper loc d p = inLocation loc $-	withContentM $ httpBodyRetriever d p+retrieveHelper loc d p = do+	debugDav $ "retrieve " ++ loc+	inLocation loc $+		withContentM $ httpBodyRetriever d p  remove :: Maybe DavHandle -> Remover remove Nothing _ = return False@@ -162,6 +168,7 @@  removeHelper :: DavLocation -> DAVT IO Bool removeHelper d = do+	debugDav $ "delContent " ++ d 	v <- safely $ inLocation d delContentM 	case v of 		Just _ -> return True@@ -205,8 +212,10 @@ 	removeHelper (exportLocation loc)  removeExportDirectoryDav :: Maybe DavHandle -> ExportDirectory -> Annex Bool-removeExportDirectoryDav mh dir = runExport mh $ \_dav ->-	safely (inLocation (fromExportDirectory dir) delContentM)+removeExportDirectoryDav mh dir = 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@@ -295,14 +304,16 @@ mkColRecursive d = go =<< existsDAV d   where 	go (Right True) = return True-	go _ = ifM (inLocation d mkCol)-		( return True-		, do-			case locationParent d of-				Nothing -> makeParentDirs-				Just parent -> void (mkColRecursive parent)-			inLocation d mkCol-		)+	go _ = do+		debugDav $ "mkCol " ++ d+		ifM (inLocation d mkCol)+			( return True+			, do+				case locationParent d of+					Nothing -> makeParentDirs+					Just parent -> void (mkColRecursive parent)+				inLocation d mkCol+			)  getCreds :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe CredPair) getCreds c gc u = getRemoteCredPairFor "webdav" c gc (davCreds u)@@ -322,12 +333,16 @@ throwIO msg = ioError $ mkIOError userErrorType msg Nothing Nothing  moveDAV :: URLString -> DavLocation -> DavLocation -> DAVT IO ()-moveDAV baseurl src dest = inLocation src $ moveContentM newurl+moveDAV baseurl src dest = do+	debugDav $ "moveContent " ++ src ++ " " ++ newurl+	inLocation src $ moveContentM (B8.fromString newurl)   where-	newurl = B8.fromString (locationUrl baseurl dest)+	newurl = locationUrl baseurl dest  existsDAV :: DavLocation -> DAVT IO (Either String Bool)-existsDAV l = inLocation l check `catchNonAsync` (\e -> return (Left $ show e))+existsDAV l = do+	debugDav $ "getProps " ++ l+	inLocation l check `catchNonAsync` (\e -> return (Left $ show e))   where 	check = do 		-- Some DAV services only support depth of 1, and@@ -415,6 +430,7 @@   where 	storehttp l b' = void $ goDAV dav $ do 		maybe noop (void . mkColRecursive) (locationParent l)+		debugDav $ "putContent " ++ l 		inLocation l $ putContentM (contentType, b') 	storer locs = Legacy.storeChunked chunksize locs storehttp b 	recorder l s = storehttp l (L8.fromString s)@@ -428,7 +444,8 @@ retrieveLegacyChunked dav = fileRetriever $ \d k p -> liftIO $ 	withStoredFilesLegacyChunked k dav onerr $ \locs -> 		Legacy.meteredWriteFileChunks p d locs $ \l ->-			goDAV dav $+			goDAV dav $ do+				debugDav $ "getContent " ++ l 				inLocation l $ 					snd <$> getContentM   where@@ -462,7 +479,8 @@ 	-> IO a withStoredFilesLegacyChunked k dav onerr a = do 	let chunkcount = keyloc ++ Legacy.chunkCount-	v <- goDAV dav $ safely $ +	v <- goDAV dav $ safely $ do+		debugDav $ "getContent " ++ chunkcount 		inLocation chunkcount $ 			snd <$> getContentM 	case v of@@ -475,3 +493,6 @@ 				else a chunks   where 	keyloc = keyLocation k++debugDav :: MonadIO m => String -> DAVT m ()+debugDav msg = liftIO $ debugM "WebDAV" msg
Remote/WebDAV/DavLocation.hs view
@@ -58,10 +58,11 @@  locationParent :: String -> Maybe String locationParent loc-	| loc `elem` tops = Nothing-	| otherwise = Just (takeDirectory loc)+	| loc `elem` tops || parent `elem` tops = Nothing+	| otherwise = Just parent   where 	tops = ["/", "", "."]+	parent = takeDirectory loc  locationUrl :: URLString -> DavLocation -> URLString locationUrl baseurl loc = baseurl </> loc
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 6.20171003+Version: 6.20171018 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name>
stack.yaml view
@@ -17,10 +17,10 @@ packages: - '.' extra-deps:-- aws-0.16+- aws-0.17.1 - bloomfilter-2.0.1.0 - torrent-10000.1.1 - yesod-default-1.2.0 explicit-setup-deps:   git-annex: true-resolver: lts-8.13+resolver: lts-9.9