Merge branch 'master' into no-xmpp

12 files changed, 734 insertions, 17 deletions

diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index bc79a70a8..6db66399c 100644
--- a/Assistant/Alert.hs
+++ b/Assistant/Alert.hs
@@ -26,7 +26,6 @@ import qualified Control.Exception as E
 import Assistant.DaemonStatus
 import Assistant.WebApp.Types
 import Assistant.WebApp (renderUrl)
-import Yesod
 #endif
 import Assistant.Monad
 import Assistant.Types.UrlRenderer
diff --git a/Assistant/Fsck.hs b/Assistant/Fsck.hs
new file mode 100644
index 000000000..9d8848ba9
--- /dev/null
+++ b/Assistant/Fsck.hs
@@ -0,0 +1,50 @@
+{- git-annex assistant fscking
+ -
+ - Copyright 2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Fsck where
+
+import Assistant.Common
+import Types.ScheduledActivity
+import qualified Types.Remote as Remote
+import Annex.UUID
+import Assistant.Alert
+import Assistant.Types.UrlRenderer
+import Logs.Schedule
+import qualified Annex
+
+import qualified Data.Set as S
+
+{- Displays a nudge in the webapp if a fsck is not configured for
+ - the specified remote, or for the local repository. -}
+fsckNudge :: UrlRenderer -> Maybe Remote -> Assistant ()
+fsckNudge urlrenderer mr
+	| maybe True fsckableRemote mr =
+		whenM (liftAnnex $ annexFsckNudge <$> Annex.getGitConfig) $
+			unlessM (liftAnnex $ checkFscked mr) $
+				notFsckedNudge urlrenderer mr
+	| otherwise = noop
+
+fsckableRemote :: Remote -> Bool
+fsckableRemote = isJust . Remote.remoteFsck
+
+{- Checks if the remote, or the local repository, has a fsck scheduled.
+ - Only looks at fscks configured to run via the local repository, not
+ - other repositories. -}
+checkFscked :: Maybe Remote -> Annex Bool
+checkFscked mr = any wanted . S.toList <$> (scheduleGet =<< getUUID)
+  where
+	wanted = case mr of
+		Nothing -> isSelfFsck
+		Just r -> flip isFsckOf (Remote.uuid r)
+
+isSelfFsck :: ScheduledActivity -> Bool
+isSelfFsck (ScheduledSelfFsck _ _) = True
+isSelfFsck _ = False
+
+isFsckOf :: ScheduledActivity -> UUID -> Bool
+isFsckOf (ScheduledRemoteFsck u _ _) u' = u == u'
+isFsckOf _ _ = False
diff --git a/Assistant/Gpg.hs b/Assistant/Gpg.hs
new file mode 100644
index 000000000..34d00a384
--- /dev/null
+++ b/Assistant/Gpg.hs
@@ -0,0 +1,36 @@
+{- git-annex assistant gpg stuff
+ -
+ - Copyright 2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Gpg where
+
+import Utility.Gpg
+import Utility.UserInfo
+import Types.Remote (RemoteConfigKey)
+
+import qualified Data.Map as M
+import Control.Applicative
+import Prelude
+
+{- Generates a gpg user id that is not used by any existing secret key -}
+newUserId :: GpgCmd -> IO UserId
+newUserId cmd = do
+	oldkeys <- secretKeys cmd
+	username <- either (const "unknown") id <$> myUserName
+	let basekeyname = username ++ "'s git-annex encryption key"
+	return $ Prelude.head $ filter (\n -> M.null $ M.filter (== n) oldkeys)
+		( basekeyname
+		: map (\n -> basekeyname ++ show n) ([2..] :: [Int])
+		)
+
+data EnableEncryption = HybridEncryption | SharedEncryption | NoEncryption
+	deriving (Eq)
+
+{- Generates Remote configuration for encryption. -}
+configureEncryption :: EnableEncryption -> (RemoteConfigKey, String)
+configureEncryption SharedEncryption = ("encryption", "shared")
+configureEncryption NoEncryption = ("encryption", "none")
+configureEncryption HybridEncryption = ("encryption", "hybrid")
diff --git a/Assistant/Repair.hs b/Assistant/Repair.hs
new file mode 100644
index 000000000..29bdc44f1
--- /dev/null
+++ b/Assistant/Repair.hs
@@ -0,0 +1,159 @@
+{- git-annex assistant repository repair
+ -
+ - Copyright 2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.Repair where
+
+import Assistant.Common
+import Command.Repair (repairAnnexBranch, trackingOrSyncBranch)
+import Git.Fsck (FsckResults, foundBroken)
+import Git.Repair (runRepairOf)
+import qualified Git
+import qualified Remote
+import qualified Types.Remote as Remote
+import Logs.FsckResults
+import Annex.UUID
+import Utility.Batch
+import Annex.Path
+import Assistant.Sync
+import Assistant.Alert
+import Assistant.DaemonStatus
+import Assistant.Types.UrlRenderer
+#ifdef WITH_WEBAPP
+import Assistant.WebApp.Types
+import qualified Data.Text as T
+#endif
+import qualified Utility.Lsof as Lsof
+import Utility.ThreadScheduler
+
+import Control.Concurrent.Async
+
+{- When the FsckResults require a repair, tries to do a non-destructive
+ - repair. If that fails, pops up an alert. -}
+repairWhenNecessary :: UrlRenderer -> UUID -> Maybe Remote -> FsckResults -> Assistant Bool
+repairWhenNecessary urlrenderer u mrmt fsckresults
+	| foundBroken fsckresults = do
+		liftAnnex $ writeFsckResults u fsckresults
+		repodesc <- liftAnnex $ Remote.prettyUUID u
+		ok <- alertWhile (repairingAlert repodesc)
+			(runRepair u mrmt False)
+#ifdef WITH_WEBAPP
+		unless ok $ do
+			button <- mkAlertButton True (T.pack "Click Here") urlrenderer $
+				RepairRepositoryR u
+			void $ addAlert $ brokenRepositoryAlert [button]
+#endif
+		return ok
+	| otherwise = return False
+
+runRepair :: UUID -> Maybe Remote -> Bool -> Assistant Bool
+runRepair u mrmt destructiverepair = do
+	fsckresults <- liftAnnex $ readFsckResults u
+	myu <- liftAnnex getUUID
+	ok <- if u == myu
+		then localrepair fsckresults
+		else remoterepair fsckresults
+	liftAnnex $ clearFsckResults u
+	debug [ "Repaired", show u, show ok ]
+
+	return ok
+  where
+	localrepair fsckresults = do
+		-- Stop the watcher from running while running repairs.
+		changeSyncable Nothing False
+
+		-- This intentionally runs the repair inside the Annex
+		-- monad, which is not strictly necessary, but keeps
+		-- other threads that might be trying to use the Annex
+		-- from running until it completes.
+		ok <- liftAnnex $ repair fsckresults Nothing
+
+		-- Run a background fast fsck if a destructive repair had
+		-- to be done, to ensure that the git-annex branch
+		-- reflects the current state of the repo.
+		when destructiverepair $
+			backgroundfsck [ Param "--fast" ]
+
+		-- Start the watcher running again. This also triggers it to
+		-- do a startup scan, which is especially important if the
+		-- git repo repair removed files from the index file. Those
+		-- files will be seen as new, and re-added to the repository.
+		when (ok || destructiverepair) $
+			changeSyncable Nothing True
+
+		return ok
+
+	remoterepair fsckresults = case Remote.repairRepo =<< mrmt of
+		Nothing -> return False
+		Just mkrepair -> do
+			thisrepopath <- liftIO . absPath
+				=<< liftAnnex (fromRepo Git.repoPath)
+			a <- liftAnnex $ mkrepair $
+				repair fsckresults (Just thisrepopath)
+			liftIO $ catchBoolIO a
+
+	repair fsckresults referencerepo = do
+		(ok, modifiedbranches) <- inRepo $
+			runRepairOf fsckresults trackingOrSyncBranch destructiverepair referencerepo
+		when destructiverepair $
+			repairAnnexBranch modifiedbranches
+		return ok
+	
+	backgroundfsck params = liftIO $ void $ async $ do
+		program <- programPath
+		batchCommand program (Param "fsck" : params)
+
+{- Detect when a git lock file exists and has no git process currently
+ - writing to it. This strongly suggests it is a stale lock file.
+ -
+ - However, this could be on a network filesystem. Which is not very safe
+ - anyway (the assistant relies on being able to check when files have
+ - no writers to know when to commit them). Also, a few lock-file-ish
+ - things used by git are not kept open, particularly MERGE_HEAD.
+ -
+ - So, just in case, when the lock file appears stale, we delay for one
+ - minute, and check its size. If the size changed, delay for another
+ - minute, and so on. This will at work to detect when another machine
+ - is writing out a new index file, since git does so by writing the
+ - new content to index.lock.
+ -
+ - Returns true if locks were cleaned up.
+ -}
+repairStaleGitLocks :: Git.Repo -> Assistant Bool
+repairStaleGitLocks r = do
+	lockfiles <- liftIO $ filter islock <$> findgitfiles r
+	repairStaleLocks lockfiles
+	return $ not $ null lockfiles
+  where
+	findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator annexDir) True . Git.localGitDir
+	islock f
+		| "gc.pid" `isInfixOf` f = False
+		| ".lock" `isSuffixOf` f = True
+		| takeFileName f == "MERGE_HEAD" = True
+		| otherwise = False
+
+repairStaleLocks :: [FilePath] -> Assistant ()
+repairStaleLocks lockfiles = go =<< getsizes
+  where
+	getsize lf = catchMaybeIO $ (\s -> (lf, s)) <$> getFileSize lf
+	getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles
+	go [] = return ()
+	go l = ifM (liftIO $ null <$> Lsof.query ("--" : map fst l))
+		( do
+			waitforit "to check stale git lock file"
+			l' <- getsizes
+			if l' == l
+				then liftIO $ mapM_ nukeFile (map fst l)
+				else go l'
+		, do
+			waitforit "for git lock file writer"
+			go =<< getsizes
+		)
+	waitforit why = do
+		notice ["Waiting for 60 seconds", why]
+		liftIO $ threadDelaySeconds $ Seconds 60
diff --git a/Assistant/Restart.hs b/Assistant/Restart.hs
new file mode 100644
index 000000000..be1b21392
--- /dev/null
+++ b/Assistant/Restart.hs
@@ -0,0 +1,117 @@
+{- git-annex assistant restarting
+ -
+ - Copyright 2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.Restart where
+
+import Assistant.Common
+import Assistant.Threads.Watcher
+import Assistant.DaemonStatus
+import Assistant.NamedThread
+import Utility.ThreadScheduler
+import Utility.NotificationBroadcaster
+import Utility.Url
+import Utility.PID
+import qualified Git.Construct
+import qualified Git.Config
+import qualified Annex
+import qualified Git
+import Annex.Path
+
+import Control.Concurrent
+#ifndef mingw32_HOST_OS
+import System.Posix (signalProcess, sigTERM)
+#else
+import Utility.WinProcess
+#endif
+import Network.URI
+
+{- Before the assistant can be restarted, have to remove our 
+ - gitAnnexUrlFile and our gitAnnexPidFile. Pausing the watcher is also
+ - a good idea, to avoid fighting when two assistants are running in the
+ - same repo.
+ -}
+prepRestart :: Assistant ()
+prepRestart = do
+	liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread
+	liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexUrlFile)
+	liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexPidFile)
+
+{- To finish a restart, send a global redirect to the new url
+ - to any web browsers that are displaying the webapp.
+ -
+ - Wait for browser to update before terminating this process. -}
+postRestart :: URLString -> Assistant ()
+postRestart url = do
+	modifyDaemonStatus_ $ \status -> status { globalRedirUrl = Just url }
+	liftIO . sendNotification . globalRedirNotifier =<< getDaemonStatus
+	void $ liftIO $ forkIO $ do
+		threadDelaySeconds (Seconds 120)
+		terminateSelf
+
+terminateSelf :: IO ()
+terminateSelf =
+#ifndef mingw32_HOST_OS
+		signalProcess sigTERM =<< getPID
+#else
+		terminatePID =<< getPID
+#endif
+
+runRestart :: Assistant URLString
+runRestart = liftIO . newAssistantUrl
+	=<< liftAnnex (Git.repoLocation <$> Annex.gitRepo)
+
+{- Starts up the assistant in the repository, and waits for it to create
+ - a gitAnnexUrlFile. Waits for the assistant to be up and listening for
+ - connections by testing the url. -}
+newAssistantUrl :: FilePath -> IO URLString
+newAssistantUrl repo = do
+	startAssistant repo
+	geturl
+  where
+	geturl = do
+		r <- Git.Config.read =<< Git.Construct.fromPath repo
+		waiturl $ gitAnnexUrlFile r
+	waiturl urlfile = do
+		v <- tryIO $ readFile urlfile
+		case v of
+			Left _ -> delayed $ waiturl urlfile
+			Right url -> ifM (assistantListening url)
+				( return url
+				, delayed $ waiturl urlfile
+				)
+	delayed a = do
+		threadDelay 100000 -- 1/10th of a second
+		a
+
+{- Checks if the assistant is listening on an url.
+ -
+ - Always checks http, because https with self-signed cert is problematic.
+ - warp-tls listens to http, in order to show an error page, so this works.
+ -}
+assistantListening :: URLString -> IO Bool
+assistantListening url = catchBoolIO $ exists url' def
+  where
+	url' = case parseURI url of
+		Nothing -> url
+		Just uri -> show $ uri
+			{ uriScheme = "http:"
+			}
+
+{- Does not wait for assistant to be listening for web connections. 
+ -
+ - On windows, the assistant does not daemonize, which is why the forkIO is
+ - done.
+ -}
+startAssistant :: FilePath -> IO ()
+startAssistant repo = void $ forkIO $ do
+	program <- programPath
+	(_, _, _, pid) <- 
+		createProcess $
+			(proc program ["assistant"]) { cwd = Just repo }
+	void $ checkSuccessProcess pid
diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs
index e46910ccd..3feed290e 100644
--- a/Assistant/Sync.hs
+++ b/Assistant/Sync.hs
@@ -19,6 +19,7 @@ import Utility.Parallel
 import qualified Git
 import qualified Git.Command
 import qualified Git.Merge
+import qualified Git.Ref
 import qualified Remote
 import qualified Types.Remote as Remote
 import qualified Remote.List as Remote
@@ -204,16 +205,9 @@ manualPull currentbranch remotes = do
 			)
 	haddiverged <- liftAnnex Annex.Branch.forceUpdate
 	forM_ normalremotes $ \r ->
