From 0b12db64d834979d49ed378235b0c19b34e4a4d6 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Sun, 16 Sep 2012 01:53:06 -0400
Subject: Avoid crashing on encoding errors in filenames when writing transfer
 info files and reading from checksum commands.

---
 Logs/Transfer.hs | 33 ++++++++++++++++++++++-----------
 1 file changed, 22 insertions(+), 11 deletions(-)

(limited to 'Logs/Transfer.hs')

diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs
index 5c16e758e..a58944a83 100644
--- a/Logs/Transfer.hs
+++ b/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
-- 
cgit v1.2.3