Browse Source

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
master
Jon Kristensen 14 years ago
parent
commit
747c192fa8
  1. 6
      src/Network/XMPP.hs
  2. 328
      src/Network/XMPP/Marshal.hs
  3. 19
      src/Network/XMPP/Message.hs
  4. 5
      src/Network/XMPP/Pickle.hs
  5. 31
      src/Network/XMPP/Presence.hs
  6. 53
      src/Network/XMPP/Types.hs
  7. 17
      src/Tests.hs

6
src/Network/XMPP.hs

@ -83,11 +83,10 @@ module Network.XMPP
-- a system such as email. -- a system such as email.
-- --
-- <http://xmpp.org/rfcs/rfc6120.html#stanzas-semantics-message> -- <http://xmpp.org/rfcs/rfc6120.html#stanzas-semantics-message>
, Message , Message(..)
, MessageError , MessageError(..)
, MessageType(..) , MessageType(..)
-- *** creating -- *** creating
, simpleMessage
, answerMessage , answerMessage
-- *** sending -- *** sending
, sendMessage , sendMessage
@ -105,7 +104,6 @@ module Network.XMPP
-- <http://xmpp.org/rfcs/rfc6120.html#stanzas-semantics-presence> -- <http://xmpp.org/rfcs/rfc6120.html#stanzas-semantics-presence>
, Presence(..) , Presence(..)
, PresenceError(..) , PresenceError(..)
, ShowType(..)
-- *** creating -- *** creating
, module Network.XMPP.Presence , module Network.XMPP.Presence
-- *** sending -- *** sending

