use manifest file instead of blindly removing the whole git-annex.linux directory

FIXME: dirContentsRecursive does not find empty directories

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,17 +120,37 @@ distributionDownloadComplete d cleanup t
  -}
 upgradeToDistribution :: GitAnnexDistribution -> Assistant () -> FilePath -> Assistant ()
 upgradeToDistribution d cleanup f = do
+	(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. -}
+	liftIO deleteold
+	postUpgrade url
+  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. -}
-	error "TODO"
+	unpack = do
+		error "TODO OSX upgrade code"
 #else
-	{- Linux uses a tarball, so untar it (into a temp directory)
+	{- Linux uses a tarball (so could other POSIX systems), so
-	 - and move the directory into place. -}
+	 - untar it (into a temp directory) and move the directory
-	olddir <- parentDir <$> liftIO readProgramFile
+	 - into place. -}
+	unpack = liftIO $ do
+		olddir <- parentDir <$> readProgramFile
 		let topdir = parentDir olddir
 		let newdir = topdir </> "git-annex.linux." ++ distributionVersion d
-	liftIO $ void $ tryIO $ removeDirectoryRecursive newdir
+		whenM (doesDirectoryExist newdir) $
-	liftIO $ withTmpDirIn topdir "git-annex.upgrade" $ \tmpdir -> do
+			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
@@ -150,25 +171,19 @@ upgradeToDistribution d cleanup f = do
 			unlessM (doesDirectoryExist unpacked) $
 				error $ "did not find git-annex.linux in " ++ f
 			renameDirectory unpacked newdir
-	changeprogram $ newdir </> "git-annex"
+		return (newdir </> "git-annex", deleteFromManifest olddir)
-	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
-	postUpgrade url
 #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
-	changeprogram program = liftIO $ do
+	manifest = dir </> "git-annex.MANIFEST"
-		unlessM (boolSystem program [Param "version"]) $
+	nukedir = void . tryIO . removeDirectory
-			error "New git-annex program failed to run! Not using."
-		pf <- programFile
-		liftIO $ writeFile pf program
 
 {- This is a file that the UpgradeWatcher can watch for modifications to
  - detect when git-annex has been upgraded.

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