~psycotica0/sgx-dummy

ref: fcab5a58e2a8d9cbf37e79c3061892c316c6182a sgx-dummy/gateway.lhs -rw-r--r-- 13.1 KiB
fcab5a58Christopher Vollick Added Command Without Action 1 year, 4 months 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
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
Only exporting the main function allows GHC to do more optimisations inside, and lets -Wall warn you about unused code more effectively.

> module Main (main) where

Switch to BasicPrelude because it's nice.

> import Prelude ()
> import BasicPrelude hiding (log, forM_)

Import all the things!

> import Control.Concurrent
> import Network (PortID(PortNumber))
> import System.IO (stdout, stderr, hSetBuffering, BufferMode(LineBuffering))
> import ReadArgs (readArgs)
> import qualified Control.Exception as Ex
> import qualified Data.ByteString.Lazy as LBS
> import qualified Data.XML.Types as XML
> import qualified Text.XML.Unresolved as XML
> import qualified Data.Text.Lazy as TL
> import qualified Network.Protocol.XMPP as XMPP
> import qualified Network.Protocol.XMPP.Internal as XMPP

This is where our program starts.  When this IO action completes, the program terminates.

> main :: IO ()
> main = do

Force line buffering for our log output, even when redirected to a file.

> 	hSetBuffering stdout LineBuffering
> 	hSetBuffering stderr LineBuffering

First, we need to get our settings from the command line arguments.

> 	(componentJidText, serverHost, serverPort, componentSecret) <- readArgs
> 	let Just componentJid = XMPP.parseJID componentJidText

Now we connect up the component so that stanzas will be routed to us by the server.
Log any result on termination, successful or not.

> 	print =<< XMPP.runComponent
> 		(XMPP.Server componentJid serverHost (PortNumber serverPort))
> 		componentSecret
> 		component

This is where we handle talking to the XMPP server as an external component.  After the connection is created above, it delegates control of that connection here.

> component :: XMPP.XMPP ()
> component = do

Spawn a background thread to handle input from STDIN, looping forever.

>	void $ forkXMPP $ forever $ do

For each line from STDIN, parse as XML and push the resulting element to the XMPP stream.

If you enter invalid XML or something that is not an XMPP stanza you will have a bad time.

>		line <- TL.fromStrict <$> getLine
>		let el = XML.documentRoot $ XML.parseText_ XML.def line
>		XMPP.putStanza $ RawComponentStanza el

And now for inbound stanzas from the XMPP server.

> 	forever $ do
> 		stanza <- XMPP.getStanza

Once we get a stanza from the server, print it to STDOUT.

> 		liftIO $ LBS.putStr $
> 			XML.renderLBS renderSettings $
> 			elementToDocument $ receivedStanzaToElement stanza

We want registrations from cheogram to work properly, so check if that's what this is.

>		handleRegister stanza

> handleRegister :: XMPP.ReceivedStanza -> XMPP.XMPP ()

Is this a request for the registration form?

> handleRegister (XMPP.ReceivedIQ iq@XMPP.IQ {
> 	XMPP.iqType = XMPP.IQGet,
> 	XMPP.iqTo = Just XMPP.JID { XMPP.jidNode = Nothing },
> 	XMPP.iqPayload = Just p
> })
> 	| [_] <- XML.isNamed (s"{jabber:iq:register}query") p =
>		XMPP.putStanza $ iqReply iq $ Just $
>			XML.Element (s"{jabber:iq:register}query") [] [
>				XML.NodeElement $

Tell cheogram the user is already registered so it will continue.

>				XML.Element (s"{jabber:iq:register}registered") [] [],

And tell the user they're done so they can close their window.

>				XML.NodeElement $
>				XML.Element (s"{jabber:iq:register}instructions") [] [
>					XML.NodeContent $
>						XML.ContentText $ s"Done"
>				]
>			]

Command List

