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