diff options
| -rw-r--r-- | Assistant.hs | 2 | ||||
| -rw-r--r-- | Assistant/Alert.hs | 20 | ||||
| -rw-r--r-- | Assistant/Threads/NetWatcher.hs | 5 | ||||
| -rw-r--r-- | Assistant/Threads/Upgrader.hs | 87 | ||||
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 1 | ||||
| -rw-r--r-- | Assistant/Types/Alert.hs | 3 | ||||
| -rw-r--r-- | Assistant/Types/DaemonStatus.hs | 3 | ||||
| -rw-r--r-- | Build/Configure.hs | 9 | ||||
| -rw-r--r-- | Types/Distribution.hs | 21 |
9 files changed, 148 insertions, 3 deletions
diff --git a/Assistant.hs b/Assistant.hs index 00746b785..fd8e18843 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -28,6 +28,7 @@ import Assistant.Threads.ProblemFixer import Assistant.Threads.MountWatcher #endif import Assistant.Threads.NetWatcher +import Assistant.Threads.Upgrader import Assistant.Threads.TransferScanner import Assistant.Threads.TransferPoller import Assistant.Threads.ConfigMonitor @@ -150,6 +151,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser = , assist $ mountWatcherThread urlrenderer #endif , assist $ netWatcherThread + , assist $ upgraderThread urlrenderer , assist $ netWatcherFallbackThread , assist $ transferScannerThread urlrenderer , assist $ cronnerThread urlrenderer diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index 8bdedaa3e..93eea6d7d 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -215,6 +215,26 @@ notFsckedAlert mr button = Alert , alertData = [] } +canUpgradeAlert :: AlertPriority -> AlertButton -> Alert +canUpgradeAlert priority button = Alert + { alertHeader = Just $ fromString $ concat + [ if priority >= High + then "An important upgrade of git-annex is available!" + else "An upgrade of git-annex is available." + ] + , alertIcon = Just UpgradeIcon + , alertPriority = priority + , alertButton = Just button + , alertClosable = True + , alertClass = Message + , alertMessageRender = renderData + , alertCounter = 0 + , alertBlockDisplay = True + , alertName = Just UpgradeAlert + , alertCombiner = Just $ dataCombiner $ \_old new -> new + , alertData = [] + } + brokenRepositoryAlert :: AlertButton -> Alert brokenRepositoryAlert = errorAlert "Serious problems have been detected with your repository. This needs your immediate attention!" diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs index 0d8442c69..a7124fa01 100644 --- a/Assistant/Threads/NetWatcher.hs +++ b/Assistant/Threads/NetWatcher.hs @@ -15,6 +15,7 @@ import Assistant.Sync import Utility.ThreadScheduler import qualified Types.Remote as Remote import Assistant.DaemonStatus +import Utility.NotificationBroadcaster #if WITH_DBUS import Utility.DBus @@ -127,7 +128,9 @@ listenWicdConnections client callback = #endif handleConnection :: Assistant () -handleConnection = reconnectRemotes True =<< networkRemotes +handleConnection = do + liftIO . sendNotification . networkConnectedNotifier =<< getDaemonStatus + reconnectRemotes True =<< networkRemotes {- Network remotes to sync with. -} networkRemotes :: Assistant [Remote] diff --git a/Assistant/Threads/Upgrader.hs b/Assistant/Threads/Upgrader.hs new file mode 100644 index 000000000..86a42514d --- /dev/null +++ b/Assistant/Threads/Upgrader.hs @@ -0,0 +1,87 @@ +{- git-annex assistant thread to detect when upgrade is needed + - + - 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 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 -- TODO: remove + 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 + 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 Low urlrenderer d + else when (installed < avail) $ + canUpgrade High urlrenderer d + +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" diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index b380094d6..2ad61168e 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -30,6 +30,7 @@ import Assistant.WebApp.Configurators.Preferences import Assistant.WebApp.Configurators.Edit import Assistant.WebApp.Configurators.Delete import Assistant.WebApp.Configurators.Fsck +import Assistant.WebApp.Configurators.Upgrade import Assistant.WebApp.Documentation import Assistant.WebApp.Control import Assistant.WebApp.OtherRepos diff --git a/Assistant/Types/Alert.hs b/Assistant/Types/Alert.hs index 2e52ca7ef..c2a89a698 100644 --- a/Assistant/Types/Alert.hs +++ b/Assistant/Types/Alert.hs @@ -31,6 +31,7 @@ data AlertName | CloudRepoNeededAlert | SyncAlert | NotFsckedAlert + | UpgradeAlert deriving (Eq) {- The first alert is the new alert, the second is an old alert. @@ -52,7 +53,7 @@ data Alert = Alert , alertButton :: Maybe AlertButton } -data AlertIcon = ActivityIcon | SyncIcon | SuccessIcon | ErrorIcon | InfoIcon | TheCloud +data AlertIcon = ActivityIcon | SyncIcon | SuccessIcon | ErrorIcon | InfoIcon | UpgradeIcon | TheCloud type AlertMap = M.Map AlertId Alert diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs index 5d2f5bb37..ecf67eaf7 100644 --- a/Assistant/Types/DaemonStatus.hs +++ b/Assistant/Types/DaemonStatus.hs @@ -67,6 +67,8 @@ data DaemonStatus = DaemonStatus , scheduleLogNotifier :: NotificationBroadcaster -- Broadcasts a notification once the startup sanity check has run. , startupSanityCheckNotifier :: NotificationBroadcaster + -- Broadcasts notifications when the network is connected + , networkConnectedNotifier :: NotificationBroadcaster -- When the XMPP client is connected, this will contain the XMPP -- address. , xmppClientID :: Maybe ClientID @@ -103,5 +105,6 @@ newDaemonStatus = DaemonStatus <*> newNotificationBroadcaster <*> newNotificationBroadcaster <*> newNotificationBroadcaster + <*> newNotificationBroadcaster <*> pure Nothing <*> pure M.empty diff --git a/Build/Configure.hs b/Build/Configure.hs index 262ac2080..8884d57db 100644 --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -7,7 +7,7 @@ import Data.List import System.Process import Control.Applicative import System.FilePath -import System.Environment +import System.Environment (getArgs) import Data.Maybe import Control.Monad.IfElse import Data.Char @@ -17,11 +17,13 @@ import Build.Version import Utility.SafeCommand import Utility.Monad import Utility.ExternalSHA +import Utility.Env import qualified Git.Version tests :: [TestCase] tests = [ TestCase "version" getVersion + , TestCase "UPGRADE_LOCATION" getUpgradeLocation , TestCase "git" $ requireCmd "git" "git --version >/dev/null" , TestCase "git version" getGitVersion , testCp "cp_a" "-a" @@ -90,6 +92,11 @@ testCp k option = TestCase cmd $ testCmd k cmdline cmd = "cp " ++ option cmdline = cmd ++ " " ++ testFile ++ " " ++ testFile ++ ".new" +getUpgradeLocation :: Test +getUpgradeLocation = do + e <- getEnv "UPGRADE_LOCATION" + return $ Config "upgradelocation" $ MaybeStringConfig e + getGitVersion :: Test getGitVersion = Config "gitversion" . StringConfig . show <$> Git.Version.installed diff --git a/Types/Distribution.hs b/Types/Distribution.hs new file mode 100644 index 000000000..92558d6fa --- /dev/null +++ b/Types/Distribution.hs @@ -0,0 +1,21 @@ +{- Data type for a distribution of git-annex + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Types.Distribution where + +import Data.Time.Clock + +data GitAnnexDistribution = GitAnnexDistribution + { distributionUrl :: String + , distributionSha256 :: String + , distributionVersion :: GitAnnexVersion + , distributionReleasedate :: UTCTime + , distributionUrgentUpgrade :: Maybe GitAnnexVersion + } + deriving (Read, Show, Eq) + +type GitAnnexVersion = String |