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/WebApp/Configurators.hs

@@ -101,8 +101,8 @@ repoList onlyconfigured includehere
 	| otherwise = list =<< (++) <$> configured <*> rest
 	where
 		configured = do
-			rs <- filter (not . Remote.readonly) . syncRemotes <$>
-				(liftIO . getDaemonStatus =<< daemonStatus <$> getYesod)
+			rs <- filter (not . Remote.readonly) . syncRemotes
+				<$> 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
-	let st = fromJust $ threadState webapp
+	d <- getAssistantY id
+	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)
-		(daemonStatus webapp)
-		(scanRemotes webapp)
+		(threadState d)
+		(daemonStatus d)
+		(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 <- M.toList . alertMap
-			<$> liftIO (getDaemonStatus $ daemonStatus webapp)
+		alertpairs <- lift $ M.toList . alertMap <$> getDaemonStatusY
 		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
-	liftIO $ removeAlert (daemonStatus webapp) i
+	dstatus <- getAssistantY daemonStatus
+	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 <$> liftIO (getDaemonStatus $ daemonStatus webapp)
+	m <- alertMap <$> getDaemonStatusY
 	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
-	, daemonStatus :: DaemonStatusHandle
-	, scanRemotes :: ScanRemoteMap
-	, transferQueue :: TransferQueue
-	, transferSlots :: TransferSlots
-	, pushNotifier :: PushNotifier
-	, commitChan :: CommitChan
+	{ assistantData :: AssistantData
 	, 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
-	let dstatus = daemonStatus webapp
-	let st = fromJust $ threadState webapp
+	d <- getAssistantY id
+	let dstatus = daemonStatus d
+	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)
-		(daemonStatus webapp)
-		(scanRemotes webapp)
+		(threadState d)
+		(daemonStatus d)
+		(scanRemoteMap d)
 		remote
 
 pauseTransfer :: Transfer -> Handler ()
@@ -75,13 +74,13 @@ pauseTransfer = cancelTransfer True
 
 cancelTransfer :: Bool -> Transfer -> Handler ()
 cancelTransfer pause t = do
-	webapp <- getYesod
-	let dstatus = daemonStatus webapp
+	dstatus <- getAssistantY daemonStatus
+	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
-			let dstatus = daemonStatus webapp
-			let q = transferQueue webapp
+			dstatus <- getAssistantY daemonStatus
+			q <- getAssistantY transferQueue
 			is <- liftIO $ map snd <$> getMatchingTransfers q dstatus (== t)
 			maybe noop start $ headMaybe is
 		resume tid = do
-			webapp <- getYesod
-			let dstatus = daemonStatus webapp
+			dstatus <- getAssistantY daemonStatus
 			liftIO $ do
 				alterTransferInfo dstatus t $ \i -> i
 					{ transferPaused = False }
 				throwTo tid ResumeTransfer
 		start info = do
-			webapp <- getYesod
-			let st = fromJust $ threadState webapp
-			let dstatus = daemonStatus webapp
-			let slots = transferSlots webapp
-			let commitchan = commitChan webapp
+			st <- getAssistantY threadState
+			dstatus <- getAssistantY daemonStatus
+			slots <- getAssistantY transferSlots
+			commitchan <- getAssistantY commitChan
 			liftIO $ inImmediateTransferSlot dstatus slots $ do
 				program <- readProgramFile
 				Transferrer.startTransfer st dstatus commitchan program t info
 
 getCurrentTransfers :: Handler TransferMap
-getCurrentTransfers = currentTransfers
-	<$> (liftIO . getDaemonStatus =<< daemonStatus <$> getYesod)
+getCurrentTransfers = currentTransfers <$> getDaemonStatusY