2 files changed, 71 insertions(+), 7 deletions(-)

M Router.hs
M gateway.hs

@@ 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 (),

@@ 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,