-		liftAnnex $ Command.Sync.mergeRemote r currentbranch mergeConfig
+		liftAnnex $ Command.Sync.mergeRemote r currentbranch Command.Sync.mergeConfig
 	return (catMaybes failed, haddiverged)
 
-mergeConfig :: [Git.Merge.MergeConfig]
-mergeConfig = 
-	[ Git.Merge.MergeNonInteractive
-	-- Pairing involves merging unrelated histories
-	, Git.Merge.MergeUnrelatedHistories
-	]
-
 {- Start syncing a remote, using a background thread. -}
 syncRemote :: Remote -> Assistant ()
 syncRemote remote = do
diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs
index c38c2f375..4da8795f9 100644
--- a/Assistant/Threads/Merger.hs
+++ b/Assistant/Threads/Merger.hs
@@ -11,6 +11,8 @@ import Assistant.Common
 import Assistant.TransferQueue
 import Assistant.BranchChange
 import Assistant.Sync
+import Assistant.DaemonStatus
+import Assistant.ScanRemotes
 import Utility.DirWatcher
 import Utility.DirWatcher.Types
 import qualified Annex.Branch
@@ -78,7 +80,7 @@ onChange file
 					, "into", Git.fromRef b
 					]
 				void $ liftAnnex $ Command.Sync.merge
