Assistant monad, stage 1

This adds the Assistant monad, and an AssistantData structure.
So far, none of the assistant's threads run in the monad yet.

Assistant.hs

@@ -120,13 +120,6 @@ module Assistant where
 import Assistant.Common
 import Assistant.ThreadedMonad
 import Assistant.DaemonStatus
-import Assistant.Changes
-import Assistant.Commits
-import Assistant.Pushes
-import Assistant.ScanRemotes
-import Assistant.BranchChange
-import Assistant.TransferQueue
-import Assistant.TransferSlots
 import Assistant.Threads.DaemonStatus
 import Assistant.Threads.Watcher
 import Assistant.Threads.Committer
@@ -180,24 +173,28 @@ startAssistant :: Bool -> (IO () -> IO ()) -> Maybe (String -> FilePath -> IO ()
 startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do
 	checkCanWatch
 	dstatus <- startDaemonStatus
-	liftIO $ daemonize $ run dstatus st
+	liftIO $ daemonize $
+		runAssistant go =<< newAssistantData st dstatus
   where
-	run dstatus st = do
+	go = do
-		changechan <- newChangeChan
+		d <- getAssistant id
-		commitchan <- newCommitChan
+		st <- getAssistant threadState
-		pushmap <- newFailedPushMap
+		dstatus <- getAssistant daemonStatus
-		transferqueue <- newTransferQueue
+		changechan <- getAssistant changeChan
-		transferslots <- newTransferSlots
+		commitchan <- getAssistant commitChan
-		scanremotes <- newScanRemoteMap
+		pushmap <- getAssistant failedPushMap
-		branchhandle <- newBranchChangeHandle
+		transferqueue <- getAssistant transferQueue
-		pushnotifier <- newPushNotifier
+		transferslots <- getAssistant transferSlots
+		scanremotes <- getAssistant scanRemoteMap
+		branchhandle <- getAssistant branchChangeHandle
+		pushnotifier <- getAssistant pushNotifier
 #ifdef WITH_WEBAPP
-		urlrenderer <- newUrlRenderer
+		urlrenderer <- liftIO $ newUrlRenderer
 #endif
-		mapM_ (startthread dstatus)
+		mapM_ (startthread d)
 			[ watch $ commitThread st changechan commitchan transferqueue dstatus
 #ifdef WITH_WEBAPP
-			, assist $ webAppThread (Just st) dstatus scanremotes transferqueue transferslots pushnotifier commitchan urlrenderer Nothing webappwaiter
+			, assist $ webAppThread d urlrenderer False Nothing webappwaiter
 #ifdef WITH_PAIRING
 			, assist $ pairListenerThread st dstatus scanremotes urlrenderer
 #endif
@@ -220,11 +217,12 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do
 #endif
 			, watch $ watchThread st dstatus transferqueue changechan
 			]
-		waitForTermination
+		liftIO waitForTermination
 
 	watch a = (True, a)
 	assist a = (False, a)
-	startthread dstatus (watcher, t)
+	startthread d (watcher, t)
-		| watcher || assistant = void $ forkIO $
+		| watcher || assistant = void $ liftIO $ forkIO $
-			runNamedThread dstatus t
+			flip runAssistant d $
+				runNamedThread t
 		| otherwise = noop

Assistant/BranchChange.hs

@@ -8,7 +8,7 @@
 module Assistant.BranchChange where
 
 import Control.Concurrent.MSampleVar
-import Assistant.Common
+import Common.Annex
 
 newtype BranchChangeHandle = BranchChangeHandle (MSampleVar ())
 

Assistant/Common.hs

@@ -14,8 +14,9 @@ module Assistant.Common (
 ) where
 
 import Common.Annex as X
-import Assistant.DaemonStatus
+import Assistant.Monad as X
 import Assistant.Alert
+import Assistant.DaemonStatus
 
 import System.Log.Logger
 import qualified Control.Exception as E
@@ -26,10 +27,10 @@ data NamedThread = NamedThread ThreadName (IO ())
 debug :: ThreadName -> [String] -> IO ()
 debug threadname ws = debugM threadname $ unwords $ (threadname ++ ":") : ws
 
-runNamedThread :: DaemonStatusHandle -> NamedThread -> IO ()
+runNamedThread :: NamedThread -> Assistant ()
-runNamedThread dstatus (NamedThread name a) = go
+runNamedThread (NamedThread name a) = liftIO . go =<< getAssistant daemonStatus
 	where
-		go = do
+		go dstatus = do
 			r <- E.try a :: IO (Either E.SomeException ())
 			case r of
 				Right _ -> noop

Assistant/Monad.hs

@@ -0,0 +1,83 @@
+{- git-annex assistant monad
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE PackageImports, GeneralizedNewtypeDeriving, TypeFamilies, MultiParamTypeClasses #-}
+
+module Assistant.Monad (
+	Assistant,
+	AssistantData(..),
+	newAssistantData,
+	runAssistant,
+	getAssistant,
+	liftAnnex
+) where
+
+import "mtl" Control.Monad.Reader
+import Control.Monad.Base (liftBase, MonadBase)
+
+import Common.Annex
+import Assistant.ThreadedMonad
+import Assistant.DaemonStatus
+import Assistant.ScanRemotes
+import Assistant.TransferQueue
+import Assistant.TransferSlots
+import Assistant.Pushes
+import Assistant.Commits
+import Assistant.Changes
+import Assistant.BranchChange
+
+newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
+	deriving (
+		Monad,
+		MonadIO,
+		MonadReader AssistantData,
+		Functor,
+		Applicative
+	)
+
+instance MonadBase IO Assistant where
+	liftBase = Assistant . liftBase
+
+data AssistantData = AssistantData
+	{ threadState :: ThreadState
+	, daemonStatus :: DaemonStatusHandle
+	, scanRemoteMap :: ScanRemoteMap
+	, transferQueue :: TransferQueue
+	, transferSlots :: TransferSlots
+	, pushNotifier :: PushNotifier
+	, failedPushMap :: FailedPushMap
+	, commitChan :: CommitChan
+	, changeChan :: ChangeChan
+	, branchChangeHandle :: BranchChangeHandle
+	}
+
+newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData
+newAssistantData st dstatus = AssistantData
+	<$> pure st
+	<*> pure dstatus
+	<*> newScanRemoteMap
+	<*> newTransferQueue
+	<*> newTransferSlots
+	<*> newPushNotifier
+	<*> newFailedPushMap
+	<*> newCommitChan
+	<*> newChangeChan
+	<*> newBranchChangeHandle
+
+runAssistant :: Assistant a -> AssistantData -> IO a
+runAssistant a = runReaderT (mkAssistant a)
+
+getAssistant :: (AssistantData -> a) -> Assistant a
+getAssistant = reader
+
+{- Runs an action in the git-annex monad. Note that the same monad state
+ - is shared amoung all assistant threads, so only one of these can run at
+ - a time. Therefore, long-duration actions should be avoided. -}
+liftAnnex :: Annex a -> Assistant a
+liftAnnex a = do
+	st <- reader threadState
+	liftIO $ runThreadState st a

Assistant/Threads/Watcher.hs

@@ -59,16 +59,16 @@ watchThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan
 watchThread st dstatus transferqueue changechan = NamedThread thisThread $ do
 	void $ watchDir "." ignored hooks startup
 	debug thisThread [ "watching", "."]
-	where
+  where
-		startup = startupScan st dstatus
+	startup = startupScan st dstatus
-		hook a = Just $ runHandler thisThread st dstatus transferqueue changechan a
+	hook a = Just $ runHandler thisThread st dstatus transferqueue changechan a
-		hooks = mkWatchHooks
+	hooks = mkWatchHooks
-			{ addHook = hook onAdd
+		{ addHook = hook onAdd
-			, delHook = hook onDel
+		, delHook = hook onDel
-			, addSymlinkHook = hook onAddSymlink
+		, addSymlinkHook = hook onAddSymlink
-			, delDirHook = hook onDelDir
+		, delDirHook = hook onDelDir
-			, errHook = hook onErr
+		, errHook = hook onErr
-			}
+		}
 
 {- Initial scartup scan. The action should return once the scan is complete. -}
 startupScan :: ThreadState -> DaemonStatusHandle -> IO a -> IO a
@@ -89,7 +89,7 @@ startupScan st dstatus scanner = do
 
 ignored :: FilePath -> Bool
 ignored = ig . takeFileName
-	where
+  where
 	ig ".git" = True
 	ig ".gitignore" = True
 	ig ".gitattributes" = True
@@ -109,14 +109,13 @@ runHandler threadname st dstatus transferqueue changechan handler file filestatu
 		Left e -> print e
 		Right Nothing -> noop
 		Right (Just change) -> recordChange changechan change
-	where
+  where
-		go = runThreadState st $ handler threadname file filestatus dstatus transferqueue
+	go = runThreadState st $ handler threadname file filestatus dstatus transferqueue
 
 onAdd :: Handler
 onAdd _ file filestatus _ _
 	| maybe False isRegularFile filestatus = pendingAddChange file
 	| otherwise = noChange
-	where
 
 {- A symlink might be an arbitrary symlink, which is just added.
  - Or, if it is a git-annex symlink, ensure it points to the content
@@ -124,69 +123,67 @@ onAdd _ file filestatus _ _
  -}
 onAddSymlink :: Handler
 onAddSymlink threadname file filestatus dstatus transferqueue = go =<< Backend.lookupFile file
-	where
+  where
-		go (Just (key, _)) = do
+	go (Just (key, _)) = do
-			link <- calcGitLink file key
+		link <- calcGitLink file key
-			ifM ((==) link <$> liftIO (readSymbolicLink file))
+		ifM ((==) link <$> liftIO (readSymbolicLink file))
-				( do
+			( do
-					s <- liftIO $ getDaemonStatus dstatus
+				s <- liftIO $ getDaemonStatus dstatus
-					checkcontent key s
+				checkcontent key s
-					ensurestaged link s
+				ensurestaged link s
-				, do
+			, do
-					liftIO $ debug threadname ["fix symlink", file]
+				liftIO $ debug threadname ["fix symlink", file]
-					liftIO $ removeFile file
+				liftIO $ removeFile file
-					liftIO $ createSymbolicLink link file
+				liftIO $ createSymbolicLink link file
-					checkcontent key =<< liftIO (getDaemonStatus dstatus)
+				checkcontent key =<< liftIO (getDaemonStatus dstatus)
-					addlink link
+				addlink link
-				)
+			)
-		go Nothing = do -- other symlink
+	go Nothing = do -- other symlink
-			link <- liftIO (readSymbolicLink file)
+		link <- liftIO (readSymbolicLink file)
-			ensurestaged link =<< liftIO (getDaemonStatus dstatus)
+		ensurestaged link =<< liftIO (getDaemonStatus dstatus)
 
-		{- This is often called on symlinks that are already
+	{- This is often called on symlinks that are already
-		 - staged correctly. A symlink may have been deleted
+	 - staged correctly. A symlink may have been deleted
-		 - and being re-added, or added when the watcher was
+	 - and being re-added, or added when the watcher was
-		 - not running. So they're normally restaged to make sure.
+	 - not running. So they're normally restaged to make sure.
-		 -
+	 -
-		 - As an optimisation, during the startup scan, avoid
+	 - As an optimisation, during the startup scan, avoid
-		 - restaging everything. Only links that were created since
+	 - restaging everything. Only links that were created since
-		 - the last time the daemon was running are staged.
+	 - the last time the daemon was running are staged.
-		 - (If the daemon has never ran before, avoid staging
+	 - (If the daemon has never ran before, avoid staging
-		 - links too.)
+	 - links too.)
-		 -}
+	 -}
-		ensurestaged link daemonstatus
+	ensurestaged link daemonstatus
-			| scanComplete daemonstatus = addlink link
+		| scanComplete daemonstatus = addlink link
-			| otherwise = case filestatus of
+		| otherwise = case filestatus of
-				Just s
+			Just s
-					| not (afterLastDaemonRun (statusChangeTime s) daemonstatus) -> noChange
+				| not (afterLastDaemonRun (statusChangeTime s) daemonstatus) -> noChange
-				_ -> addlink link
+			_ -> addlink link
 
-		{- For speed, tries to reuse the existing blob for
+	{- For speed, tries to reuse the existing blob for symlink target. -}
-		 - the symlink target. -}
+	addlink link = do
-		addlink link = do
+		liftIO $ debug threadname ["add symlink", file]
-			liftIO $ debug threadname ["add symlink", file]
+		v <- catObjectDetails $ Ref $ ':':file
-			v <- catObjectDetails $ Ref $ ':':file
+		case v of
-			case v of
+			Just (currlink, sha)
-				Just (currlink, sha)
+				| s2w8 link == L.unpack currlink ->
-					| s2w8 link == L.unpack currlink ->
-						stageSymlink file sha
-				_ -> do
-					sha <- inRepo $
-						Git.HashObject.hashObject BlobObject link
 					stageSymlink file sha
-			madeChange file LinkChange
+			_ -> do
+				sha <- inRepo $
+					Git.HashObject.hashObject BlobObject link
+				stageSymlink file sha
+		madeChange file LinkChange
 
-		{- When a new link appears, or a link is changed,
+	{- When a new link appears, or a link is changed, after the startup
-		 - after the startup scan, handle getting or
+	 - scan, handle getting or dropping the key's content. -}
-		 - dropping the key's content. -}
+	checkcontent key daemonstatus
-		checkcontent key daemonstatus
+		| scanComplete daemonstatus = do
-			| scanComplete daemonstatus = do
+			present <- inAnnex key
-				present <- inAnnex key
+			unless present $
-				unless present $
+				queueTransfers Next transferqueue dstatus
-					queueTransfers Next transferqueue dstatus
+					key (Just file) Download
-						key (Just file) Download
+			handleDrops dstatus present key (Just file)
-				handleDrops dstatus present key (Just file)
+		| otherwise = noop
-			| otherwise = noop
 
 onDel :: Handler
 onDel threadname file _ _dstatus _ = do

Assistant/Threads/WebApp.hs

@@ -28,12 +28,6 @@ import Assistant.WebApp.Configurators.XMPP
 import Assistant.WebApp.Documentation
 import Assistant.WebApp.OtherRepos
 import Assistant.ThreadedMonad
-import Assistant.DaemonStatus
-import Assistant.ScanRemotes
-import Assistant.TransferQueue
-import Assistant.TransferSlots
-import Assistant.Pushes
-import Assistant.Commits
 import Utility.WebApp
 import Utility.FileMode
 import Utility.TempFile
@@ -51,51 +45,43 @@ mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
 
 type Url = String
 
-webAppThread 
+webAppThread
-	:: Maybe ThreadState
+	:: AssistantData
-	-> DaemonStatusHandle
-	-> ScanRemoteMap
-	-> TransferQueue
-	-> TransferSlots
-	-> PushNotifier
-	-> CommitChan
 	-> UrlRenderer
+	-> Bool
 	-> Maybe (IO String)
 	-> Maybe (Url -> FilePath -> IO ())
 	-> NamedThread
-webAppThread mst dstatus scanremotes transferqueue transferslots pushnotifier commitchan urlrenderer postfirstrun onstartup = thread $ do
+webAppThread assistantdata urlrenderer noannex postfirstrun onstartup = thread $ do
 	webapp <- WebApp
-		<$> pure mst
+		<$> pure assistantdata
-		<*> pure dstatus
-		<*> pure scanremotes
-		<*> pure transferqueue
-		<*> pure transferslots
-		<*> pure pushnotifier
-		<*> pure commitchan
 		<*> (pack <$> genRandomToken)
-		<*> getreldir mst
+		<*> getreldir
 		<*> pure $(embed "static")
 		<*> newWebAppState
 		<*> pure postfirstrun
+		<*> pure noannex
 	setUrlRenderer urlrenderer $ yesodRender webapp (pack "")
 	app <- toWaiAppPlain webapp
 	app' <- ifM debugEnabled
 		( return $ httpDebugLogger app
 		, return app
 		)
-	runWebApp app' $ \port -> case mst of
+	runWebApp app' $ \port -> if noannex
-		Nothing -> withTempFile "webapp.html" $ \tmpfile _ ->
+		then withTempFile "webapp.html" $ \tmpfile _ ->
 			go port webapp tmpfile Nothing
-		Just st -> do
+		else do
+			let st = threadState assistantdata
 			htmlshim <- runThreadState st $ fromRepo gitAnnexHtmlShim
 			urlfile <- runThreadState st $ fromRepo gitAnnexUrlFile
 			go port webapp htmlshim (Just urlfile)
 	where
 		thread = NamedThread thisThread
-		getreldir Nothing = return Nothing
+		getreldir
-		getreldir (Just st) = Just <$>
+			| noannex = return Nothing
-			(relHome =<< absPath
+			| otherwise = Just <$>
-				=<< runThreadState st (fromRepo repoPath))
+				(relHome =<< absPath
+					=<< runThreadState (threadState assistantdata) (fromRepo repoPath))
 		go port webapp htmlshim urlfile = do
 			debug thisThread ["running on port", show port]
 			let url = myUrl webapp port

Assistant/WebApp.hs

@@ -72,6 +72,12 @@ newWebAppState = do
 		{ showIntro = True
 		, otherRepos = otherrepos }
 
+getAssistantY :: forall sub a. (AssistantData -> a) -> GHandler sub WebApp a
+getAssistantY f = f <$> (assistantData <$> getYesod)
+
+getDaemonStatusY :: forall sub. GHandler sub WebApp DaemonStatus
+getDaemonStatusY = liftIO . getDaemonStatus =<< getAssistantY daemonStatus
+
 getWebAppState :: forall sub. GHandler sub WebApp WebAppState
 getWebAppState = liftIO . atomically . readTMVar =<< webAppState <$> getYesod
 
@@ -88,7 +94,10 @@ modifyWebAppState a = go =<< webAppState <$> getYesod
  - value is returned.
  -}
 runAnnex :: forall sub a. a -> Annex a -> GHandler sub WebApp a
-runAnnex fallback a = maybe (return fallback) go =<< threadState <$> getYesod
+runAnnex fallback a = ifM (noAnnex <$> getYesod)
+	( return fallback
+	, go =<< getAssistantY threadState
+	)
 	where
 		go st = liftIO $ runThreadState st a
 
@@ -103,9 +112,7 @@ newNotifier selector = do
 	liftIO $ notificationHandleToId <$> newNotificationHandle notifier
 
 getNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> GHandler sub WebApp NotificationBroadcaster
-getNotifier selector = do
+getNotifier selector = selector <$> getDaemonStatusY
-	webapp <- getYesod
-	liftIO $ selector <$> getDaemonStatus (daemonStatus webapp)
 
 {- Adds the auth parameter as a hidden field on a form. Must be put into
  - every form. -}

Assistant/WebApp/Configurators.hs

@@ -101,8 +101,8 @@ repoList onlyconfigured includehere
 	| otherwise = list =<< (++) <$> configured <*> rest
 	where
 		configured = do
-			rs <- filter (not . Remote.readonly) . syncRemotes <$>
+			rs <- filter (not . Remote.readonly) . syncRemotes
-				(liftIO . getDaemonStatus =<< daemonStatus <$> getYesod)
+				<$> getDaemonStatusY
 			runAnnex [] $ do
 				u <- getUUID
 				let l = map Remote.uuid rs

Assistant/WebApp/Configurators/Edit.hs

@@ -69,7 +69,7 @@ setRepoConfig uuid mremote oldc newc = do
 	when (repoSyncable oldc /= repoSyncable newc) $
 		changeSyncable mremote (repoSyncable newc)
 	when (isJust mremote && repoName oldc /= repoName newc) $ do
-		dstatus <- daemonStatus <$> getYesod
+		dstatus <- getAssistantY daemonStatus
 		runAnnex undefined $ do
 			name <- fromRepo $ uniqueRemoteName (T.unpack $ repoName newc) 0
 			inRepo $ Git.Command.run "remote"

Assistant/WebApp/Configurators/Pairing.hs

@@ -87,7 +87,7 @@ getInprogressPairR _ = noPairing
  -}
 startPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget
 startPairing stage oncancel alert muuid displaysecret secret = do
-	dstatus <- daemonStatus <$> lift getYesod
+	dstatus <- lift $ getAssistantY daemonStatus
 	urlrender <- lift getUrlRender
 	reldir <- fromJust . relDir <$> lift getYesod
 

Assistant/WebApp/Configurators/S3.hs

@@ -116,13 +116,13 @@ getEnableS3R uuid = s3Configurator $ do
 
 makeS3Remote :: S3Creds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
 makeS3Remote (S3Creds ak sk) name setup config = do
-	webapp <- getYesod
+	d <- getAssistantY id
-	let st = fromJust $ threadState webapp
+	let st = threadState d
 	remotename <- runAnnex name $ fromRepo $ uniqueRemoteName name 0
 	liftIO $ S3.s3SetCredsEnv ( T.unpack ak, T.unpack sk)
 	r <- liftIO $ runThreadState st $ addRemote $ do
 		makeSpecialRemote name S3.remote config
 		return remotename
 	setup r
-	liftIO $ syncNewRemote st (daemonStatus webapp) (scanRemotes webapp) r
+	liftIO $ syncNewRemote st (daemonStatus d) (scanRemoteMap d) r
 	redirect $ EditNewCloudRepositoryR $ Remote.uuid r

Assistant/WebApp/Configurators/Ssh.hs

@@ -283,11 +283,11 @@ makeSsh' rsync setup sshdata keypair =
 
 makeSshRepo :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml
 makeSshRepo forcersync setup sshdata = do
-	webapp <- getYesod
+	d <- getAssistantY id
 	r <- liftIO $ makeSshRemote
-		(fromJust $ threadState webapp)
+		(threadState d)
-		(daemonStatus webapp)
+		(daemonStatus d)
-		(scanRemotes webapp)
+		(scanRemoteMap d)
 		forcersync sshdata
 	setup r
 	redirect $ EditNewCloudRepositoryR $ Remote.uuid r

Assistant/WebApp/Configurators/XMPP.hs

@@ -34,7 +34,7 @@ import qualified Data.Text as T
 {- Displays an alert suggesting to configure XMPP, with a button. -}
 xmppNeeded :: Handler ()
 xmppNeeded = whenM (isNothing <$> runAnnex Nothing getXMPPCreds) $ do
-	dstatus <- daemonStatus <$> getYesod
+	dstatus <- getAssistantY daemonStatus
 	urlrender <- getUrlRender
 	void $ liftIO $ addAlert dstatus $ xmppNeededAlert $ AlertButton
 		{ buttonLabel = "Configure a Jabber account"
@@ -59,7 +59,7 @@ getXMPPR = xmppPage $ do
 	where
 		storecreds creds = do
 			void $ runAnnex undefined $ setXMPPCreds creds
-			liftIO . notifyRestart =<< pushNotifier <$> getYesod
+			liftIO . notifyRestart =<< getAssistantY pushNotifier
 			redirect ConfigR
 #else
 getXMPPR = xmppPage $

Assistant/WebApp/DashBoard.hs

@@ -38,8 +38,9 @@ import Control.Concurrent
 transfersDisplay :: Bool -> Widget
 transfersDisplay warnNoScript = do
 	webapp <- lift getYesod
+	d <- lift $ getAssistantY id
 	current <- lift $ M.toList <$> getCurrentTransfers
-	queued <- liftIO $ getTransferQueue $ transferQueue webapp
+	queued <- liftIO $ getTransferQueue $ transferQueue d
 	autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
 	let transfers = simplifyTransfers $ current ++ queued
 	if null transfers

Assistant/WebApp/SideBar.hs

@@ -27,9 +27,7 @@ sideBarDisplay :: Widget
 sideBarDisplay = do
 	let content = do
 		{- Add newest alerts to the sidebar. -}
-		webapp <- lift getYesod
+		alertpairs <- lift $ M.toList . alertMap <$> getDaemonStatusY
-		alertpairs <- M.toList . alertMap
-			<$> liftIO (getDaemonStatus $ daemonStatus webapp)
 		mapM_ renderalert $
 			take displayAlerts $ reverse $ sortAlertPairs alertpairs
 	let ident = "sidebar"
@@ -75,14 +73,13 @@ getSideBarR nid = do
 {- Called by the client to close an alert. -}
 getCloseAlert :: AlertId -> Handler ()
 getCloseAlert i = do
-	webapp <- getYesod
+	dstatus <- getAssistantY daemonStatus
-	liftIO $ removeAlert (daemonStatus webapp) i
+	liftIO $ removeAlert dstatus i
 
 {- When an alert with a button is clicked on, the button takes us here. -}
 getClickAlert :: AlertId -> Handler ()
 getClickAlert i = do
-	webapp <- getYesod
+	m <- alertMap <$> getDaemonStatusY
-	m <- alertMap <$> liftIO (getDaemonStatus $ daemonStatus webapp)
 	case M.lookup i m of
 		Just (Alert { alertButton = Just b }) -> do
 			{- Spawn a thread to run the action while redirecting. -}

Assistant/WebApp/Types.hs

@@ -12,13 +12,6 @@ module Assistant.WebApp.Types where
 
 import Assistant.Common
 import Assistant.Ssh
-import Assistant.ThreadedMonad
-import Assistant.DaemonStatus
-import Assistant.ScanRemotes
-import Assistant.TransferQueue
-import Assistant.TransferSlots
-import Assistant.Pushes
-import Assistant.Commits
 import Assistant.Alert
 import Assistant.Pairing
 import Utility.NotificationBroadcaster
@@ -35,18 +28,13 @@ publicFiles "static"
 mkYesodData "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
 
 data WebApp = WebApp
-	{ threadState :: Maybe ThreadState
+	{ assistantData :: AssistantData
-	, daemonStatus :: DaemonStatusHandle
-	, scanRemotes :: ScanRemoteMap
-	, transferQueue :: TransferQueue
-	, transferSlots :: TransferSlots
-	, pushNotifier :: PushNotifier
-	, commitChan :: CommitChan
 	, secretToken :: Text
 	, relDir :: Maybe FilePath
 	, getStatic :: Static
 	, webAppState :: TMVar WebAppState
 	, postFirstRun :: Maybe (IO String)
+	, noAnnex :: Bool
 	}
 
 instance Yesod WebApp where

Assistant/WebApp/Utility.hs

@@ -23,7 +23,6 @@ import Logs.Transfer
 import Locations.UserConfig
 import qualified Config
 
-import Yesod
 import qualified Data.Map as M
 import Control.Concurrent
 import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL)
@@ -37,13 +36,13 @@ changeSyncable (Just r) True = do
 	syncRemote r
 changeSyncable (Just r) False = do
 	changeSyncFlag r False
-	webapp <- getYesod
+	d <- getAssistantY id
-	let dstatus = daemonStatus webapp
+	let dstatus = daemonStatus d
-	let st = fromJust $ threadState webapp
+	let st = threadState d
 	liftIO $ runThreadState st $ updateSyncRemotes dstatus
 	{- Stop all transfers to or from this remote.
 	 - XXX Can't stop any ongoing scan, or git syncs. -}
-	void $ liftIO $ dequeueTransfers (transferQueue webapp) dstatus tofrom
+	void $ liftIO $ dequeueTransfers (transferQueue d) dstatus tofrom
 	mapM_ (cancelTransfer False) =<<
 		filter tofrom . M.keys <$>
 			liftIO (currentTransfers <$> getDaemonStatus dstatus)
@@ -63,11 +62,11 @@ changeSyncFlag r enabled = runAnnex undefined $ do
 {- Start syncing remote, using a background thread. -}
 syncRemote :: Remote -> Handler ()
 syncRemote remote = do
-	webapp <- getYesod
+	d <- getAssistantY id
 	liftIO $ syncNewRemote
-		(fromJust $ threadState webapp)
+		(threadState d)
-		(daemonStatus webapp)
+		(daemonStatus d)
-		(scanRemotes webapp)
+		(scanRemoteMap d)
 		remote
 
 pauseTransfer :: Transfer -> Handler ()
@@ -75,13 +74,13 @@ pauseTransfer = cancelTransfer True
 
 cancelTransfer :: Bool -> Transfer -> Handler ()
 cancelTransfer pause t = do
-	webapp <- getYesod
+	dstatus <- getAssistantY daemonStatus
-	let dstatus = daemonStatus webapp
+	tq <- getAssistantY transferQueue
 	m <- getCurrentTransfers
 	liftIO $ do
 		unless pause $
 			{- remove queued transfer -}
-			void $ dequeueTransfers (transferQueue webapp) dstatus $
+			void $ dequeueTransfers tq dstatus $
 				equivilantTransfer t
 		{- stop running transfer -}
 		maybe noop (stop dstatus) (M.lookup t m)
@@ -118,28 +117,24 @@ startTransfer t = do
 	where
 		go info = maybe (start info) resume $ transferTid info
 		startqueued = do
-			webapp <- getYesod
+			dstatus <- getAssistantY daemonStatus
-			let dstatus = daemonStatus webapp
+			q <- getAssistantY transferQueue
-			let q = transferQueue webapp
 			is <- liftIO $ map snd <$> getMatchingTransfers q dstatus (== t)
 			maybe noop start $ headMaybe is
 		resume tid = do
-			webapp <- getYesod
+			dstatus <- getAssistantY daemonStatus
-			let dstatus = daemonStatus webapp
 			liftIO $ do
 				alterTransferInfo dstatus t $ \i -> i
 					{ transferPaused = False }
 				throwTo tid ResumeTransfer
 		start info = do
-			webapp <- getYesod
+			st <- getAssistantY threadState
-			let st = fromJust $ threadState webapp
+			dstatus <- getAssistantY daemonStatus
-			let dstatus = daemonStatus webapp
+			slots <- getAssistantY transferSlots
-			let slots = transferSlots webapp
+			commitchan <- getAssistantY commitChan
-			let commitchan = commitChan webapp
 			liftIO $ inImmediateTransferSlot dstatus slots $ do
 				program <- readProgramFile
 				Transferrer.startTransfer st dstatus commitchan program t info
 
 getCurrentTransfers :: Handler TransferMap
-getCurrentTransfers = currentTransfers
+getCurrentTransfers = currentTransfers <$> getDaemonStatusY
-	<$> (liftIO . getDaemonStatus =<< daemonStatus <$> getYesod)

Command/WebApp.hs

@@ -12,11 +12,6 @@ import Command
 import Assistant
 import Assistant.Common
 import Assistant.DaemonStatus
-import Assistant.ScanRemotes
-import Assistant.TransferQueue
-import Assistant.TransferSlots
-import Assistant.Pushes
-import Assistant.Commits
 import Assistant.Threads.WebApp
 import Assistant.WebApp
 import Assistant.Install
@@ -101,20 +96,21 @@ autoStart autostartfile = do
  -}
 firstRun :: IO ()
 firstRun = do
+	{- Without a repository, we cannot have an Annex monad, so cannot
+	 - get a ThreadState. Using undefined is only safe because the
+	 - webapp checks its noAnnex field before accessing the
+	 - threadstate. -}
+	let st = undefined
+	{- Get a DaemonStatus without running in the Annex monad. -}
 	dstatus <- atomically . newTMVar =<< newDaemonStatus
-	scanremotes <- newScanRemoteMap
+	d <- newAssistantData st dstatus
-	transferqueue <- newTransferQueue
-	transferslots <- newTransferSlots
 	urlrenderer <- newUrlRenderer
-	pushnotifier <- newPushNotifier
-	commitchan <- newCommitChan
 	v <- newEmptyMVar
 	let callback a = Just $ a v
-	void $ runNamedThread dstatus $
+	void $ flip runAssistant d $ runNamedThread $
-		webAppThread Nothing dstatus scanremotes
+		webAppThread d urlrenderer True 
-			transferqueue transferslots pushnotifier commitchan
+			(callback signaler)
-			urlrenderer
+			(callback mainthread)
-			(callback signaler) (callback mainthread)
 	where
 		signaler v = do
 			putMVar v ""