~singpolyma/cheogram

0fe35a9e01826626fa7978761af4e567671e6369 — Stephen Paul Weber 6 years ago 222d7f8
Figure out if we need to, and rejoin
1 files changed, 60 insertions(+), 25 deletions(-)

M Main.hs
M Main.hs => Main.hs +60 -25
@@ 4,7 4,7 @@ import BasicPrelude hiding (show, read, forM_, mapM_, getArgs)
import Data.Char
import Control.Concurrent
import Control.Concurrent.STM
import Data.Foldable (forM_, mapM_)
import Data.Foldable (forM_, mapM_, toList)
import System.Environment (getArgs)
import Control.Error (readZ)
import Data.Time (addUTCTime, getCurrentTime)


@@ 191,20 191,21 @@ handleJoinPartRoom db toVitelity toComponent existingRoom from to tel payloads j
		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 (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db (T.unpack bareMUC <> "\0startup_tels"))
		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 ((/=resourceFrom).fst) falsePresence) -- Presence is no longer false
		presence <- fmap (map f . fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db ("presence\0" <> T.unpack bareMUC))
		print presence
		case presence of
			[] -> do -- No one in the room, so we "created"
				uuid <- fromMaybe "UUIDFAIL" <$> (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
				let fullid = if (null :: [String] -> Bool) startup then "CHEOGRAMCREATE%" <> uuid else uuid
				let fullid = if (resourceFrom `elem` map fst falsePresence) 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") [] []
				}
			(_:_) | not (resourceFrom `elem` presence) -> do
			(_:_) | not (resourceFrom `elem` (presence <> map (fst :: (Text, Text) -> Text) falsePresence)) -> do
				writeStanzaChan toVitelity $ mkSMS tel $ mconcat [
						fromString "* You have joined ", bareMUC,
						fromString " as ", resourceFrom,


@@ 212,13 213,14 @@ handleJoinPartRoom db toVitelity toComponent existingRoom from to tel payloads j
						intercalate (fromString ", ") (filter (/= resourceFrom) presence)
					]
				queryDisco toComponent room to
			_ -> return ()
			_ ->
				queryDisco toComponent room to
	| not join,
	  [x] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< payloads,
	  (_:_) <- code "303" =<< isNamed (fromString "{http://jabber.org/protocol/muc#user}status") =<< elementChildren x = do
		presence <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db ("presence\0" <> T.unpack bareMUC))
		mapM_ (\nick -> do
			True <- TC.runTCM (TC.put db ("presence\0" <> T.unpack bareMUC) (show $ sort $ nub $ (nick, Just $ bareTxt from) : filter ((/=resourceFrom).fst) presence))
			True <- TC.runTCM (TC.put db ("presence\0" <> T.unpack bareMUC) (show $ sort $ nubBy (equating fst) $ (nick, Just $ bareTxt from) : filter ((/=resourceFrom).fst) presence))
			writeStanzaChan toVitelity $ mkSMS tel $ mconcat [
					fromString "* ",
					resourceFrom,


@@ 388,6 390,35 @@ componentStanza _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Jus
					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
		-- Room exists and has people in it
		presence <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db ("presence\0" <> T.unpack (bareTxt from)))
		True <- TC.runTCM $ TC.put db ("presence\0" <> T.unpack (bareTxt from)) (show $ sort $ nubBy (equating fst) items)
		let falsePresence = mapMaybe (\(nick, jid) -> ((,)nick) <$> (T.stripSuffix (fromString $ "@" <> componentHost) =<< jid)) (presence \\ items)
		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
	room nick = parseJID $ bareTxt from <> fromString "/" <> nick
	items = map (\el -> (fromMaybe mempty $ attributeText (fromString "name") el, bareTxt <$> (parseJID =<< attributeText (fromString "jid") el))) $
		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
		-- 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 { iqType = IQError, iqFrom = Just from, iqTo = Just to }))
	| (strNode <$> jidNode to) == Just (fromString "create"),
	  Just resource <- strResource <$> jidResource to =


