~singpolyma/cheogram

80a768af003fa66e7c303873d9d89c995e51cba0 — Stephen Paul Weber 6 years ago 5cc1cc9
First try

But sending presence when already in does not get us full list
1 files changed, 85 insertions(+), 49 deletions(-)

M Main.hs
M Main.hs => Main.hs +85 -49
@@ 191,31 191,34 @@ 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))

		creating <- tcGetJID db tel "creating"
		void $ TC.runTCM $ TC.out db $ tcKey tel "creating"
		let code201 = if fmap bareTxt creating == Just bareMUC then
				-- Hack for servers that don't support reserved rooms
				-- If we planned to create it, assume we did
				[undefined]
			else
				code "201" status

		presence <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db (T.unpack bareMUC <> "\0presence"))
		when (null code201 && not (resourceFrom `elem` presence)) $
			writeStanzaChan toVitelity $ mkSMS tel (mconcat [
				fromString "* You have joined ", bareMUC,
				fromString " as ", resourceFrom,
				fromString " along with\n",
				intercalate (fromString ", ") (filter (/= resourceFrom) presence)
			])

		queryDisco toComponent room to
		startup <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db (T.unpack bareMUC <> "\0startup_tels"))
		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
				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
				writeStanzaChan toVitelity $ mkSMS tel $ mconcat [
						fromString "* You have joined ", bareMUC,
						fromString " as ", resourceFrom,
						fromString " along with\n",
						intercalate (fromString ", ") (filter (/= resourceFrom) presence)
					]
				queryDisco toComponent room to
			_ -> return ()
	| 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 (T.unpack bareMUC <> "\0presence"))
		presence <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db ("presence\0" <> T.unpack bareMUC))
		mapM_ (\nick -> do
			True <- TC.runTCM (TC.put db (T.unpack bareMUC <> "\0presence") (show $ sort $ nub $ nick : filter (/=resourceFrom) presence))
			True <- TC.runTCM (TC.put db ("presence\0" <> T.unpack bareMUC) (show $ sort $ nub $ (nick, Just $ formatJID from) : filter ((/=resourceFrom).fst) presence))
			writeStanzaChan toVitelity $ mkSMS tel $ mconcat [
					fromString "* ",
					resourceFrom,


@@ 229,7 232,7 @@ handleJoinPartRoom db toVitelity toComponent existingRoom from to tel payloads j
		True <- TC.runTCM $ TC.out db $ tcKey tel "joined"
		writeStanzaChan toVitelity $ mkSMS tel (fromString "* You have left " <> bareMUC)
	| fmap bareTxt existingRoom == Just bareMUC = do
		presence <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db (T.unpack bareMUC <> "\0presence"))
		presence <- fmap (map f . fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db ("presence\0" <> T.unpack bareMUC))
		when (mod $ resourceFrom `elem` presence) $
			writeStanzaChan toVitelity $ mkSMS tel $ mconcat [
				fromString "* ",


@@ 244,6 247,7 @@ handleJoinPartRoom db toVitelity toComponent existingRoom from to tel payloads j
	mod = if join then not else id
	Just room = parseJID bareMUC
	bareMUC = bareTxt from
	f = fst :: (Text, Maybe Text) -> Text

componentStanza _ _ toComponent _ (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from}))
	| [x] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< messagePayloads m,