> handleRegister (XMPP.ReceivedIQ iq@XMPP.IQ {
> 	XMPP.iqType = XMPP.IQGet,
> 	XMPP.iqTo = Just XMPP.JID { XMPP.jidNode = Nothing },
> 	XMPP.iqPayload = Just p
> })
> 	| [_] <- XML.isNamed (s"{http://jabber.org/protocol/disco#items}query") =<< XML.hasAttributeText (s"node") (s"http://jabber.org/protocol/commands" ==) p,
> 	  Just to <- XMPP.iqTo iq
> 		= XMPP.putStanza $ iqReply iq $ Just $
> 			XML.Element (s"{http://jabber.org/protocol/disco#items}query") [(s"node", [s"http://jabber.org/protocol/commands"])] [
> 				XML.NodeElement $ XML.Element (s"item") [
> 					(s"jid", [XML.ContentText $ XMPP.formatJID to]),
> 					(s"node", [s"config"]),
> 					(s"name", [s"Test Form"])
> 				] []
> 			]

Command Final Page

> handleRegister (XMPP.ReceivedIQ iq@XMPP.IQ {
> 	XMPP.iqType = XMPP.IQSet,
> 	XMPP.iqTo = Just XMPP.JID { XMPP.jidNode = Nothing },
> 	XMPP.iqPayload = Just p
> })
> 	| [command] <- XML.isNamed (s"{http://jabber.org/protocol/commands}command") =<< XML.hasAttributeText (s"node") (s"config" ==) =<< XML.hasAttributeText (s"action") (s"execute" ==) p,
> 	  [_] <- XML.hasAttributeText (s"var") (s"runlevel" ==) =<< XML.isNamed(s"{jabber:x:data}field") =<< XML.elementChildren =<< XML.isNamed(s"{jabber:x:data}x") =<< XML.elementChildren command
> 		= XMPP.putStanza $ iqReply iq $ Just $ XML.documentRoot page3

And the same if they use "complete" instead of "execute"

> handleRegister (XMPP.ReceivedIQ iq@XMPP.IQ {
> 	XMPP.iqType = XMPP.IQSet,
> 	XMPP.iqTo = Just XMPP.JID { XMPP.jidNode = Nothing },
> 	XMPP.iqPayload = Just p
> })
> 	| [command] <- XML.isNamed (s"{http://jabber.org/protocol/commands}command") =<< XML.hasAttributeText (s"node") (s"config" ==) =<< XML.hasAttributeText (s"action") (s"complete" ==) p,
> 	  [_] <- XML.hasAttributeText (s"var") (s"runlevel" ==) =<< XML.isNamed(s"{jabber:x:data}field") =<< XML.elementChildren =<< XML.isNamed(s"{jabber:x:data}x") =<< XML.elementChildren command
> 		= XMPP.putStanza $ iqReply iq $ Just $ XML.documentRoot page3

Command Page 2

> handleRegister (XMPP.ReceivedIQ iq@XMPP.IQ {
> 	XMPP.iqType = XMPP.IQSet,
> 	XMPP.iqTo = Just XMPP.JID { XMPP.jidNode = Nothing },
> 	XMPP.iqPayload = Just p
> })
> 	| [_] <- XML.isNamed (s"{http://jabber.org/protocol/commands}command") =<< XML.hasAttributeText (s"node") (s"config" ==) =<< XML.hasAttributeText (s"action") (s"next" ==) p
> 		= XMPP.putStanza $ iqReply iq $ Just $ XML.documentRoot page2

Command Page 1

> handleRegister (XMPP.ReceivedIQ iq@XMPP.IQ {
> 	XMPP.iqType = XMPP.IQSet,
> 	XMPP.iqTo = Just XMPP.JID { XMPP.jidNode = Nothing },
> 	XMPP.iqPayload = Just p
> })
> 	| [_] <- XML.isNamed (s"{http://jabber.org/protocol/commands}command") =<< XML.hasAttributeText (s"node") (s"config" ==) =<< XML.hasAttributeText (s"action") (s"execute" ==) p
> 		= XMPP.putStanza $ iqReply iq $ Just $ XML.documentRoot page1

And again, handling "previous"

