packages feed

git-annex 3.20120615 → 3.20120624

raw patch · 107 files changed

+2798/−356 lines, 107 filesdep +hinotifydep +stmbinary-added

Dependencies added: hinotify, stm

Files

.gitignore view
@@ -11,7 +11,7 @@ *.tix .hpc Utility/Touch.hs-Utility/libdiskfree.o+Utility/*.o dist # Sandboxed builds cabal-dev
− .make-sdist.sh.swo

binary file changed (12288 → absent bytes)

− .make-sdist.sh.swp

binary file changed (4096 → absent bytes)

Annex.hs view
@@ -14,6 +14,7 @@ 	newState, 	run, 	eval,+	exec, 	getState, 	changeState, 	setFlag,@@ -134,6 +135,8 @@ run s a = runStateT (runAnnex a) s eval :: AnnexState -> Annex a -> IO a eval s a = evalStateT (runAnnex a) s+exec :: AnnexState -> Annex a -> IO AnnexState+exec s a = execStateT (runAnnex a) s  {- Sets a flag to True -} setFlag :: String -> Annex ()
Annex/Branch.hs view
@@ -35,6 +35,8 @@ import qualified Git.UnionMerge import qualified Git.UpdateIndex import Git.HashObject+import Git.Types+import Git.FilePath import qualified Git.Index import Annex.CatFile import Annex.Perms@@ -66,7 +68,7 @@  {- Creates the branch, if it does not already exist. -} create :: Annex ()-create = void $ getBranch+create = void getBranch  {- Returns the ref of the branch, creating it first if necessary. -} getBranch :: Annex Git.Ref@@ -259,15 +261,15 @@  - in changes from other branches.  -} genIndex :: Git.Repo -> IO ()-genIndex g = Git.UpdateIndex.stream_update_index g-	[Git.UpdateIndex.ls_tree fullname g]+genIndex g = Git.UpdateIndex.streamUpdateIndex g+	[Git.UpdateIndex.lsTree fullname g]  {- Merges the specified refs into the index.  - Any changes staged in the index will be preserved. -} mergeIndex :: [Git.Ref] -> Annex () mergeIndex branches = do 	h <- catFileHandle-	inRepo $ \g -> Git.UnionMerge.merge_index h g branches+	inRepo $ \g -> Git.UnionMerge.mergeIndex h g branches  {- Runs an action using the branch's index file. -} withIndex :: Annex a -> Annex a@@ -336,13 +338,13 @@ 	g <- gitRepo 	withIndex $ liftIO $ do 		h <- hashObjectStart g-		Git.UpdateIndex.stream_update_index g+		Git.UpdateIndex.streamUpdateIndex g 			[genstream (gitAnnexJournalDir g) h fs] 		hashObjectStop h 	where 		genstream dir h fs streamer = forM_ fs $ \file -> do 			let path = dir </> file 			sha <- hashFile h path-			_ <- streamer $ Git.UpdateIndex.update_index_line-				sha (fileJournal file)+			_ <- streamer $ Git.UpdateIndex.updateIndexLine+				sha FileBlob (asTopFilePath $ fileJournal file) 			removeFile path
Annex/CatFile.hs view
@@ -8,15 +8,17 @@ module Annex.CatFile ( 	catFile, 	catObject,+	catObjectDetails, 	catFileHandle ) where -import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Lazy as L  import Common.Annex import qualified Git import qualified Git.CatFile import qualified Annex+import Git.Types  catFile :: Git.Branch -> FilePath -> Annex L.ByteString catFile branch file = do@@ -27,6 +29,11 @@ catObject ref = do 	h <- catFileHandle 	liftIO $ Git.CatFile.catObject h ref++catObjectDetails :: Git.Ref -> Annex (Maybe (L.ByteString, Sha))+catObjectDetails ref = do+	h <- catFileHandle+	liftIO $ Git.CatFile.catObjectDetails h ref  catFileHandle :: Annex Git.CatFile.CatFileHandle catFileHandle = maybe startup return =<< Annex.getState Annex.catfilehandle
Annex/Content.hs view
@@ -87,7 +87,7 @@ 		 - to fiddle with permissions to open for an exclusive lock. -} 		openforlock f = catchMaybeIO $ ifM (doesFileExist f) 			( withModifiedFileMode f-				(\cur -> cur `unionFileModes` ownerWriteMode)+				(`unionFileModes` ownerWriteMode) 				open 			, open 			)@@ -168,7 +168,7 @@ withTmp key action = do 	tmp <- prepTmp key 	res <- action tmp-	liftIO $ whenM (doesFileExist tmp) $ liftIO $ removeFile tmp+	liftIO $ nukeFile tmp 	return res  {- Checks that there is disk space available to store a given key,@@ -242,7 +242,7 @@ 		removeparents file n = do 			let dir = parentDir file 			maybe noop (const $ removeparents dir (n-1))-				=<< catchMaybeIO (removeDirectory dir)+				<=< catchMaybeIO $ removeDirectory dir  {- Removes a key's file from .git/annex/objects/ -} removeAnnex :: Key -> Annex ()
Annex/Queue.hs view
@@ -1,27 +1,36 @@ {- git-annex command queue  -- - Copyright 2011 Joey Hess <joey@kitenet.net>+ - Copyright 2011, 2012 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -}  module Annex.Queue (-	add,+	addCommand,+	addUpdateIndex, 	flush,-	flushWhenFull+	flushWhenFull,+	size ) where  import Common.Annex import Annex hiding (new) import qualified Git.Queue+import qualified Git.UpdateIndex import Config  {- Adds a git command to the queue. -}-add :: String -> [CommandParam] -> [FilePath] -> Annex ()-add command params files = do+addCommand :: String -> [CommandParam] -> [FilePath] -> Annex ()+addCommand command params files = do 	q <- get-	store $ Git.Queue.add q command params files+	store <=< inRepo $ Git.Queue.addCommand command params files q +{- Adds an update-index stream to the queue. -}+addUpdateIndex :: Git.UpdateIndex.Streamer -> Annex ()+addUpdateIndex streamer = do+	q <- get+	store <=< inRepo $ Git.Queue.addUpdateIndex streamer q+ {- Runs the queue if it is full. Should be called periodically. -} flushWhenFull :: Annex () flushWhenFull = do@@ -36,6 +45,10 @@ 		showStoringStateAction 		q' <- inRepo $ Git.Queue.flush q 		store q'++{- Gets the size of the queue. -}+size :: Annex Int+size = Git.Queue.size <$> get  get :: Annex Git.Queue.Queue get = maybe new return =<< getState repoqueue
+ Assistant.hs view
@@ -0,0 +1,85 @@+{- git-annex assistant daemon+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -+ - Overview of threads and MVars, etc:+ -+ - Thread 1: parent+ - 	The initial thread run, double forks to background, starts other+ - 	threads, and then stops, waiting for them to terminate,+ - 	or for a ctrl-c.+ - Thread 2: watcher+ - 	Notices new files, and calls handlers for events, queuing changes.+ - Thread 3: inotify internal+ - 	Used by haskell inotify library to ensure inotify event buffer is+ - 	kept drained.+ - Thread 4: inotify startup scanner+ - 	Scans the tree and registers inotify watches for each directory.+ -	A MVar lock is used to prevent other inotify handlers from running+ -	until this is complete.+ - Thread 5: committer+ - 	Waits for changes to occur, and runs the git queue to update its+ - 	index, then commits.+ - Thread 6: status logger+ - 	Wakes up periodically and records the daemon's status to disk.+ - Thread 7: sanity checker+ - 	Wakes up periodically (rarely) and does sanity checks.+ -+ - ThreadState: (MVar)+ - 	The Annex state is stored here, which allows resuscitating the+ - 	Annex monad in IO actions run by the inotify and committer+ - 	threads. Thus, a single state is shared amoung the threads, and+ - 	only one at a time can access it.+ - DaemonStatusHandle: (MVar)+ - 	The daemon's current status. This MVar should only be manipulated+ - 	from inside the Annex monad, which ensures it's accessed only+ - 	after the ThreadState MVar.+ - ChangeChan: (STM TChan)+ - 	Changes are indicated by writing to this channel. The committer+ - 	reads from it.+ -}++module Assistant where++import Common.Annex+import Assistant.ThreadedMonad+import Assistant.DaemonStatus+import Assistant.Changes+import Assistant.Watcher+import Assistant.Committer+import Assistant.SanityChecker+import qualified Utility.Daemon+import Utility.LogFile++import Control.Concurrent++startDaemon :: Bool -> Annex ()+startDaemon foreground+	| foreground = do+		showStart "watch" "."+		go id+	| otherwise = do+		logfd <- liftIO . openLog =<< fromRepo gitAnnexLogFile+		pidfile <- fromRepo gitAnnexPidFile+		go $ Utility.Daemon.daemonize logfd (Just pidfile) False+	where+		go a = withThreadState $ \st -> do+			checkCanWatch+			dstatus <- startDaemonStatus+			liftIO $ a $ do+				changechan <- newChangeChan+				-- The commit thread is started early,+				-- so that the user can immediately+				-- begin adding files and having them+				-- committed, even while the startup scan+				-- is taking place.+				_ <- forkIO $ commitThread st changechan+				_ <- forkIO $ daemonStatusThread st dstatus+				_ <- forkIO $ sanityCheckerThread st dstatus changechan+				-- Does not return.+				watchThread st dstatus changechan++stopDaemon :: Annex ()+stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile
+ Assistant/Changes.hs view
@@ -0,0 +1,81 @@+{- git-annex assistant change tracking+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -}++module Assistant.Changes where++import Common.Annex+import qualified Annex.Queue+import Types.KeySource++import Control.Concurrent.STM+import Data.Time.Clock++data ChangeType = AddChange | LinkChange | RmChange | RmDirChange+	deriving (Show, Eq)++type ChangeChan = TChan Change++data Change+	= Change +		{ changeTime :: UTCTime+		, changeFile :: FilePath+		, changeType :: ChangeType+		}+	| PendingAddChange+		{ changeTime ::UTCTime+		, keySource :: KeySource+		}+	deriving (Show)++runChangeChan :: STM a -> IO a+runChangeChan = atomically++newChangeChan :: IO ChangeChan+newChangeChan = atomically newTChan++{- Handlers call this when they made a change that needs to get committed. -}+madeChange :: FilePath -> ChangeType -> Annex (Maybe Change)+madeChange f t = do+	-- Just in case the commit thread is not flushing the queue fast enough.+	Annex.Queue.flushWhenFull+	liftIO $ Just <$> (Change <$> getCurrentTime <*> pure f <*> pure t)++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)++isPendingAddChange :: Change -> Bool+isPendingAddChange (PendingAddChange {}) = True+isPendingAddChange _ = False++finishedChange :: Change -> Change+finishedChange c@(PendingAddChange { keySource = ks }) = Change+	{ changeTime = changeTime c+	, changeFile = keyFilename ks+	, changeType = AddChange+	}+finishedChange c = c++{- Gets all unhandled changes.+ - Blocks until at least one change is made. -}+getChanges :: ChangeChan -> IO [Change]+getChanges chan = runChangeChan $ do+	c <- readTChan chan+	go [c]+	where+		go l = do+			v <- tryReadTChan chan+			case v of+				Nothing -> return l+				Just c -> go (c:l)++{- Puts unhandled changes back into the channel.+ - Note: Original order is not preserved. -}+refillChanges :: ChangeChan -> [Change] -> IO ()+refillChanges chan cs = runChangeChan $ mapM_ (writeTChan chan) cs
+ Assistant/Committer.hs view
@@ -0,0 +1,195 @@+{- git-annex assistant commit thread+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -}++module Assistant.Committer where++import Common.Annex+import Assistant.Changes+import Assistant.ThreadedMonad+import Assistant.Watcher+import qualified Annex+import qualified Annex.Queue+import qualified Git.Command+import qualified Git.HashObject+import Git.Types+import qualified Command.Add+import Utility.ThreadScheduler+import qualified Utility.Lsof as Lsof+import qualified Utility.DirWatcher as DirWatcher+import Types.KeySource++import Data.Time.Clock+import Data.Tuple.Utils+import qualified Data.Set as S+import Data.Either++{- This thread makes git commits at appropriate times. -}+commitThread :: ThreadState -> ChangeChan -> IO ()+commitThread st changechan = 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 changes+			if shouldCommit time readychanges+				then do+					void $ tryIO $ runThreadState st commitStaged+				else refillChanges changechan readychanges+		else refillChanges changechan changes++commitStaged :: Annex ()+commitStaged = do+	Annex.Queue.flush+	inRepo $ Git.Command.run "commit"+		[ Param "--allow-empty-message"+		, Param "-m", Param ""+		-- Empty commits may be made if tree changes cancel+		-- each other out, etc+		, Param "--allow-empty"+		-- 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 "--quiet"+		]++{- Decide if now is a good time to make a commit.+ - Note that the list of change times has an undefined order.+ -+ - Current strategy: If there have been 10 changes within the past second,+ - a batch activity is taking place, so wait for later.+ -}+shouldCommit :: UTCTime -> [Change] -> Bool+shouldCommit now changes+	| len == 0 = False+	| len > 10000 = True -- avoid bloating queue too much+	| length (filter thisSecond changes) < 10 = True+	| otherwise = False -- batch activity+	where+		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.+ -+ - 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.+ -+ - 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+ - staged before returning, and will be committed immediately.+ -+ - OTOH, for kqueue, eventsCoalesce, so instead the symlink is directly+ - created and staged.+ -+ - Returns a list of all changes that are ready to be committed.+ - Any pending adds that are not ready yet are put back into the ChangeChan,+ - where they will be retried later.+ -}+handleAdds :: ThreadState -> ChangeChan -> [Change] -> IO [Change]+handleAdds st changechan cs = returnWhen (null pendingadds) $ do+	(postponed, toadd) <- partitionEithers <$>+		safeToAdd st pendingadds++	unless (null postponed) $+		refillChanges changechan postponed++	returnWhen (null toadd) $ do+		added <- catMaybes <$> forM toadd add+		if (DirWatcher.eventsCoalesce || null added)+			then return $ added ++ otherchanges+			else do+				r <- handleAdds st changechan+					=<< getChanges changechan+				return $ r ++ added ++ otherchanges+	where+		(pendingadds, otherchanges) = partition isPendingAddChange cs++		returnWhen c a+			| c = return otherchanges+			| otherwise = a++		add :: Change -> IO (Maybe Change)+		add change@(PendingAddChange { keySource = ks }) = do+			r <- catchMaybeIO $ sanitycheck ks $ runThreadState st $ do+				showStart "add" $ keyFilename ks+				handle (finishedChange change) (keyFilename ks)+					=<< Command.Add.ingest ks+			return $ maybeMaybe r+		add _ = return Nothing++		maybeMaybe (Just j@(Just _)) = j+		maybeMaybe _ = Nothing++		handle _ _ Nothing = do+			showEndFail+			return Nothing+		handle change file (Just key) = do+			link <- Command.Add.link file key True+			when DirWatcher.eventsCoalesce $ do+				sha <- inRepo $+					Git.HashObject.hashObject BlobObject link+				stageSymlink file sha+			showEndOk+			return $ Just change++		{- Check that the keysource's keyFilename still exists,+		 - and is still a hard link to its contentLocation,+		 - before ingesting it. -}+		sanitycheck keysource a = do+			fs <- getSymbolicLinkStatus $ keyFilename keysource+			ks <- getSymbolicLinkStatus $ contentLocation keysource+			if deviceID ks == deviceID fs && fileID ks == fileID fs+				then a+				else return Nothing++{- PendingAddChanges 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++			{- 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 })+			| S.member (contentLocation ks) openfiles = Left change+		check _ change = Right change++		canceladd (PendingAddChange { keySource = ks }) = do+			warning $ keyFilename ks+				++ " still has writers, not adding"+			-- remove the hard link+			void $ liftIO $ tryIO $+				removeFile $ contentLocation ks+		canceladd _ = noop++		openwrite (_file, mode, _pid) =+			mode == Lsof.OpenWriteOnly || mode == Lsof.OpenReadWrite++		allRight = return . map Right
+ Assistant/DaemonStatus.hs view
@@ -0,0 +1,119 @@+{- git-annex assistant daemon status+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -}++module Assistant.DaemonStatus where++import Common.Annex+import Assistant.ThreadedMonad+import Utility.ThreadScheduler+import Utility.TempFile++import Control.Concurrent+import System.Posix.Types+import Data.Time.Clock.POSIX+import Data.Time+import System.Locale++data DaemonStatus = DaemonStatus+	-- False when the daemon is performing its startup scan+	{ scanComplete :: Bool+	-- Time when a previous process of the daemon was running ok+	, lastRunning :: Maybe POSIXTime+	-- True when the sanity checker is running+	, sanityCheckRunning :: Bool+	-- Last time the sanity checker ran+	, lastSanityCheck :: Maybe POSIXTime+	}+	deriving (Show)++type DaemonStatusHandle = MVar DaemonStatus++newDaemonStatus :: DaemonStatus+newDaemonStatus = DaemonStatus+	{ scanComplete = False+	, lastRunning = Nothing+	, sanityCheckRunning = False+	, lastSanityCheck = Nothing+	}++getDaemonStatus :: DaemonStatusHandle -> Annex DaemonStatus+getDaemonStatus = liftIO . readMVar++modifyDaemonStatus :: DaemonStatusHandle -> (DaemonStatus -> DaemonStatus) -> Annex ()+modifyDaemonStatus handle a = liftIO $ modifyMVar_ handle (return . a)++{- Load any previous daemon status file, and store it in the MVar for this+ - process to use as its DaemonStatus. -}+startDaemonStatus :: Annex DaemonStatusHandle+startDaemonStatus = do+	file <- fromRepo gitAnnexDaemonStatusFile+	status <- liftIO $+		catchDefaultIO (readDaemonStatusFile file) newDaemonStatus+	liftIO $ newMVar status+		{ scanComplete = False+		, sanityCheckRunning = False+		}++{- This thread wakes up periodically and writes the daemon status to disk. -}+daemonStatusThread :: ThreadState -> DaemonStatusHandle -> IO ()+daemonStatusThread st handle = do+	checkpoint+	runEvery (Seconds tenMinutes) checkpoint+	where+		checkpoint = runThreadState st $ do+			file <- fromRepo gitAnnexDaemonStatusFile+			status <- getDaemonStatus handle+			liftIO $ writeDaemonStatusFile file status++{- Don't just dump out the structure, because it will change over time,+ - and parts of it are not relevant. -}+writeDaemonStatusFile :: FilePath -> DaemonStatus -> IO ()+writeDaemonStatusFile file status = +	viaTmp writeFile file =<< serialized <$> getPOSIXTime+	where+		serialized now = unlines+			[ "lastRunning:" ++ show now+			, "scanComplete:" ++ show (scanComplete status)+			, "sanityCheckRunning:" ++ show (sanityCheckRunning status)+			, "lastSanityCheck:" ++ maybe "" show (lastSanityCheck status)+			]++readDaemonStatusFile :: FilePath -> IO DaemonStatus+readDaemonStatusFile file = parse <$> readFile file+	where+		parse = foldr parseline newDaemonStatus . lines+		parseline line status+			| key == "lastRunning" = parseval readtime $ \v ->+				status { lastRunning = Just v }+			| key == "scanComplete" = parseval readish $ \v ->+				status { scanComplete = v }+			| key == "sanityCheckRunning" = parseval readish $ \v ->+				status { sanityCheckRunning = v }+			| key == "lastSanityCheck" = parseval readtime $ \v ->+				status { lastSanityCheck = Just v }+			| otherwise = status -- unparsable line+			where+				(key, value) = separate (== ':') line+				parseval parser a = maybe status a (parser value)+				readtime s = do+					d <- parseTime defaultTimeLocale "%s%Qs" s+					Just $ utcTimeToPOSIXSeconds d++{- Checks if a time stamp was made after the daemon was lastRunning.+ -+ - Some slop is built in; this really checks if the time stamp was made+ - at least ten minutes after the daemon was lastRunning. This is to+ - ensure the daemon shut down cleanly, and deal with minor clock skew.+ -+ - If the daemon has never ran before, this always returns False.+ -}+afterLastDaemonRun :: EpochTime -> DaemonStatus -> Bool+afterLastDaemonRun timestamp status = maybe False (< t) (lastRunning status)+	where+		t = realToFrac (timestamp + slop) :: POSIXTime+		slop = fromIntegral tenMinutes++tenMinutes :: Int+tenMinutes = 10 * 60
+ Assistant/SanityChecker.hs view
@@ -0,0 +1,81 @@+{- git-annex assistant sanity checker+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -}++module Assistant.SanityChecker (+	sanityCheckerThread+) where++import Common.Annex+import qualified Git.LsFiles+import Assistant.DaemonStatus+import Assistant.ThreadedMonad+import Assistant.Changes+import Utility.ThreadScheduler+import qualified Assistant.Watcher++import Data.Time.Clock.POSIX++{- This thread wakes up occasionally to make sure the tree is in good shape. -}+sanityCheckerThread :: ThreadState -> DaemonStatusHandle -> ChangeChan -> IO ()+sanityCheckerThread st status changechan = forever $ do+	waitForNextCheck st status++	runThreadState st $+		modifyDaemonStatus status $ \s -> s+				{ sanityCheckRunning = True }++	now <- getPOSIXTime -- before check started+	catchIO (check st status changechan)+		(runThreadState st . warning . show)++	runThreadState st $ do+		modifyDaemonStatus status $ \s -> s+			{ sanityCheckRunning = False+			, lastSanityCheck = Just now+			}++{- Only run one check per day, from the time of the last check. -}+waitForNextCheck :: ThreadState -> DaemonStatusHandle -> IO ()+waitForNextCheck st status = do+	v <- runThreadState st $+		lastSanityCheck <$> getDaemonStatus status+	now <- getPOSIXTime+	threadDelaySeconds $ Seconds $ calcdelay now v+	where+		calcdelay _ Nothing = oneDay+		calcdelay now (Just lastcheck)+			| lastcheck < now = max oneDay $+				oneDay - truncate (now - lastcheck)+			| otherwise = oneDay++oneDay :: Int+oneDay = 24 * 60 * 60++{- It's important to stay out of the Annex monad as much as possible while+ - running potentially expensive parts of this check, since remaining in it+ - will block the watcher. -}+check :: ThreadState -> DaemonStatusHandle -> ChangeChan -> IO () +check st status changechan = do+	g <- runThreadState st $ do+		showSideAction "Running daily check"+		fromRepo id+	-- Find old unstaged symlinks, and add them to git.+	unstaged <- Git.LsFiles.notInRepo False ["."] g+	now <- getPOSIXTime+	forM_ unstaged $ \file -> do+		ms <- catchMaybeIO $ getSymbolicLinkStatus file+		case ms of+			Just s	| toonew (statusChangeTime s) now -> noop+				| isSymbolicLink s ->+					addsymlink file ms+			_ -> noop+	where+		toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime)+		slop = fromIntegral tenMinutes+		insanity m = runThreadState st $ warning m+		addsymlink file s = do+			insanity $ "found unstaged symlink: " ++ file+			Assistant.Watcher.runHandler st status changechan+				Assistant.Watcher.onAddSymlink file s
+ Assistant/ThreadedMonad.hs view
@@ -0,0 +1,44 @@+{- making the Annex monad available across threads+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -}++{-# LANGUAGE BangPatterns #-}++module Assistant.ThreadedMonad where++import Common.Annex+import qualified Annex++import Control.Concurrent+import Control.Exception (throw)++{- The Annex state is stored in a MVar, so that threaded actions can access+ - it. -}+type ThreadState = MVar Annex.AnnexState++{- Stores the Annex state in a MVar.+ -+ - Once the action is finished, retrieves the state from the MVar.+ -}+withThreadState :: (ThreadState -> Annex a) -> Annex a+withThreadState a = do+	state <- Annex.getState id+	mvar <- liftIO $ newMVar state+	r <- a mvar+	newstate <- liftIO $ takeMVar mvar+	Annex.changeState (const newstate)+	return r++{- Runs an Annex action, using the state from the MVar. + -+ - This serializes calls by threads. -}+runThreadState :: ThreadState -> Annex a -> IO a+runThreadState mvar a = do+	startstate <- takeMVar mvar+	-- catch IO errors and rethrow after restoring the MVar+	!(r, newstate) <- catchIO (Annex.run startstate a) $ \e -> do+		putMVar mvar startstate+		throw e+	putMVar mvar newstate+	return r
+ Assistant/Watcher.hs view
@@ -0,0 +1,220 @@+{- git-annex assistant tree watcher+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Assistant.Watcher where++import Common.Annex+import Assistant.ThreadedMonad+import Assistant.DaemonStatus+import Assistant.Changes+import Utility.DirWatcher+import Utility.Types.DirWatcher+import qualified Annex+import qualified Annex.Queue+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 Control.Concurrent.STM+import Data.Bits.Utils+import qualified Data.ByteString.Lazy as L++checkCanWatch :: Annex ()+checkCanWatch+	| canWatch = +		unlessM (liftIO (inPath "lsof") <||> Annex.getState Annex.force) $+			needLsof+	| otherwise = error "watch mode is not available on this system"++needLsof :: Annex ()+needLsof = error $ unlines+	[ "The lsof command is needed for watch mode to be safe, and is not in PATH."+	, "To override lsof checks to ensure that files are not open for writing"+	, "when added to the annex, you can use --force"+	, "Be warned: This can corrupt data in the annex, and make fsck complain."+	]++watchThread :: ThreadState -> DaemonStatusHandle -> ChangeChan -> IO ()+watchThread st dstatus changechan = watchDir "." ignored hooks startup+	where+		startup = statupScan st dstatus+		hook a = Just $ runHandler st dstatus changechan a+		hooks = WatchHooks+			{ 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. -}+statupScan :: ThreadState -> DaemonStatusHandle -> IO a -> IO a+statupScan st dstatus scanner = do+	runThreadState st $+		showAction "scanning"+	r <- scanner+	runThreadState st $+		modifyDaemonStatus dstatus $ \s -> s { scanComplete = True }++	-- Notice any files that were deleted before watching was started.+	runThreadState st $ do+		inRepo $ Git.Command.run "add" [Param "--update"]+		showAction "started"++	return r++ignored :: FilePath -> Bool+ignored = ig . takeFileName+	where+	ig ".git" = True+	ig ".gitignore" = True+	ig ".gitattributes" = True+	ig _ = False++type Handler = FilePath -> Maybe FileStatus -> DaemonStatusHandle -> 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 :: ThreadState -> DaemonStatusHandle -> ChangeChan -> Handler -> FilePath -> Maybe FileStatus -> IO ()+runHandler st dstatus changechan handler file filestatus = void $ do+	r <- tryIO go+	case r of+		Left e -> print e+		Right Nothing -> noop+		Right (Just change) -> void $+			runChangeChan $ writeTChan changechan change+	where+		go = runThreadState st $ handler file filestatus dstatus++{- 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 file filestatus dstatus+	| maybe False isRegularFile filestatus = do+		ifM (scanComplete <$> getDaemonStatus dstatus)+			( go+			, ifM (null <$> inRepo (Git.LsFiles.notInRepo False [file]))+				( noChange+				, go+				)+			)+	| otherwise = noChange+	where+		go = 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 file filestatus dstatus = go =<< Backend.lookupFile file+	where+		go (Just (key, _)) = do+			link <- calcGitLink file key+			ifM ((==) link <$> liftIO (readSymbolicLink file))+				( ensurestaged link =<< getDaemonStatus dstatus+				, do+					liftIO $ removeFile file+					liftIO $ createSymbolicLink link file+					addlink link+				)+		go Nothing = do -- other symlink+			link <- liftIO (readSymbolicLink file)+			ensurestaged link =<< getDaemonStatus dstatus++		{- This is often called on symlinks that are already+		 - staged correctly. A symlink may have been deleted+		 - and being re-added, or added when the watcher was+		 - not running. So they're normally restaged to make sure.+		 -+		 - As an optimisation, during the status scan, avoid+		 - restaging everything. Only links that were created since+		 - the last time the daemon was running are staged.+		 - (If the daemon has never ran before, avoid staging+		 - links too.)+		 -}+		ensurestaged link daemonstatus+			| scanComplete daemonstatus = addlink link+			| otherwise = case filestatus of+				Just s+					| not (afterLastDaemonRun (statusChangeTime s) daemonstatus) -> noChange+				_ -> addlink link++		{- For speed, tries to reuse the existing blob for+		 - the symlink target. -}+		addlink link = do+			v <- catObjectDetails $ Ref $ ':':file+			case v of+				Just (currlink, sha)+					| s2w8 link == L.unpack currlink ->+						stageSymlink file sha+				_ -> do+					sha <- inRepo $+						Git.HashObject.hashObject BlobObject link+					stageSymlink file sha+			madeChange file LinkChange++onDel :: Handler+onDel file _ _dstatus = do+	Annex.Queue.addUpdateIndex =<<+		inRepo (Git.UpdateIndex.unstageFile file)+	madeChange file RmChange++{- A directory has been deleted, or moved, so tell git to remove anything+ - that was inside it from its cache. Since it could reappear at any time,+ - use --cached to only delete it from the index. + -+ - Note: This could use unstageFile, but would need to run another git+ - command to get the recursive list of files in the directory, so rm is+ - just as good. -}+onDelDir :: Handler+onDelDir dir _ _dstatus = do+	Annex.Queue.addCommand "rm"+		[Params "--quiet -r --cached --ignore-unmatch --"] [dir]+	madeChange dir RmDirChange++{- Called when there's an error with inotify. -}+onErr :: Handler+onErr msg _ _dstatus = do+	warning msg+	return Nothing++{- Adds a symlink to the index, without ever accessing the actual symlink+ - on disk. This avoids a race if git add is used, where the symlink is+ - changed to something else immediately after creation.+ -}+stageSymlink :: FilePath -> Sha -> Annex ()+stageSymlink file sha =+	Annex.Queue.addUpdateIndex =<<+		inRepo (Git.UpdateIndex.stageSymlink file sha)
Backend.hs view
@@ -6,7 +6,6 @@  -}  module Backend (-	B.KeySource(..), 	list, 	orderedList, 	genKey,@@ -23,6 +22,7 @@ import qualified Annex import Annex.CheckAttr import Types.Key+import Types.KeySource import qualified Types.Backend as B  -- When adding a new backend, import it here and add it to the list.@@ -54,12 +54,12 @@ {- Generates a key for a file, trying each backend in turn until one  - accepts it.  -}-genKey :: B.KeySource -> Maybe Backend -> Annex (Maybe (Key, Backend))+genKey :: KeySource -> Maybe Backend -> Annex (Maybe (Key, Backend)) genKey source trybackend = do 	bs <- orderedList 	let bs' = maybe bs (: bs) trybackend 	genKey' bs' source-genKey' :: [Backend] -> B.KeySource -> Annex (Maybe (Key, Backend))+genKey' :: [Backend] -> KeySource -> Annex (Maybe (Key, Backend)) genKey' [] _ = return Nothing genKey' (b:bs) source = do 	r <- B.getKey b source
Backend/SHA.hs view
@@ -11,6 +11,7 @@ import qualified Annex import Types.Backend import Types.Key+import Types.KeySource import qualified Build.SysConfig as SysConfig  type SHASize = Int
Backend/WORM.hs view
@@ -10,6 +10,7 @@ import Common.Annex import Types.Backend import Types.Key+import Types.KeySource  backends :: [Backend] backends = [backend]
Build/Configure.hs view
@@ -26,6 +26,7 @@ 	, TestCase "wget" $ testCmd "wget" "wget --version >/dev/null" 	, TestCase "bup" $ testCmd "bup" "bup --version >/dev/null" 	, TestCase "gpg" $ testCmd "gpg" "gpg --version >/dev/null"+	, TestCase "lsof" $ testCmd "lsof" "lsof -v >/dev/null 2>&1" 	, TestCase "ssh connection caching" getSshConnectionCaching 	] ++ shaTestCases False [1, 512, 224, 384] ++ shaTestCases True [256]
CHANGELOG view
@@ -1,4 +1,16 @@-git-annex (3.20120615) unstable; urgency=medium+git-annex (3.20120624) unstable; urgency=low++  * watch: New subcommand, a daemon which notices changes to+    files and automatically annexes new files, etc, so you don't+    need to manually run git commands when manipulating files.+    Available on Linux, BSDs, and OSX!+  * Enable diskfree on kfreebsd, using kqueue.+  * unused: Fix crash when key names contain invalid utf8.+  * sync: Avoid recent git's interactive merge.++ -- Joey Hess <joeyh@debian.org>  Sun, 24 Jun 2012 12:36:50 -0400++git-annex (3.20120614) unstable; urgency=medium    * addurl: Was broken by a typo introduced 2 released ago, now fixed.     Closes: #677576
Command/Add.hs view
@@ -12,6 +12,7 @@ import Command import qualified Annex import qualified Annex.Queue+import Types.KeySource import Backend import Logs.Location import Annex.Content@@ -50,34 +51,43 @@  - to prevent it from being modified in between. It's hard linked into a  - temporary location, and its writable bits are removed. It could still be  - written to by a process that already has it open for writing. -}-perform :: FilePath -> CommandPerform-perform file = do+lockDown :: FilePath -> Annex KeySource+lockDown file = do 	liftIO $ preventWrite file 	tmp <- fromRepo gitAnnexTmpDir 	createAnnexDirectory tmp-	pid <- liftIO getProcessID-	let tmpfile = tmp </> "add" ++ show pid ++ "." ++ takeFileName file-	nuke tmpfile-	liftIO $ createLink file tmpfile-	let source = KeySource { keyFilename = file, contentLocation = tmpfile }-	backend <- chooseBackend file-	genKey source backend >>= go tmpfile+	liftIO $ do+		(tmpfile, _handle) <- openTempFile tmp (takeFileName file)+		nukeFile tmpfile+		createLink file tmpfile+		return $ KeySource { keyFilename = file , contentLocation = tmpfile }++{- Moves a locked down file into the annex. -}+ingest :: KeySource -> Annex (Maybe Key)+ingest source = do+	backend <- chooseBackend $ keyFilename source+	genKey source backend >>= go 	where-		go _ Nothing = stop-		go tmpfile (Just (key, _)) = do-			handle (undo file key) $ moveAnnex key tmpfile-			nuke file-			next $ cleanup file key True+		go Nothing = do+			liftIO $ nukeFile $ contentLocation source+			return Nothing+		go (Just (key, _)) = do+			handle (undo (keyFilename source) key) $+				moveAnnex key $ contentLocation source+			liftIO $ nukeFile $ keyFilename source+			return $ Just key -nuke :: FilePath -> Annex ()-nuke file = liftIO $ whenM (doesFileExist file) $ removeFile file+perform :: FilePath -> CommandPerform+perform file = +	maybe stop (\key -> next $ cleanup file key True)+		=<< ingest =<< lockDown file  {- On error, put the file back so it doesn't seem to have vanished.  - This can be called before or after the symlink is in place. -} undo :: FilePath -> Key -> IOException -> Annex a undo file key e = do 	whenM (inAnnex key) $ do-		nuke file+		liftIO $ nukeFile file 		handle tryharder $ fromAnnex key file 		logStatus key InfoMissing 	throw e@@ -88,24 +98,31 @@ 			src <- inRepo $ gitAnnexLocation key 			liftIO $ moveFile src file -cleanup :: FilePath -> Key -> Bool -> CommandCleanup-cleanup file key hascontent = do-	handle (undo file key) $ do-		link <- calcGitLink file key-		liftIO $ createSymbolicLink link file+{- Creates the symlink to the annexed content, returns the link target. -}+link :: FilePath -> Key -> Bool -> Annex String+link file key hascontent = handle (undo file key) $ do+	l <- calcGitLink file key+	liftIO $ createSymbolicLink l file -		when hascontent $ do-			logStatus key InfoPresent+	when hascontent $ do+		logStatus key InfoPresent 	-			-- touch the symlink to have the same mtime as the-			-- file it points to-			liftIO $ do-				mtime <- modificationTime <$> getFileStatus file-				touch file (TimeSpec mtime) False+		-- touch the symlink to have the same mtime as the+		-- file it points to+		liftIO $ do+			mtime <- modificationTime <$> getFileStatus file+			touch file (TimeSpec mtime) False +	return l++{- Note: Several other commands call this, and expect it to + - create the symlink and add it. -}+cleanup :: FilePath -> Key -> Bool -> CommandCleanup+cleanup file key hascontent = do+	_ <- link file key hascontent 	params <- ifM (Annex.getState Annex.force) 		( return [Param "-f"] 		, return [] 		)-	Annex.Queue.add "add" (params++[Param "--"]) [file]+	Annex.Queue.addCommand "add" (params++[Param "--"]) [file] 	return True
Command/AddUrl.hs view
@@ -20,6 +20,7 @@ import Logs.Web import qualified Option import Types.Key+import Types.KeySource import Config  def :: [Command]
Command/Commit.hs view
@@ -22,7 +22,7 @@ start :: CommandStart start = next $ next $ do 	Annex.Branch.commit "update"-	_ <- runhook =<< (inRepo $ Git.hookPath "annex-content")+	_ <- runhook <=< inRepo $ Git.hookPath "annex-content" 	return True 	where 		runhook (Just hook) = liftIO $ boolSystem hook []
Command/DropUnused.hs view
@@ -40,5 +40,5 @@ performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform performOther filespec key = do 	f <- fromRepo $ filespec key-	liftIO $ whenM (doesFileExist f) $ removeFile f+	liftIO $ nukeFile f 	next $ return True
Command/Fix.hs view
@@ -36,5 +36,5 @@  cleanup :: FilePath -> CommandCleanup cleanup file = do-	Annex.Queue.add "add" [Param "--force", Param "--"] [file]+	Annex.Queue.addCommand "add" [Param "--force", Param "--"] [file] 	return True
Command/FromKey.hs view
@@ -39,5 +39,5 @@  cleanup :: FilePath -> CommandCleanup cleanup file = do-	Annex.Queue.add "add" [Param "--"] [file]+	Annex.Queue.addCommand "add" [Param "--"] [file] 	return True
Command/Fsck.hs view
@@ -145,17 +145,17 @@ 		 -} 		whenM (liftIO $ doesFileExist file) $ 			unlessM (inAnnex key) $ do-				showNote $ "fixing content location"+				showNote "fixing content location" 				dir <- liftIO $ parentDir <$> absPath file 				let content = absPathFrom dir have 				liftIO $ allowWrite (parentDir content) 				moveAnnex key content -		showNote $ "fixing link"+		showNote "fixing link" 		liftIO $ createDirectoryIfMissing True (parentDir file) 		liftIO $ removeFile file 		liftIO $ createSymbolicLink want file-		Annex.Queue.add "add" [Param "--force", Param "--"] [file]+		Annex.Queue.addCommand "add" [Param "--force", Param "--"] [file] 	return True  {- Checks that the location log reflects the current status of the key,@@ -220,7 +220,7 @@ 	Nothing -> return True 	Just size -> do 		size' <- fromIntegral . fileSize-			<$> (liftIO $ getFileStatus file)+			<$> liftIO (getFileStatus file) 		comparesizes size size' 	where 		comparesizes a b = do
Command/Get.hs view
@@ -26,7 +26,7 @@ 	autoCopies file key (<) $ \_numcopies -> 		case from of 			Nothing -> go $ perform key-			Just src -> do+			Just src -> 				-- get --from = copy --from 				stopUnless (Command.Move.fromOk src key) $ 					go $ Command.Move.fromPerform src False key
Command/Lock.hs view
@@ -24,5 +24,5 @@  perform :: FilePath -> CommandPerform perform file = do-	Annex.Queue.add "checkout" [Param "--"] [file]+	Annex.Queue.addCommand "checkout" [Param "--"] [file] 	next $ return True -- no cleanup needed
Command/Migrate.hs view
@@ -11,6 +11,7 @@ import Command import Backend import qualified Types.Key+import Types.KeySource import Annex.Content import qualified Command.ReKey
Command/Move.hs view
@@ -128,9 +128,9 @@ 		expensive = do 			u <- getUUID 			remotes <- Remote.keyPossibilities key-			return $ u /= Remote.uuid src && any (== src) remotes+			return $ u /= Remote.uuid src && elem src remotes fromPerform :: Remote -> Bool -> Key -> CommandPerform-fromPerform src move key = moveLock move key $ do+fromPerform src move key = moveLock move key $ 	ifM (inAnnex key) 		( handle move True 		, do
Command/Sync.hs view
@@ -16,6 +16,7 @@ import qualified Annex import qualified Annex.Branch import qualified Git.Command+import qualified Git.Merge import qualified Git.Branch import qualified Git.Ref import qualified Git@@ -157,7 +158,7 @@ mergeFrom :: Git.Ref -> CommandCleanup mergeFrom branch = do 	showOutput-	inRepo $ Git.Command.runBool "merge" [Param $ show branch]+	inRepo $ Git.Merge.mergeNonInteractive branch  changed :: Remote -> Git.Ref -> Annex Bool changed remote b = do
Command/Uninit.hs view
@@ -28,8 +28,8 @@ 		"cannot uninit when the " ++ show b ++ " branch is checked out" 	top <- fromRepo Git.repoPath 	cwd <- liftIO getCurrentDirectory-	whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath cwd)) $ error $-		"can only run uninit from the top of the git repository"+	whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath cwd)) $+		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
Command/Unused.hs view
@@ -10,8 +10,7 @@ module Command.Unused where  import qualified Data.Set as S-import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.Encoding as L+import qualified Data.ByteString.Lazy as L import Data.BloomFilter import Data.BloomFilter.Easy import Data.BloomFilter.Hash@@ -84,7 +83,7 @@ 			_ <- check "" (remoteUnusedMsg r) (remoteunused r) 0 			next $ return True 		remoteunused r =-			excludeReferenced =<< loggedKeysFor (Remote.uuid r)+			excludeReferenced <=< loggedKeysFor $ Remote.uuid r  check :: FilePath -> ([(Int, Key)] -> String) -> Annex [Key] -> Int -> Annex Int check file msg a c = do@@ -260,13 +259,14 @@ withKeysReferencedInGitRef :: (Key -> Annex ()) -> Git.Ref -> Annex () withKeysReferencedInGitRef a ref = do 	showAction $ "checking " ++ Git.Ref.describe ref-	go =<< inRepo (LsTree.lsTree ref)+	go <=< inRepo $ LsTree.lsTree ref 	where 		go [] = noop 		go (l:ls) 			| isSymLink (LsTree.mode l) = do-				content <- L.decodeUtf8 <$> catFile ref (LsTree.file l)-				case fileKey (takeFileName $ L.unpack content) of+				content <- encodeW8 . L.unpack+					<$> catFile ref (LsTree.file l)+				case fileKey (takeFileName content) of 					Nothing -> go ls 					Just k -> do 						a k
+ Command/Watch.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}++{- git-annex watch command+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Command.Watch where++import Common.Annex+import Assistant+import Command+import Option++def :: [Command]+def = [withOptions [foregroundOption, stopOption] $ +	command "watch" paramNothing seek "watch for changes"]++seek :: [CommandSeek]+seek = [withFlag stopOption $ \stopdaemon -> +	withFlag foregroundOption $ \foreground ->+	withNothing $ start foreground stopdaemon]++foregroundOption :: Option+foregroundOption = Option.flag [] "foreground" "do not daemonize"++stopOption :: Option+stopOption = Option.flag [] "stop" "stop daemon"++start :: Bool -> Bool -> CommandStart+start foreground stopdaemon = notBareRepo $ do+	if stopdaemon+		then stopDaemon+		else startDaemon foreground -- does not return+	stop
Command/Whereis.hs view
@@ -37,7 +37,7 @@ 	unless (null safelocations) $ showLongNote pp 	pp' <- prettyPrintUUIDs "untrusted" untrustedlocations 	unless (null untrustedlocations) $ showLongNote $ untrustedheader ++ pp'-	forM_ (catMaybes $ map (`M.lookup` remotemap) locations) $+	forM_ (mapMaybe (`M.lookup` remotemap) locations) $ 		performRemote key 	if null safelocations then stop else next $ return True 	where
Config.hs view
@@ -114,6 +114,6 @@ getHttpHeaders :: Annex [String] getHttpHeaders = do 	cmd <- getConfig (annexConfig "http-headers-command") ""-	if (null cmd)+	if null cmd 		then fromRepo $ Git.Config.getList "annex.http-headers" 		else lines . snd <$> liftIO (pipeFrom "sh" ["-c", cmd])
Crypto.hs view
@@ -26,7 +26,7 @@ 	prop_hmacWithCipher_sane ) where -import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.UTF8 (fromString) import Data.Digest.Pure.SHA import Control.Applicative@@ -138,7 +138,7 @@  pass :: (Cipher -> IO L.ByteString -> (Handle -> IO a) -> IO a)        -> Cipher -> IO L.ByteString -> (L.ByteString -> IO a) -> IO a-pass to n s a = to n s $ \h -> a =<< L.hGetContents h+pass to n s a = to n s $ a <=< L.hGetContents  hmacWithCipher :: Cipher -> String -> String hmacWithCipher c = hmacWithCipher' (cipherHmac c)
Git/CatFile.hs view
@@ -10,12 +10,13 @@ 	catFileStart, 	catFileStop, 	catFile,-	catObject+	catObject,+	catObjectDetails, ) where  import System.IO-import qualified Data.ByteString.Char8 as S-import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L  import Common import Git@@ -42,7 +43,11 @@ {- Uses a running git cat-file read the content of an object.  - Objects that do not exist will have "" returned. -} catObject :: CatFileHandle -> Ref -> IO L.ByteString-catObject h object = CoProcess.query h send receive+catObject h object = maybe L.empty fst <$> catObjectDetails h object++{- Gets both the content of an object, and its Sha. -}+catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha))+catObjectDetails h object = CoProcess.query h send receive 	where 		send to = do 			fileEncoding to@@ -55,16 +60,16 @@ 					| length sha == shaSize && 					  isJust (readObjectType objtype) ->  						case reads size of-							[(bytes, "")] -> readcontent bytes from+							[(bytes, "")] -> readcontent bytes from sha 							_ -> dne 					| otherwise -> dne 				_ 					| header == show object ++ " missing" -> dne 					| otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)-		readcontent bytes from = do+		readcontent bytes from sha = do 			content <- S.hGet from bytes 			c <- hGetChar from 			when (c /= '\n') $ 				error "missing newline from git cat-file"-			return $ L.fromChunks [content]-		dne = return L.empty+			return $ Just (L.fromChunks [content], Ref sha)+		dne = return Nothing
+ Git/FilePath.hs view
@@ -0,0 +1,34 @@+{- git FilePath library+ -+ - Different git commands use different types of FilePaths to refer to+ - files in the repository. Some commands use paths relative to the+ - top of the repository even when run in a subdirectory. Adding some+ - types helps keep that straight.+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.FilePath (+	TopFilePath,+	getTopFilePath,+	toTopFilePath,+	asTopFilePath,+) where++import Common+import Git++{- A FilePath, relative to the top of the git repository. -}+newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath }++{- The input FilePath can be absolute, or relative to the CWD. -}+toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath+toTopFilePath file repo = TopFilePath <$>+	relPathDirToFile (repoPath repo) <$> absPath file++{- The input FilePath must already be relative to the top of the git+ - repository -}+asTopFilePath :: FilePath -> TopFilePath+asTopFilePath file = TopFilePath file
Git/HashObject.hs view
@@ -36,8 +36,8 @@ 		receive from = getSha "hash-object" $ hGetLine from  {- Injects some content into git, returning its Sha. -}-hashObject :: Repo -> ObjectType -> String -> IO Sha-hashObject repo objtype content = getSha subcmd $ do+hashObject :: ObjectType -> String -> Repo -> IO Sha+hashObject objtype content repo = getSha subcmd $ do 	(h, s) <- pipeWriteRead (map Param params) content repo 	length s `seq` do 		forceSuccess h
+ Git/Merge.hs view
@@ -0,0 +1,17 @@+{- git merging+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.Merge where++import Common+import Git+import Git.Command++{- Avoids recent git's interactive merge. -}+mergeNonInteractive :: Ref -> Repo -> IO Bool+mergeNonInteractive branch = runBool "merge"+	[Param "--no-edit", Param $ show branch]
Git/Queue.hs view
@@ -1,6 +1,6 @@ {- git repository command queue  -- - Copyright 2010 Joey Hess <joey@kitenet.net>+ - Copyright 2010,2012 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -10,7 +10,8 @@ module Git.Queue ( 	Queue, 	new,-	add,+	addCommand,+	addUpdateIndex, 	size, 	full, 	flush,@@ -25,23 +26,40 @@ import Common import Git import Git.Command+import qualified Git.UpdateIndex+	+{- Queable actions that can be performed in a git repository.+ -}+data Action+	{- Updating the index file, using a list of streamers that can+	 - be added to as the queue grows. -}+	= UpdateIndexAction+		{ getStreamers :: [Git.UpdateIndex.Streamer] -- in reverse order+		}+	{- A git command to run, on a list of files that can be added to+	 - as the queue grows. -}+	| CommandAction +		{ getSubcommand :: String+		, getParams :: [CommandParam]+		, getFiles :: [FilePath]+		}  -{- An action to perform in a git repository. The file to act on- - is not included, and must be able to be appended after the params. -}-data Action = Action-	{ getSubcommand :: String-	, getParams :: [CommandParam]-	} deriving (Show, Eq, Ord)+{- A key that can uniquely represent an action in a Map. -}+data ActionKey = UpdateIndexActionKey | CommandActionKey String+	deriving (Eq, Ord) +actionKey :: Action -> ActionKey+actionKey (UpdateIndexAction _) = UpdateIndexActionKey+actionKey CommandAction { getSubcommand = s } = CommandActionKey s+ {- A queue of actions to perform (in any order) on a git repository,  - with lists of files to perform them on. This allows coalescing   - similar git commands. -} data Queue = Queue 	{ size :: Int 	, _limit :: Int-	, _items :: M.Map Action [FilePath]+	, items :: M.Map ActionKey Action 	}-	deriving (Show, Eq)  {- A recommended maximum size for the queue, after which it should be  - run.@@ -59,17 +77,57 @@ new :: Maybe Int -> Queue new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty -{- Adds an action to a queue. -}-add :: Queue -> String -> [CommandParam] -> [FilePath] -> Queue-add (Queue cur lim m) subcommand params files = Queue (cur + 1) lim m'+{- Adds an git command to the queue.+ -+ - Git commands with the same subcommand but different parameters are+ - assumed to be equivilant enough to perform in any order with the same+ - result.+ -}+addCommand :: String -> [CommandParam] -> [FilePath] -> Queue -> Repo -> IO Queue+addCommand subcommand params files q repo =+	updateQueue action different (length newfiles) q repo 	where-		action = Action subcommand params-		-- There are probably few items in the map, but there-		-- can be a lot of files per item. So, optimise adding-		-- files.-		m' = M.insertWith' const action fs m-		!fs = files ++ M.findWithDefault [] action m+		key = actionKey action+		action = CommandAction+			{ getSubcommand = subcommand+			, getParams = params+			, getFiles = newfiles+			}+		newfiles = files ++ maybe [] getFiles (M.lookup key $ items q)+		+		different (CommandAction { getSubcommand = s }) = s /= subcommand+		different _ = True +{- Adds an update-index streamer to the queue. -}+addUpdateIndex :: Git.UpdateIndex.Streamer -> Queue -> Repo -> IO Queue+addUpdateIndex streamer q repo =+	updateQueue action different 1 q repo+	where+		key = actionKey action+		-- the list is built in reverse order+		action = UpdateIndexAction $ streamer : streamers+		streamers = maybe [] getStreamers $ M.lookup key $ items q++		different (UpdateIndexAction _) = False+		different _ = True++{- Updates or adds an action in the queue. If the queue already contains a+ - different action, it will be flushed; this is to ensure that conflicting+ - actions, like add and rm, are run in the right order.-}+updateQueue :: Action -> (Action -> Bool) -> Int -> Queue -> Repo -> IO Queue+updateQueue !action different sizeincrease q repo+	| null (filter different (M.elems (items q))) = return $ go q+	| otherwise = go <$> flush q repo+	where+		go q' = newq+			where		+				!newq = q'+					{ size = newsize+					, items = newitems+					}+				!newsize = size q' + sizeincrease+				!newitems = M.insertWith' const (actionKey action) action (items q')+ {- Is a queue large enough that it should be flushed? -} full :: Queue -> Bool full (Queue cur lim  _) = cur > lim@@ -77,7 +135,7 @@ {- Runs a queue on a git repository. -} flush :: Queue -> Repo -> IO Queue flush (Queue _ lim m) repo = do-	forM_ (M.toList m) $ uncurry $ runAction repo+	forM_ (M.elems m) $ runAction repo 	return $ Queue 0 lim M.empty  {- Runs an Action on a list of files in a git repository.@@ -86,12 +144,15 @@  -  - Intentionally runs the command even if the list of files is empty;  - this allows queueing commands that do not need a list of files. -}-runAction :: Repo -> Action -> [FilePath] -> IO ()-runAction repo action files =+runAction :: Repo -> Action -> IO ()+runAction repo (UpdateIndexAction streamers) =+	-- list is stored in reverse order+	Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers+runAction repo action@(CommandAction {}) = 	pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs 	where 		params = toCommand $ gitCommandLine 			(Param (getSubcommand action):getParams action) repo 		feedxargs h = do 			fileEncoding h-			hPutStr h $ join "\0" files+			hPutStr h $ join "\0" $ getFiles action
Git/Types.hs view
@@ -63,3 +63,11 @@ readObjectType "tree" = Just TreeObject readObjectType _ = Nothing +{- Types of blobs. -}+data BlobType = FileBlob | ExecutableBlob | SymlinkBlob++{- Git uses magic numbers to denote the type of a blob. -}+instance Show BlobType where+	show FileBlob = "100644"+	show ExecutableBlob = "100755"+	show SymlinkBlob = "120000"
Git/UnionMerge.hs view
@@ -7,7 +7,7 @@  module Git.UnionMerge ( 	merge,-	merge_index+	mergeIndex ) where  import qualified Data.Text.Lazy as L@@ -22,6 +22,7 @@ import Git.UpdateIndex import Git.HashObject import Git.Types+import Git.FilePath  {- Performs a union merge between two branches, staging it in the index.  - Any previously staged changes in the index will be lost.@@ -31,40 +32,40 @@ merge :: Ref -> Ref -> Repo -> IO () merge x y repo = do 	h <- catFileStart repo-	stream_update_index repo-		[ ls_tree x repo-		, merge_trees x y h repo+	streamUpdateIndex repo+		[ lsTree x repo+		, mergeTrees x y h repo 		] 	catFileStop h -{- Merges a list of branches into the index. Previously staged changed in+{- Merges a list of branches into the index. Previously staged changes in  - the index are preserved (and participate in the merge). -}-merge_index :: CatFileHandle -> Repo -> [Ref] -> IO ()-merge_index h repo bs =-	stream_update_index repo $ map (\b -> merge_tree_index b h repo) bs+mergeIndex :: CatFileHandle -> Repo -> [Ref] -> IO ()+mergeIndex h repo bs =+	streamUpdateIndex repo $ map (\b -> mergeTreeIndex b h repo) bs  {- For merging two trees. -}-merge_trees :: Ref -> Ref -> CatFileHandle -> Repo -> Streamer-merge_trees (Ref x) (Ref y) h = calc_merge h $ "diff-tree":diff_opts ++ [x, y]+mergeTrees :: Ref -> Ref -> CatFileHandle -> Repo -> Streamer+mergeTrees (Ref x) (Ref y) h = doMerge h $ "diff-tree":diffOpts ++ [x, y]  {- For merging a single tree into the index. -}-merge_tree_index :: Ref -> CatFileHandle -> Repo -> Streamer-merge_tree_index (Ref x) h = calc_merge h $-	"diff-index" : diff_opts ++ ["--cached", x]+mergeTreeIndex :: Ref -> CatFileHandle -> Repo -> Streamer+mergeTreeIndex (Ref x) h = doMerge h $+	"diff-index" : diffOpts ++ ["--cached", x] -diff_opts :: [String]-diff_opts = ["--raw", "-z", "-r", "--no-renames", "-l0"]+diffOpts :: [String]+diffOpts = ["--raw", "-z", "-r", "--no-renames", "-l0"] -{- Calculates how to perform a merge, using git to get a raw diff,- - and generating update-index input. -}-calc_merge :: CatFileHandle -> [String] -> Repo -> Streamer-calc_merge ch differ repo streamer = gendiff >>= go+{- 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 	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)-		go (_:[]) = error "calc_merge parse error"+		go (_:[]) = error $ "parse error " ++ show differ  {- Given an info line from a git raw diff, and the filename, generates  - a line suitable for update-index that union merges the two sides of the@@ -73,13 +74,15 @@ mergeFile info file h repo = case filter (/= nullSha) [Ref asha, Ref bsha] of 	[] -> return Nothing 	(sha:[]) -> use sha-	shas -> use =<< either return (hashObject repo BlobObject . unlines) =<<-		calcMerge . zip shas <$> mapM getcontents shas+	shas -> use+		=<< either return (\s -> hashObject BlobObject (unlines s) repo)+		=<< calcMerge . zip shas <$> mapM getcontents shas 	where 		[_colonmode, _bmode, asha, bsha, _status] = words info 		getcontents s = map L.unpack . L.lines . 			L.decodeUtf8 <$> catObject h s-		use sha = return $ Just $ update_index_line sha file+		use sha = return $ Just $+			updateIndexLine sha FileBlob $ asTopFilePath file  {- Calculates a union merge between a list of refs, with contents.  -
Git/UpdateIndex.hs view
@@ -5,26 +5,38 @@  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE BangPatterns #-}+ module Git.UpdateIndex ( 	Streamer,-	stream_update_index,-	update_index_line,-	ls_tree+	pureStreamer,+	streamUpdateIndex,+	lsTree,+	updateIndexLine,+	unstageFile,+	stageSymlink ) where  import System.Cmd.Utils  import Common import Git+import Git.Types import Git.Command+import Git.FilePath+import Git.Sha  {- Streamers are passed a callback and should feed it lines in the form  - read by update-index, and generated by ls-tree. -} type Streamer = (String -> IO ()) -> IO () +{- A streamer with a precalculated value. -}+pureStreamer :: String -> Streamer+pureStreamer !s = \streamer -> streamer s+ {- Streams content into update-index from a list of Streamers. -}-stream_update_index :: Repo -> [Streamer] -> IO ()-stream_update_index repo as = do+streamUpdateIndex :: Repo -> [Streamer] -> IO ()+streamUpdateIndex repo as = do 	(p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo) 	fileEncoding h 	forM_ as (stream h)@@ -37,13 +49,30 @@ 			hPutStr h s 			hPutStr h "\0" +{- 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+	where+		params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]+ {- Generates a line suitable to be fed into update-index, to add  - a given file with a given sha. -}-update_index_line :: Sha -> FilePath -> String-update_index_line sha file = "100644 blob " ++ show sha ++ "\t" ++ file+updateIndexLine :: Sha -> BlobType -> TopFilePath -> String+updateIndexLine sha filetype file =+	show filetype ++ " blob " ++ show sha ++ "\t" ++ getTopFilePath file -{- Gets the current tree for a ref. -}-ls_tree :: Ref -> Repo -> Streamer-ls_tree (Ref x) repo streamer = mapM_ streamer =<< pipeNullSplit params repo-	where-		params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]+{- A streamer that removes a file from the index. -}+unstageFile :: FilePath -> Repo -> IO Streamer+unstageFile file repo = do+	p <- toTopFilePath file repo+	return $ pureStreamer $ "0 " ++ show nullSha ++ "\t" ++ getTopFilePath p++{- A streamer that adds a symlink to the index. -}+stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer+stageSymlink file sha repo = do+	!line <- updateIndexLine+		<$> pure sha+		<*> pure SymlinkBlob+		<*> toTopFilePath file repo+	return $ pureStreamer line
GitAnnex.hs view
@@ -58,6 +58,7 @@ import qualified Command.Map import qualified Command.Upgrade import qualified Command.Version+import qualified Command.Watch  cmds :: [Command] cmds = concat@@ -99,6 +100,7 @@ 	, Command.Map.def 	, Command.Upgrade.def 	, Command.Version.def+	, Command.Watch.def 	]  options :: [Option]
INSTALL view
@@ -10,6 +10,7 @@ * [[NixOS]] * [[Gentoo]] * Windows: [[sorry, not possible yet|todo/windows_support]]+* [[ScientificLinux5]] - This should cover RHEL5 clones such as CentOS5 and so on  ## Using cabal @@ -41,6 +42,9 @@   * [IfElse](http://hackage.haskell.org/package/IfElse)   * [bloomfilter](http://hackage.haskell.org/package/bloomfilter)   * [edit-distance](http://hackage.haskell.org/package/edit-distance)+  * [stm](http://hackage.haskell.org/package/stm)+  * [hinotify](http://hackage.haskell.org/package/hinotify)+    (optional; Linux only) * Shell commands   * [git](http://git-scm.com/)   * [uuid](http://www.ossp.org/pkg/lib/uuid/)@@ -51,6 +55,8 @@   * [sha1sum](ftp://ftp.gnu.org/gnu/coreutils/) (optional, but recommended;     a sha1 command will also do)   * [gpg](http://gnupg.org/) (optional; needed for encryption)+  * [lsof](ftp://lsof.itap.purdue.edu/pub/tools/unix/lsof/)+    (optional; recommended for watch mode)   * [ikiwiki](http://ikiwiki.info) (optional; used to build the docs)  Then just [[download]] git-annex and run: `make; make install`
Locations.hs view
@@ -23,6 +23,9 @@ 	gitAnnexIndex, 	gitAnnexIndexLock, 	gitAnnexIndexDirty,+	gitAnnexPidFile,+	gitAnnexDaemonStatusFile,+	gitAnnexLogFile, 	gitAnnexSshDir, 	gitAnnexRemotesDir, 	isLinkToAnnex,@@ -145,6 +148,18 @@ gitAnnexIndexDirty :: Git.Repo -> FilePath gitAnnexIndexDirty r = gitAnnexDir r </> "index.dirty" +{- Pid file for daemon mode. -}+gitAnnexPidFile :: Git.Repo -> FilePath+gitAnnexPidFile r = gitAnnexDir r </> "daemon.pid"++{- Status file for daemon mode. -}+gitAnnexDaemonStatusFile :: Git.Repo -> FilePath+gitAnnexDaemonStatusFile r = gitAnnexDir r </> "daemon.status"++{- Log file for daemon mode. -}+gitAnnexLogFile :: Git.Repo -> FilePath+gitAnnexLogFile r = gitAnnexDir r </> "daemon.log"+ {- .git/annex/ssh/ is used for ssh connection caching -} gitAnnexSshDir :: Git.Repo -> FilePath gitAnnexSshDir r = addTrailingPathSeparator $ gitAnnexDir r </> "ssh"@@ -155,7 +170,7 @@  {- Checks a symlink target to see if it appears to point to annexed content. -} isLinkToAnnex :: FilePath -> Bool-isLinkToAnnex s = ("/" ++ d) `isInfixOf` s || d `isPrefixOf` s+isLinkToAnnex s = ('/':d) `isInfixOf` s || d `isPrefixOf` s 	where 		d = ".git" </> objectDir
Makefile view
@@ -1,20 +1,28 @@+bins=git-annex+mans=git-annex.1 git-annex-shell.1+sources=Build/SysConfig.hs Utility/Touch.hs+all=$(bins) $(mans) docs++OS:=$(shell uname | sed 's/[-_].*//')+ifeq ($(OS),Linux)+BASEFLAGS_OPTS+=-DWITH_INOTIFY+clibs=Utility/libdiskfree.o+else+BASEFLAGS_OPTS+=-DWITH_KQUEUE+clibs=Utility/libdiskfree.o Utility/libkqueue.o+endif+ PREFIX=/usr IGNORE=-ignore-package monads-fd -ignore-package monads-tf-BASEFLAGS=-Wall $(IGNORE) -outputdir tmp -IUtility -DWITH_S3+BASEFLAGS=-Wall $(IGNORE) -outputdir tmp -IUtility -DWITH_S3 $(BASEFLAGS_OPTS) GHCFLAGS=-O2 $(BASEFLAGS)+CFLAGS=-Wall  ifdef PROFILE GHCFLAGS=-prof -auto-all -rtsopts -caf-all -fforce-recomp $(BASEFLAGS) endif  GHCMAKE=ghc $(GHCFLAGS) --make--bins=git-annex-mans=git-annex.1 git-annex-shell.1-sources=Build/SysConfig.hs Utility/Touch.hs-clibs=Utility/libdiskfree.o--all=$(bins) $(mans) docs  # Am I typing :make in vim? Do a fast build. ifdef VIM
Messages.hs view
@@ -183,7 +183,7 @@ 	fileEncoding stderr  handle :: IO () -> IO () -> Annex ()-handle json normal = withOutputType $ go+handle json normal = withOutputType go 	where 		go NormalOutput = liftIO normal 		go QuietOutput = q
Remote/Bup.hs view
@@ -7,7 +7,7 @@  module Remote.Bup (remote) where -import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Lazy as L import qualified Data.Map as M import System.Process
Remote/Directory.hs view
@@ -7,8 +7,8 @@  module Remote.Directory (remote) where -import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as S import qualified Data.Map as M import qualified Control.Exception as E
Remote/Hook.hs view
@@ -7,7 +7,7 @@  module Remote.Hook (remote) where -import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Lazy as L import qualified Data.Map as M import System.Exit import System.Environment
Remote/Rsync.hs view
@@ -7,7 +7,7 @@  module Remote.Rsync (remote) where -import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Lazy as L import qualified Data.Map as M  import Common.Annex@@ -100,7 +100,7 @@                 f = keyFile k  store :: RsyncOpts -> Key -> Annex Bool-store o k = rsyncSend o k =<< inRepo (gitAnnexLocation k)+store o k = rsyncSend o k <=< inRepo $ gitAnnexLocation k  storeEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> Annex Bool storeEncrypted o (cipher, enck) k = withTmp enck $ \tmp -> do
Seek.hs view
@@ -95,7 +95,7 @@  -} withField :: Option -> (Maybe String -> Annex a) -> (a -> CommandSeek) -> CommandSeek withField option converter = withValue $-	converter =<< Annex.getField (Option.name option)+	converter <=< Annex.getField $ Option.name option  withFlag :: Option -> (Bool -> CommandSeek) -> CommandSeek withFlag option = withValue $ Annex.getFlag (Option.name option)
Types/Backend.hs view
@@ -10,13 +10,7 @@ module Types.Backend where  import Types.Key--{- The source used to generate a key. The location of the content- - may be different from the filename associated with the key. -}-data KeySource = KeySource-	{ keyFilename :: FilePath-	, contentLocation :: FilePath-	}+import Types.KeySource  data BackendA a = Backend 	{ name :: String
+ Types/KeySource.hs view
@@ -0,0 +1,22 @@+{- KeySource data type+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Types.KeySource where++{- When content is in the process of being added to the annex,+ - and a Key generated from it, this data type is used. + -+ - The contentLocation may be different from the filename+ - associated with the key. For example, the add command+ - temporarily puts the content into a lockdown directory+ - for checking. The migrate command uses the content+ - of a different Key. -}+data KeySource = KeySource+	{ keyFilename :: FilePath+	, contentLocation :: FilePath+	}+	deriving (Show)
Upgrade/V1.hs view
@@ -94,7 +94,7 @@ 					link <- calcGitLink f k 					liftIO $ removeFile f 					liftIO $ createSymbolicLink link f-					Annex.Queue.add "add" [Param "--"] [f]+					Annex.Queue.addCommand "add" [Param "--"] [f]  moveLocationLogs :: Annex () moveLocationLogs = do@@ -121,9 +121,9 @@ 				old <- liftIO $ readLog1 f 				new <- liftIO $ readLog1 dest 				liftIO $ writeLog1 dest (old++new)-				Annex.Queue.add "add" [Param "--"] [dest]-				Annex.Queue.add "add" [Param "--"] [f]-				Annex.Queue.add "rm" [Param "--quiet", Param "-f", Param "--"] [f]+				Annex.Queue.addCommand "add" [Param "--"] [dest]+				Annex.Queue.addCommand "add" [Param "--"] [f]+				Annex.Queue.addCommand "rm" [Param "--quiet", Param "-f", Param "--"] [f] 		 oldlog2key :: FilePath -> Maybe (FilePath, Key) oldlog2key l
Upgrade/V2.hs view
@@ -84,7 +84,7 @@  logFiles :: FilePath -> Annex [FilePath] logFiles dir = return . filter (".log" `isSuffixOf`)-		=<< liftIO (getDirectoryContents dir)+		<=< liftIO $ getDirectoryContents dir  push :: Annex () push = do
+ Utility/Daemon.hs view
@@ -0,0 +1,72 @@+{- daemon support+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.Daemon where++import Common++import System.Posix++{- Run an action as a daemon, with all output sent to a file descriptor.+ -+ - Can write its pid to a file, to guard against multiple instances+ - running and allow easy termination.+ -+ - When successful, does not return. -}+daemonize :: Fd -> Maybe FilePath -> Bool -> IO () -> IO ()+daemonize logfd pidfile changedirectory a = do+	_ <- forkProcess child1+	out+	where+		child1 = do+			_ <- createSession+			_ <- forkProcess child2+			out+		child2 = do+			maybe noop (lockPidFile True alreadyrunning) pidfile +			when changedirectory $+				setCurrentDirectory "/"+			nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags+			_ <- redir nullfd stdInput+			mapM_ (redir logfd) [stdOutput, stdError]+			closeFd logfd+			a+			out+		redir newh h = do+			closeFd h+			dupTo newh h+		alreadyrunning = error "Daemon is already running."+		out = exitImmediately ExitSuccess++lockPidFile :: Bool -> IO () -> FilePath -> IO ()+lockPidFile write onfailure file = do+	fd <- openFd file ReadWrite (Just stdFileMode)+		defaultFileFlags { trunc = write }+	locked <- catchMaybeIO $ setLock fd (locktype, AbsoluteSeek, 0, 0)+	case locked of+		Nothing -> onfailure+		_ -> when write $ void $+			fdWrite fd =<< show <$> getProcessID+	where+		locktype+			| write = WriteLock+			| otherwise = ReadLock++{- Stops the daemon.+ -+ - The pid file is used to get the daemon's pid.+ -+ - To guard against a stale pid, try to take a nonblocking shared lock+ - of the pid file. If this *fails*, the daemon must be running,+ - and have the exclusive lock, so the pid file is trustworthy.+ -}+stopDaemon :: FilePath -> IO ()+stopDaemon pidfile = lockPidFile False go pidfile+	where+		go = do+			pid <- readish <$> readFile pidfile+			maybe noop (signalProcess sigTERM) pid
+ Utility/DirWatcher.hs view
@@ -0,0 +1,90 @@+{- generic directory watching interface+ -+ - Uses either inotify or kqueue to watch a directory (and subdirectories)+ - for changes, and runs hooks for different sorts of events as they occur.+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Utility.DirWatcher where++import Utility.Types.DirWatcher++#if WITH_INOTIFY+import qualified Utility.INotify as INotify+import qualified System.INotify as INotify+import Utility.ThreadScheduler+#endif+#if WITH_KQUEUE+import qualified Utility.Kqueue as Kqueue+#endif++type Pruner = FilePath -> Bool++canWatch :: Bool+#if (WITH_INOTIFY || WITH_KQUEUE)+canWatch = True+#else+#if defined linux_HOST_OS+#warning "Building without inotify support"+#endif+canWatch = False+#endif++/* With inotify, discrete events will be received when making multiple changes+ * to the same filename. For example, adding it, deleting it, and adding it+ * again will be three events.+ * + * OTOH, with kqueue, often only one event is received, indicating the most+ * recent state of the file.+ */+eventsCoalesce :: Bool+#if WITH_INOTIFY+eventsCoalesce = False+#else+#if WITH_KQUEUE+eventsCoalesce = True+#else+eventsCoalesce = undefined+#endif+#endif++/* With inotify, file closing is tracked to some extent, so an add event+ * will always be received for a file once its writer closes it, and+ * (typically) not before. This may mean multiple add events for the same file.+ *+ * OTOH, with kqueue, add events will often be received while a file is+ * still being written to, and then no add event will be received once the+ * writer closes it.+ */+closingTracked :: Bool+#if WITH_INOTIFY+closingTracked = True+#else+#if WITH_KQUEUE+closingTracked = False+#else+closingTracked = undefined+#endif+#endif++#if WITH_INOTIFY+watchDir :: FilePath -> Pruner -> WatchHooks -> (IO () -> IO ()) -> IO ()+watchDir dir prune hooks runstartup = INotify.withINotify $ \i -> do+	runstartup $ INotify.watchDir i dir prune hooks+	waitForTermination -- Let the inotify thread run.+#else+#if WITH_KQUEUE+watchDir :: FilePath -> Pruner -> WatchHooks -> (IO Kqueue.Kqueue -> IO Kqueue.Kqueue) -> IO ()+watchDir dir ignored hooks runstartup = do+	kq <- runstartup $ Kqueue.initKqueue dir ignored+	Kqueue.runHooks kq hooks+#else+watchDir :: FilePath -> Pruner -> WatchHooks -> (IO () -> IO ()) -> IO ()+watchDir = undefined+#endif+#endif
Utility/Directory.hs view
@@ -10,12 +10,11 @@ import System.IO.Error import System.Posix.Files import System.Directory-import Control.Exception (throw)+import Control.Exception (throw, bracket_) import Control.Monad import Control.Monad.IfElse import System.FilePath import Control.Applicative-import Control.Exception (bracket_) import System.Posix.Directory import System.IO.Unsafe (unsafeInterleaveIO) @@ -35,7 +34,7 @@ dirContents :: FilePath -> IO [FilePath] dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d -{- Gets contents of directory, and then its subdirectories, recursively,+{- Gets files in a directory, and then its subdirectories, recursively,  - and lazily. -} dirContentsRecursive :: FilePath -> IO [FilePath] dirContentsRecursive topdir = dirContentsRecursive' topdir [""]@@ -87,6 +86,13 @@ 			case r of 				(Left _) -> return False 				(Right s) -> return $ isDirectory s++{- Removes a file, which may or may not exist.+ -+ - Note that an exception is thrown if the file exists but+ - cannot be removed. -}+nukeFile :: FilePath -> IO ()+nukeFile file = whenM (doesFileExist file) $ removeFile file  {- Runs an action in another directory. -} bracketCd :: FilePath -> IO a -> IO a
Utility/FileSystemEncoding.hs view
@@ -13,6 +13,8 @@ import System.IO import System.IO.Unsafe import qualified Data.Hash.MD5 as MD5+import Data.Word+import Data.Bits.Utils  {- Sets a Handle to use the filesystem encoding. This causes data  - written or read from it to be encoded/decoded the same@@ -29,7 +31,7 @@ withFilePath fp f = Encoding.getFileSystemEncoding 	>>= \enc -> GHC.withCString enc fp f -{- Encodes a FilePath into a Str, applying the filesystem encoding.+{- Encodes a FilePath into a Md5.Str, applying the filesystem encoding.  -  - This use of unsafePerformIO is belived to be safe; GHC's interface  - only allows doing this conversion with CStrings, and the CString buffer@@ -41,3 +43,15 @@ encodeFilePath fp = MD5.Str $ unsafePerformIO $ do 	enc <- Encoding.getFileSystemEncoding 	GHC.withCString enc fp $ GHC.peekCString Encoding.char8++{- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.+ -+ - w82c produces a String, which may contain Chars that are invalid+ - unicode. From there, this is really a simple matter of applying the+ - file system encoding, only complicated by GHC's interface to doing so.+ -}+{-# NOINLINE encodeW8 #-}+encodeW8 :: [Word8] -> FilePath+encodeW8 w8 = unsafePerformIO $ do+	enc <- Encoding.getFileSystemEncoding+	GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc
Utility/Gpg.hs view
@@ -7,7 +7,7 @@  module Utility.Gpg where -import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Lazy as L import System.Posix.Types import Control.Applicative import Control.Concurrent
+ Utility/INotify.hs view
@@ -0,0 +1,171 @@+{- higher-level inotify interface+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.INotify where++import Common hiding (isDirectory)+import Utility.ThreadLock+import Utility.Types.DirWatcher++import System.INotify+import qualified System.Posix.Files as Files+import System.IO.Error+import Control.Exception (throw)++{- Watches for changes to files in a directory, and all its subdirectories+ - that are not ignored, using inotify. This function returns after+ - its initial scan is complete, leaving a thread running. Callbacks are+ - made for different events.+ -+ - Inotify is weak at recursive directory watching; the whole directory+ - tree must be scanned and watches set explicitly for each subdirectory.+ -+ - To notice newly created subdirectories, inotify is used, and+ - watches are registered for those directories. There is a race there;+ - things can be added to a directory before the watch gets registered.+ -+ - To close the inotify race, each time a new directory is found, it also + - recursively scans it, assuming all files in it were just added,+ - and registering each subdirectory.+ -+ - Note: Due to the race amelioration, multiple add events may occur+ - for the same file.+ - + - Note: Moving a file will cause events deleting it from its old location+ - and adding it to the new location. + - + - Note: Modification of files is not detected, and it's assumed that when+ - a file that was open for write is closed, it's finished being written+ - to, and can be added.+ -+ - Note: inotify has a limit to the number of watches allowed,+ - /proc/sys/fs/inotify/max_user_watches (default 8192).+ - So this will fail if there are too many subdirectories. The+ - errHook is called when this happens.+ -}+watchDir :: INotify -> FilePath -> (FilePath -> Bool) -> WatchHooks -> IO ()+watchDir i dir ignored hooks+	| ignored dir = noop+	| otherwise = do+		-- Use a lock to make sure events generated during initial+		-- scan come before real inotify events.+		lock <- newLock+		let handler event = withLock lock (void $ go event)+		void (addWatch i watchevents dir handler)+			`catchIO` failedaddwatch+		withLock lock $+			mapM_ scan =<< filter (not . dirCruft) <$>+				getDirectoryContents dir+	where+		recurse d = watchDir i d ignored hooks++		-- Select only inotify events required by the enabled+		-- hooks, but always include Create so new directories can+		-- be scanned.+		watchevents = Create : addevents ++ delevents+		addevents+			| hashook addHook || hashook addSymlinkHook = [MoveIn, CloseWrite]+			| otherwise = []+		delevents+			| hashook delHook || hashook delDirHook = [MoveOut, Delete]+			| otherwise = []++		scan f = unless (ignored f) $ do+			ms <- getstatus f+			case ms of+				Nothing -> return ()+				Just s+					| Files.isDirectory s ->+						recurse $ indir f+					| Files.isSymbolicLink s ->+						runhook addSymlinkHook f ms+					| Files.isRegularFile s ->+						runhook addHook f ms+					| otherwise ->+						noop++		-- Ignore creation events for regular files, which won't be+		-- done being written when initially created, but handle for+		-- directories and symlinks.+		go (Created { isDirectory = isd, filePath = f })+			| isd = recurse $ indir f+			| hashook addSymlinkHook =+				checkfiletype Files.isSymbolicLink addSymlinkHook f+			| otherwise = noop+		-- Closing a file is assumed to mean it's done being written.+		go (Closed { isDirectory = False, maybeFilePath = Just f }) =+				checkfiletype Files.isRegularFile addHook f+		-- When a file or directory is moved in, scan it to add new+		-- stuff.+		go (MovedIn { filePath = f }) = scan f+		go (MovedOut { isDirectory = isd, filePath = f })+			| isd = runhook delDirHook f Nothing+			| otherwise = runhook delHook f Nothing+		-- Verify that the deleted item really doesn't exist,+		-- since there can be spurious deletion events for items+		-- in a directory that has been moved out, but is still+		-- being watched.+		go (Deleted { isDirectory = isd, filePath = f })+			| isd = guarded $ runhook delDirHook f Nothing+			| otherwise = guarded $ runhook delHook f Nothing+			where+				guarded = unlessM (filetype (const True) f)+		go _ = noop++		hashook h = isJust $ h hooks++		runhook h f s+			| ignored f = noop+			| otherwise = maybe noop (\a -> a (indir f) s) (h hooks)++		indir f = dir </> f++		getstatus f = catchMaybeIO $ getSymbolicLinkStatus $ indir f+		checkfiletype check h f = do+			ms <- getstatus f+			case ms of+				Just s+					| check s -> runhook h f ms+				_ -> noop+		filetype t f = catchBoolIO $ t <$> getSymbolicLinkStatus (indir f)++		-- Inotify fails when there are too many watches with a+		-- disk full error.+		failedaddwatch e+			| isFullError e =+				case errHook hooks of+					Nothing -> throw e+					Just hook -> tooManyWatches hook dir+			| otherwise = throw e++tooManyWatches :: (String -> Maybe FileStatus -> IO ()) -> FilePath -> IO ()+tooManyWatches hook dir = do+	sysctlval <- querySysctl [Param maxwatches] :: IO (Maybe Integer)+	hook (unlines $ basewarning : maybe withoutsysctl withsysctl sysctlval) Nothing+	where+		maxwatches = "fs.inotify.max_user_watches"+		basewarning = "Too many directories to watch! (Not watching " ++ dir ++")"+		withoutsysctl = ["Increase the value in /proc/sys/fs/inotify/max_user_watches"]+		withsysctl n = let new = n * 10 in+			[ "Increase the limit permanently by running:"+			, "  echo " ++ maxwatches ++ "=" ++ show new +++			  " | sudo tee -a /etc/sysctl.conf; sudo sysctl -p"+			, "Or temporarily by running:"+			, "  sudo sysctl -w " ++ maxwatches ++ "=" ++ show new+			]++querySysctl :: Read a => [CommandParam] -> IO (Maybe a)+querySysctl ps = do+	v <- catchMaybeIO $ hPipeFrom "sysctl" $ toCommand ps+	case v of+		Nothing -> return Nothing+		Just (pid, h) -> do+			val <- parsesysctl <$> hGetContentsStrict h+			void $ getProcessStatus True False $ processID pid+			return val+	where+		parsesysctl s = readish =<< lastMaybe (words s)
− Utility/Inotify.hs 
@@ -1,95 +0,0 @@-{-# LANGUAGE CPP #-}--module Utility.Inotify where--import Common hiding (isDirectory)-import System.INotify-import qualified System.Posix.Files as Files-import System.Posix.Terminal-import Control.Concurrent.MVar-import System.Posix.Signals--demo :: IO ()-demo = withINotify $ \i -> do-	watchDir i (const True) (Just add) (Just del) "/home/joey/tmp/me"-	putStrLn "started"-	waitForTermination-	where-		add file = putStrLn $ "add " ++ file-		del file = putStrLn $ "del " ++ file--{- Watches for changes to files in a directory, and all its subdirectories- - that match a test, using inotify. This function returns after its initial- - setup is complete, leaving a thread running. Then callbacks are made for- - adding and deleting files.- -- - Inotify is weak at recursive directory watching; the whole directory- - tree must be walked and watches set explicitly for each subdirectory.- -- - To notice newly created subdirectories, inotify is used, and- - watches are registered for those directories. There is a race there;- - things can be added to a directory before the watch gets registered.- -- - To close the inotify race, each time a new directory is found, it also - - recursively scans it, assuming all files in it were just added,- - and registering each subdirectory.- -- - Note: Due to the race amelioration, multiple add events may occur- - for the same file.- - - - Note: Moving a file may involve deleting it from its old location and- - adding it to the new location. - - - - Note: Modification of files is not detected, and it's assumed that when- - a file that was open for write is closed, it's done being written- - to, and can be added.- -- - Note: inotify has a limit to the number of watches allowed,- - /proc/sys/fs/inotify/max_user_watches (default 8192).- - So This will fail if there are too many subdirectories.- -}-watchDir :: INotify -> (FilePath -> Bool) -> Maybe (FilePath -> IO ()) -> Maybe (FilePath -> IO ()) -> FilePath -> IO ()-watchDir i test add del dir = watchDir' False i test add del dir-watchDir' :: Bool -> INotify -> (FilePath -> Bool) -> Maybe (FilePath -> IO ()) -> Maybe (FilePath -> IO ()) -> FilePath -> IO ()-watchDir' scan i test add del dir = do-	if test dir-		then void $ do-			_ <- addWatch i watchevents dir go-			mapM walk =<< dirContents dir-		else noop-	where-		watchevents-			| isJust add && isJust del =-				[Create, MoveIn, MoveOut, Delete, CloseWrite]-			| isJust add = [Create, MoveIn, CloseWrite]-			| isJust del = [Create, MoveOut, Delete]-			| otherwise = [Create]--		recurse = watchDir' scan i test add del-		walk f = ifM (catchBoolIO $ Files.isDirectory <$> getFileStatus f)-			( recurse f-			, when (scan && isJust add) $ fromJust add f-			)--		go (Created { isDirectory = False }) = noop-		go (Created { filePath = subdir }) = Just recurse <@> subdir-		go (Closed { maybeFilePath = Just f }) = add <@> f-		go (MovedIn { isDirectory = False, filePath = f }) = add <@> f-		go (MovedOut { isDirectory = False, filePath = f }) = del <@> f-		go (Deleted { isDirectory = False, filePath = f }) = del <@> f-		go _ = noop-		-		Just a <@> f = a $ dir </> f-		Nothing <@> _ = noop--{- Pauses the main thread, letting children run until program termination. -}-waitForTermination :: IO ()-waitForTermination = do-	mv <- newEmptyMVar-	check softwareTermination mv-	whenM (queryTerminal stdInput) $-		check keyboardSignal mv-	takeMVar mv-	where-		check sig mv = void $-			installHandler sig (CatchOnce $ putMVar mv ()) Nothing
+ Utility/Kqueue.hs view
@@ -0,0 +1,248 @@+{- BSD kqueue file modification notification interface+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE ForeignFunctionInterface #-}++module Utility.Kqueue (+	Kqueue,+	initKqueue,+	stopKqueue,+	waitChange,+	Change(..),+	changedFile,+	isAdd,+	isDelete,+	runHooks,+) where++import Common+import Utility.Types.DirWatcher++import System.Posix.Types+import Foreign.C.Types+import Foreign.C.Error+import Foreign.Ptr+import Foreign.Marshal+import qualified Data.Map as M+import qualified Data.Set as S+import qualified System.Posix.Files as Files+import Control.Concurrent++data Change+	= Deleted FilePath+	| Added FilePath+	deriving (Show)++isAdd :: Change -> Bool+isAdd (Added _) = True+isAdd (Deleted _) = False++isDelete :: Change -> Bool+isDelete = not . isAdd++changedFile :: Change -> FilePath+changedFile (Added f) = f+changedFile (Deleted f) = f++data Kqueue = Kqueue +	{ kqueueFd :: Fd+	, kqueueTop :: FilePath+	, kqueueMap :: DirMap+	, _kqueuePruner :: Pruner+	}++type Pruner = FilePath -> Bool++type DirMap = M.Map Fd DirInfo++{- A directory, and its last known contents (with filenames relative to it) -}+data DirInfo = DirInfo+	{ dirName :: FilePath+	, dirCache :: S.Set FilePath+	}+	deriving (Show)++getDirInfo :: FilePath -> IO DirInfo+getDirInfo dir = do+	contents <- S.fromList . filter (not . dirCruft)+		<$> getDirectoryContents dir+	return $ DirInfo dir contents++{- Difference between the dirCaches of two DirInfos. -}+(//) :: DirInfo -> DirInfo -> [Change]+oldc // newc = deleted ++ added+	where+		deleted = calc Deleted oldc newc+		added   = calc Added newc oldc+		calc a x y = map a . map (dirName x </>) $+			S.toList $ S.difference (dirCache x) (dirCache y)++{- Builds a map of directories in a tree, possibly pruning some.+ - Opens each directory in the tree, and records its current contents. -}+scanRecursive :: FilePath -> Pruner -> IO DirMap+scanRecursive topdir prune = M.fromList <$> walk [] [topdir]+	where+		walk c [] = return c+		walk c (dir:rest)+			| prune dir = walk c rest+			| otherwise = do+				minfo <- catchMaybeIO $ getDirInfo dir+				case minfo of+					Nothing -> walk c rest+					Just info -> do+						mfd <- catchMaybeIO $+							openFd dir ReadOnly Nothing defaultFileFlags+						case mfd of+							Nothing -> walk c rest+							Just fd -> do+								let subdirs = map (dir </>) $+									S.toList $ dirCache info+								walk ((fd, info):c) (subdirs ++ rest)++{- Adds a list of subdirectories (and all their children), unless pruned to a+ - directory map. Adding a subdirectory that's already in the map will+ - cause its contents to be refreshed. -}+addSubDirs :: DirMap -> Pruner -> [FilePath] -> IO DirMap+addSubDirs dirmap prune dirs = do+	newmap <- foldr M.union M.empty <$>+		mapM (\d -> scanRecursive d prune) dirs+	return $ M.union newmap dirmap -- prefer newmap++{- Removes a subdirectory (and all its children) from a directory map. -}+removeSubDir :: DirMap -> FilePath -> IO DirMap+removeSubDir dirmap dir = do+	mapM_ closeFd $ M.keys toremove+	return rest+	where+		(toremove, rest) = M.partition (dirContains dir . dirName) dirmap++findDirContents :: DirMap -> FilePath -> [FilePath]+findDirContents dirmap dir = concatMap absolutecontents $ search+	where+		absolutecontents i = map (dirName i </>) (S.toList $ dirCache i)+		search = map snd $ M.toList $+			M.filter (\i -> dirName i == dir) dirmap++foreign import ccall unsafe "libkqueue.h init_kqueue" c_init_kqueue+	:: IO Fd+foreign import ccall unsafe "libkqueue.h addfds_kqueue" c_addfds_kqueue+	:: Fd -> CInt -> Ptr Fd -> IO ()+foreign import ccall unsafe "libkqueue.h waitchange_kqueue" c_waitchange_kqueue+	:: Fd -> IO Fd++{- Initializes a Kqueue to watch a directory, and all its subdirectories. -}+initKqueue :: FilePath -> Pruner -> IO Kqueue+initKqueue dir pruned = do+	dirmap <- scanRecursive dir pruned+	h <- c_init_kqueue+	let kq = Kqueue h dir dirmap pruned+	updateKqueue kq+	return kq++{- Updates a Kqueue, adding watches for its map. -}+updateKqueue :: Kqueue -> IO ()+updateKqueue (Kqueue h _ dirmap _) =+	withArrayLen (M.keys dirmap) $ \fdcnt c_fds -> do+		c_addfds_kqueue h (fromIntegral fdcnt) c_fds++{- Stops a Kqueue. Note: Does not directly close the Fds in the dirmap,+ - so it can be reused.  -}+stopKqueue :: Kqueue -> IO ()+stopKqueue = closeFd . kqueueFd++{- Waits for a change on a Kqueue.+ - May update the Kqueue.+ -}+waitChange :: Kqueue -> IO (Kqueue, [Change])+waitChange kq@(Kqueue h _ dirmap _) = do+	changedfd <- c_waitchange_kqueue h+	if changedfd == -1+		then ifM ((==) eINTR <$> getErrno)+			(yield >> waitChange kq, nochange)+		else case M.lookup changedfd dirmap of+			Nothing -> nochange+			Just info -> handleChange kq changedfd info+	where+		nochange = return (kq, [])++{- The kqueue interface does not tell what type of change took place in+ - the directory; it could be an added file, a deleted file, a renamed+ - file, a new subdirectory, or a deleted subdirectory, or a moved+ - subdirectory. + -+ - So to determine this, the contents of the directory are compared+ - with its last cached contents. The Kqueue is updated to watch new+ - directories as necessary.+ -}+handleChange :: Kqueue -> Fd -> DirInfo -> IO (Kqueue, [Change])+handleChange kq@(Kqueue _ _ dirmap pruner) fd olddirinfo =+	go =<< catchMaybeIO (getDirInfo $ dirName olddirinfo)+	where+		go (Just newdirinfo) = do+			let changes = olddirinfo // newdirinfo+			let (added, deleted) = partition isAdd changes++			-- Scan newly added directories to add to the map.+			-- (Newly added files will fail getDirInfo.)+			newdirinfos <- catMaybes <$>+				mapM (catchMaybeIO . getDirInfo . changedFile) added+			newmap <- addSubDirs dirmap pruner $ map dirName newdirinfos++			-- Remove deleted directories from the map.+			newmap' <- foldM removeSubDir newmap (map changedFile deleted)++			-- Update the cached dirinfo just looked up.+			let newmap'' = M.insertWith' const fd newdirinfo newmap'++			-- When new directories were added, need to update+			-- the kqueue to watch them.+			let kq' = kq { kqueueMap = newmap'' }+			unless (null newdirinfos) $+				updateKqueue kq'++			return (kq', changes)+		go Nothing = do+			-- The directory has been moved or deleted, so+			-- remove it from our map.+			newmap <- removeSubDir dirmap (dirName olddirinfo)+			return (kq { kqueueMap = newmap }, [])++{- Processes changes on the Kqueue, calling the hooks as appropriate.+ - Never returns. -}+runHooks :: Kqueue -> WatchHooks -> IO ()+runHooks kq hooks = do+	-- First, synthetic add events for the whole directory tree contents,+	-- to catch any files created beforehand.+	recursiveadd (kqueueMap kq) (Added $ kqueueTop kq)+	loop kq+	where+		loop q = do+			(q', changes) <- waitChange q+			forM_ changes $ dispatch (kqueueMap q')+			loop q'+		-- Kqueue returns changes for both whole directories+		-- being added and deleted, and individual files being+		-- added and deleted.+		dispatch dirmap change+			| isAdd change = withstatus change $ dispatchadd dirmap+			| otherwise = callhook delDirHook Nothing change+		dispatchadd dirmap change s+			| Files.isSymbolicLink s =+				callhook addSymlinkHook (Just s) change+			| Files.isDirectory s = recursiveadd dirmap change+			| Files.isRegularFile s =+				callhook addHook (Just s) change+			| otherwise = noop+		recursiveadd dirmap change = do+			let contents = findDirContents dirmap $ changedFile change+			forM_ contents $ \f ->+				withstatus (Added f) $ dispatchadd dirmap+		callhook h s change = case h hooks of+			Nothing -> noop+			Just a -> a (changedFile change) s+		withstatus change a = maybe noop (a change) =<<+			(catchMaybeIO (getSymbolicLinkStatus (changedFile change)))
+ Utility/LogFile.hs view
@@ -0,0 +1,31 @@+{- log files+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.LogFile where++import Common++import System.Posix++openLog :: FilePath -> IO Fd+openLog logfile = do+	rotateLog logfile 0+	openFd logfile WriteOnly (Just stdFileMode)+		defaultFileFlags { append = True }++rotateLog :: FilePath -> Int -> IO ()+rotateLog logfile num+	| num >= 10 = return ()+	| otherwise = whenM (doesFileExist currfile) $ do+		rotateLog logfile (num + 1)+		renameFile currfile nextfile+	where+		currfile = filename num+		nextfile = filename (num + 1)+		filename n+			| n == 0 = logfile+			| otherwise = logfile ++ "." ++ show n
+ Utility/Lsof.hs view
@@ -0,0 +1,88 @@+{- lsof interface+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE BangPatterns #-}++module Utility.Lsof where++import Common++import System.Posix.Types++data LsofOpenMode = OpenReadWrite | OpenReadOnly | OpenWriteOnly | OpenUnknown+	deriving (Show, Eq)++type CmdLine = String++data ProcessInfo = ProcessInfo ProcessID CmdLine+	deriving (Show)++{- Checks each of the files in a directory to find open files.+ - Note that this will find hard links to files elsewhere that are open. -}+queryDir :: FilePath -> IO [(FilePath, LsofOpenMode, ProcessInfo)]+queryDir path = query ["+d", path]++{- Runs lsof with some parameters.+ -+ - Ignores nonzero exit code; lsof returns that when no files are open.+ -+ - Note: If lsof is not available, this always returns [] !+ -}+query :: [String] -> IO [(FilePath, LsofOpenMode, ProcessInfo)]+query opts = do+	(pid, s) <- pipeFrom "lsof" ("-F0can" : opts)+	let !r = parse s+	void $ getProcessStatus True False $ processID pid+	return r++{- Parsing null-delimited output like:+ -+ - pPID\0cCMDLINE\0+ - aMODE\0nFILE\0+ - aMODE\0nFILE\0+ - pPID\0[...]+ -+ - Where each new process block is started by a pid, and a process can+ - have multiple files open.+ -}+parse :: String -> [(FilePath, LsofOpenMode, ProcessInfo)]+parse s = bundle $ go [] $ lines s+	where+		bundle = concatMap (\(fs, p) -> map (\(f, m) -> (f, m, p)) fs)++		go c [] = c+		go c ((t:r):ls)+			| t == 'p' =+				let (fs, ls') = parsefiles [] ls+				in go ((fs, parseprocess r):c) ls'+			| otherwise = parsefail+		go _ _ = parsefail++		parseprocess l =+			case splitnull l of+				[pid, 'c':cmdline, ""] ->+					case readish pid of+						(Just n) -> ProcessInfo n cmdline+						Nothing -> parsefail+				_ -> parsefail++		parsefiles c [] = (c, [])+		parsefiles c (l:ls) = +			case splitnull l of+				['a':mode, 'n':file, ""] ->+					parsefiles ((file, parsemode mode):c) ls+				(('p':_):_) -> (c, l:ls)+				_ -> parsefail++		parsemode ('r':_) = OpenReadOnly+		parsemode ('w':_) = OpenWriteOnly+		parsemode ('u':_) = OpenReadWrite+		parsemode _ = OpenUnknown++		splitnull = split "\0"++		parsefail = error $ "failed to parse lsof output: " ++ show s
+ Utility/ThreadLock.hs view
@@ -0,0 +1,19 @@+{- locking between threads+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.ThreadLock where++import Control.Concurrent.MVar++type Lock = MVar ()++newLock :: IO Lock+newLock = newMVar ()++{- Runs an action with a lock held, so only one thread at a time can run it. -}+withLock :: Lock -> IO a -> IO a+withLock lock = withMVar lock . const
+ Utility/ThreadScheduler.hs view
@@ -0,0 +1,57 @@+{- thread scheduling+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ - Copyright 2011 Bas van Dijk & Roel van Dijk+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.ThreadScheduler where++import Common++import Control.Concurrent+import System.Posix.Terminal+import System.Posix.Signals++newtype Seconds = Seconds { fromSeconds :: Int }+	deriving (Eq, Ord, Show)++{- Runs an action repeatedly forever, sleeping at least the specified number+ - of seconds in between. -}+runEvery :: Seconds -> IO a -> IO a+runEvery n a = forever $ do+	threadDelaySeconds n+	a++threadDelaySeconds :: Seconds -> IO ()+threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond)+	where+		oneSecond = 1000000 -- microseconds++{- Like threadDelay, but not bounded by an Int.+ -+ - There is no guarantee that the thread will be rescheduled promptly when the+ - delay has expired, but the thread will never continue to run earlier than+ - specified.+ - + - Taken from the unbounded-delay package to avoid a dependency for 4 lines+ - of code.+ -}+unboundDelay :: Integer -> IO ()+unboundDelay time = do+	let maxWait = min time $ toInteger (maxBound :: Int)+	threadDelay $ fromInteger maxWait+	when (maxWait /= time) $ unboundDelay (time - maxWait)++{- Pauses the main thread, letting children run until program termination. -}+waitForTermination :: IO ()+waitForTermination = do+	lock <- newEmptyMVar+	check softwareTermination lock+	whenM (queryTerminal stdInput) $+		check keyboardSignal lock+	takeMVar lock+	where+		check sig lock = void $+			installHandler sig (CatchOnce $ putMVar lock ()) Nothing
+ Utility/Types/DirWatcher.hs view
@@ -0,0 +1,22 @@+{- generic directory watching types+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Utility.Types.DirWatcher where++import Common++type Hook a = Maybe (a -> Maybe FileStatus -> IO ())++data WatchHooks = WatchHooks+	{ addHook :: Hook FilePath+	, addSymlinkHook :: Hook FilePath+	, delHook :: Hook FilePath+	, delDirHook :: Hook FilePath+	, errHook :: Hook String -- error message+	}
Utility/libdiskfree.c view
@@ -22,23 +22,15 @@ # define STATCALL statfs /* statfs64 not yet tested on a real FreeBSD machine */ # define STATSTRUCT statfs #else-#if defined (__FreeBSD_kernel__) /* Debian kFreeBSD */-# include <sys/param.h>-# include <sys/mount.h>-# define STATCALL statfs64-# define STATSTRUCT statfs-# warning free space checking code temporarily disabled due to build failure-# define UNKNOWN-#else-#if defined (__linux__)-/* This is a POSIX standard, so might also work elsewhere. */+#if defined (__linux__) || defined (__FreeBSD_kernel__)+/* Linux or Debian kFreeBSD */+/* This is a POSIX standard, so might also work elsewhere too. */ # include <sys/statvfs.h> # define STATCALL statvfs # define STATSTRUCT statvfs #else # warning free space checking code not available for this OS # define UNKNOWN-#endif #endif #endif #endif
+ Utility/libkqueue.c view
@@ -0,0 +1,73 @@+/* kqueue interface, C mini-library+ *+ * Copyright 2012 Joey Hess <joey@kitenet.net>+ *+ * Licensed under the GNU GPL version 3 or higher.+ */++#include <stdio.h>+#include <dirent.h>+#include <fcntl.h>+#include <stdlib.h>+#include <unistd.h>+#include <sys/event.h>+#include <sys/time.h>+#include <errno.h>++/* The specified fds are added to the set of fds being watched for changes.+ * Fds passed to prior calls still take effect, so it's most efficient to+ * not pass the same fds repeatedly.+ *+ * Returns the fd that changed, or -1 on error.+ */+signed int helper(const int kq, const int fdcnt, const int *fdlist, int nodelay) {+	int i, nev;+	struct kevent evlist[1];+	struct kevent chlist[fdcnt];+	struct timespec avoiddelay = {0, 0};+	struct timespec *timeout = nodelay ? &avoiddelay : NULL;+	+	for (i = 0; i < fdcnt; i++) {+		EV_SET(&chlist[i], fdlist[i], EVFILT_VNODE,+			EV_ADD | EV_ENABLE | EV_CLEAR,+			NOTE_WRITE,+			0, 0);+	}++	nev = kevent(kq, chlist, fdcnt, evlist, 1, timeout);+	if (nev == 1)+		return evlist[0].ident;+	else+		return -1;+}++/* Initializes a new, empty kqueue. */+int init_kqueue() {+	int kq;+	if ((kq = kqueue()) == -1) {+		perror("kqueue");+		exit(1);+	}+	return kq;+}++/* Adds fds to the set that should be watched. */+void addfds_kqueue(const int kq, const int fdcnt, const int *fdlist) {+	helper(kq, fdcnt, fdlist, 1);+}++/* Waits for a change event on a kqueue. */+signed int waitchange_kqueue(const int kq) {+	return helper(kq, 0, NULL, 0);+}++/*+main () {+	int list[1];+	int kq;+	list[0]=open(".", O_RDONLY);+	kq = init_kqueue();+	addfds_kqueue(kq, 1, list)+	printf("change: %i\n", waitchange_kqueue(kq));+}+*/
+ Utility/libkqueue.h view
@@ -0,0 +1,3 @@+int init_kqueue();+void addfds_kqueue(const int kq, const int fdcnt, const int *fdlist);+signed int waitchange_kqueue(const int kq);
+ Utility/libkqueue.o view

binary file changed (absent → 1108 bytes)

− debian/.changelog.swp

binary file changed (16384 → absent bytes)

debian/changelog view
@@ -1,4 +1,16 @@-git-annex (3.20120615) unstable; urgency=medium+git-annex (3.20120624) unstable; urgency=low++  * watch: New subcommand, a daemon which notices changes to+    files and automatically annexes new files, etc, so you don't+    need to manually run git commands when manipulating files.+    Available on Linux, BSDs, and OSX!+  * Enable diskfree on kfreebsd, using kqueue.+  * unused: Fix crash when key names contain invalid utf8.+  * sync: Avoid recent git's interactive merge.++ -- Joey Hess <joeyh@debian.org>  Sun, 24 Jun 2012 12:36:50 -0400++git-annex (3.20120614) unstable; urgency=medium    * addurl: Was broken by a typo introduced 2 released ago, now fixed.     Closes: #677576
debian/control view
@@ -20,6 +20,8 @@ 	libghc-ifelse-dev, 	libghc-bloomfilter-dev, 	libghc-edit-distance-dev,+	libghc-hinotify-dev [linux-any],+	libghc-stm-dev, 	ikiwiki, 	perlmagick, 	git,@@ -40,6 +42,7 @@ 	rsync, 	wget | curl, 	openssh-client (>= 1:5.6p1)+Recommends: lsof Suggests: graphviz, bup, gnupg Description: manage files with git, without checking their contents into git  git-annex allows managing files with git, without checking the file
+ doc/bugs/git_annex_unused_aborts_due_to_filename_encoding_problems.mdwn view
@@ -0,0 +1,15 @@+What steps will reproduce the problem?+I don't know exactly when it started++What is the expected output? What do you see instead?+When I run git annex unused I get++    unused . (checking for unused data...) (checking master...) git-annex: Cannot decode byte '\xb4': Data.Text.Encoding.decodeUtf8: Invalid UTF-8 stream++Most likely I have added some file with a strange encoding that git-annex can't decode. The problem is that the unused process aborts because of this.++What version of git-annex are you using? On what operating system?+ 3.20120522, Debian testing++> I've just fixed this bug in git, will be in the next release. --[[Joey]]+> [[done]]
+ doc/bugs/watch_command_on_OSX_10.7.mdwn view
@@ -0,0 +1,37 @@+Running the tip of the watch branch on OSX in an annex'ed directory.++The watch command detects the changes, does _something_, see the output below.++Output from watch command++<pre>+(Recording state in git...)+Added "./KeePass2.18.dmg"+Added "./KeePassX-0.4.3.dmg"+add ./KeePass2.18.dmg (checksum...) ok+add ./KeePassX-0.4.3.dmg (checksum...) ok+</pre>++State of the annex++<pre>+laplace:annex jtang$ git status+# On branch master+# Untracked files:+#   (use "git add <file>..." to include in what will be committed)+#+#	KeePass2.18.dmg+#	KeePassX-0.4.3.dmg+nothing added to commit but untracked files present (use "git add" to track)+</pre>++It seems to not do a git add and commit after the creation of the symlinks, manually doing this makes it all happy again till more files are added.++note: i had posted a comment in the blog post, but posting the issue here is probably more appropriate.++> Yeah, this is the issue I was struggling with last night. +> I think it's fixed in 57cf65eb6d811ba7fd19eb62a54e3b83a0c2dfa7,+> but the kqueue watch still needs a lot of work. --[[Joey]]++>> Confirmed this is fixed, but do note the known kqueue bugs in +>> [[design/assistant/inotify]]! [[done]] --[[Joey]]
+ doc/design/assistant/blog/day_10__lsof.mdwn view
@@ -0,0 +1,54 @@+A rather frustrating and long day coding went like this:++## 1-3 pm++Wrote a single function, of which all any Haskell programmer needs to know+is its type signature:++	Lsof.queryDir :: FilePath -> IO [(FilePath, LsofOpenMode, ProcessInfo)]++When I'm spending another hour or two taking a unix utility like lsof and+parsing its output, which in this case is in a rather complicated+machine-parsable output format, I often wish unix streams were strongly+typed, which would avoid this bother.++## 3-9 pm++Six hours spent making it defer annexing files until the commit thread+wakes up and is about to make a commit. Why did it take so horribly long?+Well, there were a number of complications, and some really bad bugs+involving races that were hard to reproduce reliably enough to deal with.++In other words, I was lost in the weeds for a lot of those hours...++At one point, something glorious happened, and it was always making exactly+one commit for batch mode modifications of a lot of files (like untarring+them). Unfortunatly, I had to lose that gloriousness due to another+potential race, which, while unlikely, would have made the program deadlock+if it happened. ++So, it's back to making 2 or 3 commits per batch mode change. I also have a+buglet that causes sometimes a second empty commit after a file is added.+I know why (the inotify event for the symlink gets in late,+after the commit); will try to improve commit frequency later.++## 9-11 pm++Put the capstone on the day's work, by calling lsof on a directory full+of hardlinks to the files that are about to be annexed, to check if any+are still open for write.++This works great! Starting up `git annex watch` when processes have files+open is no longer a problem, and even if you're evil enough to try having+muliple processes open the same file, it will complain and not annex it+until all the writers close it.++(Well, someone really evil could turn the write bit back on after git annex+clears it, and open the file again, but then really evil people can do+that to files in `.git/annex/objects` too, and they'll get their just+deserts when `git annex fsck` runs. So, that's ok..)++----++Anyway, will beat on it more tomorrow, and if all is well, this will finally+go out to the beta testers.
+ doc/design/assistant/blog/day_11__freebsd.mdwn view
@@ -0,0 +1,50 @@+I've been investigating how to make `git annex watch` work on+FreeBSD, and by extension, OSX.++One option is kqueue, which works on both operating systems, and allows+very basic monitoring of file changes. There's also an OSX specific+hfsevents interface.++Kqueue is far from optimal for `git annex watch`, because it provides even+less information than inotify (which didn't really provide everything I+needed, thus the lsof hack). Kqueue doesn't have events for files being+closed, only an event when a file is created. So it will be difficult for+`git annex watch` to know when a file is done being written to and can be+annexed. git annex will probably need to run lsof periodically to check when+recently added files are complete. (hsevents shares this limitation)++Kqueue also doesn't provide specific events when a file or directory is+moved. Indeed, it doesn't provide specific events about what changed at+all. All you get with kqueue is a generic "oh hey, the directory you're+watching changed in some way", and it's up to you to scan it to work out+how. So git annex will probably need to run `git ls-tree --others`+to find changes in the directory tree. This could be expensive with large+trees. (hsevents has per-file events on current versions of OSX)++Despite these warts, I want to try kqueue first, since it's more portable+than hfsevents, and will surely be easier for me to develop support for,+since I don't have direct access to OSX.++So I went to a handy Debian kFreeBSD porter box, and tried some kqueue+stuff to get a feel for it. I got a python program that does basic+directory monitoring with kqueue to work, so I know it's usable there.++Next step was getting kqueue working from Haskell. Should be easy, there's+a Haskell library already. I spent a while trying to get it to work on+Debian kFreeBSD, but ran into a+[problem](https://github.com/hesselink/kqueue/issues/1) that could be+caused by the Debian kFreeBSD being different, or just a bug in the Haskell+library. I didn't want to spend too long shaving this yak; I might install+"real" FreeBSD on a spare laptop and try to get it working there instead.++But for now, I've dropped down to C instead, and have a simple C program+that can monitor a directory with kqueue. Next I'll turn it into a simple+library, which can easily be linked into my Haskell code. The Haskell code+will pass it a set of open directory descriptors, and it'll return the+one that it gets an event on. This is necessary because kqueue doesn't+recurse into subdirectories on its own.++I've generally had good luck with this approach to adding stuff in Haskell;+rather than writing a bit-banging and structure packing low level interface+in Haskell, write it in C, with a simpler interface between C and+Haskell.
+ doc/design/assistant/blog/day_12__freebsd_redux.mdwn view
@@ -0,0 +1,23 @@+Followed my plan from yesterday, and wrote a simple C library to interface+to `kqueue`, and Haskell code to use that library. By now I think I+understand kqueue fairly well -- there are some very tricky parts to the+interface.++But... it still did't work. After building all this, my code was+failing the same way that the+[haskell kqueue library failed](https://github.com/hesselink/kqueue/issues/1)+yesterday. I filed a [bug report with a testcase]().++Then I thought to ask on #haskell. Got sorted out in quick order! The+problem turns out to be that haskell's runtime has a peridic SIGALARM,+that is interrupting my kevent call. It can be worked around with `+RTS -V0`,+but I put in a fix to retry to kevent when it's interrupted.++And now `git-annex watch` can detect changes to directories on BSD and OSX!++Note: I said "detect", not "do something useful in response to". Getting+from the limited kqueue events to actually staging changes in the git repo+is going to be another day's work. Still, brave FreeBSD or OSX users+might want to check out the `watch` branch from git and see if +`git annex watch` will at least *say* it sees changes you make to your+repository.
+ doc/design/assistant/blog/day_13__kqueue_continued.mdwn view
@@ -0,0 +1,34 @@+Good news! My beta testers report that the new kqueue code works on OSX.+At least "works" as well as it does on Debian kFreeBSD. My crazy+development strategy of developing on Debian kFreeBSD while targeting Mac+OSX is vindicated. ;-)++So, I've been beating the kqueue code into shape for the last 12 hours,+minus a few hours sleep.++First, I noticed it was seeming to starve the other threads. I'm using+Haskell's non-threaded runtime, which does cooperative multitasking between+threads, and my C code was never returning to let the other threads run.+Changed that around, so the C code runs until SIGALARMed, and then that+thread calls `yield` before looping back into the C code. Wow, cooperative+multitasking.. I last dealt with that when programming for Windows 3.1!+(Should try to use Haskell's -threaded runtime sometime, but git-annex+doesn't work under it, and I have not tried to figure out why not.)++Then I made a [single commit](http://source.git-annex.branchable.com/?p=source.git;a=commitdiff;h=2bfcc0b09c5dd37c5e0ab65cb089232bfcc31934),+with no testing, in which I made the kqueue code maintain a cache of what+it expects in the directory tree, and use that to determine what files+changed how when a change is detected. Serious code. It worked on the+first go. If you were wondering why I'm writing in Haskell ... yeah,+that's why.++And I've continued to hammer on the kqueue code, making lots of little+fixes, and at this point it seems *almost* able to handle the changes I+throw at it. It does have one big remaining problem; kqueue doesn't tell me+when a writer closes a file, so it will sometimes miss adding files. To fix+this, I'm going to need to make it maintain a queue of new files, and+periodically check them, with `lsof`, to see when they're done being+written to, and add them to the annex. So while a file is being written+to, `git annex watch` will have to wake up every second or so, and run+`lsof` ... and it'll take it at least 1 second to notice a file's complete.+Not ideal, but the best that can be managed with kqueue.
+ doc/design/assistant/blog/day_14__kqueue_kqueue_kqueue.mdwn view
@@ -0,0 +1,23 @@+... I'm getting tired of kqueue.++But the end of the tunnel is in sight. Today I made git-annex handle files+that are still open for write after a kqueue creation event is received.+Unlike with inotify, which has a new event each time a file is closed,+kqueue only gets one event when a file is first created, and so git-annex+needs to retry adding files until there are no writers left.++Eventually I found an elegant way to do that. The committer thread already+wakes up every second as long as there's a pending change to commit. So for+adds that need to be retried, it can just push them back onto the change+queue, and the committer thread will wait one second and retry the add. One+second might be too frequent to check, but it will do for now.++This means that `git annex watch` should now be usable on OSX, FreeBSD, and+NetBSD! (It'll also work on Debian kFreeBSD once [lsof is ported to it](http://bugs.debian.org/589103).)+I've meged kqueue support to `master`.++I also think I've squashed the empty commits that were sometimes made.++Incidentally, I'm 50% through my first month, and finishing [[inotify]]+was the first half of my roadmap for this month. Seem to be right on+schedule.. Now I need to start thinking about [[syncing]].
+ doc/design/assistant/blog/day_14__thinking_about_syncing.mdwn view
@@ -0,0 +1,44 @@+Pondering [[syncing]] today. I will be doing syncing of the git repository+first, and working on syncing of file data later.++The former seems straightforward enough, since we just want to push all+changes to everywhere. Indeed, git-annex already has a [[sync]] command+that uses a smart technique to allow syncing between clones without a+central bare repository. (Props to Joachim Breitner for that.)++But it's not all easy. Syncing should happen as fast as possible, so+changes show up without delay. Eventually it'll need to support syncing+between nodes that cannot directly contact one-another. Syncing needs to+deal with nodes coming and going; one example of that is a USB drive being+plugged in, which should immediatly be synced, but network can also come+and go, so it should periodically retry nodes it failed to sync with. To+start with, I'll be focusing on fast syncing between directly connected+nodes, but I have to keep this wider problem space in mind.++One problem with `git annex sync` is that it has to be run in both clones+in order for changes to fully propigate. This is because git doesn't allow+pushing changes into a non-bare repository; so instead it drops off a new+branch in `.git/refs/remotes/$foo/synced/master`. Then when it's run locally+it merges that new branch into `master`. ++So, how to trigger a clone to run `git annex sync` when syncing to it?+Well, I just realized I have spent two weeks developing something that can+be repurposed to do that! [[Inotify]] can watch for changes to+`.git/refs/remotes`, and the instant a change is made, the local sync+process can be started. This avoids needing to make another ssh connection+to trigger the sync, so is faster and allows the data to be transferred+over another protocol than ssh, which may come in handy later.++So, in summary, here's what will happen when a new file is created:++1. inotify event causes the file to be added to the annex, and+   immediately committed.+2. new branch is pushed to remotes (probably in parallel)+3. remotes notice new sync branch and merge it+4. (data sync, TBD later)+5. file is fully synced and available++Steps 1, 2, and 3 should all be able to be accomplished in under a second.+The speed of `git push` making a ssh connection will be the main limit+to making it fast. (Perhaps I should also reuse git-annex's existing ssh+connection caching code?)
+ doc/design/assistant/blog/day_15__its_aliiive.mdwn view
@@ -0,0 +1,33 @@+Syncing works! I have two clones, and any file I create in the first+is immediately visible in the second. Delete that file from the second, and+it's immediately removed from the first.++Most of my work today felt like stitching existing limbs onto a pre-existing+monster. Took the committer thread, that waits for changes and commits them,+and refashioned it into a pusher thread, that waits for commits and pushes+them. Took the watcher thread, that watches for files being made,+and refashioned it into a merger thread, that watches for git refs being+updated. Pulled in bits of the `git annex sync` command to reanimate this.++It may be a shambling hulk, but it works.++Actually, it's not much of a shambling hulk; I refactored my code after+copying it. ;)++I think I'm up to 11 threads now in the new+`git annex assistant` command, each with its own job, and each needing+to avoid stepping on the other's toes. I did see one MVar deadlock error+today, which I have not managed to reproduce after some changes. I think+the committer thread was triggering the merger thread, which probably+then waited on the Annex state MVar the committer thread had held.++Anyway, it even pushes to remotes in parallel, and keeps track of remotes+it failed to push to, although as of yet it doesn't do any attempt at+periodically retrying.++One bug I need to deal with is that the push code assumes any change+made to the remote has already been pushed back to it. When it hasn't, +the push will fail due to not being a fast-forward. I need to make it+detect this case and pull before pushing.++(I've pushed this work out in a new `assistant branch`.)
+ doc/design/assistant/comment_8_22b818e1a2a825efb78139271a14f944._comment view
@@ -0,0 +1,10 @@+[[!comment format=mdwn+ username="https://www.google.com/accounts/o8/id?id=AItOawldKnauegZulM7X6JoHJs7Gd5PnDjcgx-E"+ nickname="Matt"+ subject="Homebrew instead of MacPorts"+ date="2012-06-22T04:26:02Z"+ content="""+[Homebrew] is a much better package manager than MacPorts IMO.++[Homebrew]: http://mxcl.github.com/homebrew/+"""]]
doc/design/assistant/inotify.mdwn view
@@ -1,58 +1,68 @@-Finish "git annex watch" command, which runs, in the background, watching via-inotify for changes, and automatically annexing new files, etc.+"git annex watch" command, which runs, in the background, watching via+inotify for changes, and automatically annexing new files, etc. Now+available! -There is a `watch` branch in git that adds the command.+[[!toc]]  ## known bugs -* A process has a file open for write, another one closes it,-  and so it's added. Then the first process modifies it.+* 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]] -  Or, a process has a file open for write when `git annex watch` starts-  up, it will be added to the annex. If the process later continues-  writing, it will change content in the annex.+* When you `git annex unlock` a file, it will immediately be re-locked. -  This changes content in the annex, and fsck will later catch-  the inconsistency.+* Kqueue has to open every directory it watches, so too many directories+  will run it out of the max number of open files (typically 1024), and fail.+  I may need to fork off multiple watcher processes to handle this. -  Possible fixes: +## beyond Linux -  * Somehow track or detect if a file is open for write by any processes.-    `lsof` could be used, although it would be a little slow.+I'd also like to support OSX and if possible the BSDs. -    Here's one way to avoid the slowdown: When a file is being added,-    set it read-only, and hard-link it into a quarantine directory,-    remembering both filenames.-    Then use the batch change mode code to detect batch adds and bundle-    them together.-    Just before committing, lsof the quarantine directory. Any files in-    it that are still open for write can just have their write bit turned-    back on and be deleted from quarantine, to be handled when their writer-    closes. Files that pass quarantine get added as usual. This avoids-    repeated lsof calls slowing down adds, but does add a constant factor-    overhead (0.25 seconds lsof call) before any add gets committed.+* kqueue ([haskell bindings](http://hackage.haskell.org/package/kqueue))+  is supported by FreeBSD, OSX, and other BSDs. -  * Or, when possible, making a copy on write copy before adding the file-    would avoid this.-  * Or, as a last resort, make an expensive copy of the file and add that.-  * Tracking file opens and closes with inotify could tell if any other-    processes have the file open. But there are problems.. It doesn't-    seem to differentiate between files opened for read and for write.-    And there would still be a race after the last close and before it's-    injected into the annex, where it could be opened for write again.-    Would need to detect that and undo the annex injection or something.+  In kqueue, to watch for changes to a file, you have to have an open file+  descriptor to the file. This wouldn't scale.  -* 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]]+  Apparently, a directory can be watched, and events are generated when+  files are added/removed from it. You then have to scan to find which+  files changed. [example](https://developer.apple.com/library/mac/#samplecode/FileNotification/Listings/Main_c.html#//apple_ref/doc/uid/DTS10003143-Main_c-DontLinkElementID_3) -* When you `git annex unlock` a file, it will immediately be re-locked.+  Gamin does the best it can with just kqueue, supplimented by polling.+  The source file `server/gam_kqueue.c` makes for interesting reading.+  Using gamin to do the heavy lifting is one option. +  ([haskell bindings](http://hackage.haskell.org/package/hlibfam) for FAM;+  gamin shares the API) +  kqueue does not seem to provide a way to tell when a file gets closed,+  only when it's initially created. Poses problems..++  * [man page](http://www.freebsd.org/cgi/man.cgi?query=kqueue&apropos=0&sektion=0&format=html)+  * <https://github.com/gorakhargosh/watchdog/blob/master/src/watchdog/observers/kqueue.py> (good example program)++* hfsevents ([haskell bindings](http://hackage.haskell.org/package/hfsevents))+  is OSX specific.++  Originally it was only directory level, and you were only told a+  directory had changed and not which file. Based on the haskell+  binding's code, from OSX 10.7.0, file level events were added.++  This will be harder for me to develop for, since I don't have access to+  OSX machines..++  hfsevents does not seem to provide a way to tell when a file gets closed,+  only when it's initially created. Poses problems..++  * <https://developer.apple.com/library/mac/#documentation/Darwin/Conceptual/FSEvents_ProgGuide/Introduction/Introduction.html>+  * <http://pypi.python.org/pypi/MacFSEvents/0.2.8> (good example program)+  * <https://github.com/gorakhargosh/watchdog/blob/master/src/watchdog/observers/fsevents.py> (good example program)++* Windows has a Win32 ReadDirectoryChangesW, and perhaps other things.+ ## todo -- Support OSes other than Linux; it only uses inotify currently.-  OSX and FreeBSD use the same mechanism, and there is a Haskell interface-  for it, - Run niced and ioniced? Seems to make sense, this is a background job. - configurable option to only annex files meeting certian size or   filename criteria@@ -140,3 +150,40 @@ - coleasce related add/rm events for speed and less disk IO **done** - don't annex `.gitignore` and `.gitattributes` files **done** - run as a daemon **done**+- A process has a file open for write, another one closes it,+  and so it's added. Then the first process modifies it.++  Or, a process has a file open for write when `git annex watch` starts+  up, it will be added to the annex. If the process later continues+  writing, it will change content in the annex.++  This changes content in the annex, and fsck will later catch+  the inconsistency.++  Possible fixes: ++  * Somehow track or detect if a file is open for write by any processes.+    `lsof` could be used, although it would be a little slow.++    Here's one way to avoid the slowdown: When a file is being added,+    set it read-only, and hard-link it into a quarantine directory,+    remembering both filenames.+    Then use the batch change mode code to detect batch adds and bundle+    them together.+    Just before committing, lsof the quarantine directory. Any files in+    it that are still open for write can just have their write bit turned+    back on and be deleted from quarantine, to be handled when their writer+    closes. Files that pass quarantine get added as usual. This avoids+    repeated lsof calls slowing down adds, but does add a constant factor+    overhead (0.25 seconds lsof call) before any add gets committed. **done**++  * Or, when possible, making a copy on write copy before adding the file+    would avoid this.+  * Or, as a last resort, make an expensive copy of the file and add that.+  * Tracking file opens and closes with inotify could tell if any other+    processes have the file open. But there are problems.. It doesn't+    seem to differentiate between files opened for read and for write.+    And there would still be a race after the last close and before it's+    injected into the annex, where it could be opened for write again.+    Would need to detect that and undo the annex injection or something.+
doc/design/assistant/syncing.mdwn view
@@ -3,13 +3,24 @@  ## git syncing -1. At regular intervals, just run `git annex sync`, which already handles-   bidirectional syncing.+1. Can use `git annex sync`, which already handles bidirectional syncing.+   When a change is committed, launch the part of `git annex sync` that pushes+   out changes. **done**; changes are pushed out to all remotes in parallel+1. Watch `.git/refs/remotes/` for changes (which would be pushed in from+   another node via `git annex sync`), and run the part of `git annex sync`+   that merges in received changes, and follow it by the part that pushes out+   changes (sending them to any other remotes).+   [The watching can be done with the existing inotify code! This avoids needing+   any special mechanism to notify a remote that it's been synced to.]  +   **done**+1. Periodically retry pushes that failed. Also, detect if a push failed+   due to not being up-to-date, pull, and repush. 2. Use a git merge driver that adds both conflicting files,    so conflicts never break a sync. 3. Investigate the XMPP approach like dvcs-autosync does, or other ways of    signaling a change out of band.-4. Add a hook, so when there's a change to sync, a program can be run.+4. Add a hook, so when there's a change to sync, a program can be run+   and do its own signaling.  ## data syncing
+ doc/forum/Wishlist:_automatic_reinject.mdwn view
@@ -0,0 +1,14 @@+I think it would be useful to supplement the `reinject` command with an automatic+mode which calculates the checksum of the source file and injects the file if it+is known to the repository (without the need to provide a destination filename).+In addition, this could be done recursively if the user provides a directory to+inject. All this can probably be done already with some plumbing, but a simple+`reinject --auto` (or `scour`, or `scavenge`, if you like) would be a nice addition.+Of course this would only work for the checksum backends.++Example use cases would be:++* Recovering data from lost+found easily+* Making use of old (pre-git-annex) archival volumes with useful files+  scattered among non-useful files+* Sneaker-netting files between disconnected git-annex repositories
doc/forum/autobuilders_for_git-annex_to_aid_development.mdwn view
@@ -31,4 +31,4 @@ fi </pre> -It's also using the branches-local script for sorting and prioritising the branches to build, this branches-local script can be found at the [autobuild-ceph](https://github.com/ceph/autobuild-ceph/blob/master/branches-local) repository. If there are other people interested in setting up their own instances of gitbuilder for git-annex, please let me know and I will setup an aggregator page to collect status of the builds. The builder runs and updates the webpage every 30mins.+It's also using the branches-local script for sorting and prioritising the branches to build, this branches-local script can be found at the [autobuild-ceph](https://github.com/ceph/autobuild-ceph/blob/master/branches-local) repository. If there are other people interested in setting up their own instances of gitbuilder for git-annex, please let me know and I will setup an aggregator page to collect status of the builds. The builder runs and updates on a very regular basis.
+ doc/forum/exporting_annexed_files.mdwn view
@@ -0,0 +1,4 @@+Is there an easy way to export annexed files out of the repository? (e.g. to make a copy elsewhere, send a file by email...)++Thanks,+Denis.
doc/git-annex.mdwn view
@@ -169,6 +169,17 @@  	git annex import /media/camera/DCIM/ +* watch++  Watches for changes to files in the current directory and its subdirectories,+  and takes care of automatically adding new files, as well as dealing with+  deleted, copied, and moved files. With this running as a daemon in the+  background, you no longer need to manually run git commands when+  manipulating your files.++  To not daemonize, run with --foreground ; to stop a running daemon,+  run with --stop+ # REPOSITORY SETUP COMMANDS  * init [description]
doc/install.mdwn view
@@ -10,6 +10,7 @@ * [[NixOS]] * [[Gentoo]] * Windows: [[sorry, not possible yet|todo/windows_support]]+* [[ScientificLinux5]] - This should cover RHEL5 clones such as CentOS5 and so on  ## Using cabal @@ -41,6 +42,9 @@   * [IfElse](http://hackage.haskell.org/package/IfElse)   * [bloomfilter](http://hackage.haskell.org/package/bloomfilter)   * [edit-distance](http://hackage.haskell.org/package/edit-distance)+  * [stm](http://hackage.haskell.org/package/stm)+  * [hinotify](http://hackage.haskell.org/package/hinotify)+    (optional; Linux only) * Shell commands   * [git](http://git-scm.com/)   * [uuid](http://www.ossp.org/pkg/lib/uuid/)@@ -51,6 +55,8 @@   * [sha1sum](ftp://ftp.gnu.org/gnu/coreutils/) (optional, but recommended;     a sha1 command will also do)   * [gpg](http://gnupg.org/) (optional; needed for encryption)+  * [lsof](ftp://lsof.itap.purdue.edu/pub/tools/unix/lsof/)+    (optional; recommended for watch mode)   * [ikiwiki](http://ikiwiki.info) (optional; used to build the docs)  Then just [[download]] git-annex and run: `make; make install`
+ doc/install/OSX/comment_7_2ce7acab15403d3f993cec94ec7f3bc6._comment view
@@ -0,0 +1,14 @@+[[!comment format=mdwn+ username="http://www.davidhaslem.com/"+ nickname="David"+ subject="comment 7"+ date="2012-06-19T04:41:27Z"+ content="""+$(brew --prefix) should, in most cases, be /usr/local.  That's the recommended install location for homebrew.++I already had git installed and homebrew as my package manager - my install steps were as follows:++1. brew install haskell-platform ossp-uuid md5sha1sum coreutils pcre+2. PATH=\"$(brew --prefix coreutils)/libexec/gnubin:$PATH\" cabal install git-annex++"""]]
+ doc/install/ScientificLinux5.mdwn view
@@ -0,0 +1,72 @@+I was waiting for my backups to be done hence this article, as I was using+_git-annex_ to manage my files and I decided I needed to have+git-annex on a SL5 based machine. SL5 is just an opensource+clone/recompile of RHEL5.++I haven't tried to install the newer versions of Haskell Platform and+GHC in a while on SL5 to install git-annex. But the last time I checked+when GHC7 was out, it was a pain to install GHC on SL5.++However I have discovered that someone has gone through the trouble of+packaging up GHC and Haskell Platform for RHEL based distros.++* <http://justhub.org/download> - Packaged GHC and Haskell Platform+  RPM's for RHEL based systems.++I'm primarily interested in installing _git-annex_ on SL5 based+systems. The installation process goes as such...++First install GHC and Haskell Platform (you need root for these+following steps)++    $ wget http://sherkin.justhub.org/el5/RPMS/x86_64/justhub-release-2.0-4.0.el5.x86_64.rpm+    $ rpm -ivh justhub-release-2.0-4.0.el5.x86_64.rpm+    $ yum install haskell++The RPM's don't place the files in /usr/bin, so you must add the+following to your .bashrc (from here on you don't need root if you+don't want things to be system wide)++    $ export PATH=/usr/hs/bin:$PATH++On SL5 pcre is at version 6.6 which is far too old for one of the+dependancies that git-annex requires. Therefore the user must install+an updated version of _pcre_ either from source or another method, I+chose to install it from source and by hand into /usr/local++    $ wget http://sourceforge.net/projects/pcre/files/pcre/8.30/pcre-8.30.tar.gz/download+    $ tar zxvf pcre-8.30.tar.gz+    $ cd pcre-8.30+    $ ./configure+    $ make && make install++Once the packages are installed and are in your execution path, using+cabal to configure and build git-annex just makes life easier, it+should install all the needed dependancies.++    $ cabal update+    $ cabal install pcre-light --extra-include-dirs=/usr/local/include+    $ git clone git://git.kitenet.net/git-annex+    $ cd git-annex+    $ make git-annex.1+    $ cabal configure+    $ cabal build+    $ cabal install++Or if you want to install it globallly for everyone (otherwise it will+get installed into $HOME/.cabal/bin)++    $ cabal install --global++The above will take a while to compile and install the needed+dependancies. I would suggest any user who does should run the tests+that comes with git-annex to make sure everything is functioning as+expected.++I haven't had a chance or need to install git-annex on a SL6 based+system yet, but I would assume something similar to the above steps+would be required to do so.++The above is almost a cut and paste of <http://jcftang.github.com/2012/06/15/installing-git-annex-on-sl5/>, the above could probably be refined, it was what worked for me on SL5. Please feel free to re-edit and chop out or add useless bits of text in the above!++Note: from the minor testing, it appears the compiled binaries from SL5 will work on SL6.
− doc/news/version_3.20120511.mdwn 
@@ -1,13 +0,0 @@-git-annex 3.20120511 released with [[!toggle text="these changes"]]-[[!toggleable text="""-   * Rsync special remotes can be configured with shellescape=no-     to avoid shell quoting that is normally done when using rsync over ssh.-     This is known to be needed for certian rsync hosting providers-     (specificially hidrive.strato.com) that use rsync over ssh but do not-     pass it through the shell.-   * dropunused: Allow specifying ranges to drop.-   * addunused: New command, the opposite of dropunused, it relinks unused-     content into the git repository.-   * Fix use of several config settings: annex.ssh-options,-     annex.rsync-options, annex.bup-split-options. (And adjust types to avoid-     the bugs that broke several config settings.)"""]]
− doc/news/version_3.20120522.mdwn 
@@ -1,7 +0,0 @@-git-annex 3.20120522 released with [[!toggle text="these changes"]]-[[!toggleable text="""-   * Pass -a to cp even when it supports --reflink=auto, to preserve-     permissions.-   * Clean up handling of git directory and git worktree.-   * Add support for core.worktree, and fix support for GIT\_WORK\_TREE and-     GIT\_DIR."""]]
+ doc/news/version_3.20120624.mdwn view
@@ -0,0 +1,9 @@+git-annex 3.20120624 released with [[!toggle text="these changes"]]+[[!toggleable text="""+   * watch: New subcommand, a daemon which notices changes to+     files and automatically annexes new files, etc, so you don't+     need to manually run git commands when manipulating files.+     Available on Linux, BSDs, and OSX!+   * Enable diskfree on kfreebsd, using kqueue.+   * unused: Fix crash when key names contain invalid utf8.+   * sync: Avoid recent git's interactive merge."""]]
git-annex.1 view
@@ -154,6 +154,16 @@ .IP  git annex import /media/camera/DCIM/ .IP+.IP "watch"+Watches for changes to files in the current directory and its subdirectories,+and takes care of automatically adding new files, as well as dealing with+deleted, copied, and moved files. With this running as a daemon in the+background, you no longer need to manually run git commands when+manipulating your files.+.IP+To not daemonize, run with \-\-foreground ; to stop a running daemon,+run with \-\-stop+.IP .SH REPOSITORY SETUP COMMANDS .IP "init [description]" .IP
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 3.20120615+Version: 3.20120624 Cabal-Version: >= 1.8 License: GPL Maintainer: Joey Hess <joey@kitenet.net>@@ -28,13 +28,16 @@ Flag S3   Description: Enable S3 support +Flag Inotify+  Description: Enable inotify support+ Executable git-annex   Main-Is: git-annex.hs   Build-Depends: MissingH, hslogger, directory, filepath,    unix, containers, utf8-string, network, mtl, bytestring, old-locale, time,    pcre-light, extensible-exceptions, dataenc, SHA, process, json, HTTP,    base == 4.5.*, monad-control, transformers-base, lifted-base,-   IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance+   IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, stm   -- Need to list this because it's generated from a .hsc file.   Other-Modules: Utility.Touch   C-Sources: Utility/libdiskfree.c@@ -44,6 +47,10 @@     Build-Depends: hS3     CPP-Options: -DWITH_S3 +  if flag(Inotify)+    Build-Depends: hinotify+    CPP-Options: -DWITH_INOTIFY+ Test-Suite test   Type: exitcode-stdio-1.0   Main-Is: test.hs@@ -51,7 +58,7 @@    unix, containers, utf8-string, network, mtl, bytestring, old-locale, time,    pcre-light, extensible-exceptions, dataenc, SHA, process, json, HTTP,    base == 4.5.*, monad-control, transformers-base, lifted-base,-   IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance+   IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, stm   Other-Modules: Utility.Touch   C-Sources: Utility/libdiskfree.c   Extensions: CPP
git-union-merge.hs view
@@ -28,7 +28,7 @@ setup = cleanup -- idempotency  cleanup :: Git.Repo -> IO ()-cleanup g = whenM (doesFileExist $ tmpIndex g) $ removeFile $ tmpIndex g+cleanup g = nukeFile $ tmpIndex g  parseArgs :: IO [String] parseArgs = do
make-sdist.sh view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/bin/sh # # Workaround for `cabal sdist` requiring all included files to be listed # in .cabal.
test.hs view
@@ -28,6 +28,7 @@ import qualified Git.CurrentRepo import qualified Git.Filename import qualified Locations+import qualified Types.KeySource import qualified Types.Backend import qualified Types import qualified GitAnnex@@ -172,7 +173,7 @@ 	git_annex "drop" ["--force", sha1annexedfile] @? "drop failed" 	writeFile tmp $ content sha1annexedfile 	r <- annexeval $ Types.Backend.getKey backendSHA1 $-		Types.Backend.KeySource { Types.Backend.keyFilename = tmp, Types.Backend.contentLocation = tmp }+		Types.KeySource.KeySource { Types.KeySource.keyFilename = tmp, Types.KeySource.contentLocation = tmp } 	let key = show $ fromJust r 	git_annex "reinject" [tmp, sha1annexedfile] @? "reinject failed" 	git_annex "fromkey" [key, sha1annexedfiledup] @? "fromkey failed"