diff options
Diffstat (limited to 'Assistant')
| -rw-r--r-- | Assistant/DaemonStatus.hs | 10 | ||||
| -rw-r--r-- | Assistant/Threads/RemoteControl.hs | 23 | ||||
| -rw-r--r-- | Assistant/Threads/XMPPClient.hs | 1 | ||||
| -rw-r--r-- | Assistant/Types/DaemonStatus.hs | 3 |
4 files changed, 27 insertions, 10 deletions
diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index eb842b784..35f8fc856 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -26,6 +26,7 @@ import Data.Time.Clock.POSIX import Data.Time import System.Locale import qualified Data.Map as M +import qualified Data.Set as S import qualified Data.Text as T getDaemonStatus :: Assistant DaemonStatus @@ -78,6 +79,15 @@ updateSyncRemotes = do M.filter $ \alert -> alertName alert /= Just CloudRepoNeededAlert +changeCurrentlyConnected :: (S.Set UUID -> S.Set UUID) -> Assistant () +changeCurrentlyConnected sm = do + modifyDaemonStatus_ $ \ds -> ds + { currentlyConnectedRemotes = sm (currentlyConnectedRemotes ds) + } + v <- currentlyConnectedRemotes <$> getDaemonStatus + debug [show v] + liftIO . sendNotification =<< syncRemotesNotifier <$> getDaemonStatus + updateScheduleLog :: Assistant () updateScheduleLog = liftIO . sendNotification =<< scheduleLogNotifier <$> getDaemonStatus diff --git a/Assistant/Threads/RemoteControl.hs b/Assistant/Threads/RemoteControl.hs index d33a4858d..a886caeb9 100644 --- a/Assistant/Threads/RemoteControl.hs +++ b/Assistant/Threads/RemoteControl.hs @@ -23,8 +23,9 @@ import qualified Types.Remote as Remote import Control.Concurrent import Control.Concurrent.Async import System.Process (std_in, std_out) -import qualified Data.Map as M import Network.URI +import qualified Data.Map as M +import qualified Data.Set as S remoteControlThread :: NamedThread remoteControlThread = namedThread "RemoteControl" $ do @@ -43,9 +44,9 @@ remoteControlThread = namedThread "RemoteControl" $ do responder <- asIO $ remoteResponderThread fromh urimap -- run controller and responder until the remotedaemon dies - liftIO $ do - void $ controller `concurrently` responder - forceSuccessProcess p pid + liftIO $ void $ tryNonAsync $ controller `concurrently` responder + debug ["remotedaemon exited"] + liftIO $ forceSuccessProcess p pid -- feed from the remoteControl channel into the remotedaemon remoteControllerThread :: Handle -> Assistant () @@ -61,14 +62,10 @@ remoteResponderThread :: Handle -> MVar (M.Map URI Remote) -> Assistant () remoteResponderThread fromh urimap = go M.empty where go syncalerts = do - let cont = go syncalerts - let withr uri = withRemote uri urimap cont l <- liftIO $ hGetLine fromh case parseMessage l of - Just (CONNECTED _uri) -> do - cont - Just (DISCONNECTED _uri) -> do - cont + Just (CONNECTED uri) -> changeconnected S.insert uri + Just (DISCONNECTED uri) -> changeconnected S.delete uri Just (SYNCING uri) -> withr uri $ \r -> if M.member (Remote.uuid r) syncalerts then go syncalerts @@ -92,6 +89,12 @@ remoteResponderThread fromh urimap = go M.empty Nothing -> do debug ["protocol error from remotedaemon: ", l] cont + where + cont = go syncalerts + withr uri = withRemote uri urimap cont + changeconnected sm uri = withr uri $ \r -> do + changeCurrentlyConnected $ sm $ Remote.uuid r + cont getURIMap :: Annex (M.Map URI Remote) getURIMap = Remote.remoteMap' id (mkk . Git.location . Remote.repo) diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index ab4de9257..d23f695f6 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -67,6 +67,7 @@ xmppClient urlrenderer d creds = - is not retained. -} liftAssistant $ updateBuddyList (const noBuddies) <<~ buddyList + liftAssistant $ void client liftAssistant $ modifyDaemonStatus_ $ \s -> s { xmppClientID = Nothing } diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs index a618c700d..2adad2828 100644 --- a/Assistant/Types/DaemonStatus.hs +++ b/Assistant/Types/DaemonStatus.hs @@ -52,6 +52,8 @@ data DaemonStatus = DaemonStatus , syncDataRemotes :: [Remote] -- Are we syncing to any cloud remotes? , syncingToCloudRemote :: Bool + -- Set of uuids of remotes that are currently connected. + , currentlyConnectedRemotes :: S.Set UUID -- List of uuids of remotes that we may have gotten out of sync with. , desynced :: S.Set UUID -- Pairing request that is in progress. @@ -104,6 +106,7 @@ newDaemonStatus = DaemonStatus <*> pure [] <*> pure False <*> pure S.empty + <*> pure S.empty <*> pure Nothing <*> newNotificationBroadcaster <*> newNotificationBroadcaster |