M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +18 -30
@@ 20,14 20,10 @@ module Network.Protocol.XMPP.Client
) where
import Control.Monad.Error (throwError)
import Control.Monad.Trans (liftIO)
-import Network (connectTo)
-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 qualified System.IO as IO
import Data.ByteString (ByteString)
import qualified Data.Text.Lazy as T
+import Network (connectTo)
+import qualified System.IO as IO
import qualified Network.Protocol.XMPP.Client.Authentication as A
import qualified Network.Protocol.XMPP.Connections as C
@@ 35,7 31,7 @@ import qualified Network.Protocol.XMPP.Client.Features as F
import qualified Network.Protocol.XMPP.Handle as H
import qualified Network.Protocol.XMPP.JID as J
import qualified Network.Protocol.XMPP.Monad as M
-import Network.Protocol.XMPP.XML (element, qname)
+import qualified Network.Protocol.XMPP.XML as X
import Network.Protocol.XMPP.ErrorT
import Network.Protocol.XMPP.Stanza
@@ 64,14 60,14 @@ newStream :: J.JID -> M.XMPP [F.Feature]
newStream jid = do
M.putBytes $ C.xmlHeader "jabber:client" jid
M.readEvents C.startOfStream
- F.parseFeatures `fmap` M.getTree
+ F.parseFeatures `fmap` M.getElement
tryTLS :: J.JID -> [F.Feature] -> ([F.Feature] -> M.XMPP a) -> M.XMPP a
tryTLS sjid features m
| not (streamSupportsTLS features) = m features
| otherwise = do
- M.putTree xmlStartTLS
- M.getTree
+ M.putElement xmlStartTLS
+ M.getElement
h <- M.getHandle
eitherTLS <- liftIO $ runErrorT $ H.startTLS h
case eitherTLS of
@@ 90,11 86,11 @@ bindJID jid = do
-- Bind
M.putStanza . bindStanza . J.jidResource $ jid
bindResult <- M.getStanza
-
- let jidArrow =
- A.deep (A.hasQName (qname "urn:ietf:params:xml:ns:xmpp-bind" "jid"))
- >>> A.getChildren
- >>> A.getText
+ let getJID e =
+ X.elementChildren e
+ >>= X.hasName (X.Name "jid" (Just "urn:ietf:params:xml:ns:xmpp-bind") Nothing)
+ >>= X.elementNodes
+ >>= X.getText
let maybeJID = do
iq <- case bindResult of
@@ 102,9 98,9 @@ bindJID jid = do
_ -> Nothing
payload <- iqPayload iq
- case A.runLA jidArrow payload of
+ case getJID payload of
[] -> Nothing
- (str:_) -> J.parseJID (T.pack str)
+ (str:_) -> J.parseJID str
returnedJID <- case maybeJID of
Just x -> return x
@@ 121,27 117,19 @@ bindJID jid = do
bindStanza :: Maybe J.Resource -> IQ
bindStanza resource = (emptyIQ IQSet) { iqPayload = Just payload } where
- payload = element ("", "bind")
- [("", "xmlns", "urn:ietf:params:xml:ns:xmpp-bind")]
- requested
+ payload = X.nselement "urn:ietf:params:xml:ns:xmpp-bind" "bind" [] requested
requested = case fmap J.strResource resource of
Nothing -> []
- Just x -> [element ("", "resource")
- []
- [XN.mkText (T.unpack x)]]
+ Just x -> [X.NodeElement $ X.element "resource" [] [X.NodeText x]]
sessionStanza :: IQ
sessionStanza = (emptyIQ IQSet) { iqPayload = Just payload } where
- payload = element ("", "session")
- [("", "xmlns", "urn:ietf:params:xml:ns:xmpp-session")]
- []
+ payload = X.nselement "urn:ietf:params:xml:ns:xmpp-session" "session" [] []
streamSupportsTLS :: [F.Feature] -> Bool
streamSupportsTLS = any isStartTLS where
isStartTLS (F.FeatureStartTLS _) = True
isStartTLS _ = False
-xmlStartTLS :: DOM.XmlTree
-xmlStartTLS = element ("", "starttls")
- [("", "xmlns", "urn:ietf:params:xml:ns:xmpp-tls")]
- []
+xmlStartTLS :: X.Element
+xmlStartTLS = X.nselement "urn:ietf:params:xml:ns:xmpp-tls" "starttls" [] []
M Network/Protocol/XMPP/Client/Authentication.hs => Network/Protocol/XMPP/Client/Authentication.hs +26 -33
@@ 28,16 28,11 @@ import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import Data.Typeable (Typeable)
-
-import Text.XML.HXT.Arrow ((>>>))
-import qualified Text.XML.HXT.Arrow as A
-import qualified Text.XML.HXT.DOM.XmlNode as XN
-import Text.XML.HXT.DOM.Interface (XmlTree)
import qualified Network.Protocol.SASL.GNU as SASL
import qualified Network.Protocol.XMPP.Monad as M
+import qualified Network.Protocol.XMPP.XML as X
import Network.Protocol.XMPP.JID (JID, formatJID, jidResource)
-import Network.Protocol.XMPP.XML (element, qname)
data Result = Success | Failure
deriving (Show, Eq)
@@ 68,7 63,7 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
Just mechanism -> authSasl ctx mechanism
case res of
Right Success -> return ()
- Right Failure -> E.throwError $ M.AuthenticationFailure
+ Right Failure -> E.throwError M.AuthenticationFailure
Left (XmppError err) -> E.throwError err
Left (SaslError err) -> E.throwError $ M.AuthenticationError err
@@ 82,10 77,9 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
SASL.setProperty SASL.PropertyHostname $ utf8 hostname
(b64text, rc) <- SASL.step64 $ B.pack ""
- putTree ctx $ element ("", "auth")
- [ ("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")
- , ("", "mechanism", B.unpack mechBytes)]
- [XN.mkText $ B.unpack b64text]
+ putElement ctx $ X.nselement "urn:ietf:params:xml:ns:xmpp-sasl" "auth"
+ [("mechanism", TL.pack $ B.unpack mechBytes)]
+ [X.NodeText $ TL.pack $ B.unpack b64text]
case rc of
SASL.Complete -> saslFinish ctx
@@ 97,40 91,39 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
saslLoop :: M.Context -> SASL.Session Result
saslLoop ctx = do
- challengeText <- liftIO $ A.runX (
- A.arrIO (\_ -> getTree ctx)
- >>> A.getChildren
- >>> A.hasQName (qname "urn:ietf:params:xml:ns:xmpp-sasl" "challenge")
- >>> A.getChildren >>> A.getText)
+ elemt <- getElement ctx
+ let challengeText =
+ return elemt
+ >>= X.hasName (X.Name "challenge" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing)
+ >>= X.elementNodes
+ >>= X.getText
when (null challengeText) $ saslError "Received empty challenge"
- (b64text, rc) <- SASL.step64 $ B.pack $ concat challengeText
- putTree ctx $ element ("", "response")
- [("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")]
- [XN.mkText $ B.unpack b64text]
+ (b64text, rc) <- SASL.step64 . B.pack . concatMap TL.unpack $ challengeText
+ putElement ctx $ X.nselement "urn:ietf:params:xml:ns:xmpp-sasl" "response"
+ [] [X.NodeText $ TL.pack $ B.unpack b64text]
case rc of
SASL.Complete -> saslFinish ctx
SASL.NeedsMore -> saslLoop ctx
saslFinish :: M.Context -> SASL.Session Result
-saslFinish ctx = liftIO $ do
- successElem <- A.runX (
- A.arrIO (\_ -> getTree ctx)
- >>> A.getChildren
- >>> A.hasQName (qname "urn:ietf:params:xml:ns:xmpp-sasl" "success"))
-
- return $ if null successElem then Failure else Success
+saslFinish ctx = do
+ elemt <- getElement ctx
+ let success =
+ return elemt
+ >>= X.hasName (X.Name "success" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing)
+ return $ if null success then Failure else Success
-putTree :: M.Context -> XmlTree -> SASL.Session ()
-putTree ctx tree = liftIO $ do
- res <- M.runXMPP ctx $ M.putTree tree
+putElement :: M.Context -> X.Element -> SASL.Session ()
+putElement ctx elemt = liftIO $ do
+ res <- M.runXMPP ctx $ M.putElement elemt
case res of
Left err -> Exc.throwIO $ XmppError err
Right x -> return x
-getTree :: M.Context -> IO XmlTree
-getTree ctx = do
- res <- M.runXMPP ctx $ M.getTree
+getElement :: M.Context -> SASL.Session X.Element
+getElement ctx = liftIO $ do
+ res <- M.runXMPP ctx M.getElement
case res of
Left err -> Exc.throwIO $ XmppError err
Right x -> return x
M Network/Protocol/XMPP/Client/Features.hs => Network/Protocol/XMPP/Client/Features.hs +30 -32
@@ 13,17 13,16 @@
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
+{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.Client.Features
( Feature (..)
, parseFeatures
, parseFeature
) where
+import Control.Arrow ((&&&))
import qualified Data.ByteString.Char8 as B
-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.XML (qname)
+import qualified Data.Text.Lazy as TL
+import qualified Network.Protocol.XMPP.XML as X
data Feature =
FeatureStartTLS Bool
@@ 31,40 30,39 @@ data Feature =
| FeatureRegister
| FeatureBind
| FeatureSession
- | FeatureUnknown DOM.XmlTree
+ | FeatureUnknown X.Element
deriving (Show, Eq)
-parseFeatures :: DOM.XmlTree -> [Feature]
-parseFeatures = A.runLA $
- A.getChildren
- >>> A.hasQName qnameFeatures
- >>> A.getChildren
- >>> A.arrL (\t' -> [parseFeature t'])
+parseFeatures :: X.Element -> [Feature]
+parseFeatures elemt =
+ X.hasName nameFeatures elemt
+ >>= X.elementChildren
+ >>= return . parseFeature
-parseFeature :: DOM.XmlTree -> Feature
-parseFeature t = feature where
- mkPair = maybe ("", "") $ DOM.namespaceUri &&& DOM.localPart
- feature = case mkPair (XN.getName t) of
- ("urn:ietf:params:xml:ns:xmpp-tls", "starttls") -> parseFeatureTLS t
- ("urn:ietf:params:xml:ns:xmpp-sasl", "mechanisms") -> parseFeatureSASL t
+parseFeature :: X.Element -> Feature
+parseFeature elemt = feature where
+ unpackName = (maybe "" id . X.nameNamespace) &&& X.nameLocalName
+ feature = case unpackName (X.elementName elemt) of
+ ("urn:ietf:params:xml:ns:xmpp-tls", "starttls") -> parseFeatureTLS elemt
+ ("urn:ietf:params:xml:ns:xmpp-sasl", "mechanisms") -> parseFeatureSASL elemt
("http://jabber.org/features/iq-register", "register") -> FeatureRegister
("urn:ietf:params:xml:ns:xmpp-bind", "bind") -> FeatureBind
("urn:ietf:params:xml:ns:xmpp-session", "session") -> FeatureSession
- _ -> FeatureUnknown t
+ _ -> FeatureUnknown elemt
-parseFeatureTLS :: DOM.XmlTree -> Feature
-parseFeatureTLS t = FeatureStartTLS True -- TODO: detect whether or not required
+parseFeatureTLS :: X.Element -> Feature
+parseFeatureTLS _ = FeatureStartTLS True -- TODO: detect whether or not required
-parseFeatureSASL :: DOM.XmlTree -> Feature
-parseFeatureSASL = FeatureSASL . A.runLA (
- A.getChildren
- >>> A.hasQName qnameMechanism
- >>> A.getChildren
- >>> A.getText
- >>> A.arr B.pack)
+parseFeatureSASL :: X.Element -> Feature
+parseFeatureSASL e = FeatureSASL $
+ X.elementChildren e
+ >>= X.hasName nameMechanism
+ >>= X.elementNodes
+ >>= X.getText
+ >>= return . B.pack . TL.unpack
-qnameMechanism :: DOM.QName
-qnameMechanism = qname "urn:ietf:params:xml:ns:xmpp-sasl" "mechanism"
+nameMechanism :: X.Name
+nameMechanism = X.Name "mechanism" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing
-qnameFeatures :: DOM.QName
-qnameFeatures = qname "http://etherx.jabber.org/streams" "features"
+nameFeatures :: X.Name
+nameFeatures = X.Name "features" (Just "http://etherx.jabber.org/streams") Nothing
M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +11 -21
@@ 27,10 27,6 @@ import qualified Data.ByteString.Lazy as BL
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.Encoding as TE
import Network (connectTo)
-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.SASL.GNU (sha1)
import qualified System.IO as IO
import qualified Text.XML.LibXML.SAX as SAX
@@ 38,7 34,7 @@ import qualified Text.XML.LibXML.SAX as SAX
import qualified Network.Protocol.XMPP.Connections as C
import qualified Network.Protocol.XMPP.Handle as H
import qualified Network.Protocol.XMPP.Monad as M
-import Network.Protocol.XMPP.XML (element, qname)
+import qualified Network.Protocol.XMPP.XML as X
import Network.Protocol.XMPP.JID (JID)
runComponent :: C.Server
@@ 66,33 62,27 @@ beginStream jid = do
parseStreamID :: SAX.Event -> Maybe T.Text
parseStreamID (SAX.BeginElement _ attrs) = sid where
sid = case idAttrs of
- (x:_) -> Just . T.pack . SAX.attributeValue $ x
+ (x:_) -> Just . X.attributeValue $ x
_ -> Nothing
- idAttrs = filter (matchingName . SAX.attributeName) attrs
- matchingName n = and
- [ SAX.qnameNamespace n == "jabber:component:accept"
- , SAX.qnameLocalName n == "id"
- ]
+ idAttrs = filter (matchingName . X.attributeName) attrs
+ matchingName = (== X.Name "jid" (Just "jabber:component:accept") Nothing)
parseStreamID _ = Nothing
authenticate :: T.Text -> T.Text -> M.XMPP ()
authenticate streamID password = do
let bytes = buildSecret streamID password
let digest = showDigest $ sha1 bytes
- M.putTree $ element ("", "handshake") [] [XN.mkText digest]
- result <- M.getTree
- let accepted = A.runLA $
- A.getChildren
- >>> A.hasQName (qname "jabber:component:accept" "handshake")
- when (null (accepted result)) $
+ M.putElement $ X.element "handshake" [] [X.NodeText digest]
+ result <- M.getElement
+ let nameHandshake = X.Name "handshake" (Just "jabber:component:accept") Nothing
+ when (null (X.hasName nameHandshake result)) $
throwError M.ComponentHandshakeFailed
buildSecret :: T.Text -> T.Text -> B.ByteString
buildSecret sid password = B.concat . BL.toChunks $ bytes where
- escape = T.pack . DOM.attrEscapeXml . T.unpack
- bytes = TE.encodeUtf8 $ escape $ T.append sid password
+ bytes = TE.encodeUtf8 $ X.escape $ T.append sid password
-showDigest :: B.ByteString -> String
-showDigest = concatMap wordToHex . B.unpack where
+showDigest :: B.ByteString -> T.Text
+showDigest = T.pack . concatMap wordToHex . B.unpack where
wordToHex x = [hexDig $ shiftR x 4, hexDig $ x .&. 0xF]
hexDig = intToDigit . fromIntegral
M Network/Protocol/XMPP/Connections.hs => Network/Protocol/XMPP/Connections.hs +5 -8
@@ 24,11 24,10 @@ import Network (HostName, PortID)
import qualified Data.ByteString.Lazy as B
import qualified Data.Text.Lazy as T
import Data.Text.Lazy.Encoding (encodeUtf8)
-import qualified Text.XML.HXT.DOM.Interface as DOM
import qualified Text.XML.LibXML.SAX as SAX
+import qualified Network.Protocol.XMPP.XML as X
import Network.Protocol.XMPP.JID (JID, formatJID)
-import Network.Protocol.XMPP.XML (qname, convertQName)
data Server = Server
{ serverJID :: JID
@@ 41,8 40,7 @@ data Server = Server
-- attributes.
xmlHeader :: T.Text -> JID -> B.ByteString
xmlHeader ns jid = encodeUtf8 header where
- escape = T.pack . DOM.attrEscapeXml . T.unpack
- attr x = T.concat ["\"", escape x, "\""]
+ attr x = T.concat ["\"", X.escape x, "\""]
header = T.concat
[ "<?xml version='1.0'?>\n"
, "<stream:stream xmlns=" , attr ns
@@ 53,9 51,8 @@ xmlHeader ns jid = encodeUtf8 header where
startOfStream :: Integer -> SAX.Event -> Bool
startOfStream depth event = case (depth, event) of
- (1, (SAX.BeginElement elemName _)) ->
- qnameStream == convertQName elemName
+ (1, (SAX.BeginElement elemName _)) -> qnameStream == elemName
_ -> False
-qnameStream :: DOM.QName
-qnameStream = qname "http://etherx.jabber.org/streams" "stream"
+qnameStream :: X.Name
+qnameStream = X.Name "stream" (Just "http://etherx.jabber.org/streams") Nothing
M Network/Protocol/XMPP/Monad.hs => Network/Protocol/XMPP/Monad.hs +40 -31
@@ 14,6 14,7 @@
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.Monad
( XMPP (..)
, Error (..)
@@ 26,11 27,11 @@ module Network.Protocol.XMPP.Monad
, getContext
, readEvents
- , getTree
+ , getElement
, getStanza
, putBytes
- , putTree
+ , putElement
, putStanza
) where
import Control.Monad.Trans (MonadIO, liftIO)
@@ 38,11 39,8 @@ import qualified Control.Monad.Error as E
import qualified Control.Monad.Reader as R
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Text.Lazy (Text)
-
-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 Data.Text.Lazy.Encoding (encodeUtf8)
+import qualified Data.FailableList as FL
import qualified Text.XML.LibXML.SAX as SAX
import Network.Protocol.XMPP.ErrorT
@@ 51,11 49,12 @@ import qualified Network.Protocol.XMPP.Stanza as S
import qualified Network.Protocol.XMPP.XML as X
data Error
- = InvalidStanza DOM.XmlTree
+ = InvalidStanza X.Element
| InvalidBindResult S.ReceivedStanza
| AuthenticationFailure
| AuthenticationError Text
| TransportError Text
+ | MarkupError Text
| NoComponentStreamID
| ComponentHandshakeFailed
deriving (Show)
@@ 84,13 83,13 @@ runXMPP ctx xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) ctx
startXMPP :: H.Handle -> Text -> XMPP a -> IO (Either Error a)
startXMPP h ns xmpp = do
- sax <- SAX.mkParser
+ sax <- SAX.newParser
runXMPP (Context h ns sax) xmpp
restartXMPP :: Maybe H.Handle -> XMPP a -> XMPP a
restartXMPP newH xmpp = do
Context oldH ns _ <- getContext
- sax <- liftIO $ SAX.mkParser
+ sax <- liftIO SAX.newParser
let ctx = Context (maybe oldH id newH) ns sax
XMPP $ R.local (const ctx) (unXMPP xmpp)
@@ 114,35 113,45 @@ putBytes bytes = do
h <- getHandle
liftTLS $ H.hPutBytes h bytes
-putTree :: DOM.XmlTree -> XMPP ()
-putTree t = do
- let root = XN.mkRoot [] [t]
- [text] <- liftIO $ A.runX (A.constA root >>> A.writeDocumentToString [
- (A.a_no_xml_pi, "1")
- ])
- putBytes $ B.pack text
+putElement :: X.Element -> XMPP ()
+putElement = putBytes . encodeUtf8 . X.serialiseElement
putStanza :: S.Stanza a => a -> XMPP ()
-putStanza = putTree . S.stanzaToTree
+putStanza = putElement . S.stanzaToElement
readEvents :: (Integer -> SAX.Event -> Bool) -> XMPP [SAX.Event]
-readEvents done = do
- Context h _ p <- getContext
- let nextChar = do
- -- TODO: read in larger increments
- bytes <- liftTLS $ H.hGetBytes h 1
- return $ B.unpack bytes
- X.readEvents done nextChar p
-
-getTree :: XMPP DOM.XmlTree
-getTree = X.eventsToTree `fmap` readEvents endOfTree where
+readEvents done = xmpp where
+ xmpp = do
+ Context h _ p <- getContext
+ let nextEvents = do
+ -- TODO: read in larger increments
+ bytes <- liftTLS $ H.hGetBytes h 1
+ failable <- liftIO $ SAX.parse p bytes False
+ failableToList failable
+ X.readEvents done nextEvents
+
+ failableToList f = case f of
+ FL.Fail (SAX.Error e) -> E.throwError $ MarkupError e
+ FL.Done -> return []
+ FL.Next e es -> do
+ es' <- failableToList es
+ return $ e : es'
+
+getElement :: XMPP X.Element
+getElement = xmpp where
+ xmpp = do
+ events <- readEvents endOfTree
+ case X.eventsToElement events of
+ Just x -> return x
+ Nothing -> E.throwError $ MarkupError "getElement: invalid event list"
+
endOfTree 0 (SAX.EndElement _) = True
endOfTree _ _ = False
getStanza :: XMPP S.ReceivedStanza
getStanza = do
- tree <- getTree
+ elemt <- getElement
Context _ ns _ <- getContext
- case S.treeToStanza ns tree of
+ case S.elementToStanza ns elemt of
Just x -> return x
- Nothing -> E.throwError $ InvalidStanza tree
+ Nothing -> E.throwError $ InvalidStanza elemt
M Network/Protocol/XMPP/Stanza.hs => Network/Protocol/XMPP/Stanza.hs +60 -66
@@ 13,6 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/>.
+{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.Stanza
( Stanza (..)
@@ 28,24 29,21 @@ module Network.Protocol.XMPP.Stanza
, emptyPresence
, emptyIQ
- , treeToStanza
+ , elementToStanza
) where
+import Control.Monad (when)
import qualified Data.Text.Lazy 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 qualified Network.Protocol.XMPP.XML as X
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
+ stanzaTo :: a -> Maybe JID
+ stanzaFrom :: a -> Maybe JID
+ stanzaID :: a -> Maybe T.Text
+ stanzaLang :: a -> Maybe T.Text
+ stanzaPayloads :: a -> [X.Element]
+ stanzaToElement :: a -> X.Element
data ReceivedStanza
= ReceivedMessage Message
@@ 59,7 57,7 @@ data Message = Message
, messageFrom :: Maybe JID
, messageID :: Maybe T.Text
, messageLang :: Maybe T.Text
- , messagePayloads :: [XmlTree]
+ , messagePayloads :: [X.Element]
}
deriving (Show)
@@ 69,7 67,7 @@ instance Stanza Message where
stanzaID = messageID
stanzaLang = messageLang
stanzaPayloads = messagePayloads
- stanzaToTree x = stanzaToTree' x "message" typeStr where
+ stanzaToElement x = stanzaToElement' x "message" typeStr where
typeStr = case messageType x of
MessageNormal -> "normal"
MessageChat -> "chat"
@@ 101,7 99,7 @@ data Presence = Presence
, presenceFrom :: Maybe JID
, presenceID :: Maybe T.Text
, presenceLang :: Maybe T.Text
- , presencePayloads :: [XmlTree]
+ , presencePayloads :: [X.Element]
}
deriving (Show)
@@ 111,7 109,7 @@ instance Stanza Presence where
stanzaID = presenceID
stanzaLang = presenceLang
stanzaPayloads = presencePayloads
- stanzaToTree x = stanzaToTree' x "presence" typeStr where
+ stanzaToElement x = stanzaToElement' x "presence" typeStr where
typeStr = case presenceType x of
PresenceAvailable -> ""
PresenceUnavailable -> "unavailable"
@@ 149,7 147,7 @@ data IQ = IQ
, iqFrom :: Maybe JID
, iqID :: Maybe T.Text
, iqLang :: Maybe T.Text
- , iqPayload :: Maybe XmlTree
+ , iqPayload :: Maybe X.Element
}
deriving (Show)
@@ 159,9 157,9 @@ instance Stanza IQ where
stanzaID = iqID
stanzaLang = iqLang
stanzaPayloads iq = case iqPayload iq of
- Just tree -> [tree]
+ Just elemt -> [elemt]
Nothing -> []
- stanzaToTree x = stanzaToTree' x "iq" typeStr where
+ stanzaToElement x = stanzaToElement' x "iq" typeStr where
typeStr = case iqType x of
IQGet -> "get"
IQSet -> "set"
@@ 185,36 183,35 @@ emptyIQ t = IQ
, iqPayload = Nothing
}
-stanzaToTree' :: Stanza a => a -> String -> String -> XmlTree
-stanzaToTree' stanza name typeStr = element ("", name) attrs payloads where
- payloads = stanzaPayloads stanza
+stanzaToElement' :: Stanza a => a -> T.Text -> T.Text -> X.Element
+stanzaToElement' stanza name typeStr = X.element name attrs payloads where
+ payloads = map X.NodeElement $ 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)]
+ , if T.null typeStr then [] else [("type", typeStr)]
]
mattr label f = case f stanza of
Nothing -> []
- Just text -> [("", label, T.unpack text)]
+ Just text -> [(label, text)]
-treeToStanza :: T.Text -> XmlTree -> Maybe ReceivedStanza
-treeToStanza ns root = do
- tree <- runMA (A.getChildren >>> A.isElem) root
- treeNS <- runMA A.getNamespaceUri tree
- if T.pack treeNS == ns then Just () else Nothing
+elementToStanza :: T.Text -> X.Element -> Maybe ReceivedStanza
+elementToStanza ns elemt = do
+ let elemNS = X.nameNamespace . X.elementName $ elemt
+ when (elemNS /= Just ns) Nothing
- treeName <- runMA A.getLocalPart tree
- case treeName of
- "message" -> ReceivedMessage `fmap` parseMessage tree
- "presence" -> ReceivedPresence `fmap` parsePresence tree
- "iq" -> ReceivedIQ `fmap` parseIQ tree
+ let elemName = X.nameLocalName . X.elementName $ elemt
+ case elemName of
+ "message" -> ReceivedMessage `fmap` parseMessage elemt
+ "presence" -> ReceivedPresence `fmap` parsePresence elemt
+ "iq" -> ReceivedIQ `fmap` parseIQ elemt
_ -> Nothing
-parseMessage :: XmlTree -> Maybe Message
-parseMessage t = do
- typeStr <- runMA (A.getAttrValue "type") t
+parseMessage :: X.Element -> Maybe Message
+parseMessage elemt = do
+ typeStr <- X.getattr (X.name "type") elemt
msgType <- case typeStr of
"normal" -> Just MessageNormal
"chat" -> Just MessageChat
@@ 222,16 219,16 @@ parseMessage t = do
"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
+ msgTo <- xmlJID "to" elemt
+ msgFrom <- xmlJID "from" elemt
+ let msgID = X.getattr (X.name "id") elemt
+ let msgLang = X.getattr (X.name "lang") elemt
+ let payloads = X.elementChildren elemt
return $ Message msgType msgTo msgFrom msgID msgLang payloads
-parsePresence :: XmlTree -> Maybe Presence
-parsePresence t = do
- let typeStr = maybe "" id $ runMA (A.getAttrValue "type") t
+parsePresence :: X.Element -> Maybe Presence
+parsePresence elemt = do
+ let typeStr = maybe "" id $ X.getattr (X.name "type") elemt
pType <- case typeStr of
"" -> Just PresenceAvailable
"unavailable" -> Just PresenceUnavailable
@@ 243,16 240,16 @@ parsePresence t = do
"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
+ msgTo <- xmlJID "to" elemt
+ msgFrom <- xmlJID "from" elemt
+ let msgID = X.getattr (X.name "id") elemt
+ let msgLang = X.getattr (X.name "lang") elemt
+ let payloads = X.elementChildren elemt
return $ Presence pType msgTo msgFrom msgID msgLang payloads
-parseIQ :: XmlTree -> Maybe IQ
-parseIQ t = do
- typeStr <- runMA (A.getAttrValue "type") t
+parseIQ :: X.Element -> Maybe IQ
+parseIQ elemt = do
+ typeStr <- X.getattr (X.name "type") elemt
iqType <- case typeStr of
"get" -> Just IQGet
"set" -> Just IQSet
@@ 260,21 257,18 @@ parseIQ t = do
"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
- let payload = runMA (A.getChildren >>> A.isElem) t
+ msgTo <- xmlJID "to" elemt
+ msgFrom <- xmlJID "from" elemt
+ let msgID = X.getattr (X.name "id") elemt
+ let msgLang = X.getattr (X.name "lang") elemt
+ let payload = case X.elementChildren elemt of
+ [] -> Nothing
+ child:_ -> Just child
return $ IQ iqType msgTo msgFrom msgID msgLang payload
-xmlJID :: String -> XmlTree -> Maybe (Maybe JID)
-xmlJID attr t = case runMA (A.getAttrValue attr) t of
+xmlJID :: T.Text -> X.Element -> Maybe (Maybe JID)
+xmlJID name elemt = case X.getattr (X.name name) elemt of
Nothing -> Just Nothing
- Just raw -> case parseJID (T.pack raw) of
+ Just raw -> case parseJID 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/XML.hs => Network/Protocol/XMPP/XML.hs +84 -94
@@ 1,4 1,4 @@
--- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com>
+-- 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
@@ 13,32 13,94 @@
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
+{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.XML
- ( readEvents
- , eventsToTree
- , convertQName
+ ( module Data.XML.Types
+ , elementChildren
+ , hasName
+ , getattr
+ , getText
+ , name
+ , nsname
, element
- , attr
- , qname
+ , nselement
+ , escape
+ , serialiseElement
+ , readEvents
+ , SAX.eventsToElement
) where
-import Control.Monad.Trans (MonadIO, liftIO)
-import qualified Data.ByteString.Char8 as C8
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as TE
-
--- XML Parsing
-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 qualified Data.Text.Lazy as T
+import Data.XML.Types
import qualified Text.XML.LibXML.SAX as SAX
-readEvents :: MonadIO m => (Integer -> SAX.Event -> Bool) -> m String -> SAX.Parser -> m [SAX.Event]
-readEvents done getChars parser = readEvents' 0 [] where
- nextEvents = do
- chars <- getChars
- liftIO $ SAX.parse parser chars False
+elementChildren :: Element -> [Element]
+elementChildren = concatMap isElement . elementNodes
+
+hasName :: Name -> Element -> [Element]
+hasName n e = [e | elementName e == n]
+
+isElement :: Node -> [Element]
+isElement (NodeElement e) = [e]
+isElement _ = []
+
+getattr :: Name -> Element -> Maybe T.Text
+getattr attrname elemt = case filter ((attrname ==) . attributeName) $ elementAttributes elemt of
+ [] -> Nothing
+ attr:_ -> Just $ attributeValue attr
+
+getText :: Node -> [T.Text]
+getText (NodeText t) = [t]
+getText _ = []
+
+name :: T.Text -> Name
+name t = Name t Nothing Nothing
+
+nsname :: T.Text -> T.Text -> Name
+nsname ns n = Name n (Just ns) Nothing
+
+escape :: T.Text -> T.Text
+escape = T.concatMap escapeChar where
+ escapeChar c = case c of
+ '&' -> "&"
+ '<' -> "<"
+ '>' -> ">"
+ '"' -> """
+ '\'' -> "'"
+ _ -> T.singleton c
+
+element :: T.Text -> [(T.Text, T.Text)] -> [Node] -> Element
+element elemName attrs children = Element (name elemName) attrs' children where
+ attrs' = [Attribute (name n) value | (n, value) <- attrs]
+
+nselement :: T.Text -> T.Text -> [(T.Text, T.Text)] -> [Node] -> Element
+nselement ns ln attrs children = Element (nsname ns ln) attrs' children where
+ attrs' = [Attribute (name n) value | (n, value) <- attrs]
+
+-- A somewhat primitive serialisation function
+--
+-- TODO: better namespace / prefix handling
+serialiseElement :: Element -> T.Text
+serialiseElement e = text where
+ text = T.concat ["<", eName, " ", attrs, ">", contents, "</", eName, ">"]
+ eName = formatName $ elementName e
+ formatName = escape . nameLocalName
+ attrs = T.intercalate " " $ map attr $ elementAttributes e ++ nsattr
+ attr (Attribute n v) = T.concat [formatName n, "=\"", escape v, "\""]
+ nsattr = case nameNamespace $ elementName e of
+ Nothing -> []
+ Just ns -> [Attribute (name "xmlns") ns]
+ contents = T.concat $ map serialiseNode $ elementNodes e
+ serialiseNode (NodeElement e') = serialiseElement e'
+ serialiseNode (NodeText t) = escape t
+ serialiseNode (NodeComment _) = ""
+ serialiseNode (NodeInstruction _) = ""
+
+readEvents :: Monad m
+ => (Integer -> SAX.Event -> Bool)
+ -> m [SAX.Event]
+ -> m [SAX.Event]
+readEvents done nextEvents = readEvents' 0 [] where
readEvents' depth acc = do
events <- nextEvents
let (done', depth', acc') = step events depth acc
@@ 46,7 108,7 @@ readEvents done getChars parser = readEvents' 0 [] where
then return acc'
else readEvents' depth' acc'
- step [] depth acc = (False, depth, acc)
+ step [] depth acc = (False, depth, acc)
step (e:es) depth acc = let
depth' = depth + case e of
(SAX.BeginElement _ _) -> 1
@@ 56,75 118,3 @@ readEvents done getChars parser = readEvents' 0 [] where
in if done depth' e
then (True, depth', reverse acc')
else step es depth' acc'
-
--------------------------------------------------------------------------------
--- For converting incremental XML event lists to HXT trees
--------------------------------------------------------------------------------
-
--- This function assumes the input list is valid. No validation is performed.
-eventsToTree :: [SAX.Event] -> DOM.XmlTree
-eventsToTree = XN.mkRoot [] . eventsToTrees
-
-eventsToTrees :: [SAX.Event] -> [DOM.XmlTree]
-eventsToTrees = concatMap blockToTrees . splitBlocks
-
--- Split event list into a sequence of "blocks", which are the events including
--- and between a pair of tags. <start><start2/></start> and <start/> are both
--- single blocks.
-splitBlocks :: [SAX.Event] -> [[SAX.Event]]
-splitBlocks es = ret where (_, _, ret) = foldl splitBlocks' (0, [], []) es
-
-splitBlocks' :: (Int, [SAX.Event], [[SAX.Event]])
- -> SAX.Event
- -> (Int, [SAX.Event], [[SAX.Event]])
-splitBlocks' (depth, accum, allAccum) e =
- if depth' == 0 then
- (depth', [], allAccum ++ [accum'])
- else
- (depth', accum', allAccum)
- where
- accum' = accum ++ [e]
- depth' = depth + case e of
- (SAX.BeginElement _ _) -> 1
- (SAX.EndElement _) -> (- 1)
- _ -> 0
-
-blockToTrees :: [SAX.Event] -> [DOM.XmlTree]
-blockToTrees [] = []
-blockToTrees (begin:rest) = let end = (last rest) in case (begin, end) of
- (SAX.BeginElement qname' attrs, SAX.EndElement _) ->
- [XN.mkElement (convertQName qname')
- (map convertAttr attrs)
- (eventsToTrees (init rest))]
- (SAX.Characters s, _) -> [XN.mkText $ utf8 s]
- (_, SAX.ParseError text) -> error text
- _ -> []
-
-convertAttr :: SAX.Attribute -> DOM.XmlTree
-convertAttr (SAX.Attribute qname' value) = XN.NTree
- (XN.mkAttrNode (convertQName qname'))
- [XN.mkText $ utf8 value]
-
-convertQName :: SAX.QName -> DOM.QName
-convertQName (SAX.QName ns _ local) = qname (utf8 ns) (utf8 local)
-
--------------------------------------------------------------------------------
--- Utility functions for building XML trees
--------------------------------------------------------------------------------
-
-element :: (String, String) -> [(String, String, String)] -> [DOM.XmlTree] -> DOM.XmlTree
-element (ns, localpart) attrs children = let
- qname' = qname ns localpart
- attrs' = [attr ans alp text | (ans, alp, text) <- attrs]
- in XN.mkElement qname' attrs' children
-
-attr :: String -> String -> String -> DOM.XmlTree
-attr ns localpart text = XN.mkAttr (qname ns localpart) [XN.mkText text]
-
-qname :: String -> String -> DOM.QName
-qname ns localpart = case ns of
- "" -> DOM.mkName localpart
- _ -> DOM.mkNsName localpart ns
-
-utf8 :: String -> String
-utf8 = T.unpack . TE.decodeUtf8 . C8.pack
M network-protocol-xmpp.cabal => network-protocol-xmpp.cabal +3 -2
@@ 23,14 23,15 @@ library
base >=3 && < 5
, text >= 0.7 && < 0.8
, gnuidn >= 0.1 && < 0.2
- , hxt >= 8.5 && < 8.6
, gnutls >= 0.1 && < 0.3
, bytestring >= 0.9 && < 0.10
- , libxml-sax >= 0.3 && < 0.4
+ , libxml-sax >= 0.4 && < 0.5
, gsasl >= 0.3 && < 0.4
, network >= 2.2 && < 2.3
, transformers >= 0.2 && < 0.3
, monads-tf >= 0.1 && < 0.2
+ , xml-types >= 0.1 && < 0.2
+ , failable-list >= 0.2 && < 0.3
exposed-modules:
Network.Protocol.XMPP