diff --git a/Assistant.hs b/Assistant.hs index 5cc9f303f6..4a21a2ae9b 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -177,7 +177,7 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do checkCanWatch dstatus <- startDaemonStatus liftIO $ daemonize $ - runAssistant go =<< newAssistantData st dstatus + flip runAssistant go =<< newAssistantData st dstatus where go = do d <- getAssistant id @@ -216,6 +216,5 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do assist a = (False, a) startthread d (watcher, t) | watcher || assistant = void $ liftIO $ forkIO $ - flip runAssistant d $ - runNamedThread t + runAssistant d $ runNamedThread t | otherwise = noop diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs index 9f5c42aa3f..3b6dfedeef 100644 --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -79,8 +79,8 @@ newAssistantData st dstatus = AssistantData <*> newBuddyList <*> newNetMessagerControl -runAssistant :: Assistant a -> AssistantData -> IO a -runAssistant a = runReaderT (mkAssistant a) +runAssistant :: AssistantData -> Assistant a -> IO a +runAssistant d a = runReaderT (mkAssistant a) d getAssistant :: (AssistantData -> a) -> Assistant a getAssistant = reader @@ -97,23 +97,23 @@ liftAnnex a = do (<~>) :: (IO a -> IO b) -> Assistant a -> Assistant b io <~> a = do d <- reader id - liftIO $ io $ runAssistant a d + liftIO $ io $ runAssistant d a {- Creates an IO action that will run an Assistant action when run. -} asIO :: Assistant a -> Assistant (IO a) asIO a = do d <- reader id - return $ runAssistant a d + return $ runAssistant d a asIO1 :: (a -> Assistant b) -> Assistant (a -> IO b) asIO1 a = do d <- reader id - return $ \v -> runAssistant (a v) d + return $ \v -> runAssistant d $ a v asIO2 :: (a -> b -> Assistant c) -> Assistant (a -> b -> IO c) asIO2 a = do d <- reader id - return $ \v1 v2 -> runAssistant (a v1 v2) d + return $ \v1 v2 -> runAssistant d (a v1 v2) {- Runs an IO action on a selected field of the AssistantData. -} (<<~) :: (a -> IO b) -> (AssistantData -> a) -> Assistant b diff --git a/Assistant/NamedThread.hs b/Assistant/NamedThread.hs index 4622f87428..083252f948 100644 --- a/Assistant/NamedThread.hs +++ b/Assistant/NamedThread.hs @@ -19,12 +19,12 @@ runNamedThread (NamedThread name a) = do liftIO . go $ d { threadName = name } where go d = do - r <- E.try (runAssistant a d) :: IO (Either E.SomeException ()) + r <- E.try (runAssistant d a) :: IO (Either E.SomeException ()) case r of Right _ -> noop Left e -> do let msg = unwords [name, "crashed:", show e] hPutStrLn stderr msg -- TODO click to restart - flip runAssistant d $ void $ + runAssistant d $ void $ addAlert $ warningAlert name msg diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index 3d454d9c87..7da2bccc63 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -18,7 +18,7 @@ import Assistant.Sync import Assistant.DaemonStatus import qualified Remote import Utility.ThreadScheduler -import Assistant.WebApp +import Assistant.WebApp (UrlRenderer, renderUrl) import Assistant.WebApp.Types import Assistant.Alert import Assistant.Pairing @@ -34,73 +34,72 @@ import qualified Git.Branch import Data.Time.Clock xmppClientThread :: UrlRenderer -> NamedThread -xmppClientThread urlrenderer = NamedThread "XMPPClient" $ do - {- All Assistant actions have to be converted into IO actions that - - can be run from within the XMPP monad using liftIO. Ugly. -} - iodebug <- asIO1 debug - iopull <- asIO1 pull - iopairMsgReceived <- asIO2 $ pairMsgReceived urlrenderer - ioupdatebuddies <- asIO1 $ \p -> - updateBuddyList (updateBuddies p) <<~ buddyList - ioemptybuddies <- asIO $ - updateBuddyList (const noBuddies) <<~ buddyList - iorelay <- asIO1 relayNetMessage - ioclientthread <- asIO $ - go iorelay iodebug iopull ioupdatebuddies ioemptybuddies iopairMsgReceived - restartableClient ioclientthread +xmppClientThread urlrenderer = NamedThread "XMPPClient" $ + restartableClient . xmppClient urlrenderer =<< getAssistant id + +{- Runs the client, handing restart events. -} +restartableClient :: IO () -> Assistant () +restartableClient a = forever $ do + tid <- liftIO $ forkIO a + waitNetMessagerRestart + liftIO $ killThread tid + +xmppClient :: UrlRenderer -> AssistantData -> IO () +xmppClient urlrenderer d = do + v <- liftAssistant $ liftAnnex getXMPPCreds + case v of + Nothing -> noop -- will be restarted once creds get configured + Just c -> retry (runclient c) =<< getCurrentTime where - go iorelay iodebug iopull ioupdatebuddies ioemptybuddies iopairMsgReceived = do - v <- liftAnnex getXMPPCreds - case v of - Nothing -> noop - Just c -> liftIO $ retry (runclient c) =<< getCurrentTime - where - debug' = void . liftIO . iodebug + liftAssistant = runAssistant d + xAssistant = liftIO . liftAssistant - {- When the client exits, it's restarted; - - if it keeps failing, back off to wait 5 minutes before - - trying it again. -} - retry a starttime = do - e <- a - now <- getCurrentTime - if diffUTCTime now starttime > 300 - then do - void $ iodebug ["connection lost; reconnecting", show e] - retry a now - else do - void $ iodebug ["connection failed; will retry", show e] - threadDelaySeconds (Seconds 300) - retry a =<< getCurrentTime + {- When the client exits, it's restarted; + - if it keeps failing, back off to wait 5 minutes before + - trying it again. -} + retry client starttime = do + e <- client + now <- getCurrentTime + if diffUTCTime now starttime > 300 + then do + liftAssistant $ debug ["connection lost; reconnecting", show e] + retry client now + else do + liftAssistant $ debug ["connection failed; will retry", show e] + threadDelaySeconds (Seconds 300) + retry client =<< getCurrentTime - runclient c = void $ connectXMPP c $ \jid -> do - selfjid <- bindJID jid - debug' ["connected", show selfjid] - {- The buddy list starts empty each time - - the client connects, so that stale info - - is not retained. -} - void $ liftIO ioemptybuddies - putStanza gitAnnexSignature - xmppThread $ receivenotifications selfjid - forever $ do - a <- liftIO $ iorelay selfjid - a + runclient c = liftIO $ connectXMPP c $ \jid -> do + selfjid <- bindJID jid + putStanza gitAnnexSignature - receivenotifications selfjid = forever $ do - l <- decodeStanza selfjid <$> getStanza - debug' ["received:", show l] - mapM_ (handle selfjid) l + xAssistant $ debug ["connected", show selfjid] + {- The buddy list starts empty each time + - the client connects, so that stale info + - is not retained. -} + void $ xAssistant $ + updateBuddyList (const noBuddies) <<~ buddyList - handle _ (PresenceMessage p) = - void $ liftIO $ ioupdatebuddies p - handle _ (GotNetMessage QueryPresence) = - putStanza gitAnnexSignature - handle _ (GotNetMessage (NotifyPush us)) = - void $ liftIO $ iopull us - handle selfjid (GotNetMessage (PairingNotification stage t u)) = - maybe noop (\jid -> liftIO $ iopairMsgReceived (stage, u) (selfjid, jid)) (parseJID t) - handle _ (Ignorable _) = noop - handle _ (Unknown _) = noop - handle _ (ProtocolError _) = noop + xmppThread $ receivenotifications selfjid + forever $ do + a <- xAssistant $ relayNetMessage selfjid + a + + receivenotifications selfjid = forever $ do + l <- decodeStanza selfjid <$> getStanza + xAssistant $ debug ["received:", show l] + mapM_ (handle selfjid) l + + handle _ (PresenceMessage p) = void $ xAssistant $ + updateBuddyList (updateBuddies p) <<~ buddyList + handle _ (GotNetMessage QueryPresence) = putStanza gitAnnexSignature + handle _ (GotNetMessage (NotifyPush us)) = void $ xAssistant $ + pull us + handle selfjid (GotNetMessage (PairingNotification stage t u)) = + maybe noop (xAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID t) + handle _ (Ignorable _) = noop + handle _ (Unknown _) = noop + handle _ (ProtocolError _) = noop data XMPPEvent = GotNetMessage NetMessage @@ -153,13 +152,6 @@ relayNetMessage selfjid = convert =<< waitNetMessage return $ putStanza $ pairingNotification stage u tojid selfjid -{- Runs the client, handing restart events. -} -restartableClient :: IO () -> Assistant () -restartableClient a = forever $ do - tid <- liftIO $ forkIO a - waitNetMessagerRestart - liftIO $ killThread tid - {- Runs a XMPP action in a separate thread, using a session to allow it - to access the same XMPP client. -} xmppThread :: XMPP () -> XMPP () @@ -196,8 +188,8 @@ pull us = do unlessM (all id . fst <$> manualPull branch [r]) $ pullone rs branch -pairMsgReceived :: UrlRenderer -> (PairStage, UUID) -> (JID, JID) -> Assistant () -pairMsgReceived urlrenderer (PairReq, theiruuid) (selfjid, theirjid) +pairMsgReceived :: UrlRenderer -> PairStage -> UUID -> JID -> JID -> Assistant () +pairMsgReceived urlrenderer PairReq theiruuid selfjid theirjid -- PairReq from another client using our JID is automatically accepted. | baseJID selfjid == baseJID theirjid = do selfuuid <- liftAnnex getUUID @@ -215,7 +207,8 @@ pairMsgReceived urlrenderer (PairReq, theiruuid) (selfjid, theirjid) , buttonLabel = T.pack "Respond" , buttonAction = Just close } -pairMsgReceived _ (PairAck, theiruuid) (_selfjid, theirjid) = + +pairMsgReceived _ PairAck theiruuid _selfjid theirjid = {- PairAck must come from one of the buddies we are pairing with; - don't pair with just anyone. -} whenM (isBuddyPairing theirjid) $ do @@ -224,7 +217,8 @@ pairMsgReceived _ (PairAck, theiruuid) (_selfjid, theirjid) = sendNetMessage $ PairingNotification PairDone (formatJID theirjid) selfuuid finishXMPPPairing theirjid theiruuid -pairMsgReceived _ (PairDone, _theiruuid) (_selfjid, theirjid) = + +pairMsgReceived _ PairDone _theiruuid _selfjid theirjid = changeBuddyPairing theirjid False isBuddyPairing :: JID -> Assistant Bool diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs index 8039c561d0..7c9f747023 100644 --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -69,5 +69,5 @@ runTransferThread' d a = go Just ResumeTransfer -> go _ -> done _ -> done - done = flip runAssistant d $ + done = runAssistant d $ flip MSemN.signal 1 <<~ transferSlots diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs index 10378f60bc..325f27f43b 100644 --- a/Assistant/WebApp.hs +++ b/Assistant/WebApp.hs @@ -71,7 +71,7 @@ newWebAppState = do , otherRepos = otherrepos } liftAssistant :: forall sub a. (Assistant a) -> GHandler sub WebApp a -liftAssistant a = liftIO . runAssistant a =<< assistantData <$> getYesod +liftAssistant a = liftIO . flip runAssistant a =<< assistantData <$> getYesod getWebAppState :: forall sub. GHandler sub WebApp WebAppState getWebAppState = liftIO . atomically . readTMVar =<< webAppState <$> getYesod diff --git a/Command/WebApp.hs b/Command/WebApp.hs index 26afa2791c..43b090fc88 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -107,7 +107,7 @@ firstRun = do urlrenderer <- newUrlRenderer v <- newEmptyMVar let callback a = Just $ a v - void $ flip runAssistant d $ runNamedThread $ + void $ runAssistant d $ runNamedThread $ webAppThread d urlrenderer True (callback signaler) (callback mainthread)