From 30976fbf92c4b67f9c2827349cb822fef9f76f09 Mon Sep 17 00:00:00 2001 From: Stephen Paul Weber Date: Sat, 12 Mar 2016 11:45:52 -0500 Subject: [PATCH] Replace startup join logic with constant pings We might restart, the remote might restart, best way is to just constantly check if we're still in the room. On startup, re-check each of our users and rejoin anyone who does not respond to ping. Then keep pinging. Partial for #36 --- Main.hs | 188 ++++++++++++++++++++++++++++---------------------------- 1 file changed, 94 insertions(+), 94 deletions(-) diff --git a/Main.hs b/Main.hs index 680270e..55812a1 100644 --- a/Main.hs +++ b/Main.hs @@ -205,7 +205,7 @@ componentMessage db toVitelity _ (Message { messageFrom = Just from }) existingR writeStanzaChan toVitelity $ mkSMS tel txt componentMessage _ _ _ m _ _ _ _ _ = log "UNKNOWN MESSAGE" m -handleJoinPartRoom db toVitelity toRoomPresences toJoinPartDebouncer toComponent existingRoom from to tel payloads join +handleJoinPartRoom db toVitelity toRoomPresences toRejoinManager toJoinPartDebouncer toComponent existingRoom from to tel payloads join | join, [x] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< payloads, not $ null $ code "110" =<< isNamed (fromString "{http://jabber.org/protocol/muc#user}status") =<< elementChildren x = do @@ -219,25 +219,23 @@ handleJoinPartRoom db toVitelity toRoomPresences toJoinPartDebouncer toComponent bookmarks <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db (tcKey tel "bookmarks")) True <- TC.runTCM (TC.put db (tcKey tel "bookmarks") (show $ sort $ nub $ T.unpack bareMUC : bookmarks)) - startup <- fmap (maybe False (const True :: String -> Bool)) $ TC.runTCM $ TC.get db (T.unpack bareMUC <> "\0startup_tels") - falsePresence <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db (T.unpack bareMUC <> "\0false_presence")) - True <- TC.runTCM $ TC.put db (T.unpack (bareTxt from) <> "\0false_presence") (show $ sort $ nubBy (equating fst) $ filter ((/=T.unpack resourceFrom).fst) falsePresence) -- Presence is no longer false - presences <- syncCall toRoomPresences $ GetRoomPresences tel from atomically $ writeTChan toRoomPresences $ RecordJoin tel from (Just to) + atomically $ writeTChan toRejoinManager $ Joined from + case presences of [] -> do -- No one in the room, so we "created" log "JOINED" (tel, from, "CREATED") uuid <- fromMaybe "UUIDFAIL" <$> (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID - let fullid = if (T.unpack resourceFrom `elem` map fst falsePresence) then uuid else "CHEOGRAMCREATE%" <> uuid + let fullid = if (T.unpack resourceFrom `elem` map fst presences) then uuid else "CHEOGRAMCREATE%" <> uuid writeStanzaChan toComponent $ (emptyIQ IQGet) { iqTo = Just room, iqFrom = Just to, iqID = Just $ fromString fullid, iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/muc#owner}query") [] [] } - (_:_) | isNothing (lookup (T.unpack resourceFrom) (presences <> falsePresence)) -> do + (_:_) | isNothing (lookup (T.unpack resourceFrom) presences) -> do log "JOINED" (tel, from, "YOU HAVE JOINED") writeStanzaChan toVitelity $ mkSMS tel $ mconcat [ fromString "* You have joined ", bareMUC, @@ -460,12 +458,12 @@ handleRegister _ _ toComponent _ iq@(IQ { iqType = typ }) _ } handleRegister _ _ _ _ _ iq = log "HANDLEREGISTER UNKNOWN" iq -componentStanza _ _ _ _ toComponent _ (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from})) +componentStanza _ _ _ _ _ toComponent _ (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from})) | [x] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< messagePayloads m, not $ null $ code "104" =<< isNamed (fromString "{http://jabber.org/protocol/muc#user}status") =<< elementChildren x = do log "CODE104" (to, from) queryDisco toComponent from to -componentStanza db toVitelity _ _ toComponent componentHost (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from})) +componentStanza db toVitelity _ _ _ toComponent componentHost (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from})) | Just tel <- strNode <$> jidNode to, T.length tel == 11 && fromString "1" `T.isPrefixOf` tel = do log "RECEIVEDMESSAGE" m @@ -504,14 +502,14 @@ componentStanza db toVitelity _ _ toComponent componentHost (ReceivedMessage (m@ } where resourceFrom = strResource <$> jidResource from -componentStanza _ toVitelity _ _ _ _ (ReceivedPresence p@(Presence { presenceType = PresenceError, presenceFrom = Just from, presenceTo = Just to })) +componentStanza _ toVitelity _ _ _ _ _ (ReceivedPresence p@(Presence { presenceType = PresenceError, presenceFrom = Just from, presenceTo = Just to })) | Just tel <- strNode <$> jidNode to = do log "FAILED TO JOIN" p let errorText = maybe mempty (mconcat . (fromString "\n":) . elementText) $ listToMaybe $ isNamed (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}text") =<< elementChildren =<< isNamed (fromString "{jabber:component:accept}error") =<< presencePayloads p writeStanzaChan toVitelity $ mkSMS tel (fromString "* Failed to join " <> bareTxt from <> errorText) -componentStanza db toVitelity toRoomPresences toJoinPartDebouncer toComponent _ (ReceivedPresence (Presence { +componentStanza db toVitelity toRoomPresences toRejoinManager toJoinPartDebouncer toComponent _ (ReceivedPresence (Presence { presenceType = typ, presenceFrom = Just from, presenceTo = Just to@(JID { jidNode = Just toNode }), @@ -519,8 +517,8 @@ componentStanza db toVitelity toRoomPresences toJoinPartDebouncer toComponent _ })) | typ `elem` [PresenceAvailable, PresenceUnavailable] = do existingRoom <- tcGetJID db (strNode toNode) "joined" log "JOIN PART ROOM" (from, to, typ, existingRoom, payloads) - handleJoinPartRoom db toVitelity toRoomPresences toJoinPartDebouncer toComponent existingRoom from to (strNode toNode) payloads (typ == PresenceAvailable) -componentStanza _ _ _ _ toComponent _ (ReceivedPresence (Presence { presenceType = PresenceSubscribe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Nothing } })) = do + handleJoinPartRoom db toVitelity toRoomPresences toRejoinManager toJoinPartDebouncer toComponent existingRoom from to (strNode toNode) payloads (typ == PresenceAvailable) +componentStanza _ _ _ _ _ toComponent _ (ReceivedPresence (Presence { presenceType = PresenceSubscribe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Nothing } })) = do log "APPROVE SUBSCRIPTION" (from, to) writeStanzaChan toComponent $ (emptyPresence PresenceSubscribed) { presenceTo = Just from, @@ -531,7 +529,7 @@ componentStanza _ _ _ _ toComponent _ (ReceivedPresence (Presence { presenceType presenceTo = Just from, presenceFrom = Just to } -componentStanza _ _ _ _ toComponent _ (ReceivedPresence (Presence { presenceType = PresenceProbe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Nothing } })) = do +componentStanza _ _ _ _ _ toComponent _ (ReceivedPresence (Presence { presenceType = PresenceProbe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Nothing } })) = do log "RESPOND TO PROBES" (from, to) writeStanzaChan toComponent $ (emptyPresence PresenceAvailable) { presenceTo = Just from, @@ -545,12 +543,12 @@ componentStanza _ _ _ _ toComponent _ (ReceivedPresence (Presence { presenceType ] [] ] } -componentStanza db toVitelity _ _ toComponent componentHost (ReceivedIQ iq@(IQ { iqFrom = Just _, iqTo = Just (JID { jidNode = Nothing }), iqPayload = Just p })) +componentStanza db toVitelity _ _ _ toComponent componentHost (ReceivedIQ iq@(IQ { iqFrom = Just _, iqTo = Just (JID { jidNode = Nothing }), iqPayload = Just p })) | iqType iq `elem` [IQGet, IQSet], [query] <- isNamed (fromString "{jabber:iq:register}query") p = do log "LOOKS LIKE REGISTRATION" iq handleRegister db toVitelity toComponent componentHost iq query -componentStanza _ _ _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = id, iqPayload = Just p })) +componentStanza _ _ _ _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = id, iqPayload = Just p })) | Nothing <- jidNode to, [_] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do log "DISCO ON US" (from, to, p) @@ -573,7 +571,7 @@ componentStanza _ _ _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = ] [] ] } -componentStanza _ _ _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = id, iqPayload = Just p })) +componentStanza _ _ _ _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = id, iqPayload = Just p })) | Just _ <- jidNode to, [_] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do log "DISCO ON USER" (from, to, p) @@ -594,7 +592,7 @@ componentStanza _ _ _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = ] [] ] } -componentStanza _ _ _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQSet, iqFrom = Just from, iqTo = Just (to@JID {jidNode = Nothing}), iqID = id, iqPayload = Just p })) +componentStanza _ _ _ _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQSet, iqFrom = Just from, iqTo = Just (to@JID {jidNode = Nothing}), iqID = id, iqPayload = Just p })) | [query] <- isNamed (fromString "{jabber:iq:gateway}query") p, [prompt] <- isNamed (fromString "{jabber:iq:gateway}prompt") =<< elementChildren query = do log "jabber:iq:gateway submit" (from, to, p) @@ -621,7 +619,7 @@ componentStanza _ _ _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = [NodeContent $ ContentText $ fromString "Only US/Canada telephone numbers accepted"] ] } -componentStanza _ _ _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just (to@JID {jidNode = Nothing}), iqID = id, iqPayload = Just p })) +componentStanza _ _ _ _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just (to@JID {jidNode = Nothing}), iqID = id, iqPayload = Just p })) | [_] <- isNamed (fromString "{jabber:iq:gateway}query") p = do log "jabber:iq:gateway query" (from, to, p) writeStanzaChan toComponent $ (emptyIQ IQResult) { @@ -634,45 +632,7 @@ componentStanza _ _ _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = NodeElement $ Element (fromString "{jabber:iq:gateway}prompt") [ ] [NodeContent $ ContentText $ fromString "Phone Number"] ] } -componentStanza db _ _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, iqID = Just id })) - | fromString "CHEOGRAMSTARTUP%" `T.isPrefixOf` id = do - log "CHEOGRAMSTARTUP RESULT" (from, to, items, iq) - -- Room exists and has people in it - presence <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db ("presence\0" <> T.unpack (bareTxt from))) - -- Keep any JID associations we already know about, items is only nicks - let presence' = map (\nick -> (nick, join $ lookup nick presence)) items - True <- TC.runTCM $ TC.put db ("presence\0" <> T.unpack (bareTxt from)) (show $ sort $ nubBy (equating fst) presence') - - -- Extract tels from who we thought was in the room - let tels = mapMaybe (\(nick,jid) -> ((,)nick) <$> (T.stripSuffix jidSuffix =<< jid)) presence - let rejoinNicks = map fst tels \\ items - let falsePresence = filter (\(nick, _) -> nick `elem` rejoinNicks) tels - True <- TC.runTCM $ TC.put db (T.unpack (bareTxt from) <> "\0false_presence") (show $ sort falsePresence) - mapM_ (\(nick,tel) -> forM_ (room nick) (joinRoom db toComponent componentHost tel)) falsePresence - where - jidSuffix = fromString $ "@" <> componentHost - room nick = parseJID $ bareTxt from <> fromString "/" <> nick - items = map (fromMaybe mempty . attributeText (fromString "name")) $ - isNamed (fromString "{http://jabber.org/protocol/disco#items}item") =<< - elementChildren =<< - isNamed (fromString "{http://jabber.org/protocol/disco#items}query") =<< - toList (iqPayload iq) -componentStanza db _ _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQError, iqFrom = Just from, iqTo = Just to, iqID = Just id })) - | fromString "CHEOGRAMSTARTUP%" `T.isPrefixOf` id = do - log "CHEOGRAMSTARTUP ERROR" (from, to, iq) - -- We must assume the room has been destroyed, though maybe it's just blocking our queries - presence <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db ("presence\0" <> T.unpack (bareTxt from))) - TC.runTCM $ TC.out db ("presence\0" <> T.unpack (bareTxt from)) - let tels = mapMaybe (\(nick,jid) -> ((,)nick) <$> (T.stripSuffix (fromString $ "@" <> componentHost) =<< jid)) presence - case tels of - [] -> return () -- wut? - ((nick,tel):xs) -> do - -- startup_tels is who to make join once room is created. false_presence is who thinks they're in the room already - True <- TC.runTCM $ TC.put db (T.unpack (bareTxt from) <> "\0startup_tels") (show xs) - True <- TC.runTCM $ TC.put db (T.unpack (bareTxt from) <> "\0false_presence") (show $ sort $ (nick,tel):xs) - leaveRoom db toComponent componentHost tel "Service reset" -- in case we are in and can't tell? - forM_ (parseJID $ bareTxt from <> fromString "/" <> nick) $ joinRoom db toComponent componentHost tel -componentStanza db _ _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQError, iqFrom = Just from, iqTo = Just to })) +componentStanza db _ _ _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQError, iqFrom = Just from, iqTo = Just to })) | (strNode <$> jidNode to) == Just (fromString "create"), Just resource <- strResource <$> jidResource to = do log "create@ ERROR" (from, to, iq) @@ -683,7 +643,7 @@ componentStanza db _ _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = leaveRoom db toComponent componentHost tel "Joined a different room." joinRoom db toComponent componentHost tel room _ -> return () -- Invalid packet, ignore -componentStanza _ _ _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to })) +componentStanza _ _ _ _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to })) | (strNode <$> jidNode to) == Just (fromString "create"), Just resource <- strResource <$> jidResource to = do log "create@ RESULT" (from, to, iq) @@ -691,11 +651,19 @@ componentStanza _ _ _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = (tel:name:[]) -> void $ createRoom toComponent componentHost [T.unpack $ strDomain $ jidDomain from] tel (name <> "_" <> tel) (tel:name:servers) -> void $ createRoom toComponent componentHost servers tel name _ -> return () -- Invalid packet, ignore -componentStanza _ toVitelity _ _ _ _ (ReceivedIQ (iq@IQ { iqType = IQError, iqFrom = Just from, iqTo = Just to })) +componentStanza _ _ _ toRejoinManager _ _ _ (ReceivedIQ (iq@IQ { iqType = IQResult, iqID = Just id, iqFrom = Just from })) + | fromString "CHEOGRAMPING%" `T.isPrefixOf` id = do + log "PING RESULT" from + atomically $ writeTChan toRejoinManager (PingReply from) +componentStanza _ _ _ toRejoinManager _ _ _ (ReceivedIQ (iq@IQ { iqType = IQError, iqID = Just id, iqFrom = Just from })) + | fromString "CHEOGRAMPING%" `T.isPrefixOf` id = do + log "PING ERROR RESULT" from + atomically $ writeTChan toRejoinManager (PingError from) +componentStanza _ toVitelity _ _ _ _ _ (ReceivedIQ (iq@IQ { iqType = IQError, iqFrom = Just from, iqTo = Just to })) | Just tel <- strNode <$> jidNode to = do log "IQ ERROR" iq writeStanzaChan toVitelity $ mkSMS tel (fromString "Error while querying or configuring " <> formatJID from) -componentStanza _ _ _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, iqID = Just id, iqPayload = Just p })) +componentStanza _ _ _ _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, iqID = Just id, iqPayload = Just p })) | [query] <- isNamed (fromString "{http://jabber.org/protocol/muc#owner}query") p, [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren query = do log "DISCO RESULT" (from, to, p) @@ -714,14 +682,14 @@ componentStanza _ _ _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQResult, iqFro form { elementAttributes = [(fromString "{jabber:x:data}type", [ContentText $ fromString "submit"])] } ] } -componentStanza _ toVitelity _ _ toComponent _ (ReceivedIQ (iq@IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, iqID = Just id })) +componentStanza _ toVitelity _ _ _ toComponent _ (ReceivedIQ (iq@IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, iqID = Just id })) | Just tel <- strNode <$> jidNode to, fromString "CHEOGRAMCREATE%" `T.isPrefixOf` id = do log "CHEOGRAMCREATE RESULT YOU HAVE CREATED" (from, to, iq) writeStanzaChan toVitelity $ mkSMS tel (mconcat [fromString "* You have created ", bareTxt from]) forM_ (parseJID $ bareTxt to <> fromString "/create") $ queryDisco toComponent from -componentStanza db _ _ _ toComponent componentHost (ReceivedIQ (IQ { iqType = IQResult, iqTo = Just to, iqFrom = Just from, iqPayload = Just p })) +componentStanza db _ _ _ _ toComponent componentHost (ReceivedIQ (IQ { iqType = IQResult, iqTo = Just to, iqFrom = Just from, iqPayload = Just p })) | Just tel <- strNode <$> jidNode to, [query] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do log "DISCO RESULT" (from, to, p) @@ -732,8 +700,7 @@ componentStanza db _ _ _ toComponent componentHost (ReceivedIQ (IQ { iqType = IQ when (fmap strResource (jidResource to) == Just (fromString "create")) $ do regJid <- tcGetJID db tel "registered" forM_ regJid $ \jid -> forM_ (parseJID $ bareTxt to) $ \to -> sendInvite db toComponent jid (Invite from to Nothing Nothing) - joinStartupTels db toComponent componentHost from to -componentStanza _ _ _ _ toComponent _ (ReceivedIQ (iq@IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqPayload = Just p })) +componentStanza _ _ _ _ _ toComponent _ (ReceivedIQ (iq@IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqPayload = Just p })) | not $ null $ isNamed (fromString "{urn:xmpp:ping}ping") p = do log "urn:xmpp:ping" (from, to) writeStanzaChan toComponent $ iq { @@ -742,7 +709,7 @@ componentStanza _ _ _ _ toComponent _ (ReceivedIQ (iq@IQ { iqType = IQGet, iqFro iqType = IQResult, iqPayload = Nothing } -componentStanza _ _ _ _ toComponent _ (ReceivedIQ (iq@IQ { iqType = typ })) +componentStanza _ _ _ _ _ toComponent _ (ReceivedIQ (iq@IQ { iqType = typ })) | typ `elem` [IQGet, IQSet] = do log "REPLY WITH IQ ERROR" iq writeStanzaChan toComponent $ iq { @@ -753,16 +720,7 @@ componentStanza _ _ _ _ toComponent _ (ReceivedIQ (iq@IQ { iqType = typ })) [(fromString "{jabber:component:accept}type", [ContentText $ fromString "cancel"])] [NodeElement $ Element (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}feature-not-implemented") [] []] } -componentStanza _ _ _ _ _ _ s = log "UNKNOWN STANZA" s - -joinStartupTels db toComponent componentHost muc hopefulOwner = do - muc_membersonly <- maybe False toEnum <$> TC.runTCM (TC.get db (T.unpack (bareTxt muc) <> "\0muc_membersonly")) - startup <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db (T.unpack (bareTxt muc) <> "\0startup_tels")) - _ <- TC.runTCM $ TC.out db $ (T.unpack (bareTxt muc) <> "\0startup_tels") - forM_ startup $ \(nick, tel) -> do - when muc_membersonly $ forM_ (telToJid tel (fromString componentHost)) $ - addMUCOwner toComponent muc hopefulOwner - forM_ (parseJID $ bareTxt muc <> fromString "/" <> nick) $ joinRoom db toComponent componentHost tel +componentStanza _ _ _ _ _ _ _ s = log "UNKNOWN STANZA" s participantJid payloads = listToMaybe $ mapMaybe (parseJID <=< attributeText (fromString "jid")) $ @@ -770,7 +728,7 @@ participantJid payloads = elementChildren =<< isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< payloads -component db toVitelity toRoomPresences toJoinPartDebouncer toComponent componentHost = do +component db toVitelity toRoomPresences toRejoinManager toJoinPartDebouncer toComponent componentHost = do thread <- forkXMPP $ forever $ flip catchError (log "component EXCEPTION") $ do stanza <- liftIO $ atomically $ readTChan toComponent log "COMPONENT OUT" stanza @@ -779,7 +737,7 @@ component db toVitelity toRoomPresences toJoinPartDebouncer toComponent componen flip catchError (\e -> liftIO (log "component part 2 EXCEPTION" e >> killThread thread)) $ forever $ do s <- getStanza log "COMPONENT IN" s - liftIO $ componentStanza db toVitelity toRoomPresences toJoinPartDebouncer toComponent componentHost s + liftIO $ componentStanza db toVitelity toRoomPresences toRejoinManager toJoinPartDebouncer toComponent componentHost s telToVitelity tel | not $ all isDigit $ T.unpack tel = Nothing @@ -1103,6 +1061,60 @@ syncCall chan req = do atomically $ writeTChan chan (req var) atomically $ takeTMVar var +data RejoinManagerCommand = + CheckPings | + PingReply JID | + PingError JID | + Joined JID | + ForceRejoin JID Text + +data RejoinManagerState = PingSent Text | Rejoining + +rejoinManager db toComponent componentHost toRejoinManager = + next mempty + where + mkMucJid muc nick = parseJID $ bareTxt muc <> fromString "/" <> nick + ourJids muc (x,y) = (,) <$> mkMucJid muc x <*> (T.stripSuffix (fromString $ "@" <> componentHost) =<< y) + + next state = atomically (readTChan toRejoinManager) >>= go state + + go state (PingReply mucJid) = + next $! Map.delete mucJid state + go state (PingError mucJid) = do + forM_ (Map.lookup mucJid state) $ \x -> case x of + PingSent tel -> atomically $ writeTChan toRejoinManager (ForceRejoin mucJid tel) + _ -> return () + next state + go state (Joined mucJid) = + next $! Map.delete mucJid state + go state (ForceRejoin mucJid tel) = do + joinRoom db toComponent componentHost tel mucJid + next $! Map.insert mucJid Rejoining state + go state CheckPings = do + presenceKeys <- TC.runTCM $ TC.fwmkeys db "presence\0" maxBound + (next =<<) $! (\x -> foldM x state (presenceKeys :: [String])) $ \state pkey -> do + let Just muc = parseJID =<< T.stripPrefix (fromString "presence\0") (T.pack pkey) + putStrLn $ fromString "Checking (ping?) participants in " <> formatJID muc <> fromString "..." + presences <- fmap (mapMaybe (ourJids muc) . fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db pkey) + (\x -> foldM x state presences) $ \state (mucJid, tel) -> + case Map.lookup mucJid state of + Nothing -> do + log "PINGING" (mucJid, tel) + uuid <- fromMaybe "UUIDFAIL" <$> (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID + writeStanzaChan toComponent $ (emptyIQ IQGet) { + iqTo = Just mucJid, + iqFrom = parseJID $ tel <> T.pack ("@" <> componentHost), + iqID = Just $ fromString $ "CHEOGRAMPING%" <> uuid, + iqPayload = Just $ Element (fromString "{urn:xmpp:ping}ping") [] [] + } + return $! Map.insert mucJid (PingSent tel) state + Just (PingSent _) -> do -- Timeout, rejoin + log "PING TIMEOUT" (mucJid, tel) + joinRoom db toComponent componentHost tel mucJid + return $! Map.insert mucJid Rejoining state + Just Rejoining -> -- Don't ping, we're working on it + return state + -- tel, from (bare is MUC, resource is nick), Maybe participantJID data RoomPresences = RecordJoin Text JID (Maybe JID) | @@ -1199,29 +1211,17 @@ main = do toVitelity <- atomically newTChan toComponent <- atomically newTChan toRoomPresences <- atomically newTChan + toRejoinManager <- atomically newTChan void $ forkIO $ forever $ threadDelay 1500000 >> atomically (writeTChan chunks TimerExpire) void $ forkIO $ multipartStitcher db chunks toVitelity toComponent name conferences void $ forkIO $ joinPartDebouncer toVitelity toRoomPresences toJoinPartDebouncer void $ forkIO $ roomPresences db toRoomPresences - void $ forkIO $ forever $ log "runComponent ENDED" =<< (runEitherT . syncIO) (runComponent (Server (fromString name) host (PortNumber $ fromIntegral (read port :: Int))) (fromString secret) (component db toVitelity toRoomPresences toJoinPartDebouncer toComponent name)) + void $ forkIO $ forever $ atomically (writeTChan toRejoinManager CheckPings) >> threadDelay 120000000 + void $ forkIO $ rejoinManager db toComponent name toRejoinManager - oldPresence <- TC.runTCM $ TC.fwmkeys db "presence\0" maxBound - forM_ (oldPresence :: [String]) $ \pkey -> do - let Just muc = parseJID =<< T.stripPrefix (fromString "presence\0") (T.pack pkey) - putStrLn $ fromString "Checking participants in " <> formatJID muc <> fromString "..." - presence <- fmap (mapMaybe (snd :: (Text, Maybe Text) -> Maybe Text) . fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db pkey) - case filter ((fromString $ "@" <> name) `T.isSuffixOf`) presence of - [] -> return () -- wut? - (x:_) -> do - uuid <- fromMaybe "UUIDFAIL" <$> (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID - writeStanzaChan toComponent $ (emptyIQ IQGet) { - iqTo = Just muc, - iqFrom = parseJID x, - iqID = Just $ fromString $ "CHEOGRAMSTARTUP%" <> uuid, - iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#items}query") [] [] - } + void $ forkIO $ forever $ log "runComponent ENDED" =<< (runEitherT . syncIO) (runComponent (Server (fromString name) host (PortNumber $ fromIntegral (read port :: Int))) (fromString secret) (component db toVitelity toRoomPresences toRejoinManager toJoinPartDebouncer toComponent name)) let Just vitelityParsedJid = parseJID $ fromString vitelityJid forever $ runClient (Server (fromString "s.ms") "s.ms" (PortNumber 5222)) vitelityParsedJid (fromMaybe mempty $ strNode <$> jidNode vitelityParsedJid) (fromString vitelityPassword) $ do -- 2.45.2