328
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 #-} {-# Language OverloadedStrings, ViewPatterns, NoMonomorphismRestriction #-}
{-# OPTIONS_HADDOCK hide #-}
module Network.XMPP.Marshal where module Network.XMPP.Marshal where
import Data.XML.Pickle import Data.XML.Pickle
@ -11,15 +17,6 @@ import Network.XMPP.Types
xpStreamEntity :: PU [Node] (Either XmppStreamError Stanza) xpStreamEntity :: PU [Node] (Either XmppStreamError Stanza)
xpStreamEntity = xpEither xpStreamError xpStanza 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 :: PU [Node] Stanza
xpStanza = xpAlt stanzaSel xpStanza = xpAlt stanzaSel
[ xpWrap IQRequestS (\(IQRequestS x) -> x) xpIQRequest [ xpWrap IQRequestS (\(IQRequestS x) -> x) xpIQRequest
@ -30,188 +27,183 @@ xpStanza = xpAlt stanzaSel
, xpWrap PresenceS (\(PresenceS x) -> x) xpPresence , xpWrap PresenceS (\(PresenceS x) -> x) xpPresence
, xpWrap PresenceErrorS (\(PresenceErrorS x) -> x) xpPresenceError , 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 :: PU [Node] (Message)
xpMessage = xpWrap (\((tp, qid, from, to, lang), (sub, body, thr, ext)) xpMessage = xpWrap
-> Message qid from to lang tp sub thr body ext) (\((tp, qid, from, to, lang), ext) -> Message qid from to lang tp ext)
(\(Message qid from to lang tp sub thr body ext) (\(Message qid from to lang tp ext) -> ((tp, qid, from, to, lang), ext))
-> ((tp, qid, from, to, lang), (sub, body, thr, ext))) (xpElem "{jabber:client}message"
$ (xp5Tuple
xpElem "{jabber:client}message" (xpDefault Normal $ xpAttr "type" xpPrim)
(xp5Tuple (xpAttrImplied "id" xpPrim)
(xpDefault Normal $ xpAttr "type" xpPrim) (xpAttrImplied "from" xpPrim)
(xpAttrImplied "id" xpPrim) (xpAttrImplied "to" xpPrim)
(xpAttrImplied "from" xpPrim) (xpAttrImplied xmlLang xpPrim)
(xpAttrImplied "to" xpPrim) -- TODO: NS?
(xpAttrImplied xmlLang xpPrim) )
-- TODO: NS? (xpAll xpElemVerbatim)
) )
(xp4Tuple
(xpOption . xpElemNodes "{jabber:client}subject" $ xpContent xpId)
(xpOption . xpElemNodes "{jabber:client}body" $ xpContent xpId)
(xpOption . xpElemNodes "{jabber:client}thread" $ xpContent xpId)
(xpAll xpElemVerbatim)
)
xpPresence :: PU [Node] Presence xpPresence :: PU [Node] Presence
xpPresence = xpWrap (\((qid, from, to, lang, tp),(shw, stat, prio, ext)) xpPresence = xpWrap
-> Presence qid from to lang tp shw stat prio ext) (\((qid, from, to, lang, tp), ext) -> Presence qid from to lang tp ext)
(\(Presence qid from to lang tp shw stat prio ext) (\(Presence qid from to lang tp ext) -> ((qid, from, to, lang, tp), ext))
-> ((qid, from, to, lang, tp), (shw, stat, prio, ext))) (xpElem "{jabber:client}presence"
$ (xp5Tuple
xpElem "{jabber:client}presence" (xpAttrImplied "id" xpPrim)
(xp5Tuple (xpAttrImplied "from" xpPrim)
(xpAttrImplied "id" xpPrim) (xpAttrImplied "to" xpPrim)
(xpAttrImplied "from" xpPrim) xpLangTag
(xpAttrImplied "to" xpPrim) (xpAttrImplied "type" xpPrim)
xpLangTag )
(xpAttrImplied "type" xpPrim) (xpAll xpElemVerbatim)
) )
(xp4Tuple
(xpOption . xpElemNodes "{jabber:client}show" $ xpContent xpPrim)
(xpOption . xpElemNodes "{jabber:client}status" $ xpContent xpId)
(xpOption . xpElemNodes "{jabber:client}priority" $ xpContent xpPrim)
(xpAll xpElemVerbatim)
)
xpIQRequest :: PU [Node] IQRequest xpIQRequest :: PU [Node] IQRequest
xpIQRequest = xpWrap (\((qid, from, to, lang, tp),body) xpIQRequest = xpWrap
-> IQRequest qid from to lang tp body) (\((qid, from, to, lang, tp),body) -> IQRequest 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))
-> ((qid, from, to, lang, tp), body)) (xpElem "{jabber:client}iq"
$ (xp5Tuple
xpElem "{jabber:client}iq" (xpAttr "id" xpPrim)
(xp5Tuple (xpAttrImplied "from" xpPrim)
(xpAttr "id" xpPrim) (xpAttrImplied "to" xpPrim)
(xpAttrImplied "from" xpPrim) xpLangTag
(xpAttrImplied "to" xpPrim) ((xpAttr "type" xpPrim))
xpLangTag )
((xpAttr "type" xpPrim)) xpElemVerbatim
) )
(xpElemVerbatim)
xpIQResult :: PU [Node] IQResult xpIQResult :: PU [Node] IQResult
xpIQResult = xpWrap (\((qid, from, to, lang, _tp),body) xpIQResult = xpWrap
-> IQResult qid from to lang body) (\((qid, from, to, lang, _tp),body) -> IQResult qid from to lang body)
(\(IQResult qid from to lang body) (\(IQResult qid from to lang body) -> ((qid, from, to, lang, ()), body))
-> ((qid, from, to, lang, ()), body)) (xpElem "{jabber:client}iq"
$ (xp5Tuple
xpElem "{jabber:client}iq" (xpAttr "id" xpPrim)
(xp5Tuple (xpAttrImplied "from" xpPrim)
(xpAttr "id" xpPrim) (xpAttrImplied "to" xpPrim)
(xpAttrImplied "from" xpPrim) xpLangTag
(xpAttrImplied "to" xpPrim) ((xpAttrFixed "type" "result"))
xpLangTag )
((xpAttrFixed "type" "result")) (xpOption xpElemVerbatim)
) )
(xpOption xpElemVerbatim)
---------------------------------------------------------- ----------------------------------------------------------
-- Errors -- Errors
---------------------------------------------------------- ----------------------------------------------------------
xpErrorCondition :: PU [Node] StanzaErrorCondition xpErrorCondition :: PU [Node] StanzaErrorCondition
xpErrorCondition = xpWrap (\(cond, (), ()) -> cond) (\cond -> (cond, (), ())) $ xpErrorCondition = xpWrap
xpElemByNamespace (\(cond, (), ()) -> cond)
"urn:ietf:params:xml:ns:xmpp-stanzas" xpPrim (\cond -> (cond, (), ()))
xpUnit (xpElemByNamespace
xpUnit "urn:ietf:params:xml:ns:xmpp-stanzas"
xpPrim
xpUnit
xpUnit
)
xpStanzaError :: PU [Node] StanzaError xpStanzaError :: PU [Node] StanzaError
xpStanzaError = xpWrap xpStanzaError = xpWrap
(\(tp, (cond, txt, ext)) -> StanzaError tp cond txt ext) (\(tp, (cond, txt, ext)) -> StanzaError tp cond txt ext)
(\(StanzaError tp cond txt ext) -> (tp, (cond, txt, ext))) $ (\(StanzaError tp cond txt ext) -> (tp, (cond, txt, ext)))
xpElem "{jabber:client}error" (xpElem "{jabber:client}error"
(xpAttr "type" xpPrim) (xpAttr "type" xpPrim)
(xp3Tuple (xp3Tuple
xpErrorCondition xpErrorCondition
(xpOption $ xpElem "{jabber:client}text" (xpOption $ xpElem "{jabber:client}text"
(xpAttrImplied xmlLang xpPrim) (xpAttrImplied xmlLang xpPrim)
(xpContent xpId) (xpContent xpId)
) )
(xpOption xpElemVerbatim) (xpOption xpElemVerbatim)
) )
)
xpMessageError :: PU [Node] (MessageError) xpMessageError :: PU [Node] (MessageError)
xpMessageError = xpWrap (\((_, qid, from, to, lang), (err, ext)) xpMessageError = xpWrap
-> MessageError qid from to lang err ext) (\((_, 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))) (\(MessageError qid from to lang err ext) ->
$ (((), qid, from, to, lang), (err, ext)))
xpElem "{jabber:client}message" (xpElem "{jabber:client}message"
(xp5Tuple (xp5Tuple
(xpAttrFixed "type" "error") (xpAttrFixed "type" "error")
(xpAttrImplied "id" xpPrim) (xpAttrImplied "id" xpPrim)
(xpAttrImplied "from" xpPrim) (xpAttrImplied "from" xpPrim)
(xpAttrImplied "to" xpPrim) (xpAttrImplied "to" xpPrim)
(xpAttrImplied xmlLang xpPrim) (xpAttrImplied xmlLang xpPrim)
-- TODO: NS? -- TODO: NS?
) )
(xp2Tuple (xp2Tuple xpStanzaError (xpAll xpElemVerbatim))
xpStanzaError )
(xpAll xpElemVerbatim)
)
xpPresenceError :: PU [Node] PresenceError xpPresenceError :: PU [Node] PresenceError
xpPresenceError = xpWrap (\((qid, from, to, lang, _),(err, ext)) xpPresenceError = xpWrap
-> PresenceError qid from to lang err ext) (\((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))) (\(PresenceError qid from to lang err ext) ->
$ ((qid, from, to, lang, ()), (err, ext)))
xpElem "{jabber:client}presence" (xpElem "{jabber:client}presence"
(xp5Tuple (xp5Tuple
(xpAttrImplied "id" xpPrim) (xpAttrImplied "id" xpPrim)
(xpAttrImplied "from" xpPrim) (xpAttrImplied "from" xpPrim)
(xpAttrImplied "to" xpPrim) (xpAttrImplied "to" xpPrim)
xpLangTag xpLangTag
(xpAttrFixed "type" "error") (xpAttrFixed "type" "error")
) )
(xp2Tuple (xp2Tuple xpStanzaError (xpAll xpElemVerbatim))
xpStanzaError )
(xpAll xpElemVerbatim)
)
xpIQError :: PU [Node] IQError xpIQError :: PU [Node] IQError
xpIQError = xpWrap (\((qid, from, to, lang, _tp),(err, body)) xpIQError = xpWrap
-> IQError qid from to lang err body) (\((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))) (\(IQError qid from to lang err body) ->
$ ((qid, from, to, lang, ()), (err, body)))
xpElem "{jabber:client}iq" (xpElem "{jabber:client}iq"
(xp5Tuple (xp5Tuple
(xpAttr "id" xpPrim) (xpAttr "id" xpPrim)
(xpAttrImplied "from" xpPrim) (xpAttrImplied "from" xpPrim)
(xpAttrImplied "to" xpPrim) (xpAttrImplied "to" xpPrim)
xpLangTag xpLangTag
((xpAttrFixed "type" "error")) ((xpAttrFixed "type" "error"))
) )
(xp2Tuple (xp2Tuple xpStanzaError (xpOption xpElemVerbatim))
xpStanzaError )
(xpOption xpElemVerbatim)
)
xpStreamError :: PU [Node] XmppStreamError xpStreamError :: PU [Node] XmppStreamError
xpStreamError = xpWrap xpStreamError = xpWrap
(\((cond,() ,()), txt, el) -> XmppStreamError cond txt el) (\((cond,() ,()), txt, el) -> XmppStreamError cond txt el)
(\(XmppStreamError cond txt el) ->((cond,() ,()), txt, el)) (\(XmppStreamError cond txt el) ->((cond,() ,()), txt, el))
(xpElemNodes (xpElemNodes
(Name "error" (Name
(Just "http://etherx.jabber.org/streams") "error"
(Just "stream") (Just "http://etherx.jabber.org/streams")
) $ xp3Tuple (Just "stream")
(xpElemByNamespace )
"urn:ietf:params:xml:ns:xmpp-streams" xpPrim (xp3Tuple
xpUnit (xpElemByNamespace
xpUnit "urn:ietf:params:xml:ns:xmpp-streams"
) xpPrim
(xpOption $ xpElem xpUnit
"{urn:ietf:params:xml:ns:xmpp-streams}text" xpUnit
xpLangTag )
(xpContent xpId)) (xpOption $ xpElem
( xpOption xpElemVerbatim "{urn:ietf:params:xml:ns:xmpp-streams}text"
-- application specific error conditions xpLangTag
) (xpContent xpId)
) )
(xpOption xpElemVerbatim) -- Application specific error conditions
)
)

19
src/Network/XMPP/Message.hs

@ -5,7 +5,6 @@ module Network.XMPP.Message
, MessageType(..) , MessageType(..)
, MessageError(..) , MessageError(..)
, message , message
, simpleMessage
, answerMessage , answerMessage
) )
where where
@ -22,27 +21,23 @@ message = Message { messageID = Nothing
, messageTo = Nothing , messageTo = Nothing
, messageLangTag = Nothing , messageLangTag = Nothing
, messageType = Normal , messageType = Normal
, messageSubject = Nothing
, messageThread = Nothing
, messageBody = Nothing
, messagePayload = [] , messagePayload = []
} }
-- | Create simple message, containing nothing but a body text ---- | Create simple message, containing nothing but a body text
simpleMessage :: JID -- ^ Recipient --simpleMessage :: JID -- ^ Recipient
-> Text -- ^ Myssage body -- -> Text -- ^ Myssage body
-> Message -- -> Message
simpleMessage to txt = message { messageTo = Just to --simpleMessage to txt = message { messageTo = Just to
, messageBody = Just txt -- , messageBody = Just txt
} -- }
answerMessage :: Message -> Text -> [Element] -> Maybe Message answerMessage :: Message -> Text -> [Element] -> Maybe Message
answerMessage Message{messageFrom = Just frm, ..} txt payload = answerMessage Message{messageFrom = Just frm, ..} txt payload =
Just $ Message{ messageFrom = messageTo Just $ Message{ messageFrom = messageTo
, messageID = Nothing , messageID = Nothing
, messageTo = Just frm , messageTo = Just frm
, messageBody = Just txt
, messagePayload = payload , messagePayload = payload
, .. , ..
} }

