asakul
/
pontarius-xmpp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

Merge branch 'master' of https://github.com/nejla/pontarius

master
Philipp Balzarek 14 years ago
parent
10c22f41f0 747c192fa8
commit
cbd3c9573c
7 changed files with 225 additions and 234 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  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
Unescape View File

@ -83,11 +83,10 @@ module Network.XMPP @@ -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 @@ -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

328
src/Network/XMPP/Marshal.hs
Unescape View File

@ -1,5 +1,11 @@ @@ -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 @@ -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 @@ -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
)
)

19
src/Network/XMPP/Message.hs
Unescape View File

@ -5,7 +5,6 @@ module Network.XMPP.Message @@ -5,7 +5,6 @@ module Network.XMPP.Message
, MessageType(..)
, MessageError(..)
, message
, simpleMessage
, answerMessage
)
where
@ -22,27 +21,23 @@ message = Message { messageID = Nothing @@ -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
, ..
}

5
src/Network/XMPP/Pickle.hs
Unescape View File

@ -76,7 +76,6 @@ unpickleElem' p x = case unpickle (xpNodeElem p) x of @@ -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

31
src/Network/XMPP/Presence.hs
Unescape View File

@ -11,9 +11,6 @@ presence = Presence { presenceID = Nothing @@ -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 @@ -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

53
src/Network/XMPP/Types.hs
Unescape View File

@ -29,7 +29,6 @@ module Network.XMPP.Types @@ -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 @@ -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 @@ -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 @@ -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 _ _ = []
-- |

17
src/Tests.hs
Unescape View File

@ -71,6 +71,23 @@ autoAccept = forever $ do @@ -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."

Write Preview
Loading…
Cancel
Save