A Network/Protocol/XMPP/Internal/Features.hs => Network/Protocol/XMPP/Internal/Features.hs +71 -0
@@ 0,0 1,71 @@
+-- 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.Features
+ ( Feature (..)
+ , parseFeatures
+ , parseFeature
+ ) where
+import qualified Data.Text as T
+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)
+
+data Feature =
+ FeatureStartTLS Bool
+ | FeatureSASL [T.Text]
+ | FeatureRegister
+ | FeatureBind
+ | FeatureSession
+ | FeatureUnknown DOM.XmlTree
+ deriving (Show, Eq)
+
+parseFeatures :: DOM.XmlTree -> [Feature]
+parseFeatures t =
+ A.runLA (A.getChildren
+ >>> A.hasQName qnameFeatures
+ >>> A.getChildren
+ >>> A.arrL (\t' -> [parseFeature t'])) t
+
+parseFeature :: DOM.XmlTree -> Feature
+parseFeature t = feature where
+ mkPair = maybe ("", "") $ \n -> (DOM.namespaceUri n, DOM.localPart n)
+ 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
+ ("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
+
+parseFeatureTLS :: DOM.XmlTree -> Feature
+parseFeatureTLS t = FeatureStartTLS True -- TODO: detect whether or not required
+
+parseFeatureSASL :: DOM.XmlTree -> Feature
+parseFeatureSASL t = FeatureSASL $ map T.toUpper mechanisms where
+ mechanisms = A.runLA (
+ A.getChildren
+ >>> A.hasQName qnameMechanism
+ >>> A.getChildren
+ >>> A.getText
+ >>> A.arr T.pack) t
+
+qnameMechanism :: DOM.QName
+qnameMechanism = qname "urn:ietf:params:xml:ns:xmpp-sasl" "mechanism"
+
+qnameFeatures :: DOM.QName
+qnameFeatures = qname "http://etherx.jabber.org/streams" "features"
A Network/Protocol/XMPP/Internal/Handle.hs => Network/Protocol/XMPP/Internal/Handle.hs +68 -0
@@ 0,0 1,68 @@
+-- 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.Handle
+ ( Handle (..)
+ , startTLS
+ , hPutBytes
+ , hGetChar
+ ) where
+
+import qualified System.IO as IO
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Unsafe as B
+import qualified Network.GnuTLS as GnuTLS
+import Network.GnuTLS (AttrOp (..))
+import Foreign (allocaBytes, plusPtr)
+import Foreign.C (peekCAStringLen)
+
+data Handle =
+ PlainHandle IO.Handle
+ | SecureHandle IO.Handle (GnuTLS.Session GnuTLS.Client)
+
+startTLS :: Handle -> IO Handle
+startTLS h@(SecureHandle _ _) = return h
+startTLS (PlainHandle h) = do
+ session <- GnuTLS.tlsClient
+ [ GnuTLS.handle := h
+ , GnuTLS.priorities := [GnuTLS.CrtX509]
+ , GnuTLS.credentials := GnuTLS.certificateCredentials
+ ]
+ GnuTLS.handshake session
+ return $ SecureHandle h session
+
+hPutBytes :: Handle -> B.ByteString -> IO ()
+hPutBytes (PlainHandle h) bytes = B.hPut h bytes
+hPutBytes (SecureHandle _ session) bytes = useLoop where
+ useLoop = B.unsafeUseAsCStringLen bytes $ \(ptr, len) -> loop ptr len
+ loop ptr len = do
+ r <- GnuTLS.tlsSend session ptr len
+ case len - r of
+ x | x > 0 -> loop (plusPtr ptr r) x
+ | otherwise -> return ()
+
+hGetChar :: Handle -> IO Char
+hGetChar (PlainHandle h) = IO.hGetChar h
+hGetChar (SecureHandle h session) = allocaBytes 1 $ \ptr -> do
+ pending <- GnuTLS.tlsCheckPending session
+ if pending == 0
+ then do
+ IO.hWaitForInput h (-1)
+ return ()
+ else return ()
+
+ len <- GnuTLS.tlsRecv session ptr 1
+ [char] <- peekCAStringLen (ptr, len)
+ return char
A Network/Protocol/XMPP/Internal/Stream.hs => Network/Protocol/XMPP/Internal/Stream.hs +23 -0
@@ 0,0 1,23 @@
+-- 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 Text.XML.HXT.DOM.Interface (XmlTree)
+
+class Stream a where
+ putTree :: a -> XmlTree -> IO ()
+ getTree :: a -> IO XmlTree
A Network/Protocol/XMPP/Internal/XML.hs => Network/Protocol/XMPP/Internal/XML.hs +141 -0
@@ 0,0 1,141 @@
+-- Copyright (C) 2009-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.XML
+ ( getTree
+ , putTree
+ , readEventsUntil
+ , convertQName
+ , element
+ , attr
+ , qname
+ ) where
+import qualified Network.Protocol.XMPP.Internal.Handle as H
+import qualified Data.ByteString.Char8 as C8
+
+-- 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 Text.XML.LibXML.SAX as SAX
+
+getTree :: H.Handle -> SAX.Parser -> IO DOM.XmlTree
+getTree h p = eventsToTree `fmap` readEventsUntil finished h p where
+ finished 0 (SAX.EndElement _) = True
+ finished _ _ = False
+
+putTree :: H.Handle -> DOM.XmlTree -> IO ()
+putTree h t = do
+ let root = XN.mkRoot [] [t]
+ [text] <- A.runX (A.constA root >>> A.writeDocumentToString [
+ (A.a_no_xml_pi, "1")
+ ])
+ H.hPutBytes h $ C8.pack text
+
+-------------------------------------------------------------------------------
+
+readEventsUntil :: (Int -> SAX.Event -> Bool) -> H.Handle -> SAX.Parser -> IO [SAX.Event]
+readEventsUntil done h parser = readEventsUntil' done 0 [] $ do
+ char <- H.hGetChar h
+ SAX.parse parser [char] False
+
+readEventsUntil' :: (Int -> SAX.Event -> Bool) -> Int -> [SAX.Event] -> IO [SAX.Event] -> IO [SAX.Event]
+readEventsUntil' done depth accum getEvents = do
+ events <- getEvents
+ let (done', depth', accum') = readEventsStep done events depth accum
+ if done'
+ then return accum'
+ else readEventsUntil' done depth' accum' getEvents
+
+readEventsStep :: (Int -> SAX.Event -> Bool) -> [SAX.Event] -> Int -> [SAX.Event] -> (Bool, Int, [SAX.Event])
+readEventsStep _ [] depth accum = (False, depth, accum)
+readEventsStep done (e:es) depth accum = let
+ depth' = depth + case e of
+ (SAX.BeginElement _ _) -> 1
+ (SAX.EndElement _) -> (- 1)
+ _ -> 0
+ accum' = accum ++ [e]
+ in if done depth' e then (True, depth', accum')
+ else readEventsStep done es depth' accum'
+
+-------------------------------------------------------------------------------
+-- 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 es = XN.mkRoot [] (eventsToTrees es)
+
+eventsToTrees :: [SAX.Event] -> [DOM.XmlTree]
+eventsToTrees es = concatMap blockToTrees (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 :: [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 s]
+ (_, SAX.ParseError text) -> error text
+ _ -> []
+
+convertAttr :: SAX.Attribute -> DOM.XmlTree
+convertAttr (SAX.Attribute qname' value) = XN.NTree
+ (XN.mkAttrNode (convertQName qname'))
+ [XN.mkText value]
+
+convertQName :: SAX.QName -> DOM.QName
+convertQName (SAX.QName ns _ local) = qname ns 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