5
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 :: PU [Node] a -> Element -> Either String a
unpickleElem p x = unpickle (xpNodeElem p) x unpickleElem p x = unpickle (xpNodeElem p) x
-- Given a pickler and an object, produces an Element.
pickleElem :: PU [Node] a -> a -> Element pickleElem :: PU [Node] a -> a -> Element
pickleElem p = pickle $ xpNodeElem p pickleElem p = pickle $ xpNodeElem p

31
src/Network/XMPP/Presence.hs

@ -11,9 +11,6 @@ presence = Presence { presenceID = Nothing
, presenceTo = Nothing , presenceTo = Nothing
, presenceLangTag = Nothing , presenceLangTag = Nothing
, presenceType = Nothing , presenceType = Nothing
, presenceShowType = Nothing
, presenceStatus = Nothing
, presencePriority = Nothing
, presencePayload = [] , presencePayload = []
} }
@ -55,26 +52,26 @@ presenceOnline = presence
presenceOffline :: Presence presenceOffline :: Presence
presenceOffline = presence {presenceType = Just Unavailable} presenceOffline = presence {presenceType = Just Unavailable}
-- Change your status ---- Change your status
status --status
:: Maybe Text -- ^ Status message -- :: Maybe Text -- ^ Status message
-> Maybe ShowType -- ^ Status Type -- -> Maybe ShowType -- ^ Status Type
-> Maybe Int -- ^ Priority -- -> Maybe Int -- ^ Priority
-> Presence -- -> Presence
status txt showType prio = presence { presenceShowType = showType --status txt showType prio = presence { presenceShowType = showType
, presencePriority = prio -- , presencePriority = prio
, presenceStatus = txt -- , presenceStatus = txt
} -- }
-- | Set the current availability status. This implicitly sets the clients -- | Set the current availability status. This implicitly sets the clients
-- status online -- status online
presenceAvail :: ShowType -> Presence --presenceAvail :: ShowType -> Presence
presenceAvail showType = status Nothing (Just showType) Nothing --presenceAvail showType = status Nothing (Just showType) Nothing
-- | Set the current status message. This implicitly sets the clients -- | Set the current status message. This implicitly sets the clients
-- status online -- status online
presenceMessage :: Text -> Presence --presenceMessage :: Text -> Presence
presenceMessage txt = status (Just txt) Nothing Nothing --presenceMessage txt = status (Just txt) Nothing Nothing
-- | Add a recipient to a presence notification -- | Add a recipient to a presence notification
presTo :: Presence -> JID -> Presence presTo :: Presence -> JID -> Presence

