From 747c192fa85d43520e8b95e4e5c2d9596b88b1a2 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Sat, 5 May 2012 12:50:09 +0200 Subject: [PATCH] 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 --- src/Network/XMPP.hs | 6 +- src/Network/XMPP/Marshal.hs | 328 +++++++++++++++++------------------ src/Network/XMPP/Message.hs | 19 +- src/Network/XMPP/Pickle.hs | 5 +- src/Network/XMPP/Presence.hs | 31 ++-- src/Network/XMPP/Types.hs | 53 +++--- src/Tests.hs | 17 ++ 7 files changed, 225 insertions(+), 234 deletions(-) diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index ecc7e5e..87d9419 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -83,11 +83,10 @@ module Network.XMPP -- a system such as email. -- -- - , Message - , MessageError + , Message(..) + , MessageError(..) , MessageType(..) -- *** creating - , simpleMessage , answerMessage -- *** sending , sendMessage @@ -105,7 +104,6 @@ module Network.XMPP -- , Presence(..) , PresenceError(..) - , ShowType(..) -- *** creating , module Network.XMPP.Presence -- *** sending diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index 165a963..b10db9d 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/src/Network/XMPP/Marshal.hs @@ -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 + ) + ) \ No newline at end of file diff --git a/src/Network/XMPP/Message.hs b/src/Network/XMPP/Message.hs index b472dba..fd13506 100644 --- a/src/Network/XMPP/Message.hs +++ b/src/Network/XMPP/Message.hs @@ -5,7 +5,6 @@ module Network.XMPP.Message , MessageType(..) , MessageError(..) , message - , simpleMessage , answerMessage ) where @@ -22,27 +21,23 @@ message = Message { messageID = Nothing , messageTo = Nothing , messageLangTag = Nothing , messageType = Normal - , messageSubject = Nothing - , messageThread = Nothing - , messageBody = Nothing , messagePayload = [] } --- | Create simple message, containing nothing but a body text -simpleMessage :: JID -- ^ Recipient - -> Text -- ^ Myssage body - -> Message -simpleMessage to txt = message { messageTo = Just to - , messageBody = Just txt - } +---- | Create simple message, containing nothing but a body text +--simpleMessage :: JID -- ^ Recipient +-- -> Text -- ^ Myssage body +-- -> Message +--simpleMessage to txt = message { messageTo = Just to +-- , messageBody = Just txt +-- } answerMessage :: Message -> Text -> [Element] -> Maybe Message answerMessage Message{messageFrom = Just frm, ..} txt payload = Just $ Message{ messageFrom = messageTo , messageID = Nothing , messageTo = Just frm - , messageBody = Just txt , messagePayload = payload , .. } diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index bc611d8..035fb12 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -76,7 +76,6 @@ unpickleElem' p x = case unpickle (xpNodeElem p) x of unpickleElem :: PU [Node] a -> Element -> Either String a unpickleElem p x = unpickle (xpNodeElem p) x +-- Given a pickler and an object, produces an Element. pickleElem :: PU [Node] a -> a -> Element -pickleElem p = pickle $ xpNodeElem p - - +pickleElem p = pickle $ xpNodeElem p \ No newline at end of file diff --git a/src/Network/XMPP/Presence.hs b/src/Network/XMPP/Presence.hs index 501f60f..f2a447f 100644 --- a/src/Network/XMPP/Presence.hs +++ b/src/Network/XMPP/Presence.hs @@ -11,9 +11,6 @@ presence = Presence { presenceID = Nothing , presenceTo = Nothing , presenceLangTag = Nothing , presenceType = Nothing - , presenceShowType = Nothing - , presenceStatus = Nothing - , presencePriority = Nothing , presencePayload = [] } @@ -55,26 +52,26 @@ presenceOnline = presence presenceOffline :: Presence presenceOffline = presence {presenceType = Just Unavailable} --- Change your status -status - :: Maybe Text -- ^ Status message - -> Maybe ShowType -- ^ Status Type - -> Maybe Int -- ^ Priority - -> Presence -status txt showType prio = presence { presenceShowType = showType - , presencePriority = prio - , presenceStatus = txt - } +---- Change your status +--status +-- :: Maybe Text -- ^ Status message +-- -> Maybe ShowType -- ^ Status Type +-- -> Maybe Int -- ^ Priority +-- -> Presence +--status txt showType prio = presence { presenceShowType = showType +-- , presencePriority = prio +-- , presenceStatus = txt +-- } -- | Set the current availability status. This implicitly sets the clients -- status online -presenceAvail :: ShowType -> Presence -presenceAvail showType = status Nothing (Just showType) Nothing +--presenceAvail :: ShowType -> Presence +--presenceAvail showType = status Nothing (Just showType) Nothing -- | Set the current status message. This implicitly sets the clients -- status online -presenceMessage :: Text -> Presence -presenceMessage txt = status (Just txt) Nothing Nothing +--presenceMessage :: Text -> Presence +--presenceMessage txt = status (Just txt) Nothing Nothing -- | Add a recipient to a presence notification presTo :: Presence -> JID -> Presence diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index e71f9b2..f4c92d3 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -29,7 +29,6 @@ module Network.XMPP.Types , SaslFailure(..) , ServerAddress(..) , ServerFeatures(..) - , ShowType(..) , Stanza(..) , StanzaError(..) , StanzaErrorCondition(..) @@ -170,9 +169,6 @@ data Message = Message { messageID :: Maybe StanzaId , messageTo :: Maybe JID , messageLangTag :: Maybe LangTag , messageType :: MessageType - , messageSubject :: Maybe Text - , messageThread :: Maybe Text - , messageBody :: Maybe Text , messagePayload :: [Element] } deriving (Show) @@ -254,9 +250,6 @@ data Presence = Presence { presenceID :: Maybe StanzaId , presenceTo :: Maybe JID , presenceLangTag :: Maybe LangTag , presenceType :: Maybe PresenceType - , presenceShowType :: Maybe ShowType - , presenceStatus :: Maybe Text - , presencePriority :: Maybe Int , presencePayload :: [Element] } deriving (Show) @@ -310,29 +303,29 @@ instance Read PresenceType where readsPrec _ "probe" = [( Probe ,"")] readsPrec _ _ = [] -data ShowType = Available - | Away - | FreeChat - | DND - | XAway - deriving Eq - -instance Show ShowType where - show Available = "" - show Away = "away" - show FreeChat = "chat" - show DND = "dnd" - show XAway = "xa" - -instance Read ShowType where - readsPrec _ "" = [( Available ,"")] - readsPrec _ "available" = [( Available ,"")] - readsPrec _ "away" = [( Away ,"")] - readsPrec _ "chat" = [( FreeChat ,"")] - readsPrec _ "dnd" = [( DND ,"")] - readsPrec _ "xa" = [( XAway ,"")] - readsPrec _ "invisible" = [( Available ,"")] - readsPrec _ _ = [] +--data ShowType = Available +-- | Away +-- | FreeChat +-- | DND +-- | XAway +-- deriving Eq +-- +--instance Show ShowType where +-- show Available = "" +-- show Away = "away" +-- show FreeChat = "chat" +-- show DND = "dnd" +-- show XAway = "xa" +-- +--instance Read ShowType where +-- readsPrec _ "" = [( Available ,"")] +-- readsPrec _ "available" = [( Available ,"")] +-- readsPrec _ "away" = [( Away ,"")] +-- readsPrec _ "chat" = [( FreeChat ,"")] +-- readsPrec _ "dnd" = [( DND ,"")] +-- readsPrec _ "xa" = [( XAway ,"")] +-- readsPrec _ "invisible" = [( Available ,"")] +-- readsPrec _ _ = [] -- | diff --git a/src/Tests.hs b/src/Tests.hs index d0b8c25..71242dd 100644 --- a/src/Tests.hs +++ b/src/Tests.hs @@ -71,6 +71,23 @@ autoAccept = forever $ do st <- waitForPresence isPresenceSubscribe sendPresence $ presenceSubscribed (fromJust $ presenceFrom st) +simpleMessage :: JID -> Text -> Message +simpleMessage to txt = message + { messageTo = Just to + , messagePayload = [Element "body" + [] + [NodeContent $ ContentText txt] + ] + } + where + message = Message { messageID = Nothing + , messageFrom = Nothing + , messageTo = Nothing + , messageLangTag = Nothing + , messageType = Normal + , messagePayload = [] + } + sendUser = sendMessage . simpleMessage supervisor . Text.pack expect debug x y | x == y = debug "Ok."