cleanup daemonStatus accessors

Assistant/DaemonStatus.hs

@@ -24,11 +24,12 @@ import Data.Time
 import System.Locale
 import qualified Data.Map as M
 
-daemonStatus :: Assistant DaemonStatus
-daemonStatus = getDaemonStatus <<~ daemonStatusHandle
+-- TODO remove this
+getDaemonStatusOld :: DaemonStatusHandle -> IO DaemonStatus
+getDaemonStatusOld = atomically . readTMVar
 
-getDaemonStatus :: DaemonStatusHandle -> IO DaemonStatus
-getDaemonStatus = atomically . readTMVar
+getDaemonStatus :: Assistant DaemonStatus
+getDaemonStatus = (atomically . readTMVar) <<~ daemonStatusHandle
 
 modifyDaemonStatus_ :: DaemonStatusHandle -> (DaemonStatus -> DaemonStatus) -> IO ()
 modifyDaemonStatus_ dstatus a = modifyDaemonStatus dstatus $ \s -> (a s, ())

Assistant/Drop.hs

@@ -23,7 +23,7 @@ import Config
 handleDrops :: DaemonStatusHandle -> Bool -> Key -> AssociatedFile -> Annex ()
 handleDrops _ _ _ Nothing = noop
 handleDrops dstatus fromhere key f = do
-	syncrs <- liftIO $ syncRemotes <$> getDaemonStatus dstatus
+	syncrs <- liftIO $ syncRemotes <$> getDaemonStatusOld dstatus
 	locs <- loggedLocations key
 	handleDrops' locs syncrs fromhere key f
 

Assistant/Threads/DaemonStatus.hs

@@ -18,7 +18,7 @@ import Utility.NotificationBroadcaster
 daemonStatusThread :: NamedThread
 daemonStatusThread = NamedThread "DaemonStatus" $ do
 	notifier <- liftIO . newNotificationHandle
-		=<< changeNotifier <$> daemonStatus
+		=<< changeNotifier <$> getDaemonStatus
 	checkpoint
 	runEvery (Seconds tenMinutes) <~> do
 		liftIO $ waitNotification notifier
@@ -26,4 +26,4 @@ daemonStatusThread = NamedThread "DaemonStatus" $ do
   where
 	checkpoint = do
 		file <- liftAnnex $ fromRepo gitAnnexDaemonStatusFile
-		liftIO . writeDaemonStatusFile file =<< daemonStatus
+		liftIO . writeDaemonStatusFile file =<< getDaemonStatus

Assistant/Threads/PairListener.hs

@@ -41,7 +41,7 @@ pairListenerThread urlrenderer = NamedThread "PairListener" $ do
 		Just m -> do
 			sane <- checkSane msg
 			(pip, verified) <- verificationCheck m
-				=<< (pairingInProgress <$> daemonStatus)
+				=<< (pairingInProgress <$> getDaemonStatus)
 			let wrongstage = maybe False (\p -> pairMsgStage m <= inProgressPairStage p) pip
 			case (wrongstage, sane, pairMsgStage m) of
 				-- ignore our own messages, and

Assistant/Threads/PushNotifier.hs

@@ -89,7 +89,7 @@ xmppClient iowaitpush iodebug iopull = do
 pull :: [UUID] -> Assistant ()
 pull [] = noop
 pull us = do
-	rs <- filter matching . syncRemotes <$> daemonStatus
+	rs <- filter matching . syncRemotes <$> getDaemonStatus
 	debug $ "push notification for" : map (fromUUID . Remote.uuid ) rs
 	pullone rs =<< liftAnnex (inRepo Git.Branch.current)
   where

Assistant/Threads/Pusher.hs

@@ -46,7 +46,7 @@ pushThread = NamedThread "Pusher" $ runEvery (Seconds 2) <~> do
 	-- Now see if now's a good time to push.
 	if shouldPush commits
 		then do
