packages feed

git-annex 3.20121211 → 3.20130102

raw patch · 250 files changed

+4465/−2623 lines, 250 filesdep +hfsevents

Dependencies added: hfsevents

Files

Annex.hs view
@@ -1,6 +1,6 @@ {- git-annex monad  -- - Copyright 2010-2011 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -28,6 +28,9 @@ 	gitRepo, 	inRepo, 	fromRepo,+	getGitConfig,+	changeGitConfig,+	changeGitRepo, ) where  import "mtl" Control.Monad.State.Strict@@ -43,6 +46,7 @@ import Git.SharedRepository import qualified Git.Queue import Types.Backend+import Types.GitConfig import qualified Types.Remote import Types.Crypto import Types.BranchState@@ -88,6 +92,7 @@ -- internal state storage data AnnexState = AnnexState 	{ repo :: Git.Repo+	, gitconfig :: GitConfig 	, backends :: [BackendA Annex] 	, remotes :: [Types.Remote.RemoteA Annex] 	, output :: MessageState@@ -99,11 +104,11 @@ 	, catfilehandle :: Maybe CatFileHandle 	, checkattrhandle :: Maybe CheckAttrHandle 	, forcebackend :: Maybe String-	, forcenumcopies :: Maybe Int 	, limit :: Matcher (FileInfo -> Annex Bool) 	, uuidmap :: Maybe UUIDMap 	, preferredcontentmap :: Maybe PreferredContentMap 	, shared :: Maybe SharedRepository+	, direct :: Maybe Bool 	, forcetrust :: TrustMap 	, trustmap :: Maybe TrustMap 	, groupmap :: Maybe GroupMap@@ -117,6 +122,7 @@ newState :: Git.Repo -> AnnexState newState gitrepo = AnnexState 	{ repo = gitrepo+	, gitconfig = extractGitConfig gitrepo 	, backends = [] 	, remotes = [] 	, output = defaultMessageState@@ -128,11 +134,11 @@ 	, catfilehandle = Nothing 	, checkattrhandle = Nothing 	, forcebackend = Nothing-	, forcenumcopies = Nothing 	, limit = Left [] 	, uuidmap = Nothing 	, preferredcontentmap = Nothing 	, shared = Nothing+	, direct = Nothing 	, forcetrust = M.empty 	, trustmap = Nothing 	, groupmap = Nothing@@ -195,3 +201,18 @@ {- Extracts a value from the annex's git repisitory. -} fromRepo :: (Git.Repo -> a) -> Annex a fromRepo a = a <$> gitRepo++{- Gets the GitConfig settings. -}+getGitConfig :: Annex GitConfig+getGitConfig = getState gitconfig++{- Modifies a GitConfig setting. -}+changeGitConfig :: (GitConfig -> GitConfig) -> Annex ()+changeGitConfig a = changeState $ \s -> s { gitconfig = a (gitconfig s) }++{- Changing the git Repo data also involves re-extracting its GitConfig. -}+changeGitRepo :: Git.Repo -> Annex ()+changeGitRepo r = changeState $ \s -> s+	{ repo = r+	, gitconfig = extractGitConfig r+	}
Annex/Branch.hs view
@@ -72,18 +72,18 @@ {- Returns the ref of the branch, creating it first if necessary. -} getBranch :: Annex Git.Ref getBranch = maybe (hasOrigin >>= go >>= use) return =<< branchsha-	where-		go True = do-			inRepo $ Git.Command.run "branch"-				[Param $ show name, Param $ show originname]-			fromMaybe (error $ "failed to create " ++ show name)-				<$> branchsha-		go False = withIndex' True $-			inRepo $ Git.Branch.commit "branch created" fullname []-		use sha = do-			setIndexSha sha-			return sha-		branchsha = inRepo $ Git.Ref.sha fullname+  where+	go True = do+		inRepo $ Git.Command.run "branch"+			[Param $ show name, Param $ show originname]+		fromMaybe (error $ "failed to create " ++ show name)+			<$> branchsha+	go False = withIndex' True $+		inRepo $ Git.Branch.commit "branch created" fullname []+	use sha = do+		setIndexSha sha+		return sha+	branchsha = inRepo $ Git.Ref.sha fullname  {- Ensures that the branch and index are up-to-date; should be  - called before data is read from it. Runs only once per git-annex run. -}@@ -116,7 +116,7 @@ 	dirty <- journalDirty 	(refs, branches) <- unzip <$> filterM isnewer pairs 	if null refs- 		{- Even when no refs need to be merged, the index+		{- Even when no refs need to be merged, the index 		 - may still be updated if the branch has gotten ahead  		 - of the index. -} 		then whenM (needUpdateIndex branchref) $ lockJournal $ do@@ -128,26 +128,26 @@ 				go branchref True [] [] 		else lockJournal $ go branchref dirty refs branches 	return $ not $ null refs-	where-		isnewer (r, _) = inRepo $ Git.Branch.changed fullname r-		go branchref dirty refs branches = withIndex $ do-			cleanjournal <- if dirty then stageJournal else return noop-			let merge_desc = if null branches-				then "update"-				else "merging " ++-					unwords (map Git.Ref.describe branches) ++ -					" into " ++ show name-			unless (null branches) $ do-				showSideAction merge_desc-				mergeIndex refs-			ff <- if dirty-				then return False-				else inRepo $ Git.Branch.fastForward fullname refs-			if ff-				then updateIndex branchref-				else commitBranch branchref merge_desc-					(nub $ fullname:refs)-			liftIO cleanjournal+  where+	isnewer (r, _) = inRepo $ Git.Branch.changed fullname r+	go branchref dirty refs branches = withIndex $ do+		cleanjournal <- if dirty then stageJournal else return noop+		let merge_desc = if null branches+			then "update"+			else "merging " +++				unwords (map Git.Ref.describe branches) ++ +				" into " ++ show name+		unless (null branches) $ do+			showSideAction merge_desc+			mergeIndex refs+		ff <- if dirty+			then return False+			else inRepo $ Git.Branch.fastForward fullname refs+		if ff+			then updateIndex branchref+			else commitBranch branchref merge_desc+				(nub $ fullname:refs)+		liftIO cleanjournal  {- Gets the content of a file, which may be in the journal, or committed  - to the branch. Due to limitatons of git cat-file, does *not* get content@@ -168,15 +168,14 @@  get' :: Bool -> FilePath -> Annex String get' staleok file = fromjournal =<< getJournalFile file-	where-		fromjournal (Just content) = return content-		fromjournal Nothing-			| staleok = withIndex frombranch-			| otherwise = do-				update-				frombranch-		frombranch = withIndex $-			L.unpack <$> catFile fullname file+  where+	fromjournal (Just content) = return content+	fromjournal Nothing+		| staleok = withIndex frombranch+		| otherwise = do+			update+			frombranch+	frombranch = withIndex $ L.unpack <$> catFile fullname file  {- Applies a function to modifiy the content of a file.  -@@ -228,27 +227,27 @@ 	parentrefs <- commitparents <$> catObject committedref 	when (racedetected branchref parentrefs) $ 		fixrace committedref parentrefs-	where-		-- look for "parent ref" lines and return the refs-		commitparents = map (Git.Ref . snd) . filter isparent .-			map (toassoc . L.unpack) . L.lines-		toassoc = separate (== ' ')-		isparent (k,_) = k == "parent"+  where+	-- look for "parent ref" lines and return the refs+	commitparents = map (Git.Ref . snd) . filter isparent .+		map (toassoc . L.unpack) . L.lines+	toassoc = separate (== ' ')+	isparent (k,_) = k == "parent" 		- 		{- The race can be detected by checking the commit's-		 - parent, which will be the newly pushed branch,-		 - instead of the expected ref that the index was updated to. -}-		racedetected expectedref parentrefs-			| expectedref `elem` parentrefs = False -- good parent-			| otherwise = True -- race!+	{- The race can be detected by checking the commit's+	 - parent, which will be the newly pushed branch,+	 - instead of the expected ref that the index was updated to. -}+	racedetected expectedref parentrefs+		| expectedref `elem` parentrefs = False -- good parent+		| otherwise = True -- race! 		-		{- To recover from the race, union merge the lost refs-		 - into the index, and recommit on top of the bad commit. -}-		fixrace committedref lostrefs = do-			mergeIndex lostrefs-			commitBranch committedref racemessage [committedref]+	{- To recover from the race, union merge the lost refs+	 - into the index, and recommit on top of the bad commit. -}+	fixrace committedref lostrefs = do+		mergeIndex lostrefs+		commitBranch committedref racemessage [committedref] 		-		racemessage = message ++ " (recovery from race)"+	racemessage = message ++ " (recovery from race)"  {- Lists all files on the branch. There may be duplicates in the list. -} files :: Annex [FilePath]@@ -326,7 +325,7 @@  - given ref of the branch. -} setIndexSha :: Git.Ref -> Annex () setIndexSha ref = do-        lock <- fromRepo gitAnnexIndexLock+	lock <- fromRepo gitAnnexIndexLock 	liftIO $ writeFile lock $ show ref ++ "\n" 	setAnnexPerm lock @@ -345,9 +344,9 @@ 			[genstream dir h fs] 		hashObjectStop h 	return $ liftIO $ mapM_ removeFile $ map (dir </>) fs-	where-		genstream dir h fs streamer = forM_ fs $ \file -> do-			let path = dir </> file-			sha <- hashFile h path-			streamer $ Git.UpdateIndex.updateIndexLine-				sha FileBlob (asTopFilePath $ fileJournal file)+  where+	genstream dir h fs streamer = forM_ fs $ \file -> do+		let path = dir </> file+		sha <- hashFile h path+		streamer $ Git.UpdateIndex.updateIndexLine+			sha FileBlob (asTopFilePath $ fileJournal file)
Annex/CatFile.hs view
@@ -9,6 +9,7 @@ 	catFile, 	catObject, 	catObjectDetails,+	catKey, 	catFileHandle ) where @@ -37,8 +38,12 @@  catFileHandle :: Annex Git.CatFile.CatFileHandle catFileHandle = maybe startup return =<< Annex.getState Annex.catfilehandle-	where-		startup = do-			h <- inRepo Git.CatFile.catFileStart-			Annex.changeState $ \s -> s { Annex.catfilehandle = Just h }-			return h+  where+	startup = do+		h <- inRepo Git.CatFile.catFileStart+		Annex.changeState $ \s -> s { Annex.catfilehandle = Just h }+		return h++{- From the Sha or Ref of a symlink back to the key. -}+catKey :: Ref -> Annex (Maybe Key)+catKey ref = fileKey . takeFileName . encodeW8 . L.unpack  <$> catObject ref
Annex/CheckAttr.hs view
@@ -28,8 +28,8 @@  checkAttrHandle :: Annex Git.CheckAttrHandle checkAttrHandle = maybe startup return =<< Annex.getState Annex.checkattrhandle-	where-		startup = do-			h <- inRepo $ Git.checkAttrStart annexAttrs-			Annex.changeState $ \s -> s { Annex.checkattrhandle = Just h }-			return h+  where+	startup = do+		h <- inRepo $ Git.checkAttrStart annexAttrs+		Annex.changeState $ \s -> s { Annex.checkattrhandle = Just h }+		return h
Annex/Content.hs view
@@ -1,6 +1,6 @@ {- git-annex file content managing  -- - Copyright 2010 Joey Hess <joey@kitenet.net>+ - Copyright 2010,2012 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -10,12 +10,12 @@ 	inAnnexSafe, 	lockContent, 	calcGitLink,-	logStatus, 	getViaTmp, 	getViaTmpUnchecked, 	withTmp, 	checkDiskSpace, 	moveAnnex,+	sendAnnex, 	removeAnnex, 	fromAnnex, 	moveBad,@@ -26,15 +26,15 @@ 	freezeContent, 	thawContent, 	freezeContentDir,+	createContentDir,+	replaceFile, ) where  import System.IO.Unsafe (unsafeInterleaveIO)  import Common.Annex import Logs.Location-import Annex.UUID import qualified Git-import qualified Git.Config import qualified Annex import qualified Annex.Queue import qualified Annex.Branch@@ -48,33 +48,52 @@ import Annex.Exception import Git.SharedRepository import Annex.Perms+import Annex.Content.Direct  {- Checks if a given key's content is currently present. -} inAnnex :: Key -> Annex Bool-inAnnex = inAnnex' doesFileExist-inAnnex' :: (FilePath -> IO a) -> Key -> Annex a-inAnnex' a key = do-	whenM (fromRepo Git.repoIsUrl) $-		error "inAnnex cannot check remote repo"-	inRepo $ \g -> gitAnnexLocation key g >>= a+inAnnex = inAnnex' id False $ liftIO . doesFileExist +{- Generic inAnnex, handling both indirect and direct mode.+ -+ - In direct mode, at least one of the associated files must pass the+ - check. Additionally, the file must be unmodified.+ -}+inAnnex' :: (a -> Bool) -> a -> (FilePath -> Annex a) -> Key -> Annex a+inAnnex' isgood bad check key = withObjectLoc key checkindirect checkdirect+  where+	checkindirect loc = do+		whenM (fromRepo Git.repoIsUrl) $+			error "inAnnex cannot check remote repo"+		check loc+	checkdirect [] = return bad+	checkdirect (loc:locs) = do+		r <- check loc+		if isgood r+			then ifM (goodContent key loc)+				( return r+				, checkdirect locs+				)+			else checkdirect locs+ {- A safer check; the key's content must not only be present, but  - is not in the process of being removed. -} inAnnexSafe :: Key -> Annex (Maybe Bool)-inAnnexSafe = inAnnex' $ \f -> openforlock f >>= check-	where-		openforlock f = catchMaybeIO $-			openFd f ReadOnly Nothing defaultFileFlags-		check Nothing = return is_missing-		check (Just h) = do-			v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)-			closeFd h-			return $ case v of-				Just _ -> is_locked-				Nothing -> is_unlocked-		is_locked = Nothing-		is_unlocked = Just True-		is_missing = Just False+inAnnexSafe = inAnnex' (maybe False id) (Just False) go+  where+	go f = liftIO $ openforlock f >>= check+	openforlock f = catchMaybeIO $+		openFd f ReadOnly Nothing defaultFileFlags+	check Nothing = return is_missing+	check (Just h) = do+		v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)+		closeFd h+		return $ case v of+			Just _ -> is_locked+			Nothing -> is_unlocked+	is_locked = Nothing+	is_unlocked = Just True+	is_missing = Just False  {- Content is exclusively locked while running an action that might remove  - it. (If the content is not present, no locking is done.) -}@@ -82,25 +101,25 @@ lockContent key a = do 	file <- inRepo $ gitAnnexLocation key 	bracketIO (openforlock file >>= lock) unlock a-	where-		{- Since files are stored with the write bit disabled, have-		 - to fiddle with permissions to open for an exclusive lock. -}-		openforlock f = catchMaybeIO $ ifM (doesFileExist f)-			( withModifiedFileMode f-				(`unionFileModes` ownerWriteMode)-				open-			, open-			)-			where-				open = openFd f ReadWrite Nothing defaultFileFlags-		lock Nothing = return Nothing-		lock (Just fd) = do-			v <- tryIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)-			case v of-				Left _ -> error "content is locked"-				Right _ -> return $ Just fd-		unlock Nothing = noop-		unlock (Just l) = closeFd l+  where+	{- Since files are stored with the write bit disabled, have+	 - to fiddle with permissions to open for an exclusive lock. -}+	openforlock f = catchMaybeIO $ ifM (doesFileExist f)+		( withModifiedFileMode f+			(`unionFileModes` ownerWriteMode)+			open+		, open+		)+	  where+		open = openFd f ReadWrite Nothing defaultFileFlags+	lock Nothing = return Nothing+	lock (Just fd) = do+		v <- tryIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)+		case v of+			Left _ -> error "content is locked"+			Right _ -> return $ Just fd+	unlock Nothing = noop+	unlock (Just l) = closeFd l  {- Calculates the relative path to use to link a file to a key. -} calcGitLink :: FilePath -> Key -> Annex FilePath@@ -109,15 +128,8 @@ 	let absfile = fromMaybe whoops $ absNormPath cwd file 	loc <- inRepo $ gitAnnexLocation key 	return $ relPathDirToFile (parentDir absfile) loc-	where-		whoops = error $ "unable to normalize " ++ file--{- Updates the Logs.Location when a key's presence changes in the current- - repository. -}-logStatus :: Key -> LogStatus -> Annex ()-logStatus key status = do-	u <- getUUID-	logChange key u status+  where+	whoops = error $ "unable to normalize " ++ file  {- Runs an action, passing it a temporary filename to get,  - and if the action succeeds, moves the temp file into @@ -151,10 +163,10 @@  - and not being copied into place. -} getViaTmpUnchecked :: Key -> (FilePath -> Annex Bool) -> Annex Bool getViaTmpUnchecked key action = do-	tmp <- prepTmp key-	ifM (action tmp)+	tmpfile <- prepTmp key+	ifM (action tmpfile) 		( do-			moveAnnex key tmp+			moveAnnex key tmpfile 			logStatus key InfoPresent 			return True 		, do@@ -175,7 +187,7 @@  - in a destination (or the annex) printing a warning if not. -} checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Annex Bool checkDiskSpace destination key alreadythere = do-	reserve <- getDiskReserve+	reserve <- annexDiskReserve <$> Annex.getGitConfig 	free <- liftIO . getDiskFree =<< dir 	force <- Annex.getState Annex.force 	case (free, keySize key) of@@ -186,16 +198,18 @@ 				needmorespace (need + reserve - have - alreadythere) 			return ok 		_ -> return True-	where-		dir = maybe (fromRepo gitAnnexDir) return destination-		needmorespace n =-			warning $ "not enough free space, need " ++ -				roughSize storageUnits True n ++-				" more" ++ forcemsg-		forcemsg = " (use --force to override this check or adjust annex.diskreserve)"+  where+	dir = maybe (fromRepo gitAnnexDir) return destination+	needmorespace n =+		warning $ "not enough free space, need " ++ +			roughSize storageUnits True n +++			" more" ++ forcemsg+	forcemsg = " (use --force to override this check or adjust annex.diskreserve)" -{- Moves a file into .git/annex/objects/+{- Moves a key's content into .git/annex/objects/  -+ - In direct mode, moves it to the associated file, or files.+ -  - What if the key there already has content? This could happen for  - various reasons; perhaps the same content is being annexed again.  - Perhaps there has been a hash collision generating the keys.@@ -216,46 +230,126 @@  - meet.  -} moveAnnex :: Key -> FilePath -> Annex ()-moveAnnex key src = do-	dest <- inRepo $ gitAnnexLocation key-	ifM (liftIO $ doesFileExist dest)-		( liftIO $ removeFile src-		, do-			createContentDir dest-			liftIO $ moveFile src dest-			freezeContent dest-			freezeContentDir dest-		)+moveAnnex key src = withObjectLoc key storeobject storedirect+  where+	storeobject dest = do+		ifM (liftIO $ doesFileExist dest)+			( liftIO $ removeFile src+			, do+				createContentDir dest+				liftIO $ moveFile src dest+				freezeContent dest+				freezeContentDir dest+			)+	storedirect [] = storeobject =<< inRepo (gitAnnexLocation key)+	storedirect (dest:fs) = do+		updateCache key src+		thawContent src+		liftIO $ replaceFile dest $ moveFile src+		liftIO $ forM_ fs $ \f -> replaceFile f $ createLink dest -withObjectLoc :: Key -> ((FilePath, FilePath) -> Annex a) -> Annex a-withObjectLoc key a = do-	file <- inRepo $ gitAnnexLocation key-	let dir = parentDir file-	a (dir, file)+{- Replaces any existing file with a new version, by running an action.+ - First, makes sure the file is deleted. Or, if it didn't already exist,+ - makes sure the parent directory exists. -}+replaceFile :: FilePath -> (FilePath -> IO ()) -> IO ()+replaceFile file a = do+	r <- tryIO $ removeFile file+	case r of+		Left _ -> createDirectoryIfMissing True (parentDir file)+		_ -> noop+	a file +{- Runs an action to transfer an object's content.+ -+ - In direct mode, it's possible for the file to change as it's being sent.+ - If this happens, returns False. Currently, an arbitrary amount of bad+ - data may be sent when this occurs. The send is not retried even if+ - another file is known to have the same content; the action may not be+ - idempotent.+ -+ - Since objects changing as they're transferred is a somewhat unusual+ - situation, and since preventing writes to the file would be expensive,+ - annoying or both, we instead detect the situation after the affect,+ - and fail. Thus, it's up to the caller to detect a failure and take+ - appropriate action. Such as, for example, ensuring that the bad+ - data that was sent does not get installed into the annex it's being+ - sent to.+ -}+sendAnnex :: Key -> (FilePath -> Annex Bool) -> Annex Bool+sendAnnex key a = withObjectLoc key sendobject senddirect+  where+	sendobject = a+	senddirect [] = return False+	senddirect (f:fs) = do+		cache <- recordedCache key+		-- check that we have a good file+		ifM (compareCache f cache)+			( do+				r <- sendobject f+				-- see if file changed while it was being sent+				ok <- compareCache f cache+				return (r && ok)+			, senddirect fs+			)++{- Performs an action, passing it the location to use for a key's content.+ -+ - In direct mode, the associated files will be passed. But, if there are+ - no associated files for a key, the indirect mode action will be+ - performed instead. -}+withObjectLoc :: Key -> (FilePath -> Annex a) -> ([FilePath] -> Annex a) -> Annex a+withObjectLoc key indirect direct = ifM isDirect+	( do+		fs <- associatedFiles key+		if null fs+			then goindirect+			else direct fs+	, goindirect+	)+  where+	goindirect = indirect =<< inRepo (gitAnnexLocation key)++ cleanObjectLoc :: Key -> Annex () cleanObjectLoc key = do 	file <- inRepo $ gitAnnexLocation key 	liftIO $ removeparents file (3 :: Int)-	where-		removeparents _ 0 = noop-		removeparents file n = do-			let dir = parentDir file-			maybe noop (const $ removeparents dir (n-1))-				<=< catchMaybeIO $ removeDirectory dir+  where+	removeparents _ 0 = noop+	removeparents file n = do+		let dir = parentDir file+		maybe noop (const $ removeparents dir (n-1))+			<=< catchMaybeIO $ removeDirectory dir -{- Removes a key's file from .git/annex/objects/ -}+{- Removes a key's file from .git/annex/objects/+ -+ - In direct mode, deletes the associated files or files, and replaces+ - them with symlinks. -} removeAnnex :: Key -> Annex ()-removeAnnex key = withObjectLoc key $ \(dir, file) -> do-	liftIO $ do-		allowWrite dir-		removeFile file-	cleanObjectLoc key+removeAnnex key = withObjectLoc key remove removedirect+  where+	remove file = do+		liftIO $ do+			allowWrite $ parentDir file+			removeFile file+		cleanObjectLoc key+	removedirect fs = do+		removeCache key+		mapM_ resetfile fs+	resetfile f = do+		l <- calcGitLink f key+		top <- fromRepo Git.repoPath+		cwd <- liftIO getCurrentDirectory+		let top' = fromMaybe top $ absNormPath cwd top+		let l' = relPathDirToFile top' (fromMaybe l $ absNormPath top' l)+		liftIO $ replaceFile f $ const $+			createSymbolicLink l' f  {- Moves a key's file out of .git/annex/objects/ -} fromAnnex :: Key -> FilePath -> Annex ()-fromAnnex key dest = withObjectLoc key $ \(dir, file) -> do-	liftIO $ allowWrite dir+fromAnnex key dest = do+	file <- inRepo $ gitAnnexLocation key+	liftIO $ allowWrite $ parentDir file 	thawContent file 	liftIO $ moveFile file dest 	cleanObjectLoc key@@ -278,19 +372,19 @@ {- List of keys whose content exists in .git/annex/objects/ -} getKeysPresent :: Annex [Key] getKeysPresent = liftIO . traverse (2 :: Int) =<< fromRepo gitAnnexObjectDir-	where-		traverse depth dir = do-			contents <- catchDefaultIO [] (dirContents dir)-			if depth == 0-				then continue (mapMaybe (fileKey . takeFileName) contents) []-				else do-					let deeper = traverse (depth - 1)-					continue [] (map deeper contents)-		continue keys [] = return keys-		continue keys (a:as) = do-			{- Force lazy traversal with unsafeInterleaveIO. -}-			morekeys <- unsafeInterleaveIO a-			continue (morekeys++keys) as+  where+	traverse depth dir = do+		contents <- catchDefaultIO [] (dirContents dir)+		if depth == 0+			then continue (mapMaybe (fileKey . takeFileName) contents) []+			else do+				let deeper = traverse (depth - 1)+				continue [] (map deeper contents)+	continue keys [] = return keys+	continue keys (a:as) = do+		{- Force lazy traversal with unsafeInterleaveIO. -}+		morekeys <- unsafeInterleaveIO a+		continue (morekeys++keys) as  {- Things to do to record changes to content when shutting down.  -@@ -301,11 +395,8 @@ saveState nocommit = doSideAction $ do 	Annex.Queue.flush 	unless nocommit $-		whenM alwayscommit $+		whenM (annexAlwaysCommit <$> Annex.getGitConfig) $ 			Annex.Branch.commit "update"-	where-		alwayscommit = fromMaybe True . Git.Config.isTrue-			<$> getConfig (annexConfig "alwayscommit") ""  {- Downloads content from any of a list of urls. -} downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool@@ -318,41 +409,41 @@  - This is used to speed up some rsyncs. -} preseedTmp :: Key -> FilePath -> Annex Bool preseedTmp key file = go =<< inAnnex key-	where-		go False = return False-		go True = do-			ok <- copy-			when ok $ thawContent file-			return ok-		copy = ifM (liftIO $ doesFileExist file)-				( return True-				, do-					s <- inRepo $ gitAnnexLocation key-					liftIO $ copyFileExternal s file-				)+  where+	go False = return False+	go True = do+		ok <- copy+		when ok $ thawContent file+		return ok+	copy = ifM (liftIO $ doesFileExist file)+			( return True+			, do+				s <- inRepo $ gitAnnexLocation key+				liftIO $ copyFileExternal s file+			)  {- Blocks writing to an annexed file. The file is made unwritable  - to avoid accidental edits. core.sharedRepository may change  - who can read it. -} freezeContent :: FilePath -> Annex () freezeContent file = liftIO . go =<< fromRepo getSharedRepository-	where-		go GroupShared = modifyFileMode file $-			removeModes writeModes .-			addModes [ownerReadMode, groupReadMode]-		go AllShared = modifyFileMode file $-			removeModes writeModes .-			addModes readModes-		go _ = preventWrite file+  where+	go GroupShared = modifyFileMode file $+		removeModes writeModes .+		addModes [ownerReadMode, groupReadMode]+	go AllShared = modifyFileMode file $+		removeModes writeModes .+		addModes readModes+	go _ = preventWrite file  {- Allows writing to an annexed file that freezeContent was called on  - before. -} thawContent :: FilePath -> Annex () thawContent file = liftIO . go =<< fromRepo getSharedRepository-	where-		go GroupShared = groupWriteRead file-		go AllShared = groupWriteRead file-		go _ = allowWrite file+  where+	go GroupShared = groupWriteRead file+	go AllShared = groupWriteRead file+	go _ = allowWrite file  {- Blocks writing to the directory an annexed file is in, to prevent the  - file accidentially being deleted. However, if core.sharedRepository@@ -361,11 +452,11 @@  -} freezeContentDir :: FilePath -> Annex () freezeContentDir file = liftIO . go =<< fromRepo getSharedRepository-	where-		dir = parentDir file-		go GroupShared = groupWriteRead dir-		go AllShared = groupWriteRead dir-		go _ = preventWrite dir+  where+	dir = parentDir file+	go GroupShared = groupWriteRead dir+	go AllShared = groupWriteRead dir+	go _ = preventWrite dir  {- Makes the directory tree to store an annexed file's content,  - with appropriate permissions on each level. -}@@ -375,5 +466,5 @@ 		createAnnexDirectory dir  	-- might have already existed with restricted perms 	liftIO $ allowWrite dir-	where-		dir = parentDir dest+  where+	dir = parentDir dest
+ Annex/Content/Direct.hs view
@@ -0,0 +1,150 @@+{- git-annex file content managing for direct mode+ -+ - Copyright 2010,2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Annex.Content.Direct (+	associatedFiles,+	removeAssociatedFile,+	addAssociatedFile,+	goodContent,+	changedFileStatus,+	updateCache,+	recordedCache,+	compareCache,+	writeCache,+	removeCache,+	genCache,+	toCache,+	Cache(..),+	prop_read_show_direct+) where++import Common.Annex+import qualified Git+import Utility.TempFile+import Logs.Location++import System.Posix.Types++{- Files in the tree that are associated with a key. -}+associatedFiles :: Key -> Annex [FilePath]+associatedFiles key = do+	files <- associatedFilesRelative key+	top <- fromRepo Git.repoPath+	return $ map (top </>) files++{- List of files in the tree that are associated with a key, relative to+ - the top of the repo. -}+associatedFilesRelative :: Key -> Annex [FilePath] +associatedFilesRelative key = do+	mapping <- inRepo $ gitAnnexMapping key+	liftIO $ catchDefaultIO [] $ lines <$> readFile mapping++{- Changes the associated files information for a key, applying a+ - transformation to the list. Returns a copy of the new info. -}+changeAssociatedFiles :: Key -> ([FilePath] -> [FilePath]) -> Annex [FilePath]+changeAssociatedFiles key transform = do+	mapping <- inRepo $ gitAnnexMapping key+	files <- associatedFilesRelative key+	let files' = transform files+	when (files /= files') $+		liftIO $ viaTmp writeFile mapping $ unlines files'+	return files'++removeAssociatedFile :: Key -> FilePath -> Annex [FilePath]+removeAssociatedFile key file = do+	fs <- changeAssociatedFiles key $ filter (/= normalise file)+	when (null fs) $+		logStatus key InfoMissing+	return fs++addAssociatedFile :: Key -> FilePath -> Annex [FilePath]+addAssociatedFile key file = changeAssociatedFiles key $ \files ->+	if file' `elem` files+		then files+		else file':files+  where+	file' = normalise file++{- Checks if a file in the tree, associated with a key, has not been modified.+ -+ - To avoid needing to fsck the file's content, which can involve an+ - expensive checksum, this relies on a cache that contains the file's+ - expected mtime and inode.+ -}+goodContent :: Key -> FilePath -> Annex Bool+goodContent key file = do+	old <- recordedCache key+	compareCache file old++changedFileStatus :: Key -> FileStatus -> Annex Bool+changedFileStatus key status = do+	old <- recordedCache key+	let curr = toCache status+	return $ curr /= old++{- Gets the recorded cache for a key. -}+recordedCache :: Key -> Annex (Maybe Cache)+recordedCache key = withCacheFile key $ \cachefile ->+	catchDefaultIO Nothing $ readCache <$> readFile cachefile++{- Compares a cache with the current cache for a file. -}+compareCache :: FilePath -> Maybe Cache -> Annex Bool+compareCache file old = do+	curr <- liftIO $ genCache file+	return $ isJust curr && curr == old++{- Stores a cache of attributes for a file that is associated with a key. -}+updateCache :: Key -> FilePath -> Annex ()+updateCache key file = maybe noop (writeCache key) =<< liftIO (genCache file)++{- Writes a cache for a key. -}+writeCache :: Key -> Cache -> Annex ()+writeCache key cache = withCacheFile key $ \cachefile -> do+	createDirectoryIfMissing True (parentDir cachefile)+	writeFile cachefile $ showCache cache++{- Removes a cache. -}+removeCache :: Key -> Annex ()+removeCache key = withCacheFile key nukeFile++{- Cache a file's inode, size, and modification time to determine if it's+ - been changed. -}+data Cache = Cache FileID FileOffset EpochTime+	deriving (Eq, Show)++showCache :: Cache -> String+showCache (Cache inode size mtime) = unwords+	[ show inode+	, show size+	, show mtime+	]++readCache :: String -> Maybe Cache+readCache s = case words s of+	(inode:size:mtime:_) -> Cache+		<$> readish inode+		<*> readish size+		<*> readish mtime+	_ -> Nothing++-- for quickcheck+prop_read_show_direct :: Cache -> Bool+prop_read_show_direct c = readCache (showCache c) == Just c++genCache :: FilePath -> IO (Maybe Cache)+genCache f = catchDefaultIO Nothing $ toCache <$> getFileStatus f++toCache :: FileStatus -> Maybe Cache+toCache s+	| isRegularFile s = Just $ Cache+		(fileID s)+		(fileSize s)+		(modificationTime s)+	| otherwise = Nothing++withCacheFile :: Key -> (FilePath -> IO a) -> Annex a+withCacheFile key a = liftIO . a =<< inRepo (gitAnnexCache key)
+ Annex/Direct.hs view
@@ -0,0 +1,219 @@+{- git-annex direct mode+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Annex.Direct where++import Common.Annex+import qualified Git+import qualified Git.LsFiles+import qualified Git.UpdateIndex+import qualified Git.HashObject+import qualified Git.Merge+import qualified Git.DiffTree as DiffTree+import Git.Sha+import Git.Types+import Annex.CatFile+import Utility.FileMode+import qualified Annex.Queue+import Logs.Location+import Backend+import Types.KeySource+import Annex.Content+import Annex.Content.Direct++{- Uses git ls-files to find files that need to be committed, and stages+ - them into the index. Returns True if some changes were staged. -}+stageDirect :: Annex Bool+stageDirect = do+	Annex.Queue.flush+	top <- fromRepo Git.repoPath+	(l, cleanup) <- inRepo $ Git.LsFiles.stagedDetails [top]+	forM_ l go+	void $ liftIO cleanup+	staged <- Annex.Queue.size+	Annex.Queue.flush+	return $ staged /= 0+  where+	{- Determine what kind of modified or deleted file this is, as+	 - efficiently as we can, by getting any key that's associated+	 - with it in git, as well as its stat info. -}+	go (file, Just sha) = do+		mkey <- catKey sha+		mstat <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file+		case (mkey, mstat, toCache =<< mstat) of+			(Just key, _, Just cache) -> do+				{- All direct mode files will show as+				 - modified, so compare the cache to see if+				 - it really was. -}+				oldcache <- recordedCache key+				when (oldcache /= Just cache) $+					modifiedannexed file key cache+			(Just key, Nothing, _) -> deletedannexed file key+			(Nothing, Nothing, _) -> deletegit file+			(_, Just _, _) -> addgit file+	go (file, Nothing) = do+		mstat <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file+		case (mstat, toCache =<< mstat) of+			(Nothing, _) -> noop+			(Just stat, Just cache)+				| isSymbolicLink stat -> addgit file+				| otherwise -> void $ addDirect file cache+			(Just stat, Nothing)+				| isSymbolicLink stat -> addgit file+				| otherwise -> noop++	modifiedannexed file oldkey cache = do+		void $ removeAssociatedFile oldkey file+		void $ addDirect file cache+	+	deletedannexed file key = do+		void $ removeAssociatedFile key file+		deletegit file+	+	addgit file = Annex.Queue.addCommand "add" [Param "-f"] [file]++	deletegit file = Annex.Queue.addCommand "rm" [Param "-f"] [file]++{- Adds a file to the annex in direct mode. Can fail, if the file is+ - modified or deleted while it's being added. -}+addDirect :: FilePath -> Cache -> Annex Bool+addDirect file cache = do+	showStart "add" file+	let source = KeySource+		{ keyFilename = file+		, contentLocation = file+		}+	got =<< genKey source =<< chooseBackend file+  where+	got Nothing = do+		showEndFail+		return False+	got (Just (key, _)) = ifM (compareCache file $ Just cache)+		( do+			link <- calcGitLink file key+			sha <- inRepo $ Git.HashObject.hashObject BlobObject link+			Annex.Queue.addUpdateIndex =<<+				inRepo (Git.UpdateIndex.stageSymlink file sha)+			writeCache key cache+			void $ addAssociatedFile key file+			logStatus key InfoPresent+			showEndOk+			return True+		, do+			showEndFail+			return False+		)++{- In direct mode, git merge would usually refuse to do anything, since it+ - sees present direct mode files as type changed files. To avoid this,+ - merge is run with the work tree set to a temp directory.+ -+ - This should only be used once any changes to the real working tree have+ - already been committed, because it overwrites files in the working tree.+ -}+mergeDirect :: FilePath -> Git.Ref -> Git.Repo -> IO Bool+mergeDirect d branch g = do+	createDirectoryIfMissing True d+	let g' = g { location = Local { gitdir = Git.localGitDir g, worktree = Just d } }+	Git.Merge.mergeNonInteractive branch g'++{- Cleans up after a direct mode merge. The merge must have been committed,+ - and the commit sha passed in, along with the old sha of the tree+ - before the merge. Uses git diff-tree to find files that changed between+ - the two shas, and applies those changes to the work tree.+ -}+mergeDirectCleanup :: FilePath -> Git.Ref -> Git.Ref -> Annex ()+mergeDirectCleanup d oldsha newsha = do+	(items, cleanup) <- inRepo $ DiffTree.diffTreeRecursive oldsha newsha+	forM_ items updated+	void $ liftIO $ cleanup+	liftIO $ removeDirectoryRecursive d+  where+	updated item = do+		go DiffTree.srcsha DiffTree.srcmode moveout moveout_raw+		go DiffTree.dstsha DiffTree.dstmode movein movein_raw+	  where+		go getsha getmode a araw+			| getsha item == nullSha = noop+			| isSymLink (getmode item) =+				maybe (araw f) (\k -> void $ a k f)+					=<< catKey (getsha item)+			| otherwise = araw f+		f = DiffTree.file item++	moveout k f = removeDirect k f++	{- Files deleted by the merge are removed from the work tree.+	 - Empty work tree directories are removed, per git behavior. -}+	moveout_raw f = liftIO $ do+		nukeFile f+		void $ catchMaybeIO $ removeDirectory $ parentDir f+	+	{- The symlink is created from the key, rather than moving in the+	 - symlink created in the temp directory by the merge. This because+	 - a conflicted merge will write to some other file in the temp+	 - directory.+	 -+ 	 - Symlinks are replaced with their content, if it's available. -}+	movein k f = do+		l <- calcGitLink f k+		liftIO $ replaceFile f $ const $+			createSymbolicLink l f+		toDirect k f+	+	{- Any new, modified, or renamed files were written to the temp+	 - directory by the merge, and are moved to the real work tree. -}+	movein_raw f = liftIO $ do+		createDirectoryIfMissing True $ parentDir f+		void $ catchMaybeIO $ rename (d </> f) f++{- If possible, converts a symlink in the working tree into a direct+ - mode file. -}+toDirect :: Key -> FilePath -> Annex ()+toDirect k f = maybe noop id =<< toDirectGen k f++toDirectGen :: Key -> FilePath -> Annex (Maybe (Annex ()))+toDirectGen k f = do+	loc <- inRepo $ gitAnnexLocation k+	createContentDir loc -- thaws directory too+	locs <- filter (/= normalise f) <$> addAssociatedFile k f+	case locs of+		[] -> ifM (liftIO $ doesFileExist loc)+			( return $ Just $ do+				{- Move content from annex to direct file. -}+				updateCache k loc+				thawContent loc+				liftIO $ replaceFile f $ moveFile loc+			, return Nothing+			)+		(loc':_) -> return $ Just $ do+			{- Another direct file has the content, so+			 - hard link to it. -}+			liftIO $ replaceFile f $ createLink loc'++{- Removes a direct mode file, while retaining its content. -}+removeDirect :: Key -> FilePath -> Annex ()+removeDirect k f = do+	locs <- removeAssociatedFile k f+	when (null locs) $ do+		r <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus f+		case r of+			Just s+				| not (isSymbolicLink s) ->+					moveAnnex k f+			_ -> noop+	liftIO $ do+		nukeFile f+		void $ catchMaybeIO $ removeDirectory $ parentDir f++{- Called when a direct mode file has been changed. Its old content may be+ - lost. -}+changedDirect :: Key -> FilePath -> Annex ()+changedDirect oldk f = do+	locs <- removeAssociatedFile oldk f+	whenM (pure (null locs) <&&> not <$> inAnnex oldk) $+		logStatus oldk InfoMissing
Annex/Journal.hs view
@@ -63,10 +63,10 @@  -} journalFile :: FilePath -> Git.Repo -> FilePath journalFile file repo = gitAnnexJournalDir repo </> concatMap mangle file-	where-		mangle '/' = "_"-		mangle '_' = "__"-		mangle c = [c]+  where+	mangle '/' = "_"+	mangle '_' = "__"+	mangle c = [c]  {- Converts a journal file (relative to the journal dir) back to the  - filename on the branch. -}@@ -81,9 +81,9 @@ 	createAnnexDirectory $ takeDirectory file 	mode <- annexFileMode 	bracketIO (lock file mode) unlock a-	where-		lock file mode = do-			l <- noUmask mode $ createFile file mode-			waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0)-			return l-		unlock = closeFd+  where+	lock file mode = do+		l <- noUmask mode $ createFile file mode+		waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0)+		return l+	unlock = closeFd
Annex/LockPool.hs view
@@ -17,21 +17,21 @@ {- Create a specified lock file, and takes a shared lock. -} lockFile :: FilePath -> Annex () lockFile file = go =<< fromPool file-	where-		go (Just _) = noop -- already locked-		go Nothing = do-			mode <- annexFileMode-			fd <- liftIO $ noUmask mode $-				openFd file ReadOnly (Just mode) defaultFileFlags-			liftIO $ waitToSetLock fd (ReadLock, AbsoluteSeek, 0, 0)-			changePool $ M.insert file fd+  where+	go (Just _) = noop -- already locked+	go Nothing = do+		mode <- annexFileMode+		fd <- liftIO $ noUmask mode $+			openFd file ReadOnly (Just mode) defaultFileFlags+		liftIO $ waitToSetLock fd (ReadLock, AbsoluteSeek, 0, 0)+		changePool $ M.insert file fd  unlockFile :: FilePath -> Annex () unlockFile file = maybe noop go =<< fromPool file-	where-		go fd = do-			liftIO $ closeFd fd-			changePool $ M.delete file+  where+	go fd = do+		liftIO $ closeFd fd+		changePool $ M.delete file  getPool :: Annex (M.Map FilePath Fd) getPool = getState lockpool
Annex/Perms.hs view
@@ -21,11 +21,11 @@  withShared :: (SharedRepository -> Annex a) -> Annex a withShared a = maybe startup a =<< Annex.getState Annex.shared-	where-		startup = do-			shared <- fromRepo getSharedRepository-			Annex.changeState $ \s -> s { Annex.shared = Just shared }-			a shared+  where+	startup = do+		shared <- fromRepo getSharedRepository+		Annex.changeState $ \s -> s { Annex.shared = Just shared }+		a shared  {- Sets appropriate file mode for a file or directory in the annex,  - other than the content files and content directory. Normally,@@ -33,38 +33,38 @@  - allow the group to write, etc. -} setAnnexPerm :: FilePath -> Annex () setAnnexPerm file = withShared $ liftIO . go-	where-		go GroupShared = groupWriteRead file-		go AllShared = modifyFileMode file $ addModes $-			[ ownerWriteMode, groupWriteMode ] ++ readModes-		go _ = noop+  where+	go GroupShared = groupWriteRead file+	go AllShared = modifyFileMode file $ addModes $+		[ ownerWriteMode, groupWriteMode ] ++ readModes+	go _ = noop  {- Gets the appropriate mode to use for creating a file in the annex  - (other than content files, which are locked down more). -} annexFileMode :: Annex FileMode annexFileMode = withShared $ return . go-	where-		go GroupShared = sharedmode-		go AllShared = combineModes (sharedmode:readModes)-		go _ = stdFileMode-		sharedmode = combineModes-			[ ownerWriteMode, groupWriteMode-			, ownerReadMode, groupReadMode-			]+  where+	go GroupShared = sharedmode+	go AllShared = combineModes (sharedmode:readModes)+	go _ = stdFileMode+	sharedmode = combineModes+		[ ownerWriteMode, groupWriteMode+		, ownerReadMode, groupReadMode+		]  {- Creates a directory inside the gitAnnexDir, including any parent  - directories. Makes directories with appropriate permissions. -} createAnnexDirectory :: FilePath -> Annex () createAnnexDirectory dir = traverse dir [] =<< top-	where-		top = parentDir <$> fromRepo gitAnnexDir-		traverse d below stop-			| d `equalFilePath` stop = done-			| otherwise = ifM (liftIO $ doesDirectoryExist d)-				( done-				, traverse (parentDir d) (d:below) stop-				)-			where-				done = forM_ below $ \p -> do-					liftIO $ createDirectory p-					setAnnexPerm p+  where+	top = parentDir <$> fromRepo gitAnnexDir+	traverse d below stop+		| d `equalFilePath` stop = done+		| otherwise = ifM (liftIO $ doesDirectoryExist d)+			( done+			, traverse (parentDir d) (d:below) stop+			)+	  where+		done = forM_ below $ \p -> do+			liftIO $ createDirectory p+			setAnnexPerm p
Annex/Queue.hs view
@@ -17,7 +17,6 @@ import Annex hiding (new) import qualified Git.Queue import qualified Git.UpdateIndex-import Config  {- Adds a git command to the queue. -} addCommand :: String -> [CommandParam] -> [FilePath] -> Annex ()@@ -55,11 +54,9 @@  new :: Annex Git.Queue.Queue new = do-	q <- Git.Queue.new <$> queuesize+	q <- Git.Queue.new . annexQueueSize <$> getGitConfig 	store q 	return q-	where-		queuesize = readish <$> getConfig (annexConfig "queuesize") ""  store :: Git.Queue.Queue -> Annex () store q = changeState $ \s -> s { repoqueue = Just q }
Annex/Ssh.hs view
@@ -18,28 +18,27 @@ import Annex.LockPool import Annex.Perms #ifndef WITH_OLD_SSH-import qualified Git.Config-import Config import qualified Build.SysConfig as SysConfig+import qualified Annex #endif  {- Generates parameters to ssh to a given host (or user@host) on a given  - port, with connection caching. -} sshParams :: (String, Maybe Integer) -> [CommandParam] -> Annex [CommandParam] sshParams (host, port) opts = go =<< sshInfo (host, port)-	where-		go (Nothing, params) = ret params-		go (Just socketfile, params) = do-			cleanstale-			liftIO $ createDirectoryIfMissing True $ parentDir socketfile-			lockFile $ socket2lock socketfile-			ret params-		ret ps = return $ ps ++ opts ++ portParams port ++ [Param host]-		-- If the lock pool is empty, this is the first ssh of this-		-- run. There could be stale ssh connections hanging around-		-- from a previous git-annex run that was interrupted.-		cleanstale = whenM (not . any isLock . M.keys <$> getPool) $-			sshCleanup+  where+	go (Nothing, params) = ret params+	go (Just socketfile, params) = do+		cleanstale+		liftIO $ createDirectoryIfMissing True $ parentDir socketfile+		lockFile $ socket2lock socketfile+		ret params+	ret ps = return $ ps ++ opts ++ portParams port ++ [Param host]+	-- If the lock pool is empty, this is the first ssh of this+	-- run. There could be stale ssh connections hanging around+	-- from a previous git-annex run that was interrupted.+	cleanstale = whenM (not . any isLock . M.keys <$> getPool) $+		sshCleanup  sshInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam]) sshInfo (host, port) = ifM caching@@ -55,13 +54,12 @@ 					else return (Nothing, []) 	, return (Nothing, []) 	)-	where+  where #ifdef WITH_OLD_SSH-		caching = return False+	caching = return False #else-		caching = fromMaybe SysConfig.sshconnectioncaching -			. Git.Config.isTrue-			<$> getConfig (annexConfig "sshcaching") ""+	caching = fromMaybe SysConfig.sshconnectioncaching +		. annexSshCaching <$> Annex.getGitConfig #endif  cacheParams :: FilePath -> [CommandParam]@@ -81,34 +79,34 @@ 	sockets <- filter (not . isLock) <$> 		liftIO (catchDefaultIO [] $ dirContents dir) 	forM_ sockets cleanup-	where-		cleanup socketfile = do-			-- Drop any shared lock we have, and take an-			-- exclusive lock, without blocking. If the lock-			-- succeeds, nothing is using this ssh, and it can-			-- be stopped.-			let lockfile = socket2lock socketfile-			unlockFile lockfile-			mode <- annexFileMode-			fd <- liftIO $ noUmask mode $-				openFd lockfile ReadWrite (Just mode) defaultFileFlags-			v <- liftIO $ tryIO $-				setLock fd (WriteLock, AbsoluteSeek, 0, 0)-			case v of-				Left _ -> noop-				Right _ -> stopssh socketfile-			liftIO $ closeFd fd-		stopssh socketfile = do-			let (host, port) = socket2hostport socketfile-			(_, params) <- sshInfo (host, port)-			-- "ssh -O stop" is noisy on stderr even with -q-			void $ liftIO $ catchMaybeIO $-				withQuietOutput createProcessSuccess $-					proc "ssh" $ toCommand $-						[ Params "-O stop"-						] ++ params ++ [Param host]-			-- Cannot remove the lock file; other processes may-			-- be waiting on our exclusive lock to use it.+  where+	cleanup socketfile = do+		-- Drop any shared lock we have, and take an+		-- exclusive lock, without blocking. If the lock+		-- succeeds, nothing is using this ssh, and it can+		-- be stopped.+		let lockfile = socket2lock socketfile+		unlockFile lockfile+		mode <- annexFileMode+		fd <- liftIO $ noUmask mode $+			openFd lockfile ReadWrite (Just mode) defaultFileFlags+		v <- liftIO $ tryIO $+			setLock fd (WriteLock, AbsoluteSeek, 0, 0)+		case v of+			Left _ -> noop+			Right _ -> stopssh socketfile+		liftIO $ closeFd fd+	stopssh socketfile = do+		let (host, port) = socket2hostport socketfile+		(_, params) <- sshInfo (host, port)+		-- "ssh -O stop" is noisy on stderr even with -q+		void $ liftIO $ catchMaybeIO $+			withQuietOutput createProcessSuccess $+				proc "ssh" $ toCommand $+					[ Params "-O stop"+					] ++ params ++ [Param host]+		-- Cannot remove the lock file; other processes may+		-- be waiting on our exclusive lock to use it.  hostport2socket :: String -> Maybe Integer -> FilePath hostport2socket host Nothing = host@@ -118,8 +116,8 @@ socket2hostport socket 	| null p = (h, Nothing) 	| otherwise = (h, readish p)-	where-		(h, p) = separate (== '!') $ takeFileName socket+  where+	(h, p) = separate (== '!') $ takeFileName socket  socket2lock :: FilePath -> FilePath socket2lock socket = socket ++ lockExt
Annex/UUID.hs view
@@ -34,10 +34,10 @@  - so use the command line tool. -} genUUID :: IO UUID genUUID = gen . lines <$> readProcess command params-	where-		gen [] = error $ "no output from " ++ command-		gen (l:_) = toUUID l-		(command:params) = words SysConfig.uuid+  where+	gen [] = error $ "no output from " ++ command+	gen (l:_) = toUUID l+	(command:params) = words SysConfig.uuid  {- Get current repository's UUID. -} getUUID :: Annex UUID@@ -54,19 +54,19 @@ 			updatecache u 			return u 		else return c-	where-		updatecache u = do-			g <- gitRepo-			when (g /= r) $ storeUUID cachekey u-		cachekey = remoteConfig r "uuid"+  where+	updatecache u = do+		g <- gitRepo+		when (g /= r) $ storeUUID cachekey u+	cachekey = remoteConfig r "uuid"  removeRepoUUID :: Annex () removeRepoUUID = unsetConfig configkey  getUncachedUUID :: Git.Repo -> UUID getUncachedUUID = toUUID . Git.Config.get key ""-	where-		(ConfigKey key) = configkey+  where+	(ConfigKey key) = configkey  {- Make sure that the repo has an annex.uuid setting. -} prepUUID :: Annex ()
Annex/Version.hs view
@@ -9,6 +9,7 @@  import Common.Annex import Config+import qualified Annex  type Version = String @@ -25,10 +26,7 @@ versionField = annexConfig "version"  getVersion :: Annex (Maybe Version)-getVersion = handle <$> getConfig versionField ""-	where-		handle [] = Nothing-		handle v = Just v+getVersion = annexVersion <$> Annex.getGitConfig  setVersion :: Annex () setVersion = setConfig versionField defaultVersion@@ -41,6 +39,6 @@ 	| v `elem` supportedVersions = noop 	| v `elem` upgradableVersions = err "Upgrade this repository: git-annex upgrade" 	| otherwise = err "Upgrade git-annex."-	where-		err msg = error $ "Repository version " ++ v ++-			" is not supported. " ++ msg+  where+	err msg = error $ "Repository version " ++ v +++		" is not supported. " ++ msg
Assistant/Alert.hs view
@@ -71,7 +71,7 @@  {- Higher AlertId indicates a more recent alert. -} newtype AlertId = AlertId Integer-        deriving (Read, Show, Eq, Ord)+	deriving (Read, Show, Eq, Ord)  firstAlertId :: AlertId firstAlertId = AlertId 0@@ -247,7 +247,7 @@ 		[Tensed "Syncing" "Synced", "with", showRemotes rs] 	, alertData = [] 	, alertPriority = Low-        }+	}  scanAlert :: [Remote] -> Alert scanAlert rs = baseActivityAlert
Assistant/DaemonStatus.hs view
@@ -17,7 +17,6 @@ import qualified Remote import qualified Types.Remote as Remote import qualified Git-import Config  import Control.Concurrent.STM import System.Posix.Types@@ -48,7 +47,7 @@ {- Returns a function that updates the lists of syncable remotes. -} calcSyncRemotes :: Annex (DaemonStatus -> DaemonStatus) calcSyncRemotes = do-	rs <- filterM (repoSyncable . Remote.repo) =<<+	rs <- filter (remoteAnnexSync . Remote.gitconfig) . 		concat . Remote.byCost <$> Remote.enabledRemoteList 	alive <- trustExclude DeadTrusted (map Remote.uuid rs) 	let good r = Remote.uuid r `elem` alive
Assistant/Pushes.hs view
@@ -33,7 +33,7 @@ 	v <- getAssistant failedPushMap 	liftIO $ atomically $ store v . a . fromMaybe M.empty =<< tryTakeTMVar v   where- 	{- tryTakeTMVar empties the TMVar; refill it only if+	{- tryTakeTMVar empties the TMVar; refill it only if 	 - the modified map is not itself empty -} 	store v m 		| m == M.empty = noop
Assistant/Threads/Committer.hs view
@@ -31,6 +31,8 @@ import Types.KeySource import Config import Annex.Exception+import Annex.Content+import qualified Annex  import Data.Time.Clock import Data.Tuple.Utils@@ -41,8 +43,8 @@ commitThread :: NamedThread commitThread = NamedThread "Committer" $ do 	delayadd <- liftAnnex $-		maybe delayaddDefault (Just . Seconds) . readish-			<$> getConfig (annexConfig "delayadd") "" +		maybe delayaddDefault (return . Just . Seconds)+			=<< annexDelayAdd <$> Annex.getGitConfig 	runEvery (Seconds 1) <~> do 		-- We already waited one second as a simple rate limiter. 		-- Next, wait until at least one change is available for@@ -114,13 +116,17 @@ 	thisSecond c = now `diffUTCTime` changeTime c <= 1  {- OSX needs a short delay after a file is added before locking it down,- - as pasting a file seems to try to set file permissions or otherwise- - access the file after closing it. -}-delayaddDefault :: Maybe Seconds+ - when using a non-direct mode repository, as pasting a file seems to+ - try to set file permissions or otherwise access the file after closing+ - it. -}+delayaddDefault :: Annex (Maybe Seconds) #ifdef darwin_HOST_OS-delayaddDefault = Just $ Seconds 1+delayaddDefault = ifM isDirect+	( return Nothing+	, return $ Just $ Seconds 1+	) #else-delayaddDefault = Nothing+delayaddDefault = return Nothing #endif  {- If there are PendingAddChanges, or InProcessAddChanges, the files@@ -146,7 +152,10 @@ handleAdds :: Maybe Seconds -> [Change] -> Assistant [Change] handleAdds delayadd cs = returnWhen (null incomplete) $ do 	let (pending, inprocess) = partition isPendingAddChange incomplete-	pending' <- findnew pending+	direct <- liftAnnex isDirect+	pending' <- if direct+		then return pending+		else findnew pending 	(postponed, toadd) <- partitionEithers <$> safeToAdd delayadd pending' inprocess  	unless (null postponed) $@@ -154,7 +163,7 @@  	returnWhen (null toadd) $ do 		added <- catMaybes <$> forM toadd add-		if DirWatcher.eventsCoalesce || null added+		if DirWatcher.eventsCoalesce || null added || direct 			then return $ added ++ otherchanges 			else do 				r <- handleAdds delayadd =<< getChanges@@ -195,13 +204,15 @@ 		liftAnnex showEndFail 		return Nothing 	done change file (Just key) = do-		link <- liftAnnex $ Command.Add.link file key True-		when DirWatcher.eventsCoalesce $-			liftAnnex $ do-				sha <- inRepo $-					Git.HashObject.hashObject BlobObject link-				stageSymlink file sha-				showEndOk+		link <- liftAnnex $ ifM isDirect+			( calcGitLink file key+			, Command.Add.link file key True+			)+		liftAnnex $ whenM (pure DirWatcher.eventsCoalesce <||> isDirect) $ do+			sha <- inRepo $+				Git.HashObject.hashObject BlobObject link+			stageSymlink file sha+			showEndOk 		queueTransfers Next key (Just file) Upload 		return $ Just change
Assistant/Threads/Merger.hs view
@@ -14,8 +14,8 @@ import Utility.Types.DirWatcher import qualified Annex.Branch import qualified Git-import qualified Git.Merge import qualified Git.Branch+import qualified Command.Sync  thisThread :: ThreadName thisThread = "Merger"@@ -80,8 +80,7 @@ 				[ "merging", show changedbranch 				, "into", show current 				]-			void $ liftAnnex $ inRepo $-				Git.Merge.mergeNonInteractive changedbranch+			void $ liftAnnex  $ Command.Sync.mergeFrom changedbranch 	mergecurrent _ = noop  equivBranches :: Git.Ref -> Git.Ref -> Bool
Assistant/Threads/TransferWatcher.hs view
@@ -47,7 +47,7 @@  -} runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant () runHandler handler file _filestatus =-        either (liftIO . print) (const noop) =<< tryIO <~> handler file+	either (liftIO . print) (const noop) =<< tryIO <~> handler file  {- Called when there's an error with inotify. -} onErr :: Handler@@ -97,8 +97,8 @@ 		finished <- asIO2 finishedTransfer 		void $ liftIO $ forkIO $ do 			{- XXX race workaround delay. The location- 			 - log needs to be updated before finishedTransfer- 			 - runs. -}+			 - log needs to be updated before finishedTransfer+			 - runs. -} 			threadDelay 10000000 -- 10 seconds 			finished t minfo
Assistant/Threads/Watcher.hs view
@@ -24,22 +24,28 @@ import Logs.Transfer import Utility.DirWatcher import Utility.Types.DirWatcher+import Utility.Lsof import qualified Annex import qualified Annex.Queue-import qualified Git.Command+import qualified Git import qualified Git.UpdateIndex import qualified Git.HashObject+import qualified Git.LsFiles as LsFiles import qualified Backend import Annex.Content+import Annex.Direct+import Annex.Content.Direct import Annex.CatFile import Git.Types+import Config  import Data.Bits.Utils import qualified Data.ByteString.Lazy as L  checkCanWatch :: Annex () checkCanWatch-	| canWatch = +	| canWatch = do+		liftIO setupLsof 		unlessM (liftIO (inPath "lsof") <||> Annex.getState Annex.force) 			needLsof 	| otherwise = error "watch mode is not available on this system"@@ -55,7 +61,8 @@ watchThread :: NamedThread watchThread = NamedThread "Watcher" $ do 	startup <- asIO1 startupScan-	addhook <- hook onAdd+	direct <- liftAnnex isDirect+	addhook <- hook $ if direct then onAddDirect else onAdd 	delhook <- hook onDel 	addsymlinkhook <- hook onAddSymlink 	deldirhook <- hook onDelDir@@ -81,10 +88,16 @@  		-- Notice any files that were deleted before 		-- watching was started.-		liftAnnex $ do-			inRepo $ Git.Command.run "add" [Param "--update"]-			showAction "started"+		top <- liftAnnex $ fromRepo Git.repoPath+		(fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted [top]+		forM_ fs $ \f -> do+			liftAnnex $ Annex.Queue.addUpdateIndex =<<+				inRepo (Git.UpdateIndex.unstageFile f)+			maybe noop recordChange =<< madeChange f RmChange+		void $ liftIO $ cleanup 		+		liftAnnex $ showAction "started"+		 		modifyDaemonStatus_ $ \s -> s { scanComplete = True }  		return (True, r)@@ -120,6 +133,22 @@ 	| maybe False isRegularFile filestatus = pendingAddChange file 	| otherwise = noChange +{- In direct mode, add events are received for both new files, and+ - modified existing files. Or, in some cases, existing files that have not+ - really been modified. -}+onAddDirect :: Handler+onAddDirect file fs = do+	v <- liftAnnex $ catKey (Ref $ ':':file)+	case (v, fs) of+		(Just key, Just filestatus) ->+			ifM (liftAnnex $ changedFileStatus key filestatus)+				( do+					liftAnnex $ changedDirect key file+					pendingAddChange file+				, noChange+				)+		_ -> pendingAddChange file+ {- A symlink might be an arbitrary symlink, which is just added.  - Or, if it is a git-annex symlink, ensure it points to the content  - before adding it.@@ -221,7 +250,8 @@  {- Adds a symlink to the index, without ever accessing the actual symlink  - on disk. This avoids a race if git add is used, where the symlink is- - changed to something else immediately after creation.+ - changed to something else immediately after creation. It also allows+ - direct mode to work.  -} stageSymlink :: FilePath -> Sha -> Annex () stageSymlink file sha =
Assistant/Threads/XMPPClient.hs view
@@ -55,7 +55,7 @@ 	inAssistant = liftIO . liftAssistant  	{- When the client exits, it's restarted;- 	 - if it keeps failing, back off to wait 5 minutes before+	 - if it keeps failing, back off to wait 5 minutes before 	 - trying it again. -} 	retry client starttime = do 		e <- client
Assistant/WebApp/Configurators.hs view
@@ -19,7 +19,6 @@ import Annex.UUID (getUUID) import Logs.Remote import Logs.Trust-import Config import qualified Git #ifdef WITH_XMPP import Assistant.XMPP.Client@@ -28,10 +27,10 @@ import qualified Data.Map as M  {- The main configuration screen. -}-getConfigR :: Handler RepHtml-getConfigR = ifM (inFirstRun)+getConfigurationR :: Handler RepHtml+getConfigurationR = ifM (inFirstRun) 	( getFirstRepositoryR-	, page "Configuration" (Just Config) $ do+	, page "Configuration" (Just Configuration) $ do #ifdef WITH_XMPP 		xmppconfigured <- lift $ runAnnex False $ isJust <$> getXMPPCreds #else@@ -62,7 +61,7 @@  {- Lists known repositories, followed by options to add more. -} getRepositoriesR :: Handler RepHtml-getRepositoriesR = page "Repositories" (Just Config) $ do+getRepositoriesR = page "Repositories" (Just Configuration) $ do 	let repolist = repoListDisplay $ RepoSelector 		{ onlyCloud = False 		, onlyConfigured = False@@ -146,9 +145,9 @@ 		unconfigured <- map snd . catMaybes . filter wantedremote  			. map (findinfo m) 			<$> (trustExclude DeadTrusted $ M.keys m)-		unsyncable <- map Remote.uuid . filter wantedrepo <$>-			(filterM (\r -> not <$> repoSyncable (Remote.repo r))-				=<< Remote.enabledRemoteList)+		unsyncable <- map Remote.uuid . filter wantedrepo .+			filter (not . remoteAnnexSync . Remote.gitconfig)+			<$> Remote.enabledRemoteList 		return $ zip unsyncable (map mkNotSyncingRepoActions unsyncable) ++ unconfigured 	wantedrepo r 		| Remote.readonly r = False@@ -189,6 +188,6 @@  flipSync :: Bool -> UUID -> Handler () flipSync enable uuid = do-	mremote <- runAnnex undefined $ snd <$> Remote.repoFromUUID uuid+	mremote <- runAnnex undefined $ Remote.remoteFromUUID uuid 	changeSyncable mremote enable 	redirect RepositoriesR
Assistant/WebApp/Configurators/AWS.hs view
@@ -27,7 +27,7 @@ import qualified Data.Map as M  awsConfigurator :: Widget -> Handler RepHtml-awsConfigurator = page "Add an Amazon repository" (Just Config)+awsConfigurator = page "Add an Amazon repository" (Just Configuration)  glacierConfigurator :: Widget -> Handler RepHtml glacierConfigurator a = do
Assistant/WebApp/Configurators/Edit.hs view
@@ -15,12 +15,12 @@ import Assistant.MakeRemote (uniqueRemoteName) import Assistant.WebApp.Configurators.XMPP (xmppNeeded) import qualified Remote+import qualified Types.Remote as Remote import qualified Remote.List as Remote import Logs.UUID import Logs.Group import Logs.PreferredContent import Types.StandardGroups-import qualified Config import qualified Git import qualified Git.Command import qualified Git.Config@@ -40,12 +40,12 @@ 	} 	deriving (Show) -getRepoConfig :: UUID -> Git.Repo -> Maybe Remote -> Annex RepoConfig-getRepoConfig uuid r mremote = RepoConfig+getRepoConfig :: UUID -> Maybe Remote -> Annex RepoConfig+getRepoConfig uuid mremote = RepoConfig 	<$> pure (T.pack $ maybe "here" Remote.name mremote) 	<*> (maybe Nothing (Just . T.pack) . M.lookup uuid <$> uuidMap) 	<*> getrepogroup-	<*> Config.repoSyncable r+	<*> pure (maybe True (remoteAnnexSync . Remote.gitconfig) mremote)   where 	getrepogroup = do 		groups <- lookupGroups uuid@@ -112,9 +112,9 @@ getEditNewCloudRepositoryR uuid = xmppNeeded >> editForm True uuid  editForm :: Bool -> UUID -> Handler RepHtml-editForm new uuid = page "Configure repository" (Just Config) $ do-	(repo, mremote) <- lift $ runAnnex undefined $ Remote.repoFromUUID uuid-	curr <- lift $ runAnnex undefined $ getRepoConfig uuid repo mremote+editForm new uuid = page "Configure repository" (Just Configuration) $ do+	mremote <- lift $ runAnnex undefined $ Remote.remoteFromUUID uuid+	curr <- lift $ runAnnex undefined $ getRepoConfig uuid mremote 	lift $ checkarchivedirectory curr 	((result, form), enctype) <- lift $ 		runFormGet $ renderBootstrap $ editRepositoryAForm curr
Assistant/WebApp/Configurators/Local.hs view
@@ -29,6 +29,7 @@ import Types.StandardGroups import Logs.PreferredContent import Utility.UserInfo+import Config  import qualified Data.Text as T import Data.Char@@ -127,7 +128,7 @@  {- Making the first repository, when starting the webapp for the first time. -} getFirstRepositoryR :: Handler RepHtml-getFirstRepositoryR = page "Getting started" (Just Config) $ do+getFirstRepositoryR = page "Getting started" (Just Configuration) $ do 	path <- liftIO . defaultRepositoryPath =<< lift inFirstRun 	((res, form), enctype) <- lift $ runFormGet $ newRepositoryForm path 	case res of@@ -137,14 +138,14 @@  {- Adding a new, separate repository. -} getNewRepositoryR :: Handler RepHtml-getNewRepositoryR = page "Add another repository" (Just Config) $ do+getNewRepositoryR = page "Add another repository" (Just Configuration) $ do 	home <- liftIO myHomeDir 	((res, form), enctype) <- lift $ runFormGet $ newRepositoryForm home 	case res of 		FormSuccess (RepositoryPath p) -> lift $ do 			let path = T.unpack p 			liftIO $ makeRepo path False-			u <- liftIO $ initRepo path Nothing+			u <- liftIO $ initRepo True path Nothing 			runAnnex () $ setStandardGroup u ClientGroup 			liftIO $ addAutoStart path 			redirect $ SwitchToRepositoryR path@@ -174,7 +175,7 @@  {- Adding a removable drive. -} getAddDriveR :: Handler RepHtml-getAddDriveR = page "AAdd a removable drive" (Just Config) $ do+getAddDriveR = page "Add a removable drive" (Just Configuration) $ do 	removabledrives <- liftIO $ driveList 	writabledrives <- liftIO $ 		filterM (canWrite . T.unpack . mountPoint) removabledrives@@ -187,7 +188,7 @@   where 	make mountpoint = do 		liftIO $ makerepo dir-		u <- liftIO $ initRepo dir $ Just remotename+		u <- liftIO $ initRepo False dir $ Just remotename 		r <- addremote dir remotename 		runAnnex () $ setStandardGroup u TransferGroup 		syncRemote r@@ -212,7 +213,7 @@ 		addRemote $ makeGitRemote name dir  getEnableDirectoryR :: UUID -> Handler RepHtml-getEnableDirectoryR uuid = page "Enable a repository" (Just Config) $ do+getEnableDirectoryR uuid = page "Enable a repository" (Just Configuration) $ do 	description <- lift $ runAnnex "" $ 		T.pack . concat <$> prettyListUUIDs [uuid] 	$(widgetFile "configurators/enabledirectory")@@ -246,7 +247,7 @@ 	webapp <- getYesod 	url <- liftIO $ do 		makeRepo path False-		u <- initRepo path Nothing+		u <- initRepo True path Nothing 		inDir path $  			setStandardGroup u ClientGroup 		addAutoStart path@@ -271,8 +272,8 @@ 	state <- Annex.new =<< Git.Config.read =<< Git.Construct.fromPath dir 	Annex.eval state a -initRepo :: FilePath -> Maybe String -> IO UUID-initRepo dir desc = inDir dir $ do+initRepo :: Bool -> FilePath -> Maybe String -> IO UUID+initRepo primary_assistant_repo dir desc = inDir dir $ do 	{- Initialize a git-annex repository in a directory with a description. -} 	unlessM isInitialized $ 		initialize desc@@ -285,6 +286,8 @@ 			, Param "-m" 			, Param "created repository" 			]+	when primary_assistant_repo $+		setDirect True 	getUUID  {- Adds a directory to the autostart file. -}
Assistant/WebApp/Configurators/Pairing.hs view
@@ -233,8 +233,8 @@ 	((result, form), enctype) <- lift $ 		runFormGet $ renderBootstrap $ 			InputSecret <$> aopt textField "Secret phrase" Nothing-        case result of-                FormSuccess v -> do+	case result of+		FormSuccess v -> do 			let rawsecret = fromMaybe "" $ secretText v 			let secret = toSecret rawsecret 			case msg of@@ -247,7 +247,7 @@ 						then cont rawsecret secret 						else showform form enctype $ Just 							"That's not the right secret phrase."-                _ -> showform form enctype Nothing+		_ -> showform form enctype Nothing   where 	showform form enctype mproblem = do 		let start = isNothing msg@@ -286,7 +286,7 @@ #endif  pairPage :: Widget -> Handler RepHtml-pairPage = page "Pairing" (Just Config)+pairPage = page "Pairing" (Just Configuration)  noPairing :: Text -> Handler RepHtml noPairing pairingtype = pairPage $
Assistant/WebApp/Configurators/Ssh.hs view
@@ -24,7 +24,7 @@ import Network.Socket  sshConfigurator :: Widget -> Handler RepHtml-sshConfigurator = page "Add a remote server" (Just Config)+sshConfigurator = page "Add a remote server" (Just Configuration)  data SshInput = SshInput 	{ inputHostname :: Maybe Text@@ -288,7 +288,7 @@ 	((result, form), enctype) <- runFormGet $ 		renderBootstrap $ sshInputAForm hostnamefield $ 			SshInput Nothing Nothing Nothing 22-	let showform status = page "Add a Rsync.net repository" (Just Config) $+	let showform status = page "Add a Rsync.net repository" (Just Configuration) $ 		$(widgetFile "configurators/addrsync.net") 	case result of 		FormSuccess sshinput
Assistant/WebApp/Configurators/WebDAV.hs view
@@ -26,10 +26,10 @@ import qualified Data.Map as M  webDAVConfigurator :: Widget -> Handler RepHtml-webDAVConfigurator = page "Add a WebDAV repository" (Just Config)+webDAVConfigurator = page "Add a WebDAV repository" (Just Configuration)  boxConfigurator :: Widget -> Handler RepHtml-boxConfigurator = page "Add a Box.com repository" (Just Config)+boxConfigurator = page "Add a Box.com repository" (Just Configuration)  data WebDAVInput = WebDAVInput 	{ user :: Text
Assistant/WebApp/Configurators/XMPP.hs view
@@ -48,7 +48,7 @@  getXMPPR :: Handler RepHtml #ifdef WITH_XMPP-getXMPPR = getXMPPR' ConfigR+getXMPPR = getXMPPR' ConfigurationR #else getXMPPR = xmppPage $ 	$(widgetFile "configurators/xmpp/disabled")@@ -155,4 +155,4 @@ #endif  xmppPage :: Widget -> Handler RepHtml-xmppPage = page "Jabber" (Just Config)+xmppPage = page "Jabber" (Just Configuration)
Assistant/WebApp/DashBoard.hs view
@@ -79,7 +79,7 @@  getHomeR :: Handler RepHtml getHomeR = ifM (inFirstRun)-	( redirect ConfigR+	( redirect ConfigurationR 	, page "" (Just DashBoard) $ dashboard True 	)
Assistant/WebApp/Page.hs view
@@ -19,24 +19,24 @@ import Text.Hamlet import Data.Text (Text) -data NavBarItem = DashBoard | Config | About+data NavBarItem = DashBoard | Configuration | About 	deriving (Eq)  navBarName :: NavBarItem -> Text navBarName DashBoard = "Dashboard"-navBarName Config = "Configuration"+navBarName Configuration = "Configuration" navBarName About = "About"  navBarRoute :: NavBarItem -> Route WebApp navBarRoute DashBoard = HomeR-navBarRoute Config = ConfigR+navBarRoute Configuration = ConfigurationR navBarRoute About = AboutR  defaultNavBar :: [NavBarItem]-defaultNavBar = [DashBoard, Config, About]+defaultNavBar = [DashBoard, Configuration, About]  firstRunNavBar :: [NavBarItem]-firstRunNavBar = [Config, About]+firstRunNavBar = [Configuration, About]  selectNavBar :: Handler [NavBarItem] selectNavBar = ifM (inFirstRun) (return firstRunNavBar, return defaultNavBar)
Assistant/WebApp/Types.hs view
@@ -46,7 +46,7 @@ 	isAuthorized _ _ = checkAuthToken secretToken  	{- Add the auth token to every url generated, except static subsite-         - urls (which can show up in Permission Denied pages). -}+	 - urls (which can show up in Permission Denied pages). -} 	joinPath = insertAuthToken secretToken excludeStatic 	  where 		excludeStatic [] = True@@ -90,45 +90,45 @@ 	deriving (Read, Show, Eq)  instance PathPiece SshData where-    toPathPiece = pack . show-    fromPathPiece = readish . unpack+	toPathPiece = pack . show+	fromPathPiece = readish . unpack  instance PathPiece NotificationId where-    toPathPiece = pack . show-    fromPathPiece = readish . unpack+	toPathPiece = pack . show+	fromPathPiece = readish . unpack  instance PathPiece AlertId where-    toPathPiece = pack . show-    fromPathPiece = readish . unpack+	toPathPiece = pack . show+	fromPathPiece = readish . unpack  instance PathPiece Transfer where-    toPathPiece = pack . show-    fromPathPiece = readish . unpack+	toPathPiece = pack . show+	fromPathPiece = readish . unpack  instance PathPiece PairMsg where-    toPathPiece = pack . show-    fromPathPiece = readish . unpack+	toPathPiece = pack . show+	fromPathPiece = readish . unpack  instance PathPiece SecretReminder where-    toPathPiece = pack . show-    fromPathPiece = readish . unpack+	toPathPiece = pack . show+	fromPathPiece = readish . unpack  instance PathPiece UUID where-    toPathPiece = pack . show-    fromPathPiece = readish . unpack+	toPathPiece = pack . show+	fromPathPiece = readish . unpack  instance PathPiece BuddyKey where-    toPathPiece = pack . show-    fromPathPiece = readish . unpack+	toPathPiece = pack . show+	fromPathPiece = readish . unpack  instance PathPiece PairKey where-    toPathPiece = pack . show-    fromPathPiece = readish . unpack+	toPathPiece = pack . show+	fromPathPiece = readish . unpack  instance PathPiece RepoListNotificationId where-    toPathPiece = pack . show-    fromPathPiece = readish . unpack+	toPathPiece = pack . show+	fromPathPiece = readish . unpack  instance PathPiece RepoSelector where-    toPathPiece = pack . show-    fromPathPiece = readish . unpack+	toPathPiece = pack . show+	fromPathPiece = readish . unpack
Assistant/WebApp/routes view
@@ -5,7 +5,7 @@ /about/license LicenseR GET /about/repogroups RepoGroupR GET -/config ConfigR GET+/config ConfigurationR GET /config/repository RepositoriesR GET /config/xmpp XMPPR GET /config/xmpp/for/pairing XMPPForPairingR GET
Backend.hs view
@@ -18,7 +18,6 @@ import System.Posix.Files  import Common.Annex-import Config import qualified Annex import Annex.CheckAttr import Types.Key@@ -39,21 +38,21 @@ 	l <- Annex.getState Annex.backends -- list is cached here 	if not $ null l 		then return l-		else handle =<< Annex.getState Annex.forcebackend+		else do+			f <- Annex.getState Annex.forcebackend+			case f of+				Just name | not (null name) ->+					return [lookupBackendName name]+				_ -> do+					l' <- gen . annexBackends <$> Annex.getGitConfig+					Annex.changeState $ \s -> s { Annex.backends = l' }+					return l'   where-	handle Nothing = standard-	handle (Just "") = standard-	handle (Just name) = do-		l' <- (lookupBackendName name :) <$> standard-		Annex.changeState $ \s -> s { Annex.backends = l' }-		return l'-	standard = parseBackendList <$> getConfig (annexConfig "backends") ""-	parseBackendList [] = list-	parseBackendList s = map lookupBackendName $ words s+	gen [] = list+	gen l = map lookupBackendName l  {- Generates a key for a file, trying each backend in turn until one- - accepts it.- -}+ - accepts it. -} genKey :: KeySource -> Maybe Backend -> Annex (Maybe (Key, Backend)) genKey source trybackend = do 	bs <- orderedList@@ -94,8 +93,7 @@ 				return Nothing  {- Looks up the backend that should be used for a file.- - That can be configured on a per-file basis in the gitattributes file.- -}+ - That can be configured on a per-file basis in the gitattributes file. -} chooseBackend :: FilePath -> Annex (Maybe Backend) chooseBackend f = Annex.getState Annex.forcebackend >>= go   where
Backend/SHA.hs view
@@ -17,6 +17,7 @@ import Data.Digest.Pure.SHA import qualified Data.ByteString.Lazy as L import System.Process+import Data.Char  type SHASize = Int @@ -34,6 +35,7 @@ 	{ name = shaName size 	, getKey = keyValue size 	, fsckKey = Just $ checkKeyChecksum size+	, canUpgradeKey = Just $ needsUpgrade 	}  genBackendE :: SHASize -> Maybe Backend@@ -61,6 +63,8 @@ 	parse command [] = bad command 	parse command (l:_) 		| null sha = bad command+		-- sha is prefixed with \ when filename contains certian chars+		| "\\" `isPrefixOf` sha = drop 1 sha 		| otherwise = sha 	  where 		sha = fst $ separate (== ' ') l@@ -121,10 +125,8 @@   where 	es = filter (not . null) $ reverse $ 		take 2 $ takeWhile shortenough $-		reverse $ split "." $ takeExtensions f-	shortenough e-		| '\n' `elem` e = False -- newline in extension?!-		| otherwise = length e <= 4 -- long enough for "jpeg"+		reverse $ split "." $ filter validExtension $ takeExtensions f+	shortenough e = length e <= 4 -- long enough for "jpeg"  {- A key's checksum is checked during fsck. -} checkKeyChecksum :: SHASize -> Key -> FilePath -> Annex Bool@@ -137,6 +139,26 @@ 			check <$> shaN size file filesize 		_ -> return True   where+	sha = keySha key 	check s-		| s == dropExtensions (keyName key) = True+		| s == sha = True+		{- A bug caused checksums to be prefixed with \ in some+		 - cases; still accept these as legal now that the bug has been+		 - fixed. -}+		| '\\' : s == sha = True 		| otherwise = False++keySha :: Key -> String+keySha key = dropExtensions (keyName key)++validExtension :: Char -> Bool+validExtension c+	| isAlphaNum c = True+	| 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. -}+needsUpgrade :: Key -> Bool+needsUpgrade key = "\\" `isPrefixOf` keySha key ||+	any (not . validExtension) (takeExtensions $ keyName key)
Backend/URL.hs view
@@ -24,6 +24,7 @@ 	{ name = "URL" 	, getKey = const $ return Nothing 	, fsckKey = Nothing+	, canUpgradeKey = Nothing 	}  fromUrl :: String -> Maybe Integer -> Key
Backend/WORM.hs view
@@ -20,6 +20,7 @@ 	{ name = "WORM" 	, getKey = keyValue 	, fsckKey = Nothing+	, canUpgradeKey = Nothing 	}  {- The key includes the file size, modification time, and the
Build/Configure.hs view
@@ -26,7 +26,7 @@ 	, TestCase "wget" $ testCmd "wget" "wget --version >/dev/null" 	, TestCase "bup" $ testCmd "bup" "bup --version >/dev/null" 	, TestCase "gpg" $ testCmd "gpg" "gpg --version >/dev/null"-	, TestCase "lsof" $ testCmd "lsof" "lsof -v >/dev/null 2>&1"+	, TestCase "lsof" $ findCmdPath "lsof" "lsof" 	, TestCase "ssh connection caching" getSshConnectionCaching 	] ++ shaTestCases 	[ (1, "da39a3ee5e6b4b0d3255bfef95601890afd80709")@@ -50,7 +50,7 @@ 		zip (shacmds n) (repeat check) 	  where 		key = "sha" ++ show n-		check = "</dev/null | grep -q '" ++ knowngood ++ "'"+		check = "</dev/null 2>/dev/null | grep -q '" ++ knowngood ++ "'" 	shacmds n = concatMap (\x -> [x, 'g':x, osxpath </> x]) $ 		map (\x -> "sha" ++ show n ++ x) ["sum", ""] 	{- Max OSX sometimes puts GNU tools outside PATH, so look in
Build/OSXMkLibs.hs view
@@ -62,11 +62,13 @@ 	files <- filterM doesFileExist =<< dirContentsRecursive appbase 	process [] files libmap   where-	unprocessed s = not ("@executable_path" `isInfixOf` s)+	want s = not ("@executable_path" `isInfixOf` s)+		&& not (".framework" `isInfixOf` s)+		&& not ("libSystem.B" `isInfixOf` s) 	process c [] m = return (nub $ concat c, m) 	process c (file:rest) m = do 		_ <- boolSystem "chmod" [Param "755", File file]-		libs <- filter unprocessed . parseOtool+		libs <- filter want . parseOtool 			<$> readProcess "otool" ["-L", file] 		m' <- install_name_tool file libs m 		process (libs:c) rest m'
+ Build/Standalone.hs view
@@ -0,0 +1,78 @@+{- Makes standalone bundle.+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Build.Standalone where++import Control.Applicative+import Control.Monad.IfElse+import System.Environment+import Data.Maybe+import System.FilePath+import System.Directory+import System.IO+import Control.Monad+import Data.List+import Build.SysConfig as SysConfig++import Utility.PartialPrelude+import Utility.Directory+import Utility.Process+import Utility.Monad+import Utility.SafeCommand+import Utility.Path++{- Programs that git-annex uses, to include in the bundle.+ -+ - These may be just the command name, or the full path to it. -}+thirdpartyProgs :: [FilePath]+thirdpartyProgs = catMaybes+	[ Just "git"+	, Just "cp"+	, Just "xargs"+	, Just "gpg"+	, Just "rsync"+	, Just "ssh"+	, Just "sh"+	, headMaybe $ words SysConfig.uuid -- may include parameters+	, ifset SysConfig.curl "curl"+	, ifset SysConfig.wget "wget"+	, ifset SysConfig.bup "bup"+	, SysConfig.lsof+	, SysConfig.sha1+	, SysConfig.sha256+	, SysConfig.sha512+	, SysConfig.sha224+	, SysConfig.sha384+	]+  where+	ifset True s = Just s+	ifset False _ = Nothing++progDir :: FilePath -> FilePath+#ifdef darwin_HOST_OS+progDir topdir = topdir+#else+progDir topdir = topdir </> "bin"+#endif++installProg :: FilePath -> FilePath -> IO ()+installProg dir prog = searchPath prog >>= go+  where+	go Nothing = error $ "cannot find " ++ prog ++ " in PATH"+	go (Just f) = unlessM (boolSystem "install" [File f, File dir]) $+		error $ "install failed for " ++ prog++main = getArgs >>= go+  where+	go [] = error "specify topdir"+        go (topdir:_) = do+		let dir = progDir topdir+		createDirectoryIfMissing True dir+		forM_ thirdpartyProgs $ installProg dir+
Build/TestConfig.hs view
@@ -2,9 +2,14 @@  module Build.TestConfig where +import Utility.Path+import Utility.Monad+ import System.IO import System.Cmd import System.Exit+import System.FilePath+import System.Directory  type ConfigKey = String data ConfigValue =@@ -97,6 +102,23 @@ 		if ret == ExitSuccess 			then success c 			else search cs++{- Finds a command, either in PATH or perhaps in a sbin directory not in+ - PATH. If it's in PATH the config is set to just the command name,+ - but if it's found outside PATH, the config is set to the full path to+ - the command. -}+findCmdPath :: ConfigKey -> String -> Test+findCmdPath k command = do+	ifM (inPath command)+		( return $ Config k $ MaybeStringConfig $ Just command+		, do+			r <- getM find ["/usr/sbin", "/sbin", "/usr/local/sbin"]+			return $ Config k $ MaybeStringConfig r+		)+  where+	find d =+		let f = d </> command+		in ifM (doesFileExist f) ( return (Just f), return Nothing )  quiet :: String -> String quiet s = s ++ " >/dev/null 2>&1"
CHANGELOG view
@@ -1,3 +1,31 @@+git-annex (3.20130102) unstable; urgency=low++  * direct, indirect: New commands, that switch a repository to and from+    direct mode. In direct mode, files are accessed directly, rather than+    via symlinks. Note that direct mode is currently experimental. Many+    git-annex commands do not work in direct mode. Some git commands can+    cause data loss when used in direct mode repositories.+  * assistant: Now uses direct mode by default when setting up a new+    local repository.+  * OSX assistant: Uses the FSEvents API to detect file changes.+    This avoids issues with running out of file descriptors on large trees,+    as well as allowing detection of modification of files in direct mode.+    Other BSD systems still use kqueue.+  * kqueue: Fix bug that made broken symlinks not be noticed.+  * vicfg: Quote filename. Closes: #696193+  * Bugfix: Fixed bug parsing transfer info files, where the newline after+    the filename was included in it. This was generally benign, but in+    the assistant, it caused unexpected dropping of preferred content.+  * Bugfix: Remove leading \ from checksums output by sha*sum commands,+    when the filename contains \ or a newline. Closes: #696384+  * fsck: Still accept checksums with a leading \ as valid, now that+    above bug is fixed.+  * SHA*E backends: Exclude non-alphanumeric characters from extensions.+  * migrate: Remove leading \ in SHA* checksums, and non-alphanumerics+    from extensions of SHA*E keys.++ -- Joey Hess <joeyh@debian.org>  Wed, 02 Jan 2013 13:21:34 -0400+ git-annex (3.20121211) unstable; urgency=low    * webapp: Defaults to sharing box.com account info with friends, allowing
Checks.hs view
@@ -13,6 +13,8 @@ import Common.Annex import Types.Command import Init+import Config+import qualified Git  commonChecks :: [CommandCheck] commonChecks = [repoExists]@@ -20,6 +22,14 @@ repoExists :: CommandCheck repoExists = CommandCheck 0 ensureInitialized +notDirect :: Command -> Command+notDirect = addCheck $ whenM isDirect $+	error "You cannot run this subcommand in a direct mode repository."++notBareRepo :: Command -> Command+notBareRepo = addCheck $ whenM (fromRepo Git.repoIsLocalBare) $+	error "You cannot run this subcommand in a bare repository."+ dontCheck :: CommandCheck -> Command -> Command dontCheck check cmd = mutateCheck cmd $ \c -> filter (/= check) c @@ -29,3 +39,4 @@  mutateCheck :: Command -> ([CommandCheck] -> [CommandCheck]) -> Command mutateCheck cmd@(Command { cmdcheck = c }) a = cmd { cmdcheck = a c }+
Command.hs view
@@ -17,7 +17,6 @@ 	doCommand, 	whenAnnexed, 	ifAnnexed,-	notBareRepo, 	isBareRepo, 	numCopies, 	numCopiesCheck,@@ -96,12 +95,6 @@  ifAnnexed :: FilePath -> ((Key, Backend) -> Annex a) -> Annex a -> Annex a ifAnnexed file yes no = maybe no yes =<< Backend.lookupFile file--notBareRepo :: Annex a -> Annex a-notBareRepo a = do-	whenM isBareRepo $-		error "You cannot run this subcommand in a bare repository."-	a  isBareRepo :: Annex Bool isBareRepo = fromRepo Git.repoIsLocalBare
Command/Add.hs view
@@ -16,22 +16,25 @@ import Backend import Logs.Location import Annex.Content+import Annex.Content.Direct import Annex.Perms import Utility.Touch import Utility.FileMode+import Config  def :: [Command]-def = [command "add" paramPaths seek "add files to annex"]+def = [notDirect $ notBareRepo $+	command "add" paramPaths seek "add files to annex"]  {- Add acts on both files not checked into git yet, and unlocked files. -} seek :: [CommandSeek] seek = [withFilesNotInGit start, withFilesUnlocked start] -{- The add subcommand annexes a file, storing it in a backend, and then- - moving it into the annex directory and setting up the symlink pointing- - to its content. -}+{- The add subcommand annexes a file, generating a key for it using a+ - backend, and then moving it into the annex directory and setting up+ - the symlink pointing to its content. -} start :: FilePath -> CommandStart-start file = notBareRepo $ ifAnnexed file fixup add+start file = ifAnnexed file fixup add   where 	add = do 		s <- liftIO $ getSymbolicLinkStatus file@@ -62,20 +65,44 @@ 		createLink file tmpfile 		return $ KeySource { keyFilename = file , contentLocation = tmpfile } -{- Moves a locked down file into the annex. -}+{- Moves a locked down file into the annex.+ -+ - In direct mode, leaves the file alone, and just updates bookeeping+ - information.+ -} ingest :: KeySource -> Annex (Maybe Key) ingest source = do 	backend <- chooseBackend $ keyFilename source-	genKey source backend >>= go+	ifM isDirect+		( do+			mstat <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus $ keyFilename source+			k <- genKey source backend+			godirect k (toCache =<< mstat)+		, go =<< genKey source backend+		)   where-	go Nothing = do-		liftIO $ nukeFile $ contentLocation source-		return Nothing 	go (Just (key, _)) = do 		handle (undo (keyFilename source) key) $ 			moveAnnex key $ contentLocation source 		liftIO $ nukeFile $ keyFilename source 		return $ Just key+	go Nothing = failure++	godirect (Just (key, _)) (Just cache) =+		ifM (compareCache (keyFilename source) $ Just cache)+			( do+				writeCache key cache+				void $ addAssociatedFile key $ keyFilename source+				liftIO $ allowWrite $ keyFilename source+				liftIO $ nukeFile $ contentLocation source+				return $ Just key+			, failure+			)+	godirect _ _ = failure++	failure = do+		liftIO $ nukeFile $ contentLocation source+		return Nothing		  perform :: FilePath -> CommandPerform perform file =
Command/AddUnused.hs view
@@ -14,14 +14,16 @@ import Types.Key  def :: [Command]-def = [command "addunused" (paramRepeating paramNumRange)+def = [notDirect $ command "addunused" (paramRepeating paramNumRange) 	seek "add back unused files"]  seek :: [CommandSeek] seek = [withUnusedMaps start]  start :: UnusedMaps -> Int -> CommandStart-start = startUnused "addunused" perform (performOther "bad") (performOther "tmp")+start = startUnused "addunused" perform+	(performOther "bad")+	(performOther "tmp")  perform :: Key -> CommandPerform perform key = next $ Command.Add.cleanup file key True
Command/AddUrl.hs view
@@ -24,7 +24,7 @@ import Config  def :: [Command]-def = [withOptions [fileOption, pathdepthOption] $+def = [notDirect $ notBareRepo $ withOptions [fileOption, pathdepthOption] $ 	command "addurl" (paramRepeating paramUrl) seek "add urls to annex"]  fileOption :: Option@@ -39,7 +39,7 @@ 	withStrings $ start f d]  start :: Maybe FilePath -> Maybe Int -> String -> CommandStart-start optfile pathdepth s = notBareRepo $ go $ fromMaybe bad $ parseURI s+start optfile pathdepth s = go $ fromMaybe bad $ parseURI s   where 	bad = fromMaybe (error $ "bad url " ++ s) $ 		parseURI $ escapeURIString isUnescapedInURI s
Command/Copy.hs view
@@ -14,8 +14,9 @@ import Annex.Wanted  def :: [Command]-def = [withOptions Command.Move.options $ command "copy" paramPaths seek-	"copy content of files to/from another repository"]+def = [notDirect $ +	withOptions Command.Move.options $ command "copy" paramPaths seek+		"copy content of files to/from another repository"]  seek :: [CommandSeek] seek = [withField Command.Move.toOption Remote.byName $ \to ->
+ Command/Direct.hs view
@@ -0,0 +1,56 @@+{- git-annex command+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Command.Direct where++import Common.Annex+import Command+import qualified Git+import qualified Git.Command+import qualified Git.LsFiles+import Config+import Annex.Direct++def :: [Command]+def = [notBareRepo $ +	command "direct" paramNothing seek "switch repository to direct mode"]++seek :: [CommandSeek]+seek = [withNothing start]++start :: CommandStart+start = ifM isDirect ( stop , next perform )++perform :: CommandPerform+perform = do+	showStart "commit" ""+	showOutput+	_ <- inRepo $ Git.Command.runBool "commit"+		[Param "-a", Param "-m", Param "commit before switching to direct mode"]+	showEndOk++	top <- fromRepo Git.repoPath+	(l, clean) <- inRepo $ Git.LsFiles.inRepo [top]+	forM_ l go+	void $ liftIO clean+	next cleanup+  where+	go = whenAnnexed $ \f (k, _) -> do+		r <- toDirectGen k f+		case r of+			Nothing -> noop+			Just a -> do+				showStart "direct" f+				a+				showEndOk+		return Nothing++cleanup :: CommandCleanup+cleanup = do+	showStart "direct" ""+	setDirect True+	return True
Command/Drop.hs view
@@ -20,7 +20,7 @@ import Annex.Wanted  def :: [Command]-def = [withOptions [fromOption] $ command "drop" paramPaths seek+def = [notDirect $ withOptions [fromOption] $ command "drop" paramPaths seek 	"indicate content of files not currently wanted"]  fromOption :: Option@@ -79,7 +79,7 @@ 	stopUnless (canDropKey key numcopies have tocheck [uuid]) $ do 		ok <- Remote.removeKey remote key 		next $ cleanupRemote key remote ok- where+  where 	uuid = Remote.uuid remote  cleanupLocal :: Key -> CommandCleanup
Command/Find.hs view
@@ -20,7 +20,7 @@ import qualified Option  def :: [Command]-def = [noCommit $ withOptions [formatOption, print0Option] $+def = [notDirect $ noCommit $ withOptions [formatOption, print0Option] $ 	command "find" paramPaths seek "lists available files"]  formatOption :: Option
Command/Fix.hs view
@@ -13,7 +13,7 @@ import Annex.Content  def :: [Command]-def = [noCommit $ command "fix" paramPaths seek+def = [notDirect $ noCommit $ command "fix" paramPaths seek 	"fix up symlinks to point to annexed content"]  seek :: [CommandSeek]
Command/FromKey.hs view
@@ -14,14 +14,15 @@ import Types.Key  def :: [Command]-def = [command "fromkey" (paramPair paramKey paramPath) seek-	"adds a file using a specific key"]+def = [notDirect $ notBareRepo $+	command "fromkey" (paramPair paramKey paramPath) seek+		"adds a file using a specific key"]  seek :: [CommandSeek] seek = [withWords start]  start :: [String] -> CommandStart-start (keyname:file:[]) = notBareRepo $ do+start (keyname:file:[]) = do 	let key = fromMaybe (error "bad key") $ file2key keyname 	inbackend <- inAnnex key 	unless inbackend $ error $
Command/Fsck.hs view
@@ -34,7 +34,7 @@ import System.Locale  def :: [Command]-def = [withOptions options $ command "fsck" paramPaths seek+def = [notDirect $ withOptions options $ command "fsck" paramPaths seek 	"check for problems"]  fromOption :: Option@@ -206,7 +206,7 @@ 	return True  {- Checks that the location log reflects the current status of the key,-   in this repository only. -}+ - in this repository only. -} verifyLocationLog :: Key -> String -> Annex Bool verifyLocationLog key desc = do 	present <- inAnnex key
Command/Import.hs view
@@ -13,13 +13,14 @@ import qualified Command.Add  def :: [Command]-def = [command "import" paramPaths seek "move and add files from outside git working copy"]+def = [notDirect $ notBareRepo $ command "import" paramPaths seek+	"move and add files from outside git working copy"]  seek :: [CommandSeek] seek = [withPathContents start]  start :: (FilePath, FilePath) -> CommandStart-start (srcfile, destfile) = notBareRepo $+start (srcfile, destfile) = 	ifM (liftIO $ isRegularFile <$> getSymbolicLinkStatus srcfile) 		( do 			showStart "import" destfile@@ -33,7 +34,7 @@ 		unlessM (Annex.getState Annex.force) $ 			error $ "not overwriting existing " ++ destfile ++ 				" (use --force to override)"- + 	liftIO $ createDirectoryIfMissing True (parentDir destfile) 	liftIO $ moveFile srcfile destfile 	Command.Add.perform destfile
+ Command/Indirect.hs view
@@ -0,0 +1,83 @@+{- git-annex command+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Command.Indirect where++import Common.Annex+import Command+import qualified Git+import qualified Git.Command+import qualified Git.LsFiles+import Config+import Annex.Direct+import Annex.Content+import Annex.CatFile++def :: [Command]+def = [notBareRepo $ command "indirect" paramNothing seek+	"switch repository to indirect mode"]++seek :: [CommandSeek]+seek = [withNothing start]++start :: CommandStart+start = ifM isDirect ( next perform, stop )++perform :: CommandPerform+perform = do+	showStart "commit" ""+	whenM (stageDirect) $ do+		showOutput+		void $ inRepo $ Git.Command.runBool "commit"+			[Param "-m", Param "commit before switching to indirect mode"]+	showEndOk++	-- Note that we set indirect mode early, so that we can use+	-- moveAnnex in indirect mode.+	setDirect False++	top <- fromRepo Git.repoPath+	(l, clean) <- inRepo $ Git.LsFiles.stagedDetails [top]+	forM_ l go+	void $ liftIO clean+	next cleanup+  where+	{- Walk tree from top and move all present direct mode files into+	 - the annex, replacing with symlinks. Also delete direct mode+	 - caches and mappings. -}+	go (_, Nothing) = noop+	go (f, Just sha) = do+		r <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus f+		case r of+			Just s+				| isSymbolicLink s -> void $ flip whenAnnexed f $+					\_ (k, _) -> do+						cleandirect k+						return Nothing+				| otherwise -> +					maybe noop (fromdirect f)+						=<< catKey sha+			_ -> noop++	fromdirect f k = do+		showStart "indirect" f+		cleandirect k -- clean before content directory gets frozen+		whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do+			moveAnnex k f+			l <- calcGitLink f k+			liftIO $ createSymbolicLink l f+		showEndOk++	cleandirect k = do+		liftIO . nukeFile =<< inRepo (gitAnnexCache k)+		liftIO . nukeFile =<< inRepo (gitAnnexMapping k)++cleanup :: CommandCleanup+cleanup = do+	showStart "indirect" ""+	showEndOk+	return True
Command/InitRemote.hs view
@@ -52,7 +52,7 @@ cleanup u name c = do 	describeUUID u name 	Logs.Remote.configSet u c-        return True+	return True  {- Look up existing remote's UUID and config by name, or generate a new one -} findByName :: String -> Annex (UUID, R.RemoteConfig)
Command/Lock.hs view
@@ -12,7 +12,7 @@ import qualified Annex.Queue 	 def :: [Command]-def = [command "lock" paramPaths seek "undo unlock command"]+def = [notDirect $ command "lock" paramPaths seek "undo unlock command"]  seek :: [CommandSeek] seek = [withFilesUnlocked start, withFilesUnlockedToBeCommitted start]
Command/Log.hs view
@@ -36,7 +36,7 @@ type Outputter = Bool -> POSIXTime -> [UUID] -> Annex ()  def :: [Command]-def = [withOptions options $+def = [notDirect $ withOptions options $ 	command "log" paramPaths seek "shows location log"]  options :: [Option]
Command/Migrate.hs view
@@ -11,13 +11,15 @@ import Command import Backend import qualified Types.Key+import qualified Types.Backend import Types.KeySource import Annex.Content import qualified Command.ReKey import qualified Command.Fsck  def :: [Command]-def = [command "migrate" paramPaths seek "switch data to different backend"]+def = [notDirect $ +	command "migrate" paramPaths seek "switch data to different backend"]  seek :: [CommandSeek] seek = [withFilesInGit $ whenAnnexed start]@@ -26,7 +28,7 @@ start file (key, oldbackend) = do 	exists <- inAnnex key 	newbackend <- choosebackend =<< chooseBackend file-	if (newbackend /= oldbackend || upgradableKey key) && exists+	if (newbackend /= oldbackend || upgradableKey oldbackend key) && exists 		then do 			showStart "migrate" file 			next $ perform file key oldbackend newbackend@@ -35,10 +37,17 @@ 	choosebackend Nothing = Prelude.head <$> orderedList 	choosebackend (Just backend) = return backend -{- Checks if a key is upgradable to a newer representation. -}-{- Ideally, all keys have file size metadata. Old keys may not. -}-upgradableKey :: Key -> Bool-upgradableKey key = isNothing $ Types.Key.keySize key+{- Checks if a key is upgradable to a newer representation.+ - + - Reasons for migration:+ -  - Ideally, all keys have file size metadata. Old keys may not.+ -  - Something has changed in the backend, such as a bug fix.+ -}+upgradableKey :: Backend -> Key -> Bool+upgradableKey backend key = isNothing (Types.Key.keySize key) || backendupgradable+  where+	backendupgradable = maybe False (\a -> a key)+		(Types.Backend.canUpgradeKey backend)  {- Store the old backend's key in the new backend  - The old backend's key is not dropped from it, because there may
Command/Move.hs view
@@ -19,7 +19,7 @@ import Logs.Transfer  def :: [Command]-def = [withOptions options $ command "move" paramPaths seek+def = [notDirect $ withOptions options $ command "move" paramPaths seek 	"move content of files to/from another repository"]  fromOption :: Option
Command/ReKey.hs view
@@ -16,7 +16,7 @@ import Logs.Web  def :: [Command]-def = [command "rekey"+def = [notDirect $ command "rekey" 	(paramOptional $ paramRepeating $ paramPair paramPath paramKey) 	seek "change keys used for files"]
Command/Reinject.hs view
@@ -14,7 +14,7 @@ import qualified Command.Fsck  def :: [Command]-def = [command "reinject" (paramPair "SRC" "DEST") seek+def = [notDirect $ command "reinject" (paramPair "SRC" "DEST") seek 	"sets content of annexed file"]  seek :: [CommandSeek]
Command/SendKey.hs view
@@ -23,9 +23,8 @@  start :: Key -> CommandStart start key = ifM (inAnnex key)-	( fieldTransfer Upload key $ \_p -> do-		file <- inRepo $ gitAnnexLocation key-		liftIO $ rsyncServerSend file+	( fieldTransfer Upload key $ \_p ->+		sendAnnex key $ liftIO . rsyncServerSend 	, do 		warning "requested key is not present" 		liftIO exitFailure
Command/Status.hs view
@@ -69,6 +69,7 @@ fast_stats =  	[ supported_backends 	, supported_remote_types+	, repository_mode 	, remote_list Trusted 	, remote_list SemiTrusted 	, remote_list UnTrusted@@ -127,6 +128,11 @@ supported_remote_types = stat "supported remote types" $ json unwords $ 	return $ map R.typename Remote.remoteTypes +repository_mode :: Stat+repository_mode = stat "repository mode" $ json id $ lift $+	ifM isDirect +		( return "direct", return "indirect" )+ remote_list :: TrustLevel -> Stat remote_list level = stat n $ nojson $ lift $ do 	us <- M.keys <$> (M.union <$> uuidMap <*> remoteMap Remote.name)@@ -194,7 +200,7 @@ disk_size :: Stat disk_size = stat "available local disk space" $ json id $ lift $ 	calcfree-		<$> getDiskReserve+		<$> (annexDiskReserve <$> Annex.getGitConfig) 		<*> inRepo (getDiskFree . gitAnnexDir)   where 	calcfree reserve (Just have) = unwords
Command/Sync.hs view
@@ -1,7 +1,7 @@ {- git-annex command  -- - Copyright 2011 Joey Hess <joey@kitenet.net>  - Copyright 2011 Joachim Breitner <mail@joachim-breitner.de>+ - Copyright 2011,2012 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -15,6 +15,7 @@ import qualified Annex.Branch import qualified Annex.Queue import Annex.Content+import Annex.Direct import Annex.CatFile import qualified Git.Command import qualified Git.LsFiles as LsFiles@@ -28,7 +29,6 @@ import Types.Key import Config -import qualified Data.ByteString.Lazy as L import Data.Hash.MD5  def :: [Command]@@ -72,20 +72,26 @@ 				unwords (map Types.Remote.name s) 		return l 	available = filter (not . Remote.specialRemote)-		<$> (filterM (repoSyncable . Types.Remote.repo)-			=<< Remote.enabledRemoteList)+		. filter (remoteAnnexSync . Types.Remote.gitconfig)+		<$> Remote.enabledRemoteList 	good = filterM $ Remote.Git.repoAvail . Types.Remote.repo 	fastest = fromMaybe [] . headMaybe . Remote.byCost  commit :: CommandStart-commit = do-	showStart "commit" ""-	next $ next $ do+commit = next $ next $ do+	ifM isDirect+		( ifM stageDirect+			( runcommit [] , return True )+		, runcommit [Param "-a"]+		)+  where+	runcommit ps = do+		showStart "commit" "" 		showOutput 		Annex.Branch.commit "update" 		-- Commit will fail when the tree is clean, so ignore failure.-		_ <- inRepo $ Git.Command.runBool "commit"-			[Param "-a", Param "-m", Param "git-annex automatic sync"]+		_ <- inRepo $ Git.Command.runBool "commit" $ ps +++			[Param "-m", Param "git-annex automatic sync"] 		return True  mergeLocal :: Git.Ref -> CommandStart@@ -172,13 +178,30 @@ 	void $ Annex.Branch.forceUpdate 	stop +{- Merges from a branch into the current branch. -} mergeFrom :: Git.Ref -> Annex Bool mergeFrom branch = do 	showOutput-	ok <- inRepo $ Git.Merge.mergeNonInteractive branch-	if ok-		then return ok-		else resolveMerge+	ifM isDirect+		( maybe go godirect =<< inRepo Git.Branch.current+		, go+		)+  where+	go = runmerge $ inRepo $ Git.Merge.mergeNonInteractive branch+	godirect currbranch = do+		old <- inRepo $ Git.Ref.sha currbranch+		d <- fromRepo gitAnnexMergeDir+		r <- runmerge $ inRepo $ mergeDirect d branch+		new <- inRepo $ Git.Ref.sha currbranch+		case (old, new) of+			(Just oldsha, Just newsha) ->+				mergeDirectCleanup d oldsha newsha+			_ -> noop+		return r+	runmerge a = ifM (a)+		( return True+		, resolveMerge+		)  {- Resolves a conflicted merge. It's important that any conflicts be  - resolved in a way that itself avoids later merge conflicts, since@@ -211,7 +234,8 @@ resolveMerge' u 	| issymlink LsFiles.valUs && issymlink LsFiles.valThem = 		withKey LsFiles.valUs $ \keyUs ->-		withKey LsFiles.valThem $ \keyThem -> go keyUs keyThem+		withKey LsFiles.valThem $ \keyThem -> do+			go keyUs keyThem 	| otherwise = return False   where 	go keyUs keyThem@@ -219,7 +243,10 @@ 			makelink keyUs 			return True 		| otherwise = do-			liftIO $ nukeFile file+			ifM isDirect+				( maybe noop (\k -> removeDirect k file) keyUs+				, liftIO $ nukeFile file+				) 			Annex.Queue.addCommand "rm" [Params "--quiet -f --"] [file] 			makelink keyUs 			makelink keyThem@@ -234,15 +261,15 @@ 			nukeFile dest 			createSymbolicLink l dest 		Annex.Queue.addCommand "add" [Param "--force", Param "--"] [dest]+		whenM (isDirect) $+			toDirect key dest 	makelink _ = noop 	withKey select a = do 		let msha = select $ LsFiles.unmergedSha u 		case msha of 			Nothing -> a Nothing 			Just sha -> do-				key <- fileKey . takeFileName-					. encodeW8 . L.unpack -					<$> catObject sha+				key <- catKey sha 				maybe (return False) (a . Just) key  {- The filename to use when resolving a conflicted merge of a file,
Command/Unannex.hs view
@@ -16,7 +16,8 @@ import qualified Git.LsFiles as LsFiles  def :: [Command]-def = [command "unannex" paramPaths seek "undo accidential add command"]+def = [notDirect $+	command "unannex" paramPaths seek "undo accidential add command"]  seek :: [CommandSeek] seek = [withFilesInGit $ whenAnnexed start]
Command/Uninit.hs view
@@ -18,8 +18,8 @@ import Annex.Content  def :: [Command]-def = [addCheck check $ command "uninit" paramPaths seek -        "de-initialize git-annex and clean out repository"]+def = [notDirect $ addCheck check $ command "uninit" paramPaths seek +	"de-initialize git-annex and clean out repository"]  check :: Annex () check = do
Command/Unlock.hs view
@@ -18,7 +18,7 @@ 	, c "edit" "same as unlock" 	]   where-	c n = command n paramPaths seek+	c n = notDirect . command n paramPaths seek  seek :: [CommandSeek] seek = [withFilesInGit $ whenAnnexed start]@@ -39,12 +39,12 @@ 	tmpdest <- fromRepo $ gitAnnexTmpLocation key 	liftIO $ createDirectoryIfMissing True (parentDir tmpdest) 	showAction "copying"-	ok <- liftIO $ copyFileExternal src tmpdest-        if ok-                then do+	ifM (liftIO $ copyFileExternal src tmpdest)+		( do 			liftIO $ do 				removeFile dest 				moveFile tmpdest dest 			thawContent dest 			next $ return True-                else error "copy failed!"+		, error "copy failed!"+		)
Command/Unused.hs view
@@ -22,7 +22,6 @@ import Annex.Content import Utility.FileMode import Logs.Location-import Config import qualified Annex import qualified Git import qualified Git.Command@@ -181,11 +180,9 @@  - so will easily fit on even my lowest memory systems.  -} bloomCapacity :: Annex Int-bloomCapacity = fromMaybe 500000 . readish-	<$> getConfig (annexConfig "bloomcapacity") ""+bloomCapacity = fromMaybe 500000 . annexBloomCapacity <$> Annex.getGitConfig bloomAccuracy :: Annex Int-bloomAccuracy = fromMaybe 1000 . readish-	<$> getConfig (annexConfig "bloomaccuracy") ""+bloomAccuracy = fromMaybe 1000 . annexBloomAccuracy <$> Annex.getGitConfig bloomBitsHashes :: Annex (Int, Int) bloomBitsHashes = do 	capacity <- bloomCapacity
Command/Vicfg.hs view
@@ -44,7 +44,7 @@ vicfg curcfg f = do 	vi <- liftIO $ catchDefaultIO "vi" $ getEnv "EDITOR" 	-- Allow EDITOR to be processed by the shell, so it can contain options.-	unlessM (liftIO $ boolSystem "sh" [Param "-c", Param $ unwords [vi, f]]) $+	unlessM (liftIO $ boolSystem "sh" [Param "-c", Param $ unwords [vi, shellEscape f]]) $ 		error $ vi ++ " exited nonzero; aborting" 	r <- parseCfg curcfg <$> liftIO (readFileStrict f) 	liftIO $ nukeFile f
Command/Watch.hs view
@@ -13,7 +13,7 @@ import Option  def :: [Command]-def = [withOptions [foregroundOption, stopOption] $ +def = [notBareRepo $ withOptions [foregroundOption, stopOption] $  	command "watch" paramNothing seek "watch for changes"]  seek :: [CommandSeek]@@ -28,7 +28,7 @@ stopOption = Option.flag [] "stop" "stop daemon"  start :: Bool -> Bool -> Bool -> CommandStart-start assistant foreground stopdaemon = notBareRepo $ do+start assistant foreground stopdaemon = do 	if stopdaemon 		then stopDaemon 		else startDaemon assistant foreground Nothing -- does not return
Command/WebApp.hs view
@@ -29,8 +29,8 @@ import Control.Concurrent.STM  def :: [Command]-def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $-        command "webapp" paramNothing seek "launch webapp"]+def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $ notBareRepo $+	command "webapp" paramNothing seek "launch webapp"]  seek :: [CommandSeek] seek = [withNothing start]@@ -39,7 +39,7 @@ start = start' True  start' :: Bool -> CommandStart-start' allowauto = notBareRepo $ do+start' allowauto = do 	liftIO $ ensureInstalled 	ifM isInitialized ( go , auto ) 	stop
Command/Whereis.hs view
@@ -15,7 +15,7 @@ import Logs.Trust  def :: [Command]-def = [noCommit $ command "whereis" paramPaths seek+def = [notDirect $ noCommit $ command "whereis" paramPaths seek 	"lists repositories that have file content"]  seek :: [CommandSeek]
Config.hs view
@@ -12,32 +12,24 @@ import qualified Git.Config import qualified Git.Command import qualified Annex-import Utility.DataUnits  type UnqualifiedConfigKey = String data ConfigKey = ConfigKey String +{- Looks up a setting in git config. -}+getConfig :: ConfigKey -> String -> Annex String+getConfig (ConfigKey key) def = fromRepo $ Git.Config.get key def+ {- Changes a git config setting in both internal state and .git/config -} setConfig :: ConfigKey -> String -> Annex () setConfig (ConfigKey key) value = do 	inRepo $ Git.Command.run "config" [Param key, Param value]-	newg <- inRepo Git.Config.reRead-	Annex.changeState $ \s -> s { Annex.repo = newg }+	Annex.changeGitRepo =<< inRepo Git.Config.reRead  {- Unsets a git config setting. (Leaves it in state currently.) -} unsetConfig :: ConfigKey -> Annex () unsetConfig (ConfigKey key) = inRepo $ Git.Command.run "config"-        [Param "--unset", Param key]--{- Looks up a setting in git config. -}-getConfig :: ConfigKey -> String -> Annex String-getConfig (ConfigKey key) def = fromRepo $ Git.Config.get key def--{- Looks up a per-remote config setting in git config.- - Failing that, tries looking for a global config option. -}-getRemoteConfig :: Git.Repo -> UnqualifiedConfigKey -> String -> Annex String-getRemoteConfig r key def = -	getConfig (remoteConfig r key) =<< getConfig (annexConfig key) def+	[Param "--unset", Param key]  {- A per-remote config setting in git config. -} remoteConfig :: Git.Repo -> UnqualifiedConfigKey -> ConfigKey@@ -48,16 +40,15 @@ annexConfig :: UnqualifiedConfigKey -> ConfigKey annexConfig key = ConfigKey $ "annex." ++ key -{- Calculates cost for a remote. Either the default, or as configured +{- Calculates cost for a remote. Either the specific default, or as configured   - by remote.<name>.annex-cost, or if remote.<name>.annex-cost-command  - is set and prints a number, that is used. -}-remoteCost :: Git.Repo -> Int -> Annex Int-remoteCost r def = do-	cmd <- getRemoteConfig r "cost-command" ""-	(fromMaybe def . readish) <$>-		if not $ null cmd-			then liftIO $ readProcess "sh" ["-c", cmd]-			else getRemoteConfig r "cost" ""+remoteCost :: RemoteGitConfig -> Int -> Annex Int+remoteCost c def = case remoteAnnexCostCommand c of+	Just cmd | not (null cmd) -> liftIO $+		(fromMaybe def . readish) <$>+			readProcess "sh" ["-c", cmd]+	_ -> return $ fromMaybe def $ remoteAnnexCost c  cheapRemoteCost :: Int cheapRemoteCost = 100@@ -83,44 +74,22 @@ 	, semiCheapRemoteCost + encryptedRemoteCostAdj < expensiveRemoteCost 	] -{- Checks if a repo should be ignored. -}-repoNotIgnored :: Git.Repo -> Annex Bool-repoNotIgnored r = not . fromMaybe False . Git.Config.isTrue-	<$> getRemoteConfig r "ignore" ""--{- Checks if a repo should be synced. -}-repoSyncable :: Git.Repo -> Annex Bool-repoSyncable r = fromMaybe True . Git.Config.isTrue-	<$> getRemoteConfig r "sync" ""--{- If a value is specified, it is used; otherwise the default is looked up- - in git config. forcenumcopies overrides everything. -} getNumCopies :: Maybe Int -> Annex Int-getNumCopies v = perhaps (use v) =<< Annex.getState Annex.forcenumcopies-  where-	use (Just n) = return n-	use Nothing = perhaps (return 1) =<< -		readish <$> getConfig (annexConfig "numcopies") "1"-	perhaps fallback = maybe fallback (return . id)+getNumCopies (Just v) = return v+getNumCopies Nothing = annexNumCopies <$> Annex.getGitConfig -{- Gets the trust level set for a remote in git config. -}-getTrustLevel :: Git.Repo -> Annex (Maybe String)-getTrustLevel r = fromRepo $ Git.Config.getMaybe key-  where-	(ConfigKey key) = remoteConfig r "trustlevel"+isDirect :: Annex Bool+isDirect = annexDirect <$> Annex.getGitConfig -{- Gets annex.diskreserve setting. -}-getDiskReserve :: Annex Integer-getDiskReserve = fromMaybe megabyte . readSize dataUnits-	<$> getConfig (annexConfig "diskreserve") ""-  where-	megabyte = 1000000+setDirect :: Bool -> Annex ()+setDirect b = do+	setConfig (annexConfig "direct") $ if b then "true" else "false"+	Annex.changeGitConfig $ \c -> c { annexDirect = b } -{- Gets annex.httpheaders or annex.httpheaders-command setting,- - splitting it into lines. -}+{- Gets the http headers to use. -} getHttpHeaders :: Annex [String] getHttpHeaders = do-	cmd <- getConfig (annexConfig "http-headers-command") ""-	if null cmd-		then fromRepo $ Git.Config.getList "annex.http-headers"-		else lines <$> liftIO (readProcess "sh" ["-c", cmd])+	v <- annexHttpHeadersCommand <$> Annex.getGitConfig+	case v of+		Just cmd -> lines <$> liftIO (readProcess "sh" ["-c", cmd])+		Nothing -> annexHttpHeaders <$> Annex.getGitConfig
Crypto.hs view
@@ -93,7 +93,7 @@ 	let ks' = nub $ sort ks -- gpg complains about duplicate recipient keyids 	encipher <- Gpg.pipeStrict ([ Params "--encrypt" ] ++ recipients ks') c 	return $ EncryptedCipher encipher (KeyIds ks')- where+  where 	recipients l = force_recipients : 		concatMap (\k -> [Param "--recipient", Param k]) l 	-- Force gpg to only encrypt to the specified
Git/AutoCorrect.hs view
@@ -33,11 +33,11 @@ fuzzymatches :: String -> (c -> String) -> [c] -> [c] fuzzymatches input showchoice choices = fst $ unzip $ 	sortBy comparecost $ filter similarEnough $ zip choices costs-        where-                distance = restrictedDamerauLevenshteinDistance gitEditCosts input-                costs = map (distance . showchoice) choices-                comparecost a b = compare (snd a) (snd b)-                similarEnough (_, cst) = cst < similarityFloor+  where+	distance = restrictedDamerauLevenshteinDistance gitEditCosts input+	costs = map (distance . showchoice) choices+	comparecost a b = compare (snd a) (snd b)+	similarEnough (_, cst) = cst < similarityFloor  {- Takes action based on git's autocorrect configuration, in preparation for  - an autocorrected command being run. -}@@ -49,23 +49,23 @@ 			| n < 0 -> warn 			| otherwise -> sleep n 		Nothing -> list-	where-		list = error $ unlines $-			[ "Unknown command '" ++ input ++ "'"-			, ""-			, "Did you mean one of these?"-			] ++ map (\m -> "\t" ++ showmatch m) matches-		warn = -			hPutStr stderr $ unlines-				[ "WARNING: You called a command named '" ++-				  input ++ "', which does not exist."-				, "Continuing under the assumption that you meant '" ++-				  showmatch (Prelude.head matches) ++ "'"-				]-		sleep n = do-			warn-			hPutStrLn stderr $ unwords-				[ "in"-				, show (fromIntegral n / 10 :: Float)-				, "seconds automatically..."]-			threadDelay (n * 100000) -- deciseconds to microseconds+  where+	list = error $ unlines $+		[ "Unknown command '" ++ input ++ "'"+		, ""+		, "Did you mean one of these?"+		] ++ map (\m -> "\t" ++ showmatch m) matches+	warn = +		hPutStr stderr $ unlines+			[ "WARNING: You called a command named '" +++			  input ++ "', which does not exist."+			, "Continuing under the assumption that you meant '" +++			  showmatch (Prelude.head matches) ++ "'"+			]+	sleep n = do+		warn+		hPutStrLn stderr $ unwords+			[ "in"+			, show (fromIntegral n / 10 :: Float)+			, "seconds automatically..."]+		threadDelay (n * 100000) -- deciseconds to microseconds
Git/Branch.hs view
@@ -36,10 +36,10 @@ currentUnsafe :: Repo -> IO (Maybe Git.Ref) currentUnsafe r = parse . firstLine 	<$> pipeReadStrict [Param "symbolic-ref", Param "HEAD"] r-	where-		parse l-			| null l = Nothing-			| otherwise = Just $ Git.Ref l+  where+	parse l+		| null l = Nothing+		| otherwise = Just $ Git.Ref l  {- Checks if the second branch has any commits not present on the first  - branch. -}@@ -47,12 +47,12 @@ changed origbranch newbranch repo 	| origbranch == newbranch = return False 	| otherwise = not . null <$> diffs-	where-		diffs = pipeReadStrict-			[ Param "log"-			, Param (show origbranch ++ ".." ++ show newbranch)-			, Params "--oneline -n1"-			] repo+  where+	diffs = pipeReadStrict+		[ Param "log"+		, Param (show origbranch ++ ".." ++ show newbranch)+		, Params "--oneline -n1"+		] repo  {- Given a set of refs that are all known to have commits not  - on the branch, tries to update the branch by a fast-forward.@@ -70,23 +70,23 @@ 		( no_ff 		, maybe no_ff do_ff =<< findbest first rest 		)-	where-		no_ff = return False-		do_ff to = do-			run "update-ref"-				[Param $ show branch, Param $ show to] repo-			return True-		findbest c [] = return $ Just c-		findbest c (r:rs)-			| c == r = findbest c rs-			| otherwise = do-			better <- changed c r repo-			worse <- changed r c repo-			case (better, worse) of-				(True, True) -> return Nothing -- divergent fail-				(True, False) -> findbest r rs -- better-				(False, True) -> findbest c rs -- worse-				(False, False) -> findbest c rs -- same+  where+	no_ff = return False+	do_ff to = do+		run "update-ref"+			[Param $ show branch, Param $ show to] repo+		return True+	findbest c [] = return $ Just c+	findbest c (r:rs)+		| c == r = findbest c rs+		| otherwise = do+		better <- changed c r repo+		worse <- changed r c repo+		case (better, worse) of+			(True, True) -> return Nothing -- divergent fail+			(True, False) -> findbest r rs -- better+			(False, True) -> findbest c rs -- worse+			(False, False) -> findbest c rs -- same  {- Commits the index into the specified branch (or other ref),   - with the specified parent refs, and returns the committed sha -}@@ -99,5 +99,5 @@ 		message repo 	run "update-ref" [Param $ show branch, Param $ show sha] repo 	return sha-	where-		ps = concatMap (\r -> ["-p", show r]) parentrefs+  where+	ps = concatMap (\r -> ["-p", show r]) parentrefs
Git/CatFile.hs view
@@ -48,28 +48,28 @@ {- Gets both the content of an object, and its Sha. -} catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha)) catObjectDetails h object = CoProcess.query h send receive-	where-		send to = do-			fileEncoding to-			hPutStrLn to $ show object-		receive from = do-			fileEncoding from-			header <- hGetLine from-			case words header of-				[sha, objtype, size]-					| length sha == shaSize &&-					  isJust (readObjectType objtype) -> -						case reads size of-							[(bytes, "")] -> readcontent bytes from sha-							_ -> dne-					| otherwise -> dne-				_-					| header == show object ++ " missing" -> dne-					| otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)-		readcontent bytes from sha = do-			content <- S.hGet from bytes-			c <- hGetChar from-			when (c /= '\n') $-				error "missing newline from git cat-file"-			return $ Just (L.fromChunks [content], Ref sha)-		dne = return Nothing+  where+	send to = do+		fileEncoding to+		hPutStrLn to $ show object+	receive from = do+		fileEncoding from+		header <- hGetLine from+		case words header of+			[sha, objtype, size]+				| length sha == shaSize &&+				  isJust (readObjectType objtype) -> +					case reads size of+						[(bytes, "")] -> readcontent bytes from sha+						_ -> dne+				| otherwise -> dne+			_+				| header == show object ++ " missing" -> dne+				| otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)+	readcontent bytes from sha = do+		content <- S.hGet from bytes+		c <- hGetChar from+		when (c /= '\n') $+			error "missing newline from git cat-file"+		return $ Just (L.fromChunks [content], Ref sha)+	dne = return Nothing
Git/CheckAttr.hs view
@@ -24,12 +24,12 @@ 	cwd <- getCurrentDirectory 	h <- gitCoProcessStart params repo 	return (h, attrs, cwd)-	where-		params =-			[ Param "check-attr" -			, Params "-z --stdin"-			] ++ map Param attrs ++-			[ Param "--" ]+  where+	params =+		[ Param "check-attr" +		, Params "-z --stdin"+		] ++ map Param attrs +++		[ Param "--" ]  checkAttrStop :: CheckAttrHandle -> IO () checkAttrStop (h, _, _) = CoProcess.stop h@@ -42,26 +42,26 @@ 	case vals of 		[v] -> return v 		_ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file-	where-		send to = do-			fileEncoding to-			hPutStr to $ file' ++ "\0"-		receive from = forM attrs $ \attr -> do-			fileEncoding from-			l <- hGetLine from-			return (attr, attrvalue attr l)-		{- Before git 1.7.7, git check-attr worked best with-		 - absolute filenames; using them worked around some bugs-		 - with relative filenames.-		 - -		 - With newer git, git check-attr chokes on some absolute-		 - filenames, and the bugs that necessitated them were fixed,-		 - so use relative filenames. -}-		oldgit = Git.Version.older "1.7.7"-		file'-			| oldgit = absPathFrom cwd file-			| otherwise = relPathDirToFile cwd $ absPathFrom cwd file-		attrvalue attr l = end bits !! 0-			where-				bits = split sep l-				sep = ": " ++ attr ++ ": "+  where+	send to = do+		fileEncoding to+		hPutStr to $ file' ++ "\0"+	receive from = forM attrs $ \attr -> do+		fileEncoding from+		l <- hGetLine from+		return (attr, attrvalue attr l)+	{- Before git 1.7.7, git check-attr worked best with+	 - absolute filenames; using them worked around some bugs+	 - with relative filenames.+	 - +	 - With newer git, git check-attr chokes on some absolute+	 - filenames, and the bugs that necessitated them were fixed,+	 - so use relative filenames. -}+	oldgit = Git.Version.older "1.7.7"+	file'+		| oldgit = absPathFrom cwd file+		| otherwise = relPathDirToFile cwd $ absPathFrom cwd file+	attrvalue attr l = end bits !! 0+	  where+		bits = split sep l+		sep = ": " ++ attr ++ ": "
Git/Command.hs view
@@ -17,11 +17,11 @@ {- Constructs a git command line operating on the specified repo. -} gitCommandLine :: [CommandParam] -> Repo -> [CommandParam] gitCommandLine params Repo { location = l@(Local _ _ ) } = setdir : settree ++ params-	where-		setdir = Param $ "--git-dir=" ++ gitdir l-		settree = case worktree l of-			Nothing -> []-			Just t -> [Param $ "--work-tree=" ++ t]+  where+	setdir = Param $ "--git-dir=" ++ gitdir l+	settree = case worktree l of+		Nothing -> []+		Just t -> [Param $ "--work-tree=" ++ t] gitCommandLine _ repo = assertLocal repo $ error "internal"  {- Runs git in the specified repo. -}@@ -49,8 +49,8 @@ 	fileEncoding h 	c <- hGetContents h 	return (c, checkSuccessProcess pid)-	where-		p  = gitCreateProcess params repo+  where+	p  = gitCreateProcess params repo  {- Runs a git subcommand, and returns its output, strictly.  -@@ -63,8 +63,8 @@ 		output <- hGetContentsStrict h 		hClose h 		return output-	where-		p  = gitCreateProcess params repo+  where+	p  = gitCreateProcess params repo  {- Runs a git subcommand, feeding it input, and returning its output,  - which is expected to be fairly small, since it's all read into memory@@ -85,8 +85,8 @@ pipeNullSplit params repo = do 	(s, cleanup) <- pipeReadLazy params repo 	return (filter (not . null) $ split sep s, cleanup)-	where-		sep = "\0"+  where+	sep = "\0"   pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String]
Git/Config.hs view
@@ -48,18 +48,18 @@  -} read' :: Repo -> IO Repo read' repo = go repo-	where-		go Repo { location = Local { gitdir = d } } = git_config d-		go Repo { location = LocalUnknown d } = git_config d-		go _ = assertLocal repo $ error "internal"-		git_config d = withHandle StdoutHandle createProcessSuccess p $-			hRead repo-			where-				params = ["config", "--null", "--list"]-				p = (proc "git" params)-					{ cwd = Just d-					, env = gitEnv repo-					}+  where+	go Repo { location = Local { gitdir = d } } = git_config d+	go Repo { location = LocalUnknown d } = git_config d+	go _ = assertLocal repo $ error "internal"+	git_config d = withHandle StdoutHandle createProcessSuccess p $+		hRead repo+	  where+		params = ["config", "--null", "--list"]+		p = (proc "git" params)+			{ cwd = Just d+			, env = gitEnv repo+			}  {- Gets the global git config, returning a dummy Repo containing it. -} global :: IO (Maybe Repo)@@ -73,9 +73,9 @@ 			return $ Just repo' 		, return Nothing 		)-	where-		params = ["config", "--null", "--list", "--global"]-		p = (proc "git" params)+  where+	params = ["config", "--null", "--list", "--global"]+	p = (proc "git" params)  {- Reads git config from a handle and populates a repo with it. -} hRead :: Repo -> Handle -> IO Repo@@ -133,10 +133,10 @@ 	| all ('=' `elem`) (take 1 ls) = sep '=' ls 	-- --null --list output separates keys from values with newlines 	| otherwise = sep '\n' $ split "\0" s-	where-		ls = lines s-		sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .-			map (separate (== c))+  where+	ls = lines s+	sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .+		map (separate (== c))  {- Checks if a string from git config is a true value. -} isTrue :: String -> Maybe Bool@@ -144,8 +144,8 @@ 	| s' == "true" = Just True 	| s' == "false" = Just False 	| otherwise = Nothing-	where-		s' = map toLower s+  where+	s' = map toLower s  isBare :: Repo -> Bool isBare r = fromMaybe False $ isTrue =<< getMaybe "core.bare" r
Git/Construct.hs view
@@ -33,15 +33,15 @@  - directory. -} fromCwd :: IO Repo fromCwd = getCurrentDirectory >>= seekUp checkForRepo-	where-		norepo = error "Not in a git repository."-		seekUp check dir = do-			r <- check dir-			case r of-				Nothing -> case parentDir dir of-					"" -> norepo-					d -> seekUp check d-				Just loc -> newFrom loc+  where+	norepo = error "Not in a git repository."+	seekUp check dir = do+		r <- check dir+		case r of+			Nothing -> case parentDir dir of+				"" -> norepo+				d -> seekUp check d+			Just loc -> newFrom loc  {- Local Repo constructor, accepts a relative or absolute path. -} fromPath :: FilePath -> IO Repo@@ -55,21 +55,21 @@ 		ifM (doesDirectoryExist dir') ( ret dir' , hunt ) 	| otherwise = 		error $ "internal error, " ++ dir ++ " is not absolute"-	where-		ret = newFrom . LocalUnknown- 		{- Git always looks for "dir.git" in preference to-		 - to "dir", even if dir ends in a "/". -}-		canondir = dropTrailingPathSeparator dir-		dir' = canondir ++ ".git"-		{- When dir == "foo/.git", git looks for "foo/.git/.git",-		 - and failing that, uses "foo" as the repository. -}-		hunt-			| "/.git" `isSuffixOf` canondir =-				ifM (doesDirectoryExist $ dir </> ".git")-					( ret dir-					, ret $ takeDirectory canondir-					)-			| otherwise = ret dir+  where+	ret = newFrom . LocalUnknown+	{- Git always looks for "dir.git" in preference to+	 - to "dir", even if dir ends in a "/". -}+	canondir = dropTrailingPathSeparator dir+	dir' = canondir ++ ".git"+	{- When dir == "foo/.git", git looks for "foo/.git/.git",+	 - and failing that, uses "foo" as the repository. -}+	hunt+		| "/.git" `isSuffixOf` canondir =+			ifM (doesDirectoryExist $ dir </> ".git")+				( ret dir+				, ret $ takeDirectory canondir+				)+		| otherwise = ret dir  {- Remote Repo constructor. Throws exception on invalid url.  -@@ -85,9 +85,9 @@ fromUrlStrict url 	| startswith "file://" url = fromAbsPath $ uriPath u 	| otherwise = newFrom $ Url u-	where-		u = fromMaybe bad $ parseURI url-		bad = error $ "bad url " ++ url+  where+	u = fromMaybe bad $ parseURI url+	bad = error $ "bad url " ++ url  {- Creates a repo that has an unknown location. -} fromUnknown :: IO Repo@@ -100,21 +100,23 @@ 	| not $ repoIsUrl reference = error "internal error; reference repo not url" 	| repoIsUrl r = r 	| otherwise = r { location = Url $ fromJust $ parseURI absurl }-	where-		absurl =-			Url.scheme reference ++ "//" ++-			Url.authority reference ++-			repoPath r+  where+	absurl = concat+		[ Url.scheme reference+		, "//"+		, Url.authority reference+		, repoPath r+		]  {- Calculates a list of a repo's configured remotes, by parsing its config. -} fromRemotes :: Repo -> IO [Repo] fromRemotes repo = mapM construct remotepairs-	where-		filterconfig f = filter f $ M.toList $ config repo-		filterkeys f = filterconfig (\(k,_) -> f k)-		remotepairs = filterkeys isremote-		isremote k = startswith "remote." k && endswith ".url" k-		construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo+  where+	filterconfig f = filter f $ M.toList $ config repo+	filterkeys f = filterconfig (\(k,_) -> f k)+	remotepairs = filterkeys isremote+	isremote k = startswith "remote." k && endswith ".url" k+	construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo  {- Sets the name of a remote when constructing the Repo to represent it. -} remoteNamed :: String -> IO Repo -> IO Repo@@ -123,53 +125,51 @@ 	return $ r { remoteName = Just n }  {- Sets the name of a remote based on the git config key, such as-   "remote.foo.url". -}+ - "remote.foo.url". -} remoteNamedFromKey :: String -> IO Repo -> IO Repo remoteNamedFromKey k = remoteNamed basename-	where-		basename = join "." $ reverse $ drop 1 $-				reverse $ drop 1 $ split "." k+  where+	basename = join "." $ reverse $ drop 1 $ reverse $ drop 1 $ split "." k  {- Constructs a new Repo for one of a Repo's remotes using a given  - location (ie, an url). -} fromRemoteLocation :: String -> Repo -> IO Repo fromRemoteLocation s repo = gen $ calcloc s-	where-		gen v	-			| scpstyle v = fromUrl $ scptourl v-			| urlstyle v = fromUrl v-			| otherwise = fromRemotePath v repo-		-- insteadof config can rewrite remote location-		calcloc l-			| null insteadofs = l-			| otherwise = replacement ++ drop (length bestvalue) l-			where-				replacement = drop (length prefix) $-					take (length bestkey - length suffix) bestkey-				(bestkey, bestvalue) = maximumBy longestvalue insteadofs-				longestvalue (_, a) (_, b) = compare b a-				insteadofs = filterconfig $ \(k, v) -> -					startswith prefix k &&-					endswith suffix k &&-					startswith v l-				filterconfig f = filter f $-					concatMap splitconfigs $-						M.toList $ fullconfig repo-				splitconfigs (k, vs) = map (\v -> (k, v)) vs-				(prefix, suffix) = ("url." , ".insteadof")-		urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v-		-- git remotes can be written scp style -- [user@]host:dir-		-- but foo::bar is a git-remote-helper location instead-		scpstyle v = ":" `isInfixOf` v -			&& not ("//" `isInfixOf` v)-			&& not ("::" `isInfixOf` v)-		scptourl v = "ssh://" ++ host ++ slash dir-			where-				(host, dir) = separate (== ':') v-				slash d	| d == "" = "/~/" ++ d-					| "/" `isPrefixOf` d = d-					| "~" `isPrefixOf` d = '/':d-					| otherwise = "/~/" ++ d+  where+	gen v	+		| scpstyle v = fromUrl $ scptourl v+		| urlstyle v = fromUrl v+		| otherwise = fromRemotePath v repo+	-- insteadof config can rewrite remote location+	calcloc l+		| null insteadofs = l+		| otherwise = replacement ++ drop (length bestvalue) l+	  where+		replacement = drop (length prefix) $+			take (length bestkey - length suffix) bestkey+		(bestkey, bestvalue) = maximumBy longestvalue insteadofs+		longestvalue (_, a) (_, b) = compare b a+		insteadofs = filterconfig $ \(k, v) -> +			startswith prefix k &&+			endswith suffix k &&+			startswith v l+		filterconfig f = filter f $+			concatMap splitconfigs $ M.toList $ fullconfig repo+		splitconfigs (k, vs) = map (\v -> (k, v)) vs+		(prefix, suffix) = ("url." , ".insteadof")+	urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v+	-- git remotes can be written scp style -- [user@]host:dir+	-- but foo::bar is a git-remote-helper location instead+	scpstyle v = ":" `isInfixOf` v +		&& not ("//" `isInfixOf` v)+		&& not ("::" `isInfixOf` v)+	scptourl v = "ssh://" ++ host ++ slash dir+	  where+		(host, dir) = separate (== ':') v+		slash d	| d == "" = "/~/" ++ d+			| "/" `isPrefixOf` d = d+			| "~" `isPrefixOf` d = '/':d+			| otherwise = "/~/" ++ d  {- Constructs a Repo from the path specified in the git remotes of  - another Repo. -}@@ -191,25 +191,25 @@  expandTilde :: FilePath -> IO FilePath expandTilde = expandt True-	where-		expandt _ [] = return ""-		expandt _ ('/':cs) = do-			v <- expandt True cs-			return ('/':v)-		expandt True ('~':'/':cs) = do-			h <- myHomeDir-			return $ h </> cs-		expandt True ('~':cs) = do-			let (name, rest) = findname "" cs-			u <- getUserEntryForName name-			return $ homeDirectory u </> rest-		expandt _ (c:cs) = do-			v <- expandt False cs-			return (c:v)-		findname n [] = (n, "")-		findname n (c:cs)-			| c == '/' = (n, cs)-			| otherwise = findname (n++[c]) cs+  where+	expandt _ [] = return ""+	expandt _ ('/':cs) = do+		v <- expandt True cs+		return ('/':v)+	expandt True ('~':'/':cs) = do+		h <- myHomeDir+		return $ h </> cs+	expandt True ('~':cs) = do+		let (name, rest) = findname "" cs+		u <- getUserEntryForName name+		return $ homeDirectory u </> rest+	expandt _ (c:cs) = do+		v <- expandt False cs+		return (c:v)+	findname n [] = (n, "")+	findname n (c:cs)+		| c == '/' = (n, cs)+		| otherwise = findname (n++[c]) cs  checkForRepo :: FilePath -> IO (Maybe RepoLocation) checkForRepo dir = @@ -217,28 +217,28 @@ 		check gitDirFile $ 			check isBareRepo $ 				return Nothing-	where-		check test cont = maybe cont (return . Just) =<< test-		checkdir c = ifM c-			( return $ Just $ LocalUnknown dir-			, return Nothing-			)-		isRepo = checkdir $ gitSignature $ ".git" </> "config"-		isBareRepo = checkdir $ gitSignature "config"-			<&&> doesDirectoryExist (dir </> "objects")-		gitDirFile = do-			c <- firstLine <$>-				catchDefaultIO "" (readFile $ dir </> ".git")-			return $ if gitdirprefix `isPrefixOf` c-				then Just $ Local -					{ gitdir = absPathFrom dir $-						drop (length gitdirprefix) c-					, worktree = Just dir-					}-				else Nothing-			where-				gitdirprefix = "gitdir: "-		gitSignature file = doesFileExist $ dir </> file+  where+	check test cont = maybe cont (return . Just) =<< test+	checkdir c = ifM c+		( return $ Just $ LocalUnknown dir+		, return Nothing+		)+	isRepo = checkdir $ gitSignature $ ".git" </> "config"+	isBareRepo = checkdir $ gitSignature "config"+		<&&> doesDirectoryExist (dir </> "objects")+	gitDirFile = do+		c <- firstLine <$>+			catchDefaultIO "" (readFile $ dir </> ".git")+		return $ if gitdirprefix `isPrefixOf` c+			then Just $ Local +				{ gitdir = absPathFrom dir $+					drop (length gitdirprefix) c+				, worktree = Just dir+				}+			else Nothing+	  where+		gitdirprefix = "gitdir: "+	gitSignature file = doesFileExist $ dir </> file  newFrom :: RepoLocation -> IO Repo newFrom l = return Repo
Git/CurrentRepo.hs view
@@ -39,23 +39,23 @@ 			unless (d `dirContains` cwd) $ 				changeWorkingDirectory d 			return $ addworktree wt r-	where-		pathenv s = do-			v <- getEnv s-			case v of-				Just d -> do-					unsetEnv s-					Just <$> absPath d-				Nothing -> return Nothing-		configure Nothing r = Git.Config.read r-		configure (Just d) r = do-			r' <- Git.Config.read r-			-- Let GIT_DIR override the default gitdir.-			absd <- absPath d-			return $ changelocation r' $ Local-				{ gitdir = absd-				, worktree = worktree (location r')-				}-		addworktree w r = changelocation r $-			Local { gitdir = gitdir (location r), worktree = w }-		changelocation r l = r { location = l }+  where+	pathenv s = do+		v <- getEnv s+		case v of+			Just d -> do+				unsetEnv s+				Just <$> absPath d+			Nothing -> return Nothing+	configure Nothing r = Git.Config.read r+	configure (Just d) r = do+		r' <- Git.Config.read r+		-- Let GIT_DIR override the default gitdir.+		absd <- absPath d+		return $ changelocation r' $ Local+			{ gitdir = absd+			, worktree = worktree (location r')+			}+	addworktree w r = changelocation r $+		Local { gitdir = gitdir (location r), worktree = w }+	changelocation r l = r { location = l }
+ Git/DiffTree.hs view
@@ -0,0 +1,75 @@+{- git diff-tree interface+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.DiffTree (+	DiffTreeItem(..),+	diffTree,+	diffTreeRecursive,+	parseDiffTree+) where++import Numeric+import System.Posix.Types++import Common+import Git+import Git.Sha+import Git.Command+import qualified Git.Filename++data DiffTreeItem = DiffTreeItem+	{ srcmode :: FileMode+	, dstmode :: FileMode+	, srcsha :: Sha -- nullSha if file was added+	, dstsha :: Sha -- nullSha if file was deleted+	, status :: String+	, file :: FilePath+	} deriving Show++{- Diffs two tree Refs. -}+diffTree :: Ref -> Ref -> Repo -> IO ([DiffTreeItem], IO Bool)+diffTree = diffTree' []++{- Diffs two tree Refs, recursing into sub-trees -}+diffTreeRecursive :: Ref -> Ref -> Repo -> IO ([DiffTreeItem], IO Bool)+diffTreeRecursive = diffTree' [Param "-r"]++diffTree' :: [CommandParam] -> Ref -> Ref -> Repo -> IO ([DiffTreeItem], IO Bool)+diffTree' params src dst repo = do+	(diff, cleanup) <- pipeNullSplit ps repo+	return (parseDiffTree diff, cleanup)+  where+	ps = Params "diff-tree -z --raw --no-renames -l0" : params +++		[Param (show src), Param (show dst)]++{- Parses diff-tree output. -}+parseDiffTree :: [String] -> [DiffTreeItem]+parseDiffTree l = go l []+  where+	go [] c = c+	go (info:f:rest) c = go rest (mk info f : c)+	go (s:[]) _ = error $ "diff-tree parse error " ++ s++	mk info f = DiffTreeItem +		{ srcmode = readmode srcm+		, dstmode = readmode dstm+		, srcsha = fromMaybe (error "bad srcsha") $ extractSha ssha+		, dstsha = fromMaybe (error "bad dstsha") $ extractSha dsha+		, status = s+		, file = Git.Filename.decode f+		}+	  where+		readmode = fst . Prelude.head . readOct++		-- info = :<srcmode> SP <dstmode> SP <srcsha> SP <dstsha> SP <status>+		-- All fields are fixed, so we can pull them out of+		-- specific positions in the line.+		(srcm, past_srcm) = splitAt 7 $ drop 1 info+		(dstm, past_dstm) = splitAt 7 past_srcm+		(ssha, past_ssha) = splitAt shaSize past_dstm+		(dsha, past_dsha) = splitAt shaSize $ drop 1 past_ssha+		s = drop 1 past_dsha
Git/HashObject.hs view
@@ -29,17 +29,17 @@ {- Injects a file into git, returning the Sha of the object. -} hashFile :: HashObjectHandle -> FilePath -> IO Sha hashFile h file = CoProcess.query h send receive-	where-		send to = do-			fileEncoding to-			hPutStrLn to file-		receive from = getSha "hash-object" $ hGetLine from+  where+	send to = do+		fileEncoding to+		hPutStrLn to file+	receive from = getSha "hash-object" $ hGetLine from  {- Injects some content into git, returning its Sha. -} hashObject :: ObjectType -> String -> Repo -> IO Sha hashObject objtype content repo = getSha subcmd $ do 	s <- pipeWriteRead (map Param params) content repo 	return s-	where-		subcmd = "hash-object"-		params = [subcmd, "-t", show objtype, "-w", "--stdin"]+  where+	subcmd = "hash-object"+	params = [subcmd, "-t", show objtype, "-w", "--stdin"]
Git/Index.hs view
@@ -21,7 +21,7 @@ 	res <- getEnv var 	setEnv var index True 	return $ reset res-	where-		var = "GIT_INDEX_FILE"-		reset (Just v) = setEnv var v True-		reset _ = unsetEnv var+  where+	var = "GIT_INDEX_FILE"+	reset (Just v) = setEnv var v True+	reset _ = unsetEnv var
Git/LsFiles.hs view
@@ -8,9 +8,10 @@ module Git.LsFiles ( 	inRepo, 	notInRepo,+	deleted, 	staged, 	stagedNotDeleted,-	changedUnstaged,+	stagedDetails, 	typeChanged, 	typeChangedStaged, 	Conflicting(..),@@ -31,13 +32,20 @@ {- 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-	where-		params = [Params "ls-files --others"] ++ exclude ++-			[Params "-z --"] ++ map File l-		exclude-			| include_ignored = []-			| otherwise = [Param "--exclude-standard"]+  where+	params = [Params "ls-files --others"] ++ exclude +++		[Params "-z --"] ++ map File l+	exclude+		| include_ignored = []+		| otherwise = [Param "--exclude-standard"] +{- Returns a list of files in the specified locations that have been+ - deleted. -}+deleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)+deleted l repo = pipeNullSplit params repo+  where+	params = [Params "ls-files --deleted -z --"] ++ map File l+ {- Returns a list of all files that are staged for commit. -} staged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) staged = staged' []@@ -49,15 +57,25 @@  staged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix-	where-		prefix = [Params "diff --cached --name-only -z"]-		suffix = Param "--" : map File l+  where+	prefix = [Params "diff --cached --name-only -z"]+	suffix = Param "--" : map File l -{- Returns a list of files that have unstaged changes. -}-changedUnstaged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)-changedUnstaged l = pipeNullSplit params-	where-		params = Params "diff --name-only -z --" : map File l+{- Returns details about files that are staged in the index+ - (including the Sha of their staged contents),+ - as well as files not yet in git. -}+stagedDetails :: [FilePath] -> Repo -> IO ([(FilePath, Maybe Sha)], IO Bool)+stagedDetails l repo = do+	(ls, cleanup) <- pipeNullSplit params repo+	return (map parse ls, cleanup)+  where+	params = [Params "ls-files --others --exclude-standard --stage -z --"] +++		map File l+	parse s+		| null file = (s, Nothing)+		| otherwise = (file, extractSha $ take shaSize $ drop 7 metadata)+	  where+		(metadata, file) = separate (== '\t') s  {- Returns a list of the files in the specified locations that are staged  - for commit, and whose type has changed. -}@@ -77,9 +95,9 @@ 	let top = repoPath repo 	cwd <- getCurrentDirectory 	return (map (\f -> relPathDirToFile cwd $ top </> f) fs, cleanup)-	where-		prefix = [Params "diff --name-only --diff-filter=T -z"]-		suffix = Param "--" : map File l+  where+	prefix = [Params "diff --name-only --diff-filter=T -z"]+	suffix = Param "--" : map File l  {- A item in conflict has two possible values.  - Either can be Nothing, when that side deleted the file. -}@@ -102,14 +120,14 @@  -   1 = old version, can be ignored  -   2 = us  -   3 = them- - If a line is omitted, that side deleted the file.+ - If a line is omitted, that side removed the file.  -} unmerged :: [FilePath] -> Repo -> IO ([Unmerged], IO Bool) unmerged l repo = do 	(fs, cleanup) <- pipeNullSplit params repo 	return (reduceUnmerged [] $ catMaybes $ map parseUnmerged fs, cleanup)-	where-		params = Params "ls-files --unmerged -z --" : map File l+  where+	params = Params "ls-files --unmerged -z --" : map File l  data InternalUnmerged = InternalUnmerged 	{ isus :: Bool@@ -131,28 +149,28 @@ 			return $ InternalUnmerged (stage == 2) file 				(Just blobtype) (Just sha) 		_ -> Nothing-	where-		(metadata, file) = separate (== '\t') s+  where+	(metadata, file) = separate (== '\t') s  reduceUnmerged :: [Unmerged] -> [InternalUnmerged] -> [Unmerged] reduceUnmerged c [] = c 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)-		new = Unmerged-			{ unmergedFile = ifile i-			, unmergedBlobType = Conflicting blobtypeA blobtypeB-			, unmergedSha = Conflicting shaA shaB-			}-		findsib templatei [] = ([], deleted templatei)-		findsib templatei (l:ls)-			| ifile l == ifile templatei = (ls, l)-			| otherwise = (l:ls, deleted templatei)-		deleted templatei = templatei-			{ isus = not (isus templatei)-			, iblobtype = Nothing-			, isha = Nothing-			}+  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)+	new = Unmerged+		{ unmergedFile = ifile i+		, unmergedBlobType = Conflicting blobtypeA blobtypeB+		, unmergedSha = Conflicting shaA shaB+		}+	findsib templatei [] = ([], removed templatei)+	findsib templatei (l:ls)+		| ifile l == ifile templatei = (ls, l)+		| otherwise = (l:ls, removed templatei)+	removed templatei = templatei+		{ isus = not (isus templatei)+		, iblobtype = Nothing+		, isha = Nothing+		}
Git/LsTree.hs view
@@ -19,6 +19,7 @@ import Common import Git import Git.Command+import Git.Sha import qualified Git.Filename  data TreeItem = TreeItem@@ -47,11 +48,11 @@ 	, sha = s 	, file = Git.Filename.decode f 	}-	where-		-- l = <mode> SP <type> SP <sha> TAB <file>-		-- All fields are fixed, so we can pull them out of-		-- specific positions in the line.-		(m, past_m) = splitAt 7 l-		(t, past_t) = splitAt 4 past_m-		(s, past_s) = splitAt 40 $ Prelude.tail past_t-		f = Prelude.tail past_s+  where+	-- l = <mode> SP <type> SP <sha> TAB <file>+	-- All fields are fixed, so we can pull them out of+	-- specific positions in the line.+	(m, past_m) = splitAt 7 l+	(t, past_t) = splitAt 4 past_m+	(s, past_s) = splitAt shaSize $ Prelude.tail past_t+	f = Prelude.tail past_s
Git/Queue.hs view
@@ -86,30 +86,30 @@ addCommand :: String -> [CommandParam] -> [FilePath] -> Queue -> Repo -> IO Queue addCommand subcommand params files q repo = 	updateQueue action different (length newfiles) q repo-	where-		key = actionKey action-		action = CommandAction-			{ getSubcommand = subcommand-			, getParams = params-			, getFiles = newfiles-			}-		newfiles = files ++ maybe [] getFiles (M.lookup key $ items q)+  where+	key = actionKey action+	action = CommandAction+		{ getSubcommand = subcommand+		, getParams = params+		, getFiles = newfiles+		}+	newfiles = files ++ maybe [] getFiles (M.lookup key $ items q) 		-		different (CommandAction { getSubcommand = s }) = s /= subcommand-		different _ = True+	different (CommandAction { getSubcommand = s }) = s /= subcommand+	different _ = True  {- Adds an update-index streamer to the queue. -} addUpdateIndex :: Git.UpdateIndex.Streamer -> Queue -> Repo -> IO Queue addUpdateIndex streamer q repo = 	updateQueue action different 1 q repo-	where-		key = actionKey action-		-- the list is built in reverse order-		action = UpdateIndexAction $ streamer : streamers-		streamers = maybe [] getStreamers $ M.lookup key $ items q+  where+	key = actionKey action+	-- the list is built in reverse order+	action = UpdateIndexAction $ streamer : streamers+	streamers = maybe [] getStreamers $ M.lookup key $ items q -		different (UpdateIndexAction _) = False-		different _ = True+	different (UpdateIndexAction _) = False+	different _ = True  {- Updates or adds an action in the queue. If the queue already contains a  - different action, it will be flushed; this is to ensure that conflicting@@ -118,15 +118,15 @@ updateQueue !action different sizeincrease q repo 	| null (filter different (M.elems (items q))) = return $ go q 	| otherwise = go <$> flush q repo-	where-		go q' = newq-			where		-				!newq = q'-					{ size = newsize-					, items = newitems-					}-				!newsize = size q' + sizeincrease-				!newitems = M.insertWith' const (actionKey action) action (items q')+  where+	go q' = newq+	  where		+		!newq = q'+			{ size = newsize+			, items = newitems+			}+		!newsize = size q' + sizeincrease+		!newitems = M.insertWith' const (actionKey action) action (items q')  {- Is a queue large enough that it should be flushed? -} full :: Queue -> Bool@@ -153,8 +153,8 @@ 		fileEncoding h 		hPutStr h $ join "\0" $ getFiles action 		hClose h-	where-		p = (proc "xargs" params) { env = gitEnv repo }-		params = "-0":"git":baseparams-		baseparams = toCommand $ gitCommandLine-			(Param (getSubcommand action):getParams action) repo+  where+	p = (proc "xargs" params) { env = gitEnv repo }+	params = "-0":"git":baseparams+	baseparams = toCommand $ gitCommandLine+		(Param (getSubcommand action):getParams action) repo
Git/Ref.hs view
@@ -21,10 +21,10 @@  - Converts such a fully qualified ref into a base ref (eg: master). -} base :: Ref -> Ref base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show-	where-		remove prefix s-			| prefix `isPrefixOf` s = drop (length prefix) s-			| otherwise = s+  where+	remove prefix s+		| prefix `isPrefixOf` s = drop (length prefix) s+		| otherwise = s  {- Given a directory such as "refs/remotes/origin", and a ref such as  - refs/heads/master, yields a version of that ref under the directory,@@ -40,51 +40,51 @@ {- Get the sha of a fully qualified git ref, if it exists. -} sha :: Branch -> Repo -> IO (Maybe Sha) sha branch repo = process <$> showref repo-	where-		showref = pipeReadStrict [Param "show-ref",-			Param "--hash", -- get the hash-			Param $ show branch]-		process [] = Nothing-		process s = Just $ Ref $ firstLine s+  where+	showref = pipeReadStrict [Param "show-ref",+		Param "--hash", -- get the hash+		Param $ show branch]+	process [] = Nothing+	process s = Just $ Ref $ firstLine s  {- List of (refs, branches) matching a given ref spec. -} matching :: Ref -> Repo -> IO [(Ref, Branch)] matching ref repo = map gen . lines <$>  	pipeReadStrict [Param "show-ref", Param $ show ref] repo-	where-		gen l = let (r, b) = separate (== ' ') l in-			(Ref r, Ref b)+  where+	gen l = let (r, b) = separate (== ' ') l+		in (Ref r, Ref b)  {- List of (refs, branches) matching a given ref spec.  - Duplicate refs are filtered out. -} matchingUniq :: Ref -> Repo -> IO [(Ref, Branch)] matchingUniq ref repo = nubBy uniqref <$> matching ref repo-	where-		uniqref (a, _) (b, _) = a == b+  where+	uniqref (a, _) (b, _) = a == b  {- Checks if a String is a legal git ref name.  -  - The rules for this are complex; see git-check-ref-format(1) -} legal :: Bool -> String -> Bool legal allowonelevel s = all (== False) illegal-	where-		illegal =-			[ any ("." `isPrefixOf`) pathbits-			, any (".lock" `isSuffixOf`) pathbits-			, not allowonelevel && length pathbits < 2-			, contains ".."-			, any (\c -> contains [c]) illegalchars-			, begins "/"-			, ends "/"-			, contains "//"-			, ends "."-			, contains "@{"-			, null s-			]-		contains v = v `isInfixOf` s-		ends v = v `isSuffixOf` s-		begins v = v `isPrefixOf` s+  where+	illegal =+		[ any ("." `isPrefixOf`) pathbits+		, any (".lock" `isSuffixOf`) pathbits+		, not allowonelevel && length pathbits < 2+		, contains ".."+		, any (\c -> contains [c]) illegalchars+		, begins "/"+		, ends "/"+		, contains "//"+		, ends "."+		, contains "@{"+		, null s+		]+	contains v = v `isInfixOf` s+	ends v = v `isSuffixOf` s+	begins v = v `isPrefixOf` s -		pathbits = split "/" s-		illegalchars = " ~^:?*[\\" ++ controlchars-		controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)]+	pathbits = split "/" s+	illegalchars = " ~^:?*[\\" ++ controlchars+	controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)]
Git/Sha.hs view
@@ -11,11 +11,11 @@ import Git.Types  {- Runs an action that causes a git subcommand to emit a Sha, and strips-   any trailing newline, returning the sha. -}+ - any trailing newline, returning the sha. -} getSha :: String -> IO String -> IO Sha getSha subcommand a = maybe bad return =<< extractSha <$> a-	where-		bad = error $ "failed to read sha from git " ++ subcommand+  where+	bad = error $ "failed to read sha from git " ++ subcommand  {- Extracts the Sha from a string. There can be a trailing newline after  - it, but nothing else. -}@@ -24,12 +24,12 @@ 	| len == shaSize = val s 	| len == shaSize + 1 && length s' == shaSize = val s' 	| otherwise = Nothing-	where-		len = length s-		s' = firstLine s-		val v-			| all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v-			| otherwise = Nothing+  where+	len = length s+	s' = firstLine s+	val v+		| all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v+		| otherwise = Nothing  {- Size of a git sha. -} shaSize :: Int
Git/UnionMerge.hs view
@@ -62,11 +62,11 @@ 	(diff, cleanup) <- pipeNullSplit (map Param differ) repo 	go diff 	void $ cleanup-	where-		go [] = noop-		go (info:file:rest) = mergeFile info file ch repo >>=-			maybe (go rest) (\l -> streamer l >> go rest)-		go (_:[]) = error $ "parse error " ++ show differ+  where+	go [] = noop+	go (info:file:rest) = mergeFile info file ch repo >>=+		maybe (go rest) (\l -> streamer l >> go rest)+	go (_:[]) = error $ "parse error " ++ show differ  {- Given an info line from a git raw diff, and the filename, generates  - a line suitable for update-index that union merges the two sides of the@@ -78,16 +78,16 @@ 	shas -> use 		=<< either return (\s -> hashObject BlobObject (unlines s) repo) 		=<< calcMerge . zip shas <$> mapM getcontents shas-	where-		[_colonmode, _bmode, asha, bsha, _status] = words info-		use sha = return $ Just $-			updateIndexLine sha FileBlob $ 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-		-- are no decoding errors. Note that this works because-		-- hashObject sets fileEncoding on its write handle.-		getcontents s = lines . encodeW8 . L.unpack <$> catObject h s+  where+	[_colonmode, _bmode, asha, bsha, _status] = words info+	use sha = return $ Just $+		updateIndexLine sha FileBlob $ 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+	-- are no decoding errors. Note that this works because+	-- hashObject sets fileEncoding on its write handle.+	getcontents s = lines . encodeW8 . L.unpack <$> catObject h s  {- Calculates a union merge between a list of refs, with contents.  -@@ -98,7 +98,7 @@ calcMerge shacontents 	| null reuseable = Right $ new 	| otherwise = Left $ fst $ Prelude.head reuseable-	where-		reuseable = filter (\c -> sorteduniq (snd c) == new) shacontents-		new = sorteduniq $ concat $ map snd shacontents-		sorteduniq = S.toList . S.fromList+  where+	reuseable = filter (\c -> sorteduniq (snd c) == new) shacontents+	new = sorteduniq $ concat $ map snd shacontents+	sorteduniq = S.toList . S.fromList
Git/UpdateIndex.hs view
@@ -38,12 +38,12 @@ 	fileEncoding h 	forM_ as (stream h) 	hClose h-	where-		params = map Param ["update-index", "-z", "--index-info"]-		stream h a = a (streamer h)-		streamer h s = do-			hPutStr h s-			hPutStr h "\0"+  where+	params = map Param ["update-index", "-z", "--index-info"]+	stream h a = a (streamer h)+	streamer h s = do+		hPutStr h s+		hPutStr h "\0"  {- A streamer that adds the current tree for a ref. Useful for eg, copying  - and modifying branches. -}@@ -52,8 +52,8 @@ 	(s, cleanup) <- pipeNullSplit params repo 	mapM_ streamer s 	void $ cleanup-	where-		params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]+  where+	params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]  {- Generates a line suitable to be fed into update-index, to add  - a given file with a given sha. -}
Git/Url.hs view
@@ -28,13 +28,13 @@  - <http://trac.haskell.org/network/ticket/40> -} uriRegName' :: URIAuth -> String uriRegName' a = fixup $ uriRegName a-	where-		fixup x@('[':rest)-			| rest !! len == ']' = take len rest-			| otherwise = x-			where-				len  = length rest - 1-		fixup x = x+  where+	fixup x@('[':rest)+		| rest !! len == ']' = take len rest+		| otherwise = x+	  where+		len  = length rest - 1+	fixup x = x  {- Hostname of an URL repo. -} host :: Repo -> String@@ -55,14 +55,14 @@ {- The full authority portion an URL repo. (ie, "user@host:port") -} authority :: Repo -> String authority = authpart assemble-	where-		assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a+  where+	assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a  {- Applies a function to extract part of the uriAuthority of an URL repo. -} authpart :: (URIAuth -> a) -> Repo -> a authpart a Repo { location = Url u } = a auth-	where-		auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)+  where+	auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u) authpart _ repo = notUrl repo  notUrl :: Repo -> a
Git/Version.hs view
@@ -26,13 +26,13 @@ normalize = sum . mult 1 . reverse . 		extend precision . take precision . 		map readi . split "."-	where-		extend n l = l ++ replicate (n - length l) 0-		mult _ [] = []-		mult n (x:xs) = (n*x) : mult (n*10^width) xs-		readi :: String -> Integer-		readi s = case reads s of-			((x,_):_) -> x-			_ -> 0-		precision = 10 -- number of segments of the version to compare-		width = length "yyyymmddhhmmss" -- maximum width of a segment+  where+	extend n l = l ++ replicate (n - length l) 0+	mult _ [] = []+	mult n (x:xs) = (n*x) : mult (n*10^width) xs+	readi :: String -> Integer+	readi s = case reads s of+		((x,_):_) -> x+		_ -> 0+	precision = 10 -- number of segments of the version to compare+	width = length "yyyymmddhhmmss" -- maximum width of a segment
GitAnnex.hs view
@@ -62,6 +62,8 @@ import qualified Command.AddUrl import qualified Command.Import import qualified Command.Map+import qualified Command.Direct+import qualified Command.Indirect import qualified Command.Upgrade import qualified Command.Version import qualified Command.Help@@ -118,6 +120,8 @@ 	, Command.Status.def 	, Command.Migrate.def 	, Command.Map.def+	, Command.Direct.def+	, Command.Indirect.def 	, Command.Upgrade.def 	, Command.Version.def 	, Command.Help.def@@ -166,12 +170,10 @@ 	, Option [] ["trust-glacier"] (NoArg (Annex.setFlag "trustglacier")) "Trust Amazon Glacier inventory" 	] ++ Option.matcher   where-	setnumcopies v = Annex.changeState $-		\s -> s { Annex.forcenumcopies = readish v }-	setgitconfig :: String -> Annex ()-	setgitconfig v = do-		newg <- inRepo $ Git.Config.store v-		Annex.changeState $ \s -> s { Annex.repo = newg }+	setnumcopies v = maybe noop+		(\n -> Annex.changeGitConfig $ \c -> c { annexNumCopies = n })+		(readish v)+	setgitconfig v = Annex.changeGitRepo =<< inRepo (Git.Config.store v)  header :: String header = "Usage: git-annex command [option ..]"
INSTALL view
@@ -2,7 +2,7 @@  [[!table format=dsv header=yes data=""" detailed instructions | quick install-[[OSX]]               | [download git-annex.app](http://downloads.kitenet.net/git-annex/OSX/git-annex.dmg.bz2) **beta; [[known_problems|/bugs/OSX_app_issues]]**+[[OSX]]               | [download git-annex.app](http://downloads.kitenet.net/git-annex/OSX/current/) [[Linux|linux_standalone]] | [download prebuilt linux tarball](http://downloads.kitenet.net/git-annex/linux/) [[Debian]]            | `apt-get install git-annex` [[Ubuntu]]            | `apt-get install git-annex`
Init.hs view
@@ -47,9 +47,9 @@ 	removeVersion  {- Will automatically initialize if there is already a git-annex-   branch from somewhere. Otherwise, require a manual init-   to avoid git-annex accidentially being run in git-   repos that did not intend to use it. -}+ - branch from somewhere. Otherwise, require a manual init+ - to avoid git-annex accidentially being run in git+ - repos that did not intend to use it. -} ensureInitialized :: Annex () ensureInitialized = getVersion >>= maybe needsinit checkVersion   where
Locations.hs view
@@ -11,6 +11,8 @@ 	keyPaths, 	keyPath, 	gitAnnexLocation,+	gitAnnexMapping,+	gitAnnexCache, 	annexLocations, 	annexLocation, 	gitAnnexDir,@@ -23,6 +25,7 @@ 	gitAnnexFsckState, 	gitAnnexTransferDir, 	gitAnnexCredsDir,+	gitAnnexMergeDir, 	gitAnnexJournalDir, 	gitAnnexJournalLock, 	gitAnnexIndex,@@ -107,6 +110,21 @@ 	check locs@(l:_) = fromMaybe l <$> firstM doesFileExist locs 	check [] = error "internal" +{- File that maps from a key to the file(s) in the git repository.+ - Used in direct mode. -}+gitAnnexMapping :: Key -> Git.Repo -> IO FilePath+gitAnnexMapping key r = do+	loc <- gitAnnexLocation key r +	return $ loc ++ ".map"++{- File that caches information about a key's content, used to determine+ - if a file has changed.+ - Used in direct mode. -}+gitAnnexCache :: Key -> Git.Repo -> IO FilePath+gitAnnexCache key r  = do+	loc <- gitAnnexLocation key r +	return $ loc ++ ".cache"+ {- The annex directory of a repository. -} gitAnnexDir :: Git.Repo -> FilePath gitAnnexDir r = addTrailingPathSeparator $ Git.localGitDir r </> annexDir@@ -143,6 +161,10 @@  - remotes. -} gitAnnexCredsDir :: Git.Repo -> FilePath gitAnnexCredsDir r = addTrailingPathSeparator $ gitAnnexDir r </> "creds"++{- .git/annex/merge/ is used for direct mode merges. -}+gitAnnexMergeDir :: Git.Repo -> FilePath+gitAnnexMergeDir r = addTrailingPathSeparator $ gitAnnexDir r </> "merge"  {- .git/annex/transfer/ is used to record keys currently  - being transferred, and other transfer bookkeeping info. -}
Logs/Location.hs view
@@ -15,6 +15,7 @@  module Logs.Location ( 	LogStatus(..),+	logStatus, 	logChange, 	loggedLocations, 	loggedKeys,@@ -26,6 +27,13 @@ import Common.Annex import qualified Annex.Branch import Logs.Presence+import Annex.UUID++{- Log a change in the presence of a key's value in current repository. -}+logStatus :: Key -> LogStatus -> Annex ()+logStatus key status = do+	u <- getUUID+	logChange key u status  {- Log a change in the presence of a key's value in a repository. -} logChange :: Key -> UUID -> LogStatus -> Annex ()
Logs/PreferredContent.hs view
@@ -91,7 +91,7 @@ makeMatcher groupmap u s 	| s == "standard" = standardMatcher groupmap u 	| null (lefts tokens) = Utility.Matcher.generate $ rights tokens- 	| otherwise = matchAll+	| otherwise = matchAll   where 	tokens = map (parseToken (Just u) groupmap) (tokenizeMatcher s)
Logs/Presence.hs view
@@ -13,7 +13,7 @@  module Logs.Presence ( 	LogStatus(..),-	LogLine,+	LogLine(LogLine), 	addLog, 	readLog, 	getLog,@@ -22,6 +22,7 @@ 	logNow, 	compactLog, 	currentLog,+	prop_parse_show_log, ) where  import Data.Time.Clock.POSIX@@ -36,10 +37,10 @@ 	date :: POSIXTime, 	status :: LogStatus, 	info :: String-} deriving (Eq)+} deriving (Eq, Show)  data LogStatus = InfoPresent | InfoMissing-	deriving (Eq)+	deriving (Eq, Show, Bounded, Enum)  addLog :: FilePath -> LogLine -> Annex () addLog file line = Annex.Branch.change file $ \s -> @@ -52,13 +53,15 @@  {- Parses a log file. Unparseable lines are ignored. -} parseLog :: String -> [LogLine]-parseLog = mapMaybe (parseline . words) . lines+parseLog = mapMaybe parseline . lines   where-	parseline (a:b:c:_) = do-		d <- parseTime defaultTimeLocale "%s%Qs" a-		s <- parsestatus b-		Just $ LogLine (utcTimeToPOSIXSeconds d) s c-	parseline _ = Nothing+	parseline l = LogLine+		<$> (utcTimeToPOSIXSeconds <$> parseTime defaultTimeLocale "%s%Qs" d)+		<*> parsestatus s+		<*> pure rest+	  where+		(d, pastd) = separate (== ' ') l+		(s, rest) = separate (== ' ') pastd 	parsestatus "1" = Just InfoPresent 	parsestatus "0" = Just InfoMissing 	parsestatus _ = Nothing@@ -70,6 +73,10 @@ 	genline (LogLine d s i) = unwords [show d, genstatus s, i] 	genstatus InfoPresent = "1" 	genstatus InfoMissing = "0"++-- for quickcheck+prop_parse_show_log :: [LogLine] -> Bool+prop_parse_show_log l = parseLog (showLog l) == l  {- Generates a new LogLine with the current date. -} logNow :: LogStatus -> String -> Annex LogLine
Logs/Remote.hs view
@@ -11,8 +11,11 @@ 	configSet, 	keyValToConfig, 	configToKeyVal,+	showConfig,+	parseConfig, -	prop_idempotent_configEscape+	prop_idempotent_configEscape,+	prop_parse_show_Config, ) where  import qualified Data.Map as M@@ -86,3 +89,12 @@ {- for quickcheck -} prop_idempotent_configEscape :: String -> Bool prop_idempotent_configEscape s = s == (configUnEscape . configEscape) s++prop_parse_show_Config :: RemoteConfig -> Bool+prop_parse_show_Config c+	-- whitespace and '=' are not supported in keys+	| any (\k -> any isSpace k || any (== '=') k) (M.keys c) = True+	| otherwise = parseConfig (showConfig c) ~~ Just c+  where+	normalize v = sort . M.toList <$> v+	a ~~ b = normalize a == normalize b
Logs/Transfer.hs view
@@ -293,7 +293,10 @@ 	<*> pure (if null filename then Nothing else Just filename) 	<*> pure False   where-	(firstline, filename) = separate (== '\n') s+	(firstline, rest) = separate (== '\n') s+	filename+		| end rest == "\n" = beginning rest+		| otherwise = rest 	bits = split " " firstline 	numbits = length bits 	time = if numbits > 0@@ -302,6 +305,15 @@ 	bytes = if numbits > 1 		then Just <$> readish =<< headMaybe (drop 1 bits) 		else pure Nothing -- not failure++{- for quickcheck -}+prop_read_write_transferinfo :: TransferInfo -> Bool+prop_read_write_transferinfo info+	| transferRemote info /= Nothing = True -- remote not stored+	| transferTid info /= Nothing = True -- tid not stored+	| otherwise = Just (info { transferPaused = False }) == info'+  where+	info' = readTransferInfo (transferPid info) (writeTransferInfo info)  parsePOSIXTime :: String -> Maybe POSIXTime parsePOSIXTime s = utcTimeToPOSIXSeconds
Logs/Trust.hs view
@@ -15,6 +15,8 @@ 	lookupTrust, 	trustMapLoad, 	trustMapRaw,+	+	prop_parse_show_TrustLog, ) where  import qualified Data.Map as M@@ -26,7 +28,6 @@ import qualified Annex import Logs.UUIDBased import Remote.List-import Config import qualified Types.Remote  {- Filename of trust.log. -}@@ -83,14 +84,14 @@ 	overrides <- Annex.getState Annex.forcetrust 	logged <- trustMapRaw 	configured <- M.fromList . catMaybes-		<$> (mapM configuredtrust =<< remoteList)+		<$> (map configuredtrust <$> remoteList) 	let m = M.union overrides $ M.union configured logged 	Annex.changeState $ \s -> s { Annex.trustmap = Just m } 	return m   where-	configuredtrust r = maybe Nothing (\l -> Just (Types.Remote.uuid r, l))-		<$> maybe Nothing readTrustLevel-			<$> getTrustLevel (Types.Remote.repo r)+	configuredtrust r = (\l -> Just (Types.Remote.uuid r, l))+		=<< readTrustLevel +		=<< remoteAnnexTrustLevel (Types.Remote.gitconfig r)  {- Does not include forcetrust or git config values, just those from the  - log file. -}@@ -113,3 +114,8 @@ showTrustLog UnTrusted = "0" showTrustLog DeadTrusted = "X" showTrustLog SemiTrusted = "?"++prop_parse_show_TrustLog :: Bool+prop_parse_show_TrustLog = all check [minBound .. maxBound]+  where+	check l = parseTrustLog (showTrustLog l) == l
Makefile view
@@ -26,14 +26,19 @@ else # BSD system THREADFLAGS=-threaded-OPTFLAGS?=-DWITH_KQUEUE-clibs=Utility/libdiskfree.o Utility/libmounts.o Utility/libkqueue.o ifeq ($(OS),Darwin)+# use fsevents for OSX+OPTFLAGS?=-DWITH_FSEVENTS+clibs=Utility/libdiskfree.o Utility/libmounts.o # Ensure OSX compiler builds for 32 bit when using 32 bit ghc GHCARCH:=$(shell ghc -e 'print System.Info.arch') ifeq ($(GHCARCH),i386) CFLAGS=-Wall -m32 endif+else+# BSD system with kqueue+OPTFLAGS?=-DWITH_KQUEUE+clibs=Utility/libdiskfree.o Utility/libmounts.o Utility/libkqueue.o endif endif endif@@ -143,9 +148,6 @@ hackage: sdist 	@cabal upload dist/*.tar.gz -THIRDPARTY_BINS=git curl lsof xargs rsync uuid wget gpg \-	sha1sum sha224sum sha256sum sha384sum sha512sum cp ssh sh- LINUXSTANDALONE_DEST=$(GIT_ANNEX_TMP_BUILD_DIR)/git-annex.linux linuxstandalone: 	$(MAKE) git-annex@@ -160,19 +162,11 @@ 	ln -sf git-annex "$(LINUXSTANDALONE_DEST)/bin/git-annex-shell" 	zcat standalone/licences.gz > $(LINUXSTANDALONE_DEST)/LICENSE -	set -e; \-	for bin in $(THIRDPARTY_BINS); do \-		p="$$(which "$$bin")"; \-		if [ -z "$$p" ]; then \-			echo "** missing $$bin" >&2; \-			exit 1; \-		else \-			cp "$$p" "$(LINUXSTANDALONE_DEST)/bin/"; \-		fi; \-	done+	runghc Build/Standalone.hs "$(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" 	 	touch "$(LINUXSTANDALONE_DEST)/libdirs.tmp" 	for lib in $$(ldd "$(LINUXSTANDALONE_DEST)"/bin/* $$(find "$(LINUXSTANDALONE_DEST)"/git-core/ -type f) | grep -v -f standalone/linux/glibc-libs | grep -v "not a dynamic executable" | egrep '^	' | sed 's/^\t//' | sed 's/.*=> //' | cut -d ' ' -f 1 | sort | uniq); do \@@ -206,18 +200,10 @@ 	gzcat standalone/licences.gz > $(OSXAPP_BASE)/LICENSE 	cp $(OSXAPP_BASE)/LICENSE $(GIT_ANNEX_TMP_BUILD_DIR)/build-dmg/LICENSE.txt -	set -e; \-	for bin in $(THIRDPARTY_BINS); do \-		p="$$(which "$$bin")"; \-		if [ -z "$$p" ]; then \-			echo "** missing $$bin" >&2; \-			exit 1; \-		else \-			cp "$$p" "$(OSXAPP_BASE)"; \-		fi; \-	done+	runghc Build/Standalone.hs $(OSXAPP_BASE)  	(cd "$(shell git --exec-path)" && tar c .) | (cd "$(OSXAPP_BASE)" && tar x)+	install -d "$(OSXAPP_BASE)/templates"  	runghc Build/OSXMkLibs.hs $(OSXAPP_BASE) 	rm -f tmp/git-annex.dmg
Remote.hs view
@@ -27,7 +27,7 @@ 	byCost, 	prettyPrintUUIDs, 	prettyListUUIDs,-	repoFromUUID,+	remoteFromUUID, 	remotesWithUUID, 	remotesWithoutUUID, 	keyLocations,@@ -51,9 +51,8 @@ import Annex.UUID import Logs.UUID import Logs.Trust-import Logs.Location+import Logs.Location hiding (logStatus) import Remote.List-import qualified Git  {- Map from UUIDs of Remotes to a calculated value. -} remoteMap :: (Remote -> a) -> Annex (M.Map UUID a)@@ -147,15 +146,12 @@ 	  where 		n = finddescription m u -{- Gets the git repo associated with a UUID.+{- Gets the remote associated with a UUID.  - There's no associated remote when this is the UUID of the local repo. -}-repoFromUUID :: UUID -> Annex (Git.Repo, Maybe Remote)-repoFromUUID u = ifM ((==) u <$> getUUID)-	( (,) <$> gitRepo <*> pure Nothing-	, do-		remote <- fromMaybe (error "Unknown UUID") . M.lookup u-			<$> remoteMap id-		return (repo remote, Just remote)+remoteFromUUID :: UUID -> Annex (Maybe Remote)+remoteFromUUID u = ifM ((==) u <$> getUUID)+	( return Nothing+	, Just . fromMaybe (error "Unknown UUID") . M.lookup u <$> remoteMap id 	)  {- Filters a list of remotes to ones that have the listed uuids. -}
Remote/Bup.hs view
@@ -38,35 +38,41 @@ 	setup = bupSetup } -gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote-gen r u c = do-	buprepo <- getRemoteConfig r "buprepo" (error "missing buprepo")-	cst <- remoteCost r (if bupLocal buprepo then semiCheapRemoteCost else expensiveRemoteCost)+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote+gen r u c gc = do 	bupr <- liftIO $ bup2GitRemote buprepo+	cst <- remoteCost gc $+		if bupLocal buprepo+			then semiCheapRemoteCost+			else expensiveRemoteCost 	(u', bupr') <- getBupUUID bupr u 	+	let new = Remote+		{ uuid = u'+		, cost = cst+		, name = Git.repoDescribe r+		, storeKey = store new buprepo+		, retrieveKeyFile = retrieve buprepo+		, retrieveKeyFileCheap = retrieveCheap buprepo+		, removeKey = remove+		, hasKey = checkPresent r bupr'+		, hasKeyCheap = bupLocal buprepo+		, whereisKey = Nothing+		, config = c+		, repo = r+		, gitconfig = gc+		, localpath = if bupLocal buprepo && not (null buprepo)+			then Just buprepo+			else Nothing+		, remotetype = remote+		, readonly = False+		} 	return $ encryptableRemote c-		(storeEncrypted r buprepo)+		(storeEncrypted new buprepo) 		(retrieveEncrypted buprepo)-		Remote-			{ uuid = u'-			, cost = cst-			, name = Git.repoDescribe r- 			, storeKey = store r buprepo-			, retrieveKeyFile = retrieve buprepo-			, retrieveKeyFileCheap = retrieveCheap buprepo-			, removeKey = remove-			, hasKey = checkPresent r bupr'-			, hasKeyCheap = bupLocal buprepo-			, whereisKey = Nothing-			, config = c-			, repo = r-			, localpath = if bupLocal buprepo && not (null buprepo)-				then Just buprepo-				else Nothing-			, remotetype = remote-			, readonly = False-			}+		new+  where+	buprepo = fromMaybe (error "missing buprepo") $ remoteAnnexBupRepo gc  bupSetup :: UUID -> RemoteConfig -> Annex RemoteConfig bupSetup u c = do@@ -106,21 +112,20 @@ 		ExitSuccess -> return True 		_ -> return False -bupSplitParams :: Git.Repo -> BupRepo -> Key -> [CommandParam] -> Annex [CommandParam]+bupSplitParams :: Remote -> BupRepo -> Key -> [CommandParam] -> Annex [CommandParam] bupSplitParams r buprepo k src = do-	o <- getRemoteConfig r "bup-split-options" ""-	let os = map Param $ words o+	let os = map Param $ remoteAnnexBupSplitOptions $ gitconfig r 	showOutput -- make way for bup output 	return $ bupParams "split" buprepo  		(os ++ [Param "-n", Param (bupRef k)] ++ src) -store :: Git.Repo -> BupRepo -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool+store :: Remote -> BupRepo -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool store r buprepo k _f _p = do 	src <- inRepo $ gitAnnexLocation k 	params <- bupSplitParams r buprepo k [File src] 	liftIO $ boolSystem "bup" params -storeEncrypted :: Git.Repo -> BupRepo -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool+storeEncrypted :: Remote -> BupRepo -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool storeEncrypted r buprepo (cipher, enck) k _p = do 	src <- inRepo $ gitAnnexLocation k 	params <- bupSplitParams r buprepo enck []
Remote/Directory.hs view
@@ -33,10 +33,9 @@ 	setup = directorySetup } -gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote-gen r u c = do-	dir <- getRemoteConfig r "directory" (error "missing directory")-	cst <- remoteCost r cheapRemoteCost+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote+gen r u c gc = do+	cst <- remoteCost gc cheapRemoteCost 	let chunksize = chunkSize c 	return $ encryptableRemote c 		(storeEncrypted dir chunksize)@@ -45,7 +44,7 @@ 			uuid = u, 			cost = cst, 			name = Git.repoDescribe r,- 			storeKey = store dir chunksize,+			storeKey = store dir chunksize, 			retrieveKeyFile = retrieve dir chunksize, 			retrieveKeyFileCheap = retrieveCheap dir chunksize, 			removeKey = remove dir,@@ -54,10 +53,13 @@ 			whereisKey = Nothing, 			config = M.empty, 			repo = r,+			gitconfig = gc, 			localpath = Just dir, 			readonly = False, 			remotetype = remote 		}+  where+	dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc  directorySetup :: UUID -> RemoteConfig -> Annex RemoteConfig directorySetup u c = do
Remote/Git.hs view
@@ -19,6 +19,7 @@ import Utility.Rsync import Remote.Helper.Ssh import Types.Remote+import Types.GitConfig import qualified Git import qualified Git.Config import qualified Git.Construct@@ -37,6 +38,7 @@ import Init import Types.Key import qualified Fields+import Logs.Location  import Control.Concurrent import Control.Concurrent.MSampleVar@@ -72,10 +74,11 @@  - cached UUID value. -} configRead :: Git.Repo -> Annex Git.Repo configRead r = do-	notignored <- repoNotIgnored r+	g <- fromRepo id+	let c = extractRemoteGitConfig g (Git.repoDescribe r) 	u <- getRepoUUID r-	case (repoCheap r, notignored, u) of-		(_, False, _) -> return r+	case (repoCheap r, remoteAnnexIgnore c, u) of+		(_, True, _) -> return r 		(True, _, _) -> tryGitConfigRead r 		(False, _, NoUUID) -> tryGitConfigRead r 		_ -> return r@@ -83,29 +86,32 @@ repoCheap :: Git.Repo -> Bool repoCheap = not . Git.repoIsUrl -gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote-gen r u _ = new <$> remoteCost r defcst+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote+gen r u _ gc = go <$> remoteCost gc defcst   where 	defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost-	new cst = Remote -		{ uuid = u-		, cost = cst-		, name = Git.repoDescribe r-		, storeKey = copyToRemote r-		, retrieveKeyFile = copyFromRemote r-		, retrieveKeyFileCheap = copyFromRemoteCheap r-		, removeKey = dropKey r-		, hasKey = inAnnex r-		, hasKeyCheap = repoCheap r-		, whereisKey = Nothing-		, config = M.empty-		, localpath = if Git.repoIsLocal r || Git.repoIsLocalUnknown r-			then Just $ Git.repoPath r-			else Nothing-		, repo = r-		, readonly = Git.repoIsHttp r-		, remotetype = remote-		}+	go cst = new+	  where+		new = Remote +			{ uuid = u+			, cost = cst+			, name = Git.repoDescribe r+			, storeKey = copyToRemote new+			, retrieveKeyFile = copyFromRemote new+			, retrieveKeyFileCheap = copyFromRemoteCheap new+			, removeKey = dropKey new+			, hasKey = inAnnex r+			, hasKeyCheap = repoCheap r+			, whereisKey = Nothing+			, config = M.empty+			, localpath = if Git.repoIsLocal r || Git.repoIsLocalUnknown r+				then Just $ Git.repoPath r+				else Nothing+			, repo = r+			, gitconfig = gc+			, readonly = Git.repoIsHttp r+			, remotetype = remote+			}  {- Checks relatively inexpensively if a repository is available for use. -} repoAvail :: Git.Repo -> Annex Bool@@ -235,40 +241,40 @@   where 	tourl l = Git.repoLocation r ++ "/" ++ l -dropKey :: Git.Repo -> Key -> Annex Bool+dropKey :: Remote -> Key -> Annex Bool dropKey r key-	| not $ Git.repoIsUrl r =-		guardUsable r False $ commitOnCleanup r $ liftIO $ onLocal r $ do+	| not $ Git.repoIsUrl (repo r) =+		guardUsable (repo r) False $ commitOnCleanup r $ liftIO $ onLocal (repo r) $ do 			ensureInitialized 			whenM (Annex.Content.inAnnex key) $ do 				Annex.Content.lockContent key $ 					Annex.Content.removeAnnex key-				Annex.Content.logStatus key InfoMissing+				logStatus key InfoMissing 				Annex.Content.saveState True 			return True-	| Git.repoIsHttp r = error "dropping from http repo not supported"-	| otherwise = commitOnCleanup r $ onRemote r (boolSystem, False) "dropkey"+	| Git.repoIsHttp (repo r) = error "dropping from http repo not supported"+	| otherwise = commitOnCleanup r $ onRemote (repo r) (boolSystem, False) "dropkey" 		[ Params "--quiet --force" 		, Param $ key2file key 		] 		[]  {- Tries to copy a key's content from a remote's annex to a file. -}-copyFromRemote :: Git.Repo -> Key -> AssociatedFile -> FilePath -> Annex Bool+copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool copyFromRemote r key file dest-	| not $ Git.repoIsUrl r = guardUsable r False $ do-		params <- rsyncParams r+	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do+		let params = rsyncParams r 		u <- getUUID 		-- run copy from perspective of remote-		liftIO $ onLocal r $ do+		liftIO $ onLocal (repo r) $ do 			ensureInitialized-			loc <- inRepo $ gitAnnexLocation key-			upload u key file noRetry $-				rsyncOrCopyFile params loc dest-	| Git.repoIsSsh r = feedprogressback $ \feeder -> +			Annex.Content.sendAnnex key $ \object ->+				upload u key file noRetry $+					rsyncOrCopyFile params object dest+	| Git.repoIsSsh (repo r) = feedprogressback $ \feeder ->  		rsyncHelper (Just feeder)  			=<< rsyncParamsRemote r True key dest file-	| Git.repoIsHttp r = Annex.Content.downloadUrl (keyUrls r key) dest+	| Git.repoIsHttp (repo r) = Annex.Content.downloadUrl (keyUrls (repo r) key) dest 	| otherwise = error "copying from non-ssh, non-http repo not supported"   where 	{- Feed local rsync's progress info back to the remote,@@ -288,7 +294,7 @@ 		u <- getUUID 		let fields = (Fields.remoteUUID, fromUUID u) 			: maybe [] (\f -> [(Fields.associatedFile, f)]) file-		Just (cmd, params) <- git_annex_shell r "transferinfo" +		Just (cmd, params) <- git_annex_shell (repo r) "transferinfo"  			[Param $ key2file key] fields 		v <- liftIO $ newEmptySV 		tid <- liftIO $ forkIO $ void $ tryIO $ do@@ -309,12 +315,12 @@ 		let feeder = writeSV v 		bracketIO noop (const $ tryIO $ killThread tid) (a feeder) -copyFromRemoteCheap :: Git.Repo -> Key -> FilePath -> Annex Bool+copyFromRemoteCheap :: Remote -> Key -> FilePath -> Annex Bool copyFromRemoteCheap r key file-	| not $ Git.repoIsUrl r = guardUsable r False $ do-		loc <- liftIO $ gitAnnexLocation key r+	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do+		loc <- liftIO $ gitAnnexLocation key (repo r) 		liftIO $ catchBoolIO $ createSymbolicLink loc file >> return True-	| Git.repoIsSsh r =+	| Git.repoIsSsh (repo r) = 		ifM (Annex.Content.preseedTmp key file) 			( copyFromRemote r key Nothing file 			, return False@@ -322,26 +328,28 @@ 	| otherwise = return False  {- Tries to copy a key's content to a remote's annex. -}-copyToRemote :: Git.Repo -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool+copyToRemote :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool copyToRemote r key file p-	| not $ Git.repoIsUrl r = guardUsable r False $ commitOnCleanup r $ do-		keysrc <- inRepo $ gitAnnexLocation key-		params <- rsyncParams r+	| not $ Git.repoIsUrl (repo r) =+		guardUsable (repo r) False $ commitOnCleanup r $ copylocal+	| Git.repoIsSsh (repo r) = commitOnCleanup r $+		Annex.Content.sendAnnex key $ \object ->+			rsyncHelper (Just p) =<< rsyncParamsRemote r False key object file+	| otherwise = error "copying to non-ssh repo not supported"+  where+	copylocal = Annex.Content.sendAnnex key $ \object -> do+		let params = rsyncParams r 		u <- getUUID 		-- run copy from perspective of remote-		liftIO $ onLocal r $ ifM (Annex.Content.inAnnex key)+		liftIO $ onLocal (repo r) $ ifM (Annex.Content.inAnnex key) 			( return False 			, do 				ensureInitialized 				download u key file noRetry $ 					Annex.Content.saveState True `after` 						Annex.Content.getViaTmp key-							(\d -> rsyncOrCopyFile params keysrc d p)+							(\d -> rsyncOrCopyFile params object d p) 			)-	| Git.repoIsSsh r = commitOnCleanup r $ do-		keysrc <- inRepo $ gitAnnexLocation key-		rsyncHelper (Just p) =<< rsyncParamsRemote r False key keysrc file-	| otherwise = error "copying to non-ssh repo not supported"  rsyncHelper :: Maybe MeterUpdate -> [CommandParam] -> Annex Bool rsyncHelper callback params = do@@ -381,18 +389,18 @@  {- Generates rsync parameters that ssh to the remote and asks it  - to either receive or send the key's content. -}-rsyncParamsRemote :: Git.Repo -> Bool -> Key -> FilePath -> AssociatedFile -> Annex [CommandParam]+rsyncParamsRemote :: Remote -> Bool -> Key -> FilePath -> AssociatedFile -> Annex [CommandParam] rsyncParamsRemote r sending key file afile = do 	u <- getUUID 	let fields = (Fields.remoteUUID, fromUUID u) 		: maybe [] (\f -> [(Fields.associatedFile, f)]) afile-	Just (shellcmd, shellparams) <- git_annex_shell r+	Just (shellcmd, shellparams) <- git_annex_shell (repo r) 		(if sending then "sendkey" else "recvkey") 		[ Param $ key2file key ] 		fields 	-- Convert the ssh command into rsync command line. 	let eparam = rsyncShell (Param shellcmd:shellparams)-	o <- rsyncParams r+	let o = rsyncParams r 	if sending 		then return $ o ++ rsyncopts eparam dummy (File file) 		else return $ o ++ rsyncopts eparam (File file) dummy@@ -409,25 +417,22 @@ 	 - even though this hostname will never be used. -} 	dummy = Param "dummy:" -rsyncParams :: Git.Repo -> Annex [CommandParam]-rsyncParams r = do-	o <- getRemoteConfig r "rsync-options" ""-	return $ options ++ map Param (words o)-  where- 	-- --inplace to resume partial files-	options = [Params "-p --progress --inplace"]+-- --inplace to resume partial files+rsyncParams :: Remote -> [CommandParam]+rsyncParams r = [Params "-p --progress --inplace"] +++	map Param (remoteAnnexRsyncOptions $ gitconfig r) -commitOnCleanup :: Git.Repo -> Annex a -> Annex a+commitOnCleanup :: Remote -> Annex a -> Annex a commitOnCleanup r a = go `after` a   where-	go = Annex.addCleanup (Git.repoLocation r) cleanup+	go = Annex.addCleanup (Git.repoLocation $ repo r) cleanup 	cleanup-		| not $ Git.repoIsUrl r = liftIO $ onLocal r $+		| not $ Git.repoIsUrl (repo r) = liftIO $ onLocal (repo r) $ 			doQuietSideAction $ 				Annex.Branch.commit "update" 		| otherwise = void $ do 			Just (shellcmd, shellparams) <--				git_annex_shell r "commit" [] []+				git_annex_shell (repo r) "commit" [] [] 			 			-- Throw away stderr, since the remote may not 			-- have a new enough git-annex shell to
Remote/Glacier.hs view
@@ -37,8 +37,8 @@ 	setup = glacierSetup } -gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote-gen r u c = new <$> remoteCost r veryExpensiveRemoteCost+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote+gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost   where 	new cst = encryptableRemote c 		(storeEncrypted this)@@ -49,7 +49,7 @@ 			uuid = u, 			cost = cst, 			name = Git.repoDescribe r,- 			storeKey = store this,+			storeKey = store this, 			retrieveKeyFile = retrieve this, 			retrieveKeyFileCheap = retrieveCheap this, 			removeKey = remove this,@@ -58,6 +58,7 @@ 			whereisKey = Nothing, 			config = c, 			repo = r,+			gitconfig = gc, 			localpath = Nothing, 			readonly = False, 			remotetype = remote
Remote/Helper/Chunked.hs view
@@ -59,13 +59,12 @@  - and passes it to an action, which should chunk and store the data,  - and return the destinations it stored to, or [] on error. Then  - calls the storer to write the chunk count (if chunking). Finally, the- - fianlizer is called to rename the tmp into the dest + - finalizer is called to rename the tmp into the dest   - (and do any other cleanup).  -} storeChunks :: Key -> FilePath -> FilePath -> ChunkSize -> ([FilePath] -> IO [FilePath]) -> (FilePath -> String -> IO ()) -> (FilePath -> FilePath -> IO ()) -> IO Bool-storeChunks key tmp dest chunksize storer recorder finalizer =-	either (const $ return False) return-		=<< (E.try go :: IO (Either E.SomeException Bool))+storeChunks key tmp dest chunksize storer recorder finalizer = either onerr return+	=<< (E.try go :: IO (Either E.SomeException Bool))   where 	go = do 		stored <- storer tmpdests@@ -74,6 +73,9 @@ 			recorder chunkcount (show $ length stored) 		finalizer tmp dest 		return (not $ null stored)+	onerr e = do+		print e+		return False  	basef = tmp ++ keyFile key 	tmpdests@@ -92,21 +94,22 @@  - writes a whole L.ByteString at a time.  -} storeChunked :: ChunkSize -> [FilePath] -> (FilePath -> L.ByteString -> IO ()) -> L.ByteString -> IO [FilePath]-storeChunked chunksize dests storer content =-	either (const $ return []) return-		=<< (E.try (go chunksize dests) :: IO (Either E.SomeException [FilePath]))+storeChunked chunksize dests storer content = either onerr return+	=<< (E.try (go chunksize dests) :: IO (Either E.SomeException [FilePath]))   where 	go _ [] = return [] -- no dests!?- 	go Nothing (d:_) = do 		storer d content 		return [d]- 	go (Just sz) _ 		-- always write a chunk, even if the data is 0 bytes 		| L.null content = go Nothing dests 		| otherwise = storechunks sz [] dests content 		+	onerr e = do+		print e+		return []+	 	storechunks _ _ [] _ = return [] -- ran out of dests 	storechunks sz useddests (d:ds) b 		| L.null b = return $ reverse useddests
Remote/Helper/Hooks.hs view
@@ -13,15 +13,16 @@ import Types.Remote import qualified Annex import Annex.LockPool-import Config import Annex.Perms  {- Modifies a remote's access functions to first run the  - annex-start-command hook, and trigger annex-stop-command on shutdown.  - This way, the hooks are only run when a remote is actively being used.  -}-addHooks :: Remote -> Annex Remote-addHooks r = addHooks' r <$> lookupHook r "start" <*> lookupHook r "stop"+addHooks :: Remote -> Remote+addHooks r = addHooks' r+	(remoteAnnexStartCommand $ gitconfig r)+	(remoteAnnexStopCommand $ gitconfig r) addHooks' :: Remote -> Maybe String -> Maybe String -> Remote addHooks' r Nothing Nothing = r addHooks' r starthook stophook = r'@@ -83,10 +84,3 @@ 			Left _ -> noop 			Right _ -> run stophook 		liftIO $ closeFd fd--lookupHook :: Remote -> String -> Annex (Maybe String)-lookupHook r n = go =<< getRemoteConfig (repo r) hookname ""-  where-	go "" = return Nothing-	go command = return $ Just command-	hookname =  n ++ "-command"
Remote/Helper/Ssh.hs view
@@ -10,17 +10,19 @@ import Common.Annex import qualified Git import qualified Git.Url-import Config import Annex.UUID import Annex.Ssh import Fields+import Types.GitConfig  {- Generates parameters to ssh to a repository's host and run a command.  - Caller is responsible for doing any neccessary shellEscaping of the  - passed command. -} sshToRepo :: Git.Repo -> [CommandParam] -> Annex [CommandParam] sshToRepo repo sshcmd = do-	opts <- map Param . words <$> getRemoteConfig repo "ssh-options" ""+	g <- fromRepo id+	let c = extractRemoteGitConfig g (Git.repoDescribe repo)+	let opts = map Param $ remoteAnnexSshOptions c 	params <- sshParams (Git.Url.hostuser repo, Git.Url.port repo) opts 	return $ params ++ sshcmd
Remote/Hook.hs view
@@ -29,10 +29,9 @@ 	setup = hookSetup } -gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote-gen r u c = do-	hooktype <- getRemoteConfig r "hooktype" (error "missing hooktype")-	cst <- remoteCost r expensiveRemoteCost+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote+gen r u c gc = do+	cst <- remoteCost gc expensiveRemoteCost 	return $ encryptableRemote c 		(storeEncrypted hooktype) 		(retrieveEncrypted hooktype)@@ -40,7 +39,7 @@ 			uuid = u, 			cost = cst, 			name = Git.repoDescribe r,- 			storeKey = store hooktype,+			storeKey = store hooktype, 			retrieveKeyFile = retrieve hooktype, 			retrieveKeyFileCheap = retrieveCheap hooktype, 			removeKey = remove hooktype,@@ -50,9 +49,12 @@ 			config = M.empty, 			localpath = Nothing, 			repo = r,+			gitconfig = gc, 			readonly = False, 			remotetype = remote 		}+  where+	hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc	  hookSetup :: UUID -> RemoteConfig -> Annex RemoteConfig hookSetup u c = do
Remote/List.hs view
@@ -15,8 +15,8 @@ import qualified Annex import Logs.Remote import Types.Remote+import Types.GitConfig import Annex.UUID-import Config import Remote.Helper.Hooks import qualified Git import qualified Git.Config@@ -81,7 +81,10 @@ remoteGen :: (M.Map UUID RemoteConfig) -> RemoteType -> Git.Repo -> Annex Remote remoteGen m t r = do 	u <- getRepoUUID r-	addHooks =<< generate t r u (fromMaybe M.empty $ M.lookup u m)+	g <- fromRepo id+	let gc = extractRemoteGitConfig g (Git.repoDescribe r)+	let c = fromMaybe M.empty $ M.lookup u m+	addHooks <$> generate t r u c gc  {- Updates a local git Remote, re-reading its git config. -} updateRemote :: Remote -> Annex Remote@@ -97,7 +100,7 @@  {- All remotes that are not ignored. -} enabledRemoteList :: Annex [Remote]-enabledRemoteList = filterM (repoNotIgnored . repo) =<< remoteList+enabledRemoteList = filter (not . remoteAnnexIgnore . gitconfig) <$> remoteList  {- Checks if a remote is a special remote -} specialRemote :: Remote -> Bool
Remote/Rsync.hs view
@@ -38,10 +38,9 @@ 	setup = rsyncSetup } -gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote-gen r u c = do-	o <- genRsyncOpts r c-	cst <- remoteCost r expensiveRemoteCost+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote+gen r u c gc = do+	cst <- remoteCost gc expensiveRemoteCost 	return $ encryptableRemote c 		(storeEncrypted o) 		(retrieveEncrypted o)@@ -49,7 +48,7 @@ 			{ uuid = u 			, cost = cst 			, name = Git.repoDescribe r- 			, storeKey = store o+			, storeKey = store o 			, retrieveKeyFile = retrieve o 			, retrieveKeyFileCheap = retrieveCheap o 			, removeKey = remove o@@ -58,27 +57,24 @@ 			, whereisKey = Nothing 			, config = M.empty 			, repo = r+			, gitconfig = gc 			, localpath = if rsyncUrlIsPath $ rsyncUrl o 				then Just $ rsyncUrl o 				else Nothing 			, readonly = False 			, remotetype = remote 			}--genRsyncOpts :: Git.Repo -> RemoteConfig -> Annex RsyncOpts-genRsyncOpts r c = do-	url <- getRemoteConfig r "rsyncurl" (error "missing rsyncurl")-	opts <- map Param . filter safe . words-		<$> getRemoteConfig r "rsync-options" ""-	let escape = M.lookup "shellescape" c /= Just "no"-	return $ RsyncOpts url opts escape   where-	safe o+	o = RsyncOpts url opts escape+	url = fromMaybe (error "missing rsyncurl") $ remoteAnnexRsyncUrl gc+	opts = map Param $ filter safe $ remoteAnnexRsyncOptions gc+	escape = M.lookup "shellescape" c /= Just "no"+	safe opt 		-- Don't allow user to pass --delete to rsync; 		-- that could cause it to delete other keys 		-- in the same hash bucket as a key it sends.-		| o == "--delete" = False-		| o == "--delete-excluded" = False+		| opt == "--delete" = False+		| opt == "--delete-excluded" = False 		| otherwise = True  rsyncSetup :: UUID -> RemoteConfig -> Annex RemoteConfig@@ -168,7 +164,7 @@ 	-- to connect, and the file not being present. 	Right <$> check   where- 	check = untilTrue (rsyncUrls o k) $ \u -> +	check = untilTrue (rsyncUrls o k) $ \u ->  		liftIO $ catchBoolIO $ do 			withQuietOutput createProcessSuccess $ 				proc "rsync" $ toCommand $@@ -210,8 +206,8 @@ 	ps = rsyncOptions o ++ defaultParams ++ params  {- To send a single key is slightly tricky; need to build up a temporary-   directory structure to pass to rsync so it can create the hash-   directories. -}+ - directory structure to pass to rsync so it can create the hash+ - directories. -} rsyncSend :: RsyncOpts -> MeterUpdate -> Key -> FilePath -> Annex Bool rsyncSend o callback k src = withRsyncScratchDir $ \tmp -> do 	let dest = tmp </> Prelude.head (keyPaths k)@@ -220,7 +216,7 @@ 	rsyncRemote o (Just callback) 		[ Param "--recursive" 		, partialParams- 		  -- tmp/ to send contents of tmp dir+		-- tmp/ to send contents of tmp dir 		, Param $ addTrailingPathSeparator tmp 		, Param $ rsyncUrl o 		]
Remote/S3.hs view
@@ -37,8 +37,8 @@ 	setup = s3Setup } -gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote-gen r u c = new <$> remoteCost r expensiveRemoteCost+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote+gen r u c gc = new <$> remoteCost gc expensiveRemoteCost   where 	new cst = encryptableRemote c 		(storeEncrypted this)@@ -49,7 +49,7 @@ 			uuid = u, 			cost = cst, 			name = Git.repoDescribe r,- 			storeKey = store this,+			storeKey = store this, 			retrieveKeyFile = retrieve this, 			retrieveKeyFileCheap = retrieveCheap this, 			removeKey = remove this,@@ -58,6 +58,7 @@ 			whereisKey = Nothing, 			config = c, 			repo = r,+			gitconfig = gc, 			localpath = Nothing, 			readonly = False, 			remotetype = remote
Remote/Web.hs view
@@ -35,8 +35,8 @@ 	r <- liftIO $ Git.Construct.remoteNamed "web" Git.Construct.fromUnknown 	return [r] -gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote-gen r _ _ = +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote+gen r _ _ gc =  	return Remote { 		uuid = webUUID, 		cost = expensiveRemoteCost,@@ -49,6 +49,7 @@ 		hasKeyCheap = False, 		whereisKey = Just getUrls, 		config = M.empty,+		gitconfig = gc, 		localpath = Nothing, 		repo = r, 		readonly = True,
Remote/WebDAV.hs view
@@ -43,8 +43,8 @@ 	setup = webdavSetup } -gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote-gen r u c = new <$> remoteCost r expensiveRemoteCost+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote+gen r u c gc = new <$> remoteCost gc expensiveRemoteCost   where 	new cst = encryptableRemote c 		(storeEncrypted this)@@ -55,7 +55,7 @@ 			uuid = u, 			cost = cst, 			name = Git.repoDescribe r,- 			storeKey = store this,+			storeKey = store this, 			retrieveKeyFile = retrieve this, 			retrieveKeyFileCheap = retrieveCheap this, 			removeKey = remove this,@@ -64,6 +64,7 @@ 			whereisKey = Nothing, 			config = c, 			repo = r,+			gitconfig = gc, 			localpath = Nothing, 			readonly = False, 			remotetype = remote@@ -314,10 +315,10 @@  davCreds :: UUID -> CredPairStorage davCreds u = CredPairStorage-        { credPairFile = fromUUID u-        , credPairEnvironment = ("WEBDAV_USERNAME", "WEBDAV_PASSWORD")-        , credPairRemoteKey = Just "davcreds"-        }+	{ credPairFile = fromUUID u+	, credPairEnvironment = ("WEBDAV_USERNAME", "WEBDAV_PASSWORD")+	, credPairRemoteKey = Just "davcreds"+	}  setCredsEnv :: (String, String) -> IO () setCredsEnv creds = setEnvCredPair creds $ davCreds undefined
Types.hs view
@@ -10,6 +10,8 @@ 	Backend, 	Key, 	UUID(..),+	GitConfig(..),+	RemoteGitConfig(..), 	Remote, 	RemoteType, 	Option,@@ -18,6 +20,7 @@  import Annex import Types.Backend+import Types.GitConfig import Types.Key import Types.UUID import Types.Remote
Types/Backend.hs view
@@ -16,6 +16,7 @@ 	{ name :: String 	, getKey :: KeySource -> a (Maybe Key)  	, fsckKey :: Maybe (Key -> FilePath -> a Bool)+	, canUpgradeKey :: Maybe (Key -> Bool) 	}  instance Show (BackendA a) where
Types/BranchState.hs view
@@ -7,14 +7,10 @@  module Types.BranchState where -data BranchState = BranchState {-	branchUpdated :: Bool, -- has the branch been updated this run?-	indexChecked :: Bool, -- has the index file been checked to exist?--	-- the content of one file is cached-	cachedFile :: Maybe FilePath,-	cachedContent :: String-}+data BranchState = BranchState+	{ branchUpdated :: Bool -- has the branch been updated this run?+	, indexChecked :: Bool -- has the index file been checked to exist?+	}  startBranchState :: BranchState-startBranchState = BranchState False False Nothing ""+startBranchState = BranchState False False
Types/Command.hs view
@@ -22,9 +22,9 @@  -    a list of start stage actions. -} type CommandSeek = [String] -> Annex [CommandStart] {- c. The start stage is run before anything is printed about the-  -   command, is passed some input, and can early abort it-  -   if the input does not make sense. It should run quickly and-  -   should not modify Annex state. -}+ -    command, is passed some input, and can early abort it+ -    if the input does not make sense. It should run quickly and+ -    should not modify Annex state. -} type CommandStart = Annex (Maybe CommandPerform) {- d. The perform stage is run after a message is printed about the command  -    being run, and it should be where the bulk of the work happens. -}
+ Types/GitConfig.hs view
@@ -0,0 +1,122 @@+{- git-annex configuration+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Types.GitConfig ( +	GitConfig(..),+	extractGitConfig,+	RemoteGitConfig(..),+	extractRemoteGitConfig,+) where++import Common+import qualified Git+import qualified Git.Config+import Utility.DataUnits++{- Main git-annex settings. Each setting corresponds to a git-config key+ - such as annex.foo -}+data GitConfig = GitConfig+	{ annexVersion :: Maybe String+	, annexNumCopies :: Int+	, annexDiskReserve :: Integer+	, annexDirect :: Bool+	, annexBackends :: [String]+	, annexQueueSize :: Maybe Int+	, annexBloomCapacity :: Maybe Int+	, annexBloomAccuracy :: Maybe Int+	, annexSshCaching :: Maybe Bool+	, annexAlwaysCommit :: Bool+	, annexDelayAdd :: Maybe Int+	, annexHttpHeaders :: [String]+	, annexHttpHeadersCommand :: Maybe String+	}++extractGitConfig :: Git.Repo -> GitConfig+extractGitConfig r = GitConfig+	{ annexVersion = notempty $ getmaybe "version"+	, annexNumCopies = get "numcopies" 1+	, annexDiskReserve = fromMaybe onemegabyte $+		readSize dataUnits =<< getmaybe "diskreserve"+	, annexDirect = getbool "direct" False+	, annexBackends = fromMaybe [] $ words <$> getmaybe "backends"+	, annexQueueSize = getmayberead "queuesize"+	, annexBloomCapacity = getmayberead "bloomcapacity"+	, annexBloomAccuracy = getmayberead "bloomaccuracy"+	, annexSshCaching = getmaybebool "sshcaching"+	, annexAlwaysCommit = getbool "alwayscommit" True+	, annexDelayAdd = getmayberead "delayadd"+	, annexHttpHeaders = getlist "http-headers"+	, annexHttpHeadersCommand = getmaybe "http-headers-command"+	}+  where+	get k def = fromMaybe def $ getmayberead k+	getbool k def = fromMaybe def $ getmaybebool k+	getmaybebool k = Git.Config.isTrue =<< getmaybe k+	getmayberead k = readish =<< getmaybe k+	getmaybe k = Git.Config.getMaybe (key k) r+	getlist k = Git.Config.getList (key k) r++	key k = "annex." ++ k+			+	onemegabyte = 1000000++{- Per-remote git-annex settings. Each setting corresponds to a git-config+ - key such as <remote>.annex-foo, or if that is not set, a default from+ - annex.foo -}+data RemoteGitConfig = RemoteGitConfig+	{ remoteAnnexCost :: Maybe Int+	, remoteAnnexCostCommand :: Maybe String+	, remoteAnnexIgnore :: Bool+	, remoteAnnexSync :: Bool+	, remoteAnnexTrustLevel :: Maybe String+	, remoteAnnexStartCommand :: Maybe String+	, remoteAnnexStopCommand :: Maybe String++	-- these settings are specific to particular types of remotes+	, remoteAnnexSshOptions :: [String]+	, remoteAnnexRsyncOptions :: [String]+	, remoteAnnexRsyncUrl :: Maybe String+	, remoteAnnexBupRepo :: Maybe String+	, remoteAnnexBupSplitOptions :: [String]+	, remoteAnnexDirectory :: Maybe FilePath+	, remoteAnnexHookType :: Maybe String+	}++extractRemoteGitConfig :: Git.Repo -> String -> RemoteGitConfig+extractRemoteGitConfig r remotename = RemoteGitConfig+	{ remoteAnnexCost = getmayberead "cost"+	, remoteAnnexCostCommand = notempty $ getmaybe "cost-command"+	, remoteAnnexIgnore = getbool "ignore" False+	, remoteAnnexSync = getbool "sync" True+	, remoteAnnexTrustLevel = notempty $ getmaybe "trustlevel"+	, remoteAnnexStartCommand = notempty $ getmaybe "start-command"+	, remoteAnnexStopCommand = notempty $ getmaybe "stop-command"++	, remoteAnnexSshOptions = getoptions "ssh-options"+	, remoteAnnexRsyncOptions = getoptions "rsync-options"+	, remoteAnnexRsyncUrl = notempty $ getmaybe "rsyncurl"+	, remoteAnnexBupRepo = getmaybe "buprepo"+	, remoteAnnexBupSplitOptions = getoptions "bup-split-options"+	, remoteAnnexDirectory = notempty $ getmaybe "directory"+	, remoteAnnexHookType = notempty $ getmaybe "hooktype"+	}+  where+	getbool k def = fromMaybe def $ getmaybebool k+	getmaybebool k = Git.Config.isTrue =<< getmaybe k+	getmayberead k = readish =<< getmaybe k+	getmaybe k = maybe (Git.Config.getMaybe (key k) r) Just $+		Git.Config.getMaybe (remotekey k) r+	getoptions k = fromMaybe [] $ words <$> getmaybe k++	key k = "annex." ++ k+	remotekey k = "remote." ++ remotename ++ ".annex-" ++ k++notempty :: Maybe String -> Maybe String	+notempty Nothing = Nothing+notempty (Just "") = Nothing+notempty (Just s) = Just s+
Types/Remote.hs view
@@ -16,6 +16,7 @@ import Types.Key import Types.UUID import Types.Meters+import Types.GitConfig  type RemoteConfigKey = String type RemoteConfig = M.Map RemoteConfigKey String@@ -27,7 +28,7 @@ 	-- enumerates remotes of this type 	enumerate :: a [Git.Repo], 	-- generates a remote of this type-	generate :: Git.Repo -> UUID -> RemoteConfig -> a (RemoteA a),+	generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> a (RemoteA a), 	-- initializes or changes a remote 	setup :: UUID -> RemoteConfig -> a RemoteConfig }@@ -64,8 +65,10 @@ 	whereisKey :: Maybe (Key -> a [String]), 	-- a Remote has a persistent configuration store 	config :: RemoteConfig,-	-- git configuration for the remote+	-- git repo for the Remote 	repo :: Git.Repo,+	-- a Remote's configuration from git+	gitconfig :: RemoteGitConfig, 	-- a Remote can be assocated with a specific local filesystem path 	localpath :: Maybe FilePath, 	-- a Remote can be known to be readonly
Types/TrustLevel.hs view
@@ -10,6 +10,7 @@ 	TrustMap, 	readTrustLevel, 	showTrustLevel,+	prop_read_show_TrustLevel ) where  import qualified Data.Map as M@@ -17,7 +18,7 @@ import Types.UUID  data TrustLevel = Trusted | SemiTrusted | UnTrusted | DeadTrusted-	deriving (Eq, Enum, Ord)+	deriving (Eq, Enum, Ord, Bounded)  type TrustMap = M.Map UUID TrustLevel @@ -33,3 +34,8 @@ showTrustLevel UnTrusted = "untrusted" showTrustLevel SemiTrusted = "semitrusted" showTrustLevel DeadTrusted = "dead"++prop_read_show_TrustLevel :: Bool+prop_read_show_TrustLevel = all check [minBound .. maxBound]+  where+	check l = readTrustLevel (showTrustLevel l) == Just l
Utility/Base64.hs view
@@ -15,4 +15,4 @@  fromB64 :: String -> String fromB64 s = maybe bad w82s $ decode s-	where bad = error "bad base64 encoded data"+  where bad = error "bad base64 encoded data"
Utility/CopyFile.hs view
@@ -17,9 +17,9 @@ 	whenM (doesFileExist dest) $ 		removeFile dest 	boolSystem "cp" $ params ++ [File src, File dest]-	where-		params = map snd $ filter fst-			[ (SysConfig.cp_reflink_auto, Param "--reflink=auto")-			, (SysConfig.cp_a, Param "-a")-			, (SysConfig.cp_p && not SysConfig.cp_a, Param "-p")-			]+  where+	params = map snd $ filter fst+		[ (SysConfig.cp_reflink_auto, Param "--reflink=auto")+		, (SysConfig.cp_a, Param "-a")+		, (SysConfig.cp_p && not SysConfig.cp_a, Param "-p")+		]
Utility/DBus.hs view
@@ -57,10 +57,10 @@ 			e <- takeMVar mv 			disconnect client 			throw e-	where-		threadrunner storeerr io = loop-			where-				loop = catchClientError (io >> loop) storeerr+  where+	threadrunner storeerr io = loop+	  where+		loop = catchClientError (io >> loop) storeerr  {- Connects to the bus, and runs the client action.  -@@ -73,10 +73,10 @@ 	{- runClient can fail with not just ClientError, but also other 	 - things, if dbus is not running. Let async exceptions through. -} 	runClient getaddr clientaction `catchNonAsync` retry-	where-		retry e = do-			v' <- onretry e v-			persistentClient getaddr v' onretry clientaction+  where+	retry e = do+		v' <- onretry e v+		persistentClient getaddr v' onretry clientaction  {- Catches only ClientError -} catchClientError :: IO () -> (ClientError -> IO ()) -> IO ()
Utility/Daemon.hs view
@@ -22,27 +22,27 @@ 	maybe noop checkalreadyrunning pidfile 	_ <- forkProcess child1 	out-	where-		checkalreadyrunning f = maybe noop (const $ alreadyRunning) -			=<< checkDaemon f-		child1 = do-			_ <- createSession-			_ <- forkProcess child2-			out-		child2 = do-			maybe noop lockPidFile pidfile -			when changedirectory $-				setCurrentDirectory "/"-			nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags-			_ <- redir nullfd stdInput-			mapM_ (redir logfd) [stdOutput, stdError]-			closeFd logfd-			a-			out-		redir newh h = do-			closeFd h-			dupTo newh h-		out = exitImmediately ExitSuccess+  where+	checkalreadyrunning f = maybe noop (const $ alreadyRunning) +		=<< checkDaemon f+	child1 = do+		_ <- createSession+		_ <- forkProcess child2+		out+	child2 = do+		maybe noop lockPidFile pidfile +		when changedirectory $+			setCurrentDirectory "/"+		nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags+		_ <- redir nullfd stdInput+		mapM_ (redir logfd) [stdOutput, stdError]+		closeFd logfd+		a+		out+	redir newh h = do+		closeFd h+		dupTo newh h+	out = exitImmediately ExitSuccess  {- Locks the pid file, with an exclusive, non-blocking lock.  - Writes the pid to the file, fully atomically.@@ -62,8 +62,8 @@ 			_ <- fdWrite fd' =<< show <$> getProcessID 			renameFile newfile file 			closeFd fd-	where-		newfile = file ++ ".new"+  where+	newfile = file ++ ".new"  alreadyRunning :: IO () alreadyRunning = error "Daemon is already running."@@ -82,19 +82,19 @@ 			p <- readish <$> readFile pidfile 			return $ check locked p 		Nothing -> return Nothing-	where-		check Nothing _ = Nothing-		check _ Nothing = Nothing-		check (Just (pid, _)) (Just pid')-			| pid == pid' = Just pid-			| otherwise = error $-				"stale pid in " ++ pidfile ++ -				" (got " ++ show pid' ++ -				"; expected " ++ show pid ++ " )"+  where+	check Nothing _ = Nothing+	check _ Nothing = Nothing+	check (Just (pid, _)) (Just pid')+		| pid == pid' = Just pid+		| otherwise = error $+			"stale pid in " ++ pidfile ++ +			" (got " ++ show pid' ++ +			"; expected " ++ show pid ++ " )"  {- Stops the daemon, safely. -} stopDaemon :: FilePath -> IO () stopDaemon pidfile = go =<< checkDaemon pidfile-	where-		go Nothing = noop-		go (Just pid) = signalProcess sigTERM pid+  where+	go Nothing = noop+	go (Just pid) = signalProcess sigTERM pid
Utility/DataUnits.hs view
@@ -72,9 +72,9 @@ 	, Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committe 	, Unit (p 0) "B" "byte" 	]-	where-		p :: Integer -> Integer-		p n = 1000^n+  where+	p :: Integer -> Integer+	p n = 1000^n  {- Memory units are (stupidly named) powers of 2. -} memoryUnits :: [Unit]@@ -89,9 +89,9 @@ 	, Unit (p 1) "KiB" "kibibyte" 	, Unit (p 0) "B" "byte" 	]-	where-		p :: Integer -> Integer-		p n = 2^(n*10)+  where+	p :: Integer -> Integer+	p n = 2^(n*10)  {- Bandwidth units are only measured in bits if you're some crazy telco. -} bandwidthUnits :: [Unit]@@ -100,32 +100,32 @@ {- Do you yearn for the days when men were men and megabytes were megabytes? -} oldSchoolUnits :: [Unit] oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits-	where-		mingle (Unit _ a n, Unit s' _ _) = Unit s' a n+  where+	mingle (Unit _ a n, Unit s' _ _) = Unit s' a n  {- approximate display of a particular number of bytes -} roughSize :: [Unit] -> Bool -> ByteSize -> String roughSize units abbrev i 	| i < 0 = '-' : findUnit units' (negate i) 	| otherwise = findUnit units' i-	where-		units' = reverse $ sort units -- largest first+  where+	units' = reverse $ sort units -- largest first -		findUnit (u@(Unit s _ _):us) i'-			| i' >= s = showUnit i' u-			| otherwise = findUnit us i'-		findUnit [] i' = showUnit i' (last units') -- bytes+	findUnit (u@(Unit s _ _):us) i'+		| i' >= s = showUnit i' u+		| otherwise = findUnit us i'+	findUnit [] i' = showUnit i' (last units') -- bytes -		showUnit i' (Unit s a n) = let num = chop i' s in-			show num ++ " " ++-			(if abbrev then a else plural num n)+	showUnit i' (Unit s a n) = let num = chop i' s in+		show num ++ " " +++		(if abbrev then a else plural num n) -		chop :: Integer -> Integer -> Integer-		chop i' d = round $ (fromInteger i' :: Double) / fromInteger d+	chop :: Integer -> Integer -> Integer+	chop i' d = round $ (fromInteger i' :: Double) / fromInteger d -		plural n u-			| n == 1 = u-			| otherwise = u ++ "s"+	plural n u+		| n == 1 = u+		| otherwise = u ++ "s"  {- displays comparison of two sizes -} compareSizes :: [Unit] -> Bool -> ByteSize -> ByteSize -> String@@ -139,22 +139,22 @@ readSize units input 	| null parsednum || null parsedunit = Nothing 	| otherwise = Just $ round $ number * fromIntegral multiplier-	where-		(number, rest) = head parsednum-		multiplier = head parsedunit-		unitname = takeWhile isAlpha $ dropWhile isSpace rest+  where+	(number, rest) = head parsednum+	multiplier = head parsedunit+	unitname = takeWhile isAlpha $ dropWhile isSpace rest -		parsednum = reads input :: [(Double, String)]-		parsedunit = lookupUnit units unitname+	parsednum = reads input :: [(Double, String)]+	parsedunit = lookupUnit units unitname -		lookupUnit _ [] = [1] -- no unit given, assume bytes-		lookupUnit [] _ = []-		lookupUnit (Unit s a n:us) v-			| a ~~ v || n ~~ v = [s]-			| plural n ~~ v || a ~~ byteabbrev v = [s]-			| otherwise = lookupUnit us v+	lookupUnit _ [] = [1] -- no unit given, assume bytes+	lookupUnit [] _ = []+	lookupUnit (Unit s a n:us) v+		| a ~~ v || n ~~ v = [s]+		| plural n ~~ v || a ~~ byteabbrev v = [s]+		| otherwise = lookupUnit us v 		-		a ~~ b = map toLower a == map toLower b+	a ~~ b = map toLower a == map toLower b 		-		plural n = n ++ "s"-		byteabbrev a = a ++ "b"+	plural n = n ++ "s"+	byteabbrev a = a ++ "b"
Utility/DirWatcher.hs view
@@ -1,7 +1,8 @@ {- generic directory watching interface  -- - Uses either inotify or kqueue to watch a directory (and subdirectories)- - for changes, and runs hooks for different sorts of events as they occur.+ - Uses inotify, or kqueue, or fsevents to watch a directory+ - (and subdirectories) for changes, and runs hooks for different+ - sorts of events as they occur.  -  - Copyright 2012 Joey Hess <joey@kitenet.net>  -@@ -22,11 +23,15 @@ import qualified Utility.Kqueue as Kqueue import Control.Concurrent #endif+#if WITH_FSEVENTS+import qualified Utility.FSEvents as FSEvents+import qualified System.OSX.FSEvents as FSEvents+#endif  type Pruner = FilePath -> Bool  canWatch :: Bool-#if (WITH_INOTIFY || WITH_KQUEUE)+#if (WITH_INOTIFY || WITH_KQUEUE || WITH_FSEVENTS) canWatch = True #else #if defined linux_HOST_OS@@ -35,15 +40,14 @@ canWatch = False #endif -/* With inotify, discrete events will be received when making multiple changes- * to the same filename. For example, adding it, deleting it, and adding it- * again will be three events.- * - * OTOH, with kqueue, often only one event is received, indicating the most- * recent state of the file.- */+{- With inotify, discrete events will be received when making multiple changes+ - to the same filename. For example, adding it, deleting it, and adding it+ - again will be three events.+ - + - OTOH, with kqueue, often only one event is received, indicating the most+ - recent state of the file. -} eventsCoalesce :: Bool-#if WITH_INOTIFY+#if (WITH_INOTIFY || WITH_FSEVENTS) eventsCoalesce = False #else #if WITH_KQUEUE@@ -53,16 +57,18 @@ #endif #endif -/* With inotify, file closing is tracked to some extent, so an add event- * will always be received for a file once its writer closes it, and- * (typically) not before. This may mean multiple add events for the same file.- *- * OTOH, with kqueue, add events will often be received while a file is- * still being written to, and then no add event will be received once the- * writer closes it.- */+{- With inotify, file closing is tracked to some extent, so an add event+ - will always be received for a file once its writer closes it, and+ - (typically) not before. This may mean multiple add events for the same file.+ - + - fsevents behaves similarly, although different event types are used for+ - creating and modification of the file.+ -+ - OTOH, with kqueue, add events will often be received while a file is+ - still being written to, and then no add event will be received once the+ - writer closes it. -} closingTracked :: Bool-#if WITH_INOTIFY+#if (WITH_INOTIFY || WITH_FSEVENTS) closingTracked = True #else #if WITH_KQUEUE@@ -72,11 +78,12 @@ #endif #endif -/* With inotify, modifications to existing files can be tracked.- * Kqueue does not support this.- */+{- With inotify, modifications to existing files can be tracked.+ - Kqueue does not support this.+ - Fsevents generates events when an existing file is reopened and rewritten,+ - but not necessarily when it's opened once and modified repeatedly. -} modifyTracked :: Bool-#if WITH_INOTIFY+#if (WITH_INOTIFY || WITH_FSEVENTS) modifyTracked = True #else #if WITH_KQUEUE@@ -86,11 +93,11 @@ #endif #endif -/* Starts a watcher thread. The runStartup action is passed a scanner action- * to run, that will return once the initial directory scan is complete.- * Once runStartup returns, the watcher thread continues running,- * and processing events. Returns a DirWatcherHandle that can be used- * to shutdown later.  */+{- Starts a watcher thread. The runstartup action is passed a scanner action+ - to run, that will return once the initial directory scan is complete.+ - Once runstartup returns, the watcher thread continues running,+ - and processing events. Returns a DirWatcherHandle that can be used+ - to shutdown later. -} #if WITH_INOTIFY type DirWatcherHandle = INotify.INotify watchDir :: FilePath -> Pruner -> WatchHooks -> (IO () -> IO ()) -> IO DirWatcherHandle@@ -106,11 +113,18 @@ 	kq <- runstartup $ Kqueue.initKqueue dir prune 	forkIO $ Kqueue.runHooks kq hooks #else+#if WITH_FSEVENTS+type DirWatcherHandle = FSEvents.EventStream+watchDir :: FilePath -> Pruner -> WatchHooks -> (IO FSEvents.EventStream -> IO FSEvents.EventStream) -> IO DirWatcherHandle+watchDir dir prune hooks runstartup =+	runstartup $ FSEvents.watchDir dir prune hooks+#else type DirWatcherHandle = () watchDir :: FilePath -> Pruner -> WatchHooks -> (IO () -> IO ()) -> IO DirWatcherHandle watchDir = undefined #endif #endif+#endif  #if WITH_INOTIFY stopWatchDir :: DirWatcherHandle -> IO ()@@ -120,7 +134,12 @@ stopWatchDir :: DirWatcherHandle -> IO () stopWatchDir = killThread #else+#if WITH_FSEVENTS stopWatchDir :: DirWatcherHandle -> IO ()+stopWatchDir = FSEvents.eventStreamDestroy+#else+stopWatchDir :: DirWatcherHandle -> IO () stopWatchDir = undefined+#endif #endif #endif
Utility/Directory.hs view
@@ -44,46 +44,46 @@ 	(files, dirs') <- collect [] [] =<< catchDefaultIO [] (dirContents dir) 	files' <- dirContentsRecursive' (dirs' ++ dirs) 	return (files ++ files')-	where-		collect files dirs' [] = return (reverse files, reverse dirs')-		collect files dirs' (entry:entries)-			| dirCruft entry = collect files dirs' entries-			| otherwise = do-				ifM (doesDirectoryExist entry)-					( collect files (entry:dirs') entries-					, collect (entry:files) dirs' entries-					)			+  where+	collect files dirs' [] = return (reverse files, reverse dirs')+	collect files dirs' (entry:entries)+		| dirCruft entry = collect files dirs' entries+		| otherwise = do+			ifM (doesDirectoryExist entry)+				( collect files (entry:dirs') entries+				, collect (entry:files) dirs' entries+				)			  {- Moves one filename to another.  - First tries a rename, but falls back to moving across devices if needed. -} moveFile :: FilePath -> FilePath -> IO () moveFile src dest = tryIO (rename src dest) >>= onrename-	where-		onrename (Right _) = noop-		onrename (Left e)-			| isPermissionError e = rethrow-			| isDoesNotExistError e = rethrow-			| otherwise = do-				-- copyFile is likely not as optimised as-				-- the mv command, so we'll use the latter.-				-- But, mv will move into a directory if-				-- dest is one, which is not desired.-				whenM (isdir dest) rethrow-				viaTmp mv dest undefined-			where-				rethrow = throw e-				mv tmp _ = do-					ok <- boolSystem "mv" [Param "-f",-						Param src, Param tmp]-					unless ok $ do-						-- delete any partial-						_ <- tryIO $ removeFile tmp-						rethrow-		isdir f = do-			r <- tryIO $ getFileStatus f-			case r of-				(Left _) -> return False-				(Right s) -> return $ isDirectory s+  where+	onrename (Right _) = noop+	onrename (Left e)+		| isPermissionError e = rethrow+		| isDoesNotExistError e = rethrow+		| otherwise = do+			-- copyFile is likely not as optimised as+			-- the mv command, so we'll use the latter.+			-- But, mv will move into a directory if+			-- dest is one, which is not desired.+			whenM (isdir dest) rethrow+			viaTmp mv dest undefined+	  where+		rethrow = throw e+		mv tmp _ = do+			ok <- boolSystem "mv" [Param "-f", Param src, Param tmp]+			unless ok $ do+				-- delete any partial+				_ <- tryIO $ removeFile tmp+				rethrow++	isdir f = do+		r <- tryIO $ getFileStatus f+		case r of+			(Left _) -> return False+			(Right s) -> return $ isDirectory s  {- Removes a file, which may or may not exist.  -
Utility/DiskFree.hs view
@@ -25,5 +25,5 @@ 		( return $ Just $ toInteger free 		, return Nothing 		)-	where-		safeErrno (Errno v) = v == 0+  where+	safeErrno (Errno v) = v == 0
Utility/Dot.hs view
@@ -10,9 +10,9 @@ {- generates a graph description from a list of lines -} graph :: [String] -> String graph s = unlines $ [header] ++ map indent s ++ [footer]-	where-		header = "digraph map {"-		footer= "}"+  where+	header = "digraph map {"+	footer= "}"  {- a node in the graph -} graphNode :: String -> String -> String@@ -21,8 +21,8 @@ {- an edge between two nodes -} graphEdge :: String -> String -> Maybe String -> String graphEdge fromid toid desc = indent $ maybe edge (`label` edge) desc-	where-		edge = quote fromid ++ " -> " ++ quote toid+  where+	edge = quote fromid ++ " -> " ++ quote toid  {- adds a label to a node or edge -} label :: String -> String -> String@@ -46,18 +46,18 @@ 		ii setcolor ++ 		ii s ++ 		indent "}"-	where-		-- the "cluster_" makes dot draw a box-		name = quote ("cluster_" ++ subid)-		setlabel = "label=" ++ quote l-		setfilled = "style=" ++ quote "filled"-		setcolor = "fillcolor=" ++ quote color-		ii x = indent (indent x) ++ "\n"+  where+	-- the "cluster_" makes dot draw a box+	name = quote ("cluster_" ++ subid)+	setlabel = "label=" ++ quote l+	setfilled = "style=" ++ quote "filled"+	setcolor = "fillcolor=" ++ quote color+	ii x = indent (indent x) ++ "\n"  indent ::String -> String indent s = '\t' : s  quote :: String -> String quote s = "\"" ++ s' ++ "\""-	where-		s' = filter (/= '"') s+  where+	s' = filter (/= '"') s
+ Utility/FSEvents.hs view
@@ -0,0 +1,92 @@+{- FSEvents interface+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.FSEvents where++import Common hiding (isDirectory)+import Utility.Types.DirWatcher++import System.OSX.FSEvents+import qualified System.Posix.Files as Files+import Data.Bits ((.&.))++watchDir :: FilePath -> (FilePath -> Bool) -> WatchHooks -> IO EventStream+watchDir dir ignored hooks = do+	unlessM fileLevelEventsSupported $+		error "Need at least OSX 10.7.0 for file-level FSEvents"+	scan dir+	eventStreamCreate [dir] 1.0 True True True handle+  where+	handle evt+		| ignoredPath ignored (eventPath evt) = noop+		| otherwise = do+			{- More than one flag may be set, if events occurred+			 - close together. +			 - +			 - Order is important..+			 - If a file is added and then deleted, we'll see it's+			 - not present, and addHook won't run.+			 - OTOH, if a file is deleted and then re-added,+			 - the delHook will run first, followed by the addHook.+			 -}++			when (hasflag eventFlagItemRemoved) $+				if hasflag eventFlagItemIsDir+					then runhook delDirHook Nothing+					else runhook delHook Nothing+			when (hasflag eventFlagItemCreated) $+				maybe noop handleadd =<< getstatus (eventPath evt)+			{- When a file or dir is renamed, a rename event is+			 - received for both its old and its new name. -}+			when (hasflag eventFlagItemRenamed) $+				if hasflag eventFlagItemIsDir+					then ifM (doesDirectoryExist $ eventPath evt)+						( scan $ eventPath evt+						, runhook delDirHook Nothing+						)+					else maybe (runhook delHook Nothing) handleadd+						=<< getstatus (eventPath evt)+			{- Add hooks are run when a file is modified for +			 - compatability with INotify, which calls the add+			 - hook when a file is closed, and so tends to call+			 - both add and modify for file modifications. -}+			when (hasflag eventFlagItemModified && not (hasflag eventFlagItemIsDir)) $ do+				ms <- getstatus $ eventPath evt+				maybe noop handleadd ms+				runhook modifyHook ms+	  where+		hasflag f = eventFlags evt .&. f /= 0+		runhook h s = maybe noop (\a -> a (eventPath evt) s) (h hooks)+		handleadd s+			| Files.isSymbolicLink s = runhook addSymlinkHook $ Just s+			| Files.isRegularFile s = runhook addHook $ Just s+			| otherwise = noop+	+	scan d = unless (ignoredPath ignored d) $+		mapM_ go =<< dirContentsRecursive d+	  where		+		go f+			| ignoredPath ignored f = noop+			| otherwise = do+				ms <- getstatus f+				case ms of+					Nothing -> noop+					Just s+						| Files.isSymbolicLink s ->+							runhook addSymlinkHook ms+						| Files.isRegularFile s ->+							runhook addHook ms+						| otherwise ->+							noop+		  where+			runhook h s = maybe noop (\a -> a f s) (h hooks)+		+	getstatus = catchMaybeIO . getSymbolicLinkStatus++{- Check each component of the path to see if it's ignored. -}+ignoredPath :: (FilePath -> Bool) -> FilePath -> Bool+ignoredPath ignored = any ignored . map dropTrailingPathSeparator . splitPath
Utility/FileMode.hs view
@@ -37,10 +37,10 @@ {- Runs an action after changing a file's mode, then restores the old mode. -} withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a withModifiedFileMode file convert a = bracket setup cleanup go-	where-		setup = modifyFileMode' file convert-		cleanup oldmode = modifyFileMode file (const oldmode)-		go _ = a+  where+	setup = modifyFileMode' file convert+	cleanup oldmode = modifyFileMode file (const oldmode)+	go _ = a  writeModes :: [FileMode] writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode]@@ -83,10 +83,10 @@ noUmask mode a 	| mode == stdFileMode = a 	| otherwise = bracket setup cleanup go-	where-		setup = setFileCreationMask nullFileMode-		cleanup = setFileCreationMask-		go _ = a+  where+	setup = setFileCreationMask nullFileMode+	cleanup = setFileCreationMask+	go _ = a  combineModes :: [FileMode] -> FileMode combineModes [] = undefined
Utility/Format.hs view
@@ -43,19 +43,19 @@  - This can be repeatedly called, efficiently. -} format :: Format -> Variables -> String format f vars = concatMap expand f-	where-		expand (Const s) = s-		expand (Var name j)-			| "escaped_" `isPrefixOf` name =-				justify j $ encode_c_strict $-					getvar $ drop (length "escaped_") name-			| otherwise = justify j $ getvar name-		getvar name = fromMaybe "" $ M.lookup name vars-		justify UnJustified s        = s-		justify (LeftJustified i) s  = s ++ pad i s-		justify (RightJustified i) s = pad i s ++ s-		pad i s = take (i - length s) spaces-		spaces = repeat ' '+  where+	expand (Const s) = s+	expand (Var name j)+		| "escaped_" `isPrefixOf` name =+			justify j $ encode_c_strict $+				getvar $ drop (length "escaped_") name+		| otherwise = justify j $ getvar name+	getvar name = fromMaybe "" $ M.lookup name vars+	justify UnJustified s        = s+	justify (LeftJustified i) s  = s ++ pad i s+	justify (RightJustified i) s = pad i s ++ s+	pad i s = take (i - length s) spaces+	spaces = repeat ' '  {- Generates a Format that can be used to expand variables in a  - format string, such as "${foo} ${bar;10} ${baz;-10}\n"@@ -64,37 +64,37 @@  -} gen :: FormatString -> Format gen = filter (not . empty) . fuse [] . scan [] . decode_c-	where-		-- The Format is built up in reverse, for efficiency,-		-- and can have many adjacent Consts. Fusing it fixes both-		-- problems.-		fuse f [] = f-		fuse f (Const c1:Const c2:vs) = fuse f $ Const (c2++c1) : vs-		fuse f (v:vs) = fuse (v:f) vs+  where+	-- The Format is built up in reverse, for efficiency,+	-- and can have many adjacent Consts. Fusing it fixes both+	-- problems.+	fuse f [] = f+	fuse f (Const c1:Const c2:vs) = fuse f $ Const (c2++c1) : vs+	fuse f (v:vs) = fuse (v:f) vs -		scan f (a:b:cs)-			| a == '$' && b == '{' = invar f [] cs-			| otherwise = scan (Const [a] : f ) (b:cs)-		scan f v = Const v : f+	scan f (a:b:cs)+		| a == '$' && b == '{' = invar f [] cs+		| otherwise = scan (Const [a] : f ) (b:cs)+	scan f v = Const v : f -		invar f var [] = Const (novar var) : f-		invar f var (c:cs)-			| c == '}' = foundvar f var UnJustified cs-			| isAlphaNum c || c == '_' = invar f (c:var) cs-			| c == ';' = inpad "" f var cs-			| otherwise = scan ((Const $ novar $ c:var):f) cs+	invar f var [] = Const (novar var) : f+	invar f var (c:cs)+		| c == '}' = foundvar f var UnJustified cs+		| isAlphaNum c || c == '_' = invar f (c:var) cs+		| c == ';' = inpad "" f var cs+		| otherwise = scan ((Const $ novar $ c:var):f) cs -		inpad p f var (c:cs)-			| c == '}' = foundvar f var (readjustify $ reverse p) cs-			| otherwise = inpad (c:p) f var cs-		inpad p f var [] = Const (novar $ p++";"++var) : f-		readjustify = getjustify . fromMaybe 0 . readish-		getjustify i-			| i == 0 = UnJustified-			| i < 0 = LeftJustified (-1 * i)-			| otherwise = RightJustified i-		novar v = "${" ++ reverse v-		foundvar f v p = scan (Var (reverse v) p : f)+	inpad p f var (c:cs)+		| c == '}' = foundvar f var (readjustify $ reverse p) cs+		| otherwise = inpad (c:p) f var cs+	inpad p f var [] = Const (novar $ p++";"++var) : f+	readjustify = getjustify . fromMaybe 0 . readish+	getjustify i+		| i == 0 = UnJustified+		| i < 0 = LeftJustified (-1 * i)+		| otherwise = RightJustified i+	novar v = "${" ++ reverse v+	foundvar f v p = scan (Var (reverse v) p : f)  empty :: Frag -> Bool empty (Const "") = True@@ -106,36 +106,34 @@ decode_c :: FormatString -> FormatString decode_c [] = [] decode_c s = unescape ("", s)-	where-		e = '\\'-		unescape (b, []) = b-		-- look for escapes starting with '\'-		unescape (b, v) = b ++ fst pair ++ unescape (handle $ snd pair)-			where-				pair = span (/= e) v-		isescape x = x == e-		-- \NNN is an octal encoded character-		handle (x:n1:n2:n3:rest)-			| isescape x && alloctal = (fromoctal, rest)-				where-					alloctal = isOctDigit n1 &&-						isOctDigit n2 &&-						isOctDigit n3-					fromoctal = [chr $ readoctal [n1, n2, n3]]-					readoctal o = Prelude.read $ "0o" ++ o :: Int-		-- \C is used for a few special characters-		handle (x:nc:rest)-			| isescape x = ([echar nc], rest)-			where-				echar 'a' = '\a'-				echar 'b' = '\b'-				echar 'f' = '\f'-				echar 'n' = '\n'-				echar 'r' = '\r'-				echar 't' = '\t'-				echar 'v' = '\v'-				echar a = a-		handle n = ("", n)+  where+	e = '\\'+	unescape (b, []) = b+	-- look for escapes starting with '\'+	unescape (b, v) = b ++ fst pair ++ unescape (handle $ snd pair)+	  where+		pair = span (/= e) v+	isescape x = x == e+	-- \NNN is an octal encoded character+	handle (x:n1:n2:n3:rest)+		| isescape x && alloctal = (fromoctal, rest)+	  where+		alloctal = isOctDigit n1 && isOctDigit n2 && isOctDigit n3+		fromoctal = [chr $ readoctal [n1, n2, n3]]+		readoctal o = Prelude.read $ "0o" ++ o :: Int+	-- \C is used for a few special characters+	handle (x:nc:rest)+		| isescape x = ([echar nc], rest)+	  where+		echar 'a' = '\a'+		echar 'b' = '\b'+		echar 'f' = '\f'+		echar 'n' = '\n'+		echar 'r' = '\r'+		echar 't' = '\t'+		echar 'v' = '\v'+		echar a = a+	handle n = ("", n)  {- Inverse of decode_c. -} encode_c :: FormatString -> FormatString@@ -147,28 +145,28 @@  encode_c' :: (Char -> Bool) -> FormatString -> FormatString encode_c' p = concatMap echar-	where-		e c = '\\' : [c]-		echar '\a' = e 'a'-		echar '\b' = e 'b'-		echar '\f' = e 'f'-		echar '\n' = e 'n'-		echar '\r' = e 'r'-		echar '\t' = e 't'-		echar '\v' = e 'v'-		echar '\\' = e '\\'-		echar '"'  = e '"'-		echar c-			| ord c < 0x20 = e_asc c -- low ascii-			| ord c >= 256 = e_utf c -- unicode-			| ord c > 0x7E = e_asc c -- high ascii-			| p c          = e_asc c -- unprintable ascii-			| otherwise    = [c]     -- printable ascii-		-- unicode character is decomposed to individual Word8s,-		-- and each is shown in octal-		e_utf c = showoctal =<< (Codec.Binary.UTF8.String.encode [c] :: [Word8])-		e_asc c = showoctal $ ord c-		showoctal i = '\\' : printf "%03o" i+  where+	e c = '\\' : [c]+	echar '\a' = e 'a'+	echar '\b' = e 'b'+	echar '\f' = e 'f'+	echar '\n' = e 'n'+	echar '\r' = e 'r'+	echar '\t' = e 't'+	echar '\v' = e 'v'+	echar '\\' = e '\\'+	echar '"'  = e '"'+	echar c+		| ord c < 0x20 = e_asc c -- low ascii+		| ord c >= 256 = e_utf c -- unicode+		| ord c > 0x7E = e_asc c -- high ascii+		| p c          = e_asc c -- unprintable ascii+		| otherwise    = [c]     -- printable ascii+	-- unicode character is decomposed to individual Word8s,+	-- and each is shown in octal+	e_utf c = showoctal =<< (Codec.Binary.UTF8.String.encode [c] :: [Word8])+	e_asc c = showoctal $ ord c+	showoctal i = '\\' : printf "%03o" i  {- for quickcheck -} prop_idempotent_deencode :: String -> Bool
Utility/FreeDesktop.hs view
@@ -51,8 +51,8 @@ toString (ListV l) 	| null l = "" 	| otherwise = (intercalate ";" $ map (escapesemi . toString) l) ++ ";"-	where-		escapesemi = join "\\;" . split ";"+  where+	escapesemi = join "\\;" . split ";"  genDesktopEntry :: String -> String -> Bool -> FilePath -> [String] -> DesktopEntry genDesktopEntry name comment terminal program categories =@@ -64,13 +64,13 @@ 	, item "Exec" StringV program 	, item "Categories" ListV (map StringV categories) 	]-	where-		item x c y = (x, c y)+  where+	item x c y = (x, c y)  buildDesktopMenuFile :: DesktopEntry -> String buildDesktopMenuFile d = unlines ("[Desktop Entry]" : map keyvalue d) ++ "\n"-	where-		keyvalue (k, v) = k ++ "=" ++ toString v+  where+	keyvalue (k, v) = k ++ "=" ++ toString v  writeDesktopMenuFile :: DesktopEntry -> String -> IO () writeDesktopMenuFile d file = do@@ -115,11 +115,10 @@  - to ~/Desktop. -} userDesktopDir :: IO FilePath userDesktopDir = maybe fallback return =<< (parse <$> xdg_user_dir)-	where-		parse = maybe Nothing (headMaybe . lines)-		xdg_user_dir = catchMaybeIO $-			readProcess "xdg-user-dir" ["DESKTOP"]-		fallback = xdgEnvHome "DESKTOP_DIR" "Desktop"+  where+	parse = maybe Nothing (headMaybe . lines)+	xdg_user_dir = catchMaybeIO $ readProcess "xdg-user-dir" ["DESKTOP"]+	fallback = xdgEnvHome "DESKTOP_DIR" "Desktop"  xdgEnvHome :: String -> String -> IO String xdgEnvHome envbase homedef = do
Utility/Gpg.hs view
@@ -16,7 +16,7 @@ import Common  newtype KeyIds = KeyIds [String]-        deriving (Ord, Eq)+	deriving (Ord, Eq)  stdParams :: [CommandParam] -> IO [String] stdParams params = do@@ -29,9 +29,9 @@ 		then [] 		else ["--batch", "--no-tty", "--use-agent"] 	return $ batch ++ defaults ++ toCommand params-	where-		-- be quiet, even about checking the trustdb-		defaults = ["--quiet", "--trust-model", "always"]+  where+	-- be quiet, even about checking the trustdb+	defaults = ["--quiet", "--trust-model", "always"]  {- Runs gpg with some params and returns its stdout, strictly. -} readStrict :: [CommandParam] -> IO String@@ -74,22 +74,22 @@ 	params' <- stdParams $ passphrasefd ++ params 	closeFd frompipe `after` 		withBothHandles createProcessSuccess (proc "gpg" params') go-	where-		go (to, from) = do-			void $ forkIO $ do-				feeder to-				hClose to-			reader from+  where+	go (to, from) = do+		void $ forkIO $ do+			feeder to+			hClose to+		reader from  {- Finds gpg public keys matching some string. (Could be an email address,  - a key id, or a name. -} findPubKeys :: String -> IO KeyIds findPubKeys for = KeyIds . parse <$> readStrict params-	where-		params = [Params "--with-colons --list-public-keys", Param for]-		parse = catMaybes . map (keyIdField . split ":") . lines-		keyIdField ("pub":_:_:_:f:_) = Just f-		keyIdField _ = Nothing+  where+	params = [Params "--with-colons --list-public-keys", Param for]+	parse = catMaybes . map (keyIdField . split ":") . lines+	keyIdField ("pub":_:_:_:f:_) = Just f+	keyIdField _ = Nothing  {- Creates a block of high-quality random data suitable to use as a cipher.  - It is armored, to avoid newlines, since gpg only reads ciphers up to the@@ -100,9 +100,9 @@ 	, Param $ show randomquality 	, Param $ show size 	]-	where-		-- 1 is /dev/urandom; 2 is /dev/random-		randomquality = 1 :: Int+  where+	-- 1 is /dev/urandom; 2 is /dev/random+	randomquality = 1 :: Int  {- A test key. This is provided pre-generated since generating a new gpg  - key is too much work (requires too much entropy) for a test suite to@@ -173,10 +173,10 @@ 	, unlines ls 	, "-----END PGP "++t++" KEY BLOCK-----" 	]-	where-		t-			| public = "PUBLIC"-			| otherwise = "PRIVATE"+  where+	t+		| public = "PUBLIC"+		| otherwise = "PRIVATE"  {- Runs an action using gpg in a test harness, in which gpg does  - not use ~/.gpg/, but a directory with the test key set up to be used. -}@@ -184,20 +184,20 @@ testHarness a = do 	orig <- getEnv var 	bracket setup (cleanup orig) (const a)-	where-		var = "GNUPGHOME"		+  where+	var = "GNUPGHOME"		 -		setup = do-			base <- getTemporaryDirectory-			dir <- mktmpdir $ base </> "gpgtmpXXXXXX"-			setEnv var dir True-			_ <- pipeStrict [Params "--import -q"] $ unlines-				[testSecretKey, testKey]-			return dir+	setup = do+		base <- getTemporaryDirectory+		dir <- mktmpdir $ base </> "gpgtmpXXXXXX"+		setEnv var dir True+		_ <- pipeStrict [Params "--import -q"] $ unlines+			[testSecretKey, testKey]+		return dir 		-		cleanup orig tmpdir = removeDirectoryRecursive tmpdir >> reset orig-                reset (Just v) = setEnv var v True-                reset _ = unsetEnv var+	cleanup orig tmpdir = removeDirectoryRecursive tmpdir >> reset orig+	reset (Just v) = setEnv var v True+	reset _ = unsetEnv var  {- Tests the test harness. -} testTestHarness :: IO Bool
Utility/HumanTime.hs view
@@ -17,10 +17,10 @@ 	num <- readish s :: Maybe Integer 	units <- findUnits =<< lastMaybe s 	return $ fromIntegral num * units-	where-		findUnits 's' = Just 1-		findUnits 'm' = Just 60-		findUnits 'h' = Just $ 60 * 60-		findUnits 'd' = Just $ 60 * 60 * 24-		findUnits 'y' = Just $ 60 * 60 * 24 * 365-		findUnits _ = Nothing+  where+	findUnits 's' = Just 1+	findUnits 'm' = Just 60+	findUnits 'h' = Just $ 60 * 60+	findUnits 'd' = Just $ 60 * 60 * 24+	findUnits 'y' = Just $ 60 * 60 * 24 * 365+	findUnits _ = Nothing
Utility/INotify.hs view
@@ -59,116 +59,116 @@ 		withLock lock $ 			mapM_ scan =<< filter (not . dirCruft) <$> 				getDirectoryContents dir-	where-		recurse d = watchDir i d ignored hooks+  where+	recurse d = watchDir i d ignored hooks -		-- Select only inotify events required by the enabled-		-- hooks, but always include Create so new directories can-		-- be scanned.-		watchevents = Create : addevents ++ delevents ++ modifyevents-		addevents-			| hashook addHook || hashook addSymlinkHook = [MoveIn, CloseWrite]-			| otherwise = []-		delevents-			| hashook delHook || hashook delDirHook = [MoveOut, Delete]-			| otherwise = []-		modifyevents-			| hashook modifyHook = [Modify]-			| otherwise = []+	-- Select only inotify events required by the enabled+	-- hooks, but always include Create so new directories can+	-- be scanned.+	watchevents = Create : addevents ++ delevents ++ modifyevents+	addevents+		| hashook addHook || hashook addSymlinkHook = [MoveIn, CloseWrite]+		| otherwise = []+	delevents+		| hashook delHook || hashook delDirHook = [MoveOut, Delete]+		| otherwise = []+	modifyevents+		| hashook modifyHook = [Modify]+		| otherwise = [] -		scan f = unless (ignored f) $ do-			ms <- getstatus f-			case ms of-				Nothing -> return ()-				Just s-					| Files.isDirectory s ->-						recurse $ indir f-					| Files.isSymbolicLink s ->-						runhook addSymlinkHook f ms-					| Files.isRegularFile s ->-						runhook addHook f ms-					| otherwise ->-						noop+	scan f = unless (ignored f) $ do+		ms <- getstatus f+		case ms of+			Nothing -> return ()+			Just s+				| Files.isDirectory s ->+					recurse $ indir f+				| Files.isSymbolicLink s ->+					runhook addSymlinkHook f ms+				| Files.isRegularFile s ->+					runhook addHook f ms+				| otherwise ->+					noop -		-- Ignore creation events for regular files, which won't be-		-- done being written when initially created, but handle for-		-- directories and symlinks.-		go (Created { isDirectory = isd, filePath = f })-			| isd = recurse $ indir f-			| hashook addSymlinkHook =-				checkfiletype Files.isSymbolicLink addSymlinkHook f-			| otherwise = noop-		-- Closing a file is assumed to mean it's done being written.-		go (Closed { isDirectory = False, maybeFilePath = Just f }) =-				checkfiletype Files.isRegularFile addHook f-		-- When a file or directory is moved in, scan it to add new-		-- stuff.-		go (MovedIn { filePath = f }) = scan f-		go (MovedOut { isDirectory = isd, filePath = f })-			| isd = runhook delDirHook f Nothing-			| otherwise = runhook delHook f Nothing-		-- Verify that the deleted item really doesn't exist,-		-- since there can be spurious deletion events for items-		-- in a directory that has been moved out, but is still-		-- being watched.-		go (Deleted { isDirectory = isd, filePath = f })-			| isd = guarded $ runhook delDirHook f Nothing-			| otherwise = guarded $ runhook delHook f Nothing-			where-				guarded = unlessM (filetype (const True) f)-		go (Modified { isDirectory = isd, maybeFilePath = Just f })-			| isd = noop-			| otherwise = runhook modifyHook f Nothing-		go _ = noop+	-- Ignore creation events for regular files, which won't be+	-- done being written when initially created, but handle for+	-- directories and symlinks.+	go (Created { isDirectory = isd, filePath = f })+		| isd = recurse $ indir f+		| hashook addSymlinkHook =+			checkfiletype Files.isSymbolicLink addSymlinkHook f+		| otherwise = noop+	-- Closing a file is assumed to mean it's done being written.+	go (Closed { isDirectory = False, maybeFilePath = Just f }) =+			checkfiletype Files.isRegularFile addHook f+	-- When a file or directory is moved in, scan it to add new+	-- stuff.+	go (MovedIn { filePath = f }) = scan f+	go (MovedOut { isDirectory = isd, filePath = f })+		| isd = runhook delDirHook f Nothing+		| otherwise = runhook delHook f Nothing+	-- Verify that the deleted item really doesn't exist,+	-- since there can be spurious deletion events for items+	-- in a directory that has been moved out, but is still+	-- being watched.+	go (Deleted { isDirectory = isd, filePath = f })+		| isd = guarded $ runhook delDirHook f Nothing+		| otherwise = guarded $ runhook delHook f Nothing+	  where+		guarded = unlessM (filetype (const True) f)+	go (Modified { isDirectory = isd, maybeFilePath = Just f })+		| isd = noop+		| otherwise = runhook modifyHook f Nothing+	go _ = noop -		hashook h = isJust $ h hooks+	hashook h = isJust $ h hooks -		runhook h f s-			| ignored f = noop-			| otherwise = maybe noop (\a -> a (indir f) s) (h hooks)+	runhook h f s+		| ignored f = noop+		| otherwise = maybe noop (\a -> a (indir f) s) (h hooks) -		indir f = dir </> f+	indir f = dir </> f -		getstatus f = catchMaybeIO $ getSymbolicLinkStatus $ indir f-		checkfiletype check h f = do-			ms <- getstatus f-			case ms of-				Just s-					| check s -> runhook h f ms-				_ -> noop-		filetype t f = catchBoolIO $ t <$> getSymbolicLinkStatus (indir f)+	getstatus f = catchMaybeIO $ getSymbolicLinkStatus $ indir f+	checkfiletype check h f = do+		ms <- getstatus f+		case ms of+			Just s+				| check s -> runhook h f ms+			_ -> noop+	filetype t f = catchBoolIO $ t <$> getSymbolicLinkStatus (indir f) -		-- Inotify fails when there are too many watches with a-		-- disk full error.-		failedaddwatch e-			| isFullError e =-				case errHook hooks of-					Nothing -> throw e-					Just hook -> tooManyWatches hook dir-			| otherwise = throw e+	-- Inotify fails when there are too many watches with a+	-- disk full error.+	failedaddwatch e+		| isFullError e =+			case errHook hooks of+				Nothing -> throw e+				Just hook -> tooManyWatches hook dir+		| otherwise = throw e  tooManyWatches :: (String -> Maybe FileStatus -> IO ()) -> FilePath -> IO () tooManyWatches hook dir = do 	sysctlval <- querySysctl [Param maxwatches] :: IO (Maybe Integer) 	hook (unlines $ basewarning : maybe withoutsysctl withsysctl sysctlval) Nothing-	where-		maxwatches = "fs.inotify.max_user_watches"-		basewarning = "Too many directories to watch! (Not watching " ++ dir ++")"-		withoutsysctl = ["Increase the value in /proc/sys/fs/inotify/max_user_watches"]-		withsysctl n = let new = n * 10 in-			[ "Increase the limit permanently by running:"-			, "  echo " ++ maxwatches ++ "=" ++ show new ++-			  " | sudo tee -a /etc/sysctl.conf; sudo sysctl -p"-			, "Or temporarily by running:"-			, "  sudo sysctl -w " ++ maxwatches ++ "=" ++ show new-			]+  where+	maxwatches = "fs.inotify.max_user_watches"+	basewarning = "Too many directories to watch! (Not watching " ++ dir ++")"+	withoutsysctl = ["Increase the value in /proc/sys/fs/inotify/max_user_watches"]+	withsysctl n = let new = n * 10 in+		[ "Increase the limit permanently by running:"+		, "  echo " ++ maxwatches ++ "=" ++ show new +++		  " | sudo tee -a /etc/sysctl.conf; sudo sysctl -p"+		, "Or temporarily by running:"+		, "  sudo sysctl -w " ++ maxwatches ++ "=" ++ show new+		]  querySysctl :: Read a => [CommandParam] -> IO (Maybe a) querySysctl ps = getM go ["sysctl", "/sbin/sysctl", "/usr/sbin/sysctl"]-	where-		go p = do-			v <- catchMaybeIO $ readProcess p (toCommand ps)-			case v of-				Nothing -> return Nothing-				Just s -> return $ parsesysctl s-		parsesysctl s = readish =<< lastMaybe (words s)+  where+	go p = do+		v <- catchMaybeIO $ readProcess p (toCommand ps)+		case v of+			Nothing -> return Nothing+			Just s -> return $ parsesysctl s+	parsesysctl s = readish =<< lastMaybe (words s)
Utility/JSONStream.hs view
@@ -14,22 +14,22 @@ import Text.JSON  {- Text.JSON does not support building up a larger JSON document piece by-   piece as a stream. To support streaming, a hack. The JSObject is converted-   to a string with its final "}" is left off, allowing it to be added to-   later. -}+ - piece as a stream. To support streaming, a hack. The JSObject is converted+ - to a string with its final "}" is left off, allowing it to be added to+ - later. -} start :: JSON a => [(String, a)] -> String start l 	| last s == endchar = init s 	| otherwise = bad s-	where-		s = encodeStrict $ toJSObject l+  where+	s = encodeStrict $ toJSObject l  add :: JSON a => [(String, a)] -> String add l 	| head s == startchar = ',' : drop 1 s 	| otherwise = bad s-	where-		s = start l+  where+	s = start l  end :: String end = [endchar, '\n']
Utility/Kqueue.hs view
@@ -78,44 +78,44 @@ 	l <- filter (not . dirCruft) <$> getDirectoryContents dir 	contents <- S.fromList . catMaybes <$> mapM getDirEnt l 	return $ DirInfo dir contents-	where-		getDirEnt f = catchMaybeIO $ do-			s <- getFileStatus (dir </> f)-			return $ DirEnt f (fileID s) (isDirectory s)+  where+	getDirEnt f = catchMaybeIO $ do+		s <- getSymbolicLinkStatus (dir </> f)+		return $ DirEnt f (fileID s) (isDirectory s)  {- Difference between the dirCaches of two DirInfos. -} (//) :: DirInfo -> DirInfo -> [Change] oldc // newc = deleted ++ added-	where-		deleted = calc gendel oldc newc-		added   = calc genadd newc oldc-		gendel x = (if isSubDir x then DeletedDir else Deleted) $-			dirName oldc </> dirEnt x-		genadd x = Added $ dirName newc </> dirEnt x-		calc a x y = map a $ S.toList $-			S.difference (dirCache x) (dirCache y)+  where+	deleted = calc gendel oldc newc+	added   = calc genadd newc oldc+	gendel x = (if isSubDir x then DeletedDir else Deleted) $+		dirName oldc </> dirEnt x+	genadd x = Added $ dirName newc </> dirEnt x+	calc a x y = map a $ S.toList $+		S.difference (dirCache x) (dirCache y)  {- Builds a map of directories in a tree, possibly pruning some.  - Opens each directory in the tree, and records its current contents. -} scanRecursive :: FilePath -> Pruner -> IO DirMap scanRecursive topdir prune = M.fromList <$> walk [] [topdir]-	where-		walk c [] = return c-		walk c (dir:rest)-			| prune dir = walk c rest-			| otherwise = do-				minfo <- catchMaybeIO $ getDirInfo dir-				case minfo of-					Nothing -> walk c rest-					Just info -> do-						mfd <- catchMaybeIO $-							openFd dir ReadOnly Nothing defaultFileFlags-						case mfd of-							Nothing -> walk c rest-							Just fd -> do-								let subdirs = map (dir </>) . map dirEnt $-									S.toList $ dirCache info-								walk ((fd, info):c) (subdirs ++ rest)+  where+	walk c [] = return c+	walk c (dir:rest)+		| prune dir = walk c rest+		| otherwise = do+			minfo <- catchMaybeIO $ getDirInfo dir+			case minfo of+				Nothing -> walk c rest+				Just info -> do+					mfd <- catchMaybeIO $+						openFd dir ReadOnly Nothing defaultFileFlags+					case mfd of+						Nothing -> walk c rest+						Just fd -> do+							let subdirs = map (dir </>) . map dirEnt $+								S.toList $ dirCache info+							walk ((fd, info):c) (subdirs ++ rest)  {- Adds a list of subdirectories (and all their children), unless pruned to a  - directory map. Adding a subdirectory that's already in the map will@@ -131,16 +131,16 @@ removeSubDir dirmap dir = do 	mapM_ closeFd $ M.keys toremove 	return rest-	where-		(toremove, rest) = M.partition (dirContains dir . dirName) dirmap+  where+	(toremove, rest) = M.partition (dirContains dir . dirName) dirmap  findDirContents :: DirMap -> FilePath -> [FilePath] findDirContents dirmap dir = concatMap absolutecontents $ search-	where-		absolutecontents i = map (dirName i </>)-			(map dirEnt $ S.toList $ dirCache i)-		search = map snd $ M.toList $-			M.filter (\i -> dirName i == dir) dirmap+  where+	absolutecontents i = map (dirName i </>)+		(map dirEnt $ S.toList $ dirCache i)+	search = map snd $ M.toList $+		M.filter (\i -> dirName i == dir) dirmap  foreign import ccall safe "libkqueue.h init_kqueue" c_init_kqueue 	:: IO Fd@@ -181,8 +181,8 @@ 		else case M.lookup changedfd dirmap of 			Nothing -> nochange 			Just info -> handleChange kq changedfd info-	where-		nochange = return (kq, [])+  where+	nochange = return (kq, [])  {- The kqueue interface does not tell what type of change took place in  - the directory; it could be an added file, a deleted file, a renamed@@ -196,36 +196,36 @@ handleChange :: Kqueue -> Fd -> DirInfo -> IO (Kqueue, [Change]) handleChange kq@(Kqueue _ _ dirmap pruner) fd olddirinfo = 	go =<< catchMaybeIO (getDirInfo $ dirName olddirinfo)-	where-		go (Just newdirinfo) = do-			let changes = filter (not . pruner . changedFile) $-				 olddirinfo // newdirinfo-			let (added, deleted) = partition isAdd changes+  where+	go (Just newdirinfo) = do+		let changes = filter (not . pruner . changedFile) $+			 olddirinfo // newdirinfo+		let (added, deleted) = partition isAdd changes -			-- Scan newly added directories to add to the map.-			-- (Newly added files will fail getDirInfo.)-			newdirinfos <- catMaybes <$>-				mapM (catchMaybeIO . getDirInfo . changedFile) added-			newmap <- addSubDirs dirmap pruner $ map dirName newdirinfos+		-- Scan newly added directories to add to the map.+		-- (Newly added files will fail getDirInfo.)+		newdirinfos <- catMaybes <$>+			mapM (catchMaybeIO . getDirInfo . changedFile) added+		newmap <- addSubDirs dirmap pruner $ map dirName newdirinfos -			-- Remove deleted directories from the map.-			newmap' <- foldM removeSubDir newmap (map changedFile deleted)+		-- Remove deleted directories from the map.+		newmap' <- foldM removeSubDir newmap (map changedFile deleted) -			-- Update the cached dirinfo just looked up.-			let newmap'' = M.insertWith' const fd newdirinfo newmap'+		-- Update the cached dirinfo just looked up.+		let newmap'' = M.insertWith' const fd newdirinfo newmap' -			-- When new directories were added, need to update-			-- the kqueue to watch them.-			let kq' = kq { kqueueMap = newmap'' }-			unless (null newdirinfos) $-				updateKqueue kq'+		-- When new directories were added, need to update+		-- the kqueue to watch them.+		let kq' = kq { kqueueMap = newmap'' }+		unless (null newdirinfos) $+			updateKqueue kq' -			return (kq', changes)-		go Nothing = do-			-- The directory has been moved or deleted, so-			-- remove it from our map.-			newmap <- removeSubDir dirmap (dirName olddirinfo)-			return (kq { kqueueMap = newmap }, [])+		return (kq', changes)+	go Nothing = do+		-- The directory has been moved or deleted, so+		-- remove it from our map.+		newmap <- removeSubDir dirmap (dirName olddirinfo)+		return (kq { kqueueMap = newmap }, [])  {- Processes changes on the Kqueue, calling the hooks as appropriate.  - Never returns. -}@@ -235,35 +235,33 @@ 	-- to catch any files created beforehand. 	recursiveadd (kqueueMap kq) (Added $ kqueueTop kq) 	loop kq-	where-		loop q = do-			(q', changes) <- waitChange q-			forM_ changes $ dispatch (kqueueMap q')-			loop q'+  where+	loop q = do+		(q', changes) <- waitChange q+		forM_ changes $ dispatch (kqueueMap q')+		loop q' -		dispatch _ change@(Deleted _) = -			callhook delHook Nothing change-		dispatch _ change@(DeletedDir _) =-			callhook delDirHook Nothing change-		dispatch dirmap change@(Added _) =-			withstatus change $ dispatchadd dirmap+	dispatch _ change@(Deleted _) = +		callhook delHook Nothing change+	dispatch _ change@(DeletedDir _) =+		callhook delDirHook Nothing change+	dispatch dirmap change@(Added _) =+		withstatus change $ dispatchadd dirmap 		-		dispatchadd dirmap change s-			| Files.isSymbolicLink s =-				callhook addSymlinkHook (Just s) change-			| Files.isDirectory s = recursiveadd dirmap change-			| Files.isRegularFile s =-				callhook addHook (Just s) change-			| otherwise = noop+	dispatchadd dirmap change s+		| Files.isSymbolicLink s = callhook addSymlinkHook (Just s) change+		| Files.isDirectory s = recursiveadd dirmap change+		| Files.isRegularFile s = callhook addHook (Just s) change+		| otherwise = noop -		recursiveadd dirmap change = do-			let contents = findDirContents dirmap $ changedFile change-			forM_ contents $ \f ->-				withstatus (Added f) $ dispatchadd dirmap+	recursiveadd dirmap change = do+		let contents = findDirContents dirmap $ changedFile change+		forM_ contents $ \f ->+			withstatus (Added f) $ dispatchadd dirmap -		callhook h s change = case h hooks of-			Nothing -> noop-			Just a -> a (changedFile change) s+	callhook h s change = case h hooks of+		Nothing -> noop+		Just a -> a (changedFile change) s -		withstatus change a = maybe noop (a change) =<<-			(catchMaybeIO (getSymbolicLinkStatus (changedFile change)))+	withstatus change a = maybe noop (a change) =<<+		(catchMaybeIO (getSymbolicLinkStatus (changedFile change)))
Utility/LogFile.hs view
@@ -23,9 +23,9 @@ 	| otherwise = whenM (doesFileExist currfile) $ do 		rotateLog logfile (num + 1) 		renameFile currfile nextfile-	where-		currfile = filename num-		nextfile = filename (num + 1)-		filename n-			| n == 0 = logfile-			| otherwise = logfile ++ "." ++ show n+  where+	currfile = filename num+	nextfile = filename (num + 1)+	filename n+		| n == 0 = logfile+		| otherwise = logfile ++ "." ++ show n
Utility/Lsof.hs view
@@ -10,8 +10,10 @@ module Utility.Lsof where  import Common+import Build.SysConfig as SysConfig  import System.Posix.Types+import System.Posix.Env  data LsofOpenMode = OpenReadWrite | OpenReadOnly | OpenWriteOnly | OpenUnknown 	deriving (Show, Eq)@@ -21,6 +23,17 @@ data ProcessInfo = ProcessInfo ProcessID CmdLine 	deriving (Show) +{- lsof is not in PATH on all systems, so SysConfig may have the absolute+ - path where the program was found. Make sure at runtime that lsof is+ - available, and if it's not in PATH, adjust PATH to contain it. -}+setupLsof :: IO ()+setupLsof = do+	let cmd = fromMaybe "lsof" SysConfig.lsof+	when (isAbsolute cmd) $ do+		path <- getSearchPath+		let path' = takeDirectory cmd : path+		setEnv "PATH" (join [searchPathSeparator] path') True+ {- Checks each of the files in a directory to find open files.  - Note that this will find hard links to files elsewhere that are open. -} queryDir :: FilePath -> IO [(FilePath, LsofOpenMode, ProcessInfo)]@@ -36,8 +49,8 @@ query opts = 	withHandle StdoutHandle (createProcessChecked checkSuccessProcess) p $ \h -> do 		parse <$> hGetContentsStrict h-	where-		p = proc "lsof" ("-F0can" : opts)+  where+	p = proc "lsof" ("-F0can" : opts)  {- Parsing null-delimited output like:  -@@ -51,38 +64,36 @@  -} parse :: String -> [(FilePath, LsofOpenMode, ProcessInfo)] parse s = bundle $ go [] $ lines s-	where-		bundle = concatMap (\(fs, p) -> map (\(f, m) -> (f, m, p)) fs)+  where+	bundle = concatMap (\(fs, p) -> map (\(f, m) -> (f, m, p)) fs) -		go c [] = c-		go c ((t:r):ls)-			| t == 'p' =-				let (fs, ls') = parsefiles [] ls-				in go ((fs, parseprocess r):c) ls'-			| otherwise = parsefail-		go _ _ = parsefail+	go c [] = c+	go c ((t:r):ls)+		| t == 'p' =+			let (fs, ls') = parsefiles [] ls+			in go ((fs, parseprocess r):c) ls'+		| otherwise = parsefail+	go _ _ = parsefail -		parseprocess l =-			case splitnull l of-				[pid, 'c':cmdline, ""] ->-					case readish pid of-						(Just n) -> ProcessInfo n cmdline-						Nothing -> parsefail-				_ -> parsefail+	parseprocess l = case splitnull l of+		[pid, 'c':cmdline, ""] ->+			case readish pid of+				(Just n) -> ProcessInfo n cmdline+				Nothing -> parsefail+		_ -> parsefail -		parsefiles c [] = (c, [])-		parsefiles c (l:ls) = -			case splitnull l of-				['a':mode, 'n':file, ""] ->-					parsefiles ((file, parsemode mode):c) ls-				(('p':_):_) -> (c, l:ls)-				_ -> parsefail+	parsefiles c [] = (c, [])+	parsefiles c (l:ls) = case splitnull l of+		['a':mode, 'n':file, ""] ->+			parsefiles ((file, parsemode mode):c) ls+		(('p':_):_) -> (c, l:ls)+		_ -> parsefail -		parsemode ('r':_) = OpenReadOnly-		parsemode ('w':_) = OpenWriteOnly-		parsemode ('u':_) = OpenReadWrite-		parsemode _ = OpenUnknown+	parsemode ('r':_) = OpenReadOnly+	parsemode ('w':_) = OpenWriteOnly+	parsemode ('u':_) = OpenReadWrite+	parsemode _ = OpenUnknown -		splitnull = split "\0"+	splitnull = split "\0" -		parsefail = error $ "failed to parse lsof output: " ++ show s+	parsefail = error $ "failed to parse lsof output: " ++ show s
Utility/Matcher.hs view
@@ -58,36 +58,36 @@ {- Converts a list of Tokens into a Matcher. -} generate :: [Token op] -> Matcher op generate = go MAny-	where-		go m [] = m-		go m ts = uncurry go $ consume m ts+  where+	go m [] = m+	go m ts = uncurry go $ consume m ts  {- Consumes one or more Tokens, constructs a new Matcher,  - and returns unconsumed Tokens. -} consume :: Matcher op -> [Token op] -> (Matcher op, [Token op]) consume m [] = (m, []) consume m (t:ts) = go t-	where-		go And = cont $ m `MAnd` next-		go Or = cont $ m `MOr` next-		go Not = cont $ m `MAnd` MNot next-		go Open = let (n, r) = consume next rest in (m `MAnd` n, r)-		go Close = (m, ts)-		go (Operation o) = (m `MAnd` MOp o, ts)+  where+	go And = cont $ m `MAnd` next+	go Or = cont $ m `MOr` next+	go Not = cont $ m `MAnd` MNot next+	go Open = let (n, r) = consume next rest in (m `MAnd` n, r)+	go Close = (m, ts)+	go (Operation o) = (m `MAnd` MOp o, ts) -		(next, rest) = consume MAny ts-		cont v = (v, rest)+	(next, rest) = consume MAny ts+	cont v = (v, rest)  {- Checks if a Matcher matches, using a supplied function to check  - the value of Operations. -} match :: (op -> v -> Bool) -> Matcher op -> v -> Bool match a m v = go m-	where-		go MAny = True-		go (MAnd m1 m2) = go m1 && go m2-		go (MOr m1 m2) =  go m1 || go m2-		go (MNot m1) = not $ go m1-		go (MOp o) = a o v+  where+	go MAny = True+	go (MAnd m1 m2) = go m1 && go m2+	go (MOr m1 m2) =  go m1 || go m2+	go (MNot m1) = not $ go m1+	go (MOp o) = a o v  {- Runs a monadic Matcher, where Operations are actions in the monad. -} matchM :: Monad m => Matcher (v -> m Bool) -> v -> m Bool@@ -98,12 +98,12 @@  - parameter. -} matchMrun :: forall o (m :: * -> *). Monad m => Matcher o -> (o -> m Bool) -> m Bool matchMrun m run = go m-	where-		go MAny = return True-		go (MAnd m1 m2) = go m1 <&&> go m2-		go (MOr m1 m2) =  go m1 <||> go m2-		go (MNot m1) = liftM not (go m1)-		go (MOp o) = run o+  where+	go MAny = return True+	go (MAnd m1 m2) = go m1 <&&> go m2+	go (MOr m1 m2) =  go m1 <||> go m2+	go (MNot m1) = liftM not (go m1)+	go (MOp o) = run o  {- Checks if a matcher contains no limits. -} isEmpty :: Matcher a -> Bool
Utility/Misc.hs view
@@ -33,10 +33,10 @@  -} separate :: (a -> Bool) -> [a] -> ([a], [a]) separate c l = unbreak $ break c l-	where-		unbreak r@(a, b)-			| null b = r-			| otherwise = (a, tail b)+  where+	unbreak r@(a, b)+		| null b = r+		| otherwise = (a, tail b)  {- Breaks out the first line. -} firstLine :: String -> String@@ -47,11 +47,11 @@  - Segments may be empty. -} segment :: (a -> Bool) -> [a] -> [[a]] segment p l = map reverse $ go [] [] l-	where-		go c r [] = reverse $ c:r-		go c r (i:is)-			| p i = go [] (c:r) is-			| otherwise = go (i:c) r is+  where+	go c r [] = reverse $ c:r+	go c r (i:is)+		| p i = go [] (c:r) is+		| otherwise = go (i:c) r is  prop_segment_regressionTest :: Bool prop_segment_regressionTest = all id@@ -64,11 +64,11 @@ {- Includes the delimiters as segments of their own. -} segmentDelim :: (a -> Bool) -> [a] -> [[a]] segmentDelim p l = map reverse $ go [] [] l-	where-		go c r [] = reverse $ c:r-		go c r (i:is)-			| p i = go [] ([i]:c:r) is-			| otherwise = go (i:c) r is+  where+	go c r [] = reverse $ c:r+	go c r (i:is)+		| p i = go [] ([i]:c:r) is+		| otherwise = go (i:c) r is  {- Given two orderings, returns the second if the first is EQ and returns  - the first otherwise.@@ -96,9 +96,9 @@ 	fp <- mallocForeignPtrBytes sz 	len <- withForeignPtr fp $ \buf -> hGetBufSome h buf sz 	map (chr . fromIntegral) <$> withForeignPtr fp (peekbytes len)-	where-		peekbytes :: Int -> Ptr Word8 -> IO [Word8]-		peekbytes len buf = mapM (peekElemOff buf) [0..pred len]+  where+	peekbytes :: Int -> Ptr Word8 -> IO [Word8]+	peekbytes len buf = mapM (peekElemOff buf) [0..pred len]  {- Reaps any zombie git processes.   -
Utility/Mounts.hsc view
@@ -41,21 +41,21 @@ 	_ <- c_mounts_end h 	return mntent -	where-		getmntent h c = do-			ptr <- c_mounts_next h-			if (ptr == nullPtr)-				then return $ reverse c-				else do-					mnt_fsname_str <- #{peek struct mntent, mnt_fsname} ptr >>= peekCString-					mnt_dir_str <- #{peek struct mntent, mnt_dir} ptr >>= peekCString-					mnt_type_str <- #{peek struct mntent, mnt_type} ptr >>= peekCString-					let ent = Mntent-						{ mnt_fsname = mnt_fsname_str-						, mnt_dir = mnt_dir_str-						, mnt_type = mnt_type_str-						}-					getmntent h (ent:c)+  where+	getmntent h c = do+		ptr <- c_mounts_next h+		if (ptr == nullPtr)+			then return $ reverse c+			else do+				mnt_fsname_str <- #{peek struct mntent, mnt_fsname} ptr >>= peekCString+				mnt_dir_str <- #{peek struct mntent, mnt_dir} ptr >>= peekCString+				mnt_type_str <- #{peek struct mntent, mnt_type} ptr >>= peekCString+				let ent = Mntent+					{ mnt_fsname = mnt_fsname_str+					, mnt_dir = mnt_dir_str+					, mnt_type = mnt_type_str+					}+				getmntent h (ent:c)  {- Using unsafe imports because the C functions are belived to never block.  - Note that getmntinfo is called with MNT_NOWAIT to avoid possibly blocking;
Utility/Network.hs view
@@ -17,6 +17,5 @@  - use uname -n when available. -} getHostname :: IO (Maybe String) getHostname = catchMaybeIO uname_node-	where-		uname_node = takeWhile (/= '\n') <$>-			readProcess "uname" ["-n"]	+  where+	uname_node = takeWhile (/= '\n') <$> readProcess "uname" ["-n"]
Utility/NotificationBroadcaster.hs view
@@ -45,13 +45,13 @@ newNotificationHandle b = NotificationHandle 	<$> pure b 	<*> addclient-	where-		addclient = do-			s <- newEmptySV-			atomically $ do-				l <- takeTMVar b-				putTMVar b $ l ++ [s]-				return $ NotificationId $ length l+  where+	addclient = do+		s <- newEmptySV+		atomically $ do+			l <- takeTMVar b+			putTMVar b $ l ++ [s]+			return $ NotificationId $ length l  {- Extracts the identifier from a notification handle.  - This can be used to eg, pass the identifier through to a WebApp. -}@@ -66,8 +66,8 @@ sendNotification b = do 	l <- atomically $ readTMVar b 	mapM_ notify l-	where-		notify s = writeSV s ()+  where+	notify s = writeSV s ()  {- Used by a client to block until a new notification is available since  - the last time it tried. -}
Utility/Parallel.hs view
@@ -23,13 +23,13 @@ 	mvars <- mapM thread l 	statuses <- mapM takeMVar mvars 	return $ reduce $ partition snd $ zip l statuses-	where-		reduce (x,y) = (map fst x, map fst y)-		thread v = do-			mvar <- newEmptyMVar-			_ <- forkIO $ do-				r <- try (a v) :: IO (Either SomeException Bool)-				case r of-					Left _ -> putMVar mvar False-					Right b -> putMVar mvar b-			return mvar+  where+	reduce (x,y) = (map fst x, map fst y)+	thread v = do+		mvar <- newEmptyMVar+		_ <- forkIO $ do+			r <- try (a v) :: IO (Either SomeException Bool)+			case r of+				Left _ -> putMVar mvar False+				Right b -> putMVar mvar b+		return mvar
Utility/Path.hs view
@@ -23,18 +23,18 @@ parentDir dir 	| not $ null dirs = slash ++ join s (init dirs) 	| otherwise = ""-		where-			dirs = filter (not . null) $ split s dir-			slash = if isAbsolute dir then s else ""-			s = [pathSeparator]+  where+	dirs = filter (not . null) $ split s dir+	slash = if isAbsolute dir then s else ""+	s = [pathSeparator]  prop_parentDir_basics :: FilePath -> Bool prop_parentDir_basics dir 	| null dir = True 	| dir == "/" = parentDir dir == "" 	| otherwise = p /= dir-	where-		p = parentDir dir+  where+	p = parentDir dir  {- Checks if the first FilePath is, or could be said to contain the second.  - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc@@ -42,10 +42,10 @@  -} dirContains :: FilePath -> FilePath -> Bool dirContains a b = a == b || a' == b' || (a'++"/") `isPrefixOf` b'-	where-		norm p = fromMaybe "" $ absNormPath p "."-		a' = norm a-		b' = norm b+  where+	norm p = fromMaybe "" $ absNormPath p "."+	a' = norm a+	b' = norm b  {- Converts a filename into a normalized, absolute path.  -@@ -60,8 +60,8 @@  - from the specified cwd. -} absPathFrom :: FilePath -> FilePath -> FilePath absPathFrom cwd file = fromMaybe bad $ absNormPath cwd file-	where-		bad = error $ "unable to normalize " ++ file+  where+	bad = error $ "unable to normalize " ++ file  {- Constructs a relative path from the CWD to a file.  -@@ -78,31 +78,31 @@  -} relPathDirToFile :: FilePath -> FilePath -> FilePath relPathDirToFile from to = join s $ dotdots ++ uncommon-	where-		s = [pathSeparator]-		pfrom = split s from-		pto = split s to-		common = map fst $ takeWhile same $ zip pfrom pto-		same (c,d) = c == d-		uncommon = drop numcommon pto-		dotdots = replicate (length pfrom - numcommon) ".."-		numcommon = length common+  where+	s = [pathSeparator]+	pfrom = split s from+	pto = split s to+	common = map fst $ takeWhile same $ zip pfrom pto+	same (c,d) = c == d+	uncommon = drop numcommon pto+	dotdots = replicate (length pfrom - numcommon) ".."+	numcommon = length common  prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool prop_relPathDirToFile_basics from to 	| from == to = null r 	| otherwise = not (null r)-	where-		r = relPathDirToFile from to +  where+	r = relPathDirToFile from to   prop_relPathDirToFile_regressionTest :: Bool prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference-	where-		{- Two paths have the same directory component at the same-		 - location, but it's not really the same directory.-		 - Code used to get this wrong. -}-		same_dir_shortcurcuits_at_difference =-			relPathDirToFile "/tmp/r/lll/xxx/yyy/18" "/tmp/r/.git/annex/objects/18/gk/SHA256-foo/SHA256-foo" == "../../../../.git/annex/objects/18/gk/SHA256-foo/SHA256-foo"+  where+	{- Two paths have the same directory component at the same+	 - location, but it's not really the same directory.+	 - Code used to get this wrong. -}+	same_dir_shortcurcuits_at_difference =+		relPathDirToFile "/tmp/r/lll/xxx/yyy/18" "/tmp/r/.git/annex/objects/18/gk/SHA256-foo/SHA256-foo" == "../../../../.git/annex/objects/18/gk/SHA256-foo/SHA256-foo"  {- Given an original list of paths, and an expanded list derived from it,  - generates a list of lists, where each sublist corresponds to one of the@@ -114,8 +114,8 @@ segmentPaths [] new = [new] segmentPaths [_] new = [new] -- optimisation segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest-	where-		(found, rest)=partition (l `dirContains`) new+  where+	(found, rest)=partition (l `dirContains`) new  {- This assumes that it's cheaper to call segmentPaths on the result,  - than it would be to run the action separately with each path. In@@ -132,12 +132,26 @@ 		then "~/" ++ relPathDirToFile home path 		else path -{- Checks if a command is available in PATH. -}+{- Checks if a command is available in PATH.+ -+ - The command may be fully-qualified, in which case, this succeeds as+ - long as it exists. -} inPath :: String -> IO Bool-inPath command = getSearchPath >>= anyM indir-	where-		indir d = doesFileExist $ d </> command+inPath command = isJust <$> searchPath command +{- Finds a command in PATH and returns the full path to it.+ -+ - The command may be fully qualified already, in which case it will+ - be returned if it exists.+ -}+searchPath :: String -> IO (Maybe FilePath)+searchPath command+	| isAbsolute command = check command+	| otherwise = getSearchPath >>= getM indir+  where+	indir d = check $ d </> command+	check f = ifM (doesFileExist f) ( return (Just f), return Nothing )+ {- Checks if a filename is a unix dotfile. All files inside dotdirs  - count as dotfiles. -} dotfile :: FilePath -> Bool@@ -146,5 +160,5 @@ 	| f == ".." = False 	| f == "" = False 	| otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file)-	where-		f = takeFileName file+  where+	f = takeFileName file
Utility/Percentage.hs view
@@ -28,11 +28,11 @@ showPercentage precision (Percentage p) 	| precision == 0 || remainder == 0 = go $ show int 	| otherwise = go $ show int ++ "." ++ strip0s (show remainder)-	where-		go v = v ++ "%"-		int :: Integer-		(int, frac) = properFraction (fromRational p)-		remainder = floor (frac * multiplier) :: Integer-		strip0s = reverse . dropWhile (== '0') . reverse-		multiplier :: Float-		multiplier = 10 ** (fromIntegral precision)+  where+	go v = v ++ "%"+	int :: Integer+	(int, frac) = properFraction (fromRational p)+	remainder = floor (frac * multiplier) :: Integer+	strip0s = reverse . dropWhile (== '0') . reverse+	multiplier :: Float+	multiplier = 10 ** (fromIntegral precision)
Utility/Process.hs view
@@ -59,11 +59,11 @@ 		output  <- hGetContentsStrict h 		hClose h 		return output-	where-		p = (proc cmd args)-			{ std_out = CreatePipe-			, env = environ-			}+  where+	p = (proc cmd args)+		{ std_out = CreatePipe+		, env = environ+		}  {- Writes a string to a process on its stdin,   - returns its output, and also allows specifying the environment.@@ -99,13 +99,13 @@  	return output -	where-		p = (proc cmd args)-			{ std_in = CreatePipe-			, std_out = CreatePipe-			, std_err = Inherit-			, env = environ-			}+  where+	p = (proc cmd args)+		{ std_in = CreatePipe+		, std_out = CreatePipe+		, std_err = Inherit+		, env = environ+		}  {- Waits for a ProcessHandle, and throws an IOError if the process  - did not exit successfully. -}@@ -156,19 +156,19 @@ 	-> (Handle -> IO a) 	-> IO a withHandle h creator p a = creator p' $ a . select-	where-		base = p-			{ std_in = Inherit-			, std_out = Inherit-			, std_err = Inherit-			}-		(select, p')-			| h == StdinHandle  =-				(stdinHandle, base { std_in = CreatePipe })-			| h == StdoutHandle =-				(stdoutHandle, base { std_out = CreatePipe })-			| h == StderrHandle =-				(stderrHandle, base { std_err = CreatePipe })+  where+	base = p+		{ std_in = Inherit+		, std_out = Inherit+		, std_err = Inherit+		}+	(select, p')+		| h == StdinHandle  =+			(stdinHandle, base { std_in = CreatePipe })+		| h == StdoutHandle =+			(stdoutHandle, base { std_out = CreatePipe })+		| h == StderrHandle =+			(stderrHandle, base { std_err = CreatePipe })  {- Like withHandle, but passes (stdin, stdout) handles to the action. -} withBothHandles@@ -177,12 +177,12 @@ 	-> ((Handle, Handle) -> IO a) 	-> IO a withBothHandles creator p a = creator p' $ a . bothHandles-	where-		p' = p-			{ std_in = CreatePipe-			, std_out = CreatePipe-			, std_err = Inherit-			}+  where+	p' = p+		{ std_in = CreatePipe+		, std_out = CreatePipe+		, std_err = Inherit+		}  {- Forces the CreateProcessRunner to run quietly;  - both stdout and stderr are discarded. -}@@ -223,21 +223,21 @@ 		[ action ++ ":" 		, showCmd p 		]-	where-		action-			| piped (std_in p) && piped (std_out p) = "chat"-			| piped (std_in p)                      = "feed"-			| piped (std_out p)                     = "read"-			| otherwise                             = "call"-		piped Inherit = False-		piped _ = True+  where+	action+		| piped (std_in p) && piped (std_out p) = "chat"+		| piped (std_in p)                      = "feed"+		| piped (std_out p)                     = "read"+		| otherwise                             = "call"+	piped Inherit = False+	piped _ = True  {- Shows the command that a CreateProcess will run. -} showCmd :: CreateProcess -> String showCmd = go . cmdspec-	where-		go (ShellCommand s) = s-		go (RawCommand c ps) = c ++ " " ++ show ps+  where+	go (ShellCommand s) = s+	go (RawCommand c ps) = c ++ " " ++ show ps  {- Wrappers for System.Process functions that do debug logging.  -
+ Utility/QuickCheck.hs view
@@ -0,0 +1,37 @@+{- QuickCheck instances+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Utility.QuickCheck where++import Test.QuickCheck+import Data.Time.Clock.POSIX+import System.Posix.Types++{- Times before the epoch are excluded. -}+instance Arbitrary POSIXTime where+	arbitrary = nonNegative arbitrarySizedIntegral++instance Arbitrary EpochTime where+	arbitrary = nonNegative arbitrarySizedIntegral++{- Pids are never negative, or 0. -}+instance Arbitrary ProcessID where+	arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0)++{- Inodes are never negative. -}+instance Arbitrary FileID where+	arbitrary = nonNegative arbitrarySizedIntegral++{- File sizes are never negative. -}+instance Arbitrary FileOffset where+	arbitrary = nonNegative arbitrarySizedIntegral++nonNegative :: (Num a, Ord a) => Gen a -> Gen a+nonNegative g = g `suchThat` (>= 0)
Utility/Rsync.hs view
@@ -15,11 +15,11 @@  - shell. -} rsyncShell :: [CommandParam] -> [CommandParam] rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand command)]-	where-		{- rsync requires some weird, non-shell like quoting in-                 - here. A doubled single quote inside the single quoted-                 - string is a single quote. -}-		escape s = "'" ++  join "''" (split "'" s) ++ "'"+  where+	{- rsync requires some weird, non-shell like quoting in+	- here. A doubled single quote inside the single quoted+	- string is a single quote. -}+	escape s = "'" ++  join "''" (split "'" s) ++ "'"  {- Runs rsync in server mode to send a file. -} rsyncServerSend :: FilePath -> IO Bool@@ -60,22 +60,22 @@ 	 - on. Reap the resulting zombie. -} 	reapZombies 	return r-	where-		p = proc "rsync" (toCommand params)-		feedprogress prev buf h = do-			s <- hGetSomeString h 80-			if null s-				then return True-				else do-					putStr s-					hFlush stdout-					let (mbytes, buf') = parseRsyncProgress (buf++s)-					case mbytes of-						Nothing -> feedprogress prev buf' h-						(Just bytes) -> do-							when (bytes /= prev) $-								callback bytes-							feedprogress bytes buf' h+  where+	p = proc "rsync" (toCommand params)+	feedprogress prev buf h = do+		s <- hGetSomeString h 80+		if null s+			then return True+			else do+				putStr s+				hFlush stdout+				let (mbytes, buf') = parseRsyncProgress (buf++s)+				case mbytes of+					Nothing -> feedprogress prev buf' h+					(Just bytes) -> do+						when (bytes /= prev) $+							callback bytes+						feedprogress bytes buf' h  {- Checks if an rsync url involves the remote shell (ssh or rsh).  - Use of such urls with rsync requires additional shell@@ -84,13 +84,13 @@ rsyncUrlIsShell s 	| "rsync://" `isPrefixOf` s = False 	| otherwise = go s-	where-		-- host::dir is rsync protocol, while host:dir is ssh/rsh-		go [] = False-		go (c:cs)-			| c == '/' = False -- got to directory with no colon-			| c == ':' = not $ ":" `isPrefixOf` cs-			| otherwise = go cs+  where+	-- host::dir is rsync protocol, while host:dir is ssh/rsh+	go [] = False+	go (c:cs)+		| c == '/' = False -- got to directory with no colon+		| c == ':' = not $ ":" `isPrefixOf` cs+		| otherwise = go cs  {- Checks if a rsync url is really just a local path. -} rsyncUrlIsPath :: String -> Bool@@ -113,19 +113,19 @@  -} parseRsyncProgress :: String -> (Maybe Integer, String) parseRsyncProgress = go [] . reverse . progresschunks-	where-		go remainder [] = (Nothing, remainder)-		go remainder (x:xs) = case parsebytes (findbytesstart x) of-			Nothing -> go (delim:x++remainder) xs-			Just b -> (Just b, remainder)+  where+	go remainder [] = (Nothing, remainder)+	go remainder (x:xs) = case parsebytes (findbytesstart x) of+		Nothing -> go (delim:x++remainder) xs+		Just b -> (Just b, remainder) -		delim = '\r'-		{- Find chunks that each start with delim.-		 - The first chunk doesn't start with it-		 - (it's empty when delim is at the start of the string). -}-		progresschunks = drop 1 . split [delim]-		findbytesstart s = dropWhile isSpace s-		parsebytes s = case break isSpace s of-			([], _) -> Nothing-			(_, []) -> Nothing-			(b, _) -> readish b+	delim = '\r'+	{- Find chunks that each start with delim.+	 - The first chunk doesn't start with it+	 - (it's empty when delim is at the start of the string). -}+	progresschunks = drop 1 . split [delim]+	findbytesstart s = dropWhile isSpace s+	parsebytes s = case break isSpace s of+		([], _) -> Nothing+		(_, []) -> Nothing+		(b, _) -> readish b
Utility/SRV.hs view
@@ -74,11 +74,11 @@ 	r <- withResolver seed $ flip DNS.lookupSRV $ B8.fromString srv 	print r 	return $ maybe [] (orderHosts . map tohosts) r-	where-		tohosts (priority, weight, port, hostname) =-			( (priority, weight)-			, (B8.toString hostname, PortNumber $ fromIntegral port)-			)+  where+	tohosts (priority, weight, port, hostname) =+		( (priority, weight)+		, (B8.toString hostname, PortNumber $ fromIntegral port)+		) #else lookupSRV = lookupSRVHost #endif@@ -93,21 +93,21 @@  parseSrvHost :: String -> [HostPort] parseSrvHost = orderHosts . catMaybes . map parse . lines-	where-		parse l = case words l of-			[_, _, _, _, spriority, sweight, sport, hostname] -> do-				let v = -					( readish sport :: Maybe Int-					, readish spriority :: Maybe Int-					, readish sweight :: Maybe Int+  where+	parse l = case words l of+		[_, _, _, _, spriority, sweight, sport, hostname] -> do+			let v = +				( readish sport :: Maybe Int+				, readish spriority :: Maybe Int+				, readish sweight :: Maybe Int+				)+			case v of+				(Just port, Just priority, Just weight) -> Just+					( (priority, weight)+					, (hostname, PortNumber $ fromIntegral port) 					)-				case v of-					(Just port, Just priority, Just weight) -> Just-						( (priority, weight)-						, (hostname, PortNumber $ fromIntegral port)-						)-					_ -> Nothing-			_ -> Nothing+				_ -> Nothing+		_ -> Nothing  orderHosts :: [(PriorityWeight, HostPort)] -> [HostPort] orderHosts = map snd . sortBy (compare `on` fst)
Utility/SafeCommand.hs view
@@ -25,13 +25,13 @@  - a command and expects Strings. -} toCommand :: [CommandParam] -> [String] toCommand = (>>= unwrap)-	where-		unwrap (Param s) = [s]-		unwrap (Params s) = filter (not . null) (split " " s)-		-- Files that start with a dash are modified to avoid-		-- the command interpreting them as options.-		unwrap (File s@('-':_)) = ["./" ++ s]-		unwrap (File s) = [s]+  where+	unwrap (Param s) = [s]+	unwrap (Params s) = filter (not . null) (split " " s)+	-- Files that start with a dash are modified to avoid+	-- the command interpreting them as options.+	unwrap (File s@('-':_)) = ["./" ++ s]+	unwrap (File s) = [s]  {- Run a system command, and returns True or False  - if it succeeded or failed.@@ -41,9 +41,9 @@  boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ-	where-		dispatch ExitSuccess = True-		dispatch _ = False+  where+	dispatch ExitSuccess = True+	dispatch _ = False  {- Runs a system command, returning the exit status. -} safeSystem :: FilePath -> [CommandParam] -> IO ExitCode@@ -59,26 +59,26 @@  - the shell. -} shellEscape :: String -> String shellEscape f = "'" ++ escaped ++ "'"-	where-		-- replace ' with '"'"'-		escaped = join "'\"'\"'" $ split "'" f+  where+	-- replace ' with '"'"'+	escaped = join "'\"'\"'" $ split "'" f  {- Unescapes a set of shellEscaped words or filenames. -} shellUnEscape :: String -> [String] shellUnEscape [] = [] shellUnEscape s = word : shellUnEscape rest-	where-		(word, rest) = findword "" s-		findword w [] = (w, "")-		findword w (c:cs)-			| c == ' ' = (w, cs)-			| c == '\'' = inquote c w cs-			| c == '"' = inquote c w cs-			| otherwise = findword (w++[c]) cs-		inquote _ w [] = (w, "")-		inquote q w (c:cs)-			| c == q = findword w cs-			| otherwise = inquote q (w++[c]) cs+  where+	(word, rest) = findword "" s+	findword w [] = (w, "")+	findword w (c:cs)+		| c == ' ' = (w, cs)+		| c == '\'' = inquote c w cs+		| c == '"' = inquote c w cs+		| otherwise = findword (w++[c]) cs+	inquote _ w [] = (w, "")+	inquote q w (c:cs)+		| c == q = findword w cs+		| otherwise = inquote q (w++[c]) cs  {- For quickcheck. -} prop_idempotent_shellEscape :: String -> Bool
Utility/TSet.hs view
@@ -23,12 +23,12 @@ getTSet tset = runTSet $ do 	c <- readTChan tset 	go [c]-	where-		go l = do-			v <- tryReadTChan tset-			case v of-				Nothing -> return l-				Just c -> go (c:l)+  where+	go l = do+		v <- tryReadTChan tset+		case v of+			Nothing -> return l+			Just c -> go (c:l)  {- Puts items into a TSet. -} putTSet :: TSet a -> [a] -> IO ()
Utility/TempFile.hs view
@@ -22,7 +22,7 @@ viaTmp :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO () viaTmp a file content = do 	pid <- getProcessID-        let tmpfile = file ++ ".tmp" ++ show pid+	let tmpfile = file ++ ".tmp" ++ show pid 	createDirectoryIfMissing True (parentDir file) 	a tmpfile content 	renameFile tmpfile file
Utility/Tense.hs view
@@ -32,11 +32,11 @@  renderTense :: Tense -> TenseText -> Text renderTense tense (TenseText chunks) = T.concat $ map render chunks-	where-		render (Tensed present past)-			| tense == Present = present-			| otherwise = past-		render (UnTensed s) = s+  where+	render (Tensed present past)+		| tense == Present = present+		| otherwise = past+	render (UnTensed s) = s  {- Builds up a TenseText, separating chunks with spaces.  -@@ -45,13 +45,13 @@  -} tenseWords :: [TenseChunk] -> TenseText tenseWords = TenseText . go []-	where-		go c [] = reverse c-		go c (w:[]) = reverse (w:c)-		go c ((UnTensed w):ws) = go (UnTensed (addspace w) : c) ws-		go c ((Tensed w1 w2):ws) =-			go (Tensed (addspace w1) (addspace w2) : c) ws-		addspace w = T.append w " "+  where+	go c [] = reverse c+	go c (w:[]) = reverse (w:c)+	go c ((UnTensed w):ws) = go (UnTensed (addspace w) : c) ws+	go c ((Tensed w1 w2):ws) =+		go (Tensed (addspace w1) (addspace w2) : c) ws+	addspace w = T.append w " "  unTensed :: Text -> TenseText unTensed t = TenseText [UnTensed t]
Utility/ThreadScheduler.hs view
@@ -26,8 +26,8 @@  threadDelaySeconds :: Seconds -> IO () threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond)-	where-		oneSecond = 1000000 -- microseconds+  where+	oneSecond = 1000000 -- microseconds  {- Like threadDelay, but not bounded by an Int.  -@@ -52,6 +52,6 @@ 	whenM (queryTerminal stdInput) $ 		check keyboardSignal lock 	takeMVar lock-	where-		check sig lock = void $-			installHandler sig (CatchOnce $ putMVar lock ()) Nothing+  where+	check sig lock = void $+		installHandler sig (CatchOnce $ putMVar lock ()) Nothing
Utility/Touch.hsc view
@@ -48,9 +48,9 @@ instance Storable TimeSpec where 	-- use the larger alignment of the two types in the struct 	alignment _ = max sec_alignment nsec_alignment-		where-			sec_alignment = alignment (undefined::CTime)-			nsec_alignment = alignment (undefined::CLong)+	  where+		sec_alignment = alignment (undefined::CTime)+		nsec_alignment = alignment (undefined::CLong) 	sizeOf _ = #{size struct timespec} 	peek ptr = do 		sec <- #{peek struct timespec, tv_sec} ptr@@ -70,10 +70,10 @@ 		pokeArray ptr [atime, mtime] 		r <- c_utimensat at_fdcwd f ptr flags 		when (r /= 0) $ throwErrno "touchBoth"-	where-		flags = if follow-			then 0-			else at_symlink_nofollow +  where+	flags+       		| follow = 0+		| otherwise = at_symlink_nofollow   #else #if 0@@ -108,10 +108,10 @@ 		r <- syscall f ptr 		when (r /= 0) $ 			throwErrno "touchBoth"-	where-		syscall = if follow-			then c_lutimes-			else c_utimes+  where+	syscall+       		| follow = c_lutimes+		| otherwise = c_utimes  #else #warning "utimensat and lutimes not available; building without symlink timestamp preservation support"
Utility/Url.hs view
@@ -29,10 +29,10 @@  - also checking that its size, if available, matches a specified size. -} check :: URLString -> Headers -> Maybe Integer -> IO Bool check url headers expected_size = handle <$> exists url headers-	where-		handle (False, _) = False-		handle (True, Nothing) = True-		handle (True, s) = expected_size == s+  where+	handle (False, _) = False+	handle (True, Nothing) = True+	handle (True, s) = expected_size == s  {- Checks that an url exists and could be successfully downloaded,  - also returning its size if available. -}@@ -50,8 +50,8 @@ 			case rspCode r of 				(2,_,_) -> return (True, size r) 				_ -> return (False, Nothing)-	where-		size = liftM Prelude.read . lookupHeader HdrContentLength . rspHeaders+  where+	size = liftM Prelude.read . lookupHeader HdrContentLength . rspHeaders  {- Used to download large files, such as the contents of keys.  -@@ -66,17 +66,17 @@ download url headers options file 	| "file://" `isPrefixOf` url = curl 	| otherwise = ifM (inPath "wget") (wget , curl)-	where-		headerparams = map (\h -> Param $ "--header=" ++ h) headers-		wget = go "wget" $ headerparams ++ [Params "-c -O"]-		{- Uses the -# progress display, because the normal-		 - one is very confusing when resuming, showing-		 - the remainder to download as the whole file,-		 - and not indicating how much percent was-		 - downloaded before the resume. -}-		curl = go "curl" $ headerparams ++ [Params "-L -C - -# -o"]-		go cmd opts = boolSystem cmd $-			options++opts++[File file, File url]+  where+	headerparams = map (\h -> Param $ "--header=" ++ h) headers+	wget = go "wget" $ headerparams ++ [Params "-c -O"]+	{- Uses the -# progress display, because the normal+	 - one is very confusing when resuming, showing+	 - the remainder to download as the whole file,+	 - and not indicating how much percent was+	 - downloaded before the resume. -}+	curl = go "curl" $ headerparams ++ [Params "-L -C - -# -o"]+	go cmd opts = boolSystem cmd $+		options++opts++[File file, File url]  {- Downloads a small file. -} get :: URLString -> Headers -> IO String@@ -98,36 +98,36 @@  -} request :: URI -> Headers -> RequestMethod -> IO (Response String) request url headers requesttype = go 5 url-	where-		go :: Int -> URI -> IO (Response String)-		go 0 _ = error "Too many redirects "-		go n u = do-			rsp <- Browser.browse $ do-				Browser.setErrHandler ignore-				Browser.setOutHandler ignore-				Browser.setAllowRedirects False-				let req = mkRequest requesttype u :: Request_String-				snd <$> Browser.request (addheaders req)-			case rspCode rsp of-				(3,0,x) | x /= 5 -> redir (n - 1) u rsp-				_ -> return rsp-		ignore = const noop-		redir n u rsp = case retrieveHeaders HdrLocation rsp of-			[] -> return rsp-			(Header _ newu:_) ->-				case parseURIReference newu of-					Nothing -> return rsp-					Just newURI -> go n newURI_abs-						where+  where+	go :: Int -> URI -> IO (Response String)+	go 0 _ = error "Too many redirects "+	go n u = do+		rsp <- Browser.browse $ do+			Browser.setErrHandler ignore+			Browser.setOutHandler ignore+			Browser.setAllowRedirects False+			let req = mkRequest requesttype u :: Request_String+			snd <$> Browser.request (addheaders req)+		case rspCode rsp of+			(3,0,x) | x /= 5 -> redir (n - 1) u rsp+			_ -> return rsp+	ignore = const noop+	redir n u rsp = case retrieveHeaders HdrLocation rsp of+		[] -> return rsp+		(Header _ newu:_) ->+			case parseURIReference newu of+				Nothing -> return rsp+				Just newURI -> go n newURI_abs+				  where #if defined VERSION_network #if ! MIN_VERSION_network(2,4,0) #define WITH_OLD_URI #endif #endif #ifdef WITH_OLD_URI-							newURI_abs = fromMaybe newURI (newURI `relativeTo` u)+					newURI_abs = fromMaybe newURI (newURI `relativeTo` u) #else-							newURI_abs = newURI `relativeTo` u+					newURI_abs = newURI `relativeTo` u #endif-		addheaders req = setHeaders req (rqHeaders req ++ userheaders)-		userheaders = rights $ map parseHeader headers+	addheaders req = setHeaders req (rqHeaders req ++ userheaders)+	userheaders = rights $ map parseHeader headers
Utility/UserInfo.hs view
@@ -26,7 +26,7 @@  myVal :: [String] -> (UserEntry -> String) -> IO String myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars-	where-		check [] = return Nothing-		check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v-		getpwent = getUserEntryForID =<< getEffectiveUserID+  where+	check [] = return Nothing+	check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v+	getpwent = getUserEntryForID =<< getEffectiveUserID
Utility/Verifiable.hs view
@@ -33,5 +33,5 @@ {- for quickcheck -} prop_verifiable_sane :: String -> String -> Bool prop_verifiable_sane a s = verify (mkVerifiable a secret) secret-	where-		secret = fromString s+  where+	secret = fromString s
Utility/WebApp.hs view
@@ -43,11 +43,11 @@  - Note: The url *will* be visible to an attacker. -} runBrowser :: String -> (Maybe [(String, String)]) -> IO Bool runBrowser url env = boolSystemEnv cmd [Param url] env-	where+  where #ifdef darwin_HOST_OS-		cmd = "open"+	cmd = "open" #else-		cmd = "xdg-open"+	cmd = "xdg-open" #endif  {- Binds to a socket on localhost, and runs a webapp on it.@@ -75,25 +75,25 @@ 		(v4addr:_, _) -> go v4addr 		(_, v6addr:_) -> go v6addr 		_ -> error "unable to bind to a local socket"-	where-		hints = defaultHints-			{ addrFlags = [AI_ADDRCONFIG]-			, addrSocketType = Stream-			}-		{- Repeated attempts because bind sometimes fails for an-		 - unknown reason on OSX. -} -		go addr = go' 100 addr-		go' :: Int -> AddrInfo -> IO Socket-		go' 0 _ = error "unable to bind to local socket"-		go' n addr = do-			r <- tryIO $ bracketOnError (open addr) sClose (use addr)-			either (const $ go' (pred n) addr) return r-		open addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)-		use addr sock = do-			setSocketOption sock ReuseAddr 1-			bindSocket sock (addrAddress addr)-			listen sock maxListenQueue-			return sock+  where+	hints = defaultHints+		{ addrFlags = [AI_ADDRCONFIG]+		, addrSocketType = Stream+		}+	{- Repeated attempts because bind sometimes fails for an+	 - unknown reason on OSX. -} +	go addr = go' 100 addr+	go' :: Int -> AddrInfo -> IO Socket+	go' 0 _ = error "unable to bind to local socket"+	go' n addr = do+		r <- tryIO $ bracketOnError (open addr) sClose (use addr)+		either (const $ go' (pred n) addr) return r+	open addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+	use addr sock = do+		setSocketOption sock ReuseAddr 1+		bindSocket sock (addrAddress addr)+		listen sock maxListenQueue+		return sock  {- Checks if debugging is actually enabled. -} debugEnabled :: IO Bool@@ -121,8 +121,8 @@ 		--, frombs $ lookupRequestField "referer" req 		, frombs $ lookupRequestField "user-agent" req 		]-	where-		frombs v = toString $ L.fromChunks [v]+  where+	frombs v = toString $ L.fromChunks [v]  lookupRequestField :: CI.CI B.ByteString -> Wai.Request -> B.ByteString lookupRequestField k req = fromMaybe "" . lookup k $ Wai.requestHeaders req@@ -179,12 +179,12 @@ 	-> Builder insertAuthToken extractToken predicate webapp root pathbits params = 	fromText root `mappend` encodePath pathbits' encodedparams-	where-		pathbits' = if null pathbits then [T.empty] else pathbits-		encodedparams = map (TE.encodeUtf8 *** go) params'-		go "" = Nothing-		go x = Just $ TE.encodeUtf8 x-		authparam = (T.pack "auth", extractToken webapp)-		params'-			| predicate pathbits = authparam:params-			| otherwise = params+  where+	pathbits' = if null pathbits then [T.empty] else pathbits+	encodedparams = map (TE.encodeUtf8 *** go) params'+	go "" = Nothing+	go x = Just $ TE.encodeUtf8 x+	authparam = (T.pack "auth", extractToken webapp)+	params'+		| predicate pathbits = authparam:params+		| otherwise = params
debian/changelog view
@@ -1,3 +1,31 @@+git-annex (3.20130102) unstable; urgency=low++  * direct, indirect: New commands, that switch a repository to and from+    direct mode. In direct mode, files are accessed directly, rather than+    via symlinks. Note that direct mode is currently experimental. Many+    git-annex commands do not work in direct mode. Some git commands can+    cause data loss when used in direct mode repositories.+  * assistant: Now uses direct mode by default when setting up a new+    local repository.+  * OSX assistant: Uses the FSEvents API to detect file changes.+    This avoids issues with running out of file descriptors on large trees,+    as well as allowing detection of modification of files in direct mode.+    Other BSD systems still use kqueue.+  * kqueue: Fix bug that made broken symlinks not be noticed.+  * vicfg: Quote filename. Closes: #696193+  * Bugfix: Fixed bug parsing transfer info files, where the newline after+    the filename was included in it. This was generally benign, but in+    the assistant, it caused unexpected dropping of preferred content.+  * Bugfix: Remove leading \ from checksums output by sha*sum commands,+    when the filename contains \ or a newline. Closes: #696384+  * fsck: Still accept checksums with a leading \ as valid, now that+    above bug is fixed.+  * SHA*E backends: Exclude non-alphanumeric characters from extensions.+  * migrate: Remove leading \ in SHA* checksums, and non-alphanumerics+    from extensions of SHA*E keys.++ -- Joey Hess <joeyh@debian.org>  Wed, 02 Jan 2013 13:21:34 -0400+ git-annex (3.20121211) unstable; urgency=low    * webapp: Defaults to sharing box.com account info with friends, allowing
doc/assistant/release_notes.mdwn view
@@ -1,3 +1,28 @@+## version 3.20130102++This release makes several significant improvements to the git-annex+assistant, which is still in beta.++The main improvement is direct mode. This allows you to directly edit files+in the repository, and the assistant will automatically commit and sync+your changes. Direct mode is the default for new repositories created+by the assistant. To convert your existing repository to use direct mode,+manually run `git annex direct` inside the repository.++The following are known limitations of this release of the git-annex+assistant:++* If a file in a direct mode repository is modified as it's being transferred,+  the old version of the file can be lost, and fsck will later complain+  about a corrupt object.+* On BSD operating systems (but not on OS X), the assistant uses kqueue to+  watch files. Kqueue has to open every directory it watches, so too many+  directories will run it out of the max number of open files (typically+  1024), and fail. See [[this_bug|bugs/Issue_on_OSX_with_some_system_limits]]+  for a workaround.+* Also on systems with kqueue, modifications to existing files in direct+  mode will not be noticed.+ ## version 3.20121211  This release of the git-annex assistant (which is still in beta)
doc/bugs.mdwn view
@@ -1,6 +1,6 @@ This is git-annex's bug list. Link bugs to [[bugs/done]] when done. -[[!inline pages="./bugs/* and !./bugs/done and !link(done) +[[!inline pages="./bugs/* and !./bugs/*/* and !./bugs/done and !link(done)  and !*/Discussion" actions=yes postform=yes show=0 archive=yes]]  [[!edittemplate template=templates/bugtemplate match="bugs/*" silent=yes]]
doc/bugs/Issue_on_OSX_with_some_system_limits.mdwn view
@@ -18,4 +18,7 @@  To be precise, I suspect that the kqueue limit is 256, I had 325 files in the 'queue', I ended up doing a _git annex add_ manually and all was fine. -[[!tag /design/assistant/OSX]]+[[!meta title="kqueue system limits"]]++> This affects BSD systems that use Kqueue. It no longer affects OSX,+> since we use FSEvents there instead. --[[Joey]]
doc/bugs/OSX_alias_permissions_and_versions_problem.mdwn view
@@ -31,3 +31,7 @@ Dropbox even allows to put a symlink in the dropbox directory, and it will sync the file.   [[!tag /design/assistant/OSX]]++> Now the assistant creates new repositories using direct mode on OSX.+> In direct mode, there is no locking of files; they can be modified+> directly. [[done]] --[[Joey]]
doc/bugs/OSX_app_issues.mdwn view
@@ -1,4 +1,6 @@ This is a collection of problem reports for the standalone OSX app. If you have a problem using it, post it here. --[[Joey]]  +(Some things that should be fixed now have been moved to [[old]].)+ [[!tag /design/assistant/OSX]]
− doc/bugs/OSX_app_issues/comment_10_bb823dc3cd6dc914ed14c176afa0b2f3._comment 
@@ -1,8 +0,0 @@-[[!comment format=mdwn- username="http://wiggy.net/"- nickname="Wichert"- subject="Re: Trying to add remote server after failed attempt blocks forever"- date="2012-11-28T21:26:36Z"- content="""-It appears to not just wait forever: there was also a **git config --null --list** process taking all CPU. -"""]]
− doc/bugs/OSX_app_issues/comment_11_a30e69fed14b0809184ffe05358ab871._comment 
@@ -1,10 +0,0 @@-[[!comment format=mdwn- username="http://joeyh.name/"- ip="4.154.6.49"- subject="comment 11"- date="2012-11-29T19:55:17Z"- content="""-I've dealt with these ssh issues by including ssh in the app bundle.--OTOH, I don't know how `git config --null --list` could possibly take any appreciable amount of CPU to run. -"""]]
− doc/bugs/OSX_app_issues/comment_12_23d47b3696e537d60df1d383f33f19e4._comment 
@@ -1,15 +0,0 @@-[[!comment format=mdwn- username="https://www.google.com/accounts/o8/id?id=AItOawnqQyhiNXdPIWWSuu232luY5nc-h5RS8bE"- nickname="Arve"- subject="Make Repository hangs (git consuming 100% cpu)"- date="2012-12-01T01:26:04Z"- content="""-When starting git-annex from Applications first time (Finder or spotlight), pressing \"Make Repository\" hangs.--\"ps aux | grep git\" shows-arve            1723 100.0  0.0  2459668   3988   ??  R     2:00AM   0:31.30 git init --quiet /Users/arve/Desktop/annex/--Strange enough, if i start the app from terminal (/Applications/git-annex.app/Contents/MacOS/git-annex-webapp), the creation of repository works. Though, if I kill it and start git-annex from spotlight, the web frontend doesn't show, and \"git config --null --list\" is consuming 100% cpu.--My OSX version is 10.8.1-"""]]
− doc/bugs/OSX_app_issues/comment_13_be5738b42b13ec8cd828c5fa66f030e8._comment 
@@ -1,10 +0,0 @@-[[!comment format=mdwn- username="http://joeyh.name/"- ip="4.154.6.49"- subject="comment 13"- date="2012-12-01T18:50:31Z"- content="""-So it works with a controlling console, and git commands are somehow misbehaving without a controlling console. Very strange.--Any chance you can `dtrace -p` the stuck git processes to see what they're doing or what resource they're blocked on?-"""]]
− doc/bugs/OSX_app_issues/comment_14_e126d87a263f3aa6261f72ee7ff086fc._comment 
@@ -1,8 +0,0 @@-[[!comment format=mdwn- username="https://www.google.com/accounts/o8/id?id=AItOawnqQyhiNXdPIWWSuu232luY5nc-h5RS8bE"- nickname="Arve"- subject="comment 14"- date="2012-12-01T22:33:21Z"- content="""-\"dtrace -p pid\" gives \"dtrace: no probes specified.\" I've tried to read man dtrace, and some online resources, dtrace is new to me. Any directions?-"""]]
− doc/bugs/OSX_app_issues/comment_15_e58bd3d66f0f43c159d2b37172f152de._comment 
@@ -1,8 +0,0 @@-[[!comment format=mdwn- username="http://joeyh.name/"- ip="4.154.6.49"- subject="comment 15"- date="2012-12-01T22:49:54Z"- content="""-Seems the command I was thinking of is really `dtruss -p`-"""]]
− doc/bugs/OSX_app_issues/comment_16_01f2c968bad66b0ff0c09eb468325deb._comment 
@@ -1,8 +0,0 @@-[[!comment format=mdwn- username="https://www.google.com/accounts/o8/id?id=AItOawnqQyhiNXdPIWWSuu232luY5nc-h5RS8bE"- nickname="Arve"- subject="comment 16"- date="2012-12-01T22:53:29Z"- content="""-Returns alot of \"workq_kernreturn(0x1, 0x107D27000, 0x0)		 = -1 Err#22\"  and occasionally \"dtrace: 36244 drops on CPU 1\"-"""]]
− doc/bugs/OSX_app_issues/comment_17_82d9963e1fbf17644ce697e5a43943f5._comment 
@@ -1,16 +0,0 @@-[[!comment format=mdwn- username="http://joeyh.name/"- ip="4.154.6.49"- subject="comment 17"- date="2012-12-01T23:08:50Z"- content="""-Doesn't say anything to me..--Using nohup might help, or at least get us an error message to see. Edit `git-annex.app/Contents/MacOS/git-annex-webapp` and make the last line:--<pre>-nohup \"$base/runshell\" git-annex webapp \"$@\"-</pre>--It'll put a nohup.out log file in your home directory, or somewhere like that.-"""]]
− doc/bugs/OSX_app_issues/comment_18_29af9df9ea295d114574e76e15b8e737._comment 
@@ -1,8 +0,0 @@-[[!comment format=mdwn- username="https://www.google.com/accounts/o8/id?id=AItOawnqQyhiNXdPIWWSuu232luY5nc-h5RS8bE"- nickname="Arve"- subject="comment 18"- date="2012-12-02T00:02:51Z"- content="""-Adding nohup doesn't produce any output (that I can find; sudo find / -name nohup.out) :/-"""]]
− doc/bugs/OSX_app_issues/comment_19_6d6341b05123cd317c4eac96353c8662._comment 
@@ -1,10 +0,0 @@-[[!comment format=mdwn- username="http://joeyh.name/"- ip="4.154.2.244"- subject="comment 19"- date="2012-12-07T16:13:42Z"- content="""-This hang seems not to occur on OSX 10.7, which is the version the autobuilder is running. So this is some sort of incompatability.--So, building git-annex from source should avoid the problem. I'd like to get a version of the app built for 10.8, have not yet been able to arrange that.-"""]]
− doc/bugs/OSX_app_issues/comment_3_08613b2e2318680508483d204a43da76._comment 
@@ -1,76 +0,0 @@-[[!comment format=mdwn- username="http://edheil.wordpress.com/"- nickname="edheil"- subject="No luck running it on OS X Lion."- date="2012-11-21T06:07:55Z"- content="""-here's the crash info:--<pre>-Process:         git-annex [84369]-Path:            /Applications/git-annex.app/Contents/MacOS/bin/git-annex-Identifier:      git-annex-Version:         ??? (???)-Code Type:       X86-64 (Native)-Parent Process:  sh [84364]--Date/Time:       2012-11-21 00:27:03.068 -0500-OS Version:      Mac OS X 10.7.5 (11G63)-Report Version:  9--Crashed Thread:  0--Exception Type:  EXC_BREAKPOINT (SIGTRAP)-Exception Codes: 0x0000000000000002, 0x0000000000000000--Application Specific Information:-dyld: launch, loading dependent libraries--Dyld Error Message:-  Library not loaded: /opt/local/lib/libgss.3.dylib-  Referenced from: /Applications/git-annex.app/Contents/MacOS/opt/local/lib/libgsasl.7.dylib-  Reason: image not found--Binary Images:-       0x105baa000 -        0x107b89fe7 +git-annex (??? - ???) <45311C82-015C-3F87-9F9B-01325EFBD0D9> /Applications/git-annex.app/Contents/MacOS/bin/git-annex-       0x10822d000 -        0x10823eff7 +libz.1.dylib (1.2.7 - compatibility 1.0.0) <57016CC1-AD54-337E-A983-457933B24D35> /Applications/git-annex.app/Contents/MacOS/opt/local/lib/libz.1.dylib-       0x108245000 -        0x10827dff7 +libpcre.1.dylib (2.1.0 - compatibility 2.0.0) <431BD758-FA7B-38B3-AB7E-6511EC06152E> /Applications/git-annex.app/Contents/MacOS/opt/local/lib/libpcre.1.dylib-       0x108283000 -        0x1083b3ff7 +libxml2.2.dylib (11.0.0 - compatibility 11.0.0) <0663F820-D436-3304-B12F-9158901087EB> /Applications/git-annex.app/Contents/MacOS/opt/local/lib/libxml2.2.dylib-       0x1083e9000 -        0x108400fef +libgsasl.7.dylib (16.6.0 - compatibility 16.0.0) <41503EE1-D58B-385C-AC2E-BEAA7D0D4E38> /Applications/git-annex.app/Contents/MacOS/opt/local/lib/libgsasl.7.dylib-       0x10840a000 -        0x1084a1fff +libgnutls.26.dylib (49.3.0 - compatibility 49.0.0) <0320352A-3336-3B6B-A7DE-F3069669AD27> /Applications/git-annex.app/Contents/MacOS/opt/local/lib/libgnutls.26.dylib-       0x1084c3000 -        0x1084f1ff7 +libidn.11.dylib (18.8.0 - compatibility 18.0.0) <97073970-9370-3F85-B943-1B989EA41148> /Applications/git-annex.app/Contents/MacOS/opt/local/lib/libidn.11.dylib-       0x1084fc000 -        0x1085f5ff7 +libiconv.2.dylib (8.1.0 - compatibility 8.0.0) <1B8D243B-F617-301E-97B1-EE78A72617AB> /Applications/git-annex.app/Contents/MacOS/opt/local/lib/libiconv.2.dylib-       0x108606000 -        0x108606fff +libcharset.1.dylib (2.0.0 - compatibility 2.0.0) <E3797413-2AA3-3698-B393-E1203B4799A0> /Applications/git-annex.app/Contents/MacOS/opt/local/lib/libcharset.1.dylib-       0x10860c000 -        0x108665fef +libgmp.10.dylib (11.5.0 - compatibility 11.0.0) <EE407B22-0F44-38B6-9937-10CA6A529F37> /Applications/git-annex.app/Contents/MacOS/opt/local/lib/libgmp.10.dylib-       0x108675000 -        0x1086a2fe7 +libSystem.B.dylib (159.1.0 - compatibility 1.0.0) <7BEBB139-50BB-3112-947A-F4AA168F991C> /Applications/git-annex.app/Contents/MacOS/usr/lib/libSystem.B.dylib-       0x1086b4000 -        0x1086c8fef +libgcc_s.1.dylib (??? - ???) <3C5BF0B8-B1E9-3B41-B52F-F7499687217C> /Applications/git-annex.app/Contents/MacOS/opt/local/lib/gcc47/libgcc_s.1.dylib-       0x1086d8000 -        0x1086f5ff7 +liblzma.5.dylib (6.4.0 - compatibility 6.0.0) <1D682E06-EB89-34CA-855A-AEF611C4DF86> /usr/local/lib/liblzma.5.dylib-    0x7fff657aa000 -     0x7fff657debaf  dyld (195.6 - ???) <0CD1B35B-A28F-32DA-B72E-452EAD609613> /usr/lib/dyld-    0x7fff8b669000 -     0x7fff8b672ff7  libsystem_notify.dylib (80.1.0 - compatibility 1.0.0) <A4D651E3-D1C6-3934-AD49-7A104FD14596> /usr/lib/system/libsystem_notify.dylib-    0x7fff8b6e4000 -     0x7fff8b6e5ff7  libsystem_sandbox.dylib (??? - ???) <2A09E4DA-F47C-35CB-B70C-E0492BA9F20E> /usr/lib/system/libsystem_sandbox.dylib-    0x7fff8c000000 -     0x7fff8c006ff7  libunwind.dylib (30.0.0 - compatibility 1.0.0) <1E9C6C8C-CBE8-3F4B-A5B5-E03E3AB53231> /usr/lib/system/libunwind.dylib-    0x7fff8c1c4000 -     0x7fff8c1c5ff7  libremovefile.dylib (21.1.0 - compatibility 1.0.0) <739E6C83-AA52-3C6C-A680-B37FE2888A04> /usr/lib/system/libremovefile.dylib-    0x7fff8cf13000 -     0x7fff8cf4efff  libsystem_info.dylib (??? - ???) <35F90252-2AE1-32C5-8D34-782C614D9639> /usr/lib/system/libsystem_info.dylib-    0x7fff8dbc3000 -     0x7fff8dbc8fff  libcache.dylib (47.0.0 - compatibility 1.0.0) <1571C3AB-BCB2-38CD-B3B2-C5FC3F927C6A> /usr/lib/system/libcache.dylib-    0x7fff8dbc9000 -     0x7fff8dbd0fff  libcopyfile.dylib (85.1.0 - compatibility 1.0.0) <0AB51EE2-E914-358C-AC19-47BC024BDAE7> /usr/lib/system/libcopyfile.dylib-    0x7fff8dbdf000 -     0x7fff8dbedfff  libdispatch.dylib (187.10.0 - compatibility 1.0.0) <8E03C652-922A-3399-93DE-9EA0CBFA0039> /usr/lib/system/libdispatch.dylib-    0x7fff8dcf2000 -     0x7fff8dcf7ff7  libsystem_network.dylib (??? - ???) <5DE7024E-1D2D-34A2-80F4-08326331A75B> /usr/lib/system/libsystem_network.dylib-    0x7fff8e1bb000 -     0x7fff8e298fef  libsystem_c.dylib (763.13.0 - compatibility 1.0.0) <41B43515-2806-3FBC-ACF1-A16F35B7E290> /usr/lib/system/libsystem_c.dylib-    0x7fff8e6e2000 -     0x7fff8e6eafff  libsystem_dnssd.dylib (??? - ???) <584B321E-5159-37CD-B2E7-82E069C70AFB> /usr/lib/system/libsystem_dnssd.dylib-    0x7fff8fab6000 -     0x7fff8fab8fff  libquarantine.dylib (36.7.0 - compatibility 1.0.0) <8D9832F9-E4A9-38C3-B880-E5210B2353C7> /usr/lib/system/libquarantine.dylib-    0x7fff8fc3e000 -     0x7fff8fc80ff7  libcommonCrypto.dylib (55010.0.0 - compatibility 1.0.0) <BB770C22-8C57-365A-8716-4A3C36AE7BFB> /usr/lib/system/libcommonCrypto.dylib-    0x7fff90fa3000 -     0x7fff90fa9fff  libmacho.dylib (800.0.0 - compatibility 1.0.0) <165514D7-1BFA-38EF-A151-676DCD21FB64> /usr/lib/system/libmacho.dylib-    0x7fff90faa000 -     0x7fff90fabfff  libunc.dylib (24.0.0 - compatibility 1.0.0) <337960EE-0A85-3DD0-A760-7134CF4C0AFF> /usr/lib/system/libunc.dylib-    0x7fff910b4000 -     0x7fff910b8fff  libmathCommon.A.dylib (2026.0.0 - compatibility 1.0.0) <FF83AFF7-42B2-306E-90AF-D539C51A4542> /usr/lib/system/libmathCommon.A.dylib-    0x7fff916b9000 -     0x7fff916bdfff  libdyld.dylib (195.6.0 - compatibility 1.0.0) <FFC59565-64BD-3B37-90A4-E2C3A422CFC1> /usr/lib/system/libdyld.dylib-    0x7fff916be000 -     0x7fff916defff  libsystem_kernel.dylib (1699.32.7 - compatibility 1.0.0) <66C9F9BD-C7B3-30D4-B1A0-03C8A6392351> /usr/lib/system/libsystem_kernel.dylib-    0x7fff916df000 -     0x7fff916e0fff  libdnsinfo.dylib (395.11.0 - compatibility 1.0.0) <853BAAA5-270F-3FDC-B025-D448DB72E1C3> /usr/lib/system/libdnsinfo.dylib-    0x7fff929f8000 -     0x7fff929fdfff  libcompiler_rt.dylib (6.0.0 - compatibility 1.0.0) <98ECD5F6-E85C-32A5-98CD-8911230CB66A> /usr/lib/system/libcompiler_rt.dylib-    0x7fff93a3c000 -     0x7fff93a3cfff  libkeymgr.dylib (23.0.0 - compatibility 1.0.0) <61EFED6A-A407-301E-B454-CD18314F0075> /usr/lib/system/libkeymgr.dylib-    0x7fff97139000 -     0x7fff9713aff7  libsystem_blocks.dylib (53.0.0 - compatibility 1.0.0) <8BCA214A-8992-34B2-A8B9-B74DEACA1869> /usr/lib/system/libsystem_blocks.dylib-    0x7fff9724f000 -     0x7fff9726cfff  libxpc.dylib (77.19.0 - compatibility 1.0.0) <9F57891B-D7EF-3050-BEDD-21E7C6668248> /usr/lib/system/libxpc.dylib-    0x7fff97cfe000 -     0x7fff97d08ff7  liblaunch.dylib (392.39.0 - compatibility 1.0.0) <8C235D13-2928-30E5-9E12-2CC3D6324AE2> /usr/lib/system/liblaunch.dylib-</pre>- --"""]]
+ doc/bugs/OSX_app_issues/comment_4_4cda124b57ddc87645d5822f14ed5c59._comment view
@@ -0,0 +1,8 @@+[[!comment format=mdwn+ username="https://www.google.com/accounts/o8/id?id=AItOawkBTVYS5lTecuenAB01eHgfUxE20vWVpU4"+ nickname="Peng"+ subject="Large Mountain Loin package size"+ date="2012-12-28T22:17:43Z"+ content="""+I see that git-annex package file is 489.9MB on Mac Mountain Loin (git-annex.dmg.bz2). The file git-annex.dmg.bz2 is only of size 24M. Is there any way to reduce the package size?+"""]]
− doc/bugs/OSX_app_issues/comment_6_12bd83e7e2327c992448e87bdb85d17e._comment 
@@ -1,15 +0,0 @@-[[!comment format=mdwn- username="https://me.yahoo.com/a/6xTna_B_h.ECb6_ftC2dYLytAEwrv36etg_054U-#4c1e7"- nickname="Fake"- subject="libncurses on 10.7"- date="2012-10-17T21:24:24Z"- content="""-I'm getting an error from gpg when I try to set up a repository on a remote server with encrypted rsync.  Looks like libncurses in /usr/lib is 32 bit:--    Dyld Error Message:-      Library not loaded: /opt/local/lib/libncurses.5.dylib-      Referenced from: /Applications/git-annex.app/Contents/MacOS/opt/local/lib/libreadline.6.2.dylib-      Reason: no suitable image found.  Did find:-  	  /usr/lib/libncurses.5.dylib: mach-o, but wrong architecture-  	  /usr/lib/libncurses.5.dylib: mach-o, but wrong architecture-"""]]
− doc/bugs/OSX_app_issues/comment_6_cea97dbbfb566a9fe463365ca4511119._comment 
@@ -1,16 +0,0 @@-[[!comment format=mdwn- username="http://nico.kaiser.me/"- nickname="Nico Kaiser"- subject="git-annex crashing on OS X 10.8.2"- date="2012-11-27T08:01:29Z"- content="""-    $ /Applications/git-annex.app/Contents/MacOS/git-annex-webapp-    dyld: Symbol not found: _OBJC_CLASS_$_NSObject-      Referenced from: /usr/bin/open-      Expected in: /Applications/git-annex.app/Contents/MacOS/usr/lib/libobjc.A.dylib-     in /usr/bin/open-    WebApp crashed: failed to start web browser-    -    Launching web browser on file:///var/folders/8g/_fvs7jf572l4fj03q5mhrq9r0000gn/T/webapp1196.html--"""]]
− doc/bugs/OSX_app_issues/comment_7_911f187d46890093a54859032ada2442._comment 
@@ -1,10 +0,0 @@-[[!comment format=mdwn- username="http://joeyh.name/"- ip="4.154.6.49"- subject="comment 7"- date="2012-11-27T21:13:18Z"- content="""-@Nico, that's actually kind of promising; people have been reporting much earlier crashes with OSX. This later crash is one I think I can do something about! :)--So, it looks like the standalone app build needs to run the web browser in a clean environment that doesn't use any of its bundled libraries. I've committed that change and it will be in a release later today.-"""]]
− doc/bugs/OSX_app_issues/comment_8_08b091a58106ca6050ac669579ed9ff4._comment 
@@ -1,11 +0,0 @@-[[!comment format=mdwn- username="http://wiggy.net/"- nickname="Wichert"- subject="Adding a remote server repository fails"- date="2012-11-28T21:17:23Z"- content="""-The error message I get is:--> Failed to ssh to the server. Transcript: dyld: Symbol not found: ___progname Referenced from: /usr/bin/ssh Expected in: /Users/wichert/Applications/git-annex.app/Contents/MacOS/usr/lib/libSystem.B.dylib in /usr/bin/ssh--"""]]
− doc/bugs/OSX_app_issues/comment_9_8464c839cb169a4c6e72bebdc2065e9a._comment 
@@ -1,8 +0,0 @@-[[!comment format=mdwn- username="http://wiggy.net/"- nickname="Wichert"- subject="Trying to add remote server after failed attempt blocks forever"- date="2012-11-28T21:23:54Z"- content="""-Out of curiosity I checked what would happen if I tried to add a remote server repo again after it just failed with the missing library error (see previous comment). Surprisingly the webapp is now waiting forever at the *Testing server ...* message.-"""]]
+ doc/bugs/OSX_app_issues/old.mdwn view
@@ -0,0 +1,1 @@+These issues should be fixed now.
doc/bugs/OSX_git-annex.app_error:__LSOpenURLsWithRole__40____41__.mdwn view
@@ -22,3 +22,5 @@ **Please provide any additional information below.**  [[!tag /design/assistant/OSX]]++> This was fixed a while ago. [[done]] --[[Joey]]
+ doc/bugs/__91__webapp__93___pause_syncing_with_specific_repository.mdwn view
@@ -0,0 +1,5 @@+[Due to some stupid issue on my and AT&T's part] one of my remote repositories is currently unreachable. I would like to tell the webapp/assistant to not attempt to sync with it, or, at least, modify this error message to be more specific (by telling me which repository is unreachable).++In a red bubble it says: "Synced with rose 60justin"++That verbage is the same if they all succeed. The only difference is the red instead of green. Would be nice to know exactly which machine to kick (if I didn't already know, eg I was syncing only with repositories not under my control).
+ doc/bugs/annex-rsync-options_shell-split_carelessly.mdwn view
@@ -0,0 +1,16 @@+with rsync, it is sometimes the case that one needs to specify ssh options -- typical examples from the rsync man page are `rsync  -e 'ssh -p 2234'`. as git-annex does the shell splitting of the arguments in `annex-rsync-options` (see [[special remotes/rsync]]) itself by looking for whitespace, these options can't be passed directly. (`annex-rsync-options = -e 'ssh -p 2234'` gets split to `["rsync", "-e", "'ssh", "-p", "2234'"]` instead of `["rsync", "-e", "ssh -p 2234"]`).++git-annex should respect shell splitting rules when looking at annex-rsync-options. (i suppose there is a haskell library or module for that; in python, we have the `shlex` module for that).++## workaround++put this in .git/ssh and mark it as executable:++    #!/bin/sh+    exec ssh -p 2234 $@++put this in your git annex config in the particular remote's section:++    annex-rsync-options = -e /local/path/to/your/repo/.git/ssh++(typical bug report information: observed with git-annex 3.20121127 on debian)
+ doc/bugs/assistant_not_noticing_file_renames__44___not_fixing_files.mdwn view
@@ -0,0 +1,68 @@+What steps will reproduce the problem?++In one terminal, I created a new annex and started the assistant watching it.  ++In another, I added a file file1; assistant noticed it and added it to the annex.++I moved file1 to a directory directory1; the link broke and assistant did not fix it.  ++I created a file called file2 inside directory 2; assistant noticed it and added it to the annex.++I moved file2 back up to the annex root directory; the link broke and assistant did not fix it.++I created a file file3 in the annex root directory; assistant noticed it and added it to the annex.++Here is the content of the first terminal, where I created the annex and ran assistant:+++    ~$ mkdir testannex+    ~$ cd testannex/+    testannex$ git init .+    Initialized empty Git repository in /Users/ed/testannex/.git/+    testannex$ git annex init "test annex"+    init test annex ok+    (Recording state in git...)+    testannex$ git annex assistant --foreground+    assistant . (scanning...) (started...) add file1 (checksum...) ok+    (Recording state in git...)+    (Recording state in git...)+    add directory1/file2 (checksum...) ok+    (Recording state in git...)+    (Recording state in git...)+    add file3 (checksum...) ++here is the content of the second terminal, where I created and moved files:++    ~$ cd testannex+    testannex$ echo "file1 content" > file1+    testannex$ mkdir directory1+    testannex$ ls -l file1+    lrwxr-xr-x  1 ed  staff  180 Dec 13 15:40 file1 -> .git/annex/objects/FX/51/SHA256E-s14--edac79763e630b1b77aefb6c284bcb0362dea71c0548be0e793ffa8fd5907b80/SHA256E-s14--edac79763e630b1b77aefb6c284bcb0362dea71c0548be0e793ffa8fd5907b80+    testannex$ mv file1 directory1/+    testannex$ cd directory1/+    directory1$ cat file1+    cat: file1: No such file or directory+    directory1$ echo "file2 content" > file2+    directory1$ cat file2+    file2 content+    directory1$ cat file1+    cat: file1: No such file or directory+    directory1$ mv file2 ../+    directory1$ cd ..+    testannex$ echo "file3 content" > file3+    testannex$ +++What is the expected output? What do you see instead?++The links do not break when moved to another directory.++What version of git-annex are you using? On what operating system?++One compiled using cabal from checkout 739c937++Please provide any additional information below.++> [[fixed|done]]; this turned out to be an kqueue specific bug,+> the kqueue code statted new files, but that files for a broken symlink.+> Using lstat instead fixed this. --[[Joey]]
+ doc/bugs/git-annex_fix_not_noticing_file_renames.mdwn view
@@ -0,0 +1,36 @@+What steps will reproduce the problem?++    ~$ mkdir testannex+    ~$ cd testannex/+    testannex$ git init+    Initialized empty Git repository in /Users/ed/testannex/.git/+    testannex$ git annex init "test annex"+    init test annex ok+    (Recording state in git...)+    testannex$ echo "file1" > file1+    testannex$ git annex add file1+    add file1 (checksum...) ok+    (Recording state in git...)+    testannex$ mkdir directory+    testannex$ mv file1 directory/+    testannex$ cat directory/file1 +    cat: directory/file1: No such file or directory+    testannex$ git annex fix directory/file1+    git-annex: directory/file1 not found+++What is the expected output? What do you see instead?++    git annex fix should fix the symlink.  It looks like maybe it's *following* the symlink?++What version of git-annex are you using? On what operating system?++    checkout:  20d195f   compiled on OS X 10.7 using cabal.  ++Please provide any additional information below.++    git annex assistant is not noticing file renames either.++> git-annex commands (other than `git annex add`) only operate on files+> checked into git, which `directory/file1` is not, since you did not use+> `git mv`. Once you `git add` the file, it'll work. [[done]] --[[Joey]]
+ doc/bugs/glacier_from_multiple_repos.mdwn view
@@ -0,0 +1,14 @@+glacier-cli currently relies on a local cache of+inventory information, and so other git-annexes using the same glacier+repository are not able to access stuff in it, unless and until+`glacier vault sync` is run.++An example of this causing trouble is with the assistant. When a file is+moved into archive/, the assistant that sends it to glacier is able to+trust that it's in glacier and remove the local copy. But other assistants+that also have a copy cannot trust that, and so don't remove their copies.++I've discussed with glacier-cli's author making git-annex store enough info+in its branch to be able to bootstrap glacier-cli to know about a file.+This seems doable and he had a design; waiting on movement +on the glacier-cli side.
− doc/bugs/glacier_with_assistant_bugs.mdwn 
@@ -1,11 +0,0 @@-* When a file is moved into archive/, the assistant that sends it to-  glacier is able to trust that it's in glacier and remove the local copy.-  But other assistants that also have a copy cannot trust that, and so-  don't remove their copies.--* For that matter, glacier-cli currently relies on a local cache of-  inventory information, and so other git-annexes using the same glacier-  repository are not able to access stuff in it, unless and until-  `glacier vault sync` is run.--[[!tag /design/assistant]]
doc/bugs/gpg_bundled_with_OSX_build_fails.mdwn view
@@ -20,3 +20,6 @@ git annex Version: 3.20121017 on Mac OS X 10.7.5  [[!tag /design/assistant/OSX]]++> Libraries are now handled better in the OSX app and this should be able+> to happen anymore. [[done]] --[[Joey]]
+ doc/bugs/optinally_transfer_file_unencryptedly.mdwn view
@@ -0,0 +1,3 @@+I have a git-annex repository on a NSLU 2, and transfers are much slower over ssh compared to unencrypted transfers (no wonder at that CPU speed). For the files that I am transferring, no encryption would be necessary. Unfortunately, ssh in Debian does not support "-c none" to disable encryption.++It would be nice if git-annex would have a way of conveniently transferring files in another way than SSH. I’m not sure what a good way would be – maybe launching a one-shot HTTP-server on the sending end? Haskell libraries for that would be available... Of course it is not always the case that the host reachable with "ssh foo" is also reachable via TCP at "foo:1234"... And there are surely more problem. But still, it would be nice :-)
doc/bugs/pasting_into_annex_on_OSX.mdwn view
@@ -20,4 +20,9 @@ >> Reopening since I've heard from someone else that it can still happen. >> --[[Joey]]  +>>> Closing again, since the assistant now makes new repositories on OSX+>>> using direct mode, which should avoid this problem. NB: any existing+>>> repositories you have on OSX should be switched to use direct mode by+>>> manually running `git annex direct` in them. [[done]] --[[Joey]]+ [[!tag /design/assistant/OSX]]
doc/design/assistant.mdwn view
@@ -10,10 +10,10 @@ * Month 3 "easy setup": [[!traillink configurators]] [[!traillink pairing]] * Month 4 "cloud": [[!traillink cloud]] [[!traillink transfer_control]] * Month 5 "cloud continued": [[!traillink xmpp]] [[!traillink more_cloud_providers]]+* Month 6 "9k bonus round": [[!traillink desymlink]]  We are, approximately, here: -* Month 6 "9k bonus round": [[!traillink desymlink]] * Month 7: user-driven features and polishing;    [presentation at LCA2013](https://lca2013.linux.org.au/schedule/30059/view_talk) * Month 8: [[!traillink Android]]
doc/design/assistant/OSX.mdwn view
@@ -14,4 +14,4 @@  Bugs: -[[!inline pages="tagged(design/assistant/OSX)" show=0 archive=yes]]+[[!inline pages="tagged(design/assistant/OSX) and !link(bugs/done)" show=0 archive=yes]]
doc/design/assistant/blog.mdwn view
@@ -2,4 +2,10 @@ [crowd funded on Kickstarter](http://www.kickstarter.com/projects/joeyh/git-annex-assistant-like-dropbox-but-with-your-own/). I'll be blogging about my progress here on a semi-daily basis. +[[!sidebar content="""+[[!calendar type="month" pages="page(design/assistant/blog/*)"]]+[[!calendar type="month" month="-1" pages="page(design/assistant/blog/*)"]]+[[!calendar type="month" month="-2" pages="page(design/assistant/blog/*)"]]+"""]]+ [[!inline pages="page(design/assistant/blog/*)" show=0]]
doc/design/assistant/blog/day_107__memory_leak.mdwn view
@@ -1,6 +1,6 @@ More bugfixes today. The assistant now seems to have enough users that they're turning up interesting bugs, which is good. But does keep me too-busy to add many more bugs^Wcode.+busy to add many more bugs\^Wcode.  The fun one today made it bloat to eat all memory when logging out of a Linux desktop. I tracked that back to a bug in the Haskell DBUS library
+ doc/design/assistant/blog/day_150__12:12.mdwn view
@@ -0,0 +1,53 @@+Yesterday I cut another release. However, getting an OSX build took until+12:12 pm today because of a confusion about the location of lsof on OSX. The+OSX build is now available, and I'm looking forward to hearing if it's working!++----++Today I've been working on making `git annex sync` commit in direct mode.++For this I needed to find all new, modified, and deleted files, and I also+need the git SHA from the index for all non-new files. There's not really+an ideal git command to use to query this. For now I'm using+`git ls-files --others --stage`, which works but lists more files than I+really need to look at. It might be worth using one of the Haskell libraries+that can directly read git's index.. but for now I'll stick with `ls-files`.++It has to check all direct mode files whose content is present, which means+one stat per file (on top of the stat that git already does), as well as one+retrieval of the key per file (using the single `git cat-file` process that+git-annex talks to).++This is about as efficient as I can make it, except that unmodified+annexed files whose content is not present are listed due to --stage,+and so it has to stat those too, and currently also feeds them into `git add`.++The assistant will be able to avoid all this work, except once at startup.++Anyway, direct mode committing is working!++For now, `git annex sync` in direct mode also adds new files. This because+`git annex add` doesn't work yet in direct mode.++It's possible for a direct mode file to be changed during a commit,+which would be a problem since committing involves things like calculating+the key and caching the mtime/etc, that would be screwed up. I took+care to handle that case; it checks the mtime/etc cache before and after+generating a key for the file, and if it detects the file has changed,+avoids committing anything. It could retry, but if the file is a VM disk+image or something else that's constantly modified, commit retrying forever+would not be good.++----++For `git annex sync` to be usable in direct mode, it still needs+to handle merging. It looks like I may be able to just enhance the automatic+conflict resolution code to know about typechanged direct mode files.++The other missing piece before this can really be used is that currently+the key to file mapping is only maintained for files added locally, or+that come in via `git annex sync`. Something needs to set up that mapping+for files present when the repo is initally cloned. Maybe the thing+to do is to have a `git annex directmode` command that enables/disables+direct mode and can setup the the mapping, as well as any necessary unlocks+and setting the trust level to untrusted.
+ doc/design/assistant/blog/day_151__direct_mode_toggle.mdwn view
@@ -0,0 +1,59 @@+Built `git annex direct` and `git annex indirect` to toggle back and forth+between direct mode. Made `git annex status` show if the repository is in+direct mode. Now *only* merging is needed for direct mode to be basically+usable. ++I can do a little demo now. Pay attention to the "@" ls shows at the end+of symlinks.++	joey@gnu:~/tmp/bench/rdirect>ls+	myfile@  otherfile@+	joey@gnu:~/tmp/bench/rdirect>git annex find+	otherfile+	# So, two files, only one present in this repo.++	joey@gnu:~/tmp/bench/rdirect>git annex direct+	commit  +	# On branch master+	# Your branch is ahead of 'origin/master' by 7 commits.+	#+	nothing to commit (working directory clean)+	ok+	direct myfile ok+	direct otherfile ok+	direct  ok++	joey@gnu:~/tmp/bench/rdirect>ls+	myfile@  otherfile+	# myfile is still a broken symlink because we don't have its content+	joey@gnu:~/tmp/bench/rdirect>git annex get myfile+	get myfile (from origin...) ok+	(Recording state in git...)+	joey@gnu:~/tmp/bench/rdirect>ls+	myfile  otherfile++	joey@gnu:~/tmp/bench/rdirect>echo "look mom, no symlinks" >> myfile+	joey@gnu:~/tmp/bench/rdirect>git annex sync+	add myfile (checksum...) ok+	commit  +	(Recording state in git...)+	[master 0e8de9b] git-annex automatic sync+	...+	ok++	joey@gnu:~/tmp/bench/rdirect>git annex indirect+	commit  ok+	indirect myfile ok+	indirect otherfile ok+	indirect  ok+	joey@gnu:~/tmp/bench/rdirect>ls+	myfile@  otherfile@++I'd like `git annex direct` to set the repository to untrusted, but+I didn't do it. Partly because having `git annex indirect` set it back to+semitrusted seems possibly wrong -- the user might not trust a repo even in+indirect mode. Or might fully trust it. The docs will encourage users to+set direct mode repos to untrusted -- in direct mode you're operating+without large swathes of git-annex's carefully constructed safety net.+(When the assistant later uses direct mode, it'll untrust the repository+automatically.)
+ doc/design/assistant/blog/day_152__bugfixes.mdwn view
@@ -0,0 +1,18 @@+Fixed a bug in the kqueue code that made the assistant not notice when a+file was renamed into a subdirectory. This turned out to be because the+symlink got broken, and it was using `stat` on the file. Switching to+`lstat` fixed that.++Improved installation of programs into standalone bundles. Now it uses+the programs detected by configure, rather than a separate hardcoded list.+Also improved handling of lsof, which is not always in PATH.++Made a OSX 10.8.2 build of the app, which is nearly my last gasp attempt+at finding a way around this crazy `git init` spinning problem with Jimmy's+daily builds are used with newer OSX versions. Try it here:+<http://downloads.kitenet.net/tmp/git-annex.dmg.bz2>++----++Mailed out the Kickstarter T-shirt rewards today, to people in the US.+Have to fill out a bunch of forms before I can mail the non-US ones.
+ doc/design/assistant/blog/day_153__hibernation.mdwn view
@@ -0,0 +1,26 @@+As winter clouds set in, I have to ration my solar power and have been less+active than usual.++It seems that the OSX 10.8.2 `git init` hanging issue has indeed been+resolved, by building the app on 10.8.2. Very good news!  Autobuilder setup is+in progress.++----++Finally getting stuck in to direct mode git-merge handling. It's+not possible to run `git merge` in a direct mode tree, because it'll+see typechanged files and refuse to do anything.++So the only way to use `git merge`, rather than writing my own merge engine,+is to use `--work-tree` to make it operate in a temporary work tree directory+rather than the real one.++When it's run this way, any new, modified, or renamed files will be added+to the temp dir, and will need to be moved to the real work tree.+To detect deleted files, need to use `git ls-files --others`, and+look at the old tree to see if the listed files were in it.++When a merge conflict occurs, the new version of the file will be in the temp+directory, and the old one in the work tree. The normal automatic merge+conflict resolution machinery should work, with just some tweaks to handle+direct mode.
+ doc/design/assistant/blog/day_154__direct_mode_merging.mdwn view
@@ -0,0 +1,21 @@+Got merging working in direct mode!++Basically works as outlined yesterday, although slightly less clumsily.+Since there was already code that ran `git diff-tree` to update the+associated files mappings after a merge, I was able to adapt that same code+to also update the working tree.++An important invariant for direct mode merges is that they should never+cause annexed objects to be dropped. So if a file is deleted by a merge,+and was a direct mode file that was the only place in the working copy+where an object was stored, the object is moved into `.git/annex/objects`.+This avoids data loss and any need to re-transfer objects after a merge.+It also makes renames and other move complex tree manipulations always end+up with direct mode files, when their content was present.++Automatic merge conflict resoltion doesn't quite work right yet in direct+mode.++Direct mode has landed in the `master` branch, but I still consider it+experimental, and of course the assistant still needs to be updated to+support it.
+ doc/design/assistant/blog/day_155__bugfixes.mdwn view
@@ -0,0 +1,15 @@+Finished getting automatic merge conflict resolution working in direct+mode. Turned out I was almost there yesterday, just a bug in a filename+comparison needed to be fixed.++Fixed a bug where the assistant dropped a file after transferring it,+despite the preferred content settings saying it should keep its copy of+the file. This turned out to be due to it reading the transfer info+incorrectly, and adding a "\n" to the end of the filename, which caused the+preferred content check to think it wasn't wanted after all. (Probably+because it thought 0 copies of the file were wanted, but I didn't look into+this in detail.)++Worked on my test suite, particularly more QuickCheck tests. I need to+use QuickCheck more, particularly when I've pairs of functions, like encode+and decode, that make for easy QuickCheck properties.
+ doc/design/assistant/blog/day_156_and_157__direct_mode_assistant.mdwn view
@@ -0,0 +1,45 @@+Over Christmas, I'm working on making the assistant support direct+mode. I like to have a fairly detailed plan before starting this kind of+job, but in this case, I don't. (Also I have a cold so planning? Meh.)+This is a process of seeing what's broken in direct mode and fixing it.+I don't know if it'll be easy or hard. Let's find out..++* First, got direct mode adding of new files working. This was not hard, all the+  pieces I needed were there. For now, it uses the same method as in+  indirect mode to make sure nothing can modify the file while it's being+  added.++* An unexpected problem is that in its startup scan, the assistant runs+  `git add --update` to detect and stage any deletions that happened+  while it was not running. But in direct mode that also stages the full file+  contents, so can't be used. Had to switch to using git plumbing to only+  stage deleted files. Happily this also led to fixing a bug; deletions+  were not always committed at startup when using the old method; with the+  new method it can tell when there are deletions and trigger a commit.++* Next, got it to commit when direct mode files are modified. The Watcher+  thread gets a inotify event when this happens, so that was easy. (Although+  in doing that I had to disable a guard in direct mode that made annexed+  files co-exist with regular in-git files, so such mixed repositories+  probably won't work in direct mode yet.)++  However, naughty kqueue is another story, there are no kqueue events for+  file modifications. So this won't work on OSX or the BSDs yet. I tried+  setting some more kqueue flags in hope that one would make such events+  appear, but no luck. Seems I will need to find some other method to detect+  file modifications, possibly an OSX-specific API.++* Another unexpected problem: When an assistant receives new files from one+  of its remotes, in direct mode it still sets up symlinks to the content.+  This was because the Merger thread didn't use the `sync` command's direct+  mode aware merge code.. so fixed that.++* Finally there was some direct mode bookeeping the assistant has+  to get right. For example, when a file is modified, the old object has+  to be looked up, and be marked as not locally present any longer. That+  lookup relies on the already running `git cat-file --batch`, so it's+  not as fast as it could be, if I kept a local cache of the mapping+  between files and objects. But it seems fast enough for now.++At this point the assistant seems to work in direct mode on Linux!+Needs more testing..
+ doc/design/assistant/blog/day_158__fsevents.mdwn view
@@ -0,0 +1,20 @@+Investigated using the OSX fsevents API to detect when files are modified,+so they can be committed when using direct mode. There's a+[haskell library](http://hackage.haskell.org/package/hfsevents-0.1.3)+and even a [sample directory watching program](http://hackage.haskell.org/package/hobbes).+Initial tests look good...++Using fsevents will avoid kqueue's problems with needing enough file+descriptors to open every subdirectory. kqueue is a rather poor match for+git-annex's needs, really. It does not seem to provide events for file+modifications at all, unless every *file* is individually opened. While I+dislike leaving the BSD's out, they need a better interface to be perfectly+supported by git-annex, and kqueue will still work for indirect mode+repositories.++----++Got the assistant to use fsevents. It seems to work well!++The only problem I know of is that it doesn't yet handle whole directory+renames. That should be easy to fix later.
+ doc/design/assistant/blog/day_159__fsevents_and_assistant.mdwn view
@@ -0,0 +1,16 @@+Short day today, but I spent it all on testing the new FSEvents code,+getting it working with the assistant in direct mode. This included fixing+its handling of renaming, and various other bugs.++The assistant in direct mode now seems to work well on OSX. So I made+the assistant *default* to making direct mode repositories on OSX.++That'll presumably flush out any bugs. :) More importantly,+it let me close several OSX-specific bugs to do with interactions between+git-annex's symlinks and OSX programs that were apparently written under the+misprehension that it's a user-mode program's job to manually follow symlinks.++Of course, defaulting to direct mode also means users can just modify files+as they like and the assistant will commit and sync the changed files.+I'm waiting to see if direct mode becomes popular enough to make it the+default on all OS's.
+ doc/design/assistant/blog/day_160__finishing_up_direct_mode.mdwn view
@@ -0,0 +1,10 @@+A few final bits and pieces of direct mode. Fixed a few more bugs in the+assistant. Made all git-annex commands that don't work at+all, or only partially work in direct mode, refuse to run at all. Also,+some optimisations.++I'll surely need to revisit direct mode later and make more commands+support it; `fsck` and `add` especially.+But the only thing I'd like to deal with before I make a release with direct+mode is the problem of files being able to be modified while they're+being transferred, which can result in data loss.
doc/design/assistant/desymlink.mdwn view
@@ -43,11 +43,12 @@  ## concrete design -* Enable with annex.nosymlink or such config option.-* Use .git/ for the git repo, but `.git/annex/objects` won't be used.+* Enable with annex.direct+* Use .git/ for the git repo, but `.git/annex/objects` won't be used+  for object storage. * `git status` and similar will show all files as type changed, and   `git commit` would be a very bad idea. Just don't support users running-  git commands that affect the repository in this mode.+  git commands that affect the repository in this mode. Probably. * However, `git status` and similar also will show deleted and new files,   which will be helpful for the assistant to use when starting up. * Cache the mtime, size etc of files, and use this to detect when they've been@@ -61,6 +62,9 @@   can map to multiple files. And that when a file is deleted or moved, the   mapping needs to be updated. * May need a reverse mapping, from files in the tree to keys? TBD+  (Currently, getting by looking up symlinks using `git cat-file`)+  (Needed to make things like `git annex drop` that want to map from the+  file back to the key work.) * The existing watch code detects when a file gets closed, and in this   mode, it could be a new file, or a modified file, or an unchanged file.   For a modified file, can compare mtime, size, etc, to see if it needs@@ -73,23 +77,38 @@   to files in this remote would not be noticed and committed, unless   a git-annex command were added to do so.   Getting it basically working as a remote would be a good 1st step.+* It could also be used without the assistant as a repository that+  the user uses directly. Would need some git-annex commands+  to merge changes into the repo, update caches, and commit changes.+  This could all be done by "git annex sync".  ## TODO  * Deal with files changing as they're being transferred from a direct mode   repository to another git repository. The remote repo currently will    accept the bad data and update the location log to say it has the key.+* kqueue does not deliver an event when an existing file is modified.+  This doesn't affect OSX, which uses FSEvents now, but it makes direct+  mode assistant not 100% on other BSD's.++## done+ * `git annex sync` updates the key to files mappings for files changed,   but needs much other work to handle direct mode:   * Generate git commit, without running `git commit`, because it will-    want to stage the full files.-  * Update location logs for any files deleted by a commit.+    want to stage the full files. **done**+  * Update location logs for any files deleted by a commit. **done**   * Generate a git merge, without running `git merge` (or possibly running     it in a scratch repo?), because it will stumble over the direct files.+    **done**   * Drop contents of files deleted by a merge (including updating the     location log), or if we cannot drop,-    move their contents to `.git/annex/objects/`.+    move their contents to `.git/annex/objects/`.  **no**  .. instead, +    avoid ever losing file contents in a direct mode merge. If the file is+    deleted, its content is moved back to .git/annex/objects, if necessary.   * When a merge adds a symlink pointing at a key that is present in the     repo, replace the symlink with the direct file (either moving out     of `.git/annex/objects/` or hard-linking if the same key is present-    elsewhere in the tree.+    elsewhere in the tree. **done**+  * handle merge conflicts on direct mode files **done**+* support direct mode in the assistant (many little fixes)
doc/design/assistant/inotify.mdwn view
@@ -12,7 +12,8 @@ * Kqueue has to open every directory it watches, so too many directories   will run it out of the max number of open files (typically 1024), and fail.   I may need to fork off multiple watcher processes to handle this.-  See [[bugs/Issue_on_OSX_with_some_system_limits]].+  See [[bug|bugs/Issue_on_OSX_with_some_system_limits]]. (Does not affect+  OSX any longer).  ## todo
doc/design/assistant/polls/prioritizing_special_remotes.mdwn view
@@ -6,7 +6,7 @@ Help me prioritize my work: What special remote would you most like to use with the git-annex assistant? -[[!poll open=yes 15 "Amazon S3 (done)" 12 "Amazon Glacier (done)" 9 "Box.com (done)" 66 "My phone (or MP3 player)" 17 "Tahoe-LAFS" 6 "OpenStack SWIFT" 23 "Google Drive"]]+[[!poll open=yes 15 "Amazon S3 (done)" 12 "Amazon Glacier (done)" 9 "Box.com (done)" 66 "My phone (or MP3 player)" 18 "Tahoe-LAFS" 6 "OpenStack SWIFT" 23 "Google Drive"]]  This poll is ordered with the options I consider easiest to build listed first. Mostly because git-annex already supports them and they
doc/design/assistant/todo.mdwn view
@@ -1,4 +1,4 @@ This is a subset of [[/todo]] for items tagged for the assistant. Link items to [[todo/done]] when done. -[[!inline pages="tagged(design/assistant)" show=0 archive=yes]]+[[!inline pages="tagged(design/assistant) and !link(bugs/done)" show=0 archive=yes]]
doc/design/assistant/xmpp.mdwn view
@@ -11,6 +11,10 @@   See <http://git-annex.branchable.com/design/assistant/blog/day_114__xmpp/#comment-aaba579f92cb452caf26ac53071a6788> * Assistant.Sync.manualPull doesn't handle XMPP remotes yet.   This is needed to handle getting back in sync after reconnection.+* Support use of a single XMPP account with several separate git-annex repos.+  This probably works for the simple push notification use of XMPP. But+  XMPP pairing and the pushes over XMPP assume that anyone you're paired with+  is intending to sync to your repository.  ## design goals
+ doc/direct_mode.mdwn view
@@ -0,0 +1,75 @@+Normally, git-annex repositories consist of symlinks that are checked into+git, and in turn point at the content of large files that is stored in+`.git/annex/objects/`. Direct mode gets rid of the symlinks.++The advantage of direct mode is that you can access files directly,+including modifying them. The disadvantage is that most regular git+commands cannot safely be used, and only a subset of git-annex commands+can be used.++Repositories created by the [[assistant]] use direct mode by default.++## enabling (and disabling) direct mode++Any repository can be converted to use direct mode at any time, and if you+decide not to use it, you can convert back to indirect mode just as easily.+Also, you can have one clone of a repository using direct mode, and another+using indirect mode; direct mode interoperates.++To start using direct mode:++	git annex direct++To stop using direct mode:++	git annex indirect++With direct mode, you're operating without large swathes of git-annex's+carefully constructed safety net. So you're strongly encouraged to tell+git-annex that your direct mode repository cannot be trusted to retain+the content of a file (because any file can be deleted or modified at+any time). To do so:++	git annex untrust .++## use a direct mode repository++Perhaps the best way to use a direct mode repository is with the git-annex+assistant.++Otherwise, the main command that's used in direct mode repositories is+`git annex sync`. This automatically adds new files, commits all+changed files to git, pushes them out, pulls down any changes, etc.++You can also run `git annex get` to transfer the content of files into your+direct mode repository. Or if the direct mode repository is a remote of+some other, regular git-annex repository, you can use commands in the other+repository like `git annex copy` and `git annex move` to transfer the+contents of files to the direct mode repository.++You can use `git commit --staged`. (But not `git commit -a` .. It'll commit+whole large files into git!)++You can use `git log` and other git query commands.++## what doesn't work in direct mode++In general git-annex commands will only work in direct mode repositories on+files whose content is not present. That's because such files are still +represented as symlinks, which git-annex commands know how to operate on.+So, `git annex get` works, but `git annex drop` and `git annex move` don't,+and things like `git annex status` show incomplete information.++It's technically possible to make all git-annex commands work in direct+mode repositories, so this might change. Check back to this page to see+current status about what works and what doesn't.++As for git commands, you can probably use some git working tree+manipulation commands, like `git checkout` and `git revert` in useful+ways... But beware, these commands can replace files that are present in+your repository with broken symlinks. If that file was the only copy you+had of something, it'll be lost. ++This is one reason it's wise to make git-annex untrust your direct mode+repositories. Still, you can lose data using these sort of git commands, so+use extreme caution.
+ doc/forum/Best_way_to_manage_files_on_removable_media__63__.mdwn view
@@ -0,0 +1,18 @@+I have a bunch of removable storage devices and was planning on storing my data across+all of them.  I've run into an annoyance, and would like to see if anybody has any+ideas.++My goal was to have the full file tree on all the devices, but only a subset of the+annexed data.  Where I have run into trouble is removing data from the system.  It+seems that the "git annex unused" command checks remote branches as well as local ones+when determining whether an object is referred to.++This means that if I remove a file that is stored locally, "git annex unused" doesn't+report the corresponding object as unused until I either connect and update all+removable storage *or* remove the remote corresponding to the removable storage.  I+posted a bug about this inconsistency named+[[bugs/git annex unused considers remote branches which makes it inconsistent]].++If I used the removable storage as a special remote, then I wouldn't have this issue,+but I also wouldn't be able to conveniently use the files on it and manage the repo+from it either.
+ doc/forum/Calculating_Annex_Cost_by_Ping_Times.mdwn view
@@ -0,0 +1,1 @@+I threw together a pair of shell scripts for calculating the cost of a remote using ping times.  I don't know how useful this is in practice, but the theory seemed sound to me.  If I'm in a hotel room with my two laptops, I'd rather annex try to get a file from the other laptop than from my NAS all the way back home.  I'd love to figure out how to also detect if I'm on my VerizonWireless connection at the time and multiply the cost of all connections over the Internet accordingly, but that's down the road.  Latest versions of the pair of scripts will be at <https://gist.github.com/4410357>. I'm interested in feedback, so please fork the git repo on gist and send me changes/updates. Also of note is that these were written for MacOSX. If you're interested in using them on a different linux, pay attention to the format of the summary line of your ping command.
+ doc/forum/How_to_retroactively_annex_a_file_already_in_a_git_repo.mdwn view
@@ -0,0 +1,5 @@+I worked out how to retroactively annex a large file that had been checked into a git repo some time ago.  I thought this might be useful for others, so I am posting it here.++> This is a great tip, so I've moved it to+> [[tips|tips/How_to_retroactively_annex_a_file_already_in_a_git_repo]].+> --[[Joey]]
+ doc/forum/New_user_misunderstandings.mdwn view
@@ -0,0 +1,24 @@+New user? Can't figure out the basics? Add it here - what you wanted, what you tried.++#### I wanted to keep track of some files I had all organized in a directory outside of my ~/annex:++    $ cd ~/annex+    $ git annex add /path/to/some/photos+    fatal: '/path/to/some/photos' is outside repository++ But git-annex doesn't work that way. I had to do this instead++    $ rsync -a /path/to/some/photos+    $ git annex add photos+    (Recording state in git...)+    $ git annex status+    ... lots of helpful info...++#### I just have the OS/X app, can I do commandline stuff?++yes++    $ /Applications/git-annex.app/Contents/MacOS/git-annex add photos/+    (Recording state in git...)++but perhaps there is a better way.
+ doc/forum/OpenOffice___47___Libre_Office.mdwn view
@@ -0,0 +1,5 @@+I'm trying to use git-annex for keeping my company invoices data. It seems a good idea because it's encrypted and whatnot, I'd never upload them to Dropbox. However, Libre Office refuses to work with files copied to annex-tracked folder. It's likely a flaw in LO/OOo, but maybe someone here knows a way to make the two work together.++When opening a spreadsheet, I'm getting a "Document in use - document locked by: Unknown User - Open read-only or open a copy" dialog. I tried opening a copy and saving under a different filename , but I can only save once - any subsequent saves to the same filename result in an error.++A graphic version of my story: http://f.gdr.name/annex-ooo-1.png http://f.gdr.name/annex-ooo-2.png
+ doc/forum/Storing_uncontrolled_files_in_an_annex.mdwn view
@@ -0,0 +1,3 @@+Is there a way to store a file in an annex repo without the assistant trying to commit it? My particular issue is that git annex watch tries to add my .thunderbird folder, and I don't want it in annex. Is that a supported use case?++Also, for my better understanding, does watch keep track of what files it saw last time and only look for new things on startup? Or does it try to commit anything that's not already in git (whether symlink or not)?
+ doc/forum/assistant_overzealously_moving_stuff_to_other_repos.mdwn view
@@ -0,0 +1,5 @@+Debian Squeeze, git version 1.7.10.4, git-annex version 3.20121211++The machine has a clone of the annex with preferred content string: `present or include=calibre/* or include=img/* or include=mail/* or include=music/* or include=sounds/*`++This, I believe, should mean the assistant should never drop anything.  However for the past two days it's been moving files to an encrypted rsync remote so that there are two copies (there is another copy on an external HDD) and then it's dropping them from the current annex.  I want to keep the files here; can anyone think of any reason why they would be moved away?
+ doc/forum/multiple_urls_for_the_same_UUID.mdwn view
@@ -0,0 +1,26 @@+I've been doing a sort of experiment but I'm not sure if it's working or, really, how to even tell.++I have two macbooks that are both configured as clients as well as a USB HDD, an rsync endpoint on a home NAS, and a glacier endpoint.++For the purposes of this example, lets call the macbooks "chrissy" and "brodie". Chrissy's was initially configured with a remote for brodie with the url as++    ssh://Brodie.88195848.members.btmm.icloud.com./Users/akraut/Desktop/annex++This allows me to leverage the "Back To My Mac" free IPv6 roaming I get from Apple.  Now, occasionally, that dns resolution fails. Since I'm frequently on the same network, I can also use the mDNS address of brodie.local. which is much more reliable.++So my brilliant/terrible idea was to put this in my git config:++    [remote "brodie"]+    	url = ssh://Brodie.88195848.members.btmm.icloud.com./Users/akraut/Desktop/annex+    	fetch = +refs/heads/*:refs/remotes/brodie/*+    	annex-uuid = BF4BCA6D-9252-4B5B-BE12-36DD755FAF4B+    	annex-cost-command = /Users/akraut/Desktop/annex/tools/annex-cost6.sh Brodie.88195848.members.btmm.icloud.com.+    [remote "brodie-local"]+    	url = ssh://brodie.local./Users/akraut/Desktop/annex+    	fetch = +refs/heads/*:refs/remotes/brodie/*+    	annex-uuid = BF4BCA6D-9252-4B5B-BE12-36DD755FAF4B+    	annex-cost-command = /Users/akraut/Desktop/annex/tools/annex-cost.sh brodie.local.++Is there any reason why I shouldn't do this? Is annex smart enough to know that it can reach the same remote through both urls? Will the cost calculations be considered and the "local" url chosen if it's cost is less than the other?++(I posted the annex-cost.sh stuff at [[forum/Calculating Annex Cost by Ping Times]].)
+ doc/forum/preferred_content_settings_for_multiple_symlinks.mdwn view
@@ -0,0 +1,7 @@+I have my music library in `music/` and some really old files I recently added in `reallyold/`.  There are some MP3s in the really old files and some are the same as my library, so of course git annex is only keeping one copy.  Now, I have an rsync remote, `ma`, which prefers content from `music/` but doesn't want anything from `reallyold/`.  So while right now it is trying to drop stuff, I suspect at some point that it will try to re-add them in virtue of being in `music/`, as I've got a loop.++I want to eliminate this by using the present keyword to disable dropping for stuff in `reallyold/` and `music/`.  Here is my attempt, which doesn't work--I am hoping someone can spot what's wrong.++    (present and include=music/*) or (present and include=reallyold/*) or (exclude=reallyold/* and exclude=video/* and exclude= ...)++Note that music is included by virtue of not being excluded so it should satisfy the third disjunct.  Thanks.
doc/git-annex.mdwn view
@@ -190,6 +190,9 @@   Like watch, but also automatically syncs changes to other remotes.   Typically started at boot, or when you log in. +  With the --autostart option, the assistant is started in any repositories+  it has created.+ * webapp    Runs a web app, that allows easy setup of a git-annex repository,@@ -263,6 +266,21 @@   settings, and when it exits, stores any changes made back to the git-annex   branch. +* direct++  Switches a repository to use direct mode, where rather than symlinks to+  files, the files are directly present in the repository. Note that many git+  and git-annex commands will not work in direct mode; you're mostly+  limited to using "git annex sync" and "git annex get".++  As part of the switch to direct mode, any changed files will be committed.++* indirect++  Switches a repository back from direct mode to the default, indirect mode.+  +  As part of the switch from direct mode, any changed files will be committed.+ # REPOSITORY MAINTENANCE COMMANDS  * fsck [path ...]@@ -773,8 +791,14 @@   Makes the watch and assistant commands delay for the specified number of   seconds before adding a newly created file to the annex. Normally this   is not needed, because they already wait for all writers of the file-  to close it. On Mac OSX, this defaults to 1 second, to work around-  a bad interaction with software there.+  to close it. On Mac OSX, when not using direct mode this defaults to+  1 second, to work around a bad interaction with software there.++* `annex.direct`++  Set to true to enable an (experimental) mode where files in the repository+  are accessed directly, rather than through symlinks. Note that many git+  and git-annex commands will not work with such a repository.  * `remote.<name>.annex-cost`
doc/index.mdwn view
@@ -49,6 +49,7 @@ * [[sync]] * [[encryption]] * [[bare_repositories]]+* [[direct_mode]] * [[internals]] * [[scalability]] * [[design]]
doc/install.mdwn view
@@ -2,7 +2,7 @@  [[!table format=dsv header=yes data=""" detailed instructions | quick install-[[OSX]]               | [download git-annex.app](http://downloads.kitenet.net/git-annex/OSX/git-annex.dmg.bz2) **beta; [[known_problems|/bugs/OSX_app_issues]]**+[[OSX]]               | [download git-annex.app](http://downloads.kitenet.net/git-annex/OSX/current/) [[Linux|linux_standalone]] | [download prebuilt linux tarball](http://downloads.kitenet.net/git-annex/linux/) [[Debian]]            | `apt-get install git-annex` [[Ubuntu]]            | `apt-get install git-annex`
doc/install/OSX.mdwn view
@@ -1,20 +1,31 @@ ## git-annex.app -For easy installation, [Jimmy Tang](http://www.sgenomics.org/~jtang/)-builds a standalone git-annex.app of the git-annex assistant.+For easy installation, use the+[beta release of git-annex.app](http://downloads.kitenet.net/git-annex/OSX/current/). -* [beta release of git-annex.app](http://downloads.kitenet.net/git-annex/OSX/git-annex.dmg.bz2)-* [daily build of git-annex.app](http://www.sgenomics.org/~jtang/gitbuilder-git-annex-x00-x86_64-apple-darwin10.8.0-binary/ref/master/git-annex.dmg.bz2) ([build logs](http://www.sgenomics.org/~jtang/gitbuilder-git-annex-x00-x86_64-apple-darwin10.8.0-binary/))+Be sure to select the build matching your version of OSX.++This is still a work in progress. See [[/bugs/OSX_app_issues]] for problem+reports.++## autobuilds++[Jimmy Tang](http://www.sgenomics.org/~jtang/) autobuilds+the app for OSX Lion.++* [autobuild of git-annex.app](http://www.sgenomics.org/~jtang/gitbuilder-git-annex-x00-x86_64-apple-darwin10.8.0-binary/ref/master/git-annex.dmg.bz2) ([build logs](http://www.sgenomics.org/~jtang/gitbuilder-git-annex-x00-x86_64-apple-darwin10.8.0-binary/))   * [past builds](http://www.sgenomics.org/~jtang/gitbuilder-git-annex-x00-x86_64-apple-darwin10.8.0-binary/sha1/) -- directories are named from the commitid's -This is known to not work on all OSX systems. [[/bugs/OSX_app_issues]] is collecting reports of problems with it in one place.+[[Joey]] autobuilds the app for Mountain Lion. +* [autobuild of git-annex.app](http://downloads.kitenet.net/git-annex/autobuild/x86_64-apple-mountain-lion/git-annex.dmg.bz2) ([build logs](http://downloads.kitenet.net/git-annex/autobuild/x86_64-apple-mountain-lion/))+ ## using Brew  <pre>-sudo brew update-sudo brew install haskell-platform git ossp-uuid md5sha1sum coreutils pcre libgsasl gnutls libidn libgsasl pkg-config libxml2-sudo brew link libxml2+brew update+brew install haskell-platform git ossp-uuid md5sha1sum coreutils pcre libgsasl gnutls libidn libgsasl pkg-config libxml2+brew link libxml2 cabal update PATH=$HOME/bin:$PATH cabal install c2hs git-annex --bindir=$HOME/bin
− doc/install/OSX/comment_10_4d15bfc4fc26e7249953bebfbb09e0aa._comment 
@@ -1,11 +0,0 @@-[[!comment format=mdwn- username="https://www.google.com/accounts/o8/id?id=AItOawkp-1EQboBDqZ05MxOHNkwNQDM4luWYioA"- nickname="Charles"- subject="comment 10"- date="2012-11-15T13:26:57Z"- content="""-Installing it with brew, I had to do the following steps before the final `cabal` command:--* `cabal install c2hs`-* add `$HOME/.cabal/bin` to my `$PATH` (so that c2hs program can be found)-"""]]
− doc/install/OSX/comment_9_c6b1b31d16f2144ad08abd8c767b6ab9._comment 
@@ -1,23 +0,0 @@-[[!comment format=mdwn- username="https://www.google.com/accounts/o8/id?id=AItOawnBEsNDl_6O4rHb2en3I0-fg-6fUxglaRQ"- nickname="chee"- subject="Recent install for OS X"- date="2012-11-13T04:40:05Z"- content="""-if you are having trouble installing with `cabal install git-annex` at the moment, trouble of the XML kind, you'll need to do a couple things:--`brew update`-`brew install libxml2`-`cabal update`-`cabal install libxml --extra-include-dirs=/usr/local/Cellar/libxml2/2.8.0/include/libxml2 --extra-lib-dirs=/usr/local/Cellar/libxml2/2.8.0/lib`--well, then i hit a brick wall.--well.--I got it to work by manually symlinking from `../Cellar/libxml2/2.8.0/lib/`* into `/usr/local` and from `../../Cellar/libxml2/2.8.0/lib/` to `/usr/local/pkgconfig`, but i can't recommend it or claim to be too proud about it all.--OS X already has an old libxml knocking around so this might ruin everything for me.--let's find out !-"""]]
doc/internals.mdwn view
@@ -17,6 +17,15 @@ from the subdirectories as well as from the files. That prevents accidentially deleting or changing the file contents. +In [[direct_mode]], file contents are not stored in here, and instead+are stored directly in the file. However, the same symlinks are still+committed to git, internally.++Also in [[direct_mode]], some additional data is stored in these directories.+`.cache` files contain cached file stats used in detecting when a file has+changed, and `.map` files contain a list of file(s) in the work directory+that contain the key.+ ## The git-annex branch  This branch is managed by git-annex, with the contents listed below.
− doc/news/version_3.20121112.mdwn 
@@ -1,48 +0,0 @@-git-annex 3.20121112 released with [[!toggle text="these changes"]]-[[!toggleable text="""-   * assistant: Can use XMPP to notify other nodes about pushes made to other-     repositories, as well as pushing to them directly over XMPP.-   * wepapp: Added an XMPP configuration interface.-   * webapp: Supports pairing over XMPP, with both friends, and other repos-     using the same account.-   * assistant: Drops non-preferred content when possible.-   * assistant: Notices, and applies config changes as they are made to-     the git-annex branch, including config changes pushed in from remotes.-   * git-annex-shell: GIT\_ANNEX\_SHELL\_DIRECTORY can be set to limit it-     to operating on a specified directory.-   * webapp: When setting up authorized\_keys, use GIT\_ANNEX\_SHELL\_DIRECTORY.-   * Preferred content path matching bugfix.-   * Preferred content expressions cannot use "in=".-   * Preferred content expressions can use "present".-   * Fix handling of GIT\_DIR when it refers to a git submodule.-   * Depend on and use the Haskell SafeSemaphore library, which provides-     exception-safe versions of SampleVar and QSemN.-     Thanks, Ben Gamari for an excellent patch set.-   * file:/// URLs can now be used with the web special remote.-   * webapp: Allow dashes in ssh key comments when pairing.-   * uninit: Check and abort if there are symlinks to annexed content that-     are not checked into git.-   * webapp: Switched to using the same multicast IP address that avahi uses.-   * bup: Don't pass - to bup-split to make it read stdin; bup 0.25-     does not accept that.-   * bugfix: Don't fail transferring content from read-only repos.-     Closes: #[691341](http://bugs.debian.org/691341)-   * configure: Check that checksum programs produce correct checksums.-   * Re-enable dbus, using a new version of the library that fixes the memory-     leak.-   * NetWatcher: When dbus connection is lost, try to reconnect.-   * Use USER and HOME environment when set, and only fall back to getpwent,-     which doesn't work with LDAP or NIS.-   * rsync special remote: Include annex-rsync-options when running rsync-     to test a key's presence.-   * The standalone tarball's runshell now takes care of installing a-     ~/.ssh/git-annex-shell wrapper the first time it's run.-   * webapp: Make an initial, empty commit so there is a master branch-   * assistant: Fix syncing local drives.-   * webapp: Fix creation of rsync.net repositories.-   * webapp: Fix renaming of special remotes.-   * webapp: Generate better git remote names.-   * webapp: Ensure that rsync special remotes are enabled using the same-     name they were originally created using.-   * Bugfix: Fix hang in webapp when setting up a ssh remote with an absolute-     path."""]]
+ doc/news/version_3.20130102.mdwn view
@@ -0,0 +1,25 @@+git-annex 3.20130102 released with [[!toggle text="these changes"]]+[[!toggleable text="""+   * direct, indirect: New commands, that switch a repository to and from+     direct mode. In direct mode, files are accessed directly, rather than+     via symlinks. Note that direct mode is currently experimental. Many+     git-annex commands do not work in direct mode. Some git commands can+     cause data loss when used in direct mode repositories.+   * assistant: Now uses direct mode by default when setting up a new+     local repository.+   * OSX assistant: Uses the FSEvents API to detect file changes.+     This avoids issues with running out of file descriptors on large trees,+     as well as allowing detection of modification of files in direct mode.+     Other BSD systems still use kqueue.+   * kqueue: Fix bug that made broken symlinks not be noticed.+   * vicfg: Quote filename. Closes: #[696193](http://bugs.debian.org/696193)+   * Bugfix: Fixed bug parsing transfer info files, where the newline after+     the filename was included in it. This was generally benign, but in+     the assistant, it caused unexpected dropping of preferred content.+   * Bugfix: Remove leading \ from checksums output by sha*sum commands,+     when the filename contains \ or a newline. Closes: #[696384](http://bugs.debian.org/696384)+   * fsck: Still accept checksums with a leading \ as valid, now that+     above bug is fixed.+   * SHA*E backends: Exclude non-alphanumeric characters from extensions.+   * migrate: Remove leading \ in SHA* checksums, and non-alphanumerics+     from extensions of SHA*E keys."""]]
+ doc/tips/How_to_retroactively_annex_a_file_already_in_a_git_repo.mdwn view
@@ -0,0 +1,19 @@+I worked out how to retroactively annex a large file that had been checked into a git repo some time ago.  I thought this might be useful for others, so I am posting it here.++Suppose you have a git repo where somebody had checked in a large file you would like to have annexed, but there are a bunch of commits after it and you don't want to loose history, but you also don't want everybody to have to retrieve the large file when they clone the repo.  This will re-write history as if the file had been annexed when it was originally added.++This command works for me, it relies on the current behavior of git which is to use a directory named .git-rewrite/t/ at the top of the git tree for the extracted tree.  This will not be fast and it will rewrite history, so be sure that everybody who has a copy of your repo is OK with accepting the new history.  If the behavior of git changes, you can specify the directory to use with the -d option.  Currently, the t/ directory is created inside the directory you specify, so "-d ./.git-rewrite/" should be roughly equivalent to the default.++Enough with the explanation, on to the command:+<pre>+git filter-branch --tree-filter 'for FILE in file1 file2 file3;do if [ -f "$FILE" ] && [ ! -L "$FILE" ];then git rm --cached "$FILE";git annex add "$FILE";ln -sf `readlink "$FILE"|sed -e "s:^../../::"` "$FILE";fi;done' --tag-name-filter cat -- --all+</pre>++replace file1 file2 file3... with whatever paths you want retroactively annexed.  If you wanted bigfile1.bin in the top dir and subdir1/bigfile2.bin to be retroactively annexed try:+<pre>+git filter-branch --tree-filter 'for FILE in bigfile1.bin subdir1/bigfile2.bin;do if [ -f "$FILE" ] && [ ! -L "$FILE" ];then git rm --cached "$FILE";git annex add "$FILE";ln -sf `readlink "$FILE"|sed -e "s:^../../::"` "$FILE";fi;done' --tag-name-filter cat -- --all+</pre>++**If your repo has tags** then you should take a look at the git-filter-branch man page about the --tag-name-filter option and decide what you want to do.  By default this will re-write the tags "nearly properly".++You'll probably also want to look at the git-filter-branch man page's section titled "CHECKLIST FOR SHRINKING A REPOSITORY" if you want to free up the space in the existing repo that you just changed history on.
git-annex.1 view
@@ -173,6 +173,9 @@ Like watch, but also automatically syncs changes to other remotes. Typically started at boot, or when you log in. .IP+With the \-\-autostart option, the assistant is started in any repositories+it has created.+.IP .IP "webapp" Runs a web app, that allows easy setup of a git\-annex repository, and control of the git\-annex assistant.@@ -235,6 +238,19 @@ settings, and when it exits, stores any changes made back to the git\-annex branch. .IP+.IP "direct"+Switches a repository to use direct mode, where rather than symlinks to+files, the files are directly present in the repository. Note that many git+and git\-annex commands will not work in direct mode; you're mostly+limited to using "git annex sync" and "git annex get".+.IP+As part of the switch to direct mode, any changed files will be committed.+.IP+.IP "indirect"+Switches a repository back from direct mode to the default, indirect mode.+.IP+As part of the switch from direct mode, any changed files will be committed.+.IP .SH REPOSITORY MAINTENANCE COMMANDS .IP "fsck [path ...]" .IP@@ -679,8 +695,13 @@ Makes the watch and assistant commands delay for the specified number of seconds before adding a newly created file to the annex. Normally this is not needed, because they already wait for all writers of the file-to close it. On Mac OSX, this defaults to 1 second, to work around-a bad interaction with software there.+to close it. On Mac OSX, when not using direct mode this defaults to+1 second, to work around a bad interaction with software there.+.IP+.IP "annex.direct"+Set to true to enable an (experimental) mode where files in the repository+are accessed directly, rather than through symlinks. Note that many git+and git\-annex commands will not work with such a repository. .IP .IP "remote.<name>.annex\-cost" When determining which repository to
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 3.20121211+Version: 3.20130102 Cabal-Version: >= 1.8 License: GPL Maintainer: Joey Hess <joey@kitenet.net>@@ -84,9 +84,13 @@     Build-Depends: hinotify     CPP-Options: -DWITH_INOTIFY   else-    if (! os(windows) && ! os(solaris))-      CPP-Options: -DWITH_KQUEUE-      C-Sources: Utility/libkqueue.c+    if os(darwin)+      Build-Depends: hfsevents+      CPP-Options: -DWITH_HFSEVENTS+    else+      if (! os(windows) && ! os(solaris) && ! os(linux))+        CPP-Options: -DWITH_KQUEUE+        C-Sources: Utility/libkqueue.c    if os(linux) && flag(Dbus)     Build-Depends: dbus (>= 0.10.3)@@ -119,7 +123,7 @@    old-locale, time, pcre-light, extensible-exceptions, dataenc, SHA,    process, json, HTTP, base (>= 4.5 && < 4.7), monad-control,    transformers-base, lifted-base, IfElse, text, QuickCheck >= 2.1,-   bloomfilter, edit-distance, process+   bloomfilter, edit-distance, process, SafeSemaphore   Other-Modules: Utility.Touch   Include-Dirs: Utility   C-Sources: Utility/libdiskfree.c
standalone/linux/runshell view
@@ -58,8 +58,13 @@ GIT_EXEC_PATH=$base/git-core export GIT_EXEC_PATH +ORIG_GIT_TEMPLATE_DIR="$GIT_TEMPLATE_DIR"+export ORIG_GIT_TEMPLATE_DIR+GIT_TEMPLATE_DIR="$base/templates"+export GIT_TEMPLATE_DIR+ # Indicate which variables were exported above.-GIT_ANNEX_STANDLONE_ENV="PATH LD_LIBRARY_PATH GIT_EXEC_PATH"+GIT_ANNEX_STANDLONE_ENV="PATH LD_LIBRARY_PATH GIT_EXEC_PATH GIT_TEMPLATE_DIR" export GIT_ANNEX_STANDLONE_ENV  if [ "$1" ]; then
standalone/osx/git-annex.app/Contents/MacOS/runshell view
@@ -51,8 +51,13 @@ GIT_EXEC_PATH=$base export GIT_EXEC_PATH +ORIG_GIT_TEMPLATE_DIR="$GIT_TEMPLATE_DIR"+export ORIG_GIT_TEMPLATE_DIR+GIT_TEMPLATE_DIR="$base/templates"+export GIT_TEMPLATE_DIR+ # Indicate which variables were exported above.-GIT_ANNEX_STANDLONE_ENV="PATH GIT_EXEC_PATH"+GIT_ANNEX_STANDLONE_ENV="PATH GIT_EXEC_PATH GIT_TEMPLATE_DIR" export GIT_ANNEX_STANDLONE_ENV  if [ "$1" ]; then@@ -60,5 +65,5 @@ 	shift 1 	exec "$cmd" "$@" else-	sh+	$SHELL fi
templates/configurators/repositories/misc.hamlet view
@@ -13,7 +13,7 @@   <a href="@{StartLocalPairR}">     <i .icon-plus-sign></i> Local computer <p>-  Pair with a computer to automatically keep files in sync+  Pair with a computer to automatically keep files in sync #   over your local network.  <p>
test.hs view
@@ -1,6 +1,6 @@ {- git-annex test suite  -- - Copyright 2010,2011 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -10,6 +10,7 @@ import Test.HUnit import Test.HUnit.Tools import Test.QuickCheck+import Test.QuickCheck.Instances ()  import System.Posix.Directory (changeWorkingDirectory) import System.Posix.Files@@ -20,6 +21,7 @@ import Text.JSON  import Common+import Utility.QuickCheck ()  import qualified Utility.SafeCommand import qualified Annex@@ -30,12 +32,15 @@ import qualified Locations import qualified Types.KeySource import qualified Types.Backend+import qualified Types.TrustLevel import qualified Types import qualified GitAnnex import qualified Logs.UUIDBased import qualified Logs.Trust import qualified Logs.Remote import qualified Logs.Unused+import qualified Logs.Transfer+import qualified Logs.Presence import qualified Remote import qualified Types.Key import qualified Types.Messages@@ -49,19 +54,39 @@ import qualified Utility.Verifiable import qualified Utility.Process import qualified Utility.Misc+import qualified Annex.Content.Direct --- for quickcheck+-- instances for quickcheck instance Arbitrary Types.Key.Key where-	arbitrary = do-		n <- arbitrary-		b <- elements ['A'..'Z']-		return Types.Key.Key {-			Types.Key.keyName = n,-			Types.Key.keyBackendName = [b],-			Types.Key.keySize = Nothing,-			Types.Key.keyMtime = Nothing-		}+	arbitrary = Types.Key.Key+		<$> arbitrary+		<*> (listOf1 $ elements ['A'..'Z']) -- BACKEND+		<*> ((abs <$>) <$> arbitrary) -- size cannot be negative+		<*> arbitrary +instance Arbitrary Logs.Transfer.TransferInfo where+	arbitrary = Logs.Transfer.TransferInfo+		<$> arbitrary+		<*> arbitrary+		<*> pure Nothing -- cannot generate a ThreadID+		<*> pure Nothing -- remote not needed+		<*> arbitrary+		-- associated file cannot be empty (but can be Nothing)+		<*> arbitrary `suchThat` (/= Just "")+		<*> arbitrary++instance Arbitrary Annex.Content.Direct.Cache where+	arbitrary = Annex.Content.Direct.Cache+		<$> arbitrary+		<*> arbitrary+		<*> arbitrary++instance Arbitrary Logs.Presence.LogLine where+	arbitrary = Logs.Presence.LogLine+		<$> arbitrary+		<*> elements [minBound..maxBound]+		<*> arbitrary `suchThat` ('\n' `notElem`)+ main :: IO () main = do 	prepare@@ -83,8 +108,8 @@ 	, qctest "prop_idempotent_shellEscape" Utility.SafeCommand.prop_idempotent_shellEscape 	, qctest "prop_idempotent_shellEscape_multiword" Utility.SafeCommand.prop_idempotent_shellEscape_multiword 	, qctest "prop_idempotent_configEscape" Logs.Remote.prop_idempotent_configEscape+	, qctest "prop_parse_show_Config" Logs.Remote.prop_parse_show_Config 	, qctest "prop_parentDir_basics" Utility.Path.prop_parentDir_basics- 	, qctest "prop_relPathDirToFile_basics" Utility.Path.prop_relPathDirToFile_basics 	, qctest "prop_relPathDirToFile_regressionTest" Utility.Path.prop_relPathDirToFile_regressionTest 	, qctest "prop_cost_sane" Config.prop_cost_sane@@ -93,6 +118,11 @@ 	, qctest "prop_addLog_sane" Logs.UUIDBased.prop_addLog_sane 	, qctest "prop_verifiable_sane" Utility.Verifiable.prop_verifiable_sane 	, qctest "prop_segment_regressionTest" Utility.Misc.prop_segment_regressionTest+	, qctest "prop_read_write_transferinfo" Logs.Transfer.prop_read_write_transferinfo+	, qctest "prop_read_show_direct" Annex.Content.Direct.prop_read_show_direct+	, qctest "prop_parse_show_log" Logs.Presence.prop_parse_show_log+	, qctest "prop_read_show_TrustLevel" Types.TrustLevel.prop_read_show_TrustLevel+	, qctest "prop_parse_show_TrustLog" Logs.Trust.prop_parse_show_TrustLog 	]  blackbox :: Test