completely untested linux upgrade code

Assistant/Threads/UpgradeWatcher.hs

@@ -1,4 +1,4 @@
-{- git-annex assistant thread to detect when git-annex binary is changed
+{- git-annex assistant thread to detect when git-annex is upgraded
  -
  - Copyright 2013 Joey Hess <joey@kitenet.net>
  -
@@ -15,8 +15,6 @@ import Assistant.Common
 import Assistant.Upgrade
 import Utility.DirWatcher
 import Utility.DirWatcher.Types
-import Config.Files
-import qualified Utility.Lsof as Lsof
 import Utility.ThreadScheduler
 import Assistant.Types.UrlRenderer
 import Assistant.Alert
@@ -27,7 +25,6 @@ import qualified Build.SysConfig
 #endif
 
 import Control.Concurrent.MVar
-import Data.Tuple.Utils
 import qualified Data.Text as T
 
 data WatcherState = InStartupScan | Started | Upgrading
@@ -37,12 +34,12 @@ upgradWatcherThread :: UrlRenderer -> NamedThread
 upgradWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do
 	whenM (liftIO $ checkSuccessfulUpgrade) $
 		showSuccessfulUpgrade urlrenderer
-	go =<< liftIO programPath
+	go =<< liftIO upgradeFlagFile
   where
 	go Nothing = debug [ "cannot determine program path" ]
-	go (Just program) = do
+	go (Just flagfile) = do
 		mvar <- liftIO $ newMVar InStartupScan
-		changed <- Just <$> asIO2 (changedFile urlrenderer mvar program)
+		changed <- Just <$> asIO2 (changedFile urlrenderer mvar flagfile)
 		let hooks = mkWatchHooks
 			{ addHook = changed
 			, delHook = changed
@@ -50,7 +47,7 @@ upgradWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do
 			, modifyHook = changed
 			, delDirHook = changed
 			}
-		let dir = parentDir program
+		let dir = parentDir flagfile
 		let depth = length (splitPath dir) + 1
 		let nosubdirs f = length (splitPath f) == depth
 		void $ liftIO $ watchDir dir nosubdirs hooks (startup mvar)
@@ -61,39 +58,21 @@ upgradWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do
 		return r
 
 changedFile :: UrlRenderer -> MVar WatcherState -> FilePath -> FilePath -> Maybe FileStatus -> Assistant ()
-changedFile urlrenderer mvar program file _status
+changedFile urlrenderer mvar flagfile file _status
-	| program /= file = noop
+	| flagfile /= file = noop
 	| otherwise = do
 		state <- liftIO $ readMVar mvar
 		when (state == Started) $ do
 			setstate Upgrading
-			ifM (sanityCheck program)
+			ifM (liftIO upgradeSanityCheck)
 				( handleUpgrade urlrenderer
 				, do
-					debug ["new version of", program, "failed sanity check; not using"]
+					debug ["new version failed sanity check; not using"]
 					setstate Started
 				)
   where
 	setstate = void . liftIO . swapMVar mvar
 
-{- The program's file has been changed. Before restarting,
- - it needs to not be open for write by anything, and should run
- - successfully when run with the parameter "version".
- -}
-sanityCheck :: FilePath -> Assistant Bool
-sanityCheck program = do
-	untilM (liftIO $ present <&&> nowriter) $ do
-		debug [program, "is still being written; waiting"]
-		liftIO $ threadDelaySeconds (Seconds 60)
-	debug [program, "has changed, and seems to be ready to run"]
-	liftIO $ boolSystem program [Param "version"]
-  where
-	present = doesFileExist program
-	nowriter = null
-		. filter (`elem` [Lsof.OpenReadWrite, Lsof.OpenWriteOnly])
-		. map snd3
-		<$> Lsof.query [program]
-
 handleUpgrade :: UrlRenderer -> Assistant ()
 handleUpgrade urlrenderer = do
 	-- Wait 2 minutes for any final upgrade changes to settle.

Assistant/Upgrade.hs

@@ -5,6 +5,8 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
+{-# LANGUAGE CPP #-}
+
 module Assistant.Upgrade where
 
 import Assistant.Common
@@ -16,15 +18,22 @@ import Utility.Env
 import Types.Distribution
 import Logs.Transfer
 import Logs.Web
+import Logs.Presence
+import Logs.Location
 import Annex.Content
 import qualified Backend
 import qualified Types.Backend
 import qualified Types.Key
 import Assistant.TransferQueue
 import Assistant.TransferSlots
-import Remote
+import Remote (remoteFromUUID)
+import Config.Files
+import Utility.ThreadScheduler
+import Utility.Tmp
+import qualified Utility.Lsof as Lsof
 
 import qualified Data.Map as M
+import Data.Tuple.Utils
 
 {- Upgrade without interaction in the webapp. -}
 unattendedUpgrade :: Assistant ()
@@ -52,13 +61,14 @@ upgradedEnv :: String
 upgradedEnv = "GIT_ANNEX_UPGRADED"
 
 {- Start downloading the distribution key from the web.
- - Install a hook that will be run once the download is complete. -}
+ - Install a hook that will be run once the download is complete,
+ - and finishes the upgrade. -}
 startDistributionDownload :: GitAnnexDistribution -> Assistant ()
 startDistributionDownload d = do
 	liftAnnex $ setUrlPresent k u
-	hook <- asIO1 $ distributionDownloadComplete d
+	hook <- asIO1 $ distributionDownloadComplete d cleanup
-	modifyDaemonStatus_ $ \status -> status
+	modifyDaemonStatus_ $ \s -> s
-		{ transferHook = M.insert k hook (transferHook status) }
+		{ transferHook = M.insert k hook (transferHook s) }
 	maybe noop (queueTransfer "upgrade" Next (Just f) t)
 		=<< liftAnnex (remoteFromUUID webUUID)
 	startTransfer t
@@ -71,15 +81,22 @@ startDistributionDownload d = do
 		, transferUUID = webUUID
 		, transferKey = k
 		}
+	cleanup = liftAnnex $ do
+		removeAnnex k
+		setUrlMissing k u
+		logStatus k InfoMissing
 
-{- Fsck the key to verify the download. -}
+{- Called once the download is done.
-distributionDownloadComplete :: GitAnnexDistribution -> Transfer -> Assistant ()
+ - Passed an action that can be used to clean up the downloaded file.
-distributionDownloadComplete d t 
+ -
-	| transferDirection t == Download = do
+ - Fsck the key to verify the download.
-		maybe noop upgradeToDistribution
+ -}
+distributionDownloadComplete :: GitAnnexDistribution -> Assistant () -> Transfer -> Assistant ()
+distributionDownloadComplete d cleanup t 
+	| transferDirection t == Download =
+		maybe cleanup (upgradeToDistribution d cleanup)
 			=<< liftAnnex (withObjectLoc k fsckit (getM fsckit))
-		liftAnnex $ setUrlMissing k (distributionUrl d)
+	| otherwise = cleanup
-	| otherwise = noop
   where
 	k = distributionKey d
 	fsckit f = case Backend.maybeLookupBackendName (Types.Key.keyBackendName k) of
@@ -88,12 +105,90 @@ distributionDownloadComplete d t
 			Nothing -> return $ Just f
 			Just a -> ifM (a k f)
 				( return $ Just f
-				, do
+				, return Nothing
-					-- unlikely to resume a bad
-					-- download from web
-					liftIO $ nukeFile f
-					return Nothing
 				)
 
-upgradeToDistribution :: FilePath -> Assistant ()
+{- The upgrade method varies by OS.
-upgradeToDistribution f = error "TODO"
+ -
+ - In general, find where the distribution was installed before,
+ - and unpack the new distribution next to it (in a versioned directory).
+ - Then update the programFile to point to the new version.
+ -}
+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 programFile
+	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
+		tarok <- boolSystem "tar"
+			[ Param "--directory", File tmpdir
+			, Param "xf"
+			, Param f
+			]
+		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"
+	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
+  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
+
+usingDistribution :: IO Bool
+usingDistribution = isJust <$> getEnv "GIT_ANNEX_STANDLONE_ENV"
+
+{- This is a file that the UpgradeWatcher can watch for modifications to
+ - detect when git-annex has been upgraded.
+ -}
+upgradeFlagFile :: IO (Maybe FilePath)
+upgradeFlagFile = ifM usingDistribution
+	( Just <$> programFile
+	, programPath
+	)
+
+{- Sanity check to see if an upgrade is complete and the program is ready
+ - to be run. -}
+upgradeSanityCheck :: IO Bool
+upgradeSanityCheck = ifM usingDistribution
+	( doesFileExist =<< programFile
+	, do
+		-- Ensure that the program is present, and has no writers,
+		-- and can be run. This should handle distribution
+		-- upgrades, manual upgrades, etc.
+		v <- programPath
+		case v of
+			Nothing -> return False
+			Just program -> do
+				untilM (doesFileExist program <&&> nowriter program) $
+					threadDelaySeconds (Seconds 60)
+				boolSystem program [Param "version"]
+	)
+  where
+	nowriter f = null
+		. filter (`elem` [Lsof.OpenReadWrite, Lsof.OpenWriteOnly])
+		. map snd3
+		<$> Lsof.query [f]

Assistant/WebApp/Configurators/Upgrade.hs

@@ -18,7 +18,8 @@ import Config
 {- On Android, just point the user at the apk file to download.
  - Installation will be handled by selecting the downloaded file.
  -
- - Otherwise, start the download.
+ - Otherwise, start the upgrade process, which will run fully
+ - noninteractively.
  - -}
 getConfigStartUpgradeR :: GitAnnexDistribution -> Handler Html
 getConfigStartUpgradeR d = do