-			remotes <- filter pushable . syncRemotes <$> daemonStatus
+			remotes <- filter pushable . syncRemotes <$> getDaemonStatus
 			unless (null remotes) $
 				void $ alertWhile (pushAlert remotes) $ do
 					now <- liftIO $ getCurrentTime

Assistant/Threads/SanityChecker.hs

@@ -49,7 +49,7 @@ sanityCheckerThread = NamedThread "SanityChecker" $ forever $ do
 {- Only run one check per day, from the time of the last check. -}
 waitForNextCheck :: Assistant ()
 waitForNextCheck = do
-	v <- lastSanityCheck <$> daemonStatus
+	v <- lastSanityCheck <$> getDaemonStatus
 	now <- liftIO getPOSIXTime
 	liftIO $ threadDelaySeconds $ Seconds $ calcdelay now v
   where

Assistant/Threads/TransferPoller.hs

@@ -22,10 +22,10 @@ transferPollerThread :: NamedThread
 transferPollerThread = NamedThread "TransferPoller" $ do
 	g <- liftAnnex gitRepo
 	tn <- liftIO . newNotificationHandle =<<
-		transferNotifier <$> daemonStatus
+		transferNotifier <$> getDaemonStatus
 	forever $ do
 		liftIO $ threadDelay 500000 -- 0.5 seconds
-		ts <- currentTransfers <$> daemonStatus
+		ts <- currentTransfers <$> getDaemonStatus
 		if M.null ts
 			-- block until transfers running
 			then liftIO $ waitNotification tn

Assistant/Threads/TransferScanner.hs

@@ -57,7 +57,7 @@ transferScannerThread = NamedThread "TransferScanner" $ do
 	 -   and then the system (or us) crashed, and that info was
 	 -   lost.
 	 -}
-	startupScan = addScanRemotes True =<< syncRemotes <$> daemonStatus
+	startupScan = addScanRemotes True =<< syncRemotes <$> getDaemonStatus
 
 {- This is a cheap scan for failed transfers involving a remote. -}
 failedTransferScan :: Remote -> Assistant ()
@@ -122,7 +122,7 @@ expensiveScan rs = unless onlyweb $ do
 		locs <- loggedLocations key
 		{- The syncable remotes may have changed since this
 		 - scan began. -}
-		syncrs <- liftIO $ syncRemotes <$> getDaemonStatus dstatus
+		syncrs <- liftIO $ syncRemotes <$> getDaemonStatusOld dstatus
 		present <- inAnnex key
 
 		handleDrops' locs syncrs present key (Just f)

Assistant/Threads/Watcher.hs

@@ -133,18 +133,18 @@ onAddSymlink file filestatus = go =<< liftAnnex (Backend.lookupFile file)
 		link <- liftAnnex $ calcGitLink file key
 		ifM ((==) link <$> liftIO (readSymbolicLink file))
 			( do
-				s <- daemonStatus
+				s <- getDaemonStatus
 				checkcontent key s
 				ensurestaged link s
 			, do
 				liftIO $ removeFile file
 				liftIO $ createSymbolicLink link file
-				checkcontent key =<< daemonStatus
+				checkcontent key =<< getDaemonStatus
 				addlink link
 			)
 	go Nothing = do -- other symlink
 		link <- liftIO (readSymbolicLink file)
