Merge branch 'master' into adjustedbranch

Annex/Branch.hs

@@ -45,7 +45,8 @@ import qualified Git.Branch
 import qualified Git.UnionMerge
 import qualified Git.UpdateIndex
 import Git.LsTree (lsTreeParams)
-import Git.HashObject
+import qualified Git.HashObject
+import Annex.HashObject
 import Git.Types
 import Git.FilePath
 import Annex.CatFile
@@ -342,8 +343,9 @@ genIndex g = Git.UpdateIndex.streamUpdateIndex g
 mergeIndex :: JournalLocked -> [Git.Ref] -> Annex ()
 mergeIndex jl branches = do
 	prepareModifyIndex jl
-	h <- catFileHandle
-	inRepo $ \g -> Git.UnionMerge.mergeIndex h g branches
+	hashhandle <- hashObjectHandle
+	ch <- catFileHandle
+	inRepo $ \g -> Git.UnionMerge.mergeIndex hashhandle ch g branches
 
 {- Removes any stale git lock file, to avoid git falling over when
  - updating the index.
@@ -423,11 +425,10 @@ stageJournal jl = withIndex $ do
 	let dir = gitAnnexJournalDir g
 	(jlogf, jlogh) <- openjlog
 	liftIO $ fileEncoding jlogh
-	withJournalHandle $ \jh -> do
-		h <- hashObjectStart g
+	h <- hashObjectHandle
+	withJournalHandle $ \jh ->
 		Git.UpdateIndex.streamUpdateIndex g
 			[genstream dir h jh jlogh]
-		hashObjectStop h
 	return $ cleanup dir jlogh jlogf
   where
 	genstream dir h jh jlogh streamer = do
@@ -437,7 +438,7 @@ stageJournal jl = withIndex $ do
 			Just file -> do
 				unless (dirCruft file) $ do
 					let path = dir </> file
-					sha <- hashFile h path
+					sha <- Git.HashObject.hashFile h path
 					hPutStrLn jlogh file
 					streamer $ Git.UpdateIndex.updateIndexLine
 						sha FileBlob (asTopFilePath $ fileJournal file)
@@ -549,13 +550,11 @@ performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do
 	run changers = do
 		trustmap <- calcTrustMap <$> getRaw trustLog
 		fs <- branchFiles
-		hasher <- inRepo hashObjectStart
 		forM_ fs $ \f -> do
 			content <- getRaw f
-			apply changers hasher f content trustmap
-		liftIO $ hashObjectStop hasher
-	apply [] _ _ _ _ = return ()
-	apply (changer:rest) hasher file content trustmap =
+			apply changers f content trustmap
+	apply [] _ _ _ = return ()
+	apply (changer:rest) file content trustmap =
 		case changer file content trustmap of
 			RemoveFile -> do
 				Annex.Queue.addUpdateIndex
@@ -564,12 +563,12 @@ performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do
 				-- transitions on it.
 				return ()
 			ChangeFile content' -> do
-				sha <- inRepo $ hashObject BlobObject content'
+				sha <- hashBlob content'
 				Annex.Queue.addUpdateIndex $ Git.UpdateIndex.pureStreamer $
 					Git.UpdateIndex.updateIndexLine sha FileBlob (asTopFilePath file)
-				apply rest hasher file content' trustmap
+				apply rest file content' trustmap
 			PreserveFile ->
-				apply rest hasher file content trustmap
+				apply rest file content trustmap
 
 checkBranchDifferences :: Git.Ref -> Annex ()
 checkBranchDifferences ref = do

Annex/Concurrent.hs

@@ -11,6 +11,7 @@ import Annex.Common
 import Annex
 import Annex.CatFile
 import Annex.CheckAttr
+import Annex.HashObject
 import Annex.CheckIgnore
 import qualified Annex.Queue
 
@@ -64,4 +65,5 @@ mergeState st = do
 	closehandles = do
 		catFileStop
 		checkAttrStop
+		hashObjectStop
 		checkIgnoreStop

Annex/HashObject.hs

@@ -0,0 +1,47 @@
+{- git hash-object interface, with handle automatically stored in the Annex monad
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.HashObject (
+	hashFile,
+	hashBlob,
+	hashObjectHandle,
+	hashObjectStop,
+) where
+
+import Annex.Common
+import qualified Git.HashObject
+import qualified Annex
+import Git.Types
+
+hashObjectHandle :: Annex Git.HashObject.HashObjectHandle
+hashObjectHandle = maybe startup return =<< Annex.getState Annex.hashobjecthandle
+  where
+	startup = do
+		h <- inRepo $ Git.HashObject.hashObjectStart
+		Annex.changeState $ \s -> s { Annex.hashobjecthandle = Just h }
+		return h
+
+hashObjectStop :: Annex ()
+hashObjectStop = maybe noop stop =<< Annex.getState Annex.hashobjecthandle
+  where
+	stop h = do
+		liftIO $ Git.HashObject.hashObjectStop h
+		Annex.changeState $ \s -> s { Annex.hashobjecthandle = Nothing }
+		return ()
+
+hashFile :: FilePath -> Annex Sha
+hashFile f = do
+	h <- hashObjectHandle
+	liftIO $ Git.HashObject.hashFile h f
+
+{- Note that the content will be written to a temp file.
+ - So it may be faster to use Git.HashObject.hashObject for large
+ - blob contents. -}
+hashBlob :: String -> Annex Sha
+hashBlob content = do
+	h <- hashObjectHandle
+	liftIO $ Git.HashObject.hashBlob h content

Annex/Link.hs

@@ -18,11 +18,11 @@ module Annex.Link where
 
 import Annex.Common
 import qualified Annex
-import qualified Git.HashObject
 import qualified Git.UpdateIndex
 import qualified Annex.Queue
 import Git.Types
 import Git.FilePath
+import Annex.HashObject
 
 import qualified Data.ByteString.Lazy as L
 import Data.Int
@@ -105,12 +105,7 @@ addAnnexLink linktarget file = do
 
 {- Injects a symlink target into git, returning its Sha. -}
 hashSymlink :: LinkTarget -> Annex Sha
-hashSymlink linktarget = inRepo $ Git.HashObject.hashObject BlobObject $ 
-	toInternalGitPath linktarget
-
-hashSymlink' :: Git.HashObject.HashObjectHandle -> LinkTarget -> Annex Sha
-hashSymlink' h linktarget = liftIO $ Git.HashObject.hashBlob h $
-	toInternalGitPath linktarget
+hashSymlink linktarget = hashBlob (toInternalGitPath linktarget)
 
 {- Stages a symlink to an annexed object, using a Sha of its target. -}
 stageSymlink :: FilePath -> Sha -> Annex ()
@@ -120,8 +115,7 @@ stageSymlink file sha =
 
 {- Injects a pointer file content into git, returning its Sha. -}
 hashPointerFile :: Key -> Annex Sha
-hashPointerFile key = inRepo $ Git.HashObject.hashObject BlobObject $
-	formatPointer key
+hashPointerFile key = hashBlob (formatPointer key)
 
 hashPointerFile' :: Git.HashObject.HashObjectHandle -> Key -> Annex Sha
 hashPointerFile' h = liftIO . Git.HashObject.hashBlob h . formatPointer
@@ -162,7 +156,9 @@ formatPointer :: Key -> String
 formatPointer k = 
 	toInternalGitPath (pathSeparator:objectDir </> keyFile k) ++ "\n"
 
-{- Checks if a file is a pointer to a key. -}
+{- Checks if a worktree file is a pointer to a key.
+ -
+ - Unlocked files whose content is present are not detected by this. -}
 isPointerFile :: FilePath -> IO (Maybe Key)
 isPointerFile f = catchDefaultIO Nothing $ do
 	b <- L.take maxPointerSz <$> L.readFile f

Annex/View.hs

@@ -19,7 +19,7 @@ import qualified Git.LsFiles
 import qualified Git.Ref
 import Git.UpdateIndex
 import Git.Sha
-import Git.HashObject
+import Annex.HashObject
 import Git.Types
 import Git.FilePath
 import Annex.WorkTree
@@ -340,38 +340,36 @@ applyView' mkviewedfile getfilemetadata view = do
 	(l, clean) <- inRepo $ Git.LsFiles.inRepo [top]
 	liftIO . nukeFile =<< fromRepo gitAnnexViewIndex
 	uh <- withViewIndex $ inRepo Git.UpdateIndex.startUpdateIndex
-	hasher <- inRepo hashObjectStart
 	forM_ l $ \f -> do
 		relf <- getTopFilePath <$> inRepo (toTopFilePath f)
-		go uh hasher relf =<< lookupFile f
+		go uh relf =<< lookupFile f
 	liftIO $ do
-		hashObjectStop hasher
 		void $ stopUpdateIndex uh
 		void clean
 	genViewBranch view
   where
 	genviewedfiles = viewedFiles view mkviewedfile -- enables memoization
-	go uh hasher f (Just k) = do
+	go uh f (Just k) = do
 		metadata <- getCurrentMetaData k
 		let metadata' = getfilemetadata f `unionMetaData` metadata
 		forM_ (genviewedfiles f metadata') $ \fv -> do
 			f' <- fromRepo $ fromTopFilePath $ asTopFilePath fv
-			stagesymlink uh hasher f' =<< calcRepo (gitAnnexLink f' k)
-	go uh hasher f Nothing
+			stagesymlink uh f' =<< calcRepo (gitAnnexLink f' k)
+	go uh f Nothing
 		| "." `isPrefixOf` f = do
 			s <- liftIO $ getSymbolicLinkStatus f
 			if isSymbolicLink s
-				then stagesymlink uh hasher f =<< liftIO (readSymbolicLink f)
+				then stagesymlink uh f =<< liftIO (readSymbolicLink f)
 				else do
-					sha <- liftIO $ Git.HashObject.hashFile hasher f
+					sha <- hashFile f
 					let blobtype = if isExecutable (fileMode s)
 						then ExecutableBlob
 						else FileBlob
 					liftIO . Git.UpdateIndex.streamUpdateIndex' uh
 						=<< inRepo (Git.UpdateIndex.stageFile sha blobtype f)
 		| otherwise = noop
-	stagesymlink uh hasher f linktarget = do
-		sha <- hashSymlink' hasher linktarget
+	stagesymlink uh f linktarget = do
+		sha <- hashSymlink linktarget
 		liftIO . Git.UpdateIndex.streamUpdateIndex' uh
 			=<< inRepo (Git.UpdateIndex.stageSymlink f sha)