766c31c95c
Not yet wired up to restart the assistant on upgrade; that needs careful sanity checking to wait until the upgrade is done before restarting. Used the DirWatcher here, so it gets events for any changes to the directory containing the program file. (But not subdirs.) This is necessary in order to detect when the file is renamed as part of the upgrade, which an inotify on a single file would not detect. (Also, I have DirWatcher code, but not FileWatcher code.) Note that upgrades that remove or rename a whole directory tree containing the executable will *not* trigger this code. So eg, deleting and replacing the whole standalone tarball dir tree won't work -- but untarring it over top will. So should dpkg package upgrades. Added programPath, using a new GHC feature to find the full path to the executable. The fallback code for old GHC or unsupported OS is less good; its worst failure mode would be either failing to find the program, and so not checking for upgrades, or finding a git-annex that's in PATH, but is not the one running. This commit was sponsored by John Roepke.
93 lines
2.9 KiB
Haskell
93 lines
2.9 KiB
Haskell
{- git-annex assistant thread to detect when upgrade is available
|
|
-
|
|
- Copyright 2013 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Assistant.Threads.Upgrader (
|
|
upgraderThread
|
|
) where
|
|
|
|
import Assistant.Common
|
|
import Assistant.Types.UrlRenderer
|
|
import Assistant.DaemonStatus
|
|
import Assistant.Alert
|
|
import Utility.NotificationBroadcaster
|
|
import Utility.Tmp
|
|
import qualified Annex
|
|
import qualified Build.SysConfig
|
|
import qualified Utility.Url as Url
|
|
import qualified Annex.Url as Url
|
|
import qualified Git.Version
|
|
import Types.Distribution
|
|
#ifdef WITH_WEBAPP
|
|
import Assistant.WebApp.Types
|
|
#endif
|
|
|
|
import Data.Time.Clock
|
|
import qualified Data.Text as T
|
|
|
|
upgraderThread :: UrlRenderer -> NamedThread
|
|
upgraderThread urlrenderer = namedThread "Upgrader" $ do
|
|
checkUpgrade urlrenderer
|
|
when (isJust Build.SysConfig.upgradelocation) $ do
|
|
h <- liftIO . newNotificationHandle False . networkConnectedNotifier =<< getDaemonStatus
|
|
go h Nothing
|
|
where
|
|
{- Wait for a network connection event. Then see if it's been
|
|
- half a day since the last upgrade check. If so, proceed with
|
|
- check. -}
|
|
go h lastchecked = do
|
|
liftIO $ waitNotification h
|
|
autoupgrade <- liftAnnex $ annexAutoUpgrade <$> Annex.getGitConfig
|
|
if autoupgrade == NoAutoUpgrade
|
|
then go h lastchecked
|
|
else do
|
|
now <- liftIO getCurrentTime
|
|
if maybe True (\t -> diffUTCTime now t > halfday) lastchecked
|
|
then do
|
|
checkUpgrade urlrenderer
|
|
go h =<< Just <$> liftIO getCurrentTime
|
|
else go h lastchecked
|
|
halfday = 12 * 60 * 60
|
|
|
|
checkUpgrade :: UrlRenderer -> Assistant ()
|
|
checkUpgrade urlrenderer = do
|
|
debug [ "Checking if an upgrade is available." ]
|
|
go =<< getDistributionInfo
|
|
where
|
|
go Nothing = debug [ "Failed to check if upgrade is available." ]
|
|
go (Just d) = do
|
|
let installed = Git.Version.normalize Build.SysConfig.packageversion
|
|
let avail = Git.Version.normalize $ distributionVersion d
|
|
let old = Git.Version.normalize <$> distributionUrgentUpgrade d
|
|
if Just installed <= old
|
|
then canUpgrade High urlrenderer d
|
|
else if installed < avail
|
|
then canUpgrade Low urlrenderer d
|
|
else debug [ "No new version found." ]
|
|
|
|
canUpgrade :: AlertPriority -> UrlRenderer -> GitAnnexDistribution -> Assistant ()
|
|
canUpgrade urgency urlrenderer d = do
|
|
#ifdef WITH_WEBAPP
|
|
button <- mkAlertButton False (T.pack "Upgrade") urlrenderer (ConfigUpgradeR d)
|
|
void $ addAlert (canUpgradeAlert urgency button)
|
|
#else
|
|
noop
|
|
#endif
|
|
|
|
getDistributionInfo :: Assistant (Maybe GitAnnexDistribution)
|
|
getDistributionInfo = do
|
|
ua <- liftAnnex Url.getUserAgent
|
|
liftIO $ withTmpFile "git-annex.tmp" $ \tmpfile h -> do
|
|
hClose h
|
|
ifM (Url.downloadQuiet distributionInfoUrl [] [] tmpfile ua)
|
|
( readish <$> readFileStrict tmpfile
|
|
, return Nothing
|
|
)
|
|
|
|
distributionInfoUrl :: String
|
|
distributionInfoUrl = fromJust Build.SysConfig.upgradelocation ++ ".info"
|