-					currbranch mergeConfig
+					currbranch Command.Sync.mergeConfig
 					Git.Branch.AutomaticCommit
 					changedbranch
 	mergecurrent _ = noop
diff --git a/Assistant/Threads/RemoteControl.hs b/Assistant/Threads/RemoteControl.hs
index 447b493c6..1aa8bc9c8 100644
--- a/Assistant/Threads/RemoteControl.hs
+++ b/Assistant/Threads/RemoteControl.hs
@@ -30,7 +30,7 @@ remoteControlThread :: NamedThread
 remoteControlThread = namedThread "RemoteControl" $ do
 	program <- liftIO programPath
 	(cmd, params) <- liftIO $ toBatchCommand
-		(program, [Param "remotedaemon"])
+		(program, [Param "remotedaemon", Param "--foreground"])
 	let p = proc cmd (toCommand params)
 	(Just toh, Just fromh, _, pid) <- liftIO $ createProcess p
 		{ std_in = CreatePipe
diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs
index 1f50065b9..4b82a799d 100644
--- a/Assistant/Threads/Watcher.hs
+++ b/Assistant/Threads/Watcher.hs
@@ -65,10 +65,10 @@ checkCanWatch
 #else
 		noop
 #endif
-	| otherwise = error "watch mode is not available on this system"
+	| otherwise = giveup "watch mode is not available on this system"
 
 needLsof :: Annex ()
-needLsof = error $ unlines
+needLsof = giveup $ unlines
 	[ "The lsof command is needed for watch mode to be safe, and is not in PATH."
 	, "To override lsof checks to ensure that files are not open for writing"
 	, "when added to the annex, you can use --force"
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index 5cc689595..928d0cdd3 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/Assistant/Threads/WebApp.hs
@@ -38,6 +38,7 @@ import Assistant.WebApp.OtherRepos
 import Assistant.WebApp.Repair
 import Assistant.Types.ThreadedMonad
 import Utility.WebApp
+import Utility.AuthToken
 import Utility.Tmp
 import Utility.FileMode
 import Git
@@ -70,11 +71,11 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
 #ifdef __ANDROID__
 	when (isJust listenhost') $
 		-- See Utility.WebApp
-		error "Sorry, --listen is not currently supported on Android"
+		giveup "Sorry, --listen is not currently supported on Android"
 #endif
 	webapp <- WebApp
 		<$> pure assistantdata
-		<*> genAuthToken
+		<*> genAuthToken 128
 		<*> getreldir
 		<*> pure staticRoutes
 		<*> pure postfirstrun
diff --git a/Assistant/TransferrerPool.hs b/Assistant/TransferrerPool.hs
index 7c0cb4415..892e156e8 100644
--- a/Assistant/TransferrerPool.hs
+++ b/Assistant/TransferrerPool.hs
@@ -74,8 +74,6 @@ mkTransferrer program batchmaker = do
 		, std_in = CreatePipe
 		, std_out = CreatePipe
 		}
-	fileEncoding readh
-	fileEncoding writeh
 	return $ Transferrer
 		{ transferrerRead = readh
 		, transferrerWrite = writeh
diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs
new file mode 100644
index 000000000..afbb61924
--- /dev/null
+++ b/Assistant/Upgrade.hs
@@ -0,0 +1,361 @@
+{- git-annex assistant upgrading
+ -
+ - Copyright 2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.Upgrade where
+
+import Assistant.Common
+import Assistant.Restart
+import qualified Annex
+import Assistant.Alert
+import Assistant.DaemonStatus
+import Utility.Env
+import Types.Distribution
+import Types.Transfer
+import Logs.Web
+import Logs.Presence
+import Logs.Location
+import Annex.Content
+import Annex.UUID
+import qualified Backend
+import qualified Types.Backend
+import qualified Types.Key
+import Assistant.TransferQueue
+import Assistant.TransferSlots
+import Remote (remoteFromUUID)
+import Annex.Path
+import Config.Files
+import Utility.ThreadScheduler
+import Utility.Tmp
+import Utility.UserInfo
+import Utility.Gpg
+import Utility.FileMode
+import qualified Utility.Lsof as Lsof
+import qualified Build.SysConfig
+import qualified Utility.Url as Url
+import qualified Annex.Url as Url
+
+import qualified Data.Map as M
+import Data.Tuple.Utils
+
+{- Upgrade without interaction in the webapp. -}
+unattendedUpgrade :: Assistant ()
+unattendedUpgrade = do
+	prepUpgrade
+	url <- runRestart
+	postUpgrade url
+
+prepUpgrade :: Assistant ()
+prepUpgrade = do
+	void $ addAlert upgradingAlert
+	liftIO $ setEnv upgradedEnv "1" True
+	prepRestart
+
+postUpgrade :: URLString -> Assistant ()
+postUpgrade = postRestart
+
+autoUpgradeEnabled :: Assistant Bool
+autoUpgradeEnabled = liftAnnex $ (==) AutoUpgrade . annexAutoUpgrade <$> Annex.getGitConfig
+
+checkSuccessfulUpgrade :: IO Bool
+checkSuccessfulUpgrade = isJust <$> getEnv upgradedEnv
+
+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,
+ - and finishes the upgrade.
+ -
+ - Creates the destination directory where the upgrade will be installed
+ - early, in order to check if another upgrade has happened (or is
+ - happending). On failure, the directory is removed.
+ -}
+startDistributionDownload :: GitAnnexDistribution -> Assistant ()
+startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO oldVersionLocation
+  where
+	go Nothing = debug ["Skipping redundant upgrade"]
+	go (Just dest) = do
+		liftAnnex $ setUrlPresent webUUID k u
+		hook <- asIO1 $ distributionDownloadComplete d dest cleanup
+		modifyDaemonStatus_ $ \s -> s
+			{ transferHook = M.insert k hook (transferHook s) }
+		maybe noop (queueTransfer "upgrade" Next (Just f) t)
+			=<< liftAnnex (remoteFromUUID webUUID)
+		startTransfer t
+	k = distributionKey d
+	u = distributionUrl d
+	f = takeFileName u ++ " (for upgrade)"
+	t = Transfer
+		{ transferDirection = Download
+		, transferUUID = webUUID
+		, transferKey = k
+		}
+	cleanup = liftAnnex $ do
+		lockContentForRemoval k removeAnnex
+		setUrlMissing webUUID k u
+		logStatus k InfoMissing
+
+{- Called once the download is done.
+ - Passed an action that can be used to clean up the downloaded file.
+ -
+ - Verifies the content of the downloaded key.
+ -}
+distributionDownloadComplete :: GitAnnexDistribution -> FilePath -> Assistant () -> Transfer -> Assistant ()
+distributionDownloadComplete d dest cleanup t 
+	| transferDirection t == Download = do
+		debug ["finished downloading git-annex distribution"]
+		maybe (failedupgrade "bad download") go
+			=<< liftAnnex (withObjectLoc k fsckit (getM fsckit))
+	| otherwise = cleanup
+  where
+	k = distributionKey d
+	fsckit f = case Backend.maybeLookupBackendName (Types.Key.keyBackendName k) of
+		Nothing -> return $ Just f
+		Just b -> case Types.Backend.verifyKeyContent b of
+			Nothing -> return $ Just f
+			Just verifier -> ifM (verifier k f)
+				( return $ Just f
+				, return Nothing
+				)
+	go f = do
+		ua <- asIO $ upgradeToDistribution dest cleanup f
+		fa <- asIO1 failedupgrade
+		liftIO $ ua `catchNonAsync` (fa . show)
+	failedupgrade msg = do
+		void $ addAlert $ upgradeFailedAlert msg
+		cleanup
+		liftIO $ void $ tryIO $ removeDirectoryRecursive dest
+
+{- The upgrade method varies by OS.
+ -
+ - 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 :: FilePath -> Assistant () -> FilePath -> Assistant ()
+upgradeToDistribution newdir cleanup distributionfile = do
+	liftIO $ createDirectoryIfMissing True newdir
+	(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 $ void $ tryIO deleteold
+	postUpgrade url
+  where
+	changeprogram program = liftIO $ do
+		unlessM (boolSystem program [Param "version"]) $
+			giveup "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 = liftIO $ do
+		olddir <- oldVersionLocation
+		withTmpDirIn (parentDir newdir) "git-annex.upgrade" $ \tmpdir -> do
+			void $ boolSystem "hdiutil"
+				[ Param "attach", File distributionfile
+				, Param "-mountpoint", File tmpdir
+				]
+			void $ boolSystem "cp"
+				[ Param "-R"
+				, File $ tmpdir </> installBase </> "Contents"
+				, File $ newdir
+				]
+			void $ boolSystem "hdiutil"
+				[ Param "eject"
+				, File tmpdir
+				]
+			sanitycheck newdir
+		let deleteold = do
+			deleteFromManifest $ olddir </> "Contents" </> "MacOS"
+			makeorigsymlink olddir
+		return (newdir </> "Contents" </> "MacOS" </> "git-annex", deleteold)
+#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 <- oldVersionLocation
+		withTmpDirIn (parentDir newdir) "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 distributionfile ++
+					" > " ++ shellEscape tarball
+				]
+			tarok <- boolSystem "tar"
+				[ Param "xf"
+				, Param tarball
+				, Param "--directory", File tmpdir
+				]
+			unless tarok $
+				error $ "failed to untar " ++ distributionfile
+			sanitycheck $ tmpdir </> installBase
+			installby rename newdir (tmpdir </> installBase)
+		let deleteold = do
+			deleteFromManifest olddir
+			makeorigsymlink olddir
+		return (newdir </> "git-annex", deleteold)
+	installby a dstdir srcdir =
+		mapM_ (\x -> a x (dstdir </> takeFileName x))
+			=<< dirContents srcdir
+#endif
+	sanitycheck dir = 
+		unlessM (doesDirectoryExist dir) $
+			error $ "did not find " ++ dir ++ " in " ++ distributionfile
+	makeorigsymlink olddir = do
+		let origdir = parentDir olddir </> installBase
+		nukeFile origdir
+		createSymbolicLink newdir origdir
+
+{- Finds where the old version was installed. -}
+oldVersionLocation :: IO FilePath
+oldVersionLocation = do
+	pdir <- parentDir <$> readProgramFile
+#ifdef darwin_HOST_OS
+	let dirs = splitDirectories pdir
+	{- It will probably be deep inside a git-annex.app directory. -}
+	let olddir = case findIndex ("git-annex.app" `isPrefixOf`) dirs of
+		Nothing -> pdir
+		Just i -> joinPath (take (i + 1) dirs)
+#else
+	let olddir = pdir
+#endif
+	when (null olddir) $
+		error $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ pdir ++ ")"
+	return olddir
+
+{- Finds a place to install the new version.
+ - Generally, put it in the parent directory of where the old version was
+ - installed, and use a version number in the directory name.
+ - If unable to write to there, instead put it in the home directory.
+ -
+ - The directory is created. If it already exists, returns Nothing.
+ -}
+newVersionLocation :: GitAnnexDistribution -> FilePath -> IO (Maybe FilePath)
+newVersionLocation d olddir = 
+	trymkdir newloc $ do
+		home <- myHomeDir
+		trymkdir (home </> s) $
+			return Nothing
+  where
+	s = installBase ++ "." ++ distributionVersion d
+	topdir = parentDir olddir
+	newloc = topdir </> s
+	trymkdir dir fallback =
+		(createDirectory dir >> return (Just dir))
+			`catchIO` const fallback
+
+installBase :: String
+installBase = "git-annex." ++
+#ifdef linux_HOST_OS
+	"linux"
+#else
+#ifdef darwin_HOST_OS
+	"app"
+#else
+	"dir"
+#endif
+#endif
+
+deleteFromManifest :: FilePath -> IO ()
+deleteFromManifest dir = do
+	fs <- map (dir </>) . lines <$> catchDefaultIO "" (readFile manifest)
+	mapM_ nukeFile fs
+	nukeFile manifest
+	removeEmptyRecursive dir
+  where
+	manifest = dir </> "git-annex.MANIFEST"
+
+removeEmptyRecursive :: FilePath -> IO ()
+removeEmptyRecursive dir = do
+	mapM_ removeEmptyRecursive =<< dirContents dir
+	void $ tryIO $ removeDirectory dir
+
+{- This is a file that the UpgradeWatcher can watch for modifications to
+ - detect when git-annex has been upgraded.
+ -}
+upgradeFlagFile :: IO FilePath
+upgradeFlagFile = 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.
+		program <- programPath
+		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]
+
+usingDistribution :: IO Bool
+usingDistribution = isJust <$> getEnv "GIT_ANNEX_STANDLONE_ENV"
+
+downloadDistributionInfo :: Assistant (Maybe GitAnnexDistribution)
+downloadDistributionInfo = do
+	uo <- liftAnnex Url.getUrlOptions
+	gpgcmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig
+	liftIO $ withTmpDir "git-annex.tmp" $ \tmpdir -> do
+		let infof = tmpdir </> "info"
+		let sigf = infof ++ ".sig"
+		ifM (Url.downloadQuiet distributionInfoUrl infof uo
+			<&&> Url.downloadQuiet distributionInfoSigUrl sigf uo
+			<&&> verifyDistributionSig gpgcmd sigf)
+			( readish <$> readFileStrict infof
+			, return Nothing
+			)
+
+distributionInfoUrl :: String
+distributionInfoUrl = fromJust Build.SysConfig.upgradelocation ++ ".info"
+
+distributionInfoSigUrl :: String
+distributionInfoSigUrl = distributionInfoUrl ++ ".sig"
+
+{- Verifies that a file from the git-annex distribution has a valid
+ - signature. Pass the detached .sig file; the file to be verified should
+ - be located next to it.
+ -
+ - The gpg keyring used to verify the signature is located in
+ - trustedkeys.gpg, next to the git-annex program.
+ -}
+verifyDistributionSig :: GpgCmd -> FilePath -> IO Bool
+verifyDistributionSig gpgcmd sig = do
+	p <- readProgramFile
+	if isAbsolute p
+		then withUmask 0o0077 $ withTmpDir "git-annex-gpg.tmp" $ \gpgtmp -> do
+			let trustedkeys = takeDirectory p </> "trustedkeys.gpg"
+			boolGpgCmd gpgcmd
+				[ Param "--no-default-keyring"
+				, Param "--no-auto-check-trustdb"
+				, Param "--no-options"
+				, Param "--homedir"
+				, File gpgtmp
+				, Param "--keyring"
+				, File trustedkeys
+				, Param "--verify"
+				, File sig
+				]
+		else return False