packages feed

git-annex 3.20121001 → 3.20121009

raw patch · 99 files changed

+1880/−450 lines, 99 filesbinary-added

Files

Annex.hs view
@@ -10,6 +10,7 @@ module Annex ( 	Annex, 	AnnexState(..),+	PreferredContentMap, 	new, 	newState, 	run,@@ -45,10 +46,13 @@ import Types.Crypto import Types.BranchState import Types.TrustLevel+import Types.Group import Types.Messages+import Types.UUID import Utility.State import qualified Utility.Matcher import qualified Data.Map as M+import qualified Data.Set as S  -- git-annex's monad newtype Annex a = Annex { runAnnex :: StateT AnnexState IO a }@@ -73,6 +77,8 @@  type Matcher a = Either [Utility.Matcher.Token a] (Utility.Matcher.Matcher a) +type PreferredContentMap = M.Map UUID (Utility.Matcher.Matcher (S.Set UUID -> FilePath -> Annex Bool))+ -- internal state storage data AnnexState = AnnexState 	{ repo :: Git.Repo@@ -89,9 +95,11 @@ 	, forcebackend :: Maybe String 	, forcenumcopies :: Maybe Int 	, limit :: Matcher (FilePath -> Annex Bool)+	, preferredcontentmap :: Maybe PreferredContentMap 	, shared :: Maybe SharedRepository 	, forcetrust :: TrustMap 	, trustmap :: Maybe TrustMap+	, groupmap :: Maybe GroupMap 	, ciphers :: M.Map StorableCipher Cipher 	, lockpool :: M.Map FilePath Fd 	, flags :: M.Map String Bool@@ -115,9 +123,11 @@ 	, forcebackend = Nothing 	, forcenumcopies = Nothing 	, limit = Left []+	, preferredcontentmap = Nothing 	, shared = Nothing 	, forcetrust = M.empty 	, trustmap = Nothing+	, groupmap = Nothing 	, ciphers = M.empty 	, lockpool = M.empty 	, flags = M.empty
Annex/Branch.hs view
@@ -261,8 +261,10 @@ files = do 	update 	withIndex $ do-		bfiles <- inRepo $ Git.Command.pipeNullSplit-			[Params "ls-tree --name-only -r -z", Param $ show fullname]+		bfiles <- inRepo $ Git.Command.pipeNullSplitZombie+			[ Params "ls-tree --name-only -r -z"+			, Param $ show fullname+			] 		jfiles <- getJournalledFiles 		return $ jfiles ++ bfiles
Annex/Version.hs view
@@ -33,6 +33,9 @@ setVersion :: Annex () setVersion = setConfig versionField defaultVersion +removeVersion :: Annex ()+removeVersion = unsetConfig versionField+ checkVersion :: Version -> Annex () checkVersion v 	| v `elem` supportedVersions = noop
+ Annex/Wanted.hs view
@@ -0,0 +1,39 @@+{- git-annex control over whether content is wanted+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Annex.Wanted where++import Common.Annex+import Logs.PreferredContent+import Git.FilePath+import Annex.UUID+import Types.Remote++import qualified Data.Set as S++{- Check if a file is preferred content for the local repository. -}+wantGet :: AssociatedFile -> Annex Bool+wantGet Nothing = return True+wantGet (Just file) = do+	fp <- inRepo $ toTopFilePath file+	isPreferredContent Nothing S.empty fp++{- Check if a file is preferred content for a remote. -}+wantSend :: AssociatedFile -> UUID -> Annex Bool+wantSend Nothing _ = return True+wantSend (Just file) to = do+	fp <- inRepo $ toTopFilePath file+	isPreferredContent (Just to) S.empty fp++{- Check if a file can be dropped, maybe from a remote.+ - Don't drop files that are preferred content. -}+wantDrop :: Maybe UUID -> AssociatedFile -> Annex Bool+wantDrop _ Nothing = return True+wantDrop from (Just file) = do+	fp <- inRepo $ toTopFilePath file+	u <- maybe getUUID (return . id) from+	not <$> isPreferredContent (Just u) (S.singleton u) fp
Assistant/Changes.hs view
@@ -27,6 +27,10 @@ 		} 	| PendingAddChange 		{ changeTime ::UTCTime+		, changeFile :: FilePath+		}+	| InProcessAddChange+		{ changeTime ::UTCTime 		, keySource :: KeySource 		} 	deriving (Show)@@ -44,17 +48,21 @@ noChange :: Annex (Maybe Change) noChange = return Nothing -{- Indicates an add is in progress. -}-pendingAddChange :: KeySource -> Annex (Maybe Change)-pendingAddChange ks =-	liftIO $ Just <$> (PendingAddChange <$> getCurrentTime <*> pure ks)+{- Indicates an add needs to be done, but has not started yet. -}+pendingAddChange :: FilePath -> Annex (Maybe Change)+pendingAddChange f =+	liftIO $ Just <$> (PendingAddChange <$> getCurrentTime <*> pure f)  isPendingAddChange :: Change -> Bool isPendingAddChange (PendingAddChange {}) = True isPendingAddChange _ = False +isInProcessAddChange :: Change -> Bool+isInProcessAddChange (InProcessAddChange {}) = True+isInProcessAddChange _ = False+ finishedChange :: Change -> Change-finishedChange c@(PendingAddChange { keySource = ks }) = Change+finishedChange c@(InProcessAddChange { keySource = ks }) = Change 	{ changeTime = changeTime c 	, changeFile = keyFilename ks 	, changeType = AddChange
Assistant/MakeRemote.hs view
@@ -28,11 +28,12 @@ import Data.Char  {- Sets up and begins syncing with a new ssh or rsync remote. -}-makeSshRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Bool -> SshData -> IO ()+makeSshRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Bool -> SshData -> IO Remote makeSshRemote st dstatus scanremotes forcersync sshdata = do 	r <- runThreadState st $ 		addRemote $ maker (sshRepoName sshdata) sshurl 	syncNewRemote st dstatus scanremotes r+	return r 	where 		rsync = forcersync || rsyncOnly sshdata 		maker
Assistant/Pairing/MakeRemote.hs view
@@ -46,7 +46,7 @@ 			, "git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata) 			] 			""-	makeSshRemote st dstatus scanremotes False sshdata+	void $ makeSshRemote st dstatus scanremotes False sshdata  {- Mostly a straightforward conversion.  Except:  -  * Determine the best hostname to use to contact the host.
Assistant/Threads/Committer.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE CPP, BangPatterns #-}+ module Assistant.Threads.Committer where  import Assistant.Common@@ -16,10 +18,10 @@ import Assistant.TransferQueue import Assistant.DaemonStatus import Logs.Transfer-import qualified Annex import qualified Annex.Queue import qualified Git.Command import qualified Git.HashObject+import qualified Git.LsFiles import qualified Git.Version import Git.Types import qualified Command.Add@@ -27,6 +29,8 @@ import qualified Utility.Lsof as Lsof import qualified Utility.DirWatcher as DirWatcher import Types.KeySource+import Config+import Annex.Exception  import Data.Time.Clock import Data.Tuple.Utils@@ -38,28 +42,32 @@  {- This thread makes git commits at appropriate times. -} commitThread :: ThreadState -> ChangeChan -> CommitChan -> TransferQueue -> DaemonStatusHandle -> NamedThread-commitThread st changechan commitchan transferqueue dstatus = thread $ runEvery (Seconds 1) $ do-	-- We already waited one second as a simple rate limiter.-	-- Next, wait until at least one change is available for-	-- processing.-	changes <- getChanges changechan-	-- Now see if now's a good time to commit.-	time <- getCurrentTime-	if shouldCommit time changes-		then do-			readychanges <- handleAdds st changechan transferqueue dstatus changes-			if shouldCommit time readychanges-				then do-					debug thisThread-						[ "committing"-						, show (length readychanges)-						, "changes"-						]-					void $ alertWhile dstatus commitAlert $-						runThreadState st commitStaged-					recordCommit commitchan (Commit time)-				else refill readychanges-		else refill changes+commitThread st changechan commitchan transferqueue dstatus = thread $ do+	delayadd <- runThreadState st $+		maybe delayaddDefault (Just . Seconds) . readish+			<$> getConfig (annexConfig "delayadd") "" +	runEvery (Seconds 1) $ do+		-- We already waited one second as a simple rate limiter.+		-- Next, wait until at least one change is available for+		-- processing.+		changes <- getChanges changechan+		-- Now see if now's a good time to commit.+		time <- getCurrentTime+		if shouldCommit time changes+			then do+				readychanges <- handleAdds delayadd st changechan transferqueue dstatus changes+				if shouldCommit time readychanges+					then do+						debug thisThread+							[ "committing"+							, show (length readychanges)+							, "changes"+							]+						void $ alertWhile dstatus commitAlert $+							runThreadState st commitStaged+						recordCommit commitchan (Commit time)+					else refill readychanges+			else refill changes 	where 		thread = NamedThread thisThread 		refill [] = noop@@ -74,18 +82,23 @@  commitStaged :: Annex Bool commitStaged = do-	Annex.Queue.flush-	void $ inRepo $ Git.Command.runBool "commit" $ nomessage-		[ Param "--quiet"-		{- Avoid running the usual git-annex pre-commit hook;-		 - watch does the same symlink fixing, and we don't want-		 - to deal with unlocked files in these commits. -}-		, Param "--no-verify"-		]-	{- Empty commits may be made if tree changes cancel-	 - each other out, etc. Git returns nonzero on those, so-	 - don't propigate out commit failures. -}-	return True+	{- This could fail if there's another commit being made by+	 - something else. -}+	v <- tryAnnex Annex.Queue.flush+	case v of+		Left _ -> return False+		Right _ -> do+			void $ inRepo $ Git.Command.runBool "commit" $ nomessage+				[ Param "--quiet"+				{- Avoid running the usual git-annex pre-commit hook;+				 - watch does the same symlink fixing, and we don't want+				 - to deal with unlocked files in these commits. -}+				, Param "--no-verify"+				]+			{- Empty commits may be made if tree changes cancel+			 - each other out, etc. Git returns nonzero on those,+			 - so don't propigate out commit failures. -}+			return True 	where 		nomessage ps 			| Git.Version.older "1.7.2" = Param "-m"@@ -109,13 +122,24 @@ 		len = length changes 		thisSecond c = now `diffUTCTime` changeTime c <= 1 -{- If there are PendingAddChanges, the files have not yet actually been- - added to the annex (probably), and that has to be done now, before- - committing.+{- 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+#ifdef darwin_HOST_OS+delayaddDefault = Just $ Seconds 1+#else+delayaddDefault = Nothing+#endif++{- If there are PendingAddChanges, or InProcessAddChanges, the files+ - have not yet actually been added to the annex, and that has to be done+ - now, before committing.  -  - Deferring the adds to this point causes batches to be bundled together,  - which allows faster checking with lsof that the files are not still open- - for write by some other process.+ - for write by some other process, and faster checking with git-ls-files+ - that the files are not already checked into git.  -  - When a file is added, Inotify will notice the new symlink. So this waits  - for additional Changes to arrive, so that the symlink has hopefully been@@ -128,10 +152,11 @@  - Any pending adds that are not ready yet are put back into the ChangeChan,  - where they will be retried later.  -}-handleAdds :: ThreadState -> ChangeChan -> TransferQueue -> DaemonStatusHandle -> [Change] -> IO [Change]-handleAdds st changechan transferqueue dstatus cs = returnWhen (null pendingadds) $ do-	(postponed, toadd) <- partitionEithers <$>-		safeToAdd st pendingadds+handleAdds :: Maybe Seconds -> ThreadState -> ChangeChan -> TransferQueue -> DaemonStatusHandle -> [Change] -> IO [Change]+handleAdds delayadd st changechan transferqueue dstatus cs = returnWhen (null incomplete) $ do+	let (pending, inprocess) = partition isPendingAddChange incomplete+	pending' <- findnew pending+	(postponed, toadd) <- partitionEithers <$> safeToAdd delayadd st pending' inprocess  	unless (null postponed) $ 		refillChanges changechan postponed@@ -141,24 +166,33 @@ 		if DirWatcher.eventsCoalesce || null added 			then return $ added ++ otherchanges 			else do-				r <- handleAdds st changechan transferqueue dstatus+				r <- handleAdds delayadd st changechan transferqueue dstatus 					=<< getChanges changechan 				return $ r ++ added ++ otherchanges 	where-		(pendingadds, otherchanges) = partition isPendingAddChange cs+		(incomplete, otherchanges) = partition (\c -> isPendingAddChange c || isInProcessAddChange c) cs+		+		findnew [] = return []+		findnew pending = do+			(!newfiles, cleanup) <- runThreadState st $+				inRepo (Git.LsFiles.notInRepo False $ map changeFile pending)+			void cleanup+			-- note: timestamp info is lost here+			let ts = changeTime (pending !! 0)+			return $ map (PendingAddChange ts) newfiles  		returnWhen c a 			| c = return otherchanges 			| otherwise = a  		add :: Change -> IO (Maybe Change)-		add change@(PendingAddChange { keySource = ks }) =+		add change@(InProcessAddChange { keySource = ks }) = 			alertWhile' dstatus (addFileAlert $ keyFilename ks) $ 				liftM ret $ catchMaybeIO $ 					sanitycheck ks $ runThreadState st $ do 						showStart "add" $ keyFilename ks 						key <- Command.Add.ingest ks-						handle (finishedChange change) (keyFilename ks) key+						done (finishedChange change) (keyFilename ks) key 			where 				{- Add errors tend to be transient and will 				 - be automatically dealt with, so don't@@ -167,10 +201,10 @@ 				ret _ = (True, Nothing) 		add _ = return Nothing -		handle _ _ Nothing = do+		done _ _ Nothing = do 			showEndFail 			return Nothing-		handle change file (Just key) = do+		done change file (Just key) = do 			link <- Command.Add.link file key True 			when DirWatcher.eventsCoalesce $ do 				sha <- inRepo $@@ -190,38 +224,43 @@ 				then a 				else return Nothing -{- PendingAddChanges can Either be Right to be added now,+{- Files can Either be Right to be added now,  - or are unsafe, and must be Left for later.  -  - Check by running lsof on the temp directory, which  - the KeySources are locked down in.  -}-safeToAdd :: ThreadState -> [Change] -> IO [Either Change Change]-safeToAdd st changes = runThreadState st $-	ifM (Annex.getState Annex.force)-		( allRight changes -- force bypasses lsof check-		, do-			tmpdir <- fromRepo gitAnnexTmpDir-			openfiles <- S.fromList . map fst3 . filter openwrite <$>-				liftIO (Lsof.queryDir tmpdir)--			let checked = map (check openfiles) changes+safeToAdd :: Maybe Seconds -> ThreadState -> [Change] -> [Change] -> IO [Either Change Change]+safeToAdd _ _ [] [] = return []+safeToAdd delayadd st pending inprocess = do+	maybe noop threadDelaySeconds delayadd+	runThreadState st $ do+		keysources <- mapM Command.Add.lockDown (map changeFile pending)+		let inprocess' = map mkinprocess (zip pending keysources)+		tmpdir <- fromRepo gitAnnexTmpDir+		openfiles <- S.fromList . map fst3 . filter openwrite <$>+			liftIO (Lsof.queryDir tmpdir)+		let checked = map (check openfiles) $ inprocess ++ inprocess' -			{- If new events are received when files are closed,-			 - there's no need to retry any changes that cannot-			 - be done now. -}-			if DirWatcher.closingTracked-				then do-					mapM_ canceladd $ lefts checked-					allRight $ rights checked-				else return checked-		)+		{- If new events are received when files are closed,+		 - there's no need to retry any changes that cannot+		 - be done now. -}+		if DirWatcher.closingTracked+			then do+				mapM_ canceladd $ lefts checked+				allRight $ rights checked+			else return checked 	where-		check openfiles change@(PendingAddChange { keySource = ks })+		check openfiles change@(InProcessAddChange { keySource = ks }) 			| S.member (contentLocation ks) openfiles = Left change 		check _ change = Right change -		canceladd (PendingAddChange { keySource = ks }) = do+		mkinprocess (c, ks) = InProcessAddChange+			{ changeTime = changeTime c+			, keySource = ks+			}++		canceladd (InProcessAddChange { keySource = ks }) = do 			warning $ keyFilename ks 				++ " still has writers, not adding" 			-- remove the hard link
Assistant/Threads/SanityChecker.hs view
@@ -76,7 +76,7 @@ check st dstatus transferqueue changechan = do 	g <- runThreadState st $ fromRepo id 	-- Find old unstaged symlinks, and add them to git.-	unstaged <- Git.LsFiles.notInRepo False ["."] g+	(unstaged, cleanup) <- Git.LsFiles.notInRepo False ["."] g 	now <- getPOSIXTime 	forM_ unstaged $ \file -> do 		ms <- catchMaybeIO $ getSymbolicLinkStatus file@@ -85,6 +85,7 @@ 				| isSymbolicLink s -> 					addsymlink file ms 			_ -> noop+	void cleanup 	return True 	where 		toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime)@@ -93,7 +94,7 @@ 			runThreadState st $ warning msg 			void $ addAlert dstatus $ sanityCheckFixAlert msg 		addsymlink file s = do-			Watcher.runHandler thisThread Nothing st dstatus+			Watcher.runHandler thisThread st dstatus 				transferqueue changechan 				Watcher.onAddSymlink file s 			insanity $ "found unstaged symlink: " ++ file
Assistant/Threads/TransferScanner.hs view
@@ -22,6 +22,7 @@ import qualified Git.LsFiles as LsFiles import Command import Annex.Content+import Annex.Wanted  import qualified Data.Set as S @@ -94,8 +95,9 @@ 	liftIO $ debug thisThread ["starting scan of", show visiblers] 	void $ alertWhile dstatus (scanAlert visiblers) $ do 		g <- runThreadState st $ fromRepo id-		files <- LsFiles.inRepo [] g+		(files, cleanup) <- LsFiles.inRepo [] g 		go files+		void cleanup 		return True 	liftIO $ debug thisThread ["finished scan of", show visiblers] 	where@@ -104,18 +106,20 @@ 			in if null rs' then rs else rs' 		go [] = noop 		go (f:fs) = do-			mapM_ (enqueue f) =<< catMaybes <$> runThreadState st-				(ifAnnexed f findtransfers $ return [])+			mapM_ (enqueue f) =<< runThreadState st+				(ifAnnexed f (findtransfers f) $ return []) 			go fs 		enqueue f (r, t) = do 			debug thisThread ["queuing", show t] 			queueTransferWhenSmall transferqueue dstatus (Just f) t r-		findtransfers (key, _) = do+		findtransfers f (key, _) = do 			locs <- loggedLocations key-			let use a = return $ map (a key locs) rs+			let use a = return $ catMaybes $ map (a key locs) rs 			ifM (inAnnex key)-				( use $ check Upload False-				, use $ check Download True+				( filterM (wantSend (Just f) . Remote.uuid . fst)+					=<< use (check Upload False)+				, ifM (wantGet $ Just f)+					( use (check Download True) , return [] ) 				) 		check direction want key locs r 			| direction == Upload && Remote.readonly r = Nothing
Assistant/Threads/Watcher.hs view
@@ -5,8 +5,6 @@  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE CPP #-}- module Assistant.Threads.Watcher ( 	watchThread, 	checkCanWatch,@@ -30,14 +28,10 @@ import qualified Git.Command import qualified Git.UpdateIndex import qualified Git.HashObject-import qualified Git.LsFiles import qualified Backend-import qualified Command.Add import Annex.Content import Annex.CatFile import Git.Types-import Config-import Utility.ThreadScheduler  import Data.Bits.Utils import qualified Data.ByteString.Lazy as L@@ -60,32 +54,19 @@ 	, "Be warned: This can corrupt data in the annex, and make fsck complain." 	] -{- 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-#ifdef darwin_HOST_OS-delayaddDefault = Just $ Seconds 1-#else-delayaddDefault = Nothing-#endif- watchThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> NamedThread watchThread st dstatus transferqueue changechan = NamedThread thisThread $ do-	delayadd <- runThreadState st $-		maybe delayaddDefault (Just . Seconds) . readish-			<$> getConfig (annexConfig "delayadd") "" -	void $ watchDir "." ignored (hooks delayadd) startup+	void $ watchDir "." ignored hooks startup 	debug thisThread [ "watching", "."] 	where 		startup = startupScan st dstatus-		hook delay a = Just $ runHandler thisThread delay st dstatus transferqueue changechan a-		hooks delayadd = mkWatchHooks-			{ addHook = hook delayadd onAdd-			, delHook = hook Nothing onDel-			, addSymlinkHook = hook Nothing onAddSymlink-			, delDirHook = hook Nothing onDelDir-			, errHook = hook Nothing onErr+		hook a = Just $ runHandler thisThread st dstatus transferqueue changechan a+		hooks = mkWatchHooks+			{ addHook = hook onAdd+			, delHook = hook onDel+			, addSymlinkHook = hook onAddSymlink+			, delDirHook = hook onDelDir+			, errHook = hook onErr 			}  {- Initial scartup scan. The action should return once the scan is complete. -}@@ -113,65 +94,35 @@ 	ig ".gitattributes" = True 	ig _ = False -type Handler = ThreadName -> Maybe Seconds -> FilePath -> Maybe FileStatus -> DaemonStatusHandle -> TransferQueue -> Annex (Maybe Change)+type Handler = ThreadName -> FilePath -> Maybe FileStatus -> DaemonStatusHandle -> TransferQueue -> Annex (Maybe Change)  {- Runs an action handler, inside the Annex monad, and if there was a  - change, adds it to the ChangeChan.  -  - Exceptions are ignored, otherwise a whole watcher thread could be crashed.  -}-runHandler :: ThreadName -> Maybe Seconds -> ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> Handler -> FilePath -> Maybe FileStatus -> IO ()-runHandler threadname delay st dstatus transferqueue changechan handler file filestatus = void $ do+runHandler :: ThreadName -> ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> Handler -> FilePath -> Maybe FileStatus -> IO ()+runHandler threadname st dstatus transferqueue changechan handler file filestatus = void $ do 	r <- tryIO go 	case r of 		Left e -> print e 		Right Nothing -> noop 		Right (Just change) -> recordChange changechan change 	where-		go = runThreadState st $ handler threadname delay file filestatus dstatus transferqueue+		go = runThreadState st $ handler threadname file filestatus dstatus transferqueue -{- During initial directory scan, this will be run for any regular files- - that are already checked into git. We don't want to turn those into- - symlinks, so do a check. This is rather expensive, but only happens- - during startup.- -- - It's possible for the file to still be open for write by some process.- - This can happen in a few ways; one is if two processes had the file open- - and only one has just closed it. We want to avoid adding a file to the- - annex that is open for write, to avoid anything being able to change it.- -- - We could run lsof on the file here to check for other writers.- - But, that's slow, and even if there is currently a writer, we will want- - to add the file *eventually*. Instead, the file is locked down as a hard- - link in a temp directory, with its write bits disabled, for later- - checking with lsof, and a Change is returned containing a KeySource- - using that hard link. The committer handles running lsof and finishing- - the add.- -} onAdd :: Handler-onAdd threadname delay file filestatus dstatus _-	| maybe False isRegularFile filestatus =-		ifM (scanComplete <$> liftIO (getDaemonStatus dstatus))-			( go-			, ifM (null <$> inRepo (Git.LsFiles.notInRepo False [file]))-				( noChange-				, go-				)-			)+onAdd _ file filestatus _ _+	| maybe False isRegularFile filestatus = pendingAddChange file 	| otherwise = noChange 	where-		go = do-			liftIO $ do-				debug threadname ["file added", file]-				maybe noop threadDelaySeconds delay-			pendingAddChange =<< Command.Add.lockDown 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.  -} onAddSymlink :: Handler-onAddSymlink threadname _ file filestatus dstatus transferqueue = go =<< Backend.lookupFile file+onAddSymlink threadname file filestatus dstatus transferqueue = go =<< Backend.lookupFile file 	where 		go (Just (key, _)) = do 			link <- calcGitLink file key@@ -232,7 +183,7 @@ 			| otherwise = noop  onDel :: Handler-onDel threadname _ file _ _dstatus _ = do+onDel threadname file _ _dstatus _ = do 	liftIO $ debug threadname ["file deleted", file] 	Annex.Queue.addUpdateIndex =<< 		inRepo (Git.UpdateIndex.unstageFile file)@@ -246,7 +197,7 @@  - command to get the recursive list of files in the directory, so rm is  - just as good. -} onDelDir :: Handler-onDelDir threadname _ dir _ _dstatus _ = do+onDelDir threadname dir _ _dstatus _ = do 	liftIO $ debug threadname ["directory deleted", dir] 	Annex.Queue.addCommand "rm" 		[Params "--quiet -r --cached --ignore-unmatch --"] [dir]@@ -254,7 +205,7 @@  {- Called when there's an error with inotify or kqueue. -} onErr :: Handler-onErr _ _ msg _ dstatus _ = do+onErr _ msg _ dstatus _ = do 	warning msg 	void $ liftIO $ addAlert dstatus $ warningAlert "watcher" msg 	return Nothing
Assistant/Threads/WebApp.hs view
@@ -17,6 +17,7 @@ import Assistant.WebApp.SideBar import Assistant.WebApp.Notifications import Assistant.WebApp.Configurators+import Assistant.WebApp.Configurators.Edit import Assistant.WebApp.Configurators.Local import Assistant.WebApp.Configurators.Ssh import Assistant.WebApp.Configurators.Pairing
Assistant/TransferQueue.hs view
@@ -27,6 +27,7 @@ import Types.Remote import qualified Remote import qualified Types.Remote as Remote+import Annex.Wanted  import Control.Concurrent.STM import qualified Data.Map as M@@ -56,22 +57,26 @@ 	, associatedFile = f 	} -{- Adds transfers to queue for some of the known remotes. -}+{- Adds transfers to queue for some of the known remotes.+ - Honors preferred content settings, only transferring wanted files. -} queueTransfers :: Schedule -> TransferQueue -> DaemonStatusHandle -> Key -> AssociatedFile -> Direction -> Annex () queueTransfers = queueTransfersMatching (const True)  {- Adds transfers to queue for some of the known remotes, that match a- - condition. -}+ - condition. Honors preferred content settings. -} queueTransfersMatching :: (UUID -> Bool) -> Schedule -> TransferQueue -> DaemonStatusHandle -> Key -> AssociatedFile -> Direction -> Annex ()-queueTransfersMatching matching schedule q dstatus k f direction = do-	rs <- sufficientremotes-		=<< knownRemotes <$> liftIO (getDaemonStatus dstatus)-	let matchingrs = filter (matching . Remote.uuid) rs-	if null matchingrs-		then defer-		else forM_ matchingrs $ \r -> liftIO $-			enqueue schedule q dstatus (gentransfer r) (stubInfo f r)+queueTransfersMatching matching schedule q dstatus k f direction+	| direction == Download = whenM (wantGet f) go+	| otherwise = go 	where+		go = do+			rs <- sufficientremotes+				=<< knownRemotes <$> liftIO (getDaemonStatus dstatus)+			let matchingrs = filter (matching . Remote.uuid) rs+			if null matchingrs+				then defer+				else forM_ matchingrs $ \r -> liftIO $+					enqueue schedule q dstatus (gentransfer r) (stubInfo f r) 		sufficientremotes rs 			{- Queue downloads from all remotes that 			 - have the key, with the cheapest ones first.@@ -80,11 +85,9 @@ 			| direction == Download = do 				uuids <- Remote.keyLocations k 				return $ filter (\r -> uuid r `elem` uuids) rs-			{- TODO: Determine a smaller set of remotes that-			 - can be uploaded to, in order to ensure all-			 - remotes can access the content. Currently,-			 - send to every remote we can. -}-			| otherwise = return $ filter (not . Remote.readonly) rs+			{- Upload to all remotes that want the content. -}+			| otherwise = filterM (wantSend f . Remote.uuid) $+				filter (not . Remote.readonly) rs 		gentransfer r = Transfer 			{ transferDirection = direction 			, transferKey = k
Assistant/WebApp/Configurators.hs view
@@ -44,8 +44,18 @@ 	repolist <- lift $ repoList False 	$(widgetFile "configurators/repositories") +data SetupRepo = EnableRepo (Route WebApp) | EditRepo (Route WebApp)++needsEnabled :: SetupRepo -> Bool+needsEnabled (EnableRepo _) = True+needsEnabled _ = False++setupRepoLink :: SetupRepo -> Route WebApp+setupRepoLink (EnableRepo r) = r+setupRepoLink (EditRepo r) = r+ {- A numbered list of known repositories, including the current one. -}-repoList :: Bool -> Handler [(String, String, Maybe (Route WebApp))]+repoList :: Bool -> Handler [(String, String, SetupRepo)] repoList onlyconfigured 	| onlyconfigured = list =<< configured 	| otherwise = list =<< (++) <$> configured <*> unconfigured@@ -55,7 +65,9 @@ 				(liftIO . getDaemonStatus =<< daemonStatus <$> getYesod) 			runAnnex [] $ do 				u <- getUUID-				return $ zip (u : map Remote.uuid rs) (repeat Nothing)+				let l = u : map Remote.uuid rs+				return $ zip l (map editlink l)+		editlink = EditRepo . EditRepositoryR 		unconfigured = runAnnex [] $ do 			m <- readRemoteLog 			catMaybes . map (findtype m) . snd@@ -67,7 +79,7 @@ 				Just "directory" -> u `enableswith` EnableDirectoryR 				Just "S3" -> u `enableswith` EnableS3R 				_ -> Nothing-		u `enableswith` r = Just (u, Just $ r u)+		u `enableswith` r = Just (u, EnableRepo $ r u) 		list l = runAnnex [] $ do 			let l' = nubBy (\x y -> fst x == fst y) l 			zip3
+ Assistant/WebApp/Configurators/Edit.hs view
@@ -0,0 +1,56 @@+{- git-annex assistant webapp configurator for editing existing repos+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}++module Assistant.WebApp.Configurators.Edit where++import Assistant.Common+import Assistant.WebApp+import Assistant.WebApp.Types+import Assistant.WebApp.SideBar+import Utility.Yesod+import qualified Remote+import Logs.UUID++import Yesod+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Map as M++data RepoConfig = RepoConfig+	{ repoDescription :: Text+	}+	deriving (Show)++editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig+editRepositoryAForm def = RepoConfig+	<$> areq textField "Description" (Just $ repoDescription def)++getRepoConfig :: UUID -> Annex RepoConfig+getRepoConfig uuid = RepoConfig+	<$> (T.pack . fromMaybe "" . M.lookup uuid <$> uuidMap)++getEditRepositoryR :: UUID -> Handler RepHtml+getEditRepositoryR uuid = bootstrap (Just Config) $ do+	sideBarDisplay+	setTitle "Configure repository"+	+	curr <- lift $ runAnnex undefined $ getRepoConfig uuid+	((result, form), enctype) <- lift $+		runFormGet $ renderBootstrap $ editRepositoryAForm curr+	case result of+		FormSuccess input -> do+			error (show input)+		_ -> showform form enctype+	where+		showform form enctype = do+			let authtoken = webAppFormAuthToken+			description <- lift $+				runAnnex T.empty $  T.pack . concat <$>+					Remote.prettyListUUIDs [uuid]+			$(widgetFile "configurators/editrepository")
Assistant/WebApp/Configurators/Local.hs view
@@ -28,10 +28,13 @@ import Utility.DataUnits import Utility.Network import Remote (prettyListUUIDs)+import Logs.Group+import Annex.UUID  import Yesod import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Set as S import Data.Char import System.Posix.Directory import qualified Control.Exception as E@@ -142,10 +145,10 @@ 	case res of 		FormSuccess (RepositoryPath p) -> lift $ do 			let path = T.unpack p-			liftIO $ do-				makeRepo path False-				initRepo path Nothing-				addAutoStart path+			liftIO $ makeRepo path False+			u <- liftIO $ initRepo path Nothing+			runAnnex () $ groupSet u (S.singleton "clients")+			liftIO $ addAutoStart path 			redirect $ SwitchToRepositoryR path 		_ -> $(widgetFile "configurators/newrepository") @@ -191,8 +194,9 @@ 	where 		go mountpoint = do 			liftIO $ makerepo dir-			liftIO $ initRepo dir $ Just remotename+			u <- liftIO $ initRepo dir $ Just remotename 			r <- addremote dir remotename+			runAnnex () $ groupSet u (S.singleton "drives") 			syncRemote r 			where 				dir = mountpoint </> gitAnnexAssistantDefaultDir@@ -260,9 +264,10 @@ startFullAssistant :: FilePath -> Handler () startFullAssistant path = do 	webapp <- getYesod+	liftIO $ makeRepo path False+	u <- liftIO $ initRepo path Nothing+	runAnnex () $ groupSet u (S.singleton "clients") 	url <- liftIO $ do-		makeRepo path False-		initRepo path Nothing 		addAutoStart path 		changeWorkingDirectory path 		fromJust $ postFirstRun webapp@@ -286,10 +291,11 @@ 	Annex.eval state a  {- Initializes a git-annex repository in a directory with a description. -}-initRepo :: FilePath -> Maybe String -> IO ()-initRepo dir desc = inDir dir $+initRepo :: FilePath -> Maybe String -> IO UUID+initRepo dir desc = inDir dir $ do 	unlessM isInitialized $ 		initialize desc+	getUUID  {- Adds a directory to the autostart file. -} addAutoStart :: FilePath -> IO ()
Assistant/WebApp/Configurators/S3.hs view
@@ -19,12 +19,14 @@ import Utility.Yesod import qualified Remote.S3 as S3 import Logs.Remote-import Remote (prettyListUUIDs)+import qualified Remote import Types.Remote (RemoteConfig)+import Logs.Group  import Yesod import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Set as S import qualified Data.Map as M  s3Configurator :: Widget -> Handler RepHtml@@ -80,7 +82,7 @@ 	case result of 		FormSuccess s3input -> lift $ do 			let name = T.unpack $ repoName s3input-			makeS3Remote (extractCreds s3input) name $ M.fromList+			makeS3Remote (extractCreds s3input) name setgroup $ M.fromList 				[ ("encryption", "shared") 				, ("type", "S3") 				, ("datacenter", T.unpack $ datacenter s3input)@@ -91,6 +93,8 @@ 		showform form enctype = do 			let authtoken = webAppFormAuthToken 			$(widgetFile "configurators/adds3")+		setgroup r = runAnnex () $+			groupSet (Remote.uuid r) (S.singleton "servers")  getEnableS3R :: UUID -> Handler RepHtml getEnableS3R uuid = s3Configurator $ do@@ -101,24 +105,24 @@ 			m <- runAnnex M.empty readRemoteLog 			let name = fromJust $ M.lookup "name" $ 				fromJust $ M.lookup uuid m-			makeS3Remote s3creds name M.empty+			makeS3Remote s3creds name (const noop) M.empty 		_ -> showform form enctype 	where 		showform form enctype = do 			let authtoken = webAppFormAuthToken 			description <- lift $ runAnnex "" $-				T.pack . concat <$> prettyListUUIDs [uuid]+				T.pack . concat <$> Remote.prettyListUUIDs [uuid] 			$(widgetFile "configurators/enables3") -makeS3Remote :: S3Creds -> String -> RemoteConfig -> Handler ()-makeS3Remote (S3Creds ak sk) name config = do+makeS3Remote :: S3Creds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()+makeS3Remote (S3Creds ak sk) name setup config = do 	webapp <- getYesod 	let st = fromJust $ threadState webapp 	remotename <- runAnnex name $ fromRepo $ uniqueRemoteName name 0-	liftIO $ do-		S3.s3SetCredsEnv ( T.unpack ak, T.unpack sk)-		r <- runThreadState st $ addRemote $ do-			makeSpecialRemote name S3.remote config-			return remotename-		syncNewRemote st (daemonStatus webapp) (scanRemotes webapp) r+	liftIO $ S3.s3SetCredsEnv ( T.unpack ak, T.unpack sk)+	r <- liftIO $ runThreadState st $ addRemote $ do+		makeSpecialRemote name S3.remote config+		return remotename+	setup r+	liftIO $ syncNewRemote st (daemonStatus webapp) (scanRemotes webapp) r 	redirect RepositoriesR
Assistant/WebApp/Configurators/Ssh.hs view
@@ -19,11 +19,13 @@ import Utility.Rsync (rsyncUrlIsShell) import Logs.Remote import Remote+import Logs.Group  import Yesod import Data.Text (Text) import qualified Data.Text as T import qualified Data.Map as M+import qualified Data.Set as S import Network.Socket import System.Posix.User @@ -130,7 +132,7 @@ 			case result of 				FormSuccess sshinput' 					| isRsyncNet (hostname sshinput') ->-						void $ lift $ makeRsyncNet sshinput'+						void $ lift $ makeRsyncNet sshinput' (const noop) 					| otherwise -> do 						s <- liftIO $ testServer sshinput' 						case s of@@ -250,23 +252,23 @@ 	$(widgetFile "configurators/ssh/confirm")  getMakeSshGitR :: SshData -> Handler RepHtml-getMakeSshGitR = makeSsh False+getMakeSshGitR = makeSsh False setupGroup  getMakeSshRsyncR :: SshData -> Handler RepHtml-getMakeSshRsyncR = makeSsh True+getMakeSshRsyncR = makeSsh True setupGroup -makeSsh :: Bool -> SshData -> Handler RepHtml-makeSsh rsync sshdata+makeSsh :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml+makeSsh rsync setup sshdata 	| needsPubKey sshdata = do 		keypair <- liftIO genSshKeyPair 		sshdata' <- liftIO $ setupSshKeyPair keypair sshdata-		makeSsh' rsync sshdata' (Just keypair)-	| otherwise = makeSsh' rsync sshdata Nothing+		makeSsh' rsync setup sshdata' (Just keypair)+	| otherwise = makeSsh' rsync setup sshdata Nothing -makeSsh' :: Bool -> SshData -> Maybe SshKeyPair -> Handler RepHtml-makeSsh' rsync sshdata keypair =+makeSsh' :: Bool -> (Remote -> Handler ()) -> SshData -> Maybe SshKeyPair -> Handler RepHtml+makeSsh' rsync setup sshdata keypair = 	sshSetup [sshhost, remoteCommand] "" $-		makeSshRepo rsync sshdata+		makeSshRepo rsync setup sshdata 	where 		sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata) 		remotedir = T.unpack $ sshDirectory sshdata@@ -280,14 +282,15 @@ 				else Nothing 			] -makeSshRepo :: Bool -> SshData -> Handler RepHtml-makeSshRepo forcersync sshdata = do+makeSshRepo :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml+makeSshRepo forcersync setup sshdata = do 	webapp <- getYesod-	liftIO $ makeSshRemote+	r <- liftIO $ makeSshRemote 		(fromJust $ threadState webapp) 		(daemonStatus webapp) 		(scanRemotes webapp) 		forcersync sshdata+	setup r 	redirect RepositoriesR  getAddRsyncNetR :: Handler RepHtml@@ -303,14 +306,14 @@ 	case result of 		FormSuccess sshinput 			| isRsyncNet (hostname sshinput) ->-				makeRsyncNet sshinput+				makeRsyncNet sshinput setupGroup 			| otherwise -> 				showform $ UnusableServer 					"That is not a rsync.net host name." 		_ -> showform UntestedServer -makeRsyncNet :: SshInput -> Handler RepHtml-makeRsyncNet sshinput = do+makeRsyncNet :: SshInput -> (Remote -> Handler ()) -> Handler RepHtml+makeRsyncNet sshinput setup = do 	knownhost <- liftIO $ maybe (return False) knownHost (hostname sshinput) 	keypair <- liftIO $ genSshKeyPair 	sshdata <- liftIO $ setupSshKeyPair keypair $@@ -338,8 +341,11 @@ 		, remotecommand 		] 	sshSetup sshopts (sshPubKey keypair) $-		makeSshRepo True sshdata+		makeSshRepo True setup sshdata  isRsyncNet :: Maybe Text -> Bool isRsyncNet Nothing = False isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host++setupGroup :: Remote -> Handler ()+setupGroup r = runAnnex () $ groupSet (Remote.uuid r) (S.singleton "server")
Assistant/WebApp/routes view
@@ -10,6 +10,7 @@ /config/repository/new/first FirstRepositoryR GET /config/repository/new NewRepositoryR GET /config/repository/switchto/#FilePath SwitchToRepositoryR GET+/config/repository/edit/#UUID EditRepositoryR GET  /config/repository/add/drive AddDriveR GET /config/repository/add/ssh AddSshR GET
Build/InstallDesktopFile.hs view
@@ -87,7 +87,7 @@  installOSXAppFile :: FilePath -> FilePath -> Maybe String -> IO () installOSXAppFile appdir appfile mcontent = do-	let src = "standalone" </> "macos" </> appdir </> appfile+	let src = "standalone" </> "osx" </> appdir </> appfile 	home <- myHomeDir 	dest <- ifM systemwideInstall 		( return $ "/Applications" </> appdir </> appfile
CHANGELOG view
@@ -1,3 +1,31 @@+git-annex (3.20121009) unstable; urgency=low++  * watch, assistant: It's now safe to git annex unlock files while+    the watcher is running, as well as modify files checked into git+    as normal files. Additionally, .gitignore settings are now honored.+    Closes: #689979+  * group, ungroup: New commands to indicate groups of repositories.+  * webapp: Adds newly created repositories to one of these groups:+    clients, drives, servers+  * vicfg: New command, allows editing (or simply viewing) most+    of the repository configuration settings stored in the git-annex branch.+  * Added preferred content expressions, configurable using vicfg.+  * get --auto: If the local repository has preferred content+    configured, only get that content.+  * drop --auto: If the repository the content is dropped from has+    preferred content configured, drop only content that is not preferred.+  * copy --auto: Only transfer content that the destination repository prefers.+  * assistant: Now honors preferred content settings when deciding what to+    transfer.+  * --copies=group:number can now be used to match files that are present+    in a specified number of repositories in a group.+  * Added --smallerthan, --largerthan, and --inall limits.+  * Only build-depend on libghc-clientsession-dev on arches that will have+    the webapp.+  * uninit: Unset annex.version. Closes: #689852++ -- Joey Hess <joeyh@debian.org>  Tue, 09 Oct 2012 15:13:23 -0400+ git-annex (3.20121001) unstable; urgency=low    * fsck: Now has an incremental mode. Start a new incremental fsck pass
CmdLine.hs view
@@ -15,6 +15,7 @@ import qualified Data.Map as M import Control.Exception (throw) import System.Console.GetOpt+import System.Posix.Signals  import Common.Annex import qualified Annex@@ -108,7 +109,9 @@  {- Actions to perform each time ran. -} startup :: Annex Bool-startup = return True+startup = liftIO $ do+	void $ installHandler sigINT Default Nothing+	return True  {- Cleanup actions. -} shutdown :: Bool -> Annex Bool
Command.hs view
@@ -22,6 +22,7 @@ 	numCopies, 	autoCopies, 	autoCopiesWith,+	checkAuto, 	module ReExported ) where @@ -113,7 +114,8 @@  -  - In auto mode, first checks that the number of known  - copies of the key is > or < than the numcopies setting, before running- - the action. -}+ - the action. Also checks any preferred content settings.+ -} autoCopies :: FilePath -> Key -> (Int -> Int -> Bool) -> CommandStart -> CommandStart autoCopies file key vs a = Annex.getState Annex.auto >>= go 	where@@ -133,4 +135,10 @@ 		auto numcopiesattr True = do 			needed <- getNumCopies numcopiesattr 			(_, have) <- trustPartition UnTrusted =<< Remote.keyLocations key-			if length have `vs` needed then a numcopiesattr else stop+			if length have `vs` needed+				then a numcopiesattr+				else stop++checkAuto :: Annex Bool -> Annex Bool+checkAuto checker = ifM (Annex.getState Annex.auto)+	( checker , return True )
Command/Copy.hs view
@@ -11,6 +11,7 @@ import Command import qualified Command.Move import qualified Remote+import Annex.Wanted  def :: [Command] def = [withOptions Command.Move.options $ command "copy" paramPaths seek@@ -21,8 +22,14 @@ 		withField Command.Move.fromOption Remote.byName $ \from -> 			withFilesInGit $ whenAnnexed $ start to from] --- A copy is just a move that does not delete the source file.--- However, --auto mode avoids unnecessary copies.+{- A copy is just a move that does not delete the source file.+ - However, --auto mode avoids unnecessary copies, and avoids getting or+ - sending non-preferred content. -} start :: Maybe Remote -> Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart start to from file (key, backend) = autoCopies file key (<) $-	Command.Move.start to from False file (key, backend)+	stopUnless shouldCopy $ +		Command.Move.start to from False file (key, backend)+	where+		shouldCopy = case to of+			Nothing -> checkAuto $ wantGet (Just file)+			Just r -> checkAuto $ wantSend (Just file) (Remote.uuid r)
Command/Drop.hs view
@@ -17,6 +17,7 @@ import Annex.Content import Config import qualified Option+import Annex.Wanted  def :: [Command] def = [withOptions [fromOption] $ command "drop" paramPaths seek@@ -31,13 +32,14 @@  start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart start from file (key, _) = autoCopiesWith file key (>) $ \numcopies ->-	case from of-		Nothing -> startLocal file numcopies key-		Just remote -> do-			u <- getUUID-			if Remote.uuid remote == u-				then startLocal file numcopies key-				else startRemote file numcopies key remote+	stopUnless (checkAuto $ wantDrop (Remote.uuid <$> from) (Just file)) $+		case from of+			Nothing -> startLocal file numcopies key+			Just remote -> do+				u <- getUUID+				if Remote.uuid remote == u+					then startLocal file numcopies key+					else startRemote file numcopies key remote  startLocal :: FilePath -> Maybe Int -> Key -> CommandStart startLocal file numcopies key = stopUnless (inAnnex key) $ do
Command/Get.hs view
@@ -13,6 +13,7 @@ import Annex.Content import qualified Command.Move import Logs.Transfer+import Annex.Wanted  def :: [Command] def = [withOptions [Command.Move.fromOption] $ command "get" paramPaths seek@@ -23,7 +24,7 @@ 	withFilesInGit $ whenAnnexed $ start from]  start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart-start from file (key, _) = stopUnless (not <$> inAnnex key) $+start from file (key, _) = stopUnless ((not <$> inAnnex key) <&&> checkAuto (wantGet $ Just file)) $ 	autoCopies file key (<) $ 		case from of 			Nothing -> go $ perform key file
+ Command/Group.hs view
@@ -0,0 +1,34 @@+{- git-annex command+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Command.Group where++import Common.Annex+import Command+import qualified Remote+import Logs.Group+import Types.Group++import qualified Data.Set as S++def :: [Command]+def = [command "group" (paramPair paramRemote paramDesc) seek "add a repository to a group"]++seek :: [CommandSeek]+seek = [withWords start]++start :: [String] -> CommandStart+start (name:g:[]) = do+	showStart "group" name+	u <- Remote.nameToUUID name+	next $ perform u g+start _ = error "Specify a repository and a group."++perform :: UUID -> Group -> CommandPerform+perform uuid g = do+	groupChange uuid (S.insert g) +	next $ return True
Command/Log.hs view
@@ -69,6 +69,7 @@ 	FilePath -> (Key, Backend) -> CommandStart start m zone os gource file (key, _) = do 	showLog output =<< readLog <$> getLog key os+	-- getLog produces a zombie; reap it 	liftIO Git.Command.reap 	stop 	where@@ -136,7 +137,7 @@ 	top <- fromRepo Git.repoPath 	p <- liftIO $ relPathCwdToFile top 	let logfile = p </> Logs.Location.logFile key-	inRepo $ pipeNullSplit $+	inRepo $ pipeNullSplitZombie $ 		[ Params "log -z --pretty=format:%ct --raw --abbrev=40" 		, Param "--remove-empty" 		] ++ os ++
Command/Status.hs view
@@ -12,6 +12,7 @@ import Control.Monad.State.Strict import qualified Data.Map as M import Text.JSON+import Data.Tuple  import Common.Annex import qualified Types.Backend as B@@ -32,6 +33,7 @@ import Config import Utility.Percentage import Logs.Transfer+import Types.TrustLevel  -- a named computation that produces a statistic type Stat = StatState (Maybe (String, StatState String))@@ -67,10 +69,10 @@ fast_stats =  	[ supported_backends 	, supported_remote_types-	, remote_list Trusted "trusted"-	, remote_list SemiTrusted "semitrusted"-	, remote_list UnTrusted "untrusted"-	, remote_list DeadTrusted "dead"+	, remote_list Trusted+	, remote_list SemiTrusted+	, remote_list UnTrusted+	, remote_list DeadTrusted 	, transfer_list 	, disk_size 	]@@ -125,14 +127,14 @@ supported_remote_types = stat "supported remote types" $ json unwords $ 	return $ map R.typename Remote.remoteTypes -remote_list :: TrustLevel -> String -> Stat-remote_list level desc = stat n $ nojson $ lift $ do+remote_list :: TrustLevel -> Stat+remote_list level = stat n $ nojson $ lift $ do 	us <- M.keys <$> (M.union <$> uuidMap <*> remoteMap Remote.name) 	rs <- fst <$> trustPartition level us 	s <- prettyPrintUUIDs n rs 	return $ if null s then "0" else show (length rs) ++ "\n" ++ beginning s 	where-		n = desc ++ " repositories"+		n = showTrustLevel level ++ " repositories" 	 local_annex_size :: Stat local_annex_size = stat "local annex size" $ json id $@@ -178,10 +180,9 @@ 	ts <- getTransfers 	if null ts 		then return "none"-		else return $ pp uuidmap "" $ sort ts+		else return $ multiLine $+			map (\(t, i) -> line uuidmap t i) $ sort ts 	where-		pp _ c [] = c-		pp uuidmap c ((t, i):xs) = "\n\t" ++ line uuidmap t i ++ pp uuidmap c xs 		line uuidmap t i = unwords 			[ showLcDirection (transferDirection t) ++ "ing" 			, fromMaybe (key2file $ transferKey t) (associatedFile i)@@ -213,10 +214,10 @@ 		<$> (backendsKeys <$> cachedReferencedData) 		<*> (backendsKeys <$> cachedPresentData) 	where-		calc a b = pp "" $ reverse . sort $ map swap $ M.toList $ M.unionWith (+) a b-		pp c [] = c-		pp c ((n, b):xs) = "\n\t" ++ b ++ ": " ++ show n ++ pp c xs-		swap (a, b) = (b, a)+		calc x y = multiLine $+			map (\(n, b) -> b ++ ": " ++ show n) $+			reverse $ sort $ map swap $ M.toList $+			M.unionWith (+) x y  cachedPresentData :: StatState KeyData cachedPresentData = do@@ -284,3 +285,7 @@  aside :: String -> String aside s = " (" ++ s ++ ")"++multiLine :: [String] -> String+multiLine = concatMap (\l -> "\n\t" ++ l)+
Command/Sync.hs view
@@ -196,11 +196,13 @@ resolveMerge :: Annex Bool resolveMerge = do 	top <- fromRepo Git.repoPath-	merged <- all id <$> (mapM resolveMerge' =<< inRepo (LsFiles.unmerged [top]))+	(fs, cleanup) <- inRepo (LsFiles.unmerged [top])+	merged <- all id <$> mapM resolveMerge' fs 	when merged $ do 		Annex.Queue.flush 		void $ inRepo $ Git.Command.runBool "commit" 			[Param "-m", Param "git-annex automatic merge conflict fix"]+	void $ liftIO cleanup 	return merged  resolveMerge' :: LsFiles.Unmerged -> Annex Bool
Command/Unannex.hs view
@@ -39,12 +39,14 @@ 	-- Commit that removal now, to avoid later confusing the 	-- pre-commit hook if this file is later added back to 	-- git as a normal, non-annexed file.-	whenM (not . null <$> inRepo (LsFiles.staged [file])) $ do+	(s, clean) <- inRepo $ LsFiles.staged [file]+	when (not $ null s) $ do 		showOutput 		inRepo $ Git.Command.run "commit" [ 			Param "-q", 			Params "-m", Param "content removed from git annex", 			Param "--", File file]+	void $ liftIO clean  	ifM (Annex.getState Annex.fast) 		( do
+ Command/Ungroup.hs view
@@ -0,0 +1,34 @@+{- git-annex command+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Command.Ungroup where++import Common.Annex+import Command+import qualified Remote+import Logs.Group+import Types.Group++import qualified Data.Set as S++def :: [Command]+def = [command "ungroup" (paramPair paramRemote paramDesc) seek "remove a repository from a group"]++seek :: [CommandSeek]+seek = [withWords start]++start :: [String] -> CommandStart+start (name:g:[]) = do+	showStart "ungroup" name+	u <- Remote.nameToUUID name+	next $ perform u g+start _ = error "Specify a repository and a group."++perform :: UUID -> Group -> CommandPerform+perform uuid g = do+	groupChange uuid (S.delete g) +	next $ return True
Command/Uninit.hs view
@@ -32,7 +32,7 @@ 		error "can only run uninit from the top of the git repository" 	where 		current_branch = Git.Ref . Prelude.head . lines <$> revhead-		revhead = inRepo $ Git.Command.pipeRead +		revhead = inRepo $ Git.Command.pipeReadStrict 			[Params "rev-parse --abbrev-ref HEAD"]  seek :: [CommandSeek]
Command/Unused.hs view
@@ -228,10 +228,14 @@ 		calla k _ = a k  withKeysReferenced' :: v -> (Key -> v -> Annex v) -> Annex v-withKeysReferenced' initial a = go initial =<< files+withKeysReferenced' initial a = do+	(files, clean) <- getfiles+	r <- go initial files+	liftIO $ void clean+	return r 	where-		files = ifM isBareRepo-			( return []+		getfiles = ifM isBareRepo+			( return ([], return True) 			, do 				top <- fromRepo Git.repoPath 				inRepo $ LsFiles.inRepo [top]@@ -251,7 +255,7 @@ 	rs <- relevantrefs <$> showref 	forM_ rs (withKeysReferencedInGitRef a) 	where-		showref = inRepo $ Git.Command.pipeRead [Param "show-ref"]+		showref = inRepo $ Git.Command.pipeReadStrict [Param "show-ref"] 		relevantrefs = map (Git.Ref .  snd) . 			nubBy uniqref . 			filter ourbranches .
+ Command/Vicfg.hs view
@@ -0,0 +1,206 @@+{- git-annex command+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Command.Vicfg where++import qualified Data.Map as M+import qualified Data.Set as S+import System.Environment (getEnv)+import Data.Tuple (swap)+import Data.Char (isSpace)++import Common.Annex+import Command+import Annex.Perms+import Types.TrustLevel+import Types.Group+import Logs.Trust+import Logs.Group+import Logs.PreferredContent+import Remote++def :: [Command]+def = [command "vicfg" paramNothing seek+	"edit git-annex's configuration"]++seek :: [CommandSeek]+seek = [withNothing start]++start :: CommandStart+start = do+	f <- fromRepo gitAnnexTmpCfgFile+	createAnnexDirectory $ parentDir f+	cfg <- getCfg+	liftIO $ writeFile f $ genCfg cfg+	vicfg cfg f+	stop++vicfg :: Cfg -> FilePath -> Annex ()+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]]) $+		error $ vi ++ " exited nonzero; aborting"+	r <- parseCfg curcfg <$> liftIO (readFileStrict f)+	liftIO $ nukeFile f+	case r of+		Left s -> do+			liftIO $ writeFile f s+			vicfg curcfg f+		Right newcfg -> setCfg curcfg newcfg++data Cfg = Cfg+	{ cfgTrustMap :: TrustMap+	, cfgGroupMap :: M.Map UUID (S.Set Group)+	, cfgPreferredContentMap :: M.Map UUID String+	, cfgDescriptions :: M.Map UUID String+	}++getCfg :: Annex Cfg+getCfg = Cfg+	<$> trustMapRaw -- without local trust overrides+	<*> (groupsByUUID <$> groupMap)+	<*> preferredContentMapRaw+	<*> uuidDescriptions++setCfg :: Cfg -> Cfg -> Annex ()+setCfg curcfg newcfg = do+	let (trustchanges, groupchanges, preferredcontentchanges) = diffCfg curcfg newcfg+	mapM_ (uncurry trustSet) $ M.toList trustchanges+	mapM_ (uncurry groupSet) $ M.toList groupchanges+	mapM_ (uncurry preferredContentSet) $ M.toList preferredcontentchanges++diffCfg :: Cfg -> Cfg -> (TrustMap, M.Map UUID (S.Set Group), M.Map UUID String)+diffCfg curcfg newcfg = (diff cfgTrustMap, diff cfgGroupMap, diff cfgPreferredContentMap)+	where+		diff f = M.differenceWith (\x y -> if x == y then Nothing else Just x)+			(f newcfg) (f curcfg)++genCfg :: Cfg -> String+genCfg cfg = unlines $ concat+	[ intro+	, trustintro, trust, defaulttrust+	, groupsintro, groups, defaultgroups+	, preferredcontentintro, preferredcontent, defaultpreferredcontent+	]+	where+		intro =+			[ com "git-annex configuration"+			, com ""+			, com "Changes saved to this file will be recorded in the git-annex branch."+			, com ""+			, com "Lines in this file have the format:"+			, com "  setting repo = value"+			]++		trustintro =+			[ ""+			, com "Repository trust configuration"+			, com "(Valid trust levels: " +++			  unwords (map showTrustLevel [Trusted .. DeadTrusted]) +++			  ")"+			]+		trust = map (\(t, u) -> line "trust" u $ showTrustLevel t) $+			sort $ map swap $ M.toList $ cfgTrustMap cfg++		defaulttrust = map (\u -> pcom $ line "trust" u $ showTrustLevel SemiTrusted) $+			missing cfgTrustMap+		groupsintro = +			[ ""+			, com "Repository groups"+			, com "(Separate group names with spaces)"+			]+		groups = sort $ map (\(s, u) -> line "group" u $ unwords $ S.toList s) $+			map swap $ M.toList $ cfgGroupMap cfg+		defaultgroups = map (\u -> pcom $ line "group" u "") $+			missing cfgGroupMap++		preferredcontentintro = +			[ ""+			, com "Repository preferred contents"+			]+		preferredcontent = sort $ map (\(s, u) -> line "preferred-content" u s) $+			map swap $ M.toList $ cfgPreferredContentMap cfg+		defaultpreferredcontent = map (\u -> pcom $ line "preferred-content" u "") $+			missing cfgPreferredContentMap++		line setting u value = unwords+			[ setting+			, showu u+			, "=" +			, value+			]+		pcom s = "#" ++ s+		showu u = fromMaybe (fromUUID u) $+			M.lookup u (cfgDescriptions cfg)+		missing field = S.toList $ M.keysSet (cfgDescriptions cfg) `S.difference` M.keysSet (field cfg)++{- If there's a parse error, returns a new version of the file,+ - with the problem lines noted. -}+parseCfg :: Cfg -> String -> Either String Cfg+parseCfg curcfg = go [] curcfg . lines+	where+		go c cfg []+			| null (catMaybes $ map fst c) = Right cfg+			| otherwise = Left $ unlines $+				badheader ++ concatMap showerr (reverse c)+		go c cfg (l:ls) = case parse (dropWhile isSpace l) cfg of+			Left msg -> go ((Just msg, l):c) cfg ls+			Right cfg' -> go ((Nothing, l):c) cfg' ls++		parse l cfg+			| null l = Right cfg+			| "#" `isPrefixOf` l = Right cfg+			| null setting || null repo' = Left "missing repository name"+			| otherwise = case M.lookup repo' name2uuid of+				Nothing -> badval "repository" repo'+				Just u -> handle cfg u setting value'+			where+				(setting, rest) = separate isSpace l+				(repo, value) = separate (== '=') rest+				value' = trimspace value+				repo' = reverse $ trimspace $+					reverse $ trimspace repo+				trimspace = dropWhile isSpace++		handle cfg u setting value+			| setting == "trust" = case readTrustLevel value of+				Nothing -> badval "trust value" value+				Just t ->+					let m = M.insert u t (cfgTrustMap cfg)+					in Right $ cfg { cfgTrustMap = m }+			| setting == "group" =+				let m = M.insert u (S.fromList $ words value) (cfgGroupMap cfg)+				in Right $ cfg { cfgGroupMap = m }+			| setting == "preferred-content" = +				case checkPreferredContentExpression value of+					Just e -> Left e+					Nothing ->+						let m = M.insert u value (cfgPreferredContentMap cfg)+						in Right $ cfg { cfgPreferredContentMap = m }+			| otherwise = badval "setting" setting++		name2uuid = M.fromList $ map swap $+			M.toList $ cfgDescriptions curcfg++		showerr (Just msg, l) = [parseerr ++ msg, l]+		showerr (Nothing, l)+			-- filter out the header and parse error lines+			-- from any previous parse failure+			| any (`isPrefixOf` l) (parseerr:badheader) = []+			| otherwise = [l]++		badval desc val = Left $ "unknown " ++ desc ++ " \"" ++ val ++ "\""+		badheader = +			[ com "There was a problem parsing your input."+			, com "Search for \"Parse error\" to find the bad lines."+			, com "Either fix the bad lines, or delete them (to discard your changes)."+			]+		parseerr = com "Parse error in next line: "++com :: String -> String+com s = "# " ++ s
Git/Branch.hs view
@@ -27,7 +27,7 @@ 	case v of 		Nothing -> return Nothing 		Just branch -> -			ifM (null <$> pipeRead [Param "show-ref", Param $ show branch] r)+			ifM (null <$> pipeReadStrict [Param "show-ref", Param $ show branch] r) 				( return Nothing 				, return v 				)@@ -35,7 +35,7 @@ {- The current branch, which may not really exist yet. -} currentUnsafe :: Repo -> IO (Maybe Git.Ref) currentUnsafe r = parse . firstLine-	<$> pipeRead [Param "symbolic-ref", Param "HEAD"] r+	<$> pipeReadStrict [Param "symbolic-ref", Param "HEAD"] r 	where 		parse l 			| null l = Nothing@@ -48,7 +48,7 @@ 	| origbranch == newbranch = return False 	| otherwise = not . null <$> diffs 	where-		diffs = pipeRead+		diffs = pipeReadStrict 			[ Param "log" 			, Param (show origbranch ++ ".." ++ show newbranch) 			, Params "--oneline -n1"@@ -93,7 +93,7 @@ commit :: String -> Branch -> [Ref] -> Repo -> IO Sha commit message branch parentrefs repo = do 	tree <- getSha "write-tree" $-		pipeRead [Param "write-tree"] repo+		pipeReadStrict [Param "write-tree"] repo 	sha <- getSha "commit-tree" $ pipeWriteRead 		(map Param $ ["commit-tree", show tree] ++ ps) 		message repo
Git/Command.hs view
@@ -8,7 +8,7 @@ module Git.Command where  import System.Posix.Process (getAnyProcessStatus)-import System.Process+import System.Process (std_out, env)  import Common import Git@@ -38,19 +38,34 @@ 	unlessM (runBool subcommand params repo) $ 		error $ "git " ++ subcommand ++ " " ++ show params ++ " failed" -{- Runs a git subcommand and returns its output, lazily. +{- Runs a git subcommand and returns its output, lazily.  -- - Note that this leaves the git process running, and so zombies will- - result unless reap is called.+ - Also returns an action that should be used when the output is all+ - read (or no more is needed), that will wait on the command, and+ - return True if it succeeded. Failure to wait will result in zombies.  -}-pipeRead :: [CommandParam] -> Repo -> IO String-pipeRead params repo = assertLocal repo $-	withHandle StdoutHandle createBackgroundProcess p $ \h -> do+pipeReadLazy :: [CommandParam] -> Repo -> IO (String, IO Bool)+pipeReadLazy params repo = assertLocal repo $ do+	(_, Just h, _, pid) <- createProcess p { std_out = CreatePipe }+	fileEncoding h+	c <- hGetContents h+	return (c, checkSuccessProcess pid)+	where+		p  = gitCreateProcess params repo++{- Runs a git subcommand, and returns its output, strictly.+ -+ - Nonzero exit status is ignored.+ -}+pipeReadStrict :: [CommandParam] -> Repo -> IO String+pipeReadStrict params repo = assertLocal repo $+	withHandle StdoutHandle (createProcessChecked ignoreFailureProcess) p $ \h -> do 		fileEncoding h-		hGetContents h+		output <- hGetContentsStrict h+		hClose h+		return output 	where-		p  = (proc "git" $ toCommand $ gitCommandLine params repo)-			{ env = gitEnv repo }+		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@@ -62,20 +77,31 @@  {- Runs a git subcommand, feeding it input on a handle with an action. -} pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO ()-pipeWrite params repo = withHandle StdinHandle createProcessSuccess p-	where-		p = (proc "git" $ toCommand $ gitCommandLine params repo)-			{ env = gitEnv repo }+pipeWrite params repo = withHandle StdinHandle createProcessSuccess $+	gitCreateProcess params repo  {- Reads null terminated output of a git command (as enabled by the -z   - parameter), and splits it. -}-pipeNullSplit :: [CommandParam] -> Repo -> IO [String]-pipeNullSplit params repo =-	filter (not . null) . split sep <$> pipeRead params repo+pipeNullSplit :: [CommandParam] -> Repo -> IO ([String], IO Bool)+pipeNullSplit params repo = do+	(s, cleanup) <- pipeReadLazy params repo+	return (filter (not . null) $ split sep s, cleanup) 	where 		sep = "\0" -{- Reaps any zombie git processes. -}++pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String]+pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo++{- Doesn't run the cleanup action. A zombie results. -}+leaveZombie :: (a, IO Bool) -> a+leaveZombie = fst++{- Reaps any zombie git processes. + -+ - Warning: Not thread safe. Anything that was expecting to wait+ - on a process and get back an exit status is going to be confused+ - if this reap gets there first. -} reap :: IO () reap = do 	-- throws an exception when there are no child processes@@ -85,3 +111,8 @@ {- Runs a git command as a coprocess. -} gitCoProcessStart :: [CommandParam] -> Repo -> IO CoProcess.CoProcessHandle gitCoProcessStart params repo = CoProcess.start "git" (toCommand $ gitCommandLine params repo) (gitEnv repo)++gitCreateProcess :: [CommandParam] -> Repo -> CreateProcess+gitCreateProcess params repo =+	(proc "git" $ toCommand $ gitCommandLine params repo)+			{ env = gitEnv repo }
Git/HashObject.hs view
@@ -39,7 +39,6 @@ hashObject :: ObjectType -> String -> Repo -> IO Sha hashObject objtype content repo = getSha subcmd $ do 	s <- pipeWriteRead (map Param params) content repo-	reap -- XXX unsure why this is needed, of if it is anymore 	return s 	where 		subcmd = "hash-object"
Git/LsFiles.hs view
@@ -25,11 +25,11 @@ import Git.Sha  {- Scans for files that are checked into git at the specified locations. -}-inRepo :: [FilePath] -> Repo -> IO [FilePath]+inRepo :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) inRepo l = pipeNullSplit $ Params "ls-files --cached -z --" : map File l  {- Scans for files at the specified locations that are not checked into git. -}-notInRepo :: Bool -> [FilePath] -> Repo -> IO [FilePath]+notInRepo :: Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) notInRepo include_ignored l repo = pipeNullSplit params repo 	where 		params = [Params "ls-files --others"] ++ exclude ++@@ -39,44 +39,44 @@ 			| otherwise = [Param "--exclude-standard"]  {- Returns a list of all files that are staged for commit. -}-staged :: [FilePath] -> Repo -> IO [FilePath]+staged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) staged = staged' []  {- Returns a list of the files, staged for commit, that are being added,  - moved, or changed (but not deleted), from the specified locations. -}-stagedNotDeleted :: [FilePath] -> Repo -> IO [FilePath]+stagedNotDeleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"] -staged' :: [CommandParam] -> [FilePath] -> Repo -> IO [FilePath]+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  {- Returns a list of files that have unstaged changes. -}-changedUnstaged :: [FilePath] -> Repo -> IO [FilePath]+changedUnstaged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) changedUnstaged l = pipeNullSplit params 	where 		params = Params "diff --name-only -z --" : map File l  {- Returns a list of the files in the specified locations that are staged  - for commit, and whose type has changed. -}-typeChangedStaged :: [FilePath] -> Repo -> IO [FilePath]+typeChangedStaged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) typeChangedStaged = typeChanged' [Param "--cached"]  {- Returns a list of the files in the specified locations whose type has  - changed.  Files only staged for commit will not be included. -}-typeChanged :: [FilePath] -> Repo -> IO [FilePath]+typeChanged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) typeChanged = typeChanged' [] -typeChanged' :: [CommandParam] -> [FilePath] -> Repo -> IO [FilePath]+typeChanged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) typeChanged' ps l repo = do-	fs <- pipeNullSplit (prefix ++ ps ++ suffix) repo+	(fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo 	-- git diff returns filenames relative to the top of the git repo; 	-- convert to filenames relative to the cwd, like git ls-files. 	let top = repoPath repo 	cwd <- getCurrentDirectory-	return $ map (\f -> relPathDirToFile cwd $ top </> f) fs+	return (map (\f -> relPathDirToFile cwd $ top </> f) fs, cleanup) 	where 		prefix = [Params "diff --name-only --diff-filter=T -z"] 		suffix = Param "--" : map File l@@ -104,11 +104,12 @@  -   3 = them  - If a line is omitted, that side deleted the file.  -}-unmerged :: [FilePath] -> Repo -> IO [Unmerged]-unmerged l repo = reduceUnmerged [] . catMaybes . map parseUnmerged <$> list repo+unmerged :: [FilePath] -> Repo -> IO ([Unmerged], IO Bool)+unmerged l repo = do+	(fs, cleanup) <- pipeNullSplit params repo+	return (reduceUnmerged [] $ catMaybes $ map parseUnmerged fs, cleanup) 	where-		files = map File l-		list = pipeNullSplit $ Params "ls-files --unmerged -z --" : files+		params = Params "ls-files --unmerged -z --" : map File l  data InternalUnmerged = InternalUnmerged 	{ isus :: Bool
Git/LsTree.hs view
@@ -30,7 +30,7 @@ {- Lists the contents of a Ref -} lsTree :: Ref -> Repo -> IO [TreeItem] lsTree t repo = map parseLsTree <$>-	pipeNullSplit [Params "ls-tree --full-tree -z -r --", File $ show t] repo+	pipeNullSplitZombie [Params "ls-tree --full-tree -z -r --", File $ show t] repo  {- Parses a line of ls-tree output.  - (The --long format is not currently supported.) -}
Git/Ref.hs view
@@ -41,7 +41,7 @@ sha :: Branch -> Repo -> IO (Maybe Sha) sha branch repo = process <$> showref repo 	where-		showref = pipeRead [Param "show-ref",+		showref = pipeReadStrict [Param "show-ref", 			Param "--hash", -- get the hash 			Param $ show branch] 		process [] = Nothing@@ -50,7 +50,7 @@ {- List of (refs, branches) matching a given ref spec. -} matching :: Ref -> Repo -> IO [(Ref, Branch)] matching ref repo = map gen . lines <$> -	pipeRead [Param "show-ref", Param $ show ref] repo+	pipeReadStrict [Param "show-ref", Param $ show ref] repo 	where 		gen l = let (r, b) = separate (== ' ') l in 			(Ref r, Ref b)
Git/UnionMerge.hs view
@@ -58,9 +58,11 @@ {- Streams update-index changes to perform a merge,  - using git to get a raw diff. -} doMerge :: CatFileHandle -> [String] -> Repo -> Streamer-doMerge ch differ repo streamer = gendiff >>= go+doMerge ch differ repo streamer = do+	(diff, cleanup) <- pipeNullSplit (map Param differ) repo+	go diff+	void $ cleanup 	where-		gendiff = pipeNullSplit (map Param differ) repo 		go [] = noop 		go (info:file:rest) = mergeFile info file ch repo >>= 			maybe (go rest) (\l -> streamer l >> go rest)
Git/UpdateIndex.hs view
@@ -48,7 +48,10 @@ {- A streamer that adds the current tree for a ref. Useful for eg, copying  - and modifying branches. -} lsTree :: Ref -> Repo -> Streamer-lsTree (Ref x) repo streamer = mapM_ streamer =<< pipeNullSplit params repo+lsTree (Ref x) repo streamer = do+	(s, cleanup) <- pipeNullSplit params repo+	mapM_ streamer s+	void $ cleanup 	where 		params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]
GitAnnex.hs view
@@ -55,6 +55,9 @@ import qualified Command.Untrust import qualified Command.Semitrust import qualified Command.Dead+import qualified Command.Group+import qualified Command.Ungroup+import qualified Command.Vicfg import qualified Command.Sync import qualified Command.AddUrl import qualified Command.Import@@ -92,6 +95,9 @@ 	, Command.Untrust.def 	, Command.Semitrust.def 	, Command.Dead.def+	, Command.Group.def+	, Command.Ungroup.def+	, Command.Vicfg.def 	, Command.FromKey.def 	, Command.DropKey.def 	, Command.TransferKey.def@@ -141,6 +147,12 @@ 		"skip files with fewer copies" 	, Option ['B'] ["inbackend"] (ReqArg Limit.addInBackend paramName) 		"skip files not using a key-value backend"+	, Option [] ["ingroup"] (ReqArg Limit.addInGroup paramGroup)+		"skip files not present in all remotes in a group"+	, Option [] ["largerthan"] (ReqArg Limit.addLargerThan paramSize)+		"skip files larger than a size"+	, Option [] ["smallerthan"] (ReqArg Limit.addSmallerThan paramSize)+		"skip files smaller than a size" 	, Option ['T'] ["time-limit"] (ReqArg Limit.addTimeLimit paramTime) 		"stop after the specified amount of time" 	] ++ Option.matcher
Init.hs view
@@ -48,6 +48,7 @@ uninitialize = do 	gitPreCommitHookUnWrite 	removeRepoUUID+	removeVersion  {- Will automatically initialize if there is already a git-annex    branch from somewhere. Otherwise, require a manual init
Limit.hs view
@@ -1,6 +1,6 @@ {- user-specified limits on files to act on  -- - Copyright 2011 Joey Hess <joey@kitenet.net>+ - Copyright 2011,2012 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -10,6 +10,8 @@ import Text.Regex.PCRE.Light.Char8 import System.Path.WildMatch import Data.Time.Clock.POSIX+import qualified Data.Set as S+import qualified Data.Map as M  import Common.Annex import qualified Annex@@ -17,10 +19,18 @@ import qualified Remote import qualified Backend import Annex.Content+import Annex.UUID import Logs.Trust+import Types.TrustLevel+import Types.Key+import Types.Group+import Logs.Group import Utility.HumanTime+import Utility.DataUnits -type Limit = Utility.Matcher.Token (FilePath -> Annex Bool)+type MatchFiles = AssumeNotPresent -> FilePath -> Annex Bool+type MkLimit = String -> Either String MatchFiles+type AssumeNotPresent = S.Set UUID  {- Checks if there are user-specified limits. -} limited :: Annex Bool@@ -42,7 +52,7 @@ 			return matcher  {- Adds something to the limit list, which is built up reversed. -}-add :: Limit -> Annex ()+add :: Utility.Matcher.Token (FilePath -> Annex Bool) -> Annex () add l = Annex.changeState $ \s -> s { Annex.limit = prepend $ Annex.limit s } 	where 		prepend (Left ls) = Left $ l:ls@@ -53,17 +63,23 @@ addToken = add . Utility.Matcher.token  {- Adds a new limit. -}-addLimit :: (FilePath -> Annex Bool) -> Annex ()-addLimit = add . Utility.Matcher.Operation+addLimit :: Either String MatchFiles -> Annex ()+addLimit = either error (\l -> add $ Utility.Matcher.Operation $ l S.empty)  {- Add a limit to skip files that do not match the glob. -} addInclude :: String -> Annex ()-addInclude glob = addLimit $ return . matchglob glob+addInclude = addLimit . limitInclude +limitInclude :: MkLimit+limitInclude glob = Right $ const $ return . matchglob glob+ {- Add a limit to skip files that match the glob. -} addExclude :: String -> Annex ()-addExclude glob = addLimit $ return . not . matchglob glob+addExclude = addLimit . limitExclude +limitExclude :: MkLimit+limitExclude glob = Right $ const $ return . not . matchglob glob+ matchglob :: String -> FilePath -> Bool matchglob glob f = isJust $ match cregex f [] 	where@@ -73,52 +89,110 @@ {- Adds a limit to skip files not believed to be present  - in a specfied repository. -} addIn :: String -> Annex ()-addIn name = addLimit $ check $ if name == "." then inAnnex else inremote+addIn = addLimit . limitIn++limitIn :: MkLimit+limitIn name = Right $ \notpresent -> check $+	if name == "."+		then inhere notpresent+		else inremote notpresent 	where 		check a = Backend.lookupFile >=> handle a 		handle _ Nothing = return False 		handle a (Just (key, _)) = a key-		inremote key = do+		inremote notpresent key = do 			u <- Remote.nameToUUID name 			us <- Remote.keyLocations key-			return $ u `elem` us+			return $ u `elem` us && u `S.notMember` notpresent+		inhere notpresent key+			| S.null notpresent = inAnnex key+			| otherwise = do+				u <- getUUID+				if u `S.member` notpresent+					then return False+					else inAnnex key  {- Adds a limit to skip files not believed to have the specified number  - of copies. -} addCopies :: String -> Annex ()-addCopies trust_num = addLimit . check $ readnum num+addCopies = addLimit . limitCopies++limitCopies :: MkLimit+limitCopies want = case split ":" want of+	[v, n] -> case readTrustLevel v of+		Just trust -> go n $ checktrust trust+		Nothing -> go n $ checkgroup v+	[n] -> go n $ const $ return True+	_ -> Left "bad value for copies" 	where-		(num, mayCheckTrust) = case split ":" trust_num of-			[trust, num'] -> (num', checkTrust (readtrust trust))-			[num'] -> (num', const (return True))-			_ -> bad-		readnum = maybe bad id . readish-		readtrust = maybe bad id . readTrust-		check n = Backend.lookupFile >=> handle n-		handle _ Nothing = return False-		handle n (Just (key, _)) = do-			us <- filterM mayCheckTrust =<< Remote.keyLocations key+		go num good = case readish num of+			Nothing -> Left "bad number for copies"+			Just n -> Right $ \notpresent ->+				Backend.lookupFile >=> handle n good notpresent+		handle _ _ _ Nothing = return False+		handle n good notpresent (Just (key, _)) = do+			us <- filter (`S.notMember` notpresent)+				<$> (filterM good =<< Remote.keyLocations key) 			return $ length us >= n-		checkTrust t u = (== t) <$> lookupTrust u-		bad = error "bad number or trust:number for --copies"+		checktrust t u = (== t) <$> lookupTrust u+		checkgroup g u = S.member g <$> lookupGroups u +{- Adds a limit to skip files not believed to be present in all+ - repositories in the specified group. -}+addInGroup :: String -> Annex ()+addInGroup groupname = do+	m <- groupMap+	addLimit $ limitInGroup m groupname++limitInGroup :: GroupMap -> MkLimit+limitInGroup m groupname+	| S.null want = Right $ const $ const $ return True+	| otherwise = Right $ \notpresent ->+		Backend.lookupFile >=> check notpresent+	where+		want = fromMaybe S.empty $ M.lookup groupname $ uuidsByGroup m+		check _ Nothing = return False+		check notpresent (Just (key, _))+			-- optimisation: Check if a wanted uuid is notpresent.+			| not (S.null (S.intersection want notpresent))	= return False+			| otherwise = do+				present <- S.fromList <$> Remote.keyLocations key+				return $ S.null $ want `S.difference` present+ {- Adds a limit to skip files not using a specified key-value backend. -} addInBackend :: String -> Annex ()-addInBackend name = addLimit $ Backend.lookupFile >=> check+addInBackend = addLimit . limitInBackend++limitInBackend :: MkLimit+limitInBackend name = Right $ const $ Backend.lookupFile >=> check 	where 		wanted = Backend.lookupBackendName name 		check = return . maybe False ((==) wanted . snd) +{- Adds a limit to skip files that are too large or too small -}+addLargerThan :: String -> Annex ()+addLargerThan = addLimit . limitSize (>)++addSmallerThan :: String -> Annex ()+addSmallerThan = addLimit . limitSize (<)++limitSize :: (Maybe Integer -> Maybe Integer -> Bool) -> MkLimit+limitSize vs s = case readSize dataUnits s of+	Nothing -> Left "bad size"+	Just sz -> Right $ const $ Backend.lookupFile >=> check sz+	where+		check _ Nothing = return False+		check sz (Just (key, _)) = return $ keySize key `vs` Just sz+ addTimeLimit :: String -> Annex () addTimeLimit s = do 	let seconds = fromMaybe (error "bad time-limit") $ parseDuration s 	start <- liftIO getPOSIXTime 	let cutoff = start + seconds-	addLimit $ const $ do+	addLimit $ Right $ const $ const $ do 		now <- liftIO getPOSIXTime 		if now > cutoff 			then do 				warning $ "Time limit (" ++ s ++ ") reached!" 				liftIO $ exitWith $ ExitFailure 101 			else return True-
Locations.hs view
@@ -30,6 +30,7 @@ 	gitAnnexLogFile, 	gitAnnexHtmlShim, 	gitAnnexUrlFile,+	gitAnnexTmpCfgFile, 	gitAnnexSshDir, 	gitAnnexRemotesDir, 	gitAnnexAssistantDefaultDir,@@ -182,6 +183,10 @@ {- File containing the url to the webapp. -} gitAnnexUrlFile :: Git.Repo -> FilePath gitAnnexUrlFile r = gitAnnexDir r </> "url"++{- Temporary file used to edit configuriation from the git-annex branch. -}+gitAnnexTmpCfgFile :: Git.Repo -> FilePath+gitAnnexTmpCfgFile r = gitAnnexDir r </> "config.tmp"  {- .git/annex/ssh/ is used for ssh connection caching -} gitAnnexSshDir :: Git.Repo -> FilePath
+ Logs/Group.hs view
@@ -0,0 +1,66 @@+{- git-annex group log+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Logs.Group (+	groupChange,+	groupSet,+	lookupGroups,+	groupMap,+) where++import qualified Data.Map as M+import qualified Data.Set as S+import Data.Time.Clock.POSIX++import Common.Annex+import qualified Annex.Branch+import qualified Annex+import Logs.UUIDBased+import Types.Group++{- Filename of group.log. -}+groupLog :: FilePath+groupLog = "group.log"++{- Returns the groups of a given repo UUID. -}+lookupGroups :: UUID -> Annex (S.Set Group)+lookupGroups u = (fromMaybe S.empty . M.lookup u) . groupsByUUID <$> groupMap++{- Applies a set modifier to change the groups for a uuid in the groupLog. -}+groupChange :: UUID -> (S.Set Group -> S.Set Group) -> Annex ()+groupChange uuid@(UUID _) modifier = do+	curr <- lookupGroups uuid+	ts <- liftIO getPOSIXTime+	Annex.Branch.change groupLog $+		showLog (unwords . S.toList) .+			changeLog ts uuid (modifier curr) .+				parseLog (Just . S.fromList . words)+	Annex.changeState $ \s -> s { Annex.groupmap = Nothing }+groupChange NoUUID _ = error "unknown UUID; cannot modify"++groupSet :: UUID -> S.Set Group -> Annex ()+groupSet u g = groupChange u (const g)++{- Read the groupLog into a map. The map is cached for speed. -}+groupMap :: Annex GroupMap+groupMap = do+	cached <- Annex.getState Annex.groupmap+	case cached of+		Just m -> return m+		Nothing -> do+			m <- makeGroupMap . simpleMap . +				parseLog (Just . S.fromList . words) <$>+					Annex.Branch.get groupLog+			Annex.changeState $ \s -> s { Annex.groupmap = Just m }+			return m++makeGroupMap :: M.Map UUID (S.Set Group) -> GroupMap+makeGroupMap byuuid = GroupMap byuuid bygroup+	where+		bygroup = M.fromListWith S.union $+			concat $ map explode $ M.toList byuuid+		explode (u, s) = map (\g -> (g, S.singleton u)) (S.toList s)
+ Logs/PreferredContent.hs view
@@ -0,0 +1,115 @@+{- git-annex preferred content matcher configuration+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Logs.PreferredContent (+	preferredContentSet,+	isPreferredContent,+	preferredContentMap,+	preferredContentMapRaw,+	checkPreferredContentExpression,+) where++import qualified Data.Map as M+import Data.Either+import Data.Time.Clock.POSIX++import Common.Annex+import qualified Annex.Branch+import qualified Annex+import Logs.UUIDBased+import Limit+import qualified Utility.Matcher+import Annex.UUID+import Git.FilePath+import Types.Group+import Logs.Group++{- Filename of preferred-content.log. -}+preferredContentLog :: FilePath+preferredContentLog = "preferred-content.log"++{- Changes the preferred content configuration of a remote. -}+preferredContentSet :: UUID -> String -> Annex ()+preferredContentSet uuid@(UUID _) val = do+	ts <- liftIO getPOSIXTime+	Annex.Branch.change preferredContentLog $+		showLog id . changeLog ts uuid val . parseLog Just+	Annex.changeState $ \s -> s { Annex.groupmap = Nothing }+preferredContentSet NoUUID _ = error "unknown UUID; cannot modify"++{- Checks if a file is preferred content for the specified repository+ - (or the current repository if none is specified). -}+isPreferredContent :: Maybe UUID -> AssumeNotPresent -> TopFilePath -> Annex Bool+isPreferredContent mu notpresent file = do+	u <- maybe getUUID return mu+	m <- preferredContentMap+	case M.lookup u m of+		Nothing -> return True+		Just matcher ->+			Utility.Matcher.matchM2 matcher notpresent $+				getTopFilePath file++{- Read the preferredContentLog into a map. The map is cached for speed. -}+preferredContentMap :: Annex Annex.PreferredContentMap+preferredContentMap = do+	groupmap <- groupMap+	cached <- Annex.getState Annex.preferredcontentmap+	case cached of+		Just m -> return m+		Nothing -> do+			m <- simpleMap . parseLog (Just . makeMatcher groupmap)+				<$> Annex.Branch.get preferredContentLog+			Annex.changeState $ \s -> s { Annex.preferredcontentmap = Just m }+			return m++preferredContentMapRaw :: Annex (M.Map UUID String)+preferredContentMapRaw = simpleMap . parseLog Just+	<$> Annex.Branch.get preferredContentLog++{- This intentionally never fails, even on unparsable expressions,+ - because the configuration is shared amoung repositories and newer+ - versions of git-annex may add new features. Instead, parse errors+ - result in a Matcher that will always succeed. -}+makeMatcher :: GroupMap -> String -> Utility.Matcher.Matcher MatchFiles+makeMatcher groupmap s+	| null (lefts tokens) =  Utility.Matcher.generate $ rights tokens+ 	| otherwise = Utility.Matcher.generate []+	where+		tokens = map (parseToken groupmap) (tokenizeMatcher s)++{- Checks if an expression can be parsed, if not returns Just error -}+checkPreferredContentExpression :: String -> Maybe String+checkPreferredContentExpression s = +	case lefts $ map (parseToken emptyGroupMap) (tokenizeMatcher s) of+		[] -> Nothing+		l -> Just $ unwords $ map ("Parse failure: " ++) l++parseToken :: GroupMap -> String -> Either String (Utility.Matcher.Token MatchFiles)+parseToken groupmap t+	| any (== t) Utility.Matcher.tokens = Right $ Utility.Matcher.token t+	| otherwise = maybe (Left $ "near " ++ show t) use $ M.lookup k m+	where+		(k, v) = separate (== '=') t+		m = M.fromList+			[ ("include", limitInclude)+			, ("exclude", limitExclude)+			, ("in", limitIn)+			, ("copies", limitCopies)+			, ("inbackend", limitInBackend)+			, ("largerthan", limitSize (>))+			, ("smallerthan", limitSize (<))+			, ("ingroup", limitInGroup groupmap)+			]+		use a = Utility.Matcher.Operation <$> a v++{- This is really dumb tokenization; there's no support for quoted values.+ - Open and close parens are always treated as standalone tokens;+ - otherwise tokens must be separated by whitespace. -}+tokenizeMatcher :: String -> [String]+tokenizeMatcher = filter (not . null ) . concatMap splitparens . words+	where+		splitparens = segmentDelim (`elem` "()")
Logs/Trust.hs view
@@ -10,8 +10,8 @@ 	trustGet, 	trustSet, 	trustPartition,-	readTrust, 	lookupTrust,+	trustMapRaw, ) where  import qualified Data.Map as M@@ -42,9 +42,11 @@ trustSet uuid@(UUID _) level = do 	ts <- liftIO getPOSIXTime 	Annex.Branch.change trustLog $-		showLog showTrust . changeLog ts uuid level . parseLog (Just . parseTrust)+		showLog showTrustLog .+			changeLog ts uuid level .+				parseLog (Just . parseTrustLog) 	Annex.changeState $ \s -> s { Annex.trustmap = Nothing }-trustSet NoUUID _ = error "unknown UUID; cannot modify trust level"+trustSet NoUUID _ = error "unknown UUID; cannot modify"  {- Returns the TrustLevel of a given repo UUID. -} lookupTrust :: UUID -> Annex TrustLevel@@ -72,38 +74,34 @@ 		Just m -> return m 		Nothing -> do 			overrides <- Annex.getState Annex.forcetrust-			logged <- simpleMap . parseLog (Just . parseTrust) <$>-				Annex.Branch.get trustLog-			configured <- M.fromList . catMaybes <$>-				(mapM configuredtrust =<< remoteList)+			logged <- trustMapRaw+			configured <- M.fromList . catMaybes+				<$> (mapM 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 readTrust <$>-					getTrustLevel (Types.Remote.repo r)+				maybe Nothing readTrustLevel+					<$> getTrustLevel (Types.Remote.repo r) -readTrust :: String -> Maybe TrustLevel-readTrust "trusted" = Just Trusted-readTrust "untrusted" = Just UnTrusted-readTrust "semitrusted" = Just SemiTrusted-readTrust "dead" = Just DeadTrusted-readTrust _ = Nothing+trustMapRaw :: Annex TrustMap+trustMapRaw = simpleMap . parseLog (Just . parseTrustLog)+	<$> Annex.Branch.get trustLog  {- The trust.log used to only list trusted repos, without a field for the  - trust status, which is why this defaults to Trusted. -}-parseTrust :: String -> TrustLevel-parseTrust s = maybe Trusted parse $ headMaybe $ words s+parseTrustLog :: String -> TrustLevel+parseTrustLog s = maybe Trusted parse $ headMaybe $ words s 	where 		parse "1" = Trusted 		parse "0" = UnTrusted 		parse "X" = DeadTrusted 		parse _ = SemiTrusted -showTrust :: TrustLevel -> String-showTrust Trusted = "1"-showTrust UnTrusted = "0"-showTrust DeadTrusted = "X"-showTrust SemiTrusted = "?"+showTrustLog :: TrustLevel -> String+showTrustLog Trusted = "1"+showTrustLog UnTrusted = "0"+showTrustLog DeadTrusted = "X"+showTrustLog SemiTrusted = "?"
Remote.hs view
@@ -42,6 +42,7 @@ import qualified Data.Map as M import Text.JSON import Text.JSON.Generic+import Data.Tuple  import Common.Annex import Types.Remote@@ -100,7 +101,6 @@ 				Nothing -> return $ byuuid m 		byuuid m = M.lookup (toUUID n) $ transform double m 		transform a = M.fromList . map a . M.toList-		swap (a, b) = (b, a) 		double (a, _) = (a, a)  {- Pretty-prints a list of UUIDs of remotes, for human display.
Remote/Git.hs view
@@ -20,7 +20,6 @@ import Remote.Helper.Ssh import Types.Remote import qualified Git-import qualified Git.Command import qualified Git.Config import qualified Git.Construct import qualified Annex@@ -212,7 +211,7 @@ 		-- No need to update the branch; its data is not used 		-- for anything onLocal is used to do. 		Annex.BranchState.disableUpdate-		liftIO Git.Command.reap `after` a+		a  keyUrls :: Git.Repo -> Key -> [String] keyUrls r key = map tourl (annexLocations key)
Seek.hs view
@@ -16,12 +16,14 @@ import Types.Key import qualified Annex import qualified Git+import qualified Git.Command import qualified Git.LsFiles as LsFiles import qualified Limit import qualified Option -seekHelper :: ([FilePath] -> Git.Repo -> IO [FilePath]) -> [FilePath] -> Annex [FilePath]-seekHelper a params = inRepo $ \g -> runPreserveOrder (`a` g) params+seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [FilePath] -> Annex [FilePath]+seekHelper a params = inRepo $ \g ->+	runPreserveOrder (\fs -> Git.Command.leaveZombie <$> a fs g) params  withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek withFilesInGit a params = prepFiltered a $ seekHelper LsFiles.inRepo params@@ -39,7 +41,7 @@ 		seekunless _ l = do 			force <- Annex.getState Annex.force 			g <- gitRepo-			liftIO $ (\p -> LsFiles.notInRepo force p g) l+			liftIO $ Git.Command.leaveZombie <$> LsFiles.notInRepo force l g  withPathContents :: ((FilePath, FilePath) -> CommandStart) -> CommandSeek withPathContents a params = map a . concat <$> liftIO (mapM get params)@@ -72,7 +74,7 @@ withFilesUnlockedToBeCommitted :: (FilePath -> CommandStart) -> CommandSeek withFilesUnlockedToBeCommitted = withFilesUnlocked' LsFiles.typeChangedStaged -withFilesUnlocked' :: ([FilePath] -> Git.Repo -> IO [FilePath]) -> (FilePath -> CommandStart) -> CommandSeek+withFilesUnlocked' :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> (FilePath -> CommandStart) -> CommandSeek withFilesUnlocked' typechanged a params = do 	-- unlocked files have changed type from a symlink to a regular file 	typechangedfiles <- seekHelper typechanged params
+ Types/Group.hs view
@@ -0,0 +1,27 @@+{- git-annex repo groups+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Types.Group (+	Group,+	GroupMap(..),+	emptyGroupMap+) where++import Types.UUID++import qualified Data.Map as M+import qualified Data.Set as S++type Group = String++data GroupMap = GroupMap+	{ groupsByUUID :: M.Map UUID (S.Set Group)+	, uuidsByGroup :: M.Map Group (S.Set UUID)+	}++emptyGroupMap :: GroupMap+emptyGroupMap = GroupMap M.empty M.empty
Types/TrustLevel.hs view
@@ -7,7 +7,9 @@  module Types.TrustLevel ( 	TrustLevel(..),-	TrustMap+	TrustMap,+	readTrustLevel,+	showTrustLevel, ) where  import qualified Data.Map as M@@ -15,6 +17,19 @@ import Types.UUID  data TrustLevel = Trusted | SemiTrusted | UnTrusted | DeadTrusted-	deriving Eq+	deriving (Eq, Enum, Ord)  type TrustMap = M.Map UUID TrustLevel++readTrustLevel :: String -> Maybe TrustLevel+readTrustLevel "trusted" = Just Trusted+readTrustLevel "untrusted" = Just UnTrusted+readTrustLevel "semitrusted" = Just SemiTrusted+readTrustLevel "dead" = Just DeadTrusted+readTrustLevel _ = Nothing++showTrustLevel :: TrustLevel -> String+showTrustLevel Trusted = "trusted"+showTrustLevel UnTrusted = "untrusted"+showTrustLevel SemiTrusted = "semitrusted"+showTrustLevel DeadTrusted = "dead"
Upgrade/V1.hs view
@@ -83,8 +83,9 @@ updateSymlinks = do 	showAction "updating symlinks" 	top <- fromRepo Git.repoPath-	files <- inRepo $ LsFiles.inRepo [top]+	(files, cleanup) <- inRepo $ LsFiles.inRepo [top] 	forM_ files fixlink+	void $ liftIO cleanup 	where 		fixlink f = do 			r <- lookupFile1 f
Usage.hs view
@@ -83,6 +83,10 @@ paramFormat = "FORMAT" paramFile :: String paramFile = "FILE"+paramGroup :: String+paramGroup = "GROUP"+paramSize :: String+paramSize = "SIZE" paramKeyValue :: String paramKeyValue = "K=V" paramNothing :: String
Utility/INotify.hs view
@@ -164,10 +164,11 @@ 			]  querySysctl :: Read a => [CommandParam] -> IO (Maybe a)-querySysctl ps = do-	v <- catchMaybeIO $ readProcess "sysctl" (toCommand ps)-	case v of-		Nothing -> return Nothing-		Just s -> return $ parsesysctl s+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)
Utility/Matcher.hs view
@@ -19,9 +19,11 @@ 	Token(..), 	Matcher, 	token,+	tokens, 	generate, 	match, 	matchM,+	matchM2, 	matchesAny ) where @@ -48,6 +50,9 @@ token ")" = Close token t = error $ "unknown token " ++ t +tokens :: [String]+tokens = words "and or not ( )"+ {- Converts a list of Tokens into a Matcher. -} generate :: [Token op] -> Matcher op generate = go MAny@@ -91,6 +96,15 @@ 		go (MOr m1 m2) =  go m1 <||> go m2 		go (MNot m1) = liftM not (go m1) 		go (MOp o) = o v++matchM2 :: Monad m => Matcher (v1 -> v2 -> m Bool) -> v1 -> v2 -> m Bool+matchM2 m v1 v2 = 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) = o v1 v2  {- Checks is a matcher contains no limits, and so (presumably) matches  - anything. Note that this only checks the trivial case; it is possible
Utility/Misc.hs view
@@ -42,11 +42,15 @@ {- Splits a list into segments that are delimited by items matching  - a predicate. (The delimiters are not included in the segments.) -} segment :: (a -> Bool) -> [a] -> [[a]]-segment p l = map reverse $ go [] [] l+segment p = filter (not . all p) . segmentDelim p++{- 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 [] (c:r) 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
Utility/Monad.hs view
@@ -16,6 +16,12 @@ firstM _ [] = return Nothing firstM p (x:xs) = ifM (p x) (return $ Just x , firstM p xs) +{- Runs the action on values from the list until it succeeds, returning+ - its result. -}+getM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)+getM _ [] = return Nothing+getM p (x:xs) = maybe (getM p xs) (return . Just) =<< p x+ {- Returns true if any value in the list satisfies the predicate,  - stopping once one is found. -} anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
Utility/Process.hs view
@@ -116,8 +116,10 @@ 	code <- waitForProcess pid 	return $ code == ExitSuccess -ignoreFailureProcess :: ProcessHandle -> IO ()-ignoreFailureProcess = void . waitForProcess+ignoreFailureProcess :: ProcessHandle -> IO Bool+ignoreFailureProcess pid = do+	void $ waitForProcess pid+	return True  {- Runs createProcess, then an action on its handles, and then  - forceSuccessProcess. -}
Utility/Rsync.hs view
@@ -53,7 +53,7 @@  - The params must enable rsync's --progress mode for this to work.  -} rsyncProgress :: (Integer -> IO ()) -> [CommandParam] -> IO Bool-rsyncProgress callback params = catchBoolIO $+rsyncProgress callback params =  	withHandle StdoutHandle createProcessSuccess p (feedprogress 0 []) 	where 		p = proc "rsync" (toCommand params)
Utility/SafeCommand.hs view
@@ -49,8 +49,6 @@ safeSystem :: FilePath -> [CommandParam] -> IO ExitCode safeSystem command params = safeSystemEnv command params Nothing -{- Unlike many implementations of system, SIGINT(ctrl-c) is allowed- - to propigate and will terminate the program. -} safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode safeSystemEnv command params environ = do 	(_, _, _, pid) <- createProcess (proc command $ toCommand params)
debian/changelog view
@@ -1,3 +1,31 @@+git-annex (3.20121009) unstable; urgency=low++  * watch, assistant: It's now safe to git annex unlock files while+    the watcher is running, as well as modify files checked into git+    as normal files. Additionally, .gitignore settings are now honored.+    Closes: #689979+  * group, ungroup: New commands to indicate groups of repositories.+  * webapp: Adds newly created repositories to one of these groups:+    clients, drives, servers+  * vicfg: New command, allows editing (or simply viewing) most+    of the repository configuration settings stored in the git-annex branch.+  * Added preferred content expressions, configurable using vicfg.+  * get --auto: If the local repository has preferred content+    configured, only get that content.+  * drop --auto: If the repository the content is dropped from has+    preferred content configured, drop only content that is not preferred.+  * copy --auto: Only transfer content that the destination repository prefers.+  * assistant: Now honors preferred content settings when deciding what to+    transfer.+  * --copies=group:number can now be used to match files that are present+    in a specified number of repositories in a group.+  * Added --smallerthan, --largerthan, and --inall limits.+  * Only build-depend on libghc-clientsession-dev on arches that will have+    the webapp.+  * uninit: Unset annex.version. Closes: #689852++ -- Joey Hess <joeyh@debian.org>  Tue, 09 Oct 2012 15:13:23 -0400+ git-annex (3.20121001) unstable; urgency=low    * fsck: Now has an incremental mode. Start a new incremental fsck pass
debian/control view
@@ -27,6 +27,7 @@ 	libghc-yesod-static-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64], 	libghc-yesod-default-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64], 	libghc-hamlet-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64],+	libghc-clientsession-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64], 	libghc-case-insensitive-dev, 	libghc-http-types-dev, 	libghc-transformers-dev,@@ -36,7 +37,6 @@ 	libghc-blaze-builder-dev, 	libghc-blaze-html-dev, 	libghc-crypto-api-dev,-	libghc-clientsession-dev, 	libghc-network-multicast-dev, 	libghc-network-info-dev, 	ikiwiki,
doc/bugs/S3_memory_leaks.mdwn view
@@ -8,3 +8,7 @@ The author of hS3 is aware of the problem, and working on it. I think I have identified the root cause of the buffering; it's done by hS3 so it can resend the data if S3 sends it a 307 redirect. --[[Joey]]++At least the send leak should be fixed by the patch in the s3-memory-leak+branch in git. That needs a patch to hS3, which I have sent to its author.+--[[Joey]]
+ doc/bugs/bad_comment_in_ssh_public_key_ssh-rsa.mdwn view
@@ -0,0 +1,22 @@+What steps will reproduce the problem?+I was trying to pair two repositories on 2 different computers, +but my public key had this email address at the end:+bachir@Bachirs-iMac.local++What is the expected output? What do you see instead?+I was expecting successful pairing.+I got:+bad comment in ssh public key ssh-rsa+AAB3....SAK+bachir@Bachirs-iMac.local++What version of git-annex are you using? On what operating system?+I am using the package git-annex  Version: 3.20120925 +on MacOSX Lion++Please provide any additional information below.+I've checked your code, seems to complain about the dash '-' in the email address+bachir@Bachirs-iMac.local++> This bug is already fixed, the fix is in the +> 3.20121001 release. [[done]] --[[Joey]]
+ doc/bugs/error_when_using_repositories_with_non-ASCII_characters.mdwn view
@@ -0,0 +1,59 @@+*What steps will reproduce the problem?*++    hactar% mkdir demonstração+    hactar% cd demonstração+    hactar% cp ~/tmp/*(.) .+    hactar% git init+    Initialized empty Git repository in /tmp/demonstração/.git/+    hactar% git annex init+    init  ok+    (Recording state in git...)+    hactar% git annex add .+    add Equipment Consumption.ods (checksum...) ok+    add Personal.vcard (checksum...) ok+    add Trampo.vcard (checksum...) ok+    add blah.txt (checksum...) ok+    [ more git output ]+    hactar% git commit -m initial+    [master (root-commit) d16bafb] initial+     42 files changed, 42 insertions(+)+    [ more git output ]+    hactar% cd /var/tmp+    hactar% git clone ssh://localhost//tmp/demonstração demonstração+    Cloning into 'demonstração'...+    remote: Counting objects: 176, done.+    remote: Compressing objects: 100% (134/134), done.+    remote: Total 176 (delta 1), reused 0 (delta 0)+    Receiving objects: 100% (176/176), 17.23 KiB, done.+    Resolving deltas: 100% (1/1), done.+    hactar% cd demonstração+    hactar% git annex init+    init  ok+    (Recording state in git...)+    hactar% git annex status+    supported backends: SHA256E SHA1E SHA512E SHA224E SHA384E SHA256 SHA1 SHA512 SHA224 SHA384 WORM URL+    supported remote types: git S3 bup directory rsync web hook+    trusted repositories: (merging origin/git-annex into git-annex...)++    git-annex: fd:14: commitBuffer: invalid argument (invalid character)+    failed+    git-annex: status: 1 failed++*What is the expected output? What do you see instead?*++I expect that "git annex status" will complete successfuly and show information about all repositories.+Instead of that I get the "git-annex: fd:14: commitBuffer: invalid argument (invalid character)" error above.++*What version of git-annex are you using? On what operating system?*++This is with Debian's git-annex_3.20121001_i386.deb installed on an Ubuntu 12.04 system.+Using Ubuntu's original version (3.20120406) the error message is a bit different (here I used the name acentuação instead of demonstração):++    trusted repositories: git-annex-shell: //tmp/acentuação: changeWorkingDirectory: does not exist (No such file or directory)+    Command ssh ["-S","/var/tmp/acentua\231\227o/.git/annex/ssh/localhost","-o","ControlMaster=auto","-o","ControlPersist=yes","localhost","git-annex-shell 'configlist' '//tmp/acentua\195\167\195\163o'"] failed; exit code 1++> I think this is the last unvalid utf-8 bug in git-annex. At least,+> the last one I hypothesized exists. It's in the union merge code. I will+> try to look at it again soon; the last 2 times I looked at that code+> I could not see an easy way to make it allow invalid utf-8 encoded data.+> --[[Joey]]
doc/bugs/git_defunct_processes___40__child_of_git-annex_assistant__41__.mdwn view
@@ -31,4 +31,4 @@  For testing, I am also using two repositories on the same computer.  I set this up from the command line, as the web app does not seem to support syncing to two different git folders on the same computer. -> [[done]]; see comments --[[Joey]] +> [[done]]; all zombies are squelched now in the assistant. --[[Joey]]
doc/bugs/signal_weirdness.mdwn view
@@ -14,7 +14,7 @@ Here git-annex exits before rsync has fully exited. Not a large problem but sorta weird. -The culprit is `safeSystemEnv` in Utility.SafeCommand, which installs+The culprit is `CmdLine.startup` in Utility.SafeCommand, which installs a default signal handler for SIGINT, which causes it to immediatly terminate git-annex. rsync, in turn, has its own SIGINT handler, which  prints the message, typically later.
doc/design/assistant/android.mdwn view
@@ -38,41 +38,7 @@ The app should be aware of network status, and avoid expensive data transfers when not on wifi. This may need to be configurable. -### FAT sucks--The main media partition will use some awful FAT filesystem format from-1982 that cannot support git-annex's symlinks. (Hopefully it can at least-handle all of git's filenames.) Possible approaches to this follow.--(May want to consider which of these would make a Windows port easier too.)--#### bare git repo with file browser--Keep only a bare git repo on Android. The app would then need to include-a file browser to access the files in there, and adding a file would move-it into the repo.--Not ideal.--Could be improved some by registering git-annex as a file handling app on-Android, allowing you to "send to" git-annex.--#### implement git smudge filters--See [[todo/smudge]].--Difficult. Would make git-annex generally better.--#### keep files outside bare git repo--Use a bare git repo but don't keep files in `annex/objects`, instead-leave them outside the repo, and add some local mapping to find them.--Problem: Would leave files unlocked to modification, which might lose a-version git-annex dependend upon existing on the phone. (Maybe the phone-would have to be always considered an untrusted repo, which probably-makes sense anyway.)--#### crazy `LD_PRELOAD` wrapper+## FAT -Need I say more? (Also, Android's linker may not even support it.)+Due to use of the fat filesystem, which doesn't do symlinks, [[nosymlink]]+is probably needed.
+ doc/design/assistant/blog/.day_101__transfer_control_done.mdwn.swp view

binary file changed (absent → 12288 bytes)

+ doc/design/assistant/blog/day_100__cursed_clouds.mdwn view
@@ -0,0 +1,19 @@+Preferred content control is wired up to `--auto` and working for `get`,+`copy`, and `drop`. Note that `drop --from remote --auto` drops files that+the remote's preferred content settings indicate it doesn't want;+likewise `copy --to remote --auto` sends content that the remote does want.++Also implemented `smallerthan`, `largerthan`, and `ingroup` limits,+which should be everything needed for the scenarios described in+[[transfer_control]].++Dying to hook this up to the assistant, but a cloudy day is forcing me to+curtail further computer use.++----++Also, last night I developed a patch for the hS3 library, that should let+git-annex upload large files to S3 without buffering their whole content in+memory. I have a `s3-memory-leak` in git-annex that uses the new API I+developed. Hopefully hS3's maintainer will release a new version with that+soon.
+ doc/design/assistant/blog/day_101__transfer_control_done.mdwn view
@@ -0,0 +1,12 @@+Got the assistant honoring preferred content settings. Although so far that+only determines what it transfers. Additional work will be needed to make+content be dropped when it stops being preferred.++----++Now all repositories created by the webapp will be put into one of three+groups: clients, drives, and servers.++----++
+ doc/design/assistant/blog/day_95__repository_groups.mdwn view
@@ -0,0 +1,21 @@+Spent a lot of time this weekend thinking about/stuck on the [[cloud]]+notification problem. Currently IRC is looking like the best way for+repositories to notify one-another when changes are made, but I'm not sure+about using that, and not ready to start on it.++Instead, laid some groundwork for [[transfer_control]] today. Added +some simple commands to manage groups of repositories, and find files+that are present in repositories in a group. I'm not completely happy+with the syntax for that, and need to think up some good syntax to specify+files that are present in *all* repositories in a group.++The plan is to have the assistant automatically guess at groups to put new+repositories it makes in (it should be able to make good guesses),+as well as have an interface to change them, and an interface to configure+transfer control using these groups (and other ways of matching files).+And, probably, some canned transfer control recipes for common setups.++---++Collected up the past week's work and made a release today. I'm probably+back to making regular releases every week or two.
+ doc/design/assistant/blog/day_96__revisiting_file_adds.mdwn view
@@ -0,0 +1,24 @@+Today I revisited something from way back in [[day_7__bugfixes]].+Back then, it wasn't practical to run `git ls-files` on every+file the watcher noticed, to check if it was already in git. Revisiting+this, I found I could efficiently do that check at the same point it checks+`lsof`. When there's a lot of files being added, they're batched up at that+point, so it won't be calling `git ls-files` repeatedly.++Result: It's safe to mix use of the assistant with files stored in git+in the normal way. And it's safe to mix use of `git annex unlock` with+the assistant; it won't immediately re-lock files. Yay!++----++Also fixed a crash in the committer, and made `git annex status` display+repository groups.++----++Been thinking through where to store the [[transfer_control]] expressions.+Since repositories need to know about the transfer controls of other+remotes, storing them in `.git/config` isn't right. I thought it might be+nice to configure the expressions in `.gitattributes`, but it seems the+file format doesn't allow complicated multi-word attributes. Instead,+they'll be stored in the git-annex branch.
+ doc/design/assistant/blog/day_97__stuffing.mdwn view
@@ -0,0 +1,14 @@+Not a lot of programming today; I spent most of the day stuffing hundreds+of envelopes for this Kickstarter thing you may have heard of. Some post+office is going to be very surprised with all the international mail soon.++----++That said, I did write 184 lines of code. (Actually rather a lot, but it+was mostly pure functional code, so easy to write.) That+pops up your text editor on a file with the the trust and group+configurations of repositories, that's stored in the git-annex branch.+Handy for both viewing that stuff all in one place, and changing it.++The real reason for doing that is to provide a nice interface for editing+transfer control expressions, which I'll be adding next.
+ doc/design/assistant/blog/day_98__preferred_content.mdwn view
@@ -0,0 +1,44 @@+Started implementing [[transfer_control]]. Although I'm currently calling+the configuration for it "preferred content expressions". (What a mouthful!)++I was mostly able to reuse the Limit code (used to handle parameters like+--not --in otherrepo), so it can already build Matchers for preferred content+expressions in my little Domain Specific Language.++Preferred content expressions can be edited with `git annex vicfg`, which+checks that they parse properly. ++The plan is that the first place to use them is not going to be inside the+assistant, but in commands that use the `--auto` parameter, which will use+them as an additional constraint, in addition to the numcopies setting+already used. Once I get it working there, I'll add it to the assistant.++Let's say a repo has a preferred content setting of+"(not copies=trusted:2) and (not in=usbdrive)"++* `git annex get --auto` will get files that have less than 2 trusted+  copies, and are not in the usb drive.+* `git annex drop --auto` will drop files that have 2 or more trusted+  copies, and are not in the usb drive (assuming numcopies allows dropping+  them of course).+* `git annex copy --auto --to thatrepo` run from another repo+  will only copy files that have less than 2 trusted copies. (And if that+  was run on the usb drive, it'd never copy anything!)++There is a complication here.. What if the repo with that preferred content+setting is itself trusted? Then when it gets a file, its number of+trusted copies increases, which will make it be dropped again. :-/++This is a nuance that the numcopies code already deals with, but it's+much harder to deal with it in these complicated expressions. I need to think+about this; the three ideas I'm working on are:++1. Leave it to whoever/whatever writes these expressions to write ones+   that avoid such problems. Which is ok if I'm the only one writing+   pre-canned ones, in practice..+2. Transform expressions into ones that avoid such problems. (For example,+   replace "not copies=trusted:2" with "not (copies=trusted:2 or (in=here and+   trusted=here and copies=trusted:3))"+3. Have some of the commands (mostly drop I think) pretend the drop+   has already happened, and check if it'd then want to get the file back+   again.
+ doc/design/assistant/blog/day_99_shotgun.mdwn view
@@ -0,0 +1,70 @@+Fixed the assistant to wait on all the zombie processes that would sometimes+pile up. I didn't realize this was as bad as it was.++Zombies and git-annex have been a problem since I started developing it,+because back then I made some rather poor choices, due to barely knowing+how to write Haskell. So parts of the code that stream input from git commands+don't clean up after them properly. Not normally a problem, because+git-annex reaps the zombies after each file it processes. But this reaping+is not thread-safe; it cannot be used in the assistant.++If I were starting git-annex today, I'd use one of the new Haskell things like+Conduits, that allow for very clean control over finalization of resources.+But switching it to Conduits now would probably take weeks of work; I've not+yet felt it was worthwhile. (Also it's not clear Conduits are the last,+best thing.)++For now, it keeps track of the pids it needs to wait on, and all the code+run by the assistant is zombie-free. However, some code for fsck and unused+that I anticipate the assistant using eventually still has some lurking+zombies.++----++Solved the issue with preferred content expressions and dropping that+I mentioned yesterday. My solution was to add a parameter to specify a set+of repositories where content should be assumed not to be present. When+deciding whether to drop, it can put the current repository in, and then+if the expression fails to match, the content can be dropped.++Using yesterday's example "(not copies=trusted:2) and (not in=usbdrive)",+when the local repo is one of the 2 trusted copies, the drop check will+see only 1 trusted copy, so the expression matches, and so the content will+not be dropped.++I've not tested my solution, but it type checks. :P I'll wire it up to+`get/drop/move --auto` tomorrow and see how it performs.++----++Would preferred content expressions be more readble if they were inverted+(becoming content filtering expressions)?++1. "(not copies=trusted:2) and (not in=usbdrive)" becomes+   "copies=trusted:2 or in=usbdrive"+2. "smallerthan=10mb and include=*.mp3 and exclude=junk/*" becomes+   "largerthan=10mb or exclude=*.mp3" or include=junk/*"+3. "(not group=archival) and (not copies=archival:1)" becomes+   "group=archival or copies=archival:1"++1 and 3 are improved, but 2, less so. It's a trifle weird for "include"+to mean "include in excluded content".++The other reason not to do this is that currently the expressions+can be fed into `git annex find` on the command line, and it'll come+back with the files that would be kept.++Perhaps a middle groud is to make "dontwant" be an alias for "not".+Then we can write "dontwant (copies=trusted:2 or in=usbdrive)"++----++A user told me this:++> I can confirm that the assistant does what it is supposed to do really well. I+> just hooked up my notebook to the network and it starts syncing from notebook to+> fileserver and the assistant on the fileserver also immediately starts syncing+> to the [..] backup++That makes me happy, it's the first quite so real-world success report I've+heard.
doc/design/assistant/desymlink.mdwn view
@@ -1,5 +1,42 @@ While dropbox allows modifying files in the folder, git-annex freezes-them upon creation.+them upon creation, using symlinks. -To allow editing files in its folder, something like [[todo/smudge]] is-needed, to get rid of the symlinks that stand in for the files.+This is a core design simplification of git-annex.+But it is problimatic too:++* To allow directly editing files in its folder, something like [[todo/smudge]] is+  needed, to get rid of the symlinks that stand in for the files.+* OSX seems to have a [[lot_of_problems|bugs/OSX_alias_permissions_and_versions_problem]]+  with stupid programs that follow symlinks and present the git-annex+  hash filename to the user.+* FAT sucks and doesn't support symlinks at all, so [[Android]] can't+  have regular repos on it.++One approach for this would be to hide the git repo away somewhere,+and have the git-annex assistant watch a regular directory, with+regular files.++There would have to be a mapping from files to git-annex objects.+And some intelligent way to determine when a file has been changed+and no longer corresponds to its object. (Not expensive hashing every time,+plz.)++Since this leaves every file open to modification, any such repository+probably needs to be considered untrusted by git-annex. So it doesn't+leave its only copy of a file in such a repository, but instead+syncs it to a proper git-annex repository.++The assistant would make git commits still, of symlinks. It can already do+that with without actual symlinks existing on disk. More difficult is+handling merging; git merge wants a real repository with files it can+really operate on. The assistant would need to calculate merges on its own,+and update the regular directory to reflect changes made in the merge.++Another massive problem with this idea is that it doesn't allow for+[[partial_content]]. The symlinks that everyone loves to hate on are what+make it possible for the contents of some files to not be present on+disk, while the files are still in git and can be retreived as desired.+With real files, some other standin for a missing file would be needed.+Perhaps a 0 length, unreadable, unwritable file? On systems that+support symlinks it could be a broken symlink like is used now, that+is converted to a real file when it becomes present.
doc/design/assistant/inotify.mdwn view
@@ -6,10 +6,6 @@  ## known bugs -* If a file is checked into git as a normal file and gets modified-  (or merged, etc), it will be converted into an annexed file.-  See [[blog/day_7__bugfixes]].- * When you `git annex unlock` a file, it will immediately be re-locked.   See [[bugs/watcher_commits_unlocked_files]]. @@ -203,3 +199,6 @@     injected into the annex, where it could be opened for write again.     Would need to detect that and undo the annex injection or something. +- If a file is checked into git as a normal file and gets modified+  (or merged, etc), it will be converted into an annexed file.+  See [[blog/day_7__bugfixes]]. **done**; we always check ls-files now
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 14 "Amazon S3 (done)" 9 "Amazon Glacier" 6 "Box.com" 49 "My phone (or MP3 player)" 7 "Tahoe-LAFS" 3 "OpenStack SWIFT" 14 "Google Drive"]]+[[!poll open=yes 14 "Amazon S3 (done)" 9 "Amazon Glacier" 7 "Box.com" 54 "My phone (or MP3 player)" 7 "Tahoe-LAFS" 3 "OpenStack SWIFT" 16 "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/transfer_control.mdwn view
@@ -8,9 +8,21 @@ that has a limited size. This page is about making the assistant do something smart with such remotes. -## specifying what data belongs on a remote+## TODO -Imagine a per-remote `annex-accept` setting, that matches things that+* easy configuration of preferred content+* Drop no longer preferred content.+  - When a file is renamed, it might stop being preferred, so+    could be checked and dropped. (If there's multiple links to+    the same content, this gets tricky.)+  - When a file is sent or received, the sender's preferred content+    settings may change, causing it to be dropped from the sender.+  - May also want to check for things to drop, from both local and remotes,+    when doing the expensive trasfer scan.++## specifying what data a remote prefers to contain **done**++Imagine a per-remote preferred content setting, that matches things that should be stored on the remote.  For example, a MP3 player might use:@@ -23,18 +35,14 @@ between them might use: `not (in=laptop1 and in=laptop2 and in=laptop3)`  In this case, transferring data from the usb repo should-check if `annex-accept` then rejects the data, and if so, drop it+check if preferred content settings rejects the data, and if so, drop it from the repo. So once all three laptops have the data, it is pruned from the transfer drive. -It may make sense to have annex-accept info also be stored in the git-annex-branch, for settings that should apply to a repo globally. Does it make-sense to have local configuration too?--## repo classes+## repo groups **done** -Seems like git-annex needs a way to know the classes of repos. Some-classes:+Seems like git-annex needs a way to know the groups of repos. Some+groups:  * enduser: The user interacts with this repo directly. * archival: This repo accumulates stuff, and once it's in enough archives,@@ -43,24 +51,43 @@   it does not hold data for long periods of time, and tends to have a   limited size. -Add a class.log that can assign repos to these or other classes.-(Should a repo be allowed to be in multiple classes?)+Add a group.log that can assign repos to these or other groups. **done** -Some examples of using classes:+Some examples of using groups:  * Want to remove content from a repo, if it's not an archival repo,   and the content has reached at least one archival repo: -  `(not class=archival) and (not copies=archival:1)`+  `(not group=archival) and (not copies=archival:1)`    That would make send to configure on all repos, or even set-  a global `annex.accept` to it.+  a global `annex.accept` to it. **done**  * Make a cloud repo only hold data until all known clients have a copy: -  `not inall(enduser)`+  `not ingroup(enduser)`  ## configuration  The above is all well and good for those who enjoy boolean algebra, but how to configure these sorts of expressions in the webapp?++## the state change problem **done**++Imagine that a trusted repo has setting like `not copies=trusted:2`+This means that `git annex get --auto` should get files not in 2 trusted+repos. But once it has, the file is in 3 trusted repos, and so `git annex+drop --auto` should drop it again!++How to fix? Can it even be fixed? Maybe care has to be taken when+writing expressions, to avoid this problem. One that avoids it:+`not (copies=trusted:2 or (in=here and trusted=here and copies=trusted:3))`++Or, expressions could be automatically rewritten to avoid the problem.++Or, perhaps simulation could be used to detect the problem. Before+dropping, check the expression. Then simulate that the drop has happened.+Does the expression now make it want to add it? Then don't drop it!+How to implement this simulation?++> Solved, fwiw..
doc/design/assistant/webapp.mdwn view
@@ -23,6 +23,9 @@  * there could be a UI to export a file, which would make it be served up   over http by the web app+* there could be a UI (some javascript thing) in the web browser to+  submit urls to the web app to be added to the annex and downloaded.+  See: [[todo/wishlist:_an_"assistant"_for_web-browsing_--_tracking_the_sources_of_the_downloads]] * Display the `inotify max_user_watches` exceeded message. **done** * Display something sane when kqueue runs out of file descriptors. * allow renaming git remotes and/or setting git-annex repo descriptions
+ doc/forum/Using_Linux_static_builds.mdwn view
@@ -0,0 +1,25 @@+Hello,++I want to use git-annex on a couple of machines that are not under my control (and one that is). For that I use the provided static build, but encountered several problems:++I suppose the first step for command line use is to execute runshell:++On one machine:++flindner@yoko:~> software/git-annex.linux/runshell +/bin/bash: /lib64/libc.so.6: version `GLIBC_2.11' not found (required by /home/flindner/software/git-annex.linux//lib/x86_64-linux-gnu/libreadline.so.6)++Is there anything I can do about it?++On the other machine:++flindner@bladefoam2:~$ software/git-annex.linux/runshell +bash-4.1$ ++It starts a bare, non-configured shell instance. Can I modifiy and source the script to only set the environment and not start up a new shell?++Another question: If using ssh:// remotes, how can I tell git-annex the first command to set up the environment need in order to execute command via SSH?++Thanks,++Florian
+ doc/forum/special_remote_for_iPods.mdwn view
@@ -0,0 +1,5 @@+I know versions of this question have been asked before, but I'm looking for a different answer.++I would like a braindead special remote that can be used with devices such as portable music players. No symbolic links, no hashing, no rewriting of the filenames. The remote can be untrusted, file identity can be checked with just the filename and maybe the size. The "directory" special remote with the WORM backend seems to come closest, but does too much. ++Should I just try to roll it using hooks?
doc/git-annex.mdwn view
@@ -248,6 +248,21 @@   Indicates that the repository has been irretrevably lost.   (To undo, use semitrust.) +* group repository groupname++  Adds a repository to a group, such as "archival", "enduser", or "transfer".+  The groupname must be a single word.++* ungroup repository groupname++  Removes a repository from a group.++* vicfg++  Opens EDITOR on a temp file containing most of the above configuration+  settings, and when it exits, stores any changes made back to the git-annex+  branch.+ # REPOSITORY MAINTENANCE COMMANDS  * fsck [path ...]@@ -487,7 +502,8 @@ * --auto    Enables automatic mode. Commands that get, drop, or move file contents-  will only do so when needed to help satisfy the setting of annex.numcopies.+  will only do so when needed to help satisfy the setting of annex.numcopies,+  and preferred content configuration.  * --quiet @@ -616,15 +632,35 @@   copies, on remotes with the specified trust level. For example,   "--copies=trusted:2" +* --copies=groupname:number++  Matches only files that git-annex believes have the specified number of+  copies, on remotes in the specified group. For example,+  "--copies=archival:2"+ * --inbackend=name    Matches only files whose content is stored using the specified key-value   backend. +* --ingroup=groupname++  Matches only files that git-annex believes are present in all repositories+  in the specified group.++* --smallerthan=size+* --largerthan=size++  Matches only files whose content is smaller than, or larger than the+  specified size.+ +  The size can be specified with any commonly used units, for example,+  "0.5 gb" or "100 KiloBytes"+ * --not    Inverts the next file matching option. For example, to only act on-  mp3s, use: --not --exclude='*.mp3'+  files with less than 3 copies, use --not --copies=3  * --and
+ doc/install/OSX/comment_2_7683740a98182de06cb329792e0c0a25._comment view
@@ -0,0 +1,25 @@+[[!comment format=mdwn+ username="https://www.google.com/accounts/o8/id?id=AItOawmYiJgOvC4IDYkr2KIjMlfVD9r_1Sij_jY"+ nickname="Douglas"+ subject="setup: standalone/macos/git-annex.app/Contents/Info.plist: does not exist"+ date="2012-10-06T14:46:55Z"+ content="""+I tried installing with cabal and homebrew on Mountain Lion. After cabal install git-annex I get:++    Linking dist/build/git-annex/git-annex ...+    Installing executable(s) in /Users/dfc/.cabal/bin+    setup: standalone/macos/git-annex.app/Contents/Info.plist: does not exist+    cabal: Error: some packages failed to install:+    git-annex-3.20121001 failed during the final install step. The exception was:+    ExitFailure 1+++There is no directory named macos inside of standalone:++    jumbo:git-annex-3.20121001 dfc$ ls -l standalone/+    total 112+    -rw-r--r--+ 1 dfc  staff  55614 Oct  6 10:40 licences.gz+    drwxr-xr-x+ 6 dfc  staff    204 Oct  6 10:40 linux+    drwxr-xr-x+ 3 dfc  staff    102 Oct  6 10:40 osx++"""]]
+ doc/install/OSX/comment_3_b090f40fe5a32e00b472a5ab2b850b4a._comment view
@@ -0,0 +1,8 @@+[[!comment format=mdwn+ username="http://joeyh.name/"+ ip="4.154.0.149"+ subject="comment 3"+ date="2012-10-06T21:05:45Z"+ content="""+@Douglas, I've fixed that in git. FWIW, the program is installed before that point. Actually, I am leaning toward not having cabal install that plist file at all.+"""]]
doc/internals.mdwn view
@@ -67,6 +67,25 @@  Repositories not listed are semi-trusted. +## `group.log`++Used to group repositories together.++The file format is one line per repository, with the uuid followed by a space,+and then a space-separated list of groups this repository is part of,+and finally a timestamp.++## `preferred-content.log`++Used to indicate which repositories prefer to contain which file contents.++The file format is one line per repository, with the uuid followed by a space,+then a boolean expression, and finally a timestamp.++Files matching the expression are preferred to be retained in the+repository, while files not matching it are preferred to be stored+somewhere else.+ ## `aaa/bbb/*.log`  These log files record [[location_tracking]] information
− doc/news/version_3.20120721.mdwn 
@@ -1,14 +0,0 @@-git-annex 3.20120721 released with [[!toggle text="these changes"]]-[[!toggleable text="""-   * get, move, copy: Now refuse to do anything when the requested file-     transfer is already in progress by another process.-   * status: Lists transfers that are currently in progress.-   * Fix passing --uuid to git-annex-shell.-   * When shaNsum commands cannot be found, use the Haskell SHA library-     (already a dependency) to do the checksumming. This may be slower,-     but avoids portability problems.-   * Use SHA library for files less than 50 kb in size, at which point it's-     faster than forking the more optimised external program.-   * SHAnE backends are now smarter about composite extensions, such as-     .tar.gz Closes: #[680450](http://bugs.debian.org/680450)-   * map: Write map.dot to .git/annex, which avoids watch trying to annex it."""]]
+ doc/news/version_3.20121009.mdwn view
@@ -0,0 +1,25 @@+git-annex 3.20121009 released with [[!toggle text="these changes"]]+[[!toggleable text="""+   * watch, assistant: It's now safe to git annex unlock files while+     the watcher is running, as well as modify files checked into git+     as normal files. Additionally, .gitignore settings are now honored.+     Closes: #[689979](http://bugs.debian.org/689979)+   * group, ungroup: New commands to indicate groups of repositories.+   * webapp: Adds newly created repositories to one of these groups:+     clients, drives, servers+   * vicfg: New command, allows editing (or simply viewing) most+     of the repository configuration settings stored in the git-annex branch.+   * Added preferred content expressions, configurable using vicfg.+   * get --auto: If the local repository has preferred content+     configured, only get that content.+   * drop --auto: If the repository the content is dropped from has+     preferred content configured, drop only content that is not preferred.+   * copy --auto: Only transfer content that the destination repository prefers.+   * assistant: Now honors preferred content settings when deciding what to+     transfer.+   * --copies=group:number can now be used to match files that are present+     in a specified number of repositories in a group.+   * Added --smallerthan, --largerthan, and --inall limits.+   * Only build-depend on libghc-clientsession-dev on arches that will have+     the webapp.+   * uninit: Unset annex.version. Closes: #[689852](http://bugs.debian.org/689852)"""]]
+ doc/preferred_content.mdwn view
@@ -0,0 +1,37 @@+git-annex tries to ensure that the configured number of [[copies]] of your+data always exist, and leaves it up to you to use commands like `git annex+get` and `git annex drop` to move the content to the repositories you want+to contain it. But sometimes, it can be good to have more fine-grained+control over which repositories prefer to have which content. Configuring+this allows `git annex get --auto`, `git annex drop --auto`, etc to do+smarter things.++Currently, preferred content settings can only be edited using `git+annex vicfg`. Each repository can have its own settings, and other+repositories may also try to honor those settings. So there's no local+`.git/config` setting it.++The idea is that you write an expression that files are matched against.+If a file matches, it's preferred to have its content stored in the+repository. If it doesn't, it's preferred to drop its content from+the repository (if there are enough copies elsewhere).++The expressions are very similar to the file matching options documented+on the [[git-annex]] man page. At the command line, you can use those+options in commands like this:++	git annex get --include='*.mp3' --and -'(' --not --in=archive -')'++The equivilant preferred content expression looks like this:++	include=*.mp3 and (not in=archive)++So, just remove the dashes, basically.++Note that while --include and --exclude match files relative to the current+directory, preferred content expressions always match files relative to the+top of the git repository. Perhaps you put files into `out/` directories+when you're done with them. Then you could configure your laptop to prefer+to not retain those files, like this:++	exclude=*/out/*
doc/walkthrough/automatically_managing_content.mdwn view
@@ -38,3 +38,8 @@  The --auto option can also be used with the copy command, again this lets git-annex decide whether to actually copy content.++The above shows how to use --auto to manage content based on the number+of copies. It's also possible to configure, on a per-repository basis,+which content is desired. Then --auto also takes that into account+see [[preferred_content]] for details.
git-annex.1 view
@@ -223,6 +223,18 @@ Indicates that the repository has been irretrevably lost. (To undo, use semitrust.) .IP+.IP "group repository groupname"+Adds a repository to a group, such as "archival", "enduser", or "transfer".+The groupname must be a single word.+.IP+.IP "ungroup repository groupname"+Removes a repository from a group.+.IP+.IP "vicfg"+Opens EDITOR on a temp file containing most of the above configuration+settings, and when it exits, stores any changes made back to the git\-annex+branch.+.IP .SH REPOSITORY MAINTENANCE COMMANDS .IP "fsck [path ...]" .IP@@ -437,7 +449,8 @@ .IP .IP "\-\-auto" Enables automatic mode. Commands that get, drop, or move file contents-will only do so when needed to help satisfy the setting of annex.numcopies.+will only do so when needed to help satisfy the setting of annex.numcopies,+and preferred content configuration. .IP .IP "\-\-quiet" Avoid the default verbose display of what is done; only show errors@@ -548,13 +561,30 @@ copies, on remotes with the specified trust level. For example, "\-\-copies=trusted:2" .IP+.IP "\-\-copies=groupname:number"+Matches only files that git\-annex believes have the specified number of+copies, on remotes in the specified group. For example,+"\-\-copies=archival:2"+.IP .IP "\-\-inbackend=name" Matches only files whose content is stored using the specified key\-value backend. .IP+.IP "\-\-ingroup=groupname"+Matches only files that git\-annex believes are present in all repositories+in the specified group.+.IP+.IP "\-\-smallerthan=size"+.IP "\-\-largerthan=size"+Matches only files whose content is smaller than, or larger than the+specified size.+.IP+The size can be specified with any commonly used units, for example,+"0.5 gb" or "100 KiloBytes"+.IP .IP "\-\-not" Inverts the next file matching option. For example, to only act on-mp3s, use: \-\-not \-\-exclude='*.mp3'+files with less than 3 copies, use \-\-not \-\-copies=3 .IP .IP "\-\-and" Requires that both the previous and the next file matching option matches.
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 3.20121001+Version: 3.20121009 Cabal-Version: >= 1.8 License: GPL Maintainer: Joey Hess <joey@kitenet.net>
+ templates/configurators/editrepository.hamlet view
@@ -0,0 +1,13 @@+<div .span9 .hero-unit>+  <h2>+    Configuring #{description}+  <p>+    <form .form-horizontal enctype=#{enctype}>+      <fieldset>+        ^{form}+        ^{authtoken}+        <div .form-actions>+          <button .btn .btn-primary type=submit>+            Save Changes+          <a .btn href="@{RepositoriesR}">+            Cancel
templates/configurators/repositories.hamlet view
@@ -3,21 +3,24 @@     Your repositories   <table .table .table-condensed>     <tbody>-      $forall (num, name, needsenabled) <- repolist+      $forall (num, name, setuprepo) <- repolist         <tr>           <td>             #{num}           <td>-            $if isJust needsenabled+            $if needsEnabled setuprepo               <i>#{name}             $else               #{name}           <td>-            $maybe enable <- needsenabled+            $if needsEnabled setuprepo               <i>not enabled here #               &rarr; #-              <a href="@{enable}">+              <a href="@{setupRepoLink setuprepo}">                 enable+            $else+              <a href="@{setupRepoLink setuprepo}">+                configure   <div .row-fluid>     <div .span6>       <h2>