crazy optimisation

Crazy like a fox..

Annex/CatFile.hs

@@ -8,6 +8,7 @@
 module Annex.CatFile (
 	catFile,
 	catObject,
+	catObjectDetails,
 	catFileHandle
 ) where
 
@@ -17,6 +18,7 @@ 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
@@ -28,6 +30,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
 	where

Command/Watch.hs

@@ -18,12 +18,17 @@ import qualified Annex.Queue
 import qualified Command.Add
 import qualified Git.Command
 import qualified Git.UpdateIndex
+import qualified Git.HashObject
 import qualified Backend
 import Annex.Content
+import Annex.CatFile
+import Git.Types
 
 import Control.Concurrent
 import Control.Concurrent.STM
 import Data.Time.Clock
+import Data.Bits.Utils
+import qualified Data.ByteString.Lazy as L
 
 #if defined linux_HOST_OS
 import Utility.Inotify
@@ -127,6 +132,9 @@ madeChange :: FilePath -> String -> Annex (Maybe Change)
 madeChange file desc = liftIO $ 
 	Just <$> (Change <$> getCurrentTime <*> pure file <*> pure desc)
 
+noChange :: Annex (Maybe Change)
+noChange = return Nothing
+
 {- Adding a file is tricky; the file has to be replaced with a symlink
  - but this is race prone, as the symlink could be changed immediately
  - after creation. To avoid that race, git add is not used to stage the
@@ -139,7 +147,7 @@ onAdd :: Handler
 onAdd file = do
 	showStart "add" file
 	handle =<< Command.Add.ingest file
-	return Nothing
+	noChange
 	where
 		handle Nothing = showEndFail
 		handle (Just key) = do
@@ -153,22 +161,35 @@ onAdd file = do
 onAddSymlink :: Handler
 onAddSymlink file = go =<< Backend.lookupFile file
 	where
-		go Nothing = do
-			addlink =<< liftIO (readSymbolicLink file)
-			madeChange file "add"
+		go Nothing = addlink =<< liftIO (readSymbolicLink file)
 		go (Just (key, _)) = do
 			link <- calcGitLink file key
 			ifM ((==) link <$> liftIO (readSymbolicLink file))
-				( do
-					addlink link
-					madeChange file "add"
+				( addlink link
 				, do
 					liftIO $ removeFile file
 					liftIO $ createSymbolicLink link file
 					addlink link
-					madeChange file "fix"
 				)
-		addlink link = stageSymlink file link
+		{- This is often called on symlinks that are already staged
+		 - correctly, especially during the startup scan. A symlink
+		 - may have been deleted and re-added, or added when
+		 - the watcher was not running; so it always stages
+		 - even symlinks that already exist.
+		 -
+		 - So 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 "link"
 
 onDel :: Handler
 onDel file = do
@@ -197,10 +218,10 @@ onErr msg = do
 
 {- Adds a symlink to the index, without ever accessing the actual symlink
  - on disk. -}
-stageSymlink :: FilePath -> String -> Annex ()
-stageSymlink file linktext =
+stageSymlink :: FilePath -> Sha -> Annex ()
+stageSymlink file sha =
 	Annex.Queue.addUpdateIndex =<<
-		inRepo (Git.UpdateIndex.stageSymlink file linktext)
+		inRepo (Git.UpdateIndex.stageSymlink file sha)
 
 {- Signals that a change has been made, that needs to get committed. -}
 signalChange :: ChangeChan -> Change -> Annex ()

Git/CatFile.hs

@@ -10,7 +10,8 @@ module Git.CatFile (
 	catFileStart,
 	catFileStop,
 	catFile,
-	catObject
+	catObject,
+	catObjectDetails,
 ) where
 
 import System.IO
@@ -42,7 +43,11 @@ catFile h branch file = catObject h $ Ref $ show branch ++ ":" ++ file
 {- 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 @@ catObject h object = CoProcess.query h send receive
 					| 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/UpdateIndex.hs

@@ -24,7 +24,6 @@ import Git
 import Git.Types
 import Git.Command
 import Git.FilePath
-import Git.HashObject
 import Git.Sha
 
 {- Streamers are passed a callback and should feed it lines in the form
@@ -70,10 +69,10 @@ unstageFile file repo = do
 	return $ pureStreamer $ "0 " ++ show nullSha ++ "\t" ++ getTopFilePath p
 
 {- A streamer that adds a symlink to the index. -}
-stageSymlink :: FilePath -> String -> Repo -> IO Streamer
-stageSymlink file linktext repo = do
+stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer
+stageSymlink file sha repo = do
 	line <- updateIndexLine
-		<$> hashObject BlobObject linktext repo
+		<$> pure sha
 		<*> pure SymlinkBlob
 		<*> toTopFilePath file repo
 	return $ pureStreamer line