-		ensurestaged link =<< daemonStatus
+		ensurestaged link =<< getDaemonStatus
 
 	{- This is often called on symlinks that are already
 	 - staged correctly. A symlink may have been deleted

Assistant/TransferQueue.hs

@@ -58,7 +58,7 @@ queueTransfersMatching matching schedule q dstatus k f direction
 	where
 		go = do
 			rs <- sufficientremotes
-				=<< syncRemotes <$> liftIO (getDaemonStatus dstatus)
+				=<< syncRemotes <$> liftIO (getDaemonStatusOld dstatus)
 			let matchingrs = filter (matching . Remote.uuid) rs
 			if null matchingrs
 				then defer
@@ -92,7 +92,7 @@ queueTransfersMatching matching schedule q dstatus k f direction
 queueDeferredDownloads :: Schedule -> TransferQueue -> DaemonStatusHandle -> Annex ()
 queueDeferredDownloads schedule q dstatus = do
 	l <- liftIO $ atomically $ swapTVar (deferreddownloads q) []
-	rs <- syncRemotes <$> liftIO (getDaemonStatus dstatus)
+	rs <- syncRemotes <$> liftIO (getDaemonStatusOld dstatus)
 	left <- filterM (queue rs) l
 	unless (null left) $
 		liftIO $ atomically $ modifyTVar' (deferreddownloads q) $

Assistant/WebApp.hs

@@ -74,9 +74,6 @@ newWebAppState = do
 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 daemonStatusHandle
-
 runAssistantY :: forall sub a. (Assistant a) -> GHandler sub WebApp a
 runAssistantY a = liftIO . runAssistant a =<< assistantData <$> getYesod
 
@@ -112,7 +109,7 @@ newNotifier selector = do
 	liftIO $ notificationHandleToId <$> newNotificationHandle notifier
 
 getNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> GHandler sub WebApp NotificationBroadcaster
-getNotifier selector = selector <$> getDaemonStatusY
+getNotifier selector = selector <$> runAssistantY getDaemonStatus
 
 {- Adds the auth parameter as a hidden field on a form. Must be put into
  - every form. -}

Assistant/WebApp/Configurators.hs

@@ -10,6 +10,7 @@
 module Assistant.WebApp.Configurators where
 
 import Assistant.Common
+import Assistant.DaemonStatus
 import Assistant.WebApp
 import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
@@ -101,7 +102,7 @@ repoList onlyconfigured includehere
 	where
 		configured = do
 			rs <- filter (not . Remote.readonly) . syncRemotes
-				<$> getDaemonStatusY
+				<$> runAssistantY getDaemonStatus
 			runAnnex [] $ do
 				u <- getUUID
 				let l = map Remote.uuid rs

Assistant/WebApp/SideBar.hs

@@ -27,7 +27,8 @@ sideBarDisplay :: Widget
 sideBarDisplay = do
 	let content = do
 		{- Add newest alerts to the sidebar. -}
-		alertpairs <- lift $ M.toList . alertMap <$> getDaemonStatusY
+		alertpairs <- lift $ M.toList . alertMap
+			<$> runAssistantY getDaemonStatus
 		mapM_ renderalert $
 			take displayAlerts $ reverse $ sortAlertPairs alertpairs
 	let ident = "sidebar"
@@ -79,7 +80,7 @@ getCloseAlert i = do
 {- When an alert with a button is clicked on, the button takes us here. -}
 getClickAlert :: AlertId -> Handler ()
 getClickAlert i = do
-	m <- alertMap <$> getDaemonStatusY
+	m <- alertMap <$> runAssistantY getDaemonStatus
 	case M.lookup i m of
 		Just (Alert { alertButton = Just b }) -> do
 			{- Spawn a thread to run the action while redirecting. -}

Assistant/WebApp/Utility.hs

@@ -44,7 +44,7 @@ changeSyncable (Just r) False = do
 	void $ liftIO $ dequeueTransfers (transferQueue d) dstatus tofrom
 	mapM_ (cancelTransfer False) =<<
 		filter tofrom . M.keys <$>
-			liftIO (currentTransfers <$> getDaemonStatus dstatus)
+			runAssistantY (currentTransfers <$> getDaemonStatus)
 	where
 		tofrom t = transferUUID t == Remote.uuid r
 
@@ -128,4 +128,4 @@ startTransfer t = do
 				Transferrer.startTransfer program t info
 
 getCurrentTransfers :: Handler TransferMap
-getCurrentTransfers = currentTransfers <$> getDaemonStatusY
+getCurrentTransfers = currentTransfers <$> runAssistantY getDaemonStatus