webapp: Check annex.version.

Assistant.hs

@@ -64,8 +64,8 @@ stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile
  -
  - startbrowser is passed the url and html shim file, as well as the original
  - stdout and stderr descriptors. -}
-startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe HostName ->  Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex ()
+startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe String -> Maybe HostName ->  Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex ()
-startDaemon assistant foreground startdelay listenhost startbrowser = do
+startDaemon assistant foreground startdelay cannotrun listenhost startbrowser = do
 	Annex.changeState $ \s -> s { Annex.daemon = True }
 	pidfile <- fromRepo gitAnnexPidFile
 	logfile <- fromRepo gitAnnexLogFile
@@ -117,44 +117,51 @@ startDaemon assistant foreground startdelay listenhost startbrowser = do
 #endif
 		notice ["starting", desc, "version", SysConfig.packageversion]
 		urlrenderer <- liftIO newUrlRenderer
-		mapM_ (startthread urlrenderer)
-			[ watch $ commitThread
 #ifdef WITH_WEBAPP
-			, assist $ webAppThread d urlrenderer False listenhost Nothing webappwaiter
+		let webappthread = [ assist $ webAppThread d urlrenderer False cannotrun listenhost Nothing webappwaiter ]
+#else
+		let webappthread = []
+#endif
+		let threads = if isJust cannotrun
+			then webappthread
+			else webappthread ++
+				[ watch $ commitThread
+#ifdef WITH_WEBAPP
 #ifdef WITH_PAIRING
-			, assist $ pairListenerThread urlrenderer
+				, assist $ pairListenerThread urlrenderer
 #endif
 #ifdef WITH_XMPP
-			, assist $ xmppClientThread urlrenderer
+				, assist $ xmppClientThread urlrenderer
-			, assist $ xmppSendPackThread urlrenderer
+				, assist $ xmppSendPackThread urlrenderer
-			, assist $ xmppReceivePackThread urlrenderer
+				, assist $ xmppReceivePackThread urlrenderer
 #endif
 #endif
-			, assist $ pushThread
+				, assist $ pushThread
-			, assist $ pushRetryThread
+				, assist $ pushRetryThread
-			, assist $ mergeThread
+				, assist $ mergeThread
-			, assist $ transferWatcherThread
+				, assist $ transferWatcherThread
-			, assist $ transferPollerThread
+				, assist $ transferPollerThread
-			, assist $ transfererThread
+				, assist $ transfererThread
-			, assist $ daemonStatusThread
+				, assist $ daemonStatusThread
-			, assist $ sanityCheckerDailyThread
+				, assist $ sanityCheckerDailyThread
-			, assist $ sanityCheckerHourlyThread
+				, assist $ sanityCheckerHourlyThread
-			, assist $ problemFixerThread urlrenderer
+				, assist $ problemFixerThread urlrenderer
 #ifdef WITH_CLIBS
-			, assist $ mountWatcherThread urlrenderer
+				, assist $ mountWatcherThread urlrenderer
 #endif
-			, assist $ netWatcherThread
+				, assist $ netWatcherThread
-			, assist $ netWatcherFallbackThread
+				, assist $ netWatcherFallbackThread
-			, assist $ transferScannerThread urlrenderer
+				, assist $ transferScannerThread urlrenderer
-			, assist $ cronnerThread urlrenderer
+				, assist $ cronnerThread urlrenderer
-			, assist $ configMonitorThread
+				, assist $ configMonitorThread
-			, assist $ glacierThread
+				, assist $ glacierThread
-			, watch $ watchThread
+				, watch $ watchThread
-			-- must come last so that all threads that wait
+				-- must come last so that all threads that wait
-			-- on it have already started waiting
+				-- on it have already started waiting
-			, watch $ sanityCheckerStartupThread startdelay
+				, watch $ sanityCheckerStartupThread startdelay
-			]
+				]
 	
+		mapM_ (startthread urlrenderer) threads
 		liftIO waitForTermination
 
 	watch a = (True, a)

Assistant/Threads/WebApp.hs

@@ -52,11 +52,12 @@ webAppThread
 	:: AssistantData
 	-> UrlRenderer
 	-> Bool
+	-> Maybe String
 	-> Maybe HostName
 	-> Maybe (IO Url)
 	-> Maybe (Url -> FilePath -> IO ())
 	-> NamedThread
-webAppThread assistantdata urlrenderer noannex listenhost postfirstrun onstartup = thread $ liftIO $ do
+webAppThread assistantdata urlrenderer noannex cannotrun listenhost postfirstrun onstartup = thread $ liftIO $ do
 #ifdef __ANDROID__
 	when (isJust listenhost) $
 		-- See Utility.WebApp
@@ -68,6 +69,7 @@ webAppThread assistantdata urlrenderer noannex listenhost postfirstrun onstartup
 		<*> getreldir
 		<*> pure staticRoutes
 		<*> pure postfirstrun
+		<*> pure cannotrun
 		<*> pure noannex
 		<*> pure listenhost
 	setUrlRenderer urlrenderer $ yesodRender webapp (pack "")

Assistant/WebApp/Page.hs

@@ -52,16 +52,19 @@ page title navbaritem content = customPage navbaritem $ do
 customPage :: Maybe NavBarItem -> Widget -> Handler Html
 customPage navbaritem content = do
 	webapp <- getYesod
