summaryrefslogtreecommitdiff
path: root/Assistant
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2016-12-24 14:48:51 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2016-12-24 15:01:55 -0400
commit42e08cd4575d3dc558dfe172c1f28c752d69e8c6 (patch)
tree78a8eddc31c390aaf8f66435bb13db9366f9a7c4 /Assistant
parent34f375526f44ff255d45bbabcd1425b3d5d0bb4a (diff)
parent3b9d9a267b7c9247d36d9b622e1b836724ca5fb0 (diff)
Merge branch 'master' into no-xmpp
Diffstat (limited to 'Assistant')
-rw-r--r--Assistant/Alert.hs1
-rw-r--r--Assistant/Fsck.hs50
-rw-r--r--Assistant/Gpg.hs36
-rw-r--r--Assistant/Repair.hs159
-rw-r--r--Assistant/Restart.hs117
-rw-r--r--Assistant/Sync.hs10
-rw-r--r--Assistant/Threads/Merger.hs4
-rw-r--r--Assistant/Threads/RemoteControl.hs2
-rw-r--r--Assistant/Threads/Watcher.hs4
-rw-r--r--Assistant/Threads/WebApp.hs5
-rw-r--r--Assistant/TransferrerPool.hs2
-rw-r--r--Assistant/Upgrade.hs361
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