~singpolyma/cheogram-smtp

7021b245c810f61f4b4abb5ef5f936e5712b7599 — Stephen Paul Weber 6 months ago 91b56cb master
jabber:iq:gateway working against my local Gajim
2 files changed, 71 insertions(+), 7 deletions(-)

M Router.hs
M gateway.hs
M Router.hs => Router.hs +12 -0
@@ 18,6 18,13 @@ runRoutedComponent server secret =
runRouted :: Routes -> XMPP.XMPP ()
runRouted routes = forever $ XMPP.getStanza >>= (void . forkXMPP . handle)
	where
	handle (XMPP.ReceivedPresence presence@XMPP.Presence {
		XMPP.presenceType = XMPP.PresenceProbe
	}) = presenceProbeRoute routes presence
	handle (XMPP.ReceivedPresence presence@XMPP.Presence {
		XMPP.presenceType = XMPP.PresenceSubscribe
	}) = presenceSubscribeRoute routes presence

	handle (XMPP.ReceivedIQ iq@XMPP.IQ { XMPP.iqType = XMPP.IQGet }) =
		iqGetRoute routes iq
	handle (XMPP.ReceivedIQ iq@XMPP.IQ { XMPP.iqType = XMPP.IQSet }) =


@@ 26,6 33,7 @@ runRouted routes = forever $ XMPP.getStanza >>= (void . forkXMPP . handle)
		iqResultRoute routes iq
	handle (XMPP.ReceivedIQ iq@XMPP.IQ { XMPP.iqType = XMPP.IQError }) =
		iqErrorRoute routes iq

	handle (XMPP.ReceivedMessage message@XMPP.Message {
		XMPP.messageType = XMPP.MessageNormal
	}) = messageNormalRoute routes message


@@ 41,6 49,8 @@ runRouted routes = forever $ XMPP.getStanza >>= (void . forkXMPP . handle)
	handle _ = return ()

data Routes = Routes {
	presenceProbeRoute :: XMPP.Presence -> XMPP.XMPP (),
	presenceSubscribeRoute :: XMPP.Presence -> XMPP.XMPP (),
	iqGetRoute :: XMPP.IQ -> XMPP.XMPP (),
	iqSetRoute :: XMPP.IQ -> XMPP.XMPP (),
	iqResultRoute :: XMPP.IQ -> XMPP.XMPP (),


@@ 53,6 63,8 @@ data Routes = Routes {

defaultRoutes :: Routes
defaultRoutes = Routes {
	presenceProbeRoute = const $ return (),
	presenceSubscribeRoute = const $ return (),
	iqGetRoute = XMPP.putStanza . iqError notImplemented,
	iqSetRoute = XMPP.putStanza . iqError notImplemented,
	iqResultRoute = const $ return (),

M gateway.hs => gateway.hs +59 -7
@@ 71,6 71,23 @@ iqSetHandler replyMap componentJid trustedJids iq@XMPP.IQ {
				Focus.lookupAndDelete (Just sid) replyMap
			forM_ lookupIQ $ \originalIQ ->
				XMPP.putStanza $ iqReply Nothing originalIQ
iqSetHandler _ componentJid _ iq@XMPP.IQ {
		XMPP.iqTo = Just XMPP.JID { XMPP.jidNode = Nothing },
		XMPP.iqPayload = Just payload
	} | [prompt] <- fmap (mconcat . XML.elementText) $
	    XML.isNamed (s"{jabber:iq:gateway}prompt") =<<
	    XML.elementChildren =<<
	    XML.isNamed (s"{jabber:iq:gateway}query") payload =
		-- TODO: Check if prompt is a valid email address
		XMPP.putStanza $ flip iqReply iq $ Just $ XML.Element
			(s"{jabber:iq:gateway}query") [] [
				XML.NodeElement $ mkElement
				(s"{jabber:iq:gateway}jid") $
					XMPP.formatJID $ componentJid {
						XMPP.jidNode = Just $ XMPP.Node$
						               escapeJid prompt
					}
			]
iqSetHandler _ _ _ iq = XMPP.putStanza $ iqError notImplemented iq

addVCardData :: VCard -> MIME.MIMEMessage -> MIME.MIMEMessage


@@ 143,13 160,18 @@ iqGetHandler iq@XMPP.IQ {
				(s"gateway") (s"smtp") (s"Cheogram SMTP")
		]
	) iq
	where
	nodeAttribute = fmap (\node -> (s"node", [XML.ContentText node])) $
		XML.attributeText (s"node") p
iqGetHandler iq@XMPP.IQ {
	XMPP.iqTo = Just to,
	XMPP.iqPayload = Just p
} | Nothing <- XMPP.jidNode to,
  | Nothing <- XMPP.jidNode to,
    [_] <- XML.isNamed (s"{jabber:iq:gateway}query") p =
	XMPP.putStanza $ flip iqReply iq $ Just $ XML.Element
		(s"{jabber:iq:gateway}query") [] [
			XML.NodeElement $ mkElement
				(s"{jabber:iq:gateway}prompt")
				(s"Email address"),
			XML.NodeElement $ mkElement
				(s"{jabber:iq:gateway}desc")
				(s"Please enter your contact's email address.")
		]
  | Nothing <- XMPP.jidNode to,
    [_] <- XML.isNamed (s"{vcard-temp}vCard") p =
	XMPP.putStanza $ flip iqReply iq $ Just $ XML.Element
		(s"{vcard-temp}vCard") [] [


@@ 162,8 184,36 @@ iqGetHandler iq@XMPP.IQ {
				\the listed homepage.\n\n\
				\Part of the Soprani.ca project.")
		]
	where
	nodeAttribute = fmap (\node -> (s"node", [XML.ContentText node])) $
		XML.attributeText (s"node") p
iqGetHandler iq = XMPP.putStanza $ iqError notImplemented iq

presenceProbeHandler :: XMPP.Presence -> XMPP.XMPP ()
presenceProbeHandler XMPP.Presence {
	XMPP.presenceFrom = Just from,
	XMPP.presenceTo = Just to@XMPP.JID { XMPP.jidNode = Nothing }
} = XMPP.putStanza $ (XMPP.emptyPresence XMPP.PresenceAvailable) {
		XMPP.presenceTo = Just from,
		XMPP.presenceFrom = Just to
	}
presenceProbeHandler _ = return ()

presenceSubscribeHandler :: XMPP.Presence -> XMPP.XMPP ()
presenceSubscribeHandler XMPP.Presence {
	XMPP.presenceFrom = Just from,
	XMPP.presenceTo = Just to@XMPP.JID { XMPP.jidNode = Nothing }
} = do
	XMPP.putStanza $ (XMPP.emptyPresence XMPP.PresenceSubscribed) {
			XMPP.presenceTo = Just from,
			XMPP.presenceFrom = Just to
		}
	XMPP.putStanza $ (XMPP.emptyPresence XMPP.PresenceAvailable) {
			XMPP.presenceTo = Just from,
			XMPP.presenceFrom = Just to
		}
presenceSubscribeHandler _ = return ()

main :: IO ()
main = do
	hSetBuffering stdout LineBuffering


@@ 183,6 233,8 @@ main = do
	exceptT print return $ runRoutedComponent server secret $ do
		(sendIQ, iqReceived) <- iqManager
		return $ defaultRoutes {
			presenceProbeRoute = presenceProbeHandler,
			presenceSubscribeRoute = presenceSubscribeHandler,
			iqGetRoute = iqGetHandler,
			iqSetRoute =
				iqSetHandler replyMap componentJid trustedJids,