~singpolyma/cheogram

19d8750ce84b9961189b55f650c3de6f7c1b39b9 — Stephen Paul Weber 9 years ago eacee55
Support direct invitation in
1 files changed, 16 insertions(+), 3 deletions(-)

M Main.hs
M Main.hs => Main.hs +16 -3
@@ 43,8 43,9 @@ data Invite = Invite {
	invitePassword :: Maybe Text
} deriving (Show)

getMediatedInvitation (Message {messageFrom = Just from, messagePayloads = payload}) = do
	x <- listToMaybe $ isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< payload
getMediatedInvitation m = do
	from <- messageFrom m
	x <- listToMaybe $ isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< messagePayloads m
	invite <- listToMaybe $ isNamed (fromString "{http://jabber.org/protocol/muc#user}invite") =<< elementChildren x
	inviteFrom <- parseJID =<< attributeText (fromString "from") invite
	return $ Invite {


@@ 60,6 61,18 @@ getMediatedInvitation (Message {messageFrom = Just from, messagePayloads = paylo
			(isNamed (fromString "{http://jabber.org/protocol/muc#user}password") =<< elementChildren x)
	}

getDirectInvitation m = do
	x <- listToMaybe $ isNamed (fromString "{jabber:x:conference}x") =<< messagePayloads m
	Invite <$>
		(parseJID =<< attributeText (fromString "jid") x) <*>
		messageFrom m <*>
		Just (do
			txt <- attributeText (fromString "reason") x
			guard (not $ T.null txt)
			return txt
		) <*>
		Just (attributeText (fromString "password") x)

forkXMPP :: XMPP () -> XMPP ThreadId
forkXMPP kid = do
	session <- getSession


@@ 98,7 111,7 @@ componentMessage _ toVitelity _ _ existingRoom bareFrom resourceFrom tel body =

componentStanza db toVitelity _ (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from}))
	| Just tel <- strNode <$> jidNode to,
	  Just invite <- getMediatedInvitation m = do
	  Just invite <- getMediatedInvitation m <|> getDirectInvitation m = do
		let txt = mconcat [
				fromString "* ",
				bareTxt (inviteFrom invite), -- TODO: or MUC nick