Avoid crashing on encoding errors in filenames when writing transfer info files and reading from checksum commands.

Backend/SHA.hs

@@ -16,6 +16,7 @@ import Types.KeySource
 import qualified Build.SysConfig as SysConfig
 import Data.Digest.Pure.SHA
 import qualified Data.ByteString.Lazy as L
+import System.Process
 
 type SHASize = Int
 
@@ -55,7 +56,7 @@ shaN shasize file filesize = do
 	case shaCommand shasize filesize of
 		Left sha -> liftIO $ sha <$> L.readFile file
 		Right command -> liftIO $ parse command . lines <$>
-			readProcess command (toCommand [File file])
+			readsha command (toCommand [File file])
 	where
 		parse command [] = bad command
 		parse command (l:_)
@@ -64,6 +65,16 @@ shaN shasize file filesize = do
 			where
 				sha = fst $ separate (== ' ') l
 		bad command = error $ command ++ " parse error"
+		{- sha commands output the filename, so need to set fileEncoding -}
+		readsha command args =
+			withHandle StdoutHandle createProcessSuccess p $ \h -> do
+				fileEncoding h
+				output  <- hGetContentsStrict h
+				hClose h
+				return output
+			where
+				p = (proc command args)
+					{ std_out = CreatePipe }
 
 shaCommand :: SHASize -> Integer -> Either (L.ByteString -> String) String
 shaCommand shasize filesize

Logs/Transfer.hs

@@ -97,28 +97,27 @@ runTransfer t file a = do
 		<*> pure Nothing
 		<*> pure file
 		<*> pure False
-	let content = writeTransferInfo info
-	ok <- bracketIO (prep tfile mode content) (cleanup tfile) a
-	unless ok $ failed content
+	ok <- bracketIO (prep tfile mode info) (cleanup tfile) a
+	unless ok $ failed info
 	return ok
 	where
-		prep tfile mode content = do
+		prep tfile mode info = do
 			fd <- openFd (transferLockFile tfile) ReadWrite (Just mode)
 				defaultFileFlags { trunc = True }
 			locked <- catchMaybeIO $
 				setLock fd (WriteLock, AbsoluteSeek, 0, 0)
 			when (locked == Nothing) $
 				error $ "transfer already in progress"
-			writeFile tfile content
+			writeTransferInfoFile info tfile
 			return fd
 		cleanup tfile fd = do
 			void $ tryIO $ removeFile tfile
 			void $ tryIO $ removeFile $ transferLockFile tfile
 			closeFd fd
-		failed content = do
+		failed info = do
 			failedtfile <- fromRepo $ failedTransferFile t
 			createAnnexDirectory $ takeDirectory failedtfile
-			liftIO $ writeFile failedtfile content
+			liftIO $ writeTransferInfoFile info failedtfile
 
 {- If a transfer is still running, returns its TransferInfo. -}
 checkTransfer :: Transfer -> Annex (Maybe TransferInfo)
@@ -136,9 +135,8 @@ checkTransfer t = do
 			case locked of
 				Nothing -> return Nothing
 				Just (pid, _) -> liftIO $
-					flip catchDefaultIO Nothing $ do
-						readTransferInfo (Just pid)
-							<$> readFile tfile
+					flip catchDefaultIO Nothing $
+						readTransferInfoFile (Just pid) tfile
 
 {- Gets all currently running transfers. -}
 getTransfers :: Annex [(Transfer, TransferInfo)]
@@ -159,7 +157,7 @@ getFailedTransfers u = catMaybes <$> (liftIO . getpairs =<< concat <$> findfiles
 	where
 		getpairs = mapM $ \f -> do
 			let mt = parseTransferFile f
-			mi <- readTransferInfo Nothing <$> readFile f
+			mi <- readTransferInfoFile Nothing f
 			return $ case (mt, mi) of
 				(Just t, Just i) -> Just (t, i)
 				_ -> Nothing
@@ -196,6 +194,13 @@ parseTransferFile file
 	where
 		bits = splitDirectories file
 
+writeTransferInfoFile :: TransferInfo -> FilePath -> IO ()
+writeTransferInfoFile info tfile = do
+	h <- openFile tfile WriteMode
+	fileEncoding h
+	hPutStr h $ writeTransferInfo info
+	hClose h
+
 writeTransferInfo :: TransferInfo -> String
 writeTransferInfo info = unlines
 	-- transferPid is not included; instead obtained by looking at
@@ -205,6 +210,12 @@ writeTransferInfo info = unlines
 	, fromMaybe "" $ associatedFile info -- comes last; arbitrary content
 	]
 
+readTransferInfoFile :: (Maybe ProcessID) -> FilePath -> IO (Maybe TransferInfo)
+readTransferInfoFile mpid tfile = do
+	h <- openFile tfile ReadMode
+	fileEncoding h
+	hClose h `after` (readTransferInfo mpid <$> hGetContentsStrict h)
+
 readTransferInfo :: (Maybe ProcessID) -> String -> Maybe TransferInfo
 readTransferInfo mpid s =
 	case bits of

debian/changelog

@@ -20,6 +20,8 @@ git-annex (3.20120826) UNRELEASED; urgency=low
   * Support repositories created with --separate-git-dir. Closes: #684405
   * reinject: When the provided file doesn't match, leave it where it is,
     rather than moving to .git/annex/bad/
+  * Avoid crashing on encoding errors in filenames when writing transfer info
+    files and reading from checksum commands.
 
  -- Joey Hess <joeyh@debian.org>  Mon, 27 Aug 2012 13:27:39 -0400
 

doc/bugs/commitBuffer:_invalid_argument___40__invalid_character__41__.mdwn

@@ -223,3 +223,6 @@ http://git-annex.branchable.com/todo/support-non-utf8-locales/
     failed
     (Recording state in git...)
     git-annex: copy: 1 failed
+
+> [[Fixed|done]]. Sorry this took so long, I was at a very busy point when
+> you filed this and am only just getting caught up. --[[Joey]]