direct mode committing

Annex/CatFile.hs

@@ -9,6 +9,7 @@ module Annex.CatFile (
 	catFile,
 	catObject,
 	catObjectDetails,
+	catKey,
 	catFileHandle
 ) where
 
@@ -42,3 +43,7 @@ catFileHandle = maybe startup return =<< Annex.getState Annex.catfilehandle
 			h <- inRepo Git.CatFile.catFileStart
 			Annex.changeState $ \s -> s { Annex.catfilehandle = Just h }
 			return h
+
+{- From the Sha of a symlink back to the key. -}
+catKey :: Sha -> Annex (Maybe Key)
+catKey sha = fileKey . takeFileName . encodeW8 . L.unpack  <$> catObject sha

Annex/Content.hs

@@ -10,7 +10,6 @@ module Annex.Content (
 	inAnnexSafe,
 	lockContent,
 	calcGitLink,
-	logStatus,
 	getViaTmp,
 	getViaTmpUnchecked,
 	withTmp,
@@ -33,7 +32,6 @@ import System.IO.Unsafe (unsafeInterleaveIO)
 
 import Common.Annex
 import Logs.Location
-import Annex.UUID
 import qualified Git
 import qualified Git.Config
 import qualified Annex
@@ -132,13 +130,6 @@ calcGitLink file key = do
 	where
 		whoops = error $ "unable to normalize " ++ file
 
-{- Updates the Logs.Location when a key's presence changes in the current
- - repository. -}
-logStatus :: Key -> LogStatus -> Annex ()
-logStatus key status = do
-	u <- getUUID
-	logChange key u status
-
 {- Runs an action, passing it a temporary filename to get,
  - and if the action succeeds, moves the temp file into 
  - the annex as a key's content. -}

Annex/Content/Direct.hs

@@ -7,13 +7,18 @@
 
 module Annex.Content.Direct (
 	associatedFiles,
-	changeAssociatedFiles,
+	removeAssociatedFile,
+	addAssociatedFile,
 	updateAssociatedFiles,
 	goodContent,
 	updateCache,
 	recordedCache,
 	compareCache,
-	removeCache
+	writeCache,
+	removeCache,
+	genCache,
+	toCache,
+	Cache
 ) where
 
 import Common.Annex
@@ -23,9 +28,9 @@ import Git.Sha
 import Annex.CatFile
 import Utility.TempFile
 import Utility.FileMode
+import Logs.Location
 
 import System.Posix.Types
-import qualified Data.ByteString.Lazy as L
 
 {- Files in the tree that are associated with a key. -}
 associatedFiles :: Key -> Annex [FilePath]
@@ -42,19 +47,24 @@ associatedFilesRelative key = do
 	liftIO $ catchDefaultIO [] $ lines <$> readFile mapping
 
 {- Changes the associated files information for a key, applying a
- - transformation to the list. -}
-changeAssociatedFiles :: Key -> ([FilePath] -> [FilePath]) -> Annex ()
+ - transformation to the list. Returns a copy of the new info. -}
+changeAssociatedFiles :: Key -> ([FilePath] -> [FilePath]) -> Annex [FilePath]
 changeAssociatedFiles key transform = do
 	mapping <- inRepo $ gitAnnexMapping key
 	files <- associatedFilesRelative key
 	let files' = transform files
 	when (files /= files') $
 		liftIO $ viaTmp writeFile mapping $ unlines files'
+	return files'
 
-removeAssociatedFile :: Key -> FilePath -> Annex ()
-removeAssociatedFile key file = changeAssociatedFiles key $ filter (/= file)
+removeAssociatedFile :: Key -> FilePath -> Annex [FilePath]
+removeAssociatedFile key file = do
+	fs <- changeAssociatedFiles key $ filter (/= file)
+	when (null fs) $
+		logStatus key InfoMissing
+	return fs
 
-addAssociatedFile :: Key -> FilePath -> Annex ()
+addAssociatedFile :: Key -> FilePath -> Annex [FilePath]
 addAssociatedFile key file = changeAssociatedFiles key $ \files ->
 	if file `elem` files
 		then files
@@ -74,10 +84,8 @@ updateAssociatedFiles oldsha newsha = do
 	  where
 		go getsha getmode a =
 			when (getsha item /= nullSha && isSymLink (getmode item)) $ do
-				key <- getkey $ getsha item
-				maybe noop (\k -> a k $ DiffTree.file item) key
-		getkey sha = fileKey . takeFileName . encodeW8 . L.unpack
-			<$> catObject sha
+				key <- catKey (getsha item)
+				maybe noop (\k -> void $ a k $ DiffTree.file item) key
 
 {- Checks if a file in the tree, associated with a key, has not been modified.
  -
@@ -103,10 +111,13 @@ compareCache file old = do
 
 {- Stores a cache of attributes for a file that is associated with a key. -}
 updateCache :: Key -> FilePath -> Annex ()
-updateCache key file = do
-	withCacheFile key $ \cachefile -> do
-		createDirectoryIfMissing True (parentDir cachefile)
-		maybe noop (writeFile cachefile . showCache) =<< genCache file
+updateCache key file = maybe noop (writeCache key) =<< liftIO (genCache file)
+
+{- Writes a cache for a key. -}
+writeCache :: Key -> Cache -> Annex ()
+writeCache key cache = withCacheFile key $ \cachefile -> do
+	createDirectoryIfMissing True (parentDir cachefile)
+	writeFile cachefile $ showCache cache
 
 {- Removes a cache. -}
 removeCache :: Key -> Annex ()
@@ -115,7 +126,7 @@ removeCache key = withCacheFile key nukeFile
 {- Cache a file's inode, size, and modification time to determine if it's
  - been changed. -}
 data Cache = Cache FileID FileOffset EpochTime
-  deriving (Eq)
+  deriving (Eq, Show)
 
 showCache :: Cache -> String
 showCache (Cache inode size mtime) = unwords

Annex/Direct.hs

@@ -0,0 +1,105 @@
+{- git-annex direct mode
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Direct where
+
+import Common.Annex
+import qualified Git
+import qualified Git.LsFiles
+import qualified Git.UpdateIndex
+import qualified Git.HashObject
+import qualified Annex.Queue
+import Git.Types
+import Annex.CatFile
+import Logs.Location
+import Backend
+import Types.KeySource
+import Annex.Content
+import Annex.Content.Direct
+
+{- Uses git ls-files to find files that need to be committed, and stages
+ - them into the index. Returns True if some changes were staged. -}
+stageDirect :: Annex Bool
+stageDirect = do
+	Annex.Queue.flush
+	top <- fromRepo Git.repoPath
+	(l, cleanup) <- inRepo $ Git.LsFiles.stagedDetails [top]
+	forM_ l go
+	void $ liftIO cleanup
+	staged <- Annex.Queue.size
+	Annex.Queue.flush
+	return $ staged /= 0
+  where
+	{- Determine what kind of modified or deleted file this is, as
+	 - efficiently as we can, by getting any key that's associated
+	 - with it in git, as well as its stat info. -}
+	go (file, Just sha) = do
+		mkey <- catKey sha
+		mstat <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file
+		case (mkey, mstat, toCache =<< mstat) of
+			(Just key, _, Just cache) -> do
+				{- All direct mode files will show as
+				 - modified, so compare the cache to see if
+				 - it really was. -}
+				oldcache <- recordedCache key
+				when (oldcache /= Just cache) $
+					modifiedannexed file key cache
+			(Just key, Nothing, _) -> deletedannexed file key
+			(Nothing, Nothing, _) -> deletegit file
+			(_, Just _, _) -> addgit file
+	go (file, Nothing) = do
+		mstat <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file
+		case (mstat, toCache =<< mstat) of
+			(Nothing, _) -> noop
+			(Just stat, Just cache)
+				| isSymbolicLink stat -> addgit file
+				| otherwise -> void $ addDirect file cache
+			(Just stat, Nothing)
+				| isSymbolicLink stat -> addgit file
+				| otherwise -> noop
+
+	modifiedannexed file oldkey cache = do
+		void $ removeAssociatedFile oldkey file
+		void $ addDirect file cache
+	
+	deletedannexed file key = do
+		void $ removeAssociatedFile key file
+		deletegit file
+	
+	addgit file = Annex.Queue.addCommand "add" [Param "-f"] [file]
+
+	deletegit file = Annex.Queue.addCommand "rm" [Param "-f"] [file]
+
+{- Adds a file to the annex in direct mode. Can fail, if the file is
+ - modified or deleted while it's being added. -}
+addDirect :: FilePath -> Cache -> Annex Bool
+addDirect file cache = do
+	showStart "add" file
+	let source = KeySource
+		{ keyFilename = file
+		, contentLocation = file
+		}
+	got =<< genKey source =<< chooseBackend file
+  where
+	got Nothing = do
+		showEndFail
+		return False
+	got (Just (key, _)) = ifM (compareCache file $ Just cache)
+		( do
+			link <- calcGitLink file key
+			sha <- inRepo $ Git.HashObject.hashObject BlobObject link
+			Annex.Queue.addUpdateIndex =<<
+				inRepo (Git.UpdateIndex.stageSymlink file sha)
+			writeCache key cache
+			void $ addAssociatedFile key file
+			logStatus key InfoPresent
+			showEndOk
+			return True
+		, do
+			showEndFail
+			return False
+		)

Backend.hs

@@ -52,8 +52,7 @@ orderedList = do
 	parseBackendList s = map lookupBackendName $ words s
 
 {- Generates a key for a file, trying each backend in turn until one
- - accepts it.
- -}
+ - accepts it. -}
 genKey :: KeySource -> Maybe Backend -> Annex (Maybe (Key, Backend))
 genKey source trybackend = do
 	bs <- orderedList
@@ -94,8 +93,7 @@ lookupFile file = do
 				return Nothing
 
 {- Looks up the backend that should be used for a file.
- - That can be configured on a per-file basis in the gitattributes file.
- -}
+ - That can be configured on a per-file basis in the gitattributes file. -}
 chooseBackend :: FilePath -> Annex (Maybe Backend)
 chooseBackend f = Annex.getState Annex.forcebackend >>= go
   where

Command/Sync.hs

@@ -16,6 +16,7 @@ import qualified Annex.Branch
 import qualified Annex.Queue
 import Annex.Content
 import Annex.Content.Direct
+import Annex.Direct
 import Annex.CatFile
 import qualified Git.Command
 import qualified Git.LsFiles as LsFiles
@@ -29,7 +30,6 @@ import qualified Remote.Git
 import Types.Key
 import Config
 
-import qualified Data.ByteString.Lazy as L
 import Data.Hash.MD5
 
 def :: [Command]
@@ -79,14 +79,20 @@ syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted )
 	fastest = fromMaybe [] . headMaybe . Remote.byCost
 
 commit :: CommandStart
-commit = do
-	showStart "commit" ""
-	next $ next $ do
+commit = next $ next $ do
+	Annex.Branch.commit "update"
+	ifM isDirect
+		( ifM stageDirect
+			( runcommit [] , return True )
+		, runcommit [Param "-a"]
+		)
+  where
+	runcommit ps = do
+		showStart "commit" ""
 		showOutput
-		Annex.Branch.commit "update"
 		-- Commit will fail when the tree is clean, so ignore failure.
-		_ <- inRepo $ Git.Command.runBool "commit"
-			[Param "-a", Param "-m", Param "git-annex automatic sync"]
+		_ <- inRepo $ Git.Command.runBool "commit" $ ps ++
+			[Param "-m", Param "git-annex automatic sync"]
 		return True
 
 mergeLocal :: Git.Ref -> CommandStart
@@ -136,7 +142,7 @@ mergeRemote remote b = case b of
 	Nothing -> do
 		branch <- inRepo Git.Branch.currentUnsafe
 		all id <$> (mapM merge $ branchlist branch)
-	Just branch -> all id <$> (mapM merge =<< tomerge (branchlist b))
+	Just _ -> all id <$> (mapM merge =<< tomerge (branchlist b))
   where
 	merge = mergeFrom . remoteBranch remote
 	tomerge branches = filterM (changed remote) branches
@@ -259,9 +265,7 @@ resolveMerge' u
 		case msha of
 			Nothing -> a Nothing
 			Just sha -> do
-				key <- fileKey . takeFileName
-					. encodeW8 . L.unpack 
-					<$> catObject sha
+				key <- catKey sha
 				maybe (return False) (a . Just) key
 
 {- The filename to use when resolving a conflicted merge of a file,

Git/LsFiles.hs

@@ -10,7 +10,7 @@ module Git.LsFiles (
 	notInRepo,
 	staged,
 	stagedNotDeleted,
-	notStaged,
+	stagedDetails,
 	typeChanged,
 	typeChangedStaged,
 	Conflicting(..),
@@ -53,13 +53,21 @@ staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix
 	prefix = [Params "diff --cached --name-only -z"]
 	suffix = Param "--" : map File l
 
-{- Returns a list of all files that have unstaged changes. This includes
- - any new files, that have not been added yet. -}
-notStaged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
-notStaged l repo = pipeNullSplit params repo
+{- Returns details about files that are staged in the index
+ - (including the Sha of their staged contents),
+ - as well as files not yet in git. -}
+stagedDetails :: [FilePath] -> Repo -> IO ([(FilePath, Maybe Sha)], IO Bool)
+stagedDetails l repo = do
+	(ls, cleanup) <- pipeNullSplit params repo
+	return (map parse ls, cleanup)
   where
-	params = [Params "ls-files --others --deleted --modified --exclude-standard -z --"] ++
+	params = [Params "ls-files --others --exclude-standard --stage -z --"] ++
 		map File l
+	parse s
+		| null file = (s, Nothing)
+		| otherwise = (file, extractSha $ take shaSize $ drop 7 metadata)
+	  where
+		(metadata, file) = separate (== '\t') s
 
 {- Returns a list of the files in the specified locations that are staged
  - for commit, and whose type has changed. -}

Logs/Location.hs

@@ -15,6 +15,7 @@
 
 module Logs.Location (
 	LogStatus(..),
+	logStatus,
 	logChange,
 	loggedLocations,
 	loggedKeys,
@@ -26,6 +27,13 @@ module Logs.Location (
 import Common.Annex
 import qualified Annex.Branch
 import Logs.Presence
+import Annex.UUID
+
+{- Log a change in the presence of a key's value in current repository. -}
+logStatus :: Key -> LogStatus -> Annex ()
+logStatus key status = do
+	u <- getUUID
+	logChange key u status
 
 {- Log a change in the presence of a key's value in a repository. -}
 logChange :: Key -> UUID -> LogStatus -> Annex ()

Remote.hs

@@ -51,7 +51,7 @@ import qualified Annex
 import Annex.UUID
 import Logs.UUID
 import Logs.Trust
-import Logs.Location
+import Logs.Location hiding (logStatus)
 import Remote.List
 import qualified Git
 

Remote/Git.hs

@@ -37,6 +37,7 @@ import Config
 import Init
 import Types.Key
 import qualified Fields
+import Logs.Location
 
 import Control.Concurrent
 import Control.Concurrent.MSampleVar
@@ -243,7 +244,7 @@ dropKey r key
 			whenM (Annex.Content.inAnnex key) $ do
 				Annex.Content.lockContent key $
 					Annex.Content.removeAnnex key
-				Annex.Content.logStatus key InfoMissing
+				logStatus key InfoMissing
 				Annex.Content.saveState True
 			return True
 	| Git.repoIsHttp r = error "dropping from http repo not supported"

doc/direct_mode.mdwn

@@ -20,11 +20,9 @@ deleted or modified at any time). To do so: `git annex untrust .`
 
 ## use a direct mode repository
 
-You can use `git annex add` to add files to your direct mode repository.
-
-The main command that's supported in direct mode repositories is
-`git annex sync`. This automatically commits all changed files to git,
-pushes them out, pulls down any changes, etc.
+The main command that's used in direct mode repositories is
+`git annex sync`. This automatically adds new files, commits all
+changed files to git, pushes them out, pulls down any changes, etc.
 
 You can also run `git annex get` to transfer the content of files into your
 direct mode repository. Or if the direct mode repository is a remote of
@@ -39,6 +37,9 @@ You can use `git log` and other git query commands.
 
 ## what doesn't work in direct mode
 
+Don't use `git annex add` -- it thinks all direct mode files are unlocked,
+and locks them.
+
 In general git-annex commands will only work in direct mode repositories on
 files whose content is not present. That's because such files are still 
 represented as symlinks, which git-annex commands know how to operate on.