From e17933b3721ed474420e87c3ce4214cf57aac451 Mon Sep 17 00:00:00 2001 From: John Millikin Date: Sun, 14 Jun 2009 02:33:16 +0000 Subject: [PATCH] Implemented enough parsing to get the list of stream features and SASL mechanisms. --- Network/Protocol/XMPP.hs | 111 ++++------------- Network/Protocol/XMPP/Client.hs | 50 ++++++++ Network/Protocol/XMPP/IncrementalXML.hs | 149 ++++++++++++++++++++++ Network/Protocol/XMPP/JID.hs | 97 +++++++++++++++ Network/Protocol/XMPP/Stanzas.hs | 39 ++++++ Network/Protocol/XMPP/Stream.hs | 156 ++++++++++++++++++++++++ Network/Protocol/XMPP/XMLBuilder.hs | 59 +++++++++ Tests.hs | 16 +++ Tests/Core.hs | 16 +++ incremental-xml.c | 66 ++++++++++ incremental-xml.h | 31 +++++ 11 files changed, 703 insertions(+), 87 deletions(-) create mode 100644 Network/Protocol/XMPP/Client.hs create mode 100644 Network/Protocol/XMPP/IncrementalXML.hs create mode 100644 Network/Protocol/XMPP/JID.hs create mode 100644 Network/Protocol/XMPP/Stanzas.hs create mode 100644 Network/Protocol/XMPP/Stream.hs create mode 100644 Network/Protocol/XMPP/XMLBuilder.hs create mode 100644 incremental-xml.c create mode 100644 incremental-xml.h diff --git a/Network/Protocol/XMPP.hs b/Network/Protocol/XMPP.hs index 189876c..702c6a3 100644 --- a/Network/Protocol/XMPP.hs +++ b/Network/Protocol/XMPP.hs @@ -1,90 +1,27 @@ +{- Copyright (C) 2009 John Millikin + + 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 . +-} + module Network.Protocol.XMPP ( - JID - ,JIDNode - ,JIDDomain - ,JIDResource - - ,jidNodeBuild - ,jidNodeValue - ,jidDomainBuild - ,jidDomainValue - ,jidResourceBuild - ,jidResourceValue - ,jidBuild - - ,jidParse - ,jidFormat - + module Network.Protocol.XMPP.JID + ,module Network.Protocol.XMPP.Client + ,module Network.Protocol.XMPP.Stream + ,module Network.Protocol.XMPP.Stanzas ) where -------------------------------------------------------------------------------- - -data JID = JID (Maybe JIDNode) JIDDomain (Maybe JIDResource) - deriving (Eq) - -instance Show JID where - show = jidFormat - -newtype JIDNode = JIDNode String - deriving (Eq, Show) - -newtype JIDDomain = JIDDomain String - deriving (Eq, Show) - -newtype JIDResource = JIDResource String - deriving (Eq, Show) - -jidNodeBuild :: String -> Maybe JIDNode -jidNodeBuild "" = Nothing -jidNodeBuild s = Just (JIDNode s) -- TODO: stringprep, validation - -jidNodeValue :: JIDNode -> String -jidNodeValue (JIDNode s) = s - -jidDomainBuild :: String -> Maybe JIDDomain -jidDomainBuild "" = Nothing -jidDomainBuild s = Just (JIDDomain s) -- TODO: stringprep, validation - -jidDomainValue :: JIDDomain -> String -jidDomainValue (JIDDomain s) = s - -jidResourceBuild :: String -> Maybe JIDResource -jidResourceBuild "" = Nothing -jidResourceBuild s = Just (JIDResource s) -- TODO: stringprep, validation - -jidResourceValue :: JIDResource -> String -jidResourceValue (JIDResource s) = s - -jidBuild :: String -> String -> String -> Maybe JID -jidBuild nodeStr domainStr resourceStr = case (jidDomainBuild domainStr) of - Nothing -> Nothing - (Just domain) -> Just (JID node domain resource) - where - node = jidNodeBuild nodeStr - resource = jidResourceBuild resourceStr - --- TODO: validate input according to RFC 3920, section 3.1 -jidParse :: String -> Maybe JID -jidParse s = jidBuild nodeStr domainStr resourceStr - where - (nodeStr, postNode) = if '@' `elem` s then split s '@' else ("", s) - (domainStr, resourceStr) = if '/' `elem` postNode then split postNode '/' else (postNode, "") - -jidFormat :: JID -> String -jidFormat (JID node (JIDDomain domain) resource) = concat [nodeStr, domain, resourceStr] - where - nodeStr = case node of - Nothing -> "" - Just (JIDNode s) -> s ++ "@" - resourceStr = case resource of - Nothing -> "" - Just (JIDResource s) -> "/" ++ s - -------------------------------------------------------------------------------- - -split xs final = (before, after) - where - (before, rawAfter) = span (/= final) xs - after = case rawAfter of - [] -> [] - xs -> tail xs +import Network.Protocol.XMPP.JID +import Network.Protocol.XMPP.Client +import Network.Protocol.XMPP.Stream +import Network.Protocol.XMPP.Stanzas diff --git a/Network/Protocol/XMPP/Client.hs b/Network/Protocol/XMPP/Client.hs new file mode 100644 index 0000000..c7e4f43 --- /dev/null +++ b/Network/Protocol/XMPP/Client.hs @@ -0,0 +1,50 @@ +{- Copyright (C) 2009 John Millikin + + 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 . +-} + +module Network.Protocol.XMPP.Client ( + ConnectedClient + ,AuthenticatedClient + ,clientConnect + ,clientAuthenticate + ,clientSend + ) where + +import System.IO (Handle) +import Network (HostName, PortID, connectTo) +import Network.Protocol.XMPP.JID (JID) +import Network.Protocol.XMPP.Stream (beginStream, streamFeatures) +import Network.Protocol.XMPP.Stanzas (Stanza) + +data ConnectedClient = ConnectedClient JID Handle + +data AuthenticatedClient = AuthenticatedClient Handle HostName PortID + +type Username = String +type Password = String + +clientConnect :: JID -> HostName -> PortID -> IO ConnectedClient +clientConnect jid host port = do + handle <- connectTo host port + stream <- beginStream jid host handle + putStrLn $ "streamFeatures = " ++ (show (streamFeatures stream)) + return $ ConnectedClient jid handle + +clientAuthenticate :: ConnectedClient -> Username -> Password -> AuthenticatedClient +clientAuthenticate = undefined + +clientSend :: (Stanza s) => AuthenticatedClient -> s -> IO () +clientSend = undefined + diff --git a/Network/Protocol/XMPP/IncrementalXML.hs b/Network/Protocol/XMPP/IncrementalXML.hs new file mode 100644 index 0000000..281c205 --- /dev/null +++ b/Network/Protocol/XMPP/IncrementalXML.hs @@ -0,0 +1,149 @@ +{- Copyright (C) 2009 John Millikin + + 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 . +-} + +{-# LANGUAGE ForeignFunctionInterface #-} +module Network.Protocol.XMPP.IncrementalXML ( + Parser + ,Event(..) + ,Attribute(..) + ,newParser + ,incrementalParse + ) where + +import Data.IORef (newIORef, readIORef, writeIORef, IORef) +import Foreign.C (CInt, CString, withCStringLen, peekCString, peekCStringLen) +import qualified Foreign as F +import Control.Exception (bracket) +import Text.XML.HXT.DOM.QualifiedName (mkQName, QName) + +data ParserStruct = ParserStruct +data Parser = Parser !(F.ForeignPtr ParserStruct) + +data Event = + BeginElement QName [Attribute] + | EndElement QName + | Characters String + | ParseError String + deriving (Show, Eq) + +data Attribute = Attribute QName String + deriving (Show, Eq) + +newParser :: IO Parser +newParser = do + ptr <- c_incremental_parser_new + autoptr <- F.newForeignPtr c_incremental_parser_free ptr + return $ Parser autoptr + +incrementalParse :: Parser -> String -> IO [Event] +incrementalParse (Parser autoptr) s = do + events <- newIORef [] + + withCStringLen s $ \(cs, cs_len) -> do + F.withForeignPtr autoptr $ \ptr -> do + withFunPtr (onBeginElement events) wrappedBegin $ \b -> do + withFunPtr (onEndElement events) wrappedEnd $ \e -> do + withFunPtr (onCharacters events) wrappedText $ \t -> do + retval <- (c_incremental_parse ptr cs (fromIntegral cs_len) b e t) + (readIORef events) >>= (return . checkReturn retval) + +checkReturn :: CInt -> [Event] -> [Event] +checkReturn r es = es ++ case r of + 0 -> [] + otherwise -> [ParseError (show r)] + +withFunPtr :: a -> (a -> IO (F.FunPtr a)) -> (F.FunPtr a -> IO b) -> IO b +withFunPtr f mkPtr block = bracket (mkPtr f) F.freeHaskellFunPtr block + +-- localname, prefix, namespace, value_begin, value_end +data CAttribute = CAttribute CString CString CString CString CString + +splitCAttributes :: CInt -> F.Ptr CString -> IO [CAttribute] +splitCAttributes = splitCAttributes' 0 + +splitCAttributes' _ 0 _ = return [] +splitCAttributes' offset n attrs = do + c_ln <- F.peekElemOff attrs (offset + 0) + c_prefix <- F.peekElemOff attrs (offset + 1) + c_ns <- F.peekElemOff attrs (offset + 2) + c_vbegin <- F.peekElemOff attrs (offset + 3) + c_vend <- F.peekElemOff attrs (offset + 4) + as <- splitCAttributes' (offset + 5) (n - 1) attrs + return (CAttribute c_ln c_prefix c_ns c_vbegin c_vend : as) + +convertCAttribute :: CAttribute -> IO Attribute +convertCAttribute (CAttribute c_ln c_pfx c_ns c_vbegin c_vend) = do + ln <- peekCString c_ln + pfx <- peekNullable c_pfx + ns <- peekNullable c_ns + val <- peekCStringLen (c_vbegin, F.minusPtr c_vend c_vbegin) + return (Attribute (mkQName pfx ln ns) val) + +peekNullable :: CString -> IO String +peekNullable ptr + | ptr == F.nullPtr = return "" + | otherwise = peekCString ptr + +onBeginElement :: IORef [Event] -> F.Ptr () -> CString -> CString -> CString -> CInt -> F.Ptr () -> CInt -> CInt -> F.Ptr CString -> IO () +onBeginElement eventref _ cln cpfx cns _ _ n_attrs _ raw_attrs = do + ns <- peekCString cns + pfx <- peekNullable cpfx + ln <- peekCString cln + es <- readIORef eventref + c_attrs <- splitCAttributes n_attrs raw_attrs + attrs <- mapM convertCAttribute c_attrs + writeIORef eventref (es ++ [BeginElement (mkQName pfx ln ns) attrs]) + +onEndElement :: IORef [Event] -> F.Ptr () -> CString -> CString -> CString -> IO () +onEndElement eventref _ cln cpfx cns = do + ns <- peekCString cns + pfx <- peekNullable cpfx + ln <- peekCString cln + es <- readIORef eventref + writeIORef eventref (es ++ [EndElement (mkQName pfx ln ns)]) + +onCharacters :: IORef [Event] -> F.Ptr () -> CString -> CInt -> IO () +onCharacters eventref _ ctext ctextlen = do + text <- (peekCStringLen (ctext, fromIntegral ctextlen)) + es <- readIORef eventref + writeIORef eventref (es ++ [Characters text]) + +type StartElementNsSAX2Func = (F.Ptr () -> CString -> CString -> CString -> CInt -> F.Ptr () -> CInt -> CInt -> F.Ptr CString -> IO ()) +type EndElementNsSAX2Func = (F.Ptr () -> CString -> CString -> CString -> IO ()) +type CharactersSAXFunc = (F.Ptr () -> CString -> CInt -> IO ()) + +foreign import ccall "wrapper" + wrappedBegin :: StartElementNsSAX2Func -> IO (F.FunPtr StartElementNsSAX2Func) + +foreign import ccall "wrapper" + wrappedEnd :: EndElementNsSAX2Func -> IO (F.FunPtr EndElementNsSAX2Func) + +foreign import ccall "wrapper" + wrappedText :: CharactersSAXFunc -> IO (F.FunPtr CharactersSAXFunc) + +foreign import ccall "incremental-xml.h incremental_parser_new" + c_incremental_parser_new :: IO (F.Ptr ParserStruct) + +foreign import ccall "incremental-xml.h incremental_parse" + c_incremental_parse :: F.Ptr ParserStruct -> CString -> CInt + -> F.FunPtr StartElementNsSAX2Func + -> F.FunPtr EndElementNsSAX2Func + -> F.FunPtr CharactersSAXFunc + -> IO CInt + +foreign import ccall "incremental-xml.h &incremental_parser_free" + c_incremental_parser_free :: F.FunPtr (F.Ptr ParserStruct -> IO ()) + diff --git a/Network/Protocol/XMPP/JID.hs b/Network/Protocol/XMPP/JID.hs new file mode 100644 index 0000000..1707eaa --- /dev/null +++ b/Network/Protocol/XMPP/JID.hs @@ -0,0 +1,97 @@ +{- Copyright (C) 2009 John Millikin + + 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 . +-} + +module Network.Protocol.XMPP.JID ( + JID + ,JIDNode + ,JIDDomain + ,JIDResource + + ,jidNodeBuild + ,jidNodeValue + ,jidDomainBuild + ,jidDomainValue + ,jidResourceBuild + ,jidResourceValue + ,jidBuild + + ,jidParse + ,jidFormat + ) where + +data JID = JID (Maybe JIDNode) JIDDomain (Maybe JIDResource) + deriving (Eq) + +instance Show JID where + show = jidFormat + +newtype JIDNode = JIDNode String + deriving (Eq, Show) + +newtype JIDDomain = JIDDomain String + deriving (Eq, Show) + +newtype JIDResource = JIDResource String + deriving (Eq, Show) + +jidNodeBuild :: String -> Maybe JIDNode +jidNodeBuild "" = Nothing +jidNodeBuild s = Just (JIDNode s) -- TODO: stringprep, validation + +jidNodeValue :: JIDNode -> String +jidNodeValue (JIDNode s) = s + +jidDomainBuild :: String -> Maybe JIDDomain +jidDomainBuild "" = Nothing +jidDomainBuild s = Just (JIDDomain s) -- TODO: stringprep, validation + +jidDomainValue :: JIDDomain -> String +jidDomainValue (JIDDomain s) = s + +jidResourceBuild :: String -> Maybe JIDResource +jidResourceBuild "" = Nothing +jidResourceBuild s = Just (JIDResource s) -- TODO: stringprep, validation + +jidResourceValue :: JIDResource -> String +jidResourceValue (JIDResource s) = s + +jidBuild :: String -> String -> String -> Maybe JID +jidBuild nodeStr domainStr resourceStr = let + node = jidNodeBuild nodeStr + resource = jidResourceBuild resourceStr + in case (jidDomainBuild domainStr) of + Nothing -> Nothing + (Just domain) -> Just (JID node domain resource) + +-- TODO: validate input according to RFC 3920, section 3.1 +jidParse :: String -> Maybe JID +jidParse s = let + (nodeStr, postNode) = if '@' `elem` s then split s '@' else ("", s) + (domainStr, resourceStr) = if '/' `elem` postNode then split postNode '/' else (postNode, "") + in jidBuild nodeStr domainStr resourceStr + +jidFormat :: JID -> String +jidFormat (JID node (JIDDomain domain) resource) = let + nodeStr = maybe "" (\(JIDNode s) -> s ++ "@") node + resourceStr = maybe "" (\(JIDResource s) -> "/" ++ s) resource + in concat [nodeStr, domain, resourceStr] + +split xs final = let + (before, rawAfter) = span (/= final) xs + after = case rawAfter of + [] -> [] + xs -> tail xs + in (before, after) diff --git a/Network/Protocol/XMPP/Stanzas.hs b/Network/Protocol/XMPP/Stanzas.hs new file mode 100644 index 0000000..9cd0553 --- /dev/null +++ b/Network/Protocol/XMPP/Stanzas.hs @@ -0,0 +1,39 @@ +{- Copyright (C) 2009 John Millikin + + 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 . +-} + +module Network.Protocol.XMPP.Stanzas ( + Stanza + ) where + +import Text.XML.HXT.DOM.TypeDefs (XmlTree) + +class Stanza a where + stanzaXML :: a -> XmlTree + +data Message = Message + +data Presence = Presence + +data IQ = IQ + +instance Stanza Message where + stanzaXML s = undefined + +instance Stanza Presence where + stanzaXML s = undefined + +instance Stanza IQ where + stanzaXML s = undefined diff --git a/Network/Protocol/XMPP/Stream.hs b/Network/Protocol/XMPP/Stream.hs new file mode 100644 index 0000000..0ad04bb --- /dev/null +++ b/Network/Protocol/XMPP/Stream.hs @@ -0,0 +1,156 @@ +{- Copyright (C) 2009 John Millikin + + 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 . +-} + +module Network.Protocol.XMPP.Stream ( + Stream ( + streamHostName + ,streamLanguage + ,streamVersion + ,streamFeatures + ) + ,beginStream + ,send + ) where + +import qualified System.IO as IO +import Network (HostName, PortID, connectTo) +import qualified Network.Protocol.XMPP.IncrementalXML as XML +import Data.AssocList (lookupDef) +import qualified Text.XML.HXT.DOM.QualifiedName as QN +import qualified Text.XML.HXT.DOM.XmlNode as XN +import Text.XML.HXT.DOM.TypeDefs (XmlTree) +import Text.XML.HXT.DOM.FormatXmlTree (formatXmlTree) +import Text.XML.HXT.DOM.Util (attrEscapeXml) +import Text.XML.HXT.Arrow ((>>>), (>>.)) +import Data.Tree.NTree.TypeDefs (NTree(NTree)) +import qualified Text.XML.HXT.Arrow as A +import Network.Protocol.XMPP.JID (JID) +import Network.Protocol.XMPP.Stanzas (Stanza) +import Network.Protocol.XMPP.XMLBuilder (eventsToTree) + +maxXMPPVersion = XMPPVersion 1 0 + +data Stream = Stream + { + streamHandle :: IO.Handle + ,streamParser :: XML.Parser + ,streamHostName :: HostName + ,streamLanguage :: XMLLanguage + ,streamVersion :: XMPPVersion + ,streamFeatures :: [StreamFeature] + } + +data StreamFeature = + FeatureStartTLS Bool + | FeatureSASL [SASLMechanism] + | FeatureRegister + | FeatureUnknown XmlTree + | FeatureDebug String + deriving (Show, Eq) + +newtype XMLLanguage = XMLLanguage String + deriving (Show, Eq) + +newtype SASLMechanism = SASLMechanism String + deriving (Show, Eq) + +data XMPPVersion = XMPPVersion Int Int + deriving (Show, Eq) + +------------------------------------------------------------------------------- + +beginStream :: JID -> HostName -> IO.Handle -> IO Stream +beginStream jid host handle = do + parser <- XML.newParser + + IO.hSetBuffering handle IO.NoBuffering + + -- Since only the opening tag should be written, normal XML + -- serialization cannot be used. Be careful to escape any embedded + -- attributes. + IO.hPutStr handle $ + "\n" ++ + "" + + IO.hFlush handle + + xmlChars <- hGetChars handle 100 + events <- (XML.incrementalParse parser xmlChars) + return $ beginStream' handle parser events + +beginStream' handle parser (streamStart:events) = let + -- TODO: parse from streamStart + host = "localhost" + language = XMLLanguage "en" + version = XMPPVersion 1 0 + + featuresName = QN.mkNsName "features" "http://etherx.jabber.org/streams" + + eventTree = eventsToTree events + featureRoots = A.runLA ( + A.getChildren + >>> A.hasQName featuresName) eventTree + features = case featureRoots of + [] -> [] + (t:_) -> map parseFeature (A.runLA A.getChildren t) + + in Stream handle parser host language version features + +parseFeature :: XmlTree -> StreamFeature +parseFeature t = lookupDef FeatureUnknown qname [ + (("urn:ietf:params:xml:ns:xmpp-tls", "starttls"), parseFeatureTLS) + ,(("urn:ietf:params:xml:ns:xmpp-sasl", "mechanisms"), parseFeatureSASL) + ,(("http://jabber.org/features/iq-register", "register"), (\_ -> FeatureRegister)) + ] t + where + qname = maybe ("", "") (\n -> (QN.namespaceUri n, QN.localPart n)) (XN.getName t) + +parseFeatureTLS :: XmlTree -> StreamFeature +parseFeatureTLS t = FeatureStartTLS True -- TODO: detect whether or not required + +parseFeatureSASL :: XmlTree -> StreamFeature +parseFeatureSASL t = let + mechName = QN.mkNsName "mechanism" "urn:ietf:params:xml:ns:xmpp-sasl" + rawMechanisms = A.runLA ( + A.getChildren + >>> A.hasQName mechName + >>> A.getChildren + >>> A.getText) t + + -- TODO: validate mechanism names according to SASL rules + -- <20 chars, uppercase, alphanum, etc + in FeatureSASL [SASLMechanism n | n <- rawMechanisms] + +------------------------------------------------------------------------------- + +send :: (Stanza s) => Stream -> s -> IO () +send = undefined + +------------------------------------------------------------------------------- + +hGetChars :: IO.Handle -> Int -> IO String +hGetChars h timeout = do + have_input <- IO.hWaitForInput h timeout + case have_input of + False -> return [] + True -> do + chr <- IO.hGetChar h + next <- hGetChars h timeout + return $ chr : next + diff --git a/Network/Protocol/XMPP/XMLBuilder.hs b/Network/Protocol/XMPP/XMLBuilder.hs new file mode 100644 index 0000000..701949b --- /dev/null +++ b/Network/Protocol/XMPP/XMLBuilder.hs @@ -0,0 +1,59 @@ +{- Copyright (C) 2009 John Millikin + + 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 . +-} + +module Network.Protocol.XMPP.XMLBuilder ( + eventsToTree + ) where + +import qualified Text.XML.HXT.DOM.XmlNode as XN +import Text.XML.HXT.DOM.TypeDefs (XmlTree) +import qualified Network.Protocol.XMPP.IncrementalXML as XML + +-- This function assumes the input list is valid. No validation is performed. +eventsToTree :: [XML.Event] -> XmlTree +eventsToTree es = XN.mkRoot [] (eventsToTrees es) + +eventsToTrees :: [XML.Event] -> [XmlTree] +eventsToTrees es = map blockToTree (splitBlocks es) + +-- Split event list into a sequence of "blocks", which are the events including +-- and between a pair of tags. and are both +-- single blocks. +splitBlocks :: [XML.Event] -> [[XML.Event]] +splitBlocks es = ret where (_, _, ret) = foldl splitBlocks' (0, [], []) es + +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 + (XML.BeginElement _ _) -> 1 + (XML.EndElement _) -> (- 1) + otherwise -> 0 + +blockToTree :: [XML.Event] -> XmlTree +blockToTree (begin:rest) = let end = (last rest) in case (begin, end) of + (XML.BeginElement qname attrs, XML.EndElement _) -> + XN.mkElement qname (map convertAttr attrs) (eventsToTrees (init rest)) + (XML.Characters s, _) -> XN.mkText s + (_, XML.ParseError _) -> undefined + fff -> error ("Got unexpected: " ++ (show fff)) + +convertAttr :: XML.Attribute -> XmlTree +convertAttr (XML.Attribute qname value) = XN.NTree (XN.mkAttrNode qname) [] diff --git a/Tests.hs b/Tests.hs index b1626df..0db63cf 100644 --- a/Tests.hs +++ b/Tests.hs @@ -1,3 +1,19 @@ +{- Copyright (C) 2009 John Millikin + + 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 . +-} + module Main () where import Test.HUnit diff --git a/Tests/Core.hs b/Tests/Core.hs index 73e3f34..492436e 100644 --- a/Tests/Core.hs +++ b/Tests/Core.hs @@ -1,3 +1,19 @@ +{- Copyright (C) 2009 John Millikin + + 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 . +-} + module Tests.Core (coreTests) where import Control.Monad (unless) diff --git a/incremental-xml.c b/incremental-xml.c new file mode 100644 index 0000000..c044ad4 --- /dev/null +++ b/incremental-xml.c @@ -0,0 +1,66 @@ +/* Copyright (C) 2009 John Millikin + + 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 . +*/ + +#include +#include +#include "incremental-xml.h" + +struct _IncrementalParser +{ + xmlSAXHandler handler; + xmlParserCtxt *context; +}; + +IncrementalParser * +incremental_parser_new () +{ + IncrementalParser *parser; + parser = malloc (sizeof (IncrementalParser)); + assert (parser != NULL); + + memset (&(parser->handler), 0, sizeof (parser->handler)); + parser->handler.initialized = XML_SAX2_MAGIC; + + parser->context = xmlCreatePushParserCtxt ( + &(parser->handler), parser, NULL, 0, NULL); + assert (parser->context != NULL); + + return parser; +} + +void +incremental_parser_free (IncrementalParser *p) +{ + xmlClearParserCtxt (p->context); + xmlFreeParserCtxt (p->context); + free (p); +} + +int +incremental_parse ( + IncrementalParser *parser, + const char *text, + int text_len, + startElementNsSAX2Func begin, + endElementNsSAX2Func end, + charactersSAXFunc text_handler) +{ + xmlParserCtxt *c = parser->context; + c->sax->startElementNs = begin; + c->sax->endElementNs = end; + c->sax->characters = text_handler; + return xmlParseChunk (c, text, text_len, 0); +} diff --git a/incremental-xml.h b/incremental-xml.h new file mode 100644 index 0000000..d011b5c --- /dev/null +++ b/incremental-xml.h @@ -0,0 +1,31 @@ +/* Copyright (C) 2009 John Millikin + + 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 . +*/ + +#include + +typedef struct _IncrementalParser IncrementalParser; + +IncrementalParser * +incremental_parser_new (); + +void +incremental_parser_free (IncrementalParser *); + +int +incremental_parse (IncrementalParser *, const char *, int, + startElementNsSAX2Func, + endElementNsSAX2Func, + charactersSAXFunc); -- 2.38.4