From 24d4749f3b3fba7c84db989231b3eac17ad8ddb6 Mon Sep 17 00:00:00 2001
From: Christopher Vollick <0@psycoti.ca>
Date: Fri, 15 Jan 2021 14:26:33 -0500
Subject: [PATCH] Test Commands
I'm doing a thing with ad hoc commands, but it's hard to test if there aren't
any actual commands to run.
So, I've pulled these commands from the spec and don't the bare minimum to make
it look like they may be doing something.
---
gateway.lhs | 131 ++++++++++++++++++++++++++++++++++++++++++++++++++++
1 file changed, 131 insertions(+)
diff --git a/gateway.lhs b/gateway.lhs
index 7a9536a..56da357 100644
--- a/gateway.lhs
+++ b/gateway.lhs
@@ -103,6 +103,76 @@ And tell the user they're done so they can close their window.
> ]
> ]
+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
+
Any other IQ we don't bother with, but should return an error so nothing gets stuck.
> handleRegister (XMPP.ReceivedIQ iq)
@@ -211,3 +281,64 @@ Helper to create an XMPP error payload with basic structure most errors need fil
> 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"\
+>\ \ sessionid='config:20020923T213616Z-700'\
+>\ node='config'\
+>\ status='executing'>\
+>\ \
+>\ \
+>\ \
+>\ \
+>\ Configure Service\
+>\ \
+>\ Please select the service to configure.\
+>\ \
+>\ \
+>\ \
+>\ \
+>\ \
+>\ \
+>\ \
+>\ "
+
+> page2 = XML.parseText_ XML.def $ s"\
+>\ \ sessionid='config:20020923T213616Z-700'\
+>\ node='config'\
+>\ status='executing'>\
+>\ \
+>\ \
+>\ \
+>\ \
+>\ \
+>\ Configure Service\
+>\ \
+>\ Please select the run modes and state for 'httpd'.\
+>\ \
+>\ \
+>\ 3\
+>\ 5\
+>\ \
+>\ \
+>\ \
+>\ \
+>\ \
+>\ \
+>\ off\
+>\ \
+>\ \
+>\ \
+>\ \
+>\ "
+
+> page3 = XML.parseText_ XML.def $ s"\
+>\ \ sessionid='config:20020923T213616Z-700'\
+>\ node='config'\
+>\ status='completed'>\
+>\ Service 'httpd' has been configured.\
+>\ "
--
2.45.2