> handleRegister (XMPP.ReceivedIQ iq@XMPP.IQ {
> 	XMPP.iqType = XMPP.IQSet,
> 	XMPP.iqTo = Just XMPP.JID { XMPP.jidNode = Nothing },
> 	XMPP.iqPayload = Just p
> })
> 	| [_] <- XML.isNamed (s"{http://jabber.org/protocol/commands}command") =<< XML.hasAttributeText (s"node") (s"config" ==) =<< XML.hasAttributeText (s"action") (s"prev" ==) p
> 		= XMPP.putStanza $ iqReply iq $ Just $ XML.documentRoot page1

One more time, this time with no action...

> handleRegister (XMPP.ReceivedIQ iq@XMPP.IQ {
> 	XMPP.iqType = XMPP.IQSet,
> 	XMPP.iqTo = Just XMPP.JID { XMPP.jidNode = Nothing },
> 	XMPP.iqPayload = Just p
> })
> 	| [_] <- XML.isNamed (s"{http://jabber.org/protocol/commands}command") =<< XML.hasAttributeText (s"node") (s"config" ==) p
> 		= XMPP.putStanza $ iqReply iq $ Just $ XML.documentRoot page1

Any other IQ we don't bother with, but should return an error so nothing gets stuck.

> handleRegister (XMPP.ReceivedIQ iq)
>	| XMPP.iqType iq `elem` [XMPP.IQGet, XMPP.IQSet] =
>		XMPP.putStanza $ iqError iq $ errorPayload
>			"cancel" "feature-not-implemented" mempty []

Not a registration, so just ignore it.

> handleRegister _ = return ()

We want to use pretty-printed XML output.

> renderSettings :: XML.RenderSettings
> renderSettings = XML.def { XML.rsPretty = True }

XMPP.getStanza produces a ReceivedStanza which is not an instance of Stanza, but everything it might contain is, so this just lets us extract the element we know is in there.

> receivedStanzaToElement :: XMPP.ReceivedStanza -> XML.Element
> receivedStanzaToElement (XMPP.ReceivedMessage m) = XMPP.stanzaToElement m
> receivedStanzaToElement (XMPP.ReceivedPresence p) = XMPP.stanzaToElement p
> receivedStanzaToElement (XMPP.ReceivedIQ iq) = XMPP.stanzaToElement iq

The render function we are using requires an XML.Document (and, unfortunately, includes an XML declaration, but we can live with that for now).  This wraps any elemnt in a trivial document.

> elementToDocument :: XML.Element -> XML.Document
> elementToDocument el = XML.Document (XML.Prologue [] Nothing []) el []

The XMPP connections run in their own special context, so if we want to fork threads inside there, we use this handy helper.

> forkXMPP :: XMPP.XMPP () -> XMPP.XMPP ThreadId
> forkXMPP kid = do
>	parent <- liftIO myThreadId
> 	session <- XMPP.getSession
> 	liftIO $ forkFinally
>		(void $ XMPP.runXMPP session kid)
>		(either (handler parent) (const $ return ()))
>	where

Re-throws all exceptions other than ThreadKilled to the parent thread.  Makes synchronous child exceptions asynchronous in the parent, which is a bit sloppy.

> 	handler parent e
> 		| Just Ex.ThreadKilled <- Ex.fromException e = return ()
> 		| otherwise = throwTo parent e

Alias for fromString to make string literals prettier.

> s :: (IsString a) => String -> a
> s = fromString

There is no exported way from the XMPP library to create a stanza out of an XML.Element or string, but it's easy to create something that implements the interface and wraps a raw XML.Element.

> newtype RawComponentStanza = RawComponentStanza XML.Element

> instance XMPP.Stanza RawComponentStanza where

Get the attributes right off the XML element.

> 	stanzaTo (RawComponentStanza el) =
> 		XMPP.parseJID =<< XML.attributeText (s"to") el
> 	stanzaFrom (RawComponentStanza el) =
> 		XMPP.parseJID =<< XML.attributeText (s"from") el
> 	stanzaID (RawComponentStanza el) = XML.attributeText (s"id") el
> 	stanzaLang (RawComponentStanza el) = XML.attributeText (s"xml:lang") el

All the children are payloads.

> 	stanzaPayloads (RawComponentStanza el) = XML.elementChildren el

And we can "serialize" by simply returning ourselves.

