~singpolyma/jabber-iq-gateway-web

ref: d8c4fc36e6bd0f95e384de517ad8362d9f373828 jabber-iq-gateway-web/jabber-iq-gateway-web.hs -rw-r--r-- 4.8 KiB
d8c4fc36Stephen Paul Weber Allow passing server when needed a month ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
module Main (main) where

import Prelude ()
import BasicPrelude
import Network                            (PortID (PortNumber))
import qualified Control.Concurrent.STM   as STM
import qualified Data.XML.Types           as XML
import qualified Network.HTTP.Types       as HTTP
import qualified Network.Protocol.XMPP    as XMPP
import qualified Network.URI              as URI
import qualified Network.Wai              as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Parse        as Wai
import qualified Network.Wai.Util         as Wai
import qualified UnexceptionalIO.Trans    as UIO

import IQManager
import Router
import Util

runClient :: XMPP.Server -> XMPP.JID -> Text -> XMPP.XMPP a -> IO (Either XMPP.Error a)
runClient server jid =
	XMPP.runClient server jid jidStrNode
	where
	Just jidStrNode = XMPP.strNode <$> XMPP.jidNode jid

webPost :: (XMPP.IQ -> IO (Maybe XMPP.IQ)) -> XMPP.JID -> Wai.Application
webPost sendIQ toJid req = (>>=) $ do
	(params, _) <- Wai.parseRequestBodyEx
		Wai.defaultParseRequestBodyOptions Wai.noStoreFileUploads req
	let prompt = fromMaybe mempty $ Wai.queryLookup "prompt" params
	result <- sendIQ $ (XMPP.emptyIQ XMPP.IQSet) {
			XMPP.iqTo = Just toJid,
			XMPP.iqPayload = Just $ XML.Element
				(s"{jabber:iq:gateway}query") [] [
					XML.NodeElement $ mkElement
						(s"{jabber:iq:gateway}prompt")
						prompt
				]
		}
	case result of
		Just iq |
			Just query <- child (s"{jabber:iq:gateway}query") iq,
			[jid] <- fmap (mconcat . XML.elementText) $
			         XML.isNamed (s"{jabber:iq:gateway}jid") =<<
			         XML.elementChildren query ->
				Wai.redirect' HTTP.status303 [] (xmppURI jid)
		_ -> Wai.string HTTP.status400 []
		     "No jabber:iq:gateway available."

xmppURI :: Text -> URI.URI
xmppURI jid = (URI.URI "xmpp:" Nothing (textToString jid) "" "")

css :: Text
css = s"<style>body { font-family: sans-serif; }</style>"

webGetPrompt :: (XMPP.IQ -> IO (Maybe XMPP.IQ)) -> XMPP.JID -> IO Wai.Response
webGetPrompt sendIQ toJid = do
	result <- sendIQ $ (XMPP.emptyIQ XMPP.IQGet) {
			XMPP.iqTo = Just toJid,
			XMPP.iqPayload = Just $
				XML.Element (s"{jabber:iq:gateway}query") [] []
		}
	case result of
		Just iq |
			Just query <- child (s"{jabber:iq:gateway}query") iq,
			[desc] <- fmap (mconcat . XML.elementText) $
			          XML.isNamed (s"{jabber:iq:gateway}desc") =<<
			          XML.elementChildren query,
			[prompt] <- fmap (mconcat . XML.elementText) $
			            XML.isNamed (s"{jabber:iq:gateway}prompt")
			            =<< XML.elementChildren query ->
				Wai.text HTTP.status200 (Wai.stringHeaders' [
					("Content-Type",
					"text/html; charset=utf-8")
				]) $ css ++ s"<form method=\"post\" action=\"\">\
				\<p>" ++ escapeXML desc ++ s"</p>\
				\<input type=\"text\" name=\"prompt\" \
				\placeholder=\"" ++ escapeXML prompt ++ s"\" />\
				\ <button type=\"submit\">Add Contact</button>\
				\</form>"
		_ -> Wai.string HTTP.status400 []
		     "No jabber:iq:gateway available."

web :: (XMPP.IQ -> IO (Maybe XMPP.IQ)) -> Wai.Application
web sendIQ req
	| method == HTTP.methodPost, Just toJid <- to =
		webPost sendIQ toJid req
	| method == HTTP.methodGet, Just toJid <- to =
		(>>=) $ webGetPrompt sendIQ toJid
	| otherwise = (>>=) $
		Wai.text HTTP.status200
		(Wai.stringHeaders' [
			("Content-Type", "text/html; charset=utf-8")
		])
		(css ++ s"<form method=\"get\" action=\"\">\
		\<input type=\"text\" name=\"to\"\
			\placeholder=\"JabberID to query\" />\
		\ <button type=\"submit\">Begin</button>\
		\</form>")

	where
	method = Wai.requestMethod req
	to = XMPP.parseJID =<< Wai.queryLookup "to" (Wai.queryString req)

main :: IO ()
main = do
	rpcJidStr:rpcPassword:rest <- getArgs

	-- This is right unless there is an SRV record, which we don't check for
	let Just rpcJid = XMPP.parseJID rpcJidStr
	let jidStrDomain = XMPP.strDomain $ XMPP.jidDomain rpcJid
	let Just domainJid = XMPP.parseJID jidStrDomain
	let domainStr = textToString jidStrDomain

	let server = case (fmap textToString rest, map XMPP.parseJID rest) of
		([serverStr], [Just serverJid]) -> XMPP.Server serverJid serverStr (PortNumber 5222)
		_ -> XMPP.Server domainJid domainStr (PortNumber 5222)

	sendIQChan <- atomicUIO STM.newTChan

	void $ UIO.fork $ do
		fmap (either (error . show) (const ())) $ fromIO_ $ runClient server rpcJid rpcPassword $ do
			void $ XMPP.bindJID rpcJid
			(sendIQ, iqReceived) <- iqManager
			void $ forkXMPP $ runRouted $ defaultRoutes {
					iqResultRoute = iqReceived,
					iqErrorRoute = iqReceived
				}
			forever $ do
				(iq, rvar) <- atomicUIO $
					STM.readTChan sendIQChan
				result <- sendIQ iq
				atomicUIO $ STM.putTMVar rvar result
		return ()

	Warp.runEnv 3000 $ web $ \iq -> do
		rvar <- atomicUIO STM.newEmptyTMVar
		atomicUIO $ STM.writeTChan sendIQChan (iq, rvar)
		atomicUIO $ join $ STM.takeTMVar rvar