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. 158
      src/Network/XMPP/Marshal.hs
  3. 19
      src/Network/XMPP/Message.hs
  4. 3
      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

158
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,14 +27,22 @@ 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"
$
xpElem "{jabber:client}message"
(xp5Tuple (xp5Tuple
(xpDefault Normal $ xpAttr "type" xpPrim) (xpDefault Normal $ xpAttr "type" xpPrim)
(xpAttrImplied "id" xpPrim) (xpAttrImplied "id" xpPrim)
@ -46,21 +51,14 @@ xpMessage = xpWrap (\((tp, qid, from, to, lang), (sub, body, thr, ext))
(xpAttrImplied xmlLang xpPrim) (xpAttrImplied xmlLang xpPrim)
-- TODO: NS? -- 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) (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"
$
xpElem "{jabber:client}presence"
(xp5Tuple (xp5Tuple
(xpAttrImplied "id" xpPrim) (xpAttrImplied "id" xpPrim)
(xpAttrImplied "from" xpPrim) (xpAttrImplied "from" xpPrim)
@ -68,20 +66,14 @@ xpPresence = xpWrap (\((qid, from, to, lang, tp),(shw, stat, prio, ext))
xpLangTag xpLangTag
(xpAttrImplied "type" xpPrim) (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) (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"
$
xpElem "{jabber:client}iq"
(xp5Tuple (xp5Tuple
(xpAttr "id" xpPrim) (xpAttr "id" xpPrim)
(xpAttrImplied "from" xpPrim) (xpAttrImplied "from" xpPrim)
@ -89,15 +81,14 @@ xpIQRequest = xpWrap (\((qid, from, to, lang, tp),body)
xpLangTag xpLangTag
((xpAttr "type" xpPrim)) ((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"
$
xpElem "{jabber:client}iq"
(xp5Tuple (xp5Tuple
(xpAttr "id" xpPrim) (xpAttr "id" xpPrim)
(xpAttrImplied "from" xpPrim) (xpAttrImplied "from" xpPrim)
@ -106,23 +97,28 @@ xpIQResult = xpWrap (\((qid, from, to, lang, _tp),body)
((xpAttrFixed "type" "result")) ((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, (), ()))
(xpElemByNamespace
"urn:ietf:params:xml:ns:xmpp-stanzas"
xpPrim
xpUnit xpUnit
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
@ -132,14 +128,15 @@ xpStanzaError = xpWrap
) )
(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)
@ -148,18 +145,16 @@ xpMessageError = xpWrap (\((_, qid, from, to, lang), (err, ext))
(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)
@ -167,18 +162,16 @@ xpPresenceError = xpWrap (\((qid, from, to, lang, _),(err, ext))
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)
@ -186,9 +179,7 @@ xpIQError = xpWrap (\((qid, from, to, lang, _tp),(err, body))
xpLangTag xpLangTag
((xpAttrFixed "type" "error")) ((xpAttrFixed "type" "error"))
) )
(xp2Tuple (xp2Tuple xpStanzaError (xpOption xpElemVerbatim))
xpStanzaError
(xpOption xpElemVerbatim)
) )
xpStreamError :: PU [Node] XmppStreamError xpStreamError :: PU [Node] XmppStreamError
@ -196,22 +187,23 @@ 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
"error"
(Just "http://etherx.jabber.org/streams") (Just "http://etherx.jabber.org/streams")
(Just "stream") (Just "stream")
) $ xp3Tuple )
(xp3Tuple
(xpElemByNamespace (xpElemByNamespace
"urn:ietf:params:xml:ns:xmpp-streams" xpPrim "urn:ietf:params:xml:ns:xmpp-streams"
xpPrim
xpUnit xpUnit
xpUnit xpUnit
) )
(xpOption $ xpElem (xpOption $ xpElem
"{urn:ietf:params:xml:ns:xmpp-streams}text" "{urn:ietf:params:xml:ns:xmpp-streams}text"
xpLangTag xpLangTag
(xpContent xpId)) (xpContent xpId)
( xpOption xpElemVerbatim )
-- application specific error conditions (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
, .. , ..
} }

3
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