> 	stanzaToElement (RawComponentStanza el) = el

Helpers to reply to IQ stanzas with both success and error cases.

> iqReply :: XMPP.IQ -> Maybe XML.Element -> XMPP.IQ
> iqReply iq payload = iq {
> 	XMPP.iqType = XMPP.IQResult,
> 	XMPP.iqFrom = XMPP.iqTo iq,
> 	XMPP.iqTo = XMPP.iqFrom iq,
> 	XMPP.iqPayload = payload
> }

> iqError :: XMPP.IQ -> XML.Element -> XMPP.IQ
> iqError iq payload = (iqReply iq (Just payload)) {
> 	XMPP.iqType = XMPP.IQError
> }

Helper to create an XMPP error payload with basic structure most errors need filled in.

> errorPayload :: String -> String -> Text -> [XML.Node] -> XML.Element
> errorPayload typ definedCondition english morePayload =
> 	XML.Element (s"{jabber:component:accept}error")
> 	[(s"{jabber:component:accept}type", [XML.ContentText $ fromString typ])]
> 	(
> 		(
> 			XML.NodeElement $ XML.Element (fromString nCond) [] []
> 		) :
> 		(
> 			XML.NodeElement $ XML.Element nText
> 				[(s"xml:lang", [XML.ContentText $ s"en"])]
> 				[XML.NodeContent $ XML.ContentText english]
> 		) :
> 		morePayload
> 	)
>	where
>	nText = s"{urn:ietf:params:xml:ns:xmpp-stanzas}text"
>	nCond = "{urn:ietf:params:xml:ns:xmpp-stanzas}" ++ definedCondition

These pages pulled from https://xmpp.org/extensions/xep-0050.html

> page1 = XML.parseText_ XML.def $ s"\
>\		  <command xmlns='http://jabber.org/protocol/commands'\
>\		           sessionid='config:20020923T213616Z-700'\
>\		           node='config'\
>\		           status='executing'>\
>\		    <actions execute='next'>\
>\		      <next/>\
>\		    </actions>\
>\		    <x xmlns='jabber:x:data' type='form'>\
>\		      <title>Configure Service</title>\
>\		      <instructions>\
>\		        Please select the service to configure.\
>\		      </instructions>\
>\		      <field var='service' label='Service' type='list-single'>\
>\		        <option><value>httpd</value></option>\
>\		        <option><value>jabberd</value></option>\
>\		        <option><value>postgresql</value></option>\
>\		      </field>\
>\		    </x>\
>\		  </command>"

> page2 = XML.parseText_ XML.def $ s"\
>\	  <command xmlns='http://jabber.org/protocol/commands'\
>\	           sessionid='config:20020923T213616Z-700'\
>\	           node='config'\
>\	           status='executing'>\
>\	    <actions execute='complete'>\
>\	      <prev/>\
>\	      <complete/>\
>\	    </actions>\
>\	    <x xmlns='jabber:x:data' type='form'>\
>\	      <title>Configure Service</title>\
>\	      <instructions>\
>\	        Please select the run modes and state for 'httpd'.\
>\	      </instructions>\
>\	      <field var='runlevel' label='Run Modes' type='list-multi'>\
>\	        <value>3</value>\
>\	        <value>5</value>\
>\	        <option label='Single-User'><value>1</value></option>\
>\	        <option label='Non-Networked Multi-User'><value>2</value></option>\
>\	        <option label='Full Multi-User'><value>3</value></option>\
>\	        <option label='X-Window'><value>5</value></option>\
>\	      </field>\
>\	      <field var='state' label='Run State' type='list-single'>\
>\	        <value>off</value>\
>\	        <option label='Active'><value>off</value></option>\
>\	        <option label='Inactive'><value>on</value></option>\
>\	      </field>\
>\	    </x>\
>\	  </command>"

> page3 = XML.parseText_ XML.def $ s"\
>\  <command xmlns='http://jabber.org/protocol/commands'\
>\           sessionid='config:20020923T213616Z-700'\
>\           node='config'\
>\           status='completed'>\
>\    <note type='info'>Service 'httpd' has been configured.</note>\
>\  </command>"