@@ 391,7 395,6 @@ componentStanza db _ toComponent componentHost (ReceivedIQ (IQ { iqType = IQErro
			(tel:_) -> do
				nick <- maybe tel fromString <$> TC.runTCM (TC.get db $ tcKey tel "nick")
				let Just room = parseJID $ bareTxt from <> fromString "/" <> nick
				tcPutJID db tel "creating" room
				leaveRoom db toComponent componentHost tel "Joined a different room."
				joinRoom db toComponent componentHost tel room
			_ -> return () -- Invalid packet, ignore


@@ 411,14 414,15 @@ componentStanza _ toVitelity toComponent _ (ReceivedIQ (IQ { iqType = IQResult, 
	  fromString "CHEOGRAMCREATE%" `T.isPrefixOf` id = do
		writeStanzaChan toVitelity $ mkSMS tel (mconcat [fromString "* You have created ", bareTxt from])
		queryDisco toComponent from to
componentStanza _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, 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
		uuid <- (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
		uuid <- fromMaybe "UUIDFAIL" <$> (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
		let fullid = if fromString "CHEOGRAMCREATE%" `T.isPrefixOf` id then "CHEOGRAMCREATE%" <> uuid else uuid
		writeStanzaChan toComponent $ (emptyIQ IQSet) {
			iqTo = Just from,
			iqFrom = Just to,
			iqID = Just $ fromString ("CHEOGRAMCREATE%" <> fromMaybe "UUIDFAIL" uuid),
			iqID = Just $ fromString fullid,
			iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/muc#owner}query") [] [
				NodeElement $
				fillFormField (fromString "muc#roomconfig_publicroom") (fromString "0") $


@@ 426,13 430,19 @@ componentStanza _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQResult, iqFrom = 
				form { elementAttributes = [(fromString "{jabber:x:data}type", [ContentText $ fromString "submit"])] }
			]
		}
componentStanza db _ _ _ (ReceivedIQ (IQ { iqType = IQResult, iqFrom = Just from, iqPayload = Just p }))
componentStanza db _ toComponent componentHost (ReceivedIQ (IQ { iqType = IQResult, iqTo = Just to, iqFrom = Just from, iqPayload = Just p }))
	| [query] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do
		let vars = mapMaybe (attributeText (fromString "var")) $
			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
		return ()

		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
componentStanza _ _ toComponent _ (ReceivedIQ (iq@IQ { iqType = typ }))
	| typ `elem` [IQGet, IQSet] =
		writeStanzaChan toComponent $ iq {


@@ 445,16 455,23 @@ componentStanza _ _ toComponent _ (ReceivedIQ (iq@IQ { iqType = typ }))
		}
componentStanza _ _ _ _ _ = return ()

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

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


@@ 467,6 484,7 @@ 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



@@ 562,6 580,21 @@ joinRoom db toComponent componentHost tel room = do
		] <> pwEl)]
	}

addMUCOwner toComponent room from jid = do
	uuid <- (fmap.fmap) UUID.toString UUID.nextUUID
	writeStanzaChan toComponent $ (emptyIQ IQSet) {
		iqTo = Just room,
		iqFrom = Just from,
		iqID = fmap fromString uuid,
		iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/muc#admin}admin") [] [
			NodeElement $ Element (fromString "{http://jabber.org/protocol/muc#admin}item")
				[
					(fromString "{http://jabber.org/protocol/muc#admin}affiliation", [ContentText $ fromString "owner"]),
					(fromString "{http://jabber.org/protocol/muc#admin}jid", [ContentText $ formatJID jid])
				] []
		]
	}

createRoom :: TChan StanzaRec -> String -> [String] -> String -> String -> IO Bool
createRoom toComponent componentHost (server:otherServers) tel name =
	-- First we check if this room exists on the server already


@@ 603,14 636,15 @@ processSMS db toVitelity toComponent componentHost conferenceServers tel txt = d
				(find (mucShortMatch tel (strDomain $ jidDomain room)) bookmarks)
		Just Leave -> leaveRoom db toComponent componentHost tel "Typed /leave"
		Just Who -> do
			let f = fst :: (String, Maybe String) -> String
			let snick = T.unpack nick
			let room = maybe "" (T.unpack . bareTxt) existingRoom
			presence <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db (room <> "\0presence"))
			presence <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db ("presence\0" <> room))
			writeStanzaChan toVitelity $ mkSMS tel $ fromString $ mconcat [
					"You are joined to ", room,
					" as ", snick,
					" along with\n",
					intercalate ", " (filter (/= snick) presence)
					intercalate ", " (filter (/= snick) $ map f presence)
				]
		Just List -> do
			bookmarks <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db (tcKey tel "bookmarks"))


@@ 618,21 652,9 @@ processSMS db toVitelity toComponent componentHost conferenceServers tel txt = d
		Just (InviteCmd jid)
			| Just room <- existingRoom -> do
				membersonly <- maybe False toEnum <$> TC.runTCM (TC.get db (T.unpack (bareTxt room) <> "\0muc_membersonly"))
				when membersonly $ do
				when membersonly $ forM_ (telToJid tel (fromString componentHost)) $ \from ->
					-- Try to add everyone we invite as an owner also
					uuid <- (fmap.fmap) UUID.toString UUID.nextUUID
					writeStanzaChan toComponent $ (emptyIQ IQSet) {
						iqTo = Just room,
						iqFrom = telToJid tel (fromString componentHost),
						iqID = fmap fromString uuid,
						iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/muc#admin}admin") [] [
							NodeElement $ Element (fromString "{http://jabber.org/protocol/muc#admin}item")
								[
									(fromString "{http://jabber.org/protocol/muc#admin}affiliation", [ContentText $ fromString "owner"]),
									(fromString "{http://jabber.org/protocol/muc#admin}jid", [ContentText $ formatJID jid])
								] []
						]
					}
					addMUCOwner toComponent room from jid

				writeStanzaChan toComponent $ (emptyMessage MessageNormal) {
					messageTo = Just room,


@@ 761,6 783,7 @@ openTokyoCabinet pth = TC.runTCM $ do
	return db

main = do
	putStrLn $ fromString "Starting..."
	(name:host:port:secret:vitelityJid:vitelityPassword:conferences) <- getArgs
	db <- openTokyoCabinet "./db.tcdb" :: IO TC.HDB
	chunks <- atomically newTChan


@@ 772,6 795,19 @@ main = do

	void $ forkIO $ forever $ print =<< runComponent (Server (fromString name) host (PortNumber $ fromIntegral (read port :: Int))) (fromString secret) (component db toVitelity toComponent name)

	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 "..."
		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
			[] -> 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

	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
		void $ bindJID vitelityParsedJid