53
src/Network/XMPP/Types.hs

@ -29,7 +29,6 @@ module Network.XMPP.Types
, SaslFailure(..) , SaslFailure(..)
, ServerAddress(..) , ServerAddress(..)
, ServerFeatures(..) , ServerFeatures(..)
, ShowType(..)
, Stanza(..) , Stanza(..)
, StanzaError(..) , StanzaError(..)
, StanzaErrorCondition(..) , StanzaErrorCondition(..)
@ -170,9 +169,6 @@ data Message = Message { messageID :: Maybe StanzaId
, messageTo :: Maybe JID , messageTo :: Maybe JID
, messageLangTag :: Maybe LangTag , messageLangTag :: Maybe LangTag
, messageType :: MessageType , messageType :: MessageType
, messageSubject :: Maybe Text
, messageThread :: Maybe Text
, messageBody :: Maybe Text
, messagePayload :: [Element] , messagePayload :: [Element]
} }
deriving (Show) deriving (Show)
@ -254,9 +250,6 @@ data Presence = Presence { presenceID :: Maybe StanzaId
, presenceTo :: Maybe JID , presenceTo :: Maybe JID
, presenceLangTag :: Maybe LangTag , presenceLangTag :: Maybe LangTag
, presenceType :: Maybe PresenceType , presenceType :: Maybe PresenceType
, presenceShowType :: Maybe ShowType
, presenceStatus :: Maybe Text
, presencePriority :: Maybe Int
, presencePayload :: [Element] , presencePayload :: [Element]
} }
deriving (Show) deriving (Show)
@ -310,29 +303,29 @@ instance Read PresenceType where
readsPrec _ "probe" = [( Probe ,"")] readsPrec _ "probe" = [( Probe ,"")]
readsPrec _ _ = [] readsPrec _ _ = []
data ShowType = Available --data ShowType = Available
| Away -- | Away
| FreeChat -- | FreeChat
| DND -- | DND
| XAway -- | XAway
deriving Eq -- deriving Eq
--
instance Show ShowType where --instance Show ShowType where
show Available = "" -- show Available = ""
show Away = "away" -- show Away = "away"
show FreeChat = "chat" -- show FreeChat = "chat"
show DND = "dnd" -- show DND = "dnd"
show XAway = "xa" -- show XAway = "xa"
--
instance Read ShowType where --instance Read ShowType where
readsPrec _ "" = [( Available ,"")] -- readsPrec _ "" = [( Available ,"")]
readsPrec _ "available" = [( Available ,"")] -- readsPrec _ "available" = [( Available ,"")]
readsPrec _ "away" = [( Away ,"")] -- readsPrec _ "away" = [( Away ,"")]
readsPrec _ "chat" = [( FreeChat ,"")] -- readsPrec _ "chat" = [( FreeChat ,"")]
readsPrec _ "dnd" = [( DND ,"")] -- readsPrec _ "dnd" = [( DND ,"")]
readsPrec _ "xa" = [( XAway ,"")] -- readsPrec _ "xa" = [( XAway ,"")]
readsPrec _ "invisible" = [( Available ,"")] -- readsPrec _ "invisible" = [( Available ,"")]
readsPrec _ _ = [] -- readsPrec _ _ = []
-- | -- |

17
src/Tests.hs

@ -71,6 +71,23 @@ autoAccept = forever $ do
st <- waitForPresence isPresenceSubscribe st <- waitForPresence isPresenceSubscribe
sendPresence $ presenceSubscribed (fromJust $ presenceFrom st) 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 sendUser = sendMessage . simpleMessage supervisor . Text.pack
expect debug x y | x == y = debug "Ok." expect debug x y | x == y = debug "Ok."

Loading…
Cancel
Save