@@ 436,13 467,7 @@ componentStanza db _ toComponent componentHost (ReceivedIQ (IQ { iqType = IQResu
			isNamed (fromString "{http://jabber.org/protocol/disco#info}feature") =<< elementChildren query
		let muc_membersonly = fromEnum $ fromString "muc_membersonly" `elem` vars
		True <- TC.runTCM $ TC.put db (T.unpack (formatJID from) <> "\0muc_membersonly") muc_membersonly

		startup <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db (T.unpack (formatJID from) <> "\0startup_tels"))
		_ <- TC.runTCM $ TC.out db $ (T.unpack (formatJID from) <> "\0startup_tels")
		forM_ startup $ \tel -> do
			when (toEnum muc_membersonly) $ forM_ (telToJid tel (fromString componentHost)) $
				addMUCOwner toComponent from to
			joinRoom db toComponent componentHost tel from
		joinStartupTels db toComponent componentHost from to
componentStanza _ _ toComponent _ (ReceivedIQ (iq@IQ { iqType = typ }))
	| typ `elem` [IQGet, IQSet] =
		writeStanzaChan toComponent $ iq {


@@ 455,6 480,15 @@ componentStanza _ _ toComponent _ (ReceivedIQ (iq@IQ { iqType = typ }))
		}
componentStanza _ _ _ _ _ = return ()

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

participantJid (Presence { presencePayloads = payloads }) =
	listToMaybe $ mapMaybe (parseJID <=< attributeText (fromString "jid")) $
	isNamed (fromString "{http://jabber.org/protocol/muc#user}item") =<<


@@ 463,15 497,14 @@ participantJid (Presence { presencePayloads = payloads }) =

storePresence db (ReceivedPresence (Presence { presenceType = PresenceUnavailable, presenceFrom = Just from })) = do
	presence <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db ("presence\0" <> T.unpack (bareTxt from)))
	True <- TC.runTCM (TC.put db ("presence\0" <> T.unpack (bareTxt from)) (show $ sort $ nub $ filter ((/=resourceFrom).f) presence))
	True <- TC.runTCM (TC.put db ("presence\0" <> T.unpack (bareTxt from)) (show $ sort $ nubBy (equating f) $ filter ((/=resourceFrom).f) presence))
	return ()
	where
	f = fst :: (String, Maybe String) -> String
	resourceFrom = fromMaybe "" (T.unpack . strResource <$> jidResource from)
storePresence db (ReceivedPresence p@(Presence { presenceType = PresenceAvailable, presenceFrom = Just from })) = do
	print ("going to store", resourceFrom, participantJid p)
	presence <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db ("presence\0" <> T.unpack (bareTxt from)))
	True <- TC.runTCM (TC.put db ("presence\0" <> T.unpack (bareTxt from)) (show $ sort $ nub $ (resourceFrom, bareTxt <$> participantJid p):presence))
	True <- TC.runTCM (TC.put db ("presence\0" <> T.unpack (bareTxt from)) (show $ sort $ nubBy (equating fst) $ (resourceFrom, bareTxt <$> participantJid p):presence))
	return ()
	where
	resourceFrom = fromMaybe "" (T.unpack . strResource <$> jidResource from)


@@ 484,7 517,6 @@ component db toVitelity toComponent componentHost = do

	flip catchError (\e -> liftIO (print e >> killThread thread)) $ forever $ do
		s <- getStanza
		liftIO $ print s
		liftIO $ componentStanza db toVitelity toComponent componentHost s
		liftIO $ storePresence db s



@@ 798,15 830,18 @@ main = do
	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 "Rejoining " <> formatJID muc <> fromString "..."
		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)
		True <- TC.runTCM $ TC.out db pkey
		let tels = mapMaybe (T.stripSuffix (fromString $ "@" <> name)) presence
		case tels of
		case filter ((fromString $ "@" <> name) `T.isSuffixOf`) presence of
			[] -> return () -- wut?
			(x:xs) -> do
				True <- TC.runTCM (TC.put db (T.unpack (formatJID muc) <> "\0startup_tels") (show xs))
				joinRoom db toComponent name x muc
			(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") [] []
				}

	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