~singpolyma/cheogram

cf5c378256a59ba3b7c722a18279989281e276e5 — Stephen Paul Weber 8 years ago 1050a41
Respond to all IQ with an error
1 files changed, 14 insertions(+), 4 deletions(-)

M Main.hs
M Main.hs => Main.hs +14 -4
@@ 72,14 72,14 @@ componentMessage _ toVitelity _ _ existingRoom bareFrom resourceFrom tel body =
		| fmap bareTxt existingRoom == Just bareFrom = fromMaybe (fromString "nonick") resourceFrom
		| otherwise = bareFrom

componentStanza db toVitelity (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from}))
componentStanza db toVitelity _ (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from}))
	| Just tel <- strNode <$> jidNode to,
	  Just body <- getBody "jabber:component:accept" m = do
		existingRoom <- (parseJID . fromString =<<) <$> TC.runTCM (TC.get db $ T.unpack tel)
		componentMessage db toVitelity (messageType m) (fromMaybe mempty $ messageID m) existingRoom (bareTxt from) resourceFrom tel body
	where
	resourceFrom = strResource <$> jidResource from
componentStanza db toVitelity (ReceivedPresence p@(Presence { presenceFrom = Just from, presenceTo = Just to }))
componentStanza db toVitelity _ (ReceivedPresence p@(Presence { presenceFrom = Just from, presenceTo = Just to }))
	| Just tel <- strNode <$> jidNode to,
	  [x] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< presencePayloads p,
	  [status] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}status") =<< elementChildren x,


@@ 94,7 94,17 @@ componentStanza db toVitelity (ReceivedPresence p@(Presence { presenceFrom = Jus
	where
	bareMUC = bareTxt from
	roomNick = fromMaybe mempty (strResource <$> jidResource from)
componentStanza _ _ _ = return ()
componentStanza _ _ toComponent (ReceivedIQ (IQ { iqType = typ, iqFrom = Just from, iqTo = to, iqID = id }))
	| typ `elem` [IQGet, IQSet] =
		writeStanzaChan toComponent $ (emptyIQ IQError) {
			iqTo = Just from,
			iqFrom = to,
			iqID = id,
			iqPayload = Just $ Element (fromString "{jabber:component:accept}error")
				[(fromString "{jabber:component:accept}type", [ContentText $ fromString "cancel"])]
				[NodeElement $ Element (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}feature-not-implemented") [] []]
		}
componentStanza _ _ _ _ = return ()

component db toVitelity toComponent = do
	forkXMPP $ forever $ flip catchError (const $ return ()) $ do


@@ 104,7 114,7 @@ component db toVitelity toComponent = do
	--forever $ getStanza >>= liftIO . componentStanza db toVitelity
	forever $ flip catchError (const $ return ()) $ do
		s <- getStanza
		liftIO $ componentStanza db toVitelity s
		liftIO $ componentStanza db toVitelity toComponent s

data Command = Join JID | Send Text
	deriving (Show, Eq)