Permalink
Browse files

updated Marshal.hs: fixed formatting, xpStanza where-local; im-specific

fields of Message and Presence removed; simpleMessage moved to Tests.hs
as to not to break it
  • Loading branch information...
1 parent 6e1a329 commit 747c192fa85d43520e8b95e4e5c2d9596b88b1a2 Jon Kristensen committed May 5, 2012
Showing with 225 additions and 234 deletions.
  1. +2 −4 src/Network/XMPP.hs
  2. +160 −168 src/Network/XMPP/Marshal.hs
  3. +7 −12 src/Network/XMPP/Message.hs
  4. +2 −3 src/Network/XMPP/Pickle.hs
  5. +14 −17 src/Network/XMPP/Presence.hs
  6. +23 −30 src/Network/XMPP/Types.hs
  7. +17 −0 src/Tests.hs
View
@@ -83,11 +83,10 @@ module Network.XMPP
-- a system such as email.
--
-- <http://xmpp.org/rfcs/rfc6120.html#stanzas-semantics-message>
- , Message
- , MessageError
+ , Message(..)
+ , MessageError(..)
, MessageType(..)
-- *** creating
- , simpleMessage
, answerMessage
-- *** sending
, sendMessage
@@ -105,7 +104,6 @@ module Network.XMPP
-- <http://xmpp.org/rfcs/rfc6120.html#stanzas-semantics-presence>
, Presence(..)
, PresenceError(..)
- , ShowType(..)
-- *** creating
, module Network.XMPP.Presence
-- *** sending
View
@@ -1,5 +1,11 @@
+-- Picklers and unpicklers convert Haskell data to XML and XML to Haskell data,
+-- respectively. By convensions, pickler/unpickler ("PU") function names start
+-- out with "xp".
+
{-# Language OverloadedStrings, ViewPatterns, NoMonomorphismRestriction #-}
+{-# OPTIONS_HADDOCK hide #-}
+
module Network.XMPP.Marshal where
import Data.XML.Pickle
@@ -11,15 +17,6 @@ import Network.XMPP.Types
xpStreamEntity :: PU [Node] (Either XmppStreamError Stanza)
xpStreamEntity = xpEither xpStreamError xpStanza
-stanzaSel :: Stanza -> Int
-stanzaSel (IQRequestS _) = 0
-stanzaSel (IQResultS _) = 1
-stanzaSel (IQErrorS _) = 2
-stanzaSel (MessageS _) = 3
-stanzaSel (MessageErrorS _) = 4
-stanzaSel (PresenceS _) = 5
-stanzaSel (PresenceErrorS _) = 6
-
xpStanza :: PU [Node] Stanza
xpStanza = xpAlt stanzaSel
[ xpWrap IQRequestS (\(IQRequestS x) -> x) xpIQRequest
@@ -30,188 +27,183 @@ xpStanza = xpAlt stanzaSel
, xpWrap PresenceS (\(PresenceS x) -> x) xpPresence
, xpWrap PresenceErrorS (\(PresenceErrorS x) -> x) xpPresenceError
]
+ where
+ -- Selector for which pickler to execute above.
+ stanzaSel :: Stanza -> Int
+ stanzaSel (IQRequestS _) = 0
+ stanzaSel (IQResultS _) = 1
+ stanzaSel (IQErrorS _) = 2
+ stanzaSel (MessageS _) = 3
+ stanzaSel (MessageErrorS _) = 4
+ stanzaSel (PresenceS _) = 5
+ stanzaSel (PresenceErrorS _) = 6
xpMessage :: PU [Node] (Message)
-xpMessage = xpWrap (\((tp, qid, from, to, lang), (sub, body, thr, ext))
- -> Message qid from to lang tp sub thr body ext)
- (\(Message qid from to lang tp sub thr body ext)
- -> ((tp, qid, from, to, lang), (sub, body, thr, ext)))
- $
- xpElem "{jabber:client}message"
- (xp5Tuple
- (xpDefault Normal $ xpAttr "type" xpPrim)
- (xpAttrImplied "id" xpPrim)
- (xpAttrImplied "from" xpPrim)
- (xpAttrImplied "to" xpPrim)
- (xpAttrImplied xmlLang xpPrim)
- -- TODO: NS?
- )
- (xp4Tuple
- (xpOption . xpElemNodes "{jabber:client}subject" $ xpContent xpId)
- (xpOption . xpElemNodes "{jabber:client}body" $ xpContent xpId)
- (xpOption . xpElemNodes "{jabber:client}thread" $ xpContent xpId)
- (xpAll xpElemVerbatim)
- )
-
+xpMessage = xpWrap
+ (\((tp, qid, from, to, lang), ext) -> Message qid from to lang tp ext)
+ (\(Message qid from to lang tp ext) -> ((tp, qid, from, to, lang), ext))
+ (xpElem "{jabber:client}message"
+ (xp5Tuple
+ (xpDefault Normal $ xpAttr "type" xpPrim)
+ (xpAttrImplied "id" xpPrim)
+ (xpAttrImplied "from" xpPrim)
+ (xpAttrImplied "to" xpPrim)
+ (xpAttrImplied xmlLang xpPrim)
+ -- TODO: NS?
+ )
+ (xpAll xpElemVerbatim)
+ )
xpPresence :: PU [Node] Presence
-xpPresence = xpWrap (\((qid, from, to, lang, tp),(shw, stat, prio, ext))
- -> Presence qid from to lang tp shw stat prio ext)
- (\(Presence qid from to lang tp shw stat prio ext)
- -> ((qid, from, to, lang, tp), (shw, stat, prio, ext)))
- $
- xpElem "{jabber:client}presence"
- (xp5Tuple
- (xpAttrImplied "id" xpPrim)
- (xpAttrImplied "from" xpPrim)
- (xpAttrImplied "to" xpPrim)
- xpLangTag
- (xpAttrImplied "type" xpPrim)
- )
- (xp4Tuple
- (xpOption . xpElemNodes "{jabber:client}show" $ xpContent xpPrim)
- (xpOption . xpElemNodes "{jabber:client}status" $ xpContent xpId)
- (xpOption . xpElemNodes "{jabber:client}priority" $ xpContent xpPrim)
- (xpAll xpElemVerbatim)
- )
+xpPresence = xpWrap
+ (\((qid, from, to, lang, tp), ext) -> Presence qid from to lang tp ext)
+ (\(Presence qid from to lang tp ext) -> ((qid, from, to, lang, tp), ext))
+ (xpElem "{jabber:client}presence"
+ (xp5Tuple
+ (xpAttrImplied "id" xpPrim)
+ (xpAttrImplied "from" xpPrim)
+ (xpAttrImplied "to" xpPrim)
+ xpLangTag
+ (xpAttrImplied "type" xpPrim)
+ )
+ (xpAll xpElemVerbatim)
+ )
xpIQRequest :: PU [Node] IQRequest
-xpIQRequest = xpWrap (\((qid, from, to, lang, tp),body)
- -> IQRequest qid from to lang tp body)
- (\(IQRequest qid from to lang tp body)
- -> ((qid, from, to, lang, tp), body))
- $
- xpElem "{jabber:client}iq"
- (xp5Tuple
- (xpAttr "id" xpPrim)
- (xpAttrImplied "from" xpPrim)
- (xpAttrImplied "to" xpPrim)
- xpLangTag
- ((xpAttr "type" xpPrim))
- )
- (xpElemVerbatim)
+xpIQRequest = xpWrap
+ (\((qid, from, to, lang, tp),body) -> IQRequest qid from to lang tp body)
+ (\(IQRequest qid from to lang tp body) -> ((qid, from, to, lang, tp), body))
+ (xpElem "{jabber:client}iq"
+ (xp5Tuple
+ (xpAttr "id" xpPrim)
+ (xpAttrImplied "from" xpPrim)
+ (xpAttrImplied "to" xpPrim)
+ xpLangTag
+ ((xpAttr "type" xpPrim))
+ )
+ xpElemVerbatim
+ )
xpIQResult :: PU [Node] IQResult
-xpIQResult = xpWrap (\((qid, from, to, lang, _tp),body)
- -> IQResult qid from to lang body)
- (\(IQResult qid from to lang body)
- -> ((qid, from, to, lang, ()), body))
- $
- xpElem "{jabber:client}iq"
- (xp5Tuple
- (xpAttr "id" xpPrim)
- (xpAttrImplied "from" xpPrim)
- (xpAttrImplied "to" xpPrim)
- xpLangTag
- ((xpAttrFixed "type" "result"))
- )
- (xpOption xpElemVerbatim)
+xpIQResult = xpWrap
+ (\((qid, from, to, lang, _tp),body) -> IQResult qid from to lang body)
+ (\(IQResult qid from to lang body) -> ((qid, from, to, lang, ()), body))
+ (xpElem "{jabber:client}iq"
+ (xp5Tuple
+ (xpAttr "id" xpPrim)
+ (xpAttrImplied "from" xpPrim)
+ (xpAttrImplied "to" xpPrim)
+ xpLangTag
+ ((xpAttrFixed "type" "result"))
+ )
+ (xpOption xpElemVerbatim)
+ )
----------------------------------------------------------
-- Errors
----------------------------------------------------------
xpErrorCondition :: PU [Node] StanzaErrorCondition
-xpErrorCondition = xpWrap (\(cond, (), ()) -> cond) (\cond -> (cond, (), ())) $
- xpElemByNamespace
- "urn:ietf:params:xml:ns:xmpp-stanzas" xpPrim
- xpUnit
- xpUnit
+xpErrorCondition = xpWrap
+ (\(cond, (), ()) -> cond)
+ (\cond -> (cond, (), ()))
+ (xpElemByNamespace
+ "urn:ietf:params:xml:ns:xmpp-stanzas"
+ xpPrim
+ xpUnit
+ xpUnit
+ )
xpStanzaError :: PU [Node] StanzaError
xpStanzaError = xpWrap
- (\(tp, (cond, txt, ext)) -> StanzaError tp cond txt ext)
- (\(StanzaError tp cond txt ext) -> (tp, (cond, txt, ext))) $
- xpElem "{jabber:client}error"
- (xpAttr "type" xpPrim)
- (xp3Tuple
- xpErrorCondition
- (xpOption $ xpElem "{jabber:client}text"
- (xpAttrImplied xmlLang xpPrim)
- (xpContent xpId)
- )
- (xpOption xpElemVerbatim)
- )
+ (\(tp, (cond, txt, ext)) -> StanzaError tp cond txt ext)
+ (\(StanzaError tp cond txt ext) -> (tp, (cond, txt, ext)))
+ (xpElem "{jabber:client}error"
+ (xpAttr "type" xpPrim)
+ (xp3Tuple
+ xpErrorCondition
+ (xpOption $ xpElem "{jabber:client}text"
+ (xpAttrImplied xmlLang xpPrim)
+ (xpContent xpId)
+ )
+ (xpOption xpElemVerbatim)
+ )
+ )
xpMessageError :: PU [Node] (MessageError)
-xpMessageError = xpWrap (\((_, qid, from, to, lang), (err, ext))
- -> MessageError qid from to lang err ext)
- (\(MessageError qid from to lang err ext)
- -> (((), qid, from, to, lang), (err, ext)))
- $
- xpElem "{jabber:client}message"
- (xp5Tuple
- (xpAttrFixed "type" "error")
- (xpAttrImplied "id" xpPrim)
- (xpAttrImplied "from" xpPrim)
- (xpAttrImplied "to" xpPrim)
- (xpAttrImplied xmlLang xpPrim)
- -- TODO: NS?
- )
- (xp2Tuple
- xpStanzaError
- (xpAll xpElemVerbatim)
- )
+xpMessageError = xpWrap
+ (\((_, qid, from, to, lang), (err, ext)) ->
+ MessageError qid from to lang err ext)
+ (\(MessageError qid from to lang err ext) ->
+ (((), qid, from, to, lang), (err, ext)))
+ (xpElem "{jabber:client}message"
+ (xp5Tuple
+ (xpAttrFixed "type" "error")
+ (xpAttrImplied "id" xpPrim)
+ (xpAttrImplied "from" xpPrim)
+ (xpAttrImplied "to" xpPrim)
+ (xpAttrImplied xmlLang xpPrim)
+ -- TODO: NS?
+ )
+ (xp2Tuple xpStanzaError (xpAll xpElemVerbatim))
+ )
xpPresenceError :: PU [Node] PresenceError
-xpPresenceError = xpWrap (\((qid, from, to, lang, _),(err, ext))
- -> PresenceError qid from to lang err ext)
- (\(PresenceError qid from to lang err ext)
- -> ((qid, from, to, lang, ()), (err, ext)))
- $
- xpElem "{jabber:client}presence"
- (xp5Tuple
- (xpAttrImplied "id" xpPrim)
- (xpAttrImplied "from" xpPrim)
- (xpAttrImplied "to" xpPrim)
- xpLangTag
- (xpAttrFixed "type" "error")
- )
- (xp2Tuple
- xpStanzaError
- (xpAll xpElemVerbatim)
- )
+xpPresenceError = xpWrap
+ (\((qid, from, to, lang, _),(err, ext)) ->
+ PresenceError qid from to lang err ext)
+ (\(PresenceError qid from to lang err ext) ->
+ ((qid, from, to, lang, ()), (err, ext)))
+ (xpElem "{jabber:client}presence"
+ (xp5Tuple
+ (xpAttrImplied "id" xpPrim)
+ (xpAttrImplied "from" xpPrim)
+ (xpAttrImplied "to" xpPrim)
+ xpLangTag
+ (xpAttrFixed "type" "error")
+ )
+ (xp2Tuple xpStanzaError (xpAll xpElemVerbatim))
+ )
xpIQError :: PU [Node] IQError
-xpIQError = xpWrap (\((qid, from, to, lang, _tp),(err, body))
- -> IQError qid from to lang err body)
- (\(IQError qid from to lang err body)
- -> ((qid, from, to, lang, ()), (err, body)))
- $
- xpElem "{jabber:client}iq"
- (xp5Tuple
- (xpAttr "id" xpPrim)
- (xpAttrImplied "from" xpPrim)
- (xpAttrImplied "to" xpPrim)
- xpLangTag
- ((xpAttrFixed "type" "error"))
- )
- (xp2Tuple
- xpStanzaError
- (xpOption xpElemVerbatim)
- )
+xpIQError = xpWrap
+ (\((qid, from, to, lang, _tp),(err, body)) ->
+ IQError qid from to lang err body)
+ (\(IQError qid from to lang err body) ->
+ ((qid, from, to, lang, ()), (err, body)))
+ (xpElem "{jabber:client}iq"
+ (xp5Tuple
+ (xpAttr "id" xpPrim)
+ (xpAttrImplied "from" xpPrim)
+ (xpAttrImplied "to" xpPrim)
+ xpLangTag
+ ((xpAttrFixed "type" "error"))
+ )
+ (xp2Tuple xpStanzaError (xpOption xpElemVerbatim))
+ )
xpStreamError :: PU [Node] XmppStreamError
xpStreamError = xpWrap
- (\((cond,() ,()), txt, el) -> XmppStreamError cond txt el)
- (\(XmppStreamError cond txt el) ->((cond,() ,()), txt, el))
- (xpElemNodes
- (Name "error"
- (Just "http://etherx.jabber.org/streams")
- (Just "stream")
- ) $ xp3Tuple
- (xpElemByNamespace
- "urn:ietf:params:xml:ns:xmpp-streams" xpPrim
- xpUnit
- xpUnit
- )
- (xpOption $ xpElem
- "{urn:ietf:params:xml:ns:xmpp-streams}text"
- xpLangTag
- (xpContent xpId))
- ( xpOption xpElemVerbatim
- -- application specific error conditions
- )
- )
-
-
+ (\((cond,() ,()), txt, el) -> XmppStreamError cond txt el)
+ (\(XmppStreamError cond txt el) ->((cond,() ,()), txt, el))
+ (xpElemNodes
+ (Name
+ "error"
+ (Just "http://etherx.jabber.org/streams")
+ (Just "stream")
+ )
+ (xp3Tuple
+ (xpElemByNamespace
+ "urn:ietf:params:xml:ns:xmpp-streams"
+ xpPrim
+ xpUnit
+ xpUnit
+ )
+ (xpOption $ xpElem
+ "{urn:ietf:params:xml:ns:xmpp-streams}text"
+ xpLangTag
+ (xpContent xpId)
+ )
+ (xpOption xpElemVerbatim) -- Application specific error conditions
+ )
+ )
Oops, something went wrong.

0 comments on commit 747c192

Please sign in to comment.