upgrade alerts

The webapp will check twice a day, when the network is connected, to see if
it can download a distributon upgrade file. If a newer version is found,
display an upgrade alert.

This will need the autobuilders to set UPGRADE_LOCATION to the url
it can be downloaded from when building git-annex. Only builds with that
set need automatic upgrade alerts.

Currently, the upgrade page just requests the user manually download
and upgrade it. But, all the info is provided to do automated upgrades
in the future.

Note that urls used will need to all be https.

This commit was sponsored by Dirk Kraft.

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

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!"
 

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]

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"

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

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
 

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

Assistant/WebApp/Configurators/Upgrade.hs

@@ -0,0 +1,24 @@
+{- git-annex assistant webapp upgrade UI
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
+
+module Assistant.WebApp.Configurators.Upgrade where
+
+import Assistant.WebApp.Common
+import Types.Distribution
+import Utility.HumanTime
+
+import Data.Time.Clock
+
+getConfigUpgradeR :: GitAnnexDistribution -> Handler Html
+getConfigUpgradeR d = page "Upgrade git-annex" (Just Configuration) $ do
+	now <- liftIO getCurrentTime
+	let upgradeage = Duration $ floor $
+		now `diffUTCTime` distributionReleasedate d
+	$(widgetFile "configurators/upgrade")
+

Assistant/WebApp/SideBar.hs

@@ -97,6 +97,7 @@ htmlIcon SyncIcon = [whamlet|<img src="@{StaticR syncicon_gif}" alt="">|]
 htmlIcon InfoIcon = bootstrapIcon "info-sign"
 htmlIcon SuccessIcon = bootstrapIcon "ok"
 htmlIcon ErrorIcon = bootstrapIcon "exclamation-sign"
+htmlIcon UpgradeIcon = bootstrapIcon "arrow-up"
 -- utf-8 umbrella (utf-8 cloud looks too stormy)
 htmlIcon TheCloud = [whamlet|&#9730;|]
 

Assistant/WebApp/Types.hs

@@ -25,6 +25,7 @@ import Utility.Gpg (KeyId)
 import Build.SysConfig (packageversion)
 import Types.ScheduledActivity
 import Assistant.WebApp.RepoId
+import Types.Distribution
 
 import Yesod.Static
 import Text.Hamlet
@@ -222,3 +223,7 @@ instance PathPiece ScheduledActivity where
 instance PathPiece RepoId where
 	toPathPiece = pack . show
 	fromPathPiece = readish . unpack
+
+instance PathPiece GitAnnexDistribution where
+	toPathPiece = pack . show
+	fromPathPiece = readish . unpack

Assistant/WebApp/routes

@@ -21,6 +21,7 @@
 /config/xmpp/needcloudrepo/#UUID NeedCloudRepoR GET
 /config/fsck ConfigFsckR GET POST
 /config/fsck/preferences ConfigFsckPreferencesR POST
+/config/upgrade/#GitAnnexDistribution ConfigUpgradeR GET
 
 /config/addrepository AddRepositoryR GET
 /config/repository/new NewRepositoryR GET POST

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

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

templates/configurators/upgrade.hamlet

@@ -0,0 +1,12 @@
+<div .span9 .hero-unit>
+  <h2>
+    Upgrade git-annex
+  <p>
+    Version #{distributionVersion d} was released #
+    #{fromDuration upgradeage} ago.
+  <p>
+    To upgrade to this version, you will need to manually download and #
+    install it. (Sorry, upgrades are not automated yet..)
+  <p>
+    <a .btn .btn-primary href="#{distributionUrl d}">
+      Download