~singpolyma/cheogram-smtp

53d8dd287934cca45764161c2c156f359f247c96 — Stephen Paul Weber 4 months ago 3a86097
Fix namespaces on attributes

It turns out that attributes should normally *not* have explicit namespaces.
This is because the XML spec says that an attribute with no namespace is
implicity namespaced by the element it is on (to a pseudo namespace partition).

I think this was only ever working because the XML text generator in the XMPP
library is primitive and wasn't adding prefixes.
4 files changed, 27 insertions(+), 41 deletions(-)

M Email.hs
M Util.hs
M gateway.hs
M test/EmailTest.hs
M Email.hs => Email.hs +3 -5
@@ 108,7 108,7 @@ emailToOriginID email = fmap originID $ hush . MIME.parse messageID =<<
	firstOf (MIME.headers . MIME.header (s"message-id")) email
	where
	originID msgid = XML.Element (s"{urn:xmpp:sid:0}origin-id")
		[(s"{urn:xmpp:sid:0}id", [XML.ContentText msgid])] []
		[(s"id", [XML.ContentText msgid])] []

extractThreadFromRef :: Text -> Atto.Parser Text
extractThreadFromRef domain = mfilter (/= s"\0") $ fmap equalsDecode $


@@ 153,9 153,7 @@ emailToThread domain email = thread <&> \threadID ->
	where
	parent =
		maybeToList $
		fmap (
			(,) (s"{jabber:component:accept}parent") .
			(:[]) . XML.ContentText
		fmap ((,) (s"parent") . (:[]) . XML.ContentText
		)
		(hush . MIME.parse (extractThreadFromRefs domain) =<< refs)
	thread = fmap (s"References: "++) $


@@ 288,7 286,7 @@ messageToEmail fromDomain now message@XMPP.Message {
	refs = mkReferences message
	jidHeader = Just $ MIME.encodeEncodedWords (bareTxt from)
	dateHeader = fromMaybe now $ parseXMPPTime =<<
		XML.attributeText (s"{urn:xmpp:delay}stamp") =<<
		XML.attributeText (s"stamp") =<<
		child (s"{urn:xmpp:delay}delay") message
	subjectHeader = MIME.encodeEncodedWords <$>
		(getSubject message <|> defaultSubject message)

M Util.hs => Util.hs +5 -17
@@ 132,7 132,7 @@ getSubject = fmap (mconcat . XML.elementText) .
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])]
	[(s"type", [XML.ContentText $ fromString typ])]
	(
		(
			XML.NodeElement $ XML.Element definedConditionName [] []


@@ 168,27 168,15 @@ mkElement name content = XML.Element name []
mkDiscoIdentity :: Text -> Text -> Text -> XML.Element
mkDiscoIdentity category typ name =
	XML.Element (s"{http://jabber.org/protocol/disco#info}identity") [
		(
			s"{http://jabber.org/protocol/disco#info}category",
			[XML.ContentText category]
		),
		(
			s"{http://jabber.org/protocol/disco#info}type",
			[XML.ContentText typ]
		),
		(
			s"{http://jabber.org/protocol/disco#info}name",
			[XML.ContentText name]
		)
		(s"category", [XML.ContentText category]),
		(s"type", [XML.ContentText typ]),
		(s"name", [XML.ContentText name])
	] []

mkDiscoFeature :: Text -> XML.Element
mkDiscoFeature var =
	XML.Element (s"{http://jabber.org/protocol/disco#info}feature") [
		(
			s"{http://jabber.org/protocol/disco#info}var",
			[XML.ContentText var]
		)
		(s"var", [XML.ContentText var])
	] []

(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d

M gateway.hs => gateway.hs +10 -10
@@ 30,15 30,11 @@ newtype RawComponentStanza = RawComponentStanza XML.Element

instance XMPP.Stanza RawComponentStanza where
	stanzaTo (RawComponentStanza el) =
		XMPP.parseJID =<<
		XML.attributeText (s"{jabber:component:accept}to") el
		XMPP.parseJID =<< XML.attributeText (s"to") el
	stanzaFrom (RawComponentStanza el) =
		XMPP.parseJID =<<
		XML.attributeText (s"{jabber:component:accept}from") el
	stanzaID (RawComponentStanza el) =
		XML.attributeText (s"{jabber:component:accept}id") el
	stanzaLang (RawComponentStanza el) =
		XML.attributeText (s"xml:lang") 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
	stanzaPayloads (RawComponentStanza el) = XML.elementChildren el
	stanzaToElement (RawComponentStanza el) = el



@@ 49,7 45,7 @@ defaultMessageError = errorPayload "cancel" "undefined-condition"
overrideID :: Text -> XML.Element -> XML.Element
overrideID newID el = el {
	XML.elementAttributes =
		(s"{jabber:component:accept}id", [XML.ContentText newID]) :
		(s"id", [XML.ContentText newID]) :
		XML.elementAttributes el
}



@@ 142,11 138,15 @@ iqGetHandler iq@XMPP.IQ {
} | Nothing <- XMPP.jidNode to,
    [_] <- XML.isNamed (s"{http://jabber.org/protocol/disco#info}query") p =
	XMPP.putStanza $ iqReply (Just $ XML.Element
		(s"{http://jabber.org/protocol/disco#info}query") [] [
		(s"{http://jabber.org/protocol/disco#info}query")
		(maybeToList nodeAttribute) [
			XML.NodeElement $ mkDiscoIdentity
				(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.putStanza $ iqError notImplemented iq

main :: IO ()

M test/EmailTest.hs => test/EmailTest.hs +9 -9
@@ 59,7 59,7 @@ unit_emailToStanzaSimple =
				XML.NodeContent $ XML.ContentText $ s"Human"
			],
			XML.Element (s"{urn:xmpp:sid:0}origin-id") [(
				s"{urn:xmpp:sid:0}id",
				s"id",
				[XML.ContentText $ s"boop-id@ids.example.com"]
			)] [],
			XML.Element (s"{jabber:component:accept}thread") [] [


@@ 183,11 183,11 @@ unit_emailToStanzaReply =
				XML.NodeContent $ XML.ContentText $ s"subject"
			],
			XML.Element (s"{urn:xmpp:sid:0}origin-id") [(
				s"{urn:xmpp:sid:0}id",
				s"id",
				[XML.ContentText $ s"abc@example.com"]
			)] [],
			XML.Element (s"{jabber:component:accept}thread") [(
				s"{jabber:component:accept}parent",
				s"parent",
				[XML.ContentText $ s"athread"]
			)] [
				XML.NodeContent $ XML.ContentText $


@@ 222,7 222,7 @@ unit_emailToStanzaReplyNulThread =
				XML.NodeContent $ XML.ContentText $ s"subject"
			],
			XML.Element (s"{urn:xmpp:sid:0}origin-id") [(
				s"{urn:xmpp:sid:0}id",
				s"id",
				[XML.ContentText $ s"abc@example.com"]
			)] [],
			XML.Element (s"{jabber:component:accept}thread") [] [


@@ 258,11 258,11 @@ unit_emailToStanzaDeepReply =
				XML.NodeContent $ XML.ContentText $ s"subject"
			],
			XML.Element (s"{urn:xmpp:sid:0}origin-id") [(
				s"{urn:xmpp:sid:0}id",
				s"id",
				[XML.ContentText $ s"abc@example.com"]
			)] [],
			XML.Element (s"{jabber:component:accept}thread") [(
				s"{jabber:component:accept}parent",
				s"parent",
				[XML.ContentText $ s"References: <1583335391.\
					\7d84bbbf-4dd8-42f7-81cc-d7f4ffa06609.\
					\exBUAYVLbCAwUgAUpONVhfirfwVfAUZf\


@@ 318,11 318,11 @@ unit_emailToStanzaDeepInReplyTo =
				XML.NodeContent $ XML.ContentText $ s"subject"
			],
			XML.Element (s"{urn:xmpp:sid:0}origin-id") [(
				s"{urn:xmpp:sid:0}id",
				s"id",
				[XML.ContentText $ s"abc@example.com"]
			)] [],
			XML.Element (s"{jabber:component:accept}thread") [(
				s"{jabber:component:accept}parent",
				s"parent",
				[XML.ContentText $ s"References: <1583335391.\
					\7d84bbbf-4dd8-42f7-81cc-d7f4ffa06609.\
					\exBUAYVLbCAwUgAUpONVhfirfwVfAUZf\


@@ 474,7 474,7 @@ unit_messageToEmailWithDelay =
		XMPP.messageFrom = XMPP.parseJID $ s"f@example.com",
		XMPP.messagePayloads = [
			XML.Element (s"{urn:xmpp:delay}delay") [(
				s"{urn:xmpp:delay}stamp",
				s"stamp",
				[XML.ContentText $ s"2009-02-22T00:10:00Z"]
			)] [],
			XML.Element (s"{jabber:component:accept}body")