~singpolyma/cheogram

302641d689a25ef1afe029cda37382b99cbe1fb7 — Stephen Paul Weber 8 years ago 9a5533c
Create rooms as members-only
1 files changed, 63 insertions(+), 2 deletions(-)

M Main.hs
M Main.hs => Main.hs +63 -2
@@ 63,6 63,21 @@ queryDisco toComponent to from = do
		iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#info}query") [] []
	}

fillFormField var value form = form {
		elementNodes = map (\node ->
			case node of
				NodeElement el
					| elementName el == fromString "{jabber:x:data}field" &&
					  (attributeText (fromString "{jabber:x:data}var") el == Just var ||
					  attributeText (fromString "var") el == Just var) ->
						NodeElement $ el { elementNodes = [
							NodeElement $ Element (fromString "{jabber:x:data}value") []
								[NodeContent $ ContentText $ value]
						]}
				x -> x
		) (elementNodes form)
	}

data Invite = Invite {
	inviteMUC :: JID,
	inviteFrom :: JID,


@@ 220,9 235,30 @@ componentStanza db toVitelity toComponent _ (ReceivedPresence p@(Presence { pres
			True <- TC.runTCM $ TC.out db $ tcKey tel "invited"
			return ()
		tcPutJID db tel "joined" from
		writeStanzaChan toVitelity $ mkSMS tel (mconcat [fromString "* You have joined ", bareMUC, fromString " as ", roomNick])
		queryDisco toComponent (fromMaybe (error "bareMUC not actually a JID") $ parseJID bareMUC) to

		creating <- tcGetJID db tel "creating"
		True <- 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

		case code201 of
			(_:_) -> do
				uuid <- (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
				writeStanzaChan toComponent $ (emptyIQ IQGet) {
					iqTo = Just room,
					iqFrom = Just to,
					iqID = uuid,
					iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/muc#owner}query") [] []
				}
			_ -> do
				writeStanzaChan toVitelity $ mkSMS tel (mconcat [fromString "* You have joined ", bareMUC, fromString " as ", roomNick])
				queryDisco toComponent room to
	where
	Just room = parseJID bareMUC
	bareMUC = bareTxt from
	roomNick = fromMaybe mempty (strResource <$> jidResource from)
componentStanza db toVitelity _ _ (ReceivedPresence p@(Presence { presenceType = PresenceUnavailable, presenceFrom = Just from, presenceTo = Just to }))


@@ 322,6 358,7 @@ 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


@@ 332,6 369,30 @@ componentStanza db _ toComponent componentHost (ReceivedIQ (IQ { iqType = IQResu
			(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 }))
	| Just tel <- strNode <$> jidNode to = do
		print iq
		writeStanzaChan toVitelity $ mkSMS tel (fromString "Error while querying or configuring " <> formatJID from)
componentStanza _ toVitelity toComponent _ (ReceivedIQ (IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, iqID = Just id }))
	| Just tel <- strNode <$> jidNode to,
	  (fromString "CHEOGRAMCREATE%") `T.isPrefixOf` id = do
		writeStanzaChan toVitelity $ mkSMS tel (mconcat [fromString "* You have created ", bareTxt from])
		queryDisco toComponent from to
componentStanza _ _ toComponent componentHost (ReceivedIQ (IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, 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
		writeStanzaChan toComponent $ (emptyIQ IQSet) {
			iqTo = Just from,
			iqFrom = Just to,
			iqID = Just $ fromString ("CHEOGRAMCREATE%" <> fromMaybe "UUIDFAIL" uuid),
			iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/muc#owner}query") [] [
				NodeElement $
				fillFormField (fromString "muc#roomconfig_publicroom") (fromString "0") $
				fillFormField (fromString "muc#roomconfig_membersonly") (fromString "1")
				form { elementAttributes = [(fromString "{jabber:x:data}type", [ContentText $ fromString "submit"])] }
			]
		}
componentStanza db _ toComponent _ (ReceivedIQ (IQ { iqType = IQResult, iqFrom = Just from, iqPayload = Just p }))
	| [query] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do
		let vars = mapMaybe (attributeText (fromString "var")) $