M Network/Protocol/XMPP.hs => Network/Protocol/XMPP.hs +56 -11
@@ 15,19 15,64 @@
module Network.Protocol.XMPP
- ( module Network.Protocol.XMPP.Client
- , module Network.Protocol.XMPP.Component
- , module Network.Protocol.XMPP.JID
- , module Network.Protocol.XMPP.Stanza
- , module Network.Protocol.XMPP.Stream
+ (
+ -- * JIDs
+ JID (..)
+ , Node
+ , Domain
+ , Resource
+
+ , strNode
+ , strDomain
+ , strResource
+
+ , parseJID
+ , formatJID
+
+ -- * Stanzas
+ , Stanza
+ ( stanzaTo
+ , stanzaFrom
+ , stanzaID
+ , stanzaLang
+ , stanzaPayloads
+ )
+
+ , ReceivedStanza (..)
+ , Message (..)
+ , Presence (..)
+ , IQ (..)
+ , MessageType (..)
+ , PresenceType (..)
+ , IQType (..)
+
+ , emptyMessage
+ , emptyPresence
+ , emptyIQ
+
+ -- * Streams
+ , Stream
+ , putStanza
+ , getStanza
+
+ -- * Connecting to a server
, Server (..)
+
+ -- ** Clients
+ , Client
+ , connectClient
+ , clientJID
+ , bindClient
+
+ -- ** Components
+ , Component
+ , connectComponent
+ , componentJID
+ , componentStreamID
) where
-
+import Network.Protocol.XMPP.JID
import Network.Protocol.XMPP.Client
import Network.Protocol.XMPP.Component
-import Network.Protocol.XMPP.JID
-import Network.Protocol.XMPP.Stanza
+import Network.Protocol.XMPP.Connections
import Network.Protocol.XMPP.Stream
-
-
-import Network.Protocol.XMPP.Internal.Connections
+import Network.Protocol.XMPP.Stanza
R Network/Protocol/XMPP/Internal/Authentication.hs => Network/Protocol/XMPP/Authentication.hs +3 -3
@@ 13,7 13,7 @@
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
-module Network.Protocol.XMPP.Internal.Authentication
+module Network.Protocol.XMPP.Authentication
( Result(..)
, authenticate
) where
@@ 28,8 28,8 @@ import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified Network.Protocol.SASL.GNU as SASL
import Network.Protocol.XMPP.JID (JID, formatJID)
-import Network.Protocol.XMPP.Internal.XML (element, qname)
-import qualified Network.Protocol.XMPP.Internal.Stream as S
+import Network.Protocol.XMPP.XML (element, qname)
+import qualified Network.Protocol.XMPP.Stream as S
data Result = Success | Failure
deriving (Show, Eq)
M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +8 -9
@@ 30,16 30,15 @@ import Data.ByteString (ByteString)
import qualified Data.Text as T
import qualified Text.XML.LibXML.SAX as SAX
-import qualified Network.Protocol.XMPP.Internal.Authentication as A
-import qualified Network.Protocol.XMPP.Internal.Connections as C
-import qualified Network.Protocol.XMPP.Internal.Features as F
-import qualified Network.Protocol.XMPP.Internal.Handle as H
-import qualified Network.Protocol.XMPP.Internal.Stream as S
+import qualified Network.Protocol.XMPP.Authentication as A
+import qualified Network.Protocol.XMPP.Connections as C
+import qualified Network.Protocol.XMPP.Features as F
+import qualified Network.Protocol.XMPP.Handle as H
import qualified Network.Protocol.XMPP.Stream as S
-import Network.Protocol.XMPP.Internal.XML ( getTree, putTree
- , element, qname
- , readEventsUntil
- )
+import Network.Protocol.XMPP.XML ( getTree, putTree
+ , element, qname
+ , readEventsUntil
+ )
import qualified Network.Protocol.XMPP.JID as J
import Network.Protocol.XMPP.Stanza
M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +6 -7
@@ 35,14 35,13 @@ import Network.Protocol.SASL.GNU (sha1)
import qualified System.IO as IO
import qualified Text.XML.LibXML.SAX as SAX
-import qualified Network.Protocol.XMPP.Internal.Connections as C
-import qualified Network.Protocol.XMPP.Internal.Handle as H
+import qualified Network.Protocol.XMPP.Connections as C
+import qualified Network.Protocol.XMPP.Handle as H
import qualified Network.Protocol.XMPP.Stream as S
-import qualified Network.Protocol.XMPP.Internal.Stream as S
-import Network.Protocol.XMPP.Internal.XML ( getTree, putTree
- , element, qname
- , readEventsUntil
- )
+import Network.Protocol.XMPP.XML ( getTree, putTree
+ , element, qname
+ , readEventsUntil
+ )
import Network.Protocol.XMPP.JID (JID)
data Component = Component
R Network/Protocol/XMPP/Internal/Connections.hs => Network/Protocol/XMPP/Connections.hs +2 -2
@@ 14,7 14,7 @@
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE OverloadedStrings #-}
-module Network.Protocol.XMPP.Internal.Connections
+module Network.Protocol.XMPP.Connections
( Server (..)
, xmlHeader
, startOfStream
@@ 28,7 28,7 @@ import qualified Text.XML.HXT.DOM.Interface as DOM
import qualified Text.XML.LibXML.SAX as SAX
import Network.Protocol.XMPP.JID (JID, formatJID)
-import Network.Protocol.XMPP.Internal.XML (qname, convertQName)
+import Network.Protocol.XMPP.XML (qname, convertQName)
data Server = Server
{ serverJID :: JID
R Network/Protocol/XMPP/Internal/Features.hs => Network/Protocol/XMPP/Features.hs +2 -2
@@ 13,7 13,7 @@
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
-module Network.Protocol.XMPP.Internal.Features
+module Network.Protocol.XMPP.Features
( Feature (..)
, parseFeatures
, parseFeature
@@ 23,7 23,7 @@ import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.Interface as DOM
import qualified Text.XML.HXT.DOM.XmlNode as XN
-import Network.Protocol.XMPP.Internal.XML (qname)
+import Network.Protocol.XMPP.XML (qname)
data Feature =
FeatureStartTLS Bool
R Network/Protocol/XMPP/Internal/Handle.hs => Network/Protocol/XMPP/Handle.hs +1 -1
@@ 13,7 13,7 @@
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
-module Network.Protocol.XMPP.Internal.Handle
+module Network.Protocol.XMPP.Handle
( Handle (..)
, startTLS
, hPutBytes
D Network/Protocol/XMPP/Internal/Stanza.hs => Network/Protocol/XMPP/Internal/Stanza.hs +0 -255
@@ 1,255 0,0 @@
--- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>
---
--- This program is free software: you can redistribute it and/or modify
--- it under the terms of the GNU General Public License as published by
--- the Free Software Foundation, either version 3 of the License, or
--- any later version.
---
--- This program is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of
--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
--- GNU General Public License for more details.
---
--- You should have received a copy of the GNU General Public License
--- along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-module Network.Protocol.XMPP.Internal.Stanza where
-import qualified Data.Text as T
-import Text.XML.HXT.DOM.Interface (XmlTree)
-import Text.XML.HXT.Arrow ((>>>))
-import qualified Text.XML.HXT.Arrow as A
-
-import Network.Protocol.XMPP.Internal.XML (element)
-import Network.Protocol.XMPP.JID (JID, parseJID, formatJID)
-
-class Stanza a where
- stanzaTo :: a -> Maybe JID
- stanzaFrom :: a -> Maybe JID
- stanzaID :: a -> Maybe T.Text
- stanzaLang :: a -> Maybe T.Text
- stanzaPayloads :: a -> [XmlTree]
- stanzaToTree :: a -> XmlTree
-
-data ReceivedStanza
- = ReceivedMessage Message
- | ReceivedPresence Presence
- | ReceivedIQ IQ
-
-data Message = Message
- { messageType :: MessageType
- , messageTo :: Maybe JID
- , messageFrom :: Maybe JID
- , messageID :: Maybe T.Text
- , messageLang :: Maybe T.Text
- , messagePayloads :: [XmlTree]
- }
-
-instance Stanza Message where
- stanzaTo = messageTo
- stanzaFrom = messageFrom
- stanzaID = messageID
- stanzaLang = messageLang
- stanzaPayloads = messagePayloads
- stanzaToTree x = stanzaToTree' x "message" typeStr where
- typeStr = case messageType x of
- MessageNormal -> "normal"
- MessageChat -> "chat"
- MessageGroupChat -> "groupchat"
- MessageHeadline -> "headline"
- MessageError -> "error"
-
-data MessageType
- = MessageNormal
- | MessageChat
- | MessageGroupChat
- | MessageHeadline
- | MessageError
- deriving (Show, Eq)
-
-emptyMessage :: MessageType -> Message
-emptyMessage t = Message
- { messageType = t
- , messageTo = Nothing
- , messageFrom = Nothing
- , messageID = Nothing
- , messageLang = Nothing
- , messagePayloads = []
- }
-
-data Presence = Presence
- { presenceType :: PresenceType
- , presenceTo :: Maybe JID
- , presenceFrom :: Maybe JID
- , presenceID :: Maybe T.Text
- , presenceLang :: Maybe T.Text
- , presencePayloads :: [XmlTree]
- }
-
-instance Stanza Presence where
- stanzaTo = presenceTo
- stanzaFrom = presenceFrom
- stanzaID = presenceID
- stanzaLang = presenceLang
- stanzaPayloads = presencePayloads
- stanzaToTree x = stanzaToTree' x "presence" typeStr where
- typeStr = case presenceType x of
- PresenceAvailable -> ""
- PresenceUnavailable -> "unavailable"
- PresenceSubscribe -> "subscribe"
- PresenceSubscribed -> "subscribed"
- PresenceUnsubscribe -> "unsubscribe"
- PresenceUnsubscribed -> "unsubscribed"
- PresenceProbe -> "probe"
- PresenceError -> "error"
-
-data PresenceType
- = PresenceAvailable
- | PresenceUnavailable
- | PresenceSubscribe
- | PresenceSubscribed
- | PresenceUnsubscribe
- | PresenceUnsubscribed
- | PresenceProbe
- | PresenceError
- deriving (Show, Eq)
-
-emptyPresence :: PresenceType -> Presence
-emptyPresence t = Presence
- { presenceType = t
- , presenceTo = Nothing
- , presenceFrom = Nothing
- , presenceID = Nothing
- , presenceLang = Nothing
- , presencePayloads = []
- }
-
-data IQ = IQ
- { iqType :: IQType
- , iqTo :: Maybe JID
- , iqFrom :: Maybe JID
- , iqID :: Maybe T.Text
- , iqLang :: Maybe T.Text
- , iqPayload :: XmlTree
- }
-
-instance Stanza IQ where
- stanzaTo = iqTo
- stanzaFrom = iqFrom
- stanzaID = iqID
- stanzaLang = iqLang
- stanzaPayloads iq = [iqPayload iq]
- stanzaToTree x = stanzaToTree' x "iq" typeStr where
- typeStr = case iqType x of
- IQGet -> "get"
- IQSet -> "set"
- IQResult -> "result"
- IQError -> "error"
-
-data IQType
- = IQGet
- | IQSet
- | IQResult
- | IQError
- deriving (Show, Eq)
-
-emptyIQ :: IQType -> XmlTree -> IQ
-emptyIQ t tree = IQ
- { iqType = t
- , iqTo = Nothing
- , iqFrom = Nothing
- , iqID = Nothing
- , iqLang = Nothing
- , iqPayload = tree
- }
-
-stanzaToTree' :: Stanza a => a -> String -> String -> XmlTree
-stanzaToTree' stanza name typeStr = element ("", name) attrs payloads where
- payloads = stanzaPayloads stanza
- attrs = concat
- [ mattr "to" $ fmap formatJID . stanzaTo
- , mattr "from" $ fmap formatJID . stanzaFrom
- , mattr "id" stanzaID
- , mattr "xml:lang" stanzaLang
- , if null typeStr then [] else [("", "type", typeStr)]
- ]
- mattr label f = case f stanza of
- Nothing -> []
- Just text -> [("", label, T.unpack text)]
-
-treeToStanza :: T.Text -> XmlTree -> Maybe ReceivedStanza
-treeToStanza ns tree = do
- treeNS <- runMA A.getNamespaceUri tree
- if T.pack treeNS == ns then Just () else Nothing
-
- treeName <- runMA A.getLocalPart tree
- case treeName of
- "message" -> ReceivedMessage `fmap` parseMessage tree
- "presence" -> ReceivedPresence `fmap` parsePresence tree
- "iq" -> ReceivedIQ `fmap` parseIQ tree
- _ -> Nothing
-
-parseMessage :: XmlTree -> Maybe Message
-parseMessage t = do
- typeStr <- runMA (A.getAttrValue "type") t
- msgType <- case typeStr of
- "normal" -> Just MessageNormal
- "chat" -> Just MessageChat
- "groupchat" -> Just MessageGroupChat
- "headline" -> Just MessageHeadline
- "error" -> Just MessageError
- _ -> Nothing
- msgTo <- xmlJID "to" t
- msgFrom <- xmlJID "from" t
- let msgID = T.pack `fmap` runMA (A.getAttrValue "id") t
- let msgLang = T.pack `fmap` runMA (A.getAttrValue "lang") t
- let payloads = A.runLA (A.getChildren >>> A.isElem) t
- return $ Message msgType msgTo msgFrom msgID msgLang payloads
-
-parsePresence :: XmlTree -> Maybe Presence
-parsePresence t = do
- let typeStr = maybe "" id $ runMA (A.getAttrValue "type") t
- pType <- case typeStr of
- "" -> Just PresenceAvailable
- "unavailable" -> Just PresenceUnavailable
- "subscribe" -> Just PresenceSubscribe
- "subscribed" -> Just PresenceSubscribed
- "unsubscribe" -> Just PresenceUnsubscribe
- "unsubscribed" -> Just PresenceUnsubscribed
- "probe" -> Just PresenceProbe
- "error" -> Just PresenceError
- _ -> Nothing
-
- msgTo <- xmlJID "to" t
- msgFrom <- xmlJID "from" t
- let msgID = T.pack `fmap` runMA (A.getAttrValue "id") t
- let msgLang = T.pack `fmap` runMA (A.getAttrValue "lang") t
- let payloads = A.runLA (A.getChildren >>> A.isElem) t
- return $ Presence pType msgTo msgFrom msgID msgLang payloads
-
-parseIQ :: XmlTree -> Maybe IQ
-parseIQ t = do
- typeStr <- runMA (A.getAttrValue "type") t
- iqType <- case typeStr of
- "get" -> Just IQGet
- "set" -> Just IQSet
- "result" -> Just IQResult
- "error" -> Just IQError
- _ -> Nothing
- msgTo <- xmlJID "to" t
- msgFrom <- xmlJID "from" t
- let msgID = T.pack `fmap` runMA (A.getAttrValue "id") t
- let msgLang = T.pack `fmap` runMA (A.getAttrValue "lang") t
- payload <- runMA (A.getChildren >>> A.isElem) t
- return $ IQ iqType msgTo msgFrom msgID msgLang payload
-
-xmlJID :: String -> XmlTree -> Maybe (Maybe JID)
-xmlJID attr t = case runMA (A.getAttrValue attr) t of
- Nothing -> Just Nothing
- Just raw -> case parseJID (T.pack raw) of
- Just jid -> Just (Just jid)
- Nothing -> Nothing
-
-runMA :: A.LA a b -> a -> Maybe b
-runMA arr x = case A.runLA arr x of
- [] -> Nothing
- (y:_) -> Just y
D Network/Protocol/XMPP/Internal/Stream.hs => Network/Protocol/XMPP/Internal/Stream.hs +0 -25
@@ 1,25 0,0 @@
--- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>
---
--- This program is free software: you can redistribute it and/or modify
--- it under the terms of the GNU General Public License as published by
--- the Free Software Foundation, either version 3 of the License, or
--- any later version.
---
--- This program is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of
--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
--- GNU General Public License for more details.
---
--- You should have received a copy of the GNU General Public License
--- along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-module Network.Protocol.XMPP.Internal.Stream
- ( Stream (..)
- ) where
-import qualified Data.Text as T
-import Text.XML.HXT.DOM.Interface (XmlTree)
-
-class Stream a where
- streamNamespace :: a -> T.Text
- putTree :: a -> XmlTree -> IO ()
- getTree :: a -> IO XmlTree
M Network/Protocol/XMPP/JID.hs => Network/Protocol/XMPP/JID.hs +3 -7
@@ 16,13 16,9 @@
{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.JID
( JID (..)
- , Node
- , Domain
- , Resource
-
- , strNode
- , strDomain
- , strResource
+ , Node (..)
+ , Domain (..)
+ , Resource (..)
, parseJID
, formatJID
M Network/Protocol/XMPP/Stanza.hs => Network/Protocol/XMPP/Stanza.hs +244 -8
@@ 14,13 14,7 @@
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
module Network.Protocol.XMPP.Stanza
- ( Stanza
- ( stanzaTo
- , stanzaFrom
- , stanzaID
- , stanzaLang
- , stanzaPayloads
- )
+ ( Stanza (..)
, ReceivedStanza (..)
, Message (..)
@@ 33,5 27,247 @@ module Network.Protocol.XMPP.Stanza
, emptyMessage
, emptyPresence
, emptyIQ
+
+ , stanzaToTree
+ , treeToStanza
) where
-import Network.Protocol.XMPP.Internal.Stanza
+
+import qualified Data.Text as T
+import Text.XML.HXT.DOM.Interface (XmlTree)
+import Text.XML.HXT.Arrow ((>>>))
+import qualified Text.XML.HXT.Arrow as A
+
+import Network.Protocol.XMPP.XML (element)
+import Network.Protocol.XMPP.JID (JID, parseJID, formatJID)
+
+class Stanza a where
+ stanzaTo :: a -> Maybe JID
+ stanzaFrom :: a -> Maybe JID
+ stanzaID :: a -> Maybe T.Text
+ stanzaLang :: a -> Maybe T.Text
+ stanzaPayloads :: a -> [XmlTree]
+ stanzaToTree :: a -> XmlTree
+
+data ReceivedStanza
+ = ReceivedMessage Message
+ | ReceivedPresence Presence
+ | ReceivedIQ IQ
+
+data Message = Message
+ { messageType :: MessageType
+ , messageTo :: Maybe JID
+ , messageFrom :: Maybe JID
+ , messageID :: Maybe T.Text
+ , messageLang :: Maybe T.Text
+ , messagePayloads :: [XmlTree]
+ }
+
+instance Stanza Message where
+ stanzaTo = messageTo
+ stanzaFrom = messageFrom
+ stanzaID = messageID
+ stanzaLang = messageLang
+ stanzaPayloads = messagePayloads
+ stanzaToTree x = stanzaToTree' x "message" typeStr where
+ typeStr = case messageType x of
+ MessageNormal -> "normal"
+ MessageChat -> "chat"
+ MessageGroupChat -> "groupchat"
+ MessageHeadline -> "headline"
+ MessageError -> "error"
+
+data MessageType
+ = MessageNormal
+ | MessageChat
+ | MessageGroupChat
+ | MessageHeadline
+ | MessageError
+ deriving (Show, Eq)
+
+emptyMessage :: MessageType -> Message
+emptyMessage t = Message
+ { messageType = t
+ , messageTo = Nothing
+ , messageFrom = Nothing
+ , messageID = Nothing
+ , messageLang = Nothing
+ , messagePayloads = []
+ }
+
+data Presence = Presence
+ { presenceType :: PresenceType
+ , presenceTo :: Maybe JID
+ , presenceFrom :: Maybe JID
+ , presenceID :: Maybe T.Text
+ , presenceLang :: Maybe T.Text
+ , presencePayloads :: [XmlTree]
+ }
+
+instance Stanza Presence where
+ stanzaTo = presenceTo
+ stanzaFrom = presenceFrom
+ stanzaID = presenceID
+ stanzaLang = presenceLang
+ stanzaPayloads = presencePayloads
+ stanzaToTree x = stanzaToTree' x "presence" typeStr where
+ typeStr = case presenceType x of
+ PresenceAvailable -> ""
+ PresenceUnavailable -> "unavailable"
+ PresenceSubscribe -> "subscribe"
+ PresenceSubscribed -> "subscribed"
+ PresenceUnsubscribe -> "unsubscribe"
+ PresenceUnsubscribed -> "unsubscribed"
+ PresenceProbe -> "probe"
+ PresenceError -> "error"
+
+data PresenceType
+ = PresenceAvailable
+ | PresenceUnavailable
+ | PresenceSubscribe
+ | PresenceSubscribed
+ | PresenceUnsubscribe
+ | PresenceUnsubscribed
+ | PresenceProbe
+ | PresenceError
+ deriving (Show, Eq)
+
+emptyPresence :: PresenceType -> Presence
+emptyPresence t = Presence
+ { presenceType = t
+ , presenceTo = Nothing
+ , presenceFrom = Nothing
+ , presenceID = Nothing
+ , presenceLang = Nothing
+ , presencePayloads = []
+ }
+
+data IQ = IQ
+ { iqType :: IQType
+ , iqTo :: Maybe JID
+ , iqFrom :: Maybe JID
+ , iqID :: Maybe T.Text
+ , iqLang :: Maybe T.Text
+ , iqPayload :: XmlTree
+ }
+
+instance Stanza IQ where
+ stanzaTo = iqTo
+ stanzaFrom = iqFrom
+ stanzaID = iqID
+ stanzaLang = iqLang
+ stanzaPayloads iq = [iqPayload iq]
+ stanzaToTree x = stanzaToTree' x "iq" typeStr where
+ typeStr = case iqType x of
+ IQGet -> "get"
+ IQSet -> "set"
+ IQResult -> "result"
+ IQError -> "error"
+
+data IQType
+ = IQGet
+ | IQSet
+ | IQResult
+ | IQError
+ deriving (Show, Eq)
+
+emptyIQ :: IQType -> XmlTree -> IQ
+emptyIQ t tree = IQ
+ { iqType = t
+ , iqTo = Nothing
+ , iqFrom = Nothing
+ , iqID = Nothing
+ , iqLang = Nothing
+ , iqPayload = tree
+ }
+
+stanzaToTree' :: Stanza a => a -> String -> String -> XmlTree
+stanzaToTree' stanza name typeStr = element ("", name) attrs payloads where
+ payloads = stanzaPayloads stanza
+ attrs = concat
+ [ mattr "to" $ fmap formatJID . stanzaTo
+ , mattr "from" $ fmap formatJID . stanzaFrom
+ , mattr "id" stanzaID
+ , mattr "xml:lang" stanzaLang
+ , if null typeStr then [] else [("", "type", typeStr)]
+ ]
+ mattr label f = case f stanza of
+ Nothing -> []
+ Just text -> [("", label, T.unpack text)]
+
+treeToStanza :: T.Text -> XmlTree -> Maybe ReceivedStanza
+treeToStanza ns tree = do
+ treeNS <- runMA A.getNamespaceUri tree
+ if T.pack treeNS == ns then Just () else Nothing
+
+ treeName <- runMA A.getLocalPart tree
+ case treeName of
+ "message" -> ReceivedMessage `fmap` parseMessage tree
+ "presence" -> ReceivedPresence `fmap` parsePresence tree
+ "iq" -> ReceivedIQ `fmap` parseIQ tree
+ _ -> Nothing
+
+parseMessage :: XmlTree -> Maybe Message
+parseMessage t = do
+ typeStr <- runMA (A.getAttrValue "type") t
+ msgType <- case typeStr of
+ "normal" -> Just MessageNormal
+ "chat" -> Just MessageChat
+ "groupchat" -> Just MessageGroupChat
+ "headline" -> Just MessageHeadline
+ "error" -> Just MessageError
+ _ -> Nothing
+ msgTo <- xmlJID "to" t
+ msgFrom <- xmlJID "from" t
+ let msgID = T.pack `fmap` runMA (A.getAttrValue "id") t
+ let msgLang = T.pack `fmap` runMA (A.getAttrValue "lang") t
+ let payloads = A.runLA (A.getChildren >>> A.isElem) t
+ return $ Message msgType msgTo msgFrom msgID msgLang payloads
+
+parsePresence :: XmlTree -> Maybe Presence
+parsePresence t = do
+ let typeStr = maybe "" id $ runMA (A.getAttrValue "type") t
+ pType <- case typeStr of
+ "" -> Just PresenceAvailable
+ "unavailable" -> Just PresenceUnavailable
+ "subscribe" -> Just PresenceSubscribe
+ "subscribed" -> Just PresenceSubscribed
+ "unsubscribe" -> Just PresenceUnsubscribe
+ "unsubscribed" -> Just PresenceUnsubscribed
+ "probe" -> Just PresenceProbe
+ "error" -> Just PresenceError
+ _ -> Nothing
+
+ msgTo <- xmlJID "to" t
+ msgFrom <- xmlJID "from" t
+ let msgID = T.pack `fmap` runMA (A.getAttrValue "id") t
+ let msgLang = T.pack `fmap` runMA (A.getAttrValue "lang") t
+ let payloads = A.runLA (A.getChildren >>> A.isElem) t
+ return $ Presence pType msgTo msgFrom msgID msgLang payloads
+
+parseIQ :: XmlTree -> Maybe IQ
+parseIQ t = do
+ typeStr <- runMA (A.getAttrValue "type") t
+ iqType <- case typeStr of
+ "get" -> Just IQGet
+ "set" -> Just IQSet
+ "result" -> Just IQResult
+ "error" -> Just IQError
+ _ -> Nothing
+ msgTo <- xmlJID "to" t
+ msgFrom <- xmlJID "from" t
+ let msgID = T.pack `fmap` runMA (A.getAttrValue "id") t
+ let msgLang = T.pack `fmap` runMA (A.getAttrValue "lang") t
+ payload <- runMA (A.getChildren >>> A.isElem) t
+ return $ IQ iqType msgTo msgFrom msgID msgLang payload
+
+xmlJID :: String -> XmlTree -> Maybe (Maybe JID)
+xmlJID attr t = case runMA (A.getAttrValue attr) t of
+ Nothing -> Just Nothing
+ Just raw -> case parseJID (T.pack raw) of
+ Just jid -> Just (Just jid)
+ Nothing -> Nothing
+
+runMA :: A.LA a b -> a -> Maybe b
+runMA arr x = case A.runLA arr x of
+ [] -> Nothing
+ (y:_) -> Just y
M Network/Protocol/XMPP/Stream.hs => Network/Protocol/XMPP/Stream.hs +13 -7
@@ 14,15 14,21 @@
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
module Network.Protocol.XMPP.Stream
- ( Stream
+ ( Stream (..)
, putStanza
, getStanza
) where
-import Network.Protocol.XMPP.Internal.Stream
-import Network.Protocol.XMPP.Internal.Stanza
+import qualified Data.Text as T
+import Text.XML.HXT.DOM.Interface (XmlTree)
+import qualified Network.Protocol.XMPP.Stanza as S
-putStanza :: (Stream stream, Stanza stanza) => stream -> stanza -> IO ()
-putStanza stream = putTree stream . stanzaToTree
+class Stream a where
+ streamNamespace :: a -> T.Text
+ putTree :: a -> XmlTree -> IO ()
+ getTree :: a -> IO XmlTree
-getStanza :: Stream stream => stream -> IO (Maybe ReceivedStanza)
-getStanza stream = treeToStanza (streamNamespace stream) `fmap` getTree stream
+putStanza :: (Stream stream, S.Stanza stanza) => stream -> stanza -> IO ()
+putStanza stream = putTree stream . S.stanzaToTree
+
+getStanza :: Stream stream => stream -> IO (Maybe S.ReceivedStanza)
+getStanza stream = S.treeToStanza (streamNamespace stream) `fmap` getTree stream
R Network/Protocol/XMPP/Internal/XML.hs => Network/Protocol/XMPP/XML.hs +2 -2
@@ 13,7 13,7 @@
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
-module Network.Protocol.XMPP.Internal.XML
+module Network.Protocol.XMPP.XML
( getTree
, putTree
, readEventsUntil
@@ 22,7 22,7 @@ module Network.Protocol.XMPP.Internal.XML
, attr
, qname
) where
-import qualified Network.Protocol.XMPP.Internal.Handle as H
+import qualified Network.Protocol.XMPP.Handle as H
import qualified Data.ByteString.Char8 as C8
-- XML Parsing
M network-protocol-xmpp.cabal => network-protocol-xmpp.cabal +7 -9
@@ 34,17 34,15 @@ library
exposed-modules:
Network.Protocol.XMPP
+
+ other-modules:
+ Network.Protocol.XMPP.Authentication
Network.Protocol.XMPP.Client
Network.Protocol.XMPP.Component
+ Network.Protocol.XMPP.Connections
+ Network.Protocol.XMPP.Features
+ Network.Protocol.XMPP.Handle
Network.Protocol.XMPP.JID
Network.Protocol.XMPP.Stanza
Network.Protocol.XMPP.Stream
-
- other-modules:
- Network.Protocol.XMPP.Internal.Authentication
- Network.Protocol.XMPP.Internal.Connections
- Network.Protocol.XMPP.Internal.Features
- Network.Protocol.XMPP.Internal.Handle
- Network.Protocol.XMPP.Internal.Stanza
- Network.Protocol.XMPP.Internal.Stream
- Network.Protocol.XMPP.Internal.XML
+ Network.Protocol.XMPP.XML