diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index 6525247ebd..1706c0a57d 100644 --- a/Assistant/DaemonStatus.hs +++ b/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, ()) diff --git a/Assistant/Drop.hs b/Assistant/Drop.hs index cf20ef5b1d..021e40a877 100644 --- a/Assistant/Drop.hs +++ b/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 diff --git a/Assistant/Threads/DaemonStatus.hs b/Assistant/Threads/DaemonStatus.hs index 946bf1b052..07f0986a60 100644 --- a/Assistant/Threads/DaemonStatus.hs +++ b/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 diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 235f7f124f..b8e5f46836 100644 --- a/Assistant/Threads/PairListener.hs +++ b/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 diff --git a/Assistant/Threads/PushNotifier.hs b/Assistant/Threads/PushNotifier.hs index 85c7fd9d99..b50a2e4b90 100644 --- a/Assistant/Threads/PushNotifier.hs +++ b/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 diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs index 905cf81db6..ac65ca14cf 100644 --- a/Assistant/Threads/Pusher.hs +++ b/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 diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index 46f399dabd..2ffdc9f32d 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/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 diff --git a/Assistant/Threads/TransferPoller.hs b/Assistant/Threads/TransferPoller.hs index e28c243649..c9e20757d8 100644 --- a/Assistant/Threads/TransferPoller.hs +++ b/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 diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index ec0bc0d9be..c37b1e3b9c 100644 --- a/Assistant/Threads/TransferScanner.hs +++ b/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) diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index dee71b731f..8d155ecb19 100644 --- a/Assistant/Threads/Watcher.hs +++ b/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 diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs index 94a2945497..13f9f0088b 100644 --- a/Assistant/TransferQueue.hs +++ b/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) $ diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs index fe9844fcce..7cfea81198 100644 --- a/Assistant/WebApp.hs +++ b/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. -} diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs index 07dac0c208..1e5489be9e 100644 --- a/Assistant/WebApp/Configurators.hs +++ b/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 diff --git a/Assistant/WebApp/SideBar.hs b/Assistant/WebApp/SideBar.hs index ce6438a4e4..b43ae2b602 100644 --- a/Assistant/WebApp/SideBar.hs +++ b/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. -} diff --git a/Assistant/WebApp/Utility.hs b/Assistant/WebApp/Utility.hs index 83968ad70c..0390e111fa 100644 --- a/Assistant/WebApp/Utility.hs +++ b/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