From 4776e1d7b76d65fe36f7e3ce8d31aa49a3e7e111 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Sun, 24 Nov 2013 01:11:04 -0400
Subject: [PATCH] use manifest file instead of blindly removing the whole
 git-annex.linux directory

FIXME: dirContentsRecursive does not find empty directories
---
 Assistant/Upgrade.hs | 93 +++++++++++++++++++++++++-------------------
 Makefile             |  2 +
 2 files changed, 56 insertions(+), 39 deletions(-)

diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs
index 93e57fc263..de1a79071e 100644
--- a/Assistant/Upgrade.hs
+++ b/Assistant/Upgrade.hs
@@ -34,6 +34,7 @@ import qualified Utility.Lsof as Lsof
 
 import qualified Data.Map as M
 import Data.Tuple.Utils
+import Data.Ord
 
 {- Upgrade without interaction in the webapp. -}
 unattendedUpgrade :: Assistant ()
@@ -119,56 +120,70 @@ distributionDownloadComplete d cleanup t
  -}
 upgradeToDistribution :: GitAnnexDistribution -> Assistant () -> FilePath -> Assistant ()
 upgradeToDistribution d cleanup f = do
-#ifdef darwin_HOST_OS
-	{- OS X uses a dmg, so mount it, and copy the contents into place. -}
-	error "TODO"
-#else
-	{- Linux uses a tarball, so untar it (into a temp directory)
-	 - and move the directory into place. -}
-	olddir <- parentDir <$> liftIO readProgramFile
-	let topdir = parentDir olddir
-	let newdir = topdir </> "git-annex.linux." ++ distributionVersion d
-	liftIO $ void $ tryIO $ removeDirectoryRecursive newdir
-	liftIO $ withTmpDirIn topdir "git-annex.upgrade" $ \tmpdir -> do
-		let tarball = tmpdir </> "tar"
-		-- Cannot rely on filename extension, and this also
-		-- avoids problems if tar doesn't support transparent
-		-- decompression.
-		void $ boolSystem "sh"
-			[ Param "-c"
-			, Param $ "zcat < " ++ shellEscape f ++
-				" > " ++ shellEscape tarball
-			]
-		tarok <- boolSystem "tar"
-			[ Param "xf"
-			, Param tarball
-			, Param "--directory", File tmpdir
-			]
-		unless tarok $
-			error $ "failed to untar " ++ f
-		let unpacked = tmpdir </> "git-annex.linux"
-		unlessM (doesDirectoryExist unpacked) $
-			error $ "did not find git-annex.linux in " ++ f
-		renameDirectory unpacked newdir
-	changeprogram $ newdir </> "git-annex"
+	(program, deleteold) <- unpack
+	changeprogram program
 	cleanup
 	prepUpgrade
 	url <- runRestart
 	{- At this point, the new assistant is fully running, so
-	 - it's safe to delete the old version. To make sure we don't
-	 - delete something we shouldn't, only delete it if
-	 - "git-annex.linux" is in the name. 
-	 - This could fail, if the user cannot write to it (unlikely) -}
-	liftIO $ when ("git-annex.linux" `isPrefixOf` takeFileName olddir) $
-		void $ removeDirectoryRecursive olddir
+	 - it's safe to delete the old version. -}
+	liftIO deleteold
 	postUpgrade url
-#endif
   where
 	changeprogram program = liftIO $ do
 		unlessM (boolSystem program [Param "version"]) $
 			error "New git-annex program failed to run! Not using."
 		pf <- programFile
 		liftIO $ writeFile pf program
+	
+#ifdef darwin_HOST_OS
+	{- OS X uses a dmg, so mount it, and copy the contents into place. -}
+	unpack = do
+		error "TODO OSX upgrade code"
+#else
+	{- Linux uses a tarball (so could other POSIX systems), so
+	 - untar it (into a temp directory) and move the directory
+	 - into place. -}
+	unpack = liftIO $ do
+		olddir <- parentDir <$> readProgramFile
+		let topdir = parentDir olddir
+		let newdir = topdir </> "git-annex.linux." ++ distributionVersion d
+		whenM (doesDirectoryExist newdir) $
+			error $ "upgrade destination directory " ++ newdir ++ "already exists; not overwriting"
+		withTmpDirIn topdir "git-annex.upgrade" $ \tmpdir -> do
+			let tarball = tmpdir </> "tar"
+			-- Cannot rely on filename extension, and this also
+			-- avoids problems if tar doesn't support transparent
+			-- decompression.
+			void $ boolSystem "sh"
+				[ Param "-c"
+				, Param $ "zcat < " ++ shellEscape f ++
+					" > " ++ shellEscape tarball
+				]
+			tarok <- boolSystem "tar"
+				[ Param "xf"
+				, Param tarball
+				, Param "--directory", File tmpdir
+				]
+			unless tarok $
+				error $ "failed to untar " ++ f
+			let unpacked = tmpdir </> "git-annex.linux"
+			unlessM (doesDirectoryExist unpacked) $
+				error $ "did not find git-annex.linux in " ++ f
+			renameDirectory unpacked newdir
+		return (newdir </> "git-annex", deleteFromManifest olddir)
+#endif
+
+deleteFromManifest :: FilePath -> IO ()
+deleteFromManifest dir = do
+	fs <- map (dir </>) . lines <$> catchDefaultIO "" (readFile manifest)
+	mapM_ nukeFile fs
+	nukeFile manifest
+	mapM_ nukedir =<< sortBy (comparing length) <$> dirContentsRecursive dir
+	nukedir dir
+  where
+	manifest = dir </> "git-annex.MANIFEST"
+	nukedir = void . tryIO . removeDirectory
 
 {- This is a file that the UpgradeWatcher can watch for modifications to
  - detect when git-annex has been upgraded.
diff --git a/Makefile b/Makefile
index ee47e03bad..2a8db2d2d8 100644
--- a/Makefile
+++ b/Makefile
@@ -134,6 +134,7 @@ linuxstandalone: Build/Standalone
 	rm -f "$(LINUXSTANDALONE_DEST)/libdirs.tmp"
 
 	cd tmp/git-annex.linux && find . -type f > git-annex.MANIFEST
+	cd tmp/git-annex.linux && find . -type l >> git-annex.MANIFEST
 	cd tmp && tar czf git-annex-standalone-$(shell dpkg --print-architecture).tar.gz git-annex.linux
 
 OSXAPP_DEST=tmp/build-dmg/git-annex.app
@@ -159,6 +160,7 @@ osxapp: Build/Standalone Build/OSXMkLibs
 
 	./Build/OSXMkLibs $(OSXAPP_BASE)
 	cd $(OSXAPP_DEST) && find . -type f > Contents/MacOS/bundle/git-annex.MANIFEST
+	cd $(OSXAPP_DEST) && find . -type l >> Contents/MacOS/bundle/git-annex.MANIFEST
 	rm -f tmp/git-annex.dmg
 	hdiutil create -format UDBZ -srcfolder tmp/build-dmg \
 		-volname git-annex -o tmp/git-annex.dmg