M Network/Protocol/XMPP.hs => Network/Protocol/XMPP.hs +24 -87
@@ 1,90 1,27 @@
+{- Copyright (C) 2009 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 (
- 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
A Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +50 -0
@@ 0,0 1,50 @@
+{- Copyright (C) 2009 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.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
+
A Network/Protocol/XMPP/IncrementalXML.hs => Network/Protocol/XMPP/IncrementalXML.hs +149 -0
@@ 0,0 1,149 @@
+{- Copyright (C) 2009 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/>.
+-}
+
+{-# 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 ())
+
A Network/Protocol/XMPP/JID.hs => Network/Protocol/XMPP/JID.hs +97 -0
@@ 0,0 1,97 @@
+{- Copyright (C) 2009 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.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)
A Network/Protocol/XMPP/Stanzas.hs => Network/Protocol/XMPP/Stanzas.hs +39 -0
@@ 0,0 1,39 @@
+{- Copyright (C) 2009 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.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
A Network/Protocol/XMPP/Stream.hs => Network/Protocol/XMPP/Stream.hs +156 -0
@@ 0,0 1,156 @@
+{- Copyright (C) 2009 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.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 $
+ "<?xml version='1.0'?>\n" ++
+ "<stream:stream xmlns='jabber:client'" ++
+ " to='" ++ (attrEscapeXml . show) jid ++ "'" ++
+ " version='1.0'" ++
+ " xmlns:stream='http://etherx.jabber.org/streams'>"
+
+ 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
+
A Network/Protocol/XMPP/XMLBuilder.hs => Network/Protocol/XMPP/XMLBuilder.hs +59 -0
@@ 0,0 1,59 @@
+{- Copyright (C) 2009 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.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. <start><start2/></start> and <start/> 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) []
M Tests.hs => Tests.hs +16 -0
@@ 1,3 1,19 @@
+{- Copyright (C) 2009 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 Main () where
import Test.HUnit
M Tests/Core.hs => Tests/Core.hs +16 -0
@@ 1,3 1,19 @@
+{- Copyright (C) 2009 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 Tests.Core (coreTests) where
import Control.Monad (unless)
A incremental-xml.c => incremental-xml.c +66 -0
@@ 0,0 1,66 @@
+/* Copyright (C) 2009 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/>.
+*/
+
+#include <string.h>
+#include <assert.h>
+#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);
+}
A incremental-xml.h => incremental-xml.h +31 -0
@@ 0,0 1,31 @@
+/* Copyright (C) 2009 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/>.
+*/
+
+#include <libxml/parser.h>
+
+typedef struct _IncrementalParser IncrementalParser;
+
+IncrementalParser *
+incremental_parser_new ();
+
+void
+incremental_parser_free (IncrementalParser *);
+
+int
+incremental_parse (IncrementalParser *, const char *, int,
+ startElementNsSAX2Func,
+ endElementNsSAX2Func,
+ charactersSAXFunc);