-	navbar <- map navdetails <$> selectNavBar
+	case cannotRun webapp of
-	pageinfo <- widgetToPageContent $ do
+		Nothing -> do
-		addStylesheet $ StaticR css_bootstrap_css
+			navbar <- map navdetails <$> selectNavBar
-		addStylesheet $ StaticR css_bootstrap_responsive_css
+			pageinfo <- widgetToPageContent $ do
-		addScript $ StaticR jquery_full_js
+				addStylesheet $ StaticR css_bootstrap_css
-		addScript $ StaticR js_bootstrap_dropdown_js
+				addStylesheet $ StaticR css_bootstrap_responsive_css
-		addScript $ StaticR js_bootstrap_modal_js
+				addScript $ StaticR jquery_full_js
-		addScript $ StaticR js_bootstrap_collapse_js
+				addScript $ StaticR js_bootstrap_dropdown_js
-		$(widgetFile "page")
+				addScript $ StaticR js_bootstrap_modal_js
-	giveUrlRenderer $(Hamlet.hamletFile $ hamletTemplate "bootstrap")
+				addScript $ StaticR js_bootstrap_collapse_js
+				$(widgetFile "page")
+			giveUrlRenderer $(Hamlet.hamletFile $ hamletTemplate "bootstrap")
+		Just msg -> error msg
   where
 	navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)
 

Assistant/WebApp/Types.hs

@@ -44,6 +44,7 @@ data WebApp = WebApp
 	, relDir :: Maybe FilePath
 	, getStatic :: Static
 	, postFirstRun :: Maybe (IO String)
+	, cannotRun :: Maybe String
 	, noAnnex :: Bool
 	, listenHost ::Maybe HostName
 	}

Command/Watch.hs

@@ -32,5 +32,5 @@ start :: Bool -> Bool -> Bool -> Maybe Duration -> CommandStart
 start assistant foreground stopdaemon startdelay = do
 	if stopdaemon
 		then stopDaemon
-		else startDaemon assistant foreground startdelay Nothing Nothing -- does not return
+		else startDaemon assistant foreground startdelay Nothing Nothing Nothing -- does not return
 	stop

Command/WebApp.hs

@@ -30,6 +30,8 @@ import qualified Git.CurrentRepo
 import qualified Annex
 import Config.Files
 import qualified Option
+import Upgrade
+import Annex.Version
 
 import Control.Concurrent
 import Control.Concurrent.STM
@@ -56,10 +58,14 @@ start = start' True
 start' :: Bool -> Maybe HostName -> CommandStart
 start' allowauto listenhost = do
 	liftIO ensureInstalled
-	ifM isInitialized ( go , auto )
+	ifM isInitialized 
+		( go
+		, auto
+		)
 	stop
   where
 	go = do
+		cannotrun <- needsUpgrade . fromMaybe (error "no version") =<< getVersion
 		browser <- fromRepo webBrowser
 		f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim
 		ifM (checkpid <&&> checkshim f)
@@ -69,7 +75,7 @@ start' allowauto listenhost = do
 					url <- liftIO . readFile
 						=<< fromRepo gitAnnexUrlFile
 					liftIO $ openBrowser browser f url Nothing Nothing
-			, startDaemon True True Nothing listenhost $ Just $ 
+			, startDaemon True True Nothing cannotrun listenhost $ Just $ 
 				\origout origerr url htmlshim ->
 					if isJust listenhost
 						then maybe noop (`hPutStrLn` url) origout
@@ -133,7 +139,7 @@ firstRun listenhost = do
 	let callback a = Just $ a v
 	runAssistant d $ do
 		startNamedThread urlrenderer $
-			webAppThread d urlrenderer True listenhost
+			webAppThread d urlrenderer True Nothing listenhost
 				(callback signaler)
 				(callback mainthread)
 		waitNamedThreads
@@ -155,7 +161,7 @@ firstRun listenhost = do
 			_wait <- takeMVar v
 			state <- Annex.new =<< Git.CurrentRepo.get
 			Annex.eval state $
-				startDaemon True True Nothing listenhost $ Just $
+				startDaemon True True Nothing Nothing listenhost $ Just $
 					sendurlback v
 	sendurlback v _origout _origerr url _htmlshim = do
 		recordUrl url

Upgrade.hs

@@ -19,15 +19,21 @@ import qualified Upgrade.V2
 import qualified Upgrade.V4
 
 checkUpgrade :: Version -> Annex ()
-checkUpgrade v
+checkUpgrade = maybe noop error <=< needsUpgrade
-	| v `elem` supportedVersions = noop
+
-	| v `elem` autoUpgradeableVersions = unlessM (upgrade True) $
+needsUpgrade :: Version -> Annex (Maybe String)
-		err "Automatic upgrade failed!"
+needsUpgrade v
+	| v `elem` supportedVersions = ok
+	| v `elem` autoUpgradeableVersions = ifM (upgrade True)
+		( ok
+		, err "Automatic upgrade failed!"
+		)
 	| v `elem` upgradableVersions = err "Upgrade this repository: git-annex upgrade"
 	| otherwise = err "Upgrade git-annex."
   where
-	err msg = error $ "Repository version " ++ v ++
+	err msg = return $ Just $ "Repository version " ++ v ++
 		" is not supported. " ++ msg
+	ok = return Nothing
 
 upgrade :: Bool -> Annex Bool
 upgrade automatic = go =<< getVersion

debian/changelog

@@ -39,6 +39,7 @@ git-annex (5.20131102) UNRELEASED; urgency=low
   * Switched to the tasty test framework.
   * Android: Adjust default .gitignore to ignore .thumbnails at any location
     in the tree, not just at its top.
+  * webapp: Check annex.version.
 
  -- Joey Hess <joeyh@debian.org>  Wed, 06 Nov 2013 16:14:14 -0400
 

doc/bugs/webapp_usability:_fails_mysteriously_on_newer_repo_layouts.mdwn

@@ -30,3 +30,5 @@ the failing version is running the one from wheezy backports.
 ### Please provide any additional information below.
 
 screenshot coming up.
+
+> [[fixed|done]] --[[Joey]]