packages feed

git-annex 6.20160527 → 6.20160613

raw patch · 45 files changed

+388/−424 lines, 45 filessetup-changed

Files

Annex/AdjustedBranch.hs view
@@ -20,6 +20,7 @@ 	adjustToCrippledFileSystem, 	updateAdjustedBranch, 	propigateAdjustedCommits,+	AdjustedClone(..), 	checkAdjustedClone, 	isGitVersionSupported, 	checkVersionSupported,@@ -51,6 +52,7 @@ import Annex.GitOverlay import Utility.Tmp import qualified Database.Keys+import Config  import qualified Data.Map as M @@ -298,9 +300,20 @@ 	mkcommit = Git.Branch.commitTree Git.Branch.AutomaticCommit 		adjustedBranchCommitMessage parents treesha +{- This message should never be changed. -} adjustedBranchCommitMessage :: String adjustedBranchCommitMessage = "git-annex adjusted branch" +findAdjustingCommit :: AdjBranch -> Annex (Maybe Commit)+findAdjustingCommit (AdjBranch b) = go =<< catCommit b+  where+	go Nothing = return Nothing+	go (Just c)+		| commitMessage c == adjustedBranchCommitMessage = return (Just c)+		| otherwise = case commitParent c of+			[p] -> go =<< catCommit p+			_ -> return Nothing+ {- Update the currently checked out adjusted branch, merging the provided  - branch into it. Note that the provided branch should be a non-adjusted  - branch. -}@@ -345,10 +358,16 @@ 		withTmpDirIn misctmpdir "git" $ \tmpgit -> withWorkTreeRelated tmpgit $ 			withemptydir tmpwt $ withWorkTree tmpwt $ do 				liftIO $ writeFile (tmpgit </> "HEAD") (fromRef updatedorig)+				-- This reset makes git merge not care+				-- that the work tree is empty; otherwise+				-- it will think that all the files have+				-- been staged for deletion, and sometimes+				-- the merge includes these deletions+				-- (for an unknown reason).+				-- http://thread.gmane.org/gmane.comp.version-control.git/297237+				inRepo $ Git.Command.run [Param "reset", Param "HEAD", Param "--quiet"] 				showAction $ "Merging into " ++ fromRef (Git.Ref.base origbranch)-				-- The --no-ff is important; it makes git-				-- merge not care that the work tree is empty.-				merged <- inRepo (Git.Merge.merge' [Param "--no-ff"] tomerge mergeconfig commitmode)+				merged <- inRepo (Git.Merge.merge' [] tomerge mergeconfig commitmode) 					<||> (resolveMerge (Just updatedorig) tomerge True <&&> commitResolvedMerge commitmode) 				if merged 					then do@@ -539,23 +558,49 @@ 	(Git.DiffTree.dstmode dti) 	(Git.DiffTree.dstsha dti) +data AdjustedClone = InAdjustedClone | NotInAdjustedClone | NeedUpgradeForAdjustedClone+ {- Cloning a repository that has an adjusted branch checked out will  - result in the clone having the same adjusted branch checked out -- but- - the origbranch won't exist in the clone, nor will the basis.- - Create them. -}-checkAdjustedClone :: Annex ()-checkAdjustedClone = go =<< inRepo Git.Branch.current+ - the origbranch won't exist in the clone, nor will the basis. So+ - to properly set up the adjusted branch, the origbranch and basis need+ - to be set.+ - + - We can't trust that the origin's origbranch matches up with the currently+ - checked out adjusted branch; the origin could have the two branches+ - out of sync (eg, due to another branch having been pushed to the origin's+ - origbranch), or due to a commit on its adjusted branch not having been+ - propigated back to origbranch.+ -+ - So, find the adjusting commit on the currently checked out adjusted+ - branch, and use the parent of that commit as the basis, and set the+ - origbranch to it.+ -+ - The repository may also need to be upgraded to a new version, if the+ - current version is too old to support adjusted branches. -}+checkAdjustedClone :: Annex AdjustedClone+checkAdjustedClone = ifM isBareRepo+	( return NotInAdjustedClone+	, go =<< inRepo Git.Branch.current+	)   where-	go Nothing = return ()+	go Nothing = return NotInAdjustedClone 	go (Just currbranch) = case adjustedToOriginal currbranch of-		Nothing -> return ()+		Nothing -> return NotInAdjustedClone 		Just (adj, origbranch) -> do-			let remotebranch = Git.Ref.underBase "refs/remotes/origin" origbranch 			let basis@(BasisBranch bb) = basisBranch (originalToAdjusted origbranch adj)-			unlessM (inRepo $ Git.Ref.exists bb) $-				setBasisBranch basis remotebranch-			unlessM (inRepo $ Git.Ref.exists origbranch) $-				inRepo $ Git.Branch.update' origbranch remotebranch+			unlessM (inRepo $ Git.Ref.exists bb) $ do+				unlessM (inRepo $ Git.Ref.exists origbranch) $ do+					let remotebranch = Git.Ref.underBase "refs/remotes/origin" origbranch+					inRepo $ Git.Branch.update' origbranch remotebranch+				aps <- fmap commitParent <$> findAdjustingCommit (AdjBranch currbranch)+				case aps of+					Just [p] -> setBasisBranch basis p+					_ -> error $ "Unable to clean up from clone of adjusted branch; perhaps you should check out " ++ Git.Ref.describe origbranch+			ifM versionSupportsUnlockedPointers+				( return InAdjustedClone+				, return NeedUpgradeForAdjustedClone+				)  -- git 2.2.0 needed for GIT_COMMON_DIR which is needed -- by updateAdjustedBranch to use withWorkTreeRelated.
Annex/AutoMerge.hs view
@@ -121,7 +121,7 @@ 	let merged = not (null mergedfs') 	void $ liftIO cleanup -	unlessM isDirect $ do+	unlessM (pure inoverlay <||> isDirect) $ do 		(deleted, cleanup2) <- inRepo (LsFiles.deleted [top]) 		unless (null deleted) $ 			Annex.Queue.addCommand "rm"
Annex/Environment.hs view
@@ -33,7 +33,7 @@  checkEnvironmentIO :: IO () checkEnvironmentIO = whenM (isNothing <$> myUserGecos) $ do-	username <- myUserName+	username <- either (const "unknown") id <$> myUserName 	ensureEnv "GIT_AUTHOR_NAME" username 	ensureEnv "GIT_COMMITTER_NAME" username   where@@ -52,7 +52,7 @@ ensureCommit a = either retry return =<< tryNonAsync a    where 	retry _ = do-		name <- liftIO myUserName+		name <- liftIO $ either (const "unknown") id <$> myUserName 		setConfig (ConfigKey "user.name") name 		setConfig (ConfigKey "user.email") name 		a
Annex/GitOverlay.hs view
@@ -15,6 +15,7 @@ import Git.Index import Git.Env import qualified Annex+import qualified Annex.Queue  {- Runs an action using a different git index file. -} withIndexFile :: FilePath -> Annex a -> Annex a@@ -71,8 +72,18 @@ withAltRepo modrepo unmodrepo a = do 	g <- gitRepo 	g' <- liftIO $ modrepo g-	r <- tryNonAsync $ do-		Annex.changeState $ \s -> s { Annex.repo = g' }+	q <- Annex.Queue.get+	v <- tryNonAsync $ do+		Annex.changeState $ \s -> s+			{ Annex.repo = g'+			-- Start a separate queue for any changes made+			-- with the modified repo.+			, Annex.repoqueue = Nothing+			} 		a-	Annex.changeState $ \s -> s { Annex.repo = unmodrepo g (Annex.repo s) }-	either E.throw return r+	void $ tryNonAsync Annex.Queue.flush+	Annex.changeState $ \s -> s+		{ Annex.repo = unmodrepo g (Annex.repo s)+		, Annex.repoqueue = Just q+		}+	either E.throw return v
Annex/Ingest.hs view
@@ -11,6 +11,7 @@ 	lockDown, 	ingestAdd, 	ingest,+	ingest', 	finishIngestDirect, 	finishIngestUnlocked, 	cleanOldKeys,@@ -140,9 +141,12 @@  - tree or the index.  -} ingest :: Maybe LockedDown -> Annex (Maybe Key, Maybe InodeCache)-ingest Nothing = return (Nothing, Nothing)-ingest (Just (LockedDown cfg source)) = withTSDelta $ \delta -> do-	backend <- chooseBackend $ keyFilename source+ingest = ingest' Nothing++ingest' :: Maybe Backend -> Maybe LockedDown -> Annex (Maybe Key, Maybe InodeCache)+ingest' _ Nothing = return (Nothing, Nothing)+ingest' preferredbackend (Just (LockedDown cfg source)) = withTSDelta $ \delta -> do+	backend <- maybe (chooseBackend $ keyFilename source) (return . Just) preferredbackend 	k <- genKey source backend 	let src = contentLocation source 	ms <- liftIO $ catchMaybeIO $ getFileStatus src
Annex/Init.hs view
@@ -40,8 +40,8 @@ import Upgrade import Annex.Perms import qualified Database.Keys-#ifndef mingw32_HOST_OS import Utility.UserInfo+#ifndef mingw32_HOST_OS import Utility.FileMode import System.Posix.User import qualified Utility.LockFile.Posix as Posix@@ -52,13 +52,11 @@ genDescription Nothing = do 	reldir <- liftIO . relHome =<< liftIO . absPath =<< fromRepo Git.repoPath 	hostname <- fromMaybe "" <$> liftIO getHostname-#ifndef mingw32_HOST_OS 	let at = if null hostname then "" else "@"-	username <- liftIO myUserName-	return $ concat [username, at, hostname, ":", reldir]-#else-	return $ concat [hostname, ":", reldir]-#endif+	v <- liftIO myUserName+	return $ concat $ case v of+		Right username -> [username, at, hostname, ":", reldir]+		Left _ -> [hostname, ":", reldir]  initialize :: Maybe String -> Maybe Version -> Annex () initialize mdescription mversion = do@@ -85,7 +83,7 @@ 	checkLockSupport 	checkFifoSupport 	checkCrippledFileSystem-	unlessM isBare $+	unlessM isBareRepo $ 		hookWrite preCommitHook 	setDifferences 	unlessM (isJust <$> getVersion) $@@ -93,19 +91,23 @@ 	whenM versionSupportsUnlockedPointers $ do 		configureSmudgeFilter 		Database.Keys.scanAssociatedFiles-	ifM (crippledFileSystem <&&> (not <$> isBare))-		( ifM versionSupportsUnlockedPointers-			( adjustToCrippledFileSystem-			, do-				enableDirectMode-				setDirect True-			)-		-- Handle case where this repo was cloned from a-		-- direct mode repo-		, unlessM isBare-			switchHEADBack-		)-	checkAdjustedClone+	v <- checkAdjustedClone+	case v of+		NeedUpgradeForAdjustedClone -> void $ upgrade True+		InAdjustedClone -> return ()+		NotInAdjustedClone ->+			ifM (crippledFileSystem <&&> (not <$> isBareRepo))+				( ifM versionSupportsUnlockedPointers+					( adjustToCrippledFileSystem+					, do+						enableDirectMode+						setDirect True+					)+				-- Handle case where this repo was cloned from a+				-- direct mode repo+				, unlessM isBareRepo+					switchHEADBack+				) 	createInodeSentinalFile False  uninitialize :: Annex ()@@ -132,9 +134,6 @@ {- Checks if a repository is initialized. Does not check version for ugrade. -} isInitialized :: Annex Bool isInitialized = maybe Annex.Branch.hasSibling (const $ return True) =<< getVersion--isBare :: Annex Bool-isBare = fromRepo Git.repoIsLocalBare  {- A crippled filesystem is one that does not allow making symlinks,  - or removing write access from files. -}
Annex/Locations.hs view
@@ -411,7 +411,7 @@  -  - This is used when a new Key is initially being generated, eg by getKey.  - Unlike keyFile and fileKey, it does not need to be a reversable- - escaping. Also, it's ok to change this to add more problimatic+ - escaping. Also, it's ok to change this to add more problematic  - characters later. Unlike changing keyFile, which could result in the  - filenames used for existing keys changing and contents getting lost.  -
Annex/Queue.hs view
@@ -13,6 +13,7 @@ 	flush, 	flushWhenFull, 	size,+	get, 	mergeFrom, ) where
Annex/Transfer.hs view
@@ -46,10 +46,17 @@ noObserver _ _ _ = noop  upload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v-upload u key f d o a _witness = runTransfer (Transfer Upload u key) f d o a+upload u key f d o a _witness = guardHaveUUID u $ +	runTransfer (Transfer Upload u key) f d o a  download :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v-download u key f d o a _witness = runTransfer (Transfer Download u key) f d o a+download u key f d o a _witness = guardHaveUUID u $+	runTransfer (Transfer Download u key) f d o a++guardHaveUUID :: Observable v => UUID -> Annex v -> Annex v+guardHaveUUID u a+	| u == NoUUID = return observeFailure+	| otherwise = a  {- Runs a transfer action. Creates and locks the lock file while the  - action is running, and stores info in the transfer information
Assistant/DaemonStatus.hs view
@@ -55,6 +55,7 @@ 	let good r = Remote.uuid r `elem` alive 	let syncable = filter good rs 	let syncdata = filter (not . remoteAnnexIgnore . Remote.gitconfig) $+		filter (\r -> Remote.uuid r /= NoUUID) $ 		filter (not . Remote.isXMPPRemote) syncable  	return $ \dstatus -> dstatus
Assistant/Gpg.hs view
@@ -12,12 +12,14 @@ import Types.Remote (RemoteConfigKey)  import qualified Data.Map as M+import Control.Applicative+import Prelude  {- Generates a gpg user id that is not used by any existing secret key -} newUserId :: GpgCmd -> IO UserId newUserId cmd = do 	oldkeys <- secretKeys cmd-	username <- myUserName+	username <- either (const "unknown") id <$> myUserName 	let basekeyname = username ++ "'s git-annex encryption key" 	return $ Prelude.head $ filter (\n -> M.null $ M.filter (== n) oldkeys) 		( basekeyname
Assistant/Restart.hs view
@@ -91,7 +91,7 @@  {- Checks if the assistant is listening on an url.  -- - Always checks http, because https with self-signed cert is problimatic.+ - Always checks http, because https with self-signed cert is problematic.  - warp-tls listens to http, in order to show an error page, so this works.  -} assistantListening :: URLString -> IO Bool
Assistant/WebApp/Configurators/Pairing.hs view
@@ -226,7 +226,7 @@ 		let pubkey = either error id $ validateSshPubKey $ sshPubKey keypair 		pairdata <- liftIO $ PairData 			<$> getHostname-			<*> myUserName+			<*> (either error id <$> myUserName) 			<*> pure reldir 			<*> pure pubkey 			<*> (maybe genUUID return muuid)@@ -291,8 +291,8 @@ 		let (username, hostname) = maybe ("", "") 			(\(_, v, a) -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr a) (remoteHostName v))) 			(verifiableVal . fromPairMsg <$> msg)-		u <- T.pack <$> liftIO myUserName-		let sameusername = username == u+		u <- liftIO myUserName+		let sameusername = Right username == (T.pack <$> u) 		$(widgetFile "configurators/pairing/local/prompt")  {- This counts unicode characters as more than one character,
Assistant/WebApp/Configurators/Ssh.hs view
@@ -156,10 +156,10 @@ getAddSshR = postAddSshR postAddSshR :: Handler Html postAddSshR = sshConfigurator $ do-	username <- liftIO $ T.pack <$> myUserName+	username <- liftIO $ either (const Nothing) (Just . T.pack) <$> myUserName 	((result, form), enctype) <- liftH $ 		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ sshInputAForm textField $-			SshInput Nothing (Just username) Password Nothing Nothing 22+			SshInput Nothing username Password Nothing Nothing 22 	case result of 		FormSuccess sshinput -> do 			s <- liftAssistant $ testServer sshinput
Backend/Hash.hs view
@@ -101,8 +101,9 @@ 	| otherwise = intercalate "." ("":es)   where 	es = filter (not . null) $ reverse $-		take 2 $ takeWhile shortenough $-		reverse $ split "." $ filter validExtension $ takeExtensions f+		take 2 $ map (filter validInExtension) $+		takeWhile shortenough $+		reverse $ split "." $ takeExtensions f 	shortenough e = length e <= 4 -- long enough for "jpeg"  {- A key's checksum is checked during fsck. -}@@ -133,8 +134,8 @@ keyHash :: Key -> String keyHash key = dropExtensions (keyName key) -validExtension :: Char -> Bool-validExtension c+validInExtension :: Char -> Bool+validInExtension c 	| isAlphaNum c = True 	| c == '.' = True 	| otherwise = False@@ -143,7 +144,7 @@  - that contain non-alphanumeric characters in their extension. -} needsUpgrade :: Key -> Bool needsUpgrade key = "\\" `isPrefixOf` keyHash key ||-	any (not . validExtension) (takeExtensions $ keyName key)+	any (not . validInExtension) (takeExtensions $ keyName key)  trivialMigrate :: Key -> Backend -> AssociatedFile -> Maybe Key trivialMigrate oldkey newbackend afile
Build/BundledPrograms.hs view
@@ -70,7 +70,7 @@ 	, Just "sh" #endif #ifndef darwin_HOST_OS-	-- wget on OSX has been problimatic, looking for certs in the wrong+	-- wget on OSX has been problematic, looking for certs in the wrong 	-- places. Don't ship it, use curl or the OSX's own wget if it has 	-- one. 	, ifset SysConfig.wget "wget"
Build/EvilSplicer.hs view
@@ -620,7 +620,7 @@ 		void $ string "= " 		return $ "= do { " ++ x ++ " <- return $ " -{- Embedded files use unsafe packing, which is problimatic+{- Embedded files use unsafe packing, which is problematic  - for several reasons, including that GHC sometimes omits trailing  - newlines in the file content, which leads to the wrong byte  - count. Also, GHC sometimes outputs unicode characters, which
+ Build/MakeMans.hs view
@@ -0,0 +1,15 @@+{- Build man pages, for use by Makefile+ -+ - Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# OPTIONS_GHC -fno-warn-tabs #-}++module Main where++import Build.Mans++main :: IO ()+main = buildMansOrWarn
+ Build/Mans.hs view
@@ -0,0 +1,60 @@+{- Build man pages.+ -+ - Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# OPTIONS_GHC -fno-warn-tabs #-}++module Build.Mans where++import System.Directory+import System.FilePath+import Data.List+import Control.Monad+import System.Process+import System.Exit+import Data.Maybe+import Utility.Exception+import Control.Applicative+import Prelude++buildMansOrWarn :: IO ()+buildMansOrWarn = do+	mans <- buildMans+	when (any isNothing mans) $+		error "mdwn2man failed"++buildMans :: IO [Maybe FilePath]+buildMans = do+	mansrc <- filter isManSrc <$> getDirectoryContents "doc"+	createDirectoryIfMissing False "man"+	forM mansrc $ \f -> do+		let src = "doc" </> f+		let dest = srcToDest src+		srcm <- getModificationTime src+		destm <- catchMaybeIO $ getModificationTime dest+		if (Just srcm > destm)+			then do+				r <- system $ unwords+					[ "./Build/mdwn2man"+					, progName src+					, "1"+					, src+					, "> " ++ dest+					]+				if r == ExitSuccess+					then return (Just dest)+					else return Nothing+			else return (Just dest)++isManSrc :: FilePath -> Bool+isManSrc s = "git-annex" `isPrefixOf` (takeFileName s)+	&& takeExtension s == ".mdwn"++srcToDest :: FilePath -> FilePath+srcToDest s = "man" </> progName s ++ ".1"++progName :: FilePath -> FilePath+progName = dropExtension . takeFileName
Build/mdwn2man view
@@ -2,8 +2,6 @@ # Warning: hack  my $prog=shift;-$prog=~s/\.\d+$//;-$prog=~s/man\///; my $section=shift;  print ".TH $prog $section\n";
CHANGELOG view
@@ -1,3 +1,40 @@+git-annex (6.20160613) unstable; urgency=medium++  * Improve SHA*E extension extraction code.+  * Windows: Avoid terminating git-annex branch lines with \r\n when+    union merging and performing transitions.+  * Remove Makefile from cabal tarball; man page building is now handled by+    a small haskell program.+  * sync --content: Fix bug that caused transfers of files to be made +    to a git remote that does not have a UUID. This particularly impacted+    clones from gcrypt repositories.+  * Pass -S to git commit-tree when commit.gpgsign is set and when+    making a non-automatic commit, in order to preserve current behavior+    when used with git 2.9, which has stopped doing this itself.+  * remotedaemon: Fixed support for notifications of changes to gcrypt+    remotes, which was never tested and didn't quite work before.+  * list: Do not include dead repositories.+  * move --to: Better behavior when system is completely out of disk space;+    drop content from disk before writing location log.+  * Avoid a crash if getpwuid does not work, when querying the user's full+    name.+  * Automatically enable v6 mode when initializing in a clone from a repo+    that has an adjusted branch checked out.+  * v6: Fix initialization of a bare clone of a repo that has an adjusted+    branch checked out.+  * v6: Fix bad automatic merge conflict resolution between an annexed file+    and a directory with the same name when in an adjusted branch.+  * v6: Fix bad merge in an adjusted branch that resulted in an empty tree.+  * v6: Fix bug in initialization of clone from a repo with an adjusted branch+    that had not been synced back to master. +    (This bug caused broken tree objects to get built by a later git annex+    sync.)+  * v6: Make lock and unlock work on files whose content is not present.+  * v6: Fix update of associated files db when unlocking a file.+  * v6: Make git clean filter preserve the backend that was used for a file.++ -- Joey Hess <id@joeyh.name>  Mon, 13 Jun 2016 14:57:38 -0400+ git-annex (6.20160527) unstable; urgency=medium    * Split lines in the git-annex branch on \r as well as \n, to deal@@ -3524,7 +3561,7 @@     (Requested by the Internet Archive)   * uninit: Clear annex.uuid from .git/config. Closes: #670639   * Added shared cipher mode to encryptable special remotes. This option-    avoids gpg key distribution, at the expense of flexability, and with+    avoids gpg key distribution, at the expense of flexibility, and with     the requirement that all clones of the git repository be equally trusted.   -- Joey Hess <joeyh@debian.org>  Mon, 30 Apr 2012 13:16:10 -0400
Command.hs view
@@ -91,9 +91,6 @@ stopUnless :: Annex Bool -> Annex (Maybe a) -> Annex (Maybe a) stopUnless c a = ifM c ( a , stop ) -isBareRepo :: Annex Bool-isBareRepo = fromRepo Git.repoIsLocalBare- commonChecks :: [CommandCheck] commonChecks = [repoExists]
Command/List.hs view
@@ -56,7 +56,8 @@ 		ts <- mapM (lookupTrust . uuid) rs 		hereu <- getUUID 		heretrust <- lookupTrust hereu-		return $ (hereu, "here", heretrust) : zip3 (map uuid rs) (map name rs) ts+		let l = (hereu, "here", heretrust) : zip3 (map uuid rs) (map name rs) ts+		return $ filter (\(_, _, t) -> t /= DeadTrusted) l  	getAllUUIDs = do 		rs <- M.toList <$> uuidMap 		rs3 <- forM rs $ \(u, n) -> (,,)
Command/Lock.hs view
@@ -45,7 +45,7 @@ 	)   where 	go (Just key')-		| key' == key = error "content not present; cannot lock"+		| key' == key = cont True 		| otherwise = errorModified 	go Nothing =  		ifM (isUnmodified key file)
Command/Move.hs view
@@ -113,23 +113,29 @@ 				upload (Remote.uuid dest) key afile noRetry noObserver $ 					Remote.storeKey dest key afile 			if ok-				then do+				then finish $ 					Remote.logStatus dest key InfoPresent-					finish 				else do 					when fastcheck $ 						warning "This could have failed because --fast is enabled." 					stop-		Right True -> do+		Right True -> finish $ 			unlessM (expectedPresent dest key) $ 				Remote.logStatus dest key InfoPresent-			finish   where-	finish+	finish :: Annex () -> CommandPerform+	finish setpresentremote 		| move = lockContentForRemoval key $ \contentlock -> do+			-- Drop content before updating location logs,+			-- in case disk space is very low this frees up+			-- space before writing data to disk. 			removeAnnex contentlock-			next $ Command.Drop.cleanupLocal key-		| otherwise = next $ return True+			next $ do+				setpresentremote+				Command.Drop.cleanupLocal key+		| otherwise = next $ do+			setpresentremote+			return True  {- Moves (or copies) the content of an annexed file from a remote  - to the current repository.
Command/Smudge.hs view
@@ -13,9 +13,11 @@ import Annex.Link import Annex.FileMatcher import Annex.Ingest+import Annex.CatFile import Logs.Location import qualified Database.Keys import Git.FilePath+import Backend  import qualified Data.ByteString.Lazy as B @@ -78,8 +80,16 @@ 				-- and not stdin, we need to consume all 				-- stdin, or git will get annoyed. 				B.length b `seq` return ()+				-- Look up the backend that was used+				-- for this file before, so that when+				-- git re-cleans a file its backend does+				-- not change.+				currbackend <- maybe Nothing (maybeLookupBackendName . keyBackendName)+					<$> catKeyFile file 				liftIO . emitPointer-					=<< go =<< ingest =<< lockDown cfg file+					=<< go+					=<< ingest' currbackend+					=<< lockDown cfg file 			, liftIO $ B.hPut stdout b 			) 	stop
Command/Sync.hs view
@@ -106,7 +106,8 @@  	remotes <- syncRemotes (syncWith o) 	let gitremotes = filter Remote.gitSyncableRemote remotes-	let dataremotes = filter (not . remoteAnnexIgnore . Remote.gitconfig) remotes+	let dataremotes = filter (\r -> Remote.uuid r /= NoUUID) $ +		filter (not . remoteAnnexIgnore . Remote.gitconfig) remotes  	-- Syncing involves many actions, any of which can independently 	-- fail, without preventing the others from running.
Command/Unlock.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2010,2015 Joey Hess <id@joeyh.name>+ - Copyright 2010-2016 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -16,6 +16,8 @@ import Annex.ReplaceFile import Utility.CopyFile import Utility.FileMode+import Git.FilePath+import qualified Database.Keys  cmd :: Command cmd = mkcmd "unlock" "unlock files for modification"@@ -37,14 +39,9 @@ start file key = ifM (isJust <$> isAnnexLink file) 	( do 		showStart "unlock" file-		ifM (inAnnex key)-			( ifM versionSupportsUnlockedPointers-				( next $ performNew file key-				, startOld file key -				)-			, do-				warning "content not present; cannot unlock"-				next $ next $ return False+		ifM versionSupportsUnlockedPointers+			( next $ performNew file key+			, startOld file key 			) 	, stop 	)@@ -52,16 +49,22 @@ performNew :: FilePath -> Key -> CommandPerform performNew dest key = do 	destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus dest-	replaceFile dest $ \tmp -> do-		r <- linkFromAnnex key tmp destmode-		case r of-			LinkAnnexOk -> return ()-			_ -> error "unlock failed"+	replaceFile dest $ \tmp ->+		ifM (inAnnex key)+			( do+				r <- linkFromAnnex key tmp destmode+				case r of+					LinkAnnexOk -> return ()+					LinkAnnexNoop -> return ()+					_ -> error "unlock failed"+			, liftIO $ writePointerFile tmp key destmode+			) 	next $ cleanupNew dest key destmode  cleanupNew ::  FilePath -> Key -> Maybe FileMode -> CommandCleanup cleanupNew dest key destmode = do 	stagePointerFile dest destmode =<< hashPointerFile key+	Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath dest) 	return True  startOld :: FilePath -> Key -> CommandStart
Command/Unused.hs view
@@ -32,6 +32,7 @@ import Git.Types import Git.Sha import Git.FilePath+import Config import Logs.View (is_branchView) import Annex.BloomFilter import qualified Database.Keys
Config.hs view
@@ -86,6 +86,9 @@ setRemoteBare :: Git.Repo -> Bool -> Annex () setRemoteBare r b = setConfig (remoteConfig r "bare") (Git.Config.boolConfig b) +isBareRepo :: Annex Bool+isBareRepo = fromRepo Git.repoIsLocalBare+ isDirect :: Annex Bool isDirect = annexDirect <$> Annex.getGitConfig
Git/Branch.hs view
@@ -13,6 +13,7 @@ import Git import Git.Sha import Git.Command+import qualified Git.Config import qualified Git.Ref import qualified Git.BuildVersion @@ -114,19 +115,33 @@ 			(False, True) -> findbest c rs -- worse 			(False, False) -> findbest c rs -- same -{- The user may have set commit.gpgsign, indending all their manual+{- The user may have set commit.gpgsign, intending all their manual  - commits to be signed. But signing automatic/background commits could  - easily lead to unwanted gpg prompts or failures.  -} data CommitMode = ManualCommit | AutomaticCommit 	deriving (Eq) +{- Prevent signing automatic commits. -} applyCommitMode :: CommitMode -> [CommandParam] -> [CommandParam] applyCommitMode commitmode ps 	| commitmode == AutomaticCommit && not (Git.BuildVersion.older "2.0.0") = 		Param "--no-gpg-sign" : ps 	| otherwise = ps +{- Some versions of git commit-tree honor commit.gpgsign themselves,+ - but others need -S to be passed to enable gpg signing of manual commits. -}+applyCommitModeForCommitTree :: CommitMode -> [CommandParam] -> Repo -> [CommandParam]+applyCommitModeForCommitTree commitmode ps r+	| commitmode == ManualCommit =+		case (Git.Config.getMaybe "commit.gpgsign" r) of+			Just s | Git.Config.isTrue s == Just True ->+				Param "-S":ps+			_ -> ps'+	| otherwise = ps'+  where+	ps' = applyCommitMode commitmode ps+ {- Commit via the usual git command. -} commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool commitCommand = commitCommand' runBool@@ -172,9 +187,9 @@ 		pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps) 			sendmsg repo   where-	ps = applyCommitMode commitmode $-		map Param $ concatMap (\r -> ["-p", fromRef r]) parentrefs 	sendmsg = Just $ flip hPutStr message+	ps = applyCommitModeForCommitTree commitmode parentparams repo+	parentparams = map Param $ concatMap (\r -> ["-p", fromRef r]) parentrefs  {- A leading + makes git-push force pushing a branch. -} forcePush :: String -> String
Git/HashObject.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE CPP #-}+ module Git.HashObject where  import Common@@ -39,6 +41,10 @@  - interface does not allow batch hashing without using temp files. -} hashBlob :: HashObjectHandle -> String -> IO Sha hashBlob h s = withTmpFile "hash" $ \tmp tmph -> do+	fileEncoding tmph+#ifdef mingw32_HOST_OS+	hSetNewlineMode tmph noNewlineTranslation+#endif 	hPutStr tmph s 	hClose tmph 	hashFile h tmp
Git/Queue.hs view
@@ -163,7 +163,7 @@ 		hPutStr h $ intercalate "\0" $ toCommand $ getFiles action 		hClose h #else-	-- Using xargs on Windows is problimatic, so just run the command+	-- Using xargs on Windows is problematic, so just run the command 	-- once per file (not as efficient.) 	if null (getFiles action) 		then void $ boolSystemEnv "git" gitparams (gitEnv repo)
− Makefile 
@@ -1,292 +0,0 @@-mans=$(shell find doc -maxdepth 1 -name git-annex*.mdwn | sed -e 's/^doc/man/' -e 's/\.mdwn/\.1/')-all=git-annex mans docs--# set to "./Setup" if you lack a cabal program. Or can be set to "stack"-BUILDER?=cabal-GHC?=ghc--PREFIX?=/usr-SHAREDIR?=share--# Am I typing :make in vim? Do a fast build.-ifdef VIM-all=fast-endif--build: $(all)--Build/SysConfig.hs: Build/TestConfig.hs Build/Configure.hs-	if [ "$(BUILDER)" = ./Setup ]; then ghc --make Setup; fi-	if [ "$(BUILDER)" = stack ]; then \-		$(BUILDER) build $(BUILDEROPTIONS); \-	else \-		$(BUILDER) configure --ghc-options="$(shell Build/collect-ghc-options.sh)"; \-	fi--git-annex: Build/SysConfig.hs-	$(BUILDER) build $(BUILDEROPTIONS)-	if [ "$(BUILDER)" = stack ]; then \-		ln -sf $$(find .stack-work/ -name git-annex -type f | grep build/git-annex/git-annex | tail -n 1) git-annex; \-	else \-		ln -sf dist/build/git-annex/git-annex git-annex; \-	fi--man/%.1: doc/%.mdwn-	./Build/mdwn2man $@ 1 $< > $@--# These are not built normally.-git-union-merge.1: doc/git-union-merge.mdwn-	./Build/mdwn2man git-union-merge 1 doc/git-union-merge.mdwn > git-union-merge.1-git-union-merge:-	$(GHC) --make -threaded $@--install-mans: mans-	install -d $(DESTDIR)$(PREFIX)/$(SHAREDIR)/man/man1-	install -m 0644 $(mans) $(DESTDIR)$(PREFIX)/$(SHAREDIR)/man/man1--install-docs: docs install-mans-	install -d $(DESTDIR)$(PREFIX)/$(SHAREDIR)/doc/git-annex-	if [ -d html ]; then \-		rsync -a --delete html/ $(DESTDIR)$(PREFIX)/$(SHAREDIR)/doc/git-annex/html/; \-	fi--install-bins: build-	install -d $(DESTDIR)$(PREFIX)/bin-	install git-annex $(DESTDIR)$(PREFIX)/bin-	ln -sf git-annex $(DESTDIR)$(PREFIX)/bin/git-annex-shell--install-misc: Build/InstallDesktopFile-	./Build/InstallDesktopFile $(PREFIX)/bin/git-annex || true-	install -d $(DESTDIR)$(PREFIX)/share/bash-completion/completions-	install -m 0644 bash-completion.bash $(DESTDIR)$(PREFIX)/share/bash-completion/completions/git-annex--install: install-bins install-docs install-misc--test: git-annex-	./git-annex test--retest: git-annex-	./git-annex test --rerun-update --rerun-filter failures--# hothasktags chokes on some template haskell etc, so ignore errors-tags:-	(for f in $$(find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$'); do hothasktags -c --cpp -c -traditional -c --include=dist/build/autogen/cabal_macros.h $$f; done) 2>/dev/null | sort > tags--# If ikiwiki is available, build static html docs suitable for being-# shipped in the software package.-ifeq ($(shell which ikiwiki),)-IKIWIKI=echo "** ikiwiki not found, skipping building docs" >&2; true-else-IKIWIKI=ikiwiki-endif--mans: man $(mans)--man:-	mkdir -p man--docs: mans-	@if [ ! -e doc/index.mdwn ]; then \-		echo "** doc/index.mdwn does not exist, skipping building docs (clone git-annex source to enable full docs build)" >&2; \-	else \-		LC_ALL=C TZ=UTC $(IKIWIKI) doc html -v --wikiname git-annex \-			--plugin=goodstuff \-			--no-usedirs --disable-plugin=openid --plugin=sidebar \-			--underlaydir=/dev/null --set deterministic=1 \-			--disable-plugin=shortcut --disable-plugin=smiley \-			--plugin=comments --set comments_pagespec="*" \-			--exclude='news/.*' --exclude='design/assistant/blog/*' \-			--exclude='bugs/*' --exclude='todo/*' --exclude='forum/*' \-			--exclude='users/*' --exclude='devblog/*' --exclude='thanks'; \-	fi--clean:-	if [ "$(BUILDER)" != ./Setup ] && [ "$(BUILDER)" != cabal ]; then $(BUILDER) clean; fi-	rm -rf tmp dist git-annex $(mans) configure  *.tix .hpc \-		doc/.ikiwiki html dist tags Build/SysConfig.hs \-		Setup Build/InstallDesktopFile Build/EvilSplicer \-		Build/Standalone Build/OSXMkLibs Build/LinuxMkLibs \-		Build/DistributionUpdate Build/BuildVersion \-		git-union-merge .tasty-rerun-log-	find . -name \*.o -exec rm {} \;-	find . -name \*.hi -exec rm {} \;--Build/InstallDesktopFile: Build/InstallDesktopFile.hs-	$(GHC) --make $@ -Wall -fno-warn-tabs-Build/EvilSplicer: Build/EvilSplicer.hs-	$(GHC) --make $@ -Wall -fno-warn-tabs-Build/Standalone: Build/Standalone.hs Build/SysConfig.hs-	$(GHC) --make $@ -Wall -fno-warn-tabs-Build/OSXMkLibs: Build/OSXMkLibs.hs-	$(GHC) --make $@ -Wall -fno-warn-tabs-Build/LinuxMkLibs: Build/LinuxMkLibs.hs-	$(GHC) --make $@ -Wall -fno-warn-tabs--# Upload to hackage.-hackage:-	@cabal sdist-	@cabal upload dist/*.tar.gz--LINUXSTANDALONE_DEST=tmp/git-annex.linux-linuxstandalone:-	$(MAKE) git-annex linuxstandalone-nobuild-linuxstandalone-nobuild: Build/Standalone Build/LinuxMkLibs-	rm -rf "$(LINUXSTANDALONE_DEST)"-	mkdir -p tmp-	cp -R standalone/linux/skel "$(LINUXSTANDALONE_DEST)"-	sed -i -e 's/^GIT_ANNEX_PACKAGE_INSTALL=/GIT_ANNEX_PACKAGE_INSTALL=$(GIT_ANNEX_PACKAGE_INSTALL)/' "$(LINUXSTANDALONE_DEST)/runshell"-	-	install -d "$(LINUXSTANDALONE_DEST)/bin"-	cp git-annex "$(LINUXSTANDALONE_DEST)/bin/"-	strip "$(LINUXSTANDALONE_DEST)/bin/git-annex"-	ln -sf git-annex "$(LINUXSTANDALONE_DEST)/bin/git-annex-shell"-	zcat standalone/licences.gz > $(LINUXSTANDALONE_DEST)/LICENSE-	cp doc/logo_16x16.png doc/logo.svg $(LINUXSTANDALONE_DEST)-	cp standalone/trustedkeys.gpg $(LINUXSTANDALONE_DEST)--	./Build/Standalone "$(LINUXSTANDALONE_DEST)"-	-	install -d "$(LINUXSTANDALONE_DEST)/git-core"-	(cd "$(shell git --exec-path)" && tar c .) | (cd "$(LINUXSTANDALONE_DEST)"/git-core && tar x)-	install -d "$(LINUXSTANDALONE_DEST)/templates"-	install -d "$(LINUXSTANDALONE_DEST)/magic"-	cp /usr/share/file/magic.mgc "$(LINUXSTANDALONE_DEST)/magic"-	-	./Build/LinuxMkLibs "$(LINUXSTANDALONE_DEST)"-	-	$(MAKE) install-mans DESTDIR="$(LINUXSTANDALONE_DEST)"--	cd tmp/git-annex.linux && find . -type f > git-annex.MANIFEST-	cd tmp/git-annex.linux && find . -type l >> git-annex.MANIFEST-	cd tmp && tar c git-annex.linux | gzip -9 --rsyncable > git-annex-standalone-$(shell dpkg --print-architecture).tar.gz--# Run this target to build git-annex-standalone*.deb-debianstandalone: dpkg-buildpackage-F-# Run this target to build git-annex-standalone*.dsc-debianstandalone-dsc: dpkg-buildpackage-S--prep-standalone:-	$(MAKE) undo-standalone-	QUILT_PATCHES=debian/patches QUILT_SERIES=series.standalone-build quilt push -a-	debian/create-standalone-changelog--undo-standalone:-	test -e .git-	git checkout debian/changelog CHANGELOG-	quilt pop -a || true--commit-standalone:-	QUILT_PATCHES=debian/patches QUILT_SERIES=series.standalone-build  quilt refresh--dpkg-buildpackage%: prep-standalone-	umask 022; dpkg-buildpackage -rfakeroot $*-	$(MAKE) undo-standalone--OSXAPP_DEST=tmp/build-dmg/git-annex.app-OSXAPP_BASE=$(OSXAPP_DEST)/Contents/MacOS/bundle-osxapp: Build/Standalone Build/OSXMkLibs-	$(MAKE) git-annex--	rm -rf "$(OSXAPP_DEST)" "$(OSXAPP_BASE)"-	install -d tmp/build-dmg-	cp -R standalone/osx/git-annex.app "$(OSXAPP_DEST)"--	install -d "$(OSXAPP_BASE)"-	cp git-annex "$(OSXAPP_BASE)"-	strip "$(OSXAPP_BASE)/git-annex"-	ln -sf git-annex "$(OSXAPP_BASE)/git-annex-shell"-	gzcat standalone/licences.gz > $(OSXAPP_BASE)/LICENSE-	cp $(OSXAPP_BASE)/LICENSE tmp/build-dmg/LICENSE.txt-	cp standalone/trustedkeys.gpg $(OSXAPP_DEST)/Contents/MacOS--	./Build/Standalone $(OSXAPP_BASE)--	(cd "$(shell git --exec-path)" && tar c .) | (cd "$(OSXAPP_BASE)" && tar x)-	install -d "$(OSXAPP_BASE)/templates"-	install -d "$(OSXAPP_BASE)/magic"-	if [ -e "$(OSX_MAGIC_FILE)" ]; then \-		cp "$(OSX_MAGIC_FILE)" "$(OSXAPP_BASE)/magic/magic.mgc"; \-	else \-		echo "** OSX_MAGIC_FILE not set; not including it" >&2; \-	fi--	# OSX looks in man dir nearby the bin-	$(MAKE) install-mans DESTDIR="$(OSXAPP_BASE)/.." SHAREDIR="" PREFIX=""--	./Build/OSXMkLibs $(OSXAPP_BASE)-	cd $(OSXAPP_DEST) && find . -type f > Contents/MacOS/git-annex.MANIFEST-	cd $(OSXAPP_DEST) && find . -type l >> Contents/MacOS/git-annex.MANIFEST-	rm -f tmp/git-annex.dmg-	hdiutil create -format UDBZ -size 640m -srcfolder tmp/build-dmg \-		-volname git-annex -o tmp/git-annex.dmg--ANDROID_FLAGS?=-# Cross compile for Android.-# Uses https://github.com/neurocyte/ghc-android-android: Build/EvilSplicer-	echo "Running native build, to get TH splices.."-	if [ ! -e dist/setup/setup ]; then $(BUILDER) configure -O0 $(ANDROID_FLAGS) -fAndroidSplice;  fi-	mkdir -p tmp-	if ! $(BUILDER) build --ghc-options=-ddump-splices 2> tmp/dump-splices; then tail tmp/dump-splices >&2; exit 1; fi-	echo "Setting up Android build tree.."-	./Build/EvilSplicer tmp/splices tmp/dump-splices standalone/no-th/evilsplicer-headers.hs-	rsync -az --exclude tmp --exclude dist . tmp/androidtree-# Copy the files with expanded splices to the source tree, but-# only if the existing source file is not newer. (So, if a file-# used to have TH splices but they were removed, it will be newer,-# and not overwritten.)-	cp -uR tmp/splices/* tmp/androidtree || true-# Some additional dependencies needed by the expanded splices.-	sed -i 's/^  Build-Depends: */  Build-Depends: yesod-core, yesod-routes, shakespeare, blaze-markup, file-embed, wai-app-static, wai, unordered-containers, /' tmp/androidtree/git-annex.cabal-# Avoid warnings due to sometimes unused imports added for the splices.-	sed -i 's/GHC-Options: \(.*\)-Wall/GHC-Options: \1-Wall -fno-warn-unused-imports /i' tmp/androidtree/git-annex.cabal-	sed -i 's/Extensions: /Extensions: MagicHash /i' tmp/androidtree/git-annex.cabal-# Cabal cannot cross compile with custom build type, so workaround.-	sed -i 's/Build-type: Custom/Build-type: Simple/' tmp/androidtree/git-annex.cabal-# Build just once, but link repeatedly, for different versions of Android.-	mkdir -p tmp/androidtree/dist/build/git-annex/4.0 tmp/androidtree/dist/build/git-annex/4.3 tmp/androidtree/dist/build/git-annex/5.0-	if [ ! -e tmp/androidtree/dist/setup-config ]; then \-		cd tmp/androidtree && $$HOME/.ghc/$(shell cat standalone/android/abiversion)/arm-linux-androideabi/bin/cabal configure -fAndroid $(ANDROID_FLAGS); \-	fi-	cd tmp/androidtree && $$HOME/.ghc/$(shell cat standalone/android/abiversion)/arm-linux-androideabi/bin/cabal build \-		&& mv dist/build/git-annex/git-annex dist/build/git-annex/4.0/git-annex-	cd tmp/androidtree && $$HOME/.ghc/$(shell cat standalone/android/abiversion)/arm-linux-androideabi/bin/cabal build \-		--ghc-options=-optl-z --ghc-options=-optlnocopyreloc \-		&& mv dist/build/git-annex/git-annex dist/build/git-annex/4.3/git-annex-	cd tmp/androidtree && $$HOME/.ghc/$(shell cat standalone/android/abiversion)/arm-linux-androideabi/bin/cabal build \-		--ghc-options=-optl-z --ghc-options=-optlnocopyreloc --ghc-options=-optl-fPIE --ghc-options=-optl-pie --ghc-options=-optc-fPIE --ghc-options=-optc-pie \-		&& mv dist/build/git-annex/git-annex dist/build/git-annex/5.0/git-annex--androidapp:-	$(MAKE) android-	$(MAKE) -C standalone/android--# Bypass cabal, and only run the main ghc --make command for a-# faster development build.-fast: dist/cabalbuild-	@sh dist/cabalbuild-	@ln -sf dist/build/git-annex/git-annex git-annex-	@$(MAKE) tags >/dev/null 2>&1 &--dist/cabalbuild: dist/caballog-	grep 'ghc --make' dist/caballog | tail -n 1 > dist/cabalbuild-	-dist/caballog: git-annex.cabal-	$(BUILDER) configure -f"-Production" -O0 --enable-executable-dynamic-	$(BUILDER) build -v2 --ghc-options="-O0 -j" | tee dist/caballog--# Hardcoded command line to make hdevtools start up and work.-# You will need some memory. It's worth it.-# Note: Don't include WebDAV or Webapp. TH use bloats memory > 500 mb!-# TODO should be possible to derive this from caballog.-hdevtools:-	hdevtools --stop-server || true-	hdevtools check git-annex.hs -g -cpp -g -i -g -idist/build/git-annex/git-annex-tmp -g -i. -g -idist/build/autogen -g -Idist/build/autogen -g -Idist/build/git-annex/git-annex-tmp -g -IUtility -g -DWITH_TESTSUITE -g -DWITH_S3 -g -DWITH_ASSISTANT -g -DWITH_INOTIFY -g -DWITH_DBUS -g -DWITH_PAIRING -g -DWITH_XMPP -g -optP-include -g -optPdist/build/autogen/cabal_macros.h -g -odir -g dist/build/git-annex/git-annex-tmp -g -hidir -g dist/build/git-annex/git-annex-tmp -g -stubdir -g dist/build/git-annex/git-annex-tmp -g -threaded -g -Wall -g -XHaskell98 -g -XPackageImports--distributionupdate:-	git pull-	cabal configure-	ghc -Wall -fno-warn-tabs --make Build/DistributionUpdate -XPackageImports -optP-include -optPdist/build/autogen/cabal_macros.h-	./Build/DistributionUpdate--.PHONY: git-annex git-union-merge tags
RemoteDaemon/Common.hs view
@@ -30,7 +30,7 @@ 	return r  inLocalRepo :: TransportHandle -> (Git.Repo -> IO a) -> IO a-inLocalRepo (TransportHandle g _) a = a g+inLocalRepo (TransportHandle (LocalRepo g) _) a = a g  -- Check if any of the shas are actally new in the local git repo, -- to avoid unnecessary fetching.
RemoteDaemon/Core.hs view
@@ -111,7 +111,7 @@ -- Generates a map with a transport for each supported remote in the git repo, -- except those that have annex.sync = false genRemoteMap :: TransportHandle -> TChan Emitted -> IO RemoteMap-genRemoteMap h@(TransportHandle g _) ochan = +genRemoteMap h@(TransportHandle (LocalRepo g) _) ochan =  	M.fromList . catMaybes <$> mapM gen (Git.remotes g)   where 	gen r = case Git.location r of@@ -126,17 +126,17 @@ 			_ -> return Nothing 		_ -> return Nothing 	  where-		gc = extractRemoteGitConfig r (Git.repoDescribe r)+		gc = extractRemoteGitConfig g (Git.repoDescribe r)  genTransportHandle :: IO TransportHandle genTransportHandle = do 	annexstate <- newMVar =<< Annex.new =<< Git.CurrentRepo.get 	g <- Annex.repo <$> readMVar annexstate-	return $ TransportHandle g annexstate+	return $ TransportHandle (LocalRepo g) annexstate  updateTransportHandle :: TransportHandle -> IO TransportHandle updateTransportHandle h@(TransportHandle _g annexstate) = do 	g' <- liftAnnex h $ do 		reloadConfig 		Annex.fromRepo id-	return (TransportHandle g' annexstate)+	return (TransportHandle (LocalRepo g') annexstate)
RemoteDaemon/Transport/GCrypt.hs view
@@ -16,7 +16,7 @@ import Remote.GCrypt (accessShellConfig)  transport :: Transport-transport rr@(RemoteRepo r gc) url h@(TransportHandle g _) ichan ochan+transport rr@(RemoteRepo r gc) url h@(TransportHandle (LocalRepo g) _) ichan ochan 	| accessShellConfig gc = do 		r' <- encryptedRemote g r 		v <- liftAnnex h $ git_annex_shell r' "notifychanges" [] []
RemoteDaemon/Transport/Ssh.hs view
@@ -29,10 +29,10 @@ 		Just (cmd, params) -> transportUsingCmd cmd params rr url h ichan ochan  transportUsingCmd :: FilePath -> [CommandParam] -> Transport-transportUsingCmd cmd params rr@(RemoteRepo r gc) url h@(TransportHandle g s) ichan ochan = do+transportUsingCmd cmd params rr@(RemoteRepo r gc) url h@(TransportHandle (LocalRepo g) s) ichan ochan = do 	-- enable ssh connection caching wherever inLocalRepo is called 	g' <- liftAnnex h $ sshOptionsTo r gc g-	let transporthandle = TransportHandle g' s+	let transporthandle = TransportHandle (LocalRepo g') s 	transportUsingCmd' cmd params rr url transporthandle ichan ochan  transportUsingCmd' :: FilePath -> [CommandParam] -> Transport
RemoteDaemon/Types.hs view
@@ -29,7 +29,7 @@ type Transport = RemoteRepo -> RemoteURI -> TransportHandle -> TChan Consumed -> TChan Emitted -> IO ()  data RemoteRepo = RemoteRepo Git.Repo RemoteGitConfig-type LocalRepo = Git.Repo+newtype LocalRepo = LocalRepo Git.Repo  -- All Transports share a single AnnexState MVar --
Setup.hs view
@@ -14,11 +14,13 @@ import Control.Monad import System.Directory import Data.List+import Data.Maybe import Control.Exception import qualified System.Info  import qualified Build.DesktopFile as DesktopFile import qualified Build.Configure as Configure+import Build.Mans (buildMans) import Utility.SafeCommand  main :: IO ()@@ -51,13 +53,10 @@ 	installOrdinaryFiles verbosity dstManDir =<< srcManpages   where 	dstManDir   = mandir (absoluteInstallDirs pkg lbi copyDest) </> "man1"-	srcManpages = do-		havemans <- boolSystem "make" [Param "mans"]-		if havemans-			then zip (repeat "man")-				. filter (".1" `isSuffixOf`)-				<$> getDirectoryContents "man"-			else return []+	-- If mdwn2man fails, perhaps because perl is not available,+	-- we just skip installing man pages.+	srcManpages = zip (repeat "man") . map takeFileName . catMaybes+		<$> buildMans  installDesktopFile :: CopyDest -> Verbosity -> PackageDescription -> LocalBuildInfo -> IO () installDesktopFile copyDest _verbosity pkg lbi
Test.hs view
@@ -232,6 +232,7 @@ 	, testCase "version" test_version 	, testCase "sync" test_sync 	, testCase "union merge regression" test_union_merge_regression+	, testCase "adjusted branch merge regression" test_adjusted_branch_merge_regression 	, testCase "conflict resolution" test_conflict_resolution 	, testCase "conflict resolution (adjusted branch)" test_conflict_resolution_adjusted_branch 	, testCase "conflict resolution movein regression" test_conflict_resolution_movein_regression@@ -564,10 +565,11 @@ test_lock :: Assertion test_lock = intmpclonerepoInDirect $ do 	annexed_notpresent annexedfile-	ifM (unlockedFiles <$> getTestMode)-		( not <$> git_annex "lock" [annexedfile] @? "lock failed to fail with not present file"-		, not <$> git_annex "unlock" [annexedfile] @? "unlock failed to fail with not present file"-		)+	unlessM (annexeval Annex.Version.versionSupportsUnlockedPointers) $+		ifM (unlockedFiles <$> getTestMode)+			( not <$> git_annex "lock" [annexedfile] @? "lock failed to fail with not present file"+			, not <$> git_annex "unlock" [annexedfile] @? "unlock failed to fail with not present file"+			) 	annexed_notpresent annexedfile  	-- regression test: unlock of newly added, not committed file@@ -969,9 +971,9 @@ 					git_annex "get" [annexedfile] @? "get failed" 					boolSystem "git" [Param "remote", Param "rm", Param "origin"] @? "remote rm" 				forM_ [r3, r2, r1] $ \r -> indir r $-					git_annex "sync" [] @? "sync failed"+					git_annex "sync" [] @? ("sync failed in " ++ r) 				forM_ [r3, r2] $ \r -> indir r $-					git_annex "drop" ["--force", annexedfile] @? "drop failed"+					git_annex "drop" ["--force", annexedfile] @? ("drop failed in " ++ r) 				indir r1 $ do 					git_annex "sync" [] @? "sync failed in r1" 					git_annex_expectoutput "find" ["--in", "r3"] []@@ -1394,6 +1396,33 @@ 		git_annex_expectoutput "find" [conflictor] [conflictor] 		-- regular file because it's unlocked 		checkregularfile conflictor++{- Regression test for a bad merge between two adjusted branch repos,+ - where the same file is added to both independently. The bad merge+ - emptied the whole tree. -}+test_adjusted_branch_merge_regression :: Assertion+test_adjusted_branch_merge_regression = whenM Annex.AdjustedBranch.isGitVersionSupported $+	withtmpclonerepo $ \r1 ->+		withtmpclonerepo $ \r2 -> do+			pair r1 r2+			setup r1+			setup r2+			checkmerge "r1" r1+			checkmerge "r2" r2+  where+	conflictor = "conflictor"+	setup r = indir r $ do+		disconnectOrigin+		git_annex "upgrade" [] @? "upgrade failed"+		git_annex "adjust" ["--unlock", "--force"] @? "adjust failed"+		writeFile conflictor "conflictor"+		git_annex "add" [conflictor] @? "add conflicter failed"+		git_annex "sync" [] @? "sync failed"+	checkmerge what d = indir d $ do+		git_annex "sync" [] @? ("sync failed in " ++ what)+		l <- getDirectoryContents "."+		conflictor `elem` l+			@? ("conflictor not present after merge in " ++ what)  {- Set up repos as remotes of each other. -} pair :: FilePath -> FilePath -> Assertion
Types/MetaData.hs view
@@ -95,7 +95,7 @@ 	serialize (MetaField f) = CI.original f 	deserialize = Just . mkMetaFieldUnchecked -{- Base64 problimatic values. -}+{- Base64 problematic values. -} instance MetaSerializable MetaValue where 	serialize (MetaValue isset v) = 		serialize isset ++
Utility/QuickCheck.hs view
@@ -16,8 +16,10 @@ import Test.QuickCheck as X import Data.Time.Clock.POSIX import System.Posix.Types+#if ! MIN_VERSION_QuickCheck(2,8,2) import qualified Data.Map as M import qualified Data.Set as S+#endif import Control.Applicative import Prelude
Utility/UserInfo.hs view
@@ -15,6 +15,7 @@ ) where  import Utility.Env+import Utility.Data  import System.PosixCompat import Control.Applicative@@ -24,7 +25,7 @@  -  - getpwent will fail on LDAP or NIS, so use HOME if set. -} myHomeDir :: IO FilePath-myHomeDir = myVal env homeDirectory+myHomeDir = either error return =<< myVal env homeDirectory   where #ifndef mingw32_HOST_OS 	env = ["HOME"]@@ -33,7 +34,7 @@ #endif  {- Current user's user name. -}-myUserName :: IO String+myUserName :: IO (Either String String) myUserName = myVal env userName   where #ifndef mingw32_HOST_OS@@ -47,15 +48,15 @@ #if defined(__ANDROID__) || defined(mingw32_HOST_OS) myUserGecos = return Nothing #else-myUserGecos = Just <$> myVal [] userGecos+myUserGecos = eitherToMaybe <$> myVal [] userGecos #endif -myVal :: [String] -> (UserEntry -> String) -> IO String+myVal :: [String] -> (UserEntry -> String) -> IO (Either String String) myVal envvars extract = go envvars   where #ifndef mingw32_HOST_OS-	go [] = extract <$> (getUserEntryForID =<< getEffectiveUserID)+	go [] = Right . extract <$> (getUserEntryForID =<< getEffectiveUserID) #else-	go [] = extract <$> error ("environment not set: " ++ show envvars)+	go [] = return $ Left ("environment not set: " ++ show envvars) #endif-	go (v:vs) = maybe (go vs) return =<< getEnv v+	go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 6.20160527+Version: 6.20160613 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -139,7 +139,6 @@   doc/git-annex-xmppgit.mdwn   doc/logo.svg   doc/logo_16x16.png-  Makefile   Build/mdwn2man   Assistant/WebApp/routes   static/activityicon.gif@@ -663,6 +662,8 @@     Build.EvilSplicer     Build.InstallDesktopFile     Build.LinuxMkLibs+    Build.MakeMans+    Build.Mans     Build.NullSoftInstaller     Build.OSXMkLibs     Build.Standalone