From 2193a15fbafc2e38739a75b3ec4f1555593dc426 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 18 Mar 2012 18:40:35 +0100 Subject: [PATCH 01/26] initial --- .gitignore | 6 +++ src/Network/TLSConduit.hs | 40 +++++++++++++++++ src/Network/XMPP/Monad.hs | 63 +++++++++++++++++++++++++++ src/Network/XMPP/Stream.hs | 76 +++++++++++++++++++++++++++++++++ src/Network/XMPP/TLS.hs | 44 +++++++++++++++++++ src/Network/XMPPConduit.hs | 61 ++++++++++++++++++++++++++ src/Text/XML/Stream/Elements.hs | 76 +++++++++++++++++++++++++++++++++ xmpp-lib.cabal | 0 8 files changed, 366 insertions(+) create mode 100644 .gitignore create mode 100644 src/Network/TLSConduit.hs create mode 100644 src/Network/XMPP/Monad.hs create mode 100644 src/Network/XMPP/Stream.hs create mode 100644 src/Network/XMPP/TLS.hs create mode 100644 src/Network/XMPPConduit.hs create mode 100644 src/Text/XML/Stream/Elements.hs create mode 100644 xmpp-lib.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..a0ba28c --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ +dist/ +*.o +*.hi +*~ +*# +*.#* \ No newline at end of file diff --git a/src/Network/TLSConduit.hs b/src/Network/TLSConduit.hs new file mode 100644 index 0000000..7eedcf4 --- /dev/null +++ b/src/Network/TLSConduit.hs @@ -0,0 +1,40 @@ +module Network.TLSConduit + ( tlsinit + , module TLS + , module TLSExtra + ) + where + +import Control.Applicative +import Control.Monad.Trans + +import Crypto.Random + +import Data.ByteString +import qualified Data.ByteString.Lazy as BL +import Data.Conduit + +import Network.TLS as TLS +import Network.TLS.Extra as TLSExtra + +import System.IO(Handle) +import System.Random + +tlsinit + :: (MonadIO m, ResourceIO m1) => + TLSParams -> Handle + -> m (Source m1 ByteString, Sink ByteString m1 ()) +tlsinit tlsParams handle = do + gen <- liftIO $ (newGenIO :: IO SystemRandom) -- TODO: Find better random source? + clientContext <- client tlsParams gen handle + handshake clientContext + let src = sourceIO + (return clientContext) + bye + (\con -> IOOpen <$> recvData con) + let snk = sinkIO + (return clientContext) + (\_ -> return ()) + (\ctx dt -> sendData ctx (BL.fromChunks [dt]) >> return IOProcessing) + (\_ -> return ()) + return (src, snk) diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs new file mode 100644 index 0000000..ae2dfaf --- /dev/null +++ b/src/Network/XMPP/Monad.hs @@ -0,0 +1,63 @@ +module Network.XMPP.Monad where + +import Control.Monad.Trans +import Control.Monad.Trans.State + +import Data.Conduit +import Data.Conduit.List as CL +import Data.XML.Types + +import Data.Default +import Data.Text + +import System.IO + +import Text.XML.Stream.Elements + +type XMPPMonad a = StateT XMPPState (ResourceT IO) a + +data XMPPState = XMPPState + { conSrc :: BufferedSource IO Event + , conSink :: Sink Event IO () + , conHandle :: Maybe Handle + , sFeatures :: ServerFeatures + , haveTLS :: Bool + , sHostname :: Text + , jid :: Text + } + +data ServerFeatures = SF + { stls :: Bool + , stlsRequired :: Bool + , saslMechanisms :: [Text] + , other :: [Element] + } deriving Show + +instance Default ServerFeatures where + def = SF + { stls = False + , stlsRequired = False + , saslMechanisms = [] + , other = [] + } + +push :: Element -> XMPPMonad () +push x = do + sink <- gets conSink + lift $ CL.sourceList (elementToEvents x) $$ sink + +pushOpen :: Element -> XMPPMonad () +pushOpen x = do + sink <- gets conSink + lift $ CL.sourceList (elementToEvents' x) $$ sink + + +pulls :: Sink Event IO a -> XMPPMonad a +pulls snk = do + source <- gets conSrc + lift $ source $$ snk + +pull :: XMPPMonad Element +pull = do + source <- gets conSrc + pulls elementFromEvents diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs new file mode 100644 index 0000000..c38be19 --- /dev/null +++ b/src/Network/XMPP/Stream.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} + +module Network.XMPP.Stream where + +import Control.Monad(unless) +import Control.Monad.Trans.State + +import Network.XMPP.Monad + +import Data.Conduit +import Data.Conduit.List as CL +import qualified Data.List as L +import Data.Text as T +import Data.XML.Types + +import Text.XML.Stream.Elements + +xmppStartStream = do + hostname <- gets sHostname + pushOpen $ streamE hostname + features <- pulls xmppStream + modify (\s -> s {sFeatures = features}) + return () + + +xmppStream :: ResourceThrow m => Sink Event m ServerFeatures +xmppStream = do + xmppStreamHeader + xmppStreamFeatures + + +xmppStreamHeader :: Resource m => Sink Event m () +xmppStreamHeader = do + Just EventBeginDocument <- CL.head + Just (EventBeginElement "{http://etherx.jabber.org/streams}stream" streamAttrs) <- CL.head + unless (checkVersion streamAttrs) $ error "Not XMPP version 1.0 " + return () + where + checkVersion = L.any (\x -> (fst x == "version") && (snd x == [ContentText "1.0"])) + + +xmppStreamFeatures + :: ResourceThrow m => Sink Event m ServerFeatures +xmppStreamFeatures = do + Element "{http://etherx.jabber.org/streams}features" [] features' <- elementFromEvents + let features = do + f <- features' + case f of + NodeElement e -> [e] + _ -> [] + let starttls = features >>= isNamed "{urn:ietf:params:xml:ns:xmpp-tls}starttls" + let starttlsRequired = starttls + >>= elementChildren + >>= isNamed "{urn:ietf:params:xml:ns:xmpp-tls}required" + let mechanisms = features + >>= isNamed "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms" + >>= elementChildren + >>= isNamed "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" + >>= elementText + return SF { stls = not $ L.null starttls + , stlsRequired = not $ L.null starttlsRequired + , saslMechanisms = mechanisms + , other = features + } + +streamE :: T.Text -> Element +streamE hostname = + Element (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) + [ + ("xml:language" , [ContentText "en"]) + , ("version", [ContentText "1.0"]) + , ("to", [ContentText hostname]) + ] + [] + + diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs new file mode 100644 index 0000000..c351acc --- /dev/null +++ b/src/Network/XMPP/TLS.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.XMPP.TLS where + +import Control.Monad(when) +import Control.Monad.Trans +import Control.Monad.Trans.State + +import Network.XMPP.Monad +import Network.XMPP.Stream +import Network.TLSConduit as TLS + +import Data.Conduit +import Data.Conduit.Text as CT +import Data.Conduit.List as CL +import qualified Data.List as L +import Data.XML.Types + +import Text.XML.Stream.Elements +import Text.XML.Stream.Parse +import Text.XML.Stream.Render as XR + + +starttlsE = + Element (Name "starttls" (Just "urn:ietf:params:xml:ns:xmpp-tls") Nothing ) [] [] + +exampleParams = TLS.defaultParams {TLS.pCiphers = TLS.ciphersuite_strong} + +xmppStartTLS params = do + features <- gets sFeatures + when (stls features) $ do + push starttlsE + Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pull + Just handle <- gets conHandle + (src', snk) <- lift $ TLS.tlsinit params handle + src <- lift . bufferSource $ src' $= CT.decode CT.utf8 $= parseText def + modify (\x -> x + { conSrc = src + , conSink = XR.renderBytes def =$ snk + }) + xmppStartStream + modify (\s -> s{haveTLS = True}) + gets haveTLS + diff --git a/src/Network/XMPPConduit.hs b/src/Network/XMPPConduit.hs new file mode 100644 index 0000000..3a0cd7a --- /dev/null +++ b/src/Network/XMPPConduit.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} +module Network.XMPPConduit where + +import Control.Exception +import Control.Monad +import Control.Monad.ST (runST) +import Control.Monad.Trans +import Control.Monad.Trans.Class +import Control.Monad.Trans.State +import Control.Applicative + + +import Data.Conduit as C +import Data.Conduit.Binary as CB +import Data.Conduit.Text as CT +import Data.Default +import Data.List as L +import Data.Text as T +import Data.XML.Types + +import GHC.IO.Handle + +import Network +import qualified Network.TLSConduit as TLS + +import System.IO +import System.Random + +import Text.XML.Stream.Elements +import Text.XML.Stream.Render as XR +import Text.XML.Stream.Parse + +import qualified Data.Conduit.List as CL + + +xmppSASL = do + return () + +xmppFromHandle handle hostname jid = do + liftIO $ hSetBuffering handle NoBuffering + src <- bufferSource $ CB.sourceHandle handle $= CT.decode CT.utf8 $= parseText def + let st = XMPPState + src + (XR.renderBytes def =$ CB.sinkHandle handle) + (Just handle) + def + False + hostname + jid + flip runStateT st $ do + xmppStartStream + xmppStartTLS + xmppSASL + +main = do + con <- connectTo "localhost" (PortNumber 5222) + hSetBuffering con NoBuffering + fs <- runResourceT $ xmppFromHandle con "species_64739.dyndns.org" "uart14" + putStrLn "" + hGetContents con >>= putStrLn + diff --git a/src/Text/XML/Stream/Elements.hs b/src/Text/XML/Stream/Elements.hs new file mode 100644 index 0000000..8301c7c --- /dev/null +++ b/src/Text/XML/Stream/Elements.hs @@ -0,0 +1,76 @@ +module Text.XML.Stream.Elements where + +import Control.Applicative ((<$>)) +import Control.Monad.Trans.Class + +import Data.Text as T +import Text.XML.Unresolved +import Data.XML.Types + +import Data.Conduit as C +import Data.Conduit.List as CL + +import Text.XML.Stream.Parse + +compressNodes :: [Node] -> [Node] +compressNodes [] = [] +compressNodes [x] = [x] +compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) = + compressNodes $ NodeContent (ContentText $ x `T.append` y) : z +compressNodes (x:xs) = x : compressNodes xs + +elementFromEvents :: C.ResourceThrow m => C.Sink Event m Element +elementFromEvents = do + x <- CL.peek + case x of + Just (EventBeginElement n as) -> goE n as + _ -> lift $ C.resourceThrow $ InvalidEventStream $ "not an element: " ++ show x + where + many f = + go id + where + go front = do + x <- f + case x of + Nothing -> return $ front [] + Just y -> go (front . (:) y) + dropReturn x = CL.drop 1 >> return x + goE n as = do + CL.drop 1 + ns <- many goN + y <- CL.head + if y == Just (EventEndElement n) + then return $ Element n as $ compressNodes ns + else lift $ C.resourceThrow $ InvalidEventStream $ "Missing end element for " ++ show n ++ ", got: " ++ show y + goN = do + x <- CL.peek + case x of + Just (EventBeginElement n as) -> (Just . NodeElement) <$> goE n as + Just (EventInstruction i) -> dropReturn $ Just $ NodeInstruction i + Just (EventContent c) -> dropReturn $ Just $ NodeContent c + Just (EventComment t) -> dropReturn $ Just $ NodeComment t + Just (EventCDATA t) -> dropReturn $ Just $ NodeContent $ ContentText t + _ -> return Nothing + + +elementToEvents' :: Element -> [Event] +elementToEvents' (Element name as ns) = EventBeginElement name as : goN ns [] + where + goM [] = id + goM [x] = (goM' x :) + goM (x:xs) = (goM' x :) . goM xs + goM' (MiscInstruction i) = EventInstruction i + goM' (MiscComment t) = EventComment t + goE (Element name as ns) = + (EventBeginElement name as :) + . goN ns + . (EventEndElement name :) + goN [] = id + goN [x] = goN' x + goN (x:xs) = goN' x . goN xs + goN' (NodeElement e) = goE e + goN' (NodeInstruction i) = (EventInstruction i :) + goN' (NodeContent c) = (EventContent c :) + goN' (NodeComment t) = (EventComment t :) + +elementToEvents e@(Element name _ _) = elementToEvents' e ++ [EventEndElement name] diff --git a/xmpp-lib.cabal b/xmpp-lib.cabal new file mode 100644 index 0000000..e69de29 From 021a0487c37622097f20e9bbc68149efe017e5ac Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 19 Mar 2012 00:54:55 +0100 Subject: [PATCH 02/26] sasl working --- src/Network/XMPP/Monad.hs | 23 ++++++- src/Network/XMPP/SASL.hs | 121 +++++++++++++++++++++++++++++++++++++ src/Network/XMPPConduit.hs | 62 ++++++------------- 3 files changed, 161 insertions(+), 45 deletions(-) create mode 100644 src/Network/XMPP/SASL.hs diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index ae2dfaf..204a4d5 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -4,6 +4,8 @@ import Control.Monad.Trans import Control.Monad.Trans.State import Data.Conduit +import Data.Conduit.Text as CT +import Data.Conduit.Binary as CB import Data.Conduit.List as CL import Data.XML.Types @@ -13,6 +15,8 @@ import Data.Text import System.IO import Text.XML.Stream.Elements +import Text.XML.Stream.Render as XR +import Text.XML.Stream.Parse type XMPPMonad a = StateT XMPPState (ResourceT IO) a @@ -22,8 +26,9 @@ data XMPPState = XMPPState , conHandle :: Maybe Handle , sFeatures :: ServerFeatures , haveTLS :: Bool - , sHostname :: Text - , jid :: Text + , sHostname :: Text + , username :: Text + , resource :: Text } data ServerFeatures = SF @@ -61,3 +66,17 @@ pull :: XMPPMonad Element pull = do source <- gets conSrc pulls elementFromEvents + +xmppFromHandle handle hostname username resource f = runResourceT $ do + liftIO $ hSetBuffering handle NoBuffering + src <- bufferSource $ CB.sourceHandle handle $= CT.decode CT.utf8 $= parseText def + let st = XMPPState + src + (XR.renderBytes def =$ CB.sinkHandle handle) + (Just handle) + def + False + hostname + username + resource + runStateT f st diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs new file mode 100644 index 0000000..396a6e1 --- /dev/null +++ b/src/Network/XMPP/SASL.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} +module Network.XMPP.SASL where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Trans.State + +import qualified Crypto.Classes as CC + +import qualified Data.Attoparsec.ByteString.Char8 as AP +import qualified Data.Binary as Binary +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BL8 +import qualified Data.ByteString.Base64 as B64 +import qualified Data.List as L +import qualified Data.Digest.Pure.MD5 as MD5 +import Data.List +import Data.XML.Types + +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +import Network.XMPP.Monad + +import Numeric -- + +import qualified System.Random as Random + +import Text.XML.Stream.Elements + +saslInitE mechanism = + Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth" + [("mechanism", [ContentText mechanism]) + ] + [] + +saslResponseE resp = + Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" [] + [NodeContent $ ContentText resp] + +saslResponse2E = + Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" [] [] + +xmppSASL passwd = do + mechanisms <- gets $ saslMechanisms . sFeatures + unless ("DIGEST-MD5" `elem` mechanisms) $ error "No usable auth mechanism" + push $ saslInitE "DIGEST-MD5" + Element "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" [] + [NodeContent (ContentText content)] <- pull + let (Right challenge) = B64.decode . Text.encodeUtf8 $ content + let Right pairs = toPairs challenge + liftIO $ BS.putStrLn challenge + push . saslResponseE =<< createResponse passwd pairs + Element name attrs content <- pull + when (name == "{urn:ietf:params:xml:ns:xmpp-sasl}failure") $ + (error $ show content) + push saslResponse2E + Element "{urn:ietf:params:xml:ns:xmpp-sasl}sucess" <- pull + return () + +createResponse passwd' pairs = do + let Just qop = L.lookup "qop" pairs + let Just nonce = L.lookup "nonce" pairs + uname <- Text.encodeUtf8 <$> gets username + let passwd = Text.encodeUtf8 passwd' + realm <- Text.encodeUtf8 <$> gets sHostname + g <- liftIO $ Random.newStdGen + let cnonce = BS.tail . BS.init . + B64.encode . BS.pack . take 8 $ Random.randoms g + let nc = "00000001" + let digestURI = ("xmpp/" `BS.append` realm) + let digest = md5Digest + uname + realm + passwd + digestURI + nc + qop + nonce + cnonce + let response = BS.intercalate"," . map (BS.intercalate "=") $ + [["username" , quote uname ] + ,["realm" , quote realm ] + ,["nonce" , quote nonce ] + ,["cnonce" , quote cnonce ] + ,["nc" , nc ] + ,["qop" , qop ] + ,["digest-uri", quote digestURI ] + ,["response" , digest ] + ,["charset" , "utf-8" ] + ] + liftIO $ BS.putStrLn response + return . Text.decodeUtf8 $ B64.encode response + where quote x = BS.concat ["\"",x,"\""] + +toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)] +toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do + AP.skipSpace + name <- AP.takeWhile1 (/= '=') + AP.char '=' + quote <- ((AP.char '"' >> return True) `mplus` return False) + content <- AP.takeWhile1 (AP.notInClass ",\"" ) + when quote . void $ AP.char '"' + return (name,content) + +hash = BS8.pack . show + . (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":") + +hashRaw = toStrict . Binary.encode + . (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":") + +toStrict = BS.concat . BL.toChunks +-- TODO: this only handles MD5-sess +md5Digest uname realm password digestURI nc qop nonce cnonce= + let ha1 = hash [hashRaw [uname,realm,password], nonce, cnonce] + ha2 = hash ["AUTHENTICATE", digestURI] + in hash [ha1,nonce, nc, cnonce,qop,ha2] + diff --git a/src/Network/XMPPConduit.hs b/src/Network/XMPPConduit.hs index 3a0cd7a..eef010c 100644 --- a/src/Network/XMPPConduit.hs +++ b/src/Network/XMPPConduit.hs @@ -1,61 +1,37 @@ {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} module Network.XMPPConduit where -import Control.Exception import Control.Monad -import Control.Monad.ST (runST) import Control.Monad.Trans -import Control.Monad.Trans.Class -import Control.Monad.Trans.State -import Control.Applicative - -import Data.Conduit as C -import Data.Conduit.Binary as CB -import Data.Conduit.Text as CT -import Data.Default -import Data.List as L -import Data.Text as T -import Data.XML.Types - -import GHC.IO.Handle +import qualified Data.ByteString as BS +import Data.Text as Text import Network -import qualified Network.TLSConduit as TLS +import Network.XMPP.Monad +import Network.XMPP.TLS +import Network.XMPP.Stream +import Network.XMPP.SASL + import System.IO -import System.Random - -import Text.XML.Stream.Elements -import Text.XML.Stream.Render as XR -import Text.XML.Stream.Parse - -import qualified Data.Conduit.List as CL - - -xmppSASL = do - return () - -xmppFromHandle handle hostname jid = do - liftIO $ hSetBuffering handle NoBuffering - src <- bufferSource $ CB.sourceHandle handle $= CT.decode CT.utf8 $= parseText def - let st = XMPPState - src - (XR.renderBytes def =$ CB.sinkHandle handle) - (Just handle) - def - False - hostname - jid - flip runStateT st $ do + +fromHandle :: Handle -> Text -> Text -> Text -> IO ((), XMPPState) +fromHandle handle hostname username password = + xmppFromHandle handle hostname username "" $ do xmppStartStream - xmppStartTLS - xmppSASL + -- this will check whether the server supports tls + -- on it's own + xmppStartTLS exampleParams + xmppSASL password + forever $ pull >>= liftIO . print + return () main = do con <- connectTo "localhost" (PortNumber 5222) hSetBuffering con NoBuffering - fs <- runResourceT $ xmppFromHandle con "species_64739.dyndns.org" "uart14" + (fs,st) <- fromHandle con "species64739.dyndns.org" "bot" "pwd" + print $ haveTLS st putStrLn "" hGetContents con >>= putStrLn From 0651bcd18f15b13337049cd380dea90c9db86c9b Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 19 Mar 2012 17:21:36 +0100 Subject: [PATCH 03/26] first stab at types and marshaling --- src/Network/XMPP/Marshal.hs | 170 +++++++++++++++++++++++++++++++++ src/Network/XMPP/SASL.hs | 6 +- src/Network/XMPP/Stream.hs | 5 +- src/Network/XMPP/Types.hs | 181 ++++++++++++++++++++++++++++++++++++ src/Network/XMPPConduit.hs | 2 + 5 files changed, 360 insertions(+), 4 deletions(-) create mode 100644 src/Network/XMPP/Marshal.hs create mode 100644 src/Network/XMPP/Types.hs diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs new file mode 100644 index 0000000..ea9bbf1 --- /dev/null +++ b/src/Network/XMPP/Marshal.hs @@ -0,0 +1,170 @@ +{-# Language OverloadedStrings, ViewPatterns, NoMonomorphismRestriction #-} + +module Network.XMPP.Marshal where + +import Control.Applicative((<$>)) + +import Control.Monad.State + +import Data.Maybe + +import qualified Data.Text as Text +import Data.XML.Types + +import Network.XMPP.Types + + +-- create attribute from Just +matr _ Nothing = [] +matr n (Just x) = [(n,x)] + +-- Child if text is not empty +nech _ "" = [] +nech n x = [ NodeElement (Element n [] [NodeContent (ContentText x) ]) ] + +-- Child if text is not Nothing +mnech _ Nothing = [] +mnech n (Just x) = [ NodeElement (Element n [] [NodeContent (ContentText x) ]) ] + +-- make Attributes from text +contentify (x,y) = (x, [ContentText y]) + +-- Marshal Message to XML Element +messageToElement (Message from to ident tp sub body thread exts) = + Element "message" + (map contentify . concat $ + [ matr "from" (toText <$> from) + , [("to", toText to)] + , matr "id" ident + , [("type", toText tp)] + ]) + (concat $ + [ mnech "subject" sub + , mnech "body" body + , mnech "thread" thread + , map NodeElement exts + ]) + +-- Marshal XML element to message +elementToMessage e@(Element "message" _ _) = + let from = fromText <$> attributeText "from" e + Just to = fromText <$> attributeText "to" e + ident = attributeText "id" e + Just tp = fromText <$> attributeText "type" e + -- Oh dear, this is HORRIBLE. TODO: come up with something sane + in grabFrom (elementChildren e) $ do + -- TODO multiple bodies (different languages) + body <- maybeGrabNamed "body" + -- TODO multiple subjects (different languages) + subject <- maybeGrabNamed "subject" + thread <- maybeGrabNamed "thread" + ext <- grabRest + return $ Message + from + to + ident + tp + (elementToText <$>subject) + (elementToText <$> body) + (elementToText <$> thread) + ext + +presenceTOXML (Presence from to id tp stp stat pri exts) = + Element "message" + (map contentify . concat $ + [ matr "from" (toText <$> from) + , matr "to" (toText <$> to) + , matr "id" id + , matr "type" ( toText <$> tp) + ]) + (concat $ + [ mnech "show" (toText <$> stp) + , mnech "status" stat + , mnech "priority" (Text.pack . show <$> pri) + , map NodeElement exts + ]) + +-- Marshal XML element to message +elementToPresence e@(Element "message" _ _) = + let from = fromText <$> attributeText "from" e + to = fromText <$> attributeText "to" e + ident = attributeText "id" e + tp = fromText <$> attributeText "type" e + in grabFrom (elementChildren e) $ do + pshow <- maybeGrabNamed "show" + -- TODO multiple status (different languages) + stat <- maybeGrabNamed "status" + prio <- maybeGrabNamed "priority" + ext <- grabRest + return $ Presence + from + to + ident + tp + (fromText . elementToText <$> pshow) + (elementToText <$> stat) + (read . Text.unpack . elementToText <$> prio) + ext + + +iqToElement (IQ from to id tp body) = + Element "message" + (map contentify . concat $ + [ matr "from" (toText <$> from) + , matr "to" (toText <$> to ) + , [("id" , id)] + , [("type", toText tp)] + ]) + [ NodeElement body ] + +elementToIQ e@(Element "iq" _ _) = + let from = fromText <$> attributeText "from" e + to = fromText <$> attributeText "to" e + Just ident= attributeText "id" e + Just tp = fromText <$> attributeText "type" e + [ext] = elementChildren e + in IQ + from + to + ident + tp + ext + +-- take and remove all elements matching a predicate from the list +takeAllFromList pred l = let (l', xs) = go pred [] l in (reverse l', xs) + where + go pred ys [] = (ys, []) + go pred ys (x:xs) = + case pred x of + True -> let (ys', rs) = go pred ys xs in (ys', x:rs) + False -> go pred (x:ys) xs + +-- The "Grab Monad" : sucessively take and remove ("grab") +-- elements from a "pool" (list) + +-- Put a list of elements into the pool and start grabbing +grabFrom l = flip runState l + +-- grab all elements matching predicate out of the pool +grabAll p = do + l <- get + let (l', xs) = takeAllFromList p l + put l' + return xs + +-- grab XML-elements by exact name +grabNamed = grabAll . hasName + +-- This throws away all elements after the first one +-- TODO: Be more stricy here +maybeGrabNamed = liftM listToMaybe . grabAll . hasName + +-- grab all remaining elements from the pool +grabRest = do + l <- get + put [] + return l + +hasName x e = x == elementName e + +elementToText = Text.concat . elementText \ No newline at end of file diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 396a6e1..886cb83 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -24,6 +24,7 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Network.XMPP.Monad +import Network.XMPP.Stream import Numeric -- @@ -52,13 +53,13 @@ xmppSASL passwd = do [NodeContent (ContentText content)] <- pull let (Right challenge) = B64.decode . Text.encodeUtf8 $ content let Right pairs = toPairs challenge - liftIO $ BS.putStrLn challenge push . saslResponseE =<< createResponse passwd pairs Element name attrs content <- pull when (name == "{urn:ietf:params:xml:ns:xmpp-sasl}failure") $ (error $ show content) push saslResponse2E - Element "{urn:ietf:params:xml:ns:xmpp-sasl}sucess" <- pull + Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pull + xmppStartStream return () createResponse passwd' pairs = do @@ -92,7 +93,6 @@ createResponse passwd' pairs = do ,["response" , digest ] ,["charset" , "utf-8" ] ] - liftIO $ BS.putStrLn response return . Text.decodeUtf8 $ B64.encode response where quote x = BS.concat ["\"",x,"\""] diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index c38be19..70ea683 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -31,7 +31,10 @@ xmppStream = do xmppStreamHeader :: Resource m => Sink Event m () xmppStreamHeader = do - Just EventBeginDocument <- CL.head + hd <- CL.peek + case hd of + Just EventBeginDocument -> CL.drop 1 + _ -> return () Just (EventBeginElement "{http://etherx.jabber.org/streams}stream" streamAttrs) <- CL.head unless (checkVersion streamAttrs) $ error "Not XMPP version 1.0 " return () diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs new file mode 100644 index 0000000..5dc6d13 --- /dev/null +++ b/src/Network/XMPP/Types.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.XMPP.Types where +-- proudly "borrowed" from haskell-xmpp + +import Control.Applicative((<$>)) +import Control.Monad + +import Data.Maybe +import Data.Text as Text +import Data.String as Str +import Data.XML.Types + +class ToText a where + toText :: a -> Text + +class FromText a where + fromText :: Text -> a + +-- | Jabber ID (JID) datatype +data JID = JID { node :: Maybe Text + -- ^ Account name + , domain :: Text + -- ^ Server adress + , resource :: Maybe Text + -- ^ Resource name + } +instance ToText JID where + toText (JID n d r) = + let n' = maybe "" (`append` "@" ) n + r' = maybe "" ("/" `append` ) r + in Text.concat [n', d, r'] + +instance FromText JID where + fromText = parseJID + +instance Show JID where + show = Text.unpack . toText + +-- Ugh, that smells a bit. +parseJID jid = + let (jid', rst) = case Text.splitOn "@" jid of + [rest] -> (JID Nothing, rest) + [node,rest] -> (JID (Just node), rest) + _ -> error $ "Couldn't parse JID: \"" ++ Text.unpack jid ++ "\"" + in case Text.splitOn "/" rst of + [domain] -> jid' domain Nothing + [domain, resource] -> jid' domain (Just resource) + _ -> error $ "Couldn't parse JID: \"" ++ Text.unpack jid ++ "\"" + +instance IsString JID where + fromString = parseJID . Text.pack + + +-- should we factor from, to and id out, even though they are +-- sometimes mandatory? +data Message = Message + { mFrom :: Maybe JID + , mTo :: JID + , mId :: Maybe Text + -- ^ Message 'from', 'to', 'id' attributes + , mType :: MessageType + -- ^ Message type (2.1.1) + , mSubject :: Maybe Text + -- ^ Subject element (2.1.2.1) + , mBody :: Maybe Text + -- ^ Body element (2.1.2.2) + , mThread :: Maybe Text + -- ^ Thread element (2.1.2.3) + , mExt :: [Element] + -- ^ Additional contents, used for extensions + } deriving Show + +data Presence = Presence + { pFrom :: Maybe JID + , pTo :: Maybe JID + , pId :: Maybe Text + -- ^ Presence 'from', 'to', 'id' attributes + , pType :: Maybe PresenceType + -- ^ Presence type (2.2.1) + , pShowType :: Maybe ShowType + -- ^ Show element (2.2.2.1) + , pStatus :: Maybe Text + -- ^ Status element (2.2.2.2) + , pPriority :: Maybe Int + -- ^ Presence priority (2.2.2.3) + , pExt :: [Element] + -- ^ Additional contents, used for extensions + } + +data IQ = IQ + { iqFrom :: Maybe JID + , iqTo :: Maybe JID + , iqId :: Text + -- ^ IQ id (Core-9.2.3) + , iqType :: IQType + -- ^ IQ type (Core-9.2.3) + , iqBody :: Element + -- ^ Child element (Core-9.2.3) + } + +data Stanza = SMessage Message | SPresence Presence | SIQ IQ -- deriving Show + +data MessageType = Chat | GroupChat | Headline | Normal | MessageError deriving (Eq, Show) + +data PresenceType = Default | Unavailable | Subscribe | Subscribed | Unsubscribe | Unsubscribed | Probe | PresenceError deriving Eq + +data IQType = Get | Result | Set | IQError deriving Eq + +data ShowType = Available | Away | FreeChat | DND | XAway deriving Eq + +instance ToText MessageType where + toText Chat = "chat" + toText GroupChat = "groupchat" + toText Headline = "headline" + toText Normal = "normal" + toText MessageError = "error" + +instance ToText PresenceType where + toText Default = "" + toText Unavailable = "unavailable" + toText Subscribe = "subscribe" + toText Subscribed = "subscribed" + toText Unsubscribe = "unsubscribe" + toText Unsubscribed = "unsubscribed" + toText Probe = "probe" + toText PresenceError = "error" + +instance ToText IQType where + toText Get = "get" + toText Result = "result" + toText Set = "set" + toText IQError = "error" + +instance ToText ShowType where + toText Available = "" + toText Away = "away" + toText FreeChat = "chat" + toText DND = "dnd" + toText XAway = "xa" + + +instance FromText MessageType where + fromText "chat" = Chat + fromText "groupchat" = GroupChat + fromText "headline" = Headline + fromText "normal" = Normal + fromText "error" = MessageError + fromText "" = Chat + fromText _ = error "incorrect message type" + +instance FromText PresenceType where + fromText "" = Default + fromText "available" = Default + fromText "unavailable" = Unavailable + fromText "subscribe" = Subscribe + fromText "subscribed" = Subscribed + fromText "unsubscribe" = Unsubscribe + fromText "unsubscribed" = Unsubscribed + fromText "probe" = Probe + fromText "error" = PresenceError + fromText _ = error "incorrect presence type" + +instance FromText IQType where + fromText "get" = Get + fromText "result" = Result + fromText "set" = Set + fromText "error" = IQError + fromText "" = Get + fromText _ = error "incorrect iq type" + +instance FromText ShowType where + fromText "" = Available + fromText "available" = Available + fromText "away" = Away + fromText "chat" = FreeChat + fromText "dnd" = DND + fromText "xa" = XAway + fromText "invisible" = Available + fromText _ = error "incorrect value" + diff --git a/src/Network/XMPPConduit.hs b/src/Network/XMPPConduit.hs index eef010c..b99135a 100644 --- a/src/Network/XMPPConduit.hs +++ b/src/Network/XMPPConduit.hs @@ -3,6 +3,7 @@ module Network.XMPPConduit where import Control.Monad import Control.Monad.Trans +import Control.Monad.Trans.State import qualified Data.ByteString as BS import Data.Text as Text @@ -24,6 +25,7 @@ fromHandle handle hostname username password = -- on it's own xmppStartTLS exampleParams xmppSASL password + gets haveTLS >>= liftIO . print forever $ pull >>= liftIO . print return () From cebc4688526520c46e3fa941c636f07bee3c1902 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 19 Mar 2012 19:18:06 +0100 Subject: [PATCH 04/26] bind --- src/Network/TLSConduit.hs | 18 ++++++++++-- src/Network/XMPP/Bind.hs | 30 +++++++++++++++++++ src/Network/XMPP/Marshal.hs | 58 +++++++++++++++++++++++-------------- src/Network/XMPP/Monad.hs | 40 ++++++++++++++++--------- src/Network/XMPP/SASL.hs | 14 ++++----- src/Network/XMPP/TLS.hs | 14 ++++----- src/Network/XMPPConduit.hs | 11 ++++--- 7 files changed, 129 insertions(+), 56 deletions(-) create mode 100644 src/Network/XMPP/Bind.hs diff --git a/src/Network/TLSConduit.hs b/src/Network/TLSConduit.hs index 7eedcf4..e1faf1a 100644 --- a/src/Network/TLSConduit.hs +++ b/src/Network/TLSConduit.hs @@ -10,7 +10,7 @@ import Control.Monad.Trans import Crypto.Random -import Data.ByteString +import Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import Data.Conduit @@ -20,6 +20,8 @@ import Network.TLS.Extra as TLSExtra import System.IO(Handle) import System.Random +import System.IO + tlsinit :: (MonadIO m, ResourceIO m1) => TLSParams -> Handle @@ -37,4 +39,16 @@ tlsinit tlsParams handle = do (\_ -> return ()) (\ctx dt -> sendData ctx (BL.fromChunks [dt]) >> return IOProcessing) (\_ -> return ()) - return (src, snk) + return (src $= conduitStdout , snk) + +-- TODO: remove + +conduitStdout :: ResourceIO m + => Conduit BS.ByteString m BS.ByteString +conduitStdout = conduitIO + (return ()) + (\_ -> return ()) + (\_ bs -> do + liftIO $ BS.hPut stdout bs + return $ IOProducing [bs]) + (const $ return []) \ No newline at end of file diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs new file mode 100644 index 0000000..1cdaa77 --- /dev/null +++ b/src/Network/XMPP/Bind.hs @@ -0,0 +1,30 @@ +module Network.XMPP.Bind where + +import Control.Monad.Trans.State + +import Data.Text as Text +import Data.XML.Types + +import Network.XMPP.Monad +import Network.XMPP.Types +import Network.XMPP.Marshal + +bindSt resource= SIQ $ IQ Nothing Nothing "bind" Set + (Element "{urn:ietf:params:xml:ns:xmpp-bind}bind" + [] + (maybe [] (return . textToNode) resource)) + + +xmppBind = do + res <- gets sResource + push $ bindSt res + SIQ (IQ Nothing Nothing _ Result r) <- pull + (JID n d (Just r)) <- case r of + Element "{urn:ietf:params:xml:ns:xmpp-bind}bind" [] + [NodeElement + jid@(Element "{urn:ietf:params:xml:ns:xmpp-bind}jid" [] _)] -> + return . fromText . Text.concat . elementText $ jid + _ -> error $ "bind failed:" ++ show r + modify (\s -> s{sResource = Just r}) + + diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index ea9bbf1..8b136e5 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/src/Network/XMPP/Marshal.hs @@ -13,6 +13,18 @@ import Data.XML.Types import Network.XMPP.Types +stanzaToElement (SMessage m) = messageToElement m +stanzaToElement (SPresence m) = presenceToElement m +stanzaToElement (SIQ m) = iqToElement m + +elementToStanza e@(Element (Name n ns Nothing) _ _) = + if (ns `elem` [Nothing, Just "jabber:client"]) then + case n of + "message" -> SMessage $ elementToMessage e + "presence" -> SPresence $ elementToPresence e + "iq" -> SIQ $ elementToIQ e + s -> error $ "unknown stanza type :" ++ show e + else error $ "unknown namespace: " ++ show ns -- create attribute from Just matr _ Nothing = [] @@ -54,23 +66,23 @@ elementToMessage e@(Element "message" _ _) = -- Oh dear, this is HORRIBLE. TODO: come up with something sane in grabFrom (elementChildren e) $ do -- TODO multiple bodies (different languages) - body <- maybeGrabNamed "body" - -- TODO multiple subjects (different languages) - subject <- maybeGrabNamed "subject" - thread <- maybeGrabNamed "thread" - ext <- grabRest - return $ Message - from - to - ident - tp - (elementToText <$>subject) - (elementToText <$> body) - (elementToText <$> thread) - ext - -presenceTOXML (Presence from to id tp stp stat pri exts) = - Element "message" + body <- maybeGrabNamed "body" + -- TODO multiple subjects (different languages) + subject <- maybeGrabNamed "subject" + thread <- maybeGrabNamed "thread" + ext <- grabRest + return $ Message + from + to + ident + tp + (elementToText <$>subject) + (elementToText <$> body) + (elementToText <$> thread) + ext + +presenceToElement (Presence from to id tp stp stat pri exts) = + Element "presence" (map contentify . concat $ [ matr "from" (toText <$> from) , matr "to" (toText <$> to) @@ -85,7 +97,7 @@ presenceTOXML (Presence from to id tp stp stat pri exts) = ]) -- Marshal XML element to message -elementToPresence e@(Element "message" _ _) = +elementToPresence e@(Element (Name "message" _ _) _ _) = let from = fromText <$> attributeText "from" e to = fromText <$> attributeText "to" e ident = attributeText "id" e @@ -108,7 +120,7 @@ elementToPresence e@(Element "message" _ _) = iqToElement (IQ from to id tp body) = - Element "message" + Element "iq" (map contentify . concat $ [ matr "from" (toText <$> from) , matr "to" (toText <$> to ) @@ -117,7 +129,7 @@ iqToElement (IQ from to id tp body) = ]) [ NodeElement body ] -elementToIQ e@(Element "iq" _ _) = +elementToIQ e@(Element (Name "iq" _ _) _ _ ) = let from = fromText <$> attributeText "from" e to = fromText <$> attributeText "to" e Just ident= attributeText "id" e @@ -143,7 +155,7 @@ takeAllFromList pred l = let (l', xs) = go pred [] l in (reverse l', xs) -- elements from a "pool" (list) -- Put a list of elements into the pool and start grabbing -grabFrom l = flip runState l +grabFrom l = fst . flip runState l -- grab all elements matching predicate out of the pool grabAll p = do @@ -167,4 +179,6 @@ grabRest = do hasName x e = x == elementName e -elementToText = Text.concat . elementText \ No newline at end of file +elementToText = Text.concat . elementText + +textToNode t = NodeContent (ContentText t) \ No newline at end of file diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 204a4d5..37d77af 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -1,5 +1,7 @@ module Network.XMPP.Monad where +import Control.Applicative((<$>)) + import Control.Monad.Trans import Control.Monad.Trans.State @@ -12,6 +14,9 @@ import Data.XML.Types import Data.Default import Data.Text +import Network.XMPP.Types +import Network.XMPP.Marshal + import System.IO import Text.XML.Stream.Elements @@ -21,14 +26,14 @@ import Text.XML.Stream.Parse type XMPPMonad a = StateT XMPPState (ResourceT IO) a data XMPPState = XMPPState - { conSrc :: BufferedSource IO Event - , conSink :: Sink Event IO () - , conHandle :: Maybe Handle + { sConSrc :: BufferedSource IO Event + , sConSink :: Sink Event IO () + , sConHandle :: Maybe Handle , sFeatures :: ServerFeatures - , haveTLS :: Bool + , sHaveTLS :: Bool , sHostname :: Text - , username :: Text - , resource :: Text + , sUsername :: Text + , sResource :: Maybe Text } data ServerFeatures = SF @@ -46,27 +51,34 @@ instance Default ServerFeatures where , other = [] } -push :: Element -> XMPPMonad () -push x = do - sink <- gets conSink + +pushE :: Element -> XMPPMonad () +pushE x = do + sink <- gets sConSink lift $ CL.sourceList (elementToEvents x) $$ sink +push :: Stanza -> XMPPMonad () +push = pushE . stanzaToElement + pushOpen :: Element -> XMPPMonad () pushOpen x = do - sink <- gets conSink + sink <- gets sConSink lift $ CL.sourceList (elementToEvents' x) $$ sink pulls :: Sink Event IO a -> XMPPMonad a pulls snk = do - source <- gets conSrc + source <- gets sConSrc lift $ source $$ snk -pull :: XMPPMonad Element -pull = do - source <- gets conSrc +pullE :: XMPPMonad Element +pullE = do + source <- gets sConSrc pulls elementFromEvents +pull :: XMPPMonad Stanza +pull = elementToStanza <$> pullE + xmppFromHandle handle hostname username resource f = runResourceT $ do liftIO $ hSetBuffering handle NoBuffering src <- bufferSource $ CB.sourceHandle handle $= CT.decode CT.utf8 $= parseText def diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 886cb83..ec891b1 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -48,24 +48,24 @@ saslResponse2E = xmppSASL passwd = do mechanisms <- gets $ saslMechanisms . sFeatures unless ("DIGEST-MD5" `elem` mechanisms) $ error "No usable auth mechanism" - push $ saslInitE "DIGEST-MD5" + pushE $ saslInitE "DIGEST-MD5" Element "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" [] - [NodeContent (ContentText content)] <- pull + [NodeContent (ContentText content)] <- pullE let (Right challenge) = B64.decode . Text.encodeUtf8 $ content let Right pairs = toPairs challenge - push . saslResponseE =<< createResponse passwd pairs - Element name attrs content <- pull + pushE . saslResponseE =<< createResponse passwd pairs + Element name attrs content <- pullE when (name == "{urn:ietf:params:xml:ns:xmpp-sasl}failure") $ (error $ show content) - push saslResponse2E - Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pull + pushE saslResponse2E + Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pullE xmppStartStream return () createResponse passwd' pairs = do let Just qop = L.lookup "qop" pairs let Just nonce = L.lookup "nonce" pairs - uname <- Text.encodeUtf8 <$> gets username + uname <- Text.encodeUtf8 <$> gets sUsername let passwd = Text.encodeUtf8 passwd' realm <- Text.encodeUtf8 <$> gets sHostname g <- liftIO $ Random.newStdGen diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index c351acc..4404529 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -29,16 +29,16 @@ exampleParams = TLS.defaultParams {TLS.pCiphers = TLS.ciphersuite_strong} xmppStartTLS params = do features <- gets sFeatures when (stls features) $ do - push starttlsE - Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pull - Just handle <- gets conHandle + pushE starttlsE + Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pullE + Just handle <- gets sConHandle (src', snk) <- lift $ TLS.tlsinit params handle src <- lift . bufferSource $ src' $= CT.decode CT.utf8 $= parseText def modify (\x -> x - { conSrc = src - , conSink = XR.renderBytes def =$ snk + { sConSrc = src + , sConSink = XR.renderBytes def =$ snk }) xmppStartStream - modify (\s -> s{haveTLS = True}) - gets haveTLS + modify (\s -> s{sHaveTLS = True}) + gets sHaveTLS diff --git a/src/Network/XMPPConduit.hs b/src/Network/XMPPConduit.hs index b99135a..5c11a6d 100644 --- a/src/Network/XMPPConduit.hs +++ b/src/Network/XMPPConduit.hs @@ -13,27 +13,30 @@ import Network.XMPP.Monad import Network.XMPP.TLS import Network.XMPP.Stream import Network.XMPP.SASL +import Network.XMPP.Bind import System.IO fromHandle :: Handle -> Text -> Text -> Text -> IO ((), XMPPState) fromHandle handle hostname username password = - xmppFromHandle handle hostname username "" $ do + xmppFromHandle handle hostname username Nothing $ do xmppStartStream -- this will check whether the server supports tls -- on it's own xmppStartTLS exampleParams xmppSASL password - gets haveTLS >>= liftIO . print - forever $ pull >>= liftIO . print + xmppBind + gets sResource >>= liftIO . print + gets sHaveTLS >>= liftIO . print + forever $ pullE >>= liftIO . print return () main = do con <- connectTo "localhost" (PortNumber 5222) hSetBuffering con NoBuffering (fs,st) <- fromHandle con "species64739.dyndns.org" "bot" "pwd" - print $ haveTLS st + print $ sHaveTLS st putStrLn "" hGetContents con >>= putStrLn From d11434f18f86ab5983046945c537f034b98000fc Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 21 Mar 2012 12:13:17 +0100 Subject: [PATCH 05/26] switched to hexpat --- src/Data/Conduit/Hexpat.hs | 184 ++++++++++++++ .../TLSConduit.hs => Data/Conduit/TLS.hs} | 16 +- src/Network/XMPP/Bind.hs | 36 ++- src/Network/XMPP/Marshal.hs | 230 +++++------------- src/Network/XMPP/Monad.hs | 79 +++--- src/Network/XMPP/Pickle.hs | 66 +++++ src/Network/XMPP/SASL.hs | 57 +++-- src/Network/XMPP/Stream.hs | 115 +++++---- src/Network/XMPP/TLS.hs | 32 +-- src/Network/XMPP/Types.hs | 227 +++++++++-------- src/Network/XMPPConduit.hs | 9 +- src/Text/XML/Stream/Elements.hs | 76 ------ src/Utils.hs | 7 + 13 files changed, 636 insertions(+), 498 deletions(-) create mode 100644 src/Data/Conduit/Hexpat.hs rename src/{Network/TLSConduit.hs => Data/Conduit/TLS.hs} (70%) create mode 100644 src/Network/XMPP/Pickle.hs delete mode 100644 src/Text/XML/Stream/Elements.hs create mode 100644 src/Utils.hs diff --git a/src/Data/Conduit/Hexpat.hs b/src/Data/Conduit/Hexpat.hs new file mode 100644 index 0000000..191bee1 --- /dev/null +++ b/src/Data/Conduit/Hexpat.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE DeriveDataTypeable, NoMonomorphismRestriction #-} + +module Data.Conduit.Hexpat where + +import Control.Applicative((<$>)) +import Control.Exception +import Control.Monad +import Control.Monad.Trans + +import qualified Data.ByteString as BS +import Data.Conduit as C +import Data.Conduit.List as CL +import Data.Maybe +import Data.Typeable + +import Text.XML.Expat.Internal.IO hiding (parse) +import Text.XML.Expat.SAX +import Text.XML.Expat.Tree + +import Foreign.Ptr + +import Data.IORef +-- adapted from parseG + +-- | Parse a generalized list of ByteStrings containing XML to SAX events. +-- In the event of an error, FailDocument is the last element of the output list. +-- parseG :: forall tag text l . (GenericXMLString tag, GenericXMLString text, List l) => +-- ParseOptions tag text -- ^ Parse options +-- -> l ByteString -- ^ Input text (a lazy ByteString) +-- -> l (SAXEvent tag text) +-- parseG opts inputBlocks = runParser inputBlocks parser queueRef cacheRef +-- where + +data HexpatParser tag text a = HexpatParser + { hParser :: Parser + , hQueueRef :: IORef [SAXEvent tag text] + } + +createParser + :: (GenericXMLString tag, GenericXMLString text) => + ParseOptions tag text -> IO (HexpatParser tag text a) +createParser opts = do + let enc = overrideEncoding opts + let mEntityDecoder = entityDecoder opts + + parser <- newParser enc + queueRef <- newIORef [] + + case mEntityDecoder of + Just deco -> setEntityDecoder parser deco $ \_ txt -> do + modifyIORef queueRef (CharacterData txt:) + Nothing -> return () + + setXMLDeclarationHandler parser $ \_ cVer cEnc cSd -> do + ver <- textFromCString cVer + mEnc <- if cEnc == nullPtr + then return Nothing + else Just <$> textFromCString cEnc + let sd = if cSd < 0 + then Nothing + else Just $ if cSd /= 0 then True else False + modifyIORef queueRef (XMLDeclaration ver mEnc sd:) + return True + + setStartElementHandler parser $ \_ cName cAttrs -> do + name <- textFromCString cName + attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do + attrName <- textFromCString cAttrName + attrValue <- textFromCString cAttrValue + return (attrName, attrValue) + modifyIORef queueRef (StartElement name attrs:) + return True + + setEndElementHandler parser $ \_ cName -> do + name <- textFromCString cName + modifyIORef queueRef (EndElement name:) + return True + + setCharacterDataHandler parser $ \_ cText -> do + txt <- gxFromCStringLen cText + modifyIORef queueRef (CharacterData txt:) + return True + + setStartCDataHandler parser $ \_ -> do + modifyIORef queueRef (StartCData :) + return True + + setEndCDataHandler parser $ \_ -> do + modifyIORef queueRef (EndCData :) + return True + + setProcessingInstructionHandler parser $ \_ cTarget cText -> do + target <- textFromCString cTarget + txt <- textFromCString cText + modifyIORef queueRef (ProcessingInstruction target txt :) + return True + + setCommentHandler parser $ \_ cText -> do + txt <- textFromCString cText + modifyIORef queueRef (Comment txt :) + return True + + return (HexpatParser parser queueRef) + +data HexpatParseException = HexpatParseExceptio String deriving (Typeable, Show) +instance Exception HexpatParseException + +parseBS + :: (GenericXMLString text, GenericXMLString tag) => + ParseOptions tag text + -> Conduit BS.ByteString IO (SAXEvent tag text) +parseBS opts = conduitIO + (createParser opts) + (\_ -> return ()) + (\(HexpatParser parser queueRef) input -> do + error <- withParser parser $ \pp -> parseChunk pp input False + case error of + Nothing -> return () + Just (XMLParseError err _) -> + resourceThrow $ HexpatParseExceptio err + queue <- readIORef queueRef + writeIORef queueRef [] + return . IOProducing $ reverse queue + ) + (\(HexpatParser parser queueRef) -> do + error <- withParser parser $ \pp -> parseChunk pp BS.empty True + case error of + Nothing -> return () + Just (XMLParseError err _) -> + resourceThrow $ HexpatParseExceptio err + queue <- readIORef queueRef + writeIORef queueRef [] + return $ reverse queue + ) + +whileJust :: Monad m => m (Maybe a) -> m [a] +whileJust f = do + f' <- f + case f' of + Just x -> liftM (x :) $ whileJust f + Nothing -> return [] + + + +data StreamUnfinishedException = StreamUnfinishedException deriving (Typeable, Show) +instance Exception StreamUnfinishedException + + +elementFromEvents + :: (Eq tag, Show tag, MonadIO m, Resource m) => + Sink (SAXEvent tag text) m (NodeG [] tag text) +elementFromEvents = do + Just (StartElement name attrs) <- CL.head + children <- liftM catMaybes . whileJust $ do + next' <- CL.peek + next <- case next' of + Nothing -> liftIO . throwIO $ StreamUnfinishedException + Just n -> return n + case next of + StartElement _ _ -> Just . Just <$> elementFromEvents + EndElement n -> if n == name then CL.drop 1 >> return Nothing + else error $ "closing wrong element: " + ++ show n ++ " instead of " ++ show name + CharacterData txt -> CL.drop 1 >> (return . Just . Just $ Text txt) + _ -> return $ Just Nothing + return $ Element name attrs children + +openElementFromEvents + :: Resource m => Sink (SAXEvent tag text) m (NodeG [] tag text) +openElementFromEvents = do + throwOutJunk + Just (StartElement name attrs) <- CL.head + return $ Element name attrs [] + +throwOutJunk :: Resource m => Sink (SAXEvent t t1) m () +throwOutJunk = do + next <- peek + case next of + Nothing -> return () + Just (StartElement _ _) -> return () + _ -> CL.drop 1 >> throwOutJunk + +saxToElements = C.sequence $ throwOutJunk >> elementFromEvents + diff --git a/src/Network/TLSConduit.hs b/src/Data/Conduit/TLS.hs similarity index 70% rename from src/Network/TLSConduit.hs rename to src/Data/Conduit/TLS.hs index e1faf1a..e0a2565 100644 --- a/src/Network/TLSConduit.hs +++ b/src/Data/Conduit/TLS.hs @@ -1,4 +1,4 @@ -module Network.TLSConduit +module Data.Conduit.TLS ( tlsinit , module TLS , module TLSExtra @@ -10,7 +10,7 @@ import Control.Monad.Trans import Crypto.Random -import Data.ByteString as BS +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import Data.Conduit @@ -25,21 +25,17 @@ import System.IO tlsinit :: (MonadIO m, ResourceIO m1) => TLSParams -> Handle - -> m (Source m1 ByteString, Sink ByteString m1 ()) + -> m (Source m1 BS.ByteString, (BS.ByteString -> IO ())) tlsinit tlsParams handle = do gen <- liftIO $ (newGenIO :: IO SystemRandom) -- TODO: Find better random source? clientContext <- client tlsParams gen handle handshake clientContext let src = sourceIO (return clientContext) - bye + (\_ -> putStrLn "tls closed") (\con -> IOOpen <$> recvData con) - let snk = sinkIO - (return clientContext) - (\_ -> return ()) - (\ctx dt -> sendData ctx (BL.fromChunks [dt]) >> return IOProcessing) - (\_ -> return ()) - return (src $= conduitStdout , snk) + return (src $= conduitStdout + , \s -> sendData clientContext $ BL.fromChunks [s] ) -- TODO: remove diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index 1cdaa77..aba68c5 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -1,30 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + module Network.XMPP.Bind where +import Control.Monad.Trans import Control.Monad.Trans.State import Data.Text as Text -import Data.XML.Types import Network.XMPP.Monad import Network.XMPP.Types +import Network.XMPP.Pickle import Network.XMPP.Marshal -bindSt resource= SIQ $ IQ Nothing Nothing "bind" Set - (Element "{urn:ietf:params:xml:ns:xmpp-bind}bind" - [] - (maybe [] (return . textToNode) resource)) +import Text.XML.Expat.Pickle + +bindReqIQ resource= SIQ $ IQ Nothing Nothing "bind" Set + (pickleElem + (bindP . xpOption + $ xpElemNodes "resource" (xpContent xpText)) + resource + ) +jidP :: PU [Node Text Text] JID +jidP = bindP $ xpElemNodes "jid" (xpContent xpPrim) xmppBind = do res <- gets sResource - push $ bindSt res - SIQ (IQ Nothing Nothing _ Result r) <- pull - (JID n d (Just r)) <- case r of - Element "{urn:ietf:params:xml:ns:xmpp-bind}bind" [] - [NodeElement - jid@(Element "{urn:ietf:params:xml:ns:xmpp-bind}jid" [] _)] -> - return . fromText . Text.concat . elementText $ jid - _ -> error $ "bind failed:" ++ show r + push $ bindReqIQ res + answer <- pull + liftIO $ print answer + let SIQ (IQ Nothing Nothing _ Result b) = answer + let (JID n d (Just r)) = unpickleElem jidP b modify (\s -> s{sResource = Just r}) +bindP c = ignoreAttrs $ xpElemNs "bind" "urn:ietf:params:xml:ns:xmpp-bind" + xpUnit + c + diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index 8b136e5..5eedc1b 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/src/Network/XMPP/Marshal.hs @@ -9,176 +9,68 @@ import Control.Monad.State import Data.Maybe import qualified Data.Text as Text -import Data.XML.Types +import Network.XMPP.Pickle import Network.XMPP.Types -stanzaToElement (SMessage m) = messageToElement m -stanzaToElement (SPresence m) = presenceToElement m -stanzaToElement (SIQ m) = iqToElement m +import Text.XML.Expat.Pickle + +stanzaSel (SMessage _ )= 0 +stanzaSel (SPresence _ )= 1 +stanzaSel (SIQ _ )= 2 + +stanzaP = xpAlt stanzaSel + [ xpWrap (SMessage , (\(SMessage m) -> m)) messageP + , xpWrap (SPresence , (\(SPresence p) -> p)) presenceP + , xpWrap (SIQ , (\(SIQ i) -> i)) iqP + ] + +messageP = xpWrap ( (\((from, to, id, tp),(body, sub, thr,ext)) + -> Message from to id tp body sub thr ext) + , (\(Message from to id tp body sub thr ext) + -> ((from, to, id, tp), (body, sub, thr,ext))) + ) $ + xpElem "message" + (xp4Tuple + (xpAttrImplied "from" xpPrim) + (xpAttr "to" xpPrim) + (xpAttrImplied "id" xpText) + (xpAttrImplied "type" xpPrim) + ) + (xp4Tuple + (xpOption . xpElemNodes "body" $ xpContent xpText) + (xpOption . xpElemNodes "subject" $ xpContent xpText) + (xpOption . xpElemNodes "thread" $ xpContent xpText) + xpTrees + ) + +presenceP = xpWrap ( (\((from, to, id, tp),(shw, stat, prio, ext)) + -> Presence from to id tp shw stat prio ext) + , (\(Presence from to id tp shw stat prio ext) + -> ((from, to, id, tp), (shw, stat, prio, ext))) + ) $ + xpElem "presence" + (xp4Tuple + (xpAttrImplied "from" xpPrim) + (xpAttrImplied "to" xpPrim) + (xpAttrImplied "id" xpText) + (xpAttrImplied "type" xpPrim) + ) + (xp4Tuple + (xpOption . xpElemNodes "show" $ xpContent xpPrim) + (xpOption . xpElemNodes "status" $ xpContent xpText) + (xpOption . xpElemNodes "priority" $ xpContent xpPrim) + xpTrees + ) + +iqP = xpWrap ( (\((from, to, id, tp),body) -> IQ from to id tp body) + , (\(IQ from to id tp body) -> ((from, to, id, tp), body)) + ) $ + xpElem "iq" + (xp4Tuple + (xpAttrImplied "from" xpPrim) + (xpAttrImplied "to" xpPrim) + (xpAttr "id" xpText) + (xpAttr "type" xpPrim)) + (xpTree) -elementToStanza e@(Element (Name n ns Nothing) _ _) = - if (ns `elem` [Nothing, Just "jabber:client"]) then - case n of - "message" -> SMessage $ elementToMessage e - "presence" -> SPresence $ elementToPresence e - "iq" -> SIQ $ elementToIQ e - s -> error $ "unknown stanza type :" ++ show e - else error $ "unknown namespace: " ++ show ns - --- create attribute from Just -matr _ Nothing = [] -matr n (Just x) = [(n,x)] - --- Child if text is not empty -nech _ "" = [] -nech n x = [ NodeElement (Element n [] [NodeContent (ContentText x) ]) ] - --- Child if text is not Nothing -mnech _ Nothing = [] -mnech n (Just x) = [ NodeElement (Element n [] [NodeContent (ContentText x) ]) ] - --- make Attributes from text -contentify (x,y) = (x, [ContentText y]) - --- Marshal Message to XML Element -messageToElement (Message from to ident tp sub body thread exts) = - Element "message" - (map contentify . concat $ - [ matr "from" (toText <$> from) - , [("to", toText to)] - , matr "id" ident - , [("type", toText tp)] - ]) - (concat $ - [ mnech "subject" sub - , mnech "body" body - , mnech "thread" thread - , map NodeElement exts - ]) - --- Marshal XML element to message -elementToMessage e@(Element "message" _ _) = - let from = fromText <$> attributeText "from" e - Just to = fromText <$> attributeText "to" e - ident = attributeText "id" e - Just tp = fromText <$> attributeText "type" e - -- Oh dear, this is HORRIBLE. TODO: come up with something sane - in grabFrom (elementChildren e) $ do - -- TODO multiple bodies (different languages) - body <- maybeGrabNamed "body" - -- TODO multiple subjects (different languages) - subject <- maybeGrabNamed "subject" - thread <- maybeGrabNamed "thread" - ext <- grabRest - return $ Message - from - to - ident - tp - (elementToText <$>subject) - (elementToText <$> body) - (elementToText <$> thread) - ext - -presenceToElement (Presence from to id tp stp stat pri exts) = - Element "presence" - (map contentify . concat $ - [ matr "from" (toText <$> from) - , matr "to" (toText <$> to) - , matr "id" id - , matr "type" ( toText <$> tp) - ]) - (concat $ - [ mnech "show" (toText <$> stp) - , mnech "status" stat - , mnech "priority" (Text.pack . show <$> pri) - , map NodeElement exts - ]) - --- Marshal XML element to message -elementToPresence e@(Element (Name "message" _ _) _ _) = - let from = fromText <$> attributeText "from" e - to = fromText <$> attributeText "to" e - ident = attributeText "id" e - tp = fromText <$> attributeText "type" e - in grabFrom (elementChildren e) $ do - pshow <- maybeGrabNamed "show" - -- TODO multiple status (different languages) - stat <- maybeGrabNamed "status" - prio <- maybeGrabNamed "priority" - ext <- grabRest - return $ Presence - from - to - ident - tp - (fromText . elementToText <$> pshow) - (elementToText <$> stat) - (read . Text.unpack . elementToText <$> prio) - ext - - -iqToElement (IQ from to id tp body) = - Element "iq" - (map contentify . concat $ - [ matr "from" (toText <$> from) - , matr "to" (toText <$> to ) - , [("id" , id)] - , [("type", toText tp)] - ]) - [ NodeElement body ] - -elementToIQ e@(Element (Name "iq" _ _) _ _ ) = - let from = fromText <$> attributeText "from" e - to = fromText <$> attributeText "to" e - Just ident= attributeText "id" e - Just tp = fromText <$> attributeText "type" e - [ext] = elementChildren e - in IQ - from - to - ident - tp - ext - --- take and remove all elements matching a predicate from the list -takeAllFromList pred l = let (l', xs) = go pred [] l in (reverse l', xs) - where - go pred ys [] = (ys, []) - go pred ys (x:xs) = - case pred x of - True -> let (ys', rs) = go pred ys xs in (ys', x:rs) - False -> go pred (x:ys) xs - --- The "Grab Monad" : sucessively take and remove ("grab") --- elements from a "pool" (list) - --- Put a list of elements into the pool and start grabbing -grabFrom l = fst . flip runState l - --- grab all elements matching predicate out of the pool -grabAll p = do - l <- get - let (l', xs) = takeAllFromList p l - put l' - return xs - --- grab XML-elements by exact name -grabNamed = grabAll . hasName - --- This throws away all elements after the first one --- TODO: Be more stricy here -maybeGrabNamed = liftM listToMaybe . grabAll . hasName - --- grab all remaining elements from the pool -grabRest = do - l <- get - put [] - return l - -hasName x e = x == elementName e - -elementToText = Text.concat . elementText - -textToNode t = NodeContent (ContentText t) \ No newline at end of file diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 37d77af..b9c6302 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -1,69 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} + module Network.XMPP.Monad where import Control.Applicative((<$>)) +import Control.Monad import Control.Monad.Trans import Control.Monad.Trans.State +import Data.ByteString as BS + import Data.Conduit -import Data.Conduit.Text as CT import Data.Conduit.Binary as CB +import Data.Conduit.Hexpat as HXC import Data.Conduit.List as CL -import Data.XML.Types +import Data.Conduit.Text as CT import Data.Default -import Data.Text +import qualified Data.Text as Text import Network.XMPP.Types import Network.XMPP.Marshal +import Network.XMPP.Pickle import System.IO -import Text.XML.Stream.Elements -import Text.XML.Stream.Render as XR -import Text.XML.Stream.Parse - -type XMPPMonad a = StateT XMPPState (ResourceT IO) a - -data XMPPState = XMPPState - { sConSrc :: BufferedSource IO Event - , sConSink :: Sink Event IO () - , sConHandle :: Maybe Handle - , sFeatures :: ServerFeatures - , sHaveTLS :: Bool - , sHostname :: Text - , sUsername :: Text - , sResource :: Maybe Text - } - -data ServerFeatures = SF - { stls :: Bool - , stlsRequired :: Bool - , saslMechanisms :: [Text] - , other :: [Element] - } deriving Show - -instance Default ServerFeatures where - def = SF - { stls = False - , stlsRequired = False - , saslMechanisms = [] - , other = [] - } - - -pushE :: Element -> XMPPMonad () -pushE x = do +import Text.XML.Expat.SAX +import Text.XML.Expat.Tree +import Text.XML.Expat.Format + +parseOpts = ParseOptions (Just UTF8) Nothing + +pushN :: Element -> XMPPMonad () +pushN x = do sink <- gets sConSink - lift $ CL.sourceList (elementToEvents x) $$ sink + lift . sink $ formatNode' x push :: Stanza -> XMPPMonad () -push = pushE . stanzaToElement +push = pushN . pickleElem stanzaP pushOpen :: Element -> XMPPMonad () -pushOpen x = do +pushOpen (Element name attrs children) = do sink <- gets sConSink - lift $ CL.sourceList (elementToEvents' x) $$ sink + let sax = StartElement name attrs + lift . sink $ formatSAX' [sax] + forM children pushN + return () pulls :: Sink Event IO a -> XMPPMonad a @@ -76,15 +58,22 @@ pullE = do source <- gets sConSrc pulls elementFromEvents +pullPickle p = unpickleElem p <$> pullE + pull :: XMPPMonad Stanza -pull = elementToStanza <$> pullE +pull = pullPickle stanzaP + +-- pull :: XMPPMonad Stanza +-- pull = elementToStanza <$> pullE xmppFromHandle handle hostname username resource f = runResourceT $ do liftIO $ hSetBuffering handle NoBuffering - src <- bufferSource $ CB.sourceHandle handle $= CT.decode CT.utf8 $= parseText def + raw <- bufferSource $ CB.sourceHandle handle + src <- bufferSource $ raw $= HXC.parseBS parseOpts let st = XMPPState src - (XR.renderBytes def =$ CB.sinkHandle handle) + raw + (liftIO . BS.hPut handle) (Just handle) def False diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs new file mode 100644 index 0000000..2b4ff42 --- /dev/null +++ b/src/Network/XMPP/Pickle.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TupleSections #-} + +-- Marshalling between XML and Native Types + + +module Network.XMPP.Pickle where + +import Control.Applicative((<$>)) + +import qualified Data.ByteString as BS + +import Data.Text as Text +import Data.Text.Encoding as Text + +import Network.XMPP.Types + +import Text.XML.Expat.Pickle +import Text.XML.Expat.Tree + + +mbToBool (Just _) = True +mbToBool _ = False + +xpElemEmpty name = xpWrap (\((),()) -> () , + \() -> ((),())) $ + xpElem name xpUnit xpUnit + +xpElemExists name = xpWrap (\x -> mbToBool x + ,\x -> if x then Just () else Nothing) $ + xpOption (xpElemEmpty name) + +ignoreAttrs = xpWrap (snd, ((),)) + +mbl (Just l) = l +mbl Nothing = [] + +lmb [] = Nothing +lmb x = Just x + +right (Left l) = error l +right (Right r) = r + +unpickleElem p = right . unpickleTree' (xpRoot p) +pickleElem p = pickleTree $ xpRoot p + +xpEither l r = xpAlt eitherSel + [xpWrap (\x -> Left x, \(Left x) -> x) l + ,xpWrap (\x -> Right x, \(Right x) -> x) r + ] + where + eitherSel (Left _) = 0 + eitherSel (Right _) = 1 + +xpElemNs name ns attrs nodes = + xpWrap (\(((),a),n) -> (a,n), \(a,n) -> (((),a),n)) $ + xpElem name + (xpPair + (xpAttrFixed "xmlns" ns) + attrs + ) + nodes \ No newline at end of file diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index ec891b1..885223f 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -18,13 +18,14 @@ import qualified Data.ByteString.Base64 as B64 import qualified Data.List as L import qualified Data.Digest.Pure.MD5 as MD5 import Data.List -import Data.XML.Types import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Network.XMPP.Monad +import Network.XMPP.Pickle import Network.XMPP.Stream +import Network.XMPP.Types import Numeric -- @@ -32,34 +33,42 @@ import qualified System.Random as Random import Text.XML.Stream.Elements +import Text.XML.Expat.Pickle +import Text.XML.Expat.Tree + saslInitE mechanism = - Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth" - [("mechanism", [ContentText mechanism]) + Element "auth" + [ ("xmlns","urn:ietf:params:xml:ns:xmpp-sasl") + , ("mechanism", mechanism) ] [] saslResponseE resp = - Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" [] - [NodeContent $ ContentText resp] + Element "response" + [("xmlns","urn:ietf:params:xml:ns:xmpp-sasl")] + [Text resp] saslResponse2E = - Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" [] [] + Element "response" + [("xmlns","urn:ietf:params:xml:ns:xmpp-sasl")] + [] xmppSASL passwd = do mechanisms <- gets $ saslMechanisms . sFeatures unless ("DIGEST-MD5" `elem` mechanisms) $ error "No usable auth mechanism" - pushE $ saslInitE "DIGEST-MD5" - Element "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" [] - [NodeContent (ContentText content)] <- pullE - let (Right challenge) = B64.decode . Text.encodeUtf8 $ content + liftIO $ putStrLn "saslinit" + pushN $ saslInitE "DIGEST-MD5" + liftIO $ putStrLn "saslinit sent" + Right challenge <- B64.decode . Text.encodeUtf8<$> pullPickle challengePickle let Right pairs = toPairs challenge - pushE . saslResponseE =<< createResponse passwd pairs - Element name attrs content <- pullE - when (name == "{urn:ietf:params:xml:ns:xmpp-sasl}failure") $ - (error $ show content) - pushE saslResponse2E - Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pullE - xmppStartStream + pushN . saslResponseE =<< createResponse passwd pairs + challenge2 <- pullPickle (xpEither failurePickle challengePickle) + case challenge2 of + Left x -> error $ show x + Right c -> return () + pushN saslResponse2E + Element "success" [("xmlns","urn:ietf:params:xml:ns:xmpp-sasl")] [] <- pullE + xmppRestartStream return () createResponse passwd' pairs = do @@ -119,3 +128,17 @@ md5Digest uname realm password digestURI nc qop nonce cnonce= ha2 = hash ["AUTHENTICATE", digestURI] in hash [ha1,nonce, nc, cnonce,qop,ha2] + +-- Pickling + +failurePickle = ignoreAttrs $ + xpElem "failure" + (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-sasl") + (xpTree) + +challengePickle :: PU [Node Text.Text Text.Text] Text.Text +challengePickle = ignoreAttrs $ + xpElem "challenge" + (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-sasl") + (xpContent xpText0) + diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index 70ea683..d91d4f3 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -1,79 +1,94 @@ {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} module Network.XMPP.Stream where +import Control.Applicative((<$>)) import Control.Monad(unless) +import Control.Monad.Trans import Control.Monad.Trans.State +import Control.Monad.IO.Class import Network.XMPP.Monad +import Network.XMPP.Pickle +import Network.XMPP.Types import Data.Conduit +import Data.Conduit.Hexpat as HXC import Data.Conduit.List as CL import qualified Data.List as L import Data.Text as T -import Data.XML.Types -import Text.XML.Stream.Elements +import Text.XML.Expat.Pickle + +-- import Text.XML.Stream.Elements + xmppStartStream = do hostname <- gets sHostname - pushOpen $ streamE hostname + pushOpen $ pickleElem pickleStream ("1.0",Nothing, Just hostname) features <- pulls xmppStream modify (\s -> s {sFeatures = features}) return () +xmppRestartStream = do + raw <- gets sRawSrc + src <- gets sConSrc + newsrc <- lift (bufferSource $ raw $= HXC.parseBS parseOpts) + modify (\s -> s{sConSrc = newsrc}) + xmppStartStream + -xmppStream :: ResourceThrow m => Sink Event m ServerFeatures +xmppStream :: Sink Event IO ServerFeatures xmppStream = do xmppStreamHeader xmppStreamFeatures - -xmppStreamHeader :: Resource m => Sink Event m () +xmppStreamHeader :: Sink Event IO () xmppStreamHeader = do - hd <- CL.peek - case hd of - Just EventBeginDocument -> CL.drop 1 - _ -> return () - Just (EventBeginElement "{http://etherx.jabber.org/streams}stream" streamAttrs) <- CL.head - unless (checkVersion streamAttrs) $ error "Not XMPP version 1.0 " - return () - where - checkVersion = L.any (\x -> (fst x == "version") && (snd x == [ContentText "1.0"])) - - -xmppStreamFeatures - :: ResourceThrow m => Sink Event m ServerFeatures -xmppStreamFeatures = do - Element "{http://etherx.jabber.org/streams}features" [] features' <- elementFromEvents - let features = do - f <- features' - case f of - NodeElement e -> [e] - _ -> [] - let starttls = features >>= isNamed "{urn:ietf:params:xml:ns:xmpp-tls}starttls" - let starttlsRequired = starttls - >>= elementChildren - >>= isNamed "{urn:ietf:params:xml:ns:xmpp-tls}required" - let mechanisms = features - >>= isNamed "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms" - >>= elementChildren - >>= isNamed "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" - >>= elementText - return SF { stls = not $ L.null starttls - , stlsRequired = not $ L.null starttlsRequired - , saslMechanisms = mechanisms - , other = features - } - -streamE :: T.Text -> Element -streamE hostname = - Element (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) - [ - ("xml:language" , [ContentText "en"]) - , ("version", [ContentText "1.0"]) - , ("to", [ContentText hostname]) - ] - [] + throwOutJunk + (ver, _, _) <- unpickleElem pickleStream <$> openElementFromEvents + unless (ver == "1.0") $ error "Not XMPP version 1.0 " + return() + + +xmppStreamFeatures :: Sink Event IO ServerFeatures +xmppStreamFeatures = unpickleElem pickleStreamFeatures <$> elementFromEvents + + +-- Pickling + +pickleStream = xpWrap (snd, (((),()),)) . + xpElemAttrs "stream:stream" $ + xpPair + (xpPair + (xpAttrFixed "xmlns" "jabber:client" ) + (xpAttrFixed "xmlns:stream" "http://etherx.jabber.org/streams" ) + ) + (xpTriple + (xpAttr "version" xpText) + (xpOption $ xpAttr "from" xpText) + (xpOption $ xpAttr "to" xpText) + ) + +pickleTLSFeature = ignoreAttrs $ + xpElem "starttls" + (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-tls") + (xpElemExists "required") + +pickleSaslFeature = ignoreAttrs $ + xpElem "mechanisms" + (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-sasl") + (xpList0 $ + xpElemNodes "mechanism" (xpContent xpText) ) +pickleStreamFeatures = xpWrap ( \(tls, sasl, rest) -> SF tls (mbl sasl) rest + , (\(SF tls sasl rest) -> (tls, lmb sasl, rest)) + ) $ + xpElemNodes "stream:features" + (xpTriple + (xpOption pickleTLSFeature) + (xpOption pickleSaslFeature) + xpTrees + ) diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index 4404529..ddd69b7 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -2,43 +2,43 @@ module Network.XMPP.TLS where -import Control.Monad(when) +import Control.Monad import Control.Monad.Trans import Control.Monad.Trans.State import Network.XMPP.Monad import Network.XMPP.Stream -import Network.TLSConduit as TLS +import Network.XMPP.Types import Data.Conduit +import Data.Conduit.Hexpat as HX import Data.Conduit.Text as CT +import Data.Conduit.TLS as TLS import Data.Conduit.List as CL import qualified Data.List as L -import Data.XML.Types - -import Text.XML.Stream.Elements -import Text.XML.Stream.Parse -import Text.XML.Stream.Render as XR +import Text.XML.Expat.Tree starttlsE = - Element (Name "starttls" (Just "urn:ietf:params:xml:ns:xmpp-tls") Nothing ) [] [] + Element "starttls" [("xmlns", "urn:ietf:params:xml:ns:xmpp-tls")] [] exampleParams = TLS.defaultParams {TLS.pCiphers = TLS.ciphersuite_strong} xmppStartTLS params = do features <- gets sFeatures - when (stls features) $ do - pushE starttlsE - Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pullE + unless (stls features == Nothing) $ do + pushN starttlsE + Element "proceed" [("xmlns", "urn:ietf:params:xml:ns:xmpp-tls")] [] <- pullE Just handle <- gets sConHandle - (src', snk) <- lift $ TLS.tlsinit params handle - src <- lift . bufferSource $ src' $= CT.decode CT.utf8 $= parseText def + (raw', snk) <- lift $ TLS.tlsinit params handle + raw <- lift . bufferSource $ raw' modify (\x -> x - { sConSrc = src - , sConSink = XR.renderBytes def =$ snk + { sRawSrc = raw +-- , sConSrc = -- Note: this momentarily leaves us in an + -- inconsistent state + , sConSink = liftIO . snk }) - xmppStartStream + xmppRestartStream modify (\s -> s{sHaveTLS = True}) gets sHaveTLS diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index 5dc6d13..c10f3cc 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -5,17 +5,23 @@ module Network.XMPP.Types where import Control.Applicative((<$>)) import Control.Monad +import Control.Monad.Trans.State +import qualified Data.ByteString as BS +import Data.Conduit +import Data.Default +import Data.List.Split as L import Data.Maybe import Data.Text as Text import Data.String as Str -import Data.XML.Types -class ToText a where - toText :: a -> Text +import System.IO -class FromText a where - fromText :: Text -> a +import Text.XML.Expat.SAX +import Text.XML.Expat.Tree + +type Element = Node Text.Text Text.Text +type Event = SAXEvent Text.Text Text.Text -- | Jabber ID (JID) datatype data JID = JID { node :: Maybe Text @@ -25,31 +31,50 @@ data JID = JID { node :: Maybe Text , resource :: Maybe Text -- ^ Resource name } -instance ToText JID where - toText (JID n d r) = - let n' = maybe "" (`append` "@" ) n - r' = maybe "" ("/" `append` ) r - in Text.concat [n', d, r'] - -instance FromText JID where - fromText = parseJID - instance Show JID where show = Text.unpack . toText +type XMPPMonad a = StateT XMPPState (ResourceT IO) a + +data XMPPState = XMPPState + { sConSrc :: BufferedSource IO Event + , sRawSrc :: BufferedSource IO BS.ByteString + , sConSink :: BS.ByteString -> ResourceT IO () + , sConHandle :: Maybe Handle + , sFeatures :: ServerFeatures + , sHaveTLS :: Bool + , sHostname :: Text.Text + , sUsername :: Text.Text + , sResource :: Maybe Text.Text + } + +data ServerFeatures = SF + { stls :: Maybe Bool + , saslMechanisms :: [Text.Text] + , other :: [Element] + } deriving Show + +instance Default ServerFeatures where + def = SF + { stls = Nothing + , saslMechanisms = [] + , other = [] + } + + -- Ugh, that smells a bit. parseJID jid = - let (jid', rst) = case Text.splitOn "@" jid of + let (jid', rst) = case L.splitOn "@" jid of [rest] -> (JID Nothing, rest) - [node,rest] -> (JID (Just node), rest) - _ -> error $ "Couldn't parse JID: \"" ++ Text.unpack jid ++ "\"" - in case Text.splitOn "/" rst of - [domain] -> jid' domain Nothing - [domain, resource] -> jid' domain (Just resource) - _ -> error $ "Couldn't parse JID: \"" ++ Text.unpack jid ++ "\"" + [node,rest] -> (JID (Just (Text.pack node)), rest) + _ -> error $ "Couldn't parse JID: \"" ++ jid ++ "\"" + in case L.splitOn "/" rst of + [domain] -> jid' (Text.pack domain) Nothing + [domain, resource] -> jid' (Text.pack domain) (Just (Text.pack resource)) + _ -> error $ "Couldn't parse JID: \"" ++ jid ++ "\"" -instance IsString JID where - fromString = parseJID . Text.pack +instance Read JID where + readsPrec _ x = [(parseJID x,"")] -- should we factor from, to and id out, even though they are @@ -59,7 +84,7 @@ data Message = Message , mTo :: JID , mId :: Maybe Text -- ^ Message 'from', 'to', 'id' attributes - , mType :: MessageType + , mType :: Maybe MessageType -- ^ Message type (2.1.1) , mSubject :: Maybe Text -- ^ Subject element (2.1.2.1) @@ -86,7 +111,7 @@ data Presence = Presence -- ^ Presence priority (2.2.2.3) , pExt :: [Element] -- ^ Additional contents, used for extensions - } + } deriving Show data IQ = IQ { iqFrom :: Maybe JID @@ -97,11 +122,11 @@ data IQ = IQ -- ^ IQ type (Core-9.2.3) , iqBody :: Element -- ^ Child element (Core-9.2.3) - } + } deriving Show -data Stanza = SMessage Message | SPresence Presence | SIQ IQ -- deriving Show +data Stanza = SMessage Message | SPresence Presence | SIQ IQ deriving Show -data MessageType = Chat | GroupChat | Headline | Normal | MessageError deriving (Eq, Show) +data MessageType = Chat | GroupChat | Headline | Normal | MessageError deriving (Eq) data PresenceType = Default | Unavailable | Subscribe | Subscribed | Unsubscribe | Unsubscribed | Probe | PresenceError deriving Eq @@ -109,73 +134,79 @@ data IQType = Get | Result | Set | IQError deriving Eq data ShowType = Available | Away | FreeChat | DND | XAway deriving Eq -instance ToText MessageType where - toText Chat = "chat" - toText GroupChat = "groupchat" - toText Headline = "headline" - toText Normal = "normal" - toText MessageError = "error" - -instance ToText PresenceType where - toText Default = "" - toText Unavailable = "unavailable" - toText Subscribe = "subscribe" - toText Subscribed = "subscribed" - toText Unsubscribe = "unsubscribe" - toText Unsubscribed = "unsubscribed" - toText Probe = "probe" - toText PresenceError = "error" - -instance ToText IQType where - toText Get = "get" - toText Result = "result" - toText Set = "set" - toText IQError = "error" - -instance ToText ShowType where - toText Available = "" - toText Away = "away" - toText FreeChat = "chat" - toText DND = "dnd" - toText XAway = "xa" - - -instance FromText MessageType where - fromText "chat" = Chat - fromText "groupchat" = GroupChat - fromText "headline" = Headline - fromText "normal" = Normal - fromText "error" = MessageError - fromText "" = Chat - fromText _ = error "incorrect message type" - -instance FromText PresenceType where - fromText "" = Default - fromText "available" = Default - fromText "unavailable" = Unavailable - fromText "subscribe" = Subscribe - fromText "subscribed" = Subscribed - fromText "unsubscribe" = Unsubscribe - fromText "unsubscribed" = Unsubscribed - fromText "probe" = Probe - fromText "error" = PresenceError - fromText _ = error "incorrect presence type" - -instance FromText IQType where - fromText "get" = Get - fromText "result" = Result - fromText "set" = Set - fromText "error" = IQError - fromText "" = Get - fromText _ = error "incorrect iq type" - -instance FromText ShowType where - fromText "" = Available - fromText "available" = Available - fromText "away" = Away - fromText "chat" = FreeChat - fromText "dnd" = DND - fromText "xa" = XAway - fromText "invisible" = Available - fromText _ = error "incorrect value" - +instance Show MessageType where + show Chat = "chat" + show GroupChat = "groupchat" + show Headline = "headline" + show Normal = "normal" + show MessageError = "error" + +instance Show PresenceType where + show Default = "" + show Unavailable = "unavailable" + show Subscribe = "subscribe" + show Subscribed = "subscribed" + show Unsubscribe = "unsubscribe" + show Unsubscribed = "unsubscribed" + show Probe = "probe" + show PresenceError = "error" + +instance Show IQType where + show Get = "get" + show Result = "result" + show Set = "set" + show IQError = "error" + +instance Show ShowType where + show Available = "" + show Away = "away" + show FreeChat = "chat" + show DND = "dnd" + show XAway = "xa" + + +instance Read MessageType where + readsPrec _ "chat" = [( Chat ,"")] + readsPrec _ "groupchat" = [( GroupChat ,"")] + readsPrec _ "headline" = [( Headline ,"")] + readsPrec _ "normal" = [( Normal ,"")] + readsPrec _ "error" = [( MessageError ,"")] + readsPrec _ "" = [( Chat ,"")] + readsPrec _ _ = error "incorrect message type" + +instance Read PresenceType where + readsPrec _ "" = [( Default ,"")] + readsPrec _ "available" = [( Default ,"")] + readsPrec _ "unavailable" = [( Unavailable ,"")] + readsPrec _ "subscribe" = [( Subscribe ,"")] + readsPrec _ "subscribed" = [( Subscribed ,"")] + readsPrec _ "unsubscribe" = [( Unsubscribe ,"")] + readsPrec _ "unsubscribed" = [( Unsubscribed ,"")] + readsPrec _ "probe" = [( Probe ,"")] + readsPrec _ "error" = [( PresenceError ,"")] + readsPrec _ _ = error "incorrect presence type" + +instance Read IQType where + readsPrec _ "get" = [( Get ,"")] + readsPrec _ "result" = [( Result ,"")] + readsPrec _ "set" = [( Set ,"")] + readsPrec _ "error" = [( IQError ,"")] + readsPrec _ "" = [( Get ,"")] + readsPrec _ _ = error "incorrect iq type" + +instance Read ShowType where + readsPrec _ "" = [( Available ,"")] + readsPrec _ "available" = [( Available ,"")] + readsPrec _ "away" = [( Away ,"")] + readsPrec _ "chat" = [( FreeChat ,"")] + readsPrec _ "dnd" = [( DND ,"")] + readsPrec _ "xa" = [( XAway ,"")] + readsPrec _ "invisible" = [( Available ,"")] + readsPrec _ _ = error "incorrect value" + + +toText :: Show a => a -> Text +toText = Text.pack . show + +fromText :: Read a => Text -> a +fromText = read . Text.unpack \ No newline at end of file diff --git a/src/Network/XMPPConduit.hs b/src/Network/XMPPConduit.hs index 5c11a6d..1b1be17 100644 --- a/src/Network/XMPPConduit.hs +++ b/src/Network/XMPPConduit.hs @@ -13,14 +13,15 @@ import Network.XMPP.Monad import Network.XMPP.TLS import Network.XMPP.Stream import Network.XMPP.SASL +import Network.XMPP.Types import Network.XMPP.Bind import System.IO -fromHandle :: Handle -> Text -> Text -> Text -> IO ((), XMPPState) -fromHandle handle hostname username password = - xmppFromHandle handle hostname username Nothing $ do +fromHandle :: Handle -> Text -> Text -> Text -> Maybe Text -> IO ((), XMPPState) +fromHandle handle hostname username password resource = + xmppFromHandle handle hostname username resource $ do xmppStartStream -- this will check whether the server supports tls -- on it's own @@ -35,7 +36,7 @@ fromHandle handle hostname username password = main = do con <- connectTo "localhost" (PortNumber 5222) hSetBuffering con NoBuffering - (fs,st) <- fromHandle con "species64739.dyndns.org" "bot" "pwd" + (fs,st) <- fromHandle con "species64739.dyndns.org" "bot" "pwd" (Just "botr") print $ sHaveTLS st putStrLn "" hGetContents con >>= putStrLn diff --git a/src/Text/XML/Stream/Elements.hs b/src/Text/XML/Stream/Elements.hs deleted file mode 100644 index 8301c7c..0000000 --- a/src/Text/XML/Stream/Elements.hs +++ /dev/null @@ -1,76 +0,0 @@ -module Text.XML.Stream.Elements where - -import Control.Applicative ((<$>)) -import Control.Monad.Trans.Class - -import Data.Text as T -import Text.XML.Unresolved -import Data.XML.Types - -import Data.Conduit as C -import Data.Conduit.List as CL - -import Text.XML.Stream.Parse - -compressNodes :: [Node] -> [Node] -compressNodes [] = [] -compressNodes [x] = [x] -compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) = - compressNodes $ NodeContent (ContentText $ x `T.append` y) : z -compressNodes (x:xs) = x : compressNodes xs - -elementFromEvents :: C.ResourceThrow m => C.Sink Event m Element -elementFromEvents = do - x <- CL.peek - case x of - Just (EventBeginElement n as) -> goE n as - _ -> lift $ C.resourceThrow $ InvalidEventStream $ "not an element: " ++ show x - where - many f = - go id - where - go front = do - x <- f - case x of - Nothing -> return $ front [] - Just y -> go (front . (:) y) - dropReturn x = CL.drop 1 >> return x - goE n as = do - CL.drop 1 - ns <- many goN - y <- CL.head - if y == Just (EventEndElement n) - then return $ Element n as $ compressNodes ns - else lift $ C.resourceThrow $ InvalidEventStream $ "Missing end element for " ++ show n ++ ", got: " ++ show y - goN = do - x <- CL.peek - case x of - Just (EventBeginElement n as) -> (Just . NodeElement) <$> goE n as - Just (EventInstruction i) -> dropReturn $ Just $ NodeInstruction i - Just (EventContent c) -> dropReturn $ Just $ NodeContent c - Just (EventComment t) -> dropReturn $ Just $ NodeComment t - Just (EventCDATA t) -> dropReturn $ Just $ NodeContent $ ContentText t - _ -> return Nothing - - -elementToEvents' :: Element -> [Event] -elementToEvents' (Element name as ns) = EventBeginElement name as : goN ns [] - where - goM [] = id - goM [x] = (goM' x :) - goM (x:xs) = (goM' x :) . goM xs - goM' (MiscInstruction i) = EventInstruction i - goM' (MiscComment t) = EventComment t - goE (Element name as ns) = - (EventBeginElement name as :) - . goN ns - . (EventEndElement name :) - goN [] = id - goN [x] = goN' x - goN (x:xs) = goN' x . goN xs - goN' (NodeElement e) = goE e - goN' (NodeInstruction i) = (EventInstruction i :) - goN' (NodeContent c) = (EventContent c :) - goN' (NodeComment t) = (EventComment t :) - -elementToEvents e@(Element name _ _) = elementToEvents' e ++ [EventEndElement name] diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 index 0000000..ed4fd84 --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,7 @@ +module Utils where + +whileJust f = do + f' <- f + case f' of + Just x -> x : whileJust f + Nothing -> [] From 40c40f32587e09c1c5c1abe41a8c7e9345fa36ff Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 21 Mar 2012 19:39:40 +0100 Subject: [PATCH 06/26] Session, some bug fixes --- src/Data/Conduit/Hexpat.hs | 3 +- src/Data/Conduit/TLS.hs | 9 +++--- src/Network/XMPP/Bind.hs | 2 -- src/Network/XMPP/Marshal.hs | 12 ++++---- src/Network/XMPP/Monad.hs | 18 +++++++----- src/Network/XMPP/Pickle.hs | 5 ++-- src/Network/XMPP/SASL.hs | 7 ++--- src/Network/XMPP/Stream.hs | 2 +- src/Network/XMPP/TLS.hs | 5 ++-- src/Network/XMPP/Types.hs | 22 +++++++------- src/Network/XMPPConduit.hs | 43 --------------------------- xmpp-lib.cabal | 58 +++++++++++++++++++++++++++++++++++++ 12 files changed, 100 insertions(+), 86 deletions(-) delete mode 100644 src/Network/XMPPConduit.hs diff --git a/src/Data/Conduit/Hexpat.hs b/src/Data/Conduit/Hexpat.hs index 191bee1..e62de16 100644 --- a/src/Data/Conduit/Hexpat.hs +++ b/src/Data/Conduit/Hexpat.hs @@ -5,7 +5,8 @@ module Data.Conduit.Hexpat where import Control.Applicative((<$>)) import Control.Exception import Control.Monad -import Control.Monad.Trans +import Control.Monad.IO.Class +import Control.Monad.Trans.Class import qualified Data.ByteString as BS import Data.Conduit as C diff --git a/src/Data/Conduit/TLS.hs b/src/Data/Conduit/TLS.hs index e0a2565..261464b 100644 --- a/src/Data/Conduit/TLS.hs +++ b/src/Data/Conduit/TLS.hs @@ -6,7 +6,8 @@ module Data.Conduit.TLS where import Control.Applicative -import Control.Monad.Trans +import Control.Monad.IO.Class +import Control.Monad.Trans.Class import Crypto.Random @@ -32,9 +33,9 @@ tlsinit tlsParams handle = do handshake clientContext let src = sourceIO (return clientContext) - (\_ -> putStrLn "tls closed") + (bye) (\con -> IOOpen <$> recvData con) - return (src $= conduitStdout + return (src , \s -> sendData clientContext $ BL.fromChunks [s] ) -- TODO: remove @@ -45,6 +46,6 @@ conduitStdout = conduitIO (return ()) (\_ -> return ()) (\_ bs -> do - liftIO $ BS.hPut stdout bs + liftIO $ BS.putStrLn bs return $ IOProducing [bs]) (const $ return []) \ No newline at end of file diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index aba68c5..b56d055 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -2,7 +2,6 @@ module Network.XMPP.Bind where -import Control.Monad.Trans import Control.Monad.Trans.State import Data.Text as Text @@ -28,7 +27,6 @@ xmppBind = do res <- gets sResource push $ bindReqIQ res answer <- pull - liftIO $ print answer let SIQ (IQ Nothing Nothing _ Result b) = answer let (JID n d (Just r)) = unpickleElem jidP b modify (\s -> s{sResource = Just r}) diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index 5eedc1b..48695d2 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/src/Network/XMPP/Marshal.hs @@ -4,8 +4,6 @@ module Network.XMPP.Marshal where import Control.Applicative((<$>)) -import Control.Monad.State - import Data.Maybe import qualified Data.Text as Text @@ -25,10 +23,10 @@ stanzaP = xpAlt stanzaSel , xpWrap (SIQ , (\(SIQ i) -> i)) iqP ] -messageP = xpWrap ( (\((from, to, id, tp),(body, sub, thr,ext)) - -> Message from to id tp body sub thr ext) - , (\(Message from to id tp body sub thr ext) - -> ((from, to, id, tp), (body, sub, thr,ext))) +messageP = xpWrap ( (\((from, to, id, tp),(sub, body, thr,ext)) + -> Message from to id tp sub body thr ext) + , (\(Message from to id tp sub body thr ext) + -> ((from, to, id, tp), (sub, body, thr,ext))) ) $ xpElem "message" (xp4Tuple @@ -38,8 +36,8 @@ messageP = xpWrap ( (\((from, to, id, tp),(body, sub, thr,ext)) (xpAttrImplied "type" xpPrim) ) (xp4Tuple - (xpOption . xpElemNodes "body" $ xpContent xpText) (xpOption . xpElemNodes "subject" $ xpContent xpText) + (xpOption . xpElemNodes "body" $ xpContent xpText) (xpOption . xpElemNodes "thread" $ xpContent xpText) xpTrees ) diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index b9c6302..262bad9 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -5,10 +5,12 @@ module Network.XMPP.Monad where import Control.Applicative((<$>)) import Control.Monad -import Control.Monad.Trans +import Control.Monad.IO.Class +import Control.Monad.Trans.Class import Control.Monad.Trans.State import Data.ByteString as BS +import Data.Text(Text) import Data.Conduit import Data.Conduit.Binary as CB @@ -16,7 +18,6 @@ import Data.Conduit.Hexpat as HXC import Data.Conduit.List as CL import Data.Conduit.Text as CT -import Data.Default import qualified Data.Text as Text import Network.XMPP.Types @@ -33,17 +34,17 @@ parseOpts = ParseOptions (Just UTF8) Nothing pushN :: Element -> XMPPMonad () pushN x = do - sink <- gets sConSink - lift . sink $ formatNode' x + sink <- gets sConPush + liftIO . sink $ formatNode' x push :: Stanza -> XMPPMonad () push = pushN . pickleElem stanzaP pushOpen :: Element -> XMPPMonad () pushOpen (Element name attrs children) = do - sink <- gets sConSink + sink <- gets sConPush let sax = StartElement name attrs - lift . sink $ formatSAX' [sax] + liftIO . sink $ formatSAX' [sax] forM children pushN return () @@ -55,7 +56,6 @@ pulls snk = do pullE :: XMPPMonad Element pullE = do - source <- gets sConSrc pulls elementFromEvents pullPickle p = unpickleElem p <$> pullE @@ -66,6 +66,10 @@ pull = pullPickle stanzaP -- pull :: XMPPMonad Stanza -- pull = elementToStanza <$> pullE +xmppFromHandle + :: Handle -> Text -> Text -> Maybe Text + -> XMPPMonad a + -> IO (a, XMPPState) xmppFromHandle handle hostname username resource f = runResourceT $ do liftIO $ hSetBuffering handle NoBuffering raw <- bufferSource $ CB.sourceHandle handle diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index 2b4ff42..3b39058 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -1,8 +1,5 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TupleSections #-} -- Marshalling between XML and Native Types @@ -56,6 +53,8 @@ xpEither l r = xpAlt eitherSel eitherSel (Left _) = 0 eitherSel (Right _) = 1 + + xpElemNs name ns attrs nodes = xpWrap (\(((),a),n) -> (a,n), \(a,n) -> (((),a),n)) $ xpElem name diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 885223f..a8aaf67 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -3,7 +3,8 @@ module Network.XMPP.SASL where import Control.Applicative import Control.Monad -import Control.Monad.Trans +import Control.Monad.IO.Class +import Control.Monad.Trans.Class import Control.Monad.Trans.State import qualified Crypto.Classes as CC @@ -31,8 +32,6 @@ import Numeric -- import qualified System.Random as Random -import Text.XML.Stream.Elements - import Text.XML.Expat.Pickle import Text.XML.Expat.Tree @@ -56,9 +55,7 @@ saslResponse2E = xmppSASL passwd = do mechanisms <- gets $ saslMechanisms . sFeatures unless ("DIGEST-MD5" `elem` mechanisms) $ error "No usable auth mechanism" - liftIO $ putStrLn "saslinit" pushN $ saslInitE "DIGEST-MD5" - liftIO $ putStrLn "saslinit sent" Right challenge <- B64.decode . Text.encodeUtf8<$> pullPickle challengePickle let Right pairs = toPairs challenge pushN . saslResponseE =<< createResponse passwd pairs diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index d91d4f3..f21beab 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -5,7 +5,7 @@ module Network.XMPP.Stream where import Control.Applicative((<$>)) import Control.Monad(unless) -import Control.Monad.Trans +import Control.Monad.Trans.Class import Control.Monad.Trans.State import Control.Monad.IO.Class diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index ddd69b7..a9d2a57 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -3,7 +3,8 @@ module Network.XMPP.TLS where import Control.Monad -import Control.Monad.Trans +import Control.Monad.IO.Class +import Control.Monad.Trans.Class import Control.Monad.Trans.State import Network.XMPP.Monad @@ -36,7 +37,7 @@ xmppStartTLS params = do { sRawSrc = raw -- , sConSrc = -- Note: this momentarily leaves us in an -- inconsistent state - , sConSink = liftIO . snk + , sConPush = liftIO . snk }) xmppRestartStream modify (\s -> s{sHaveTLS = True}) diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index c10f3cc..846e757 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Network.XMPP.Types where -- proudly "borrowed" from haskell-xmpp @@ -9,7 +7,6 @@ import Control.Monad.Trans.State import qualified Data.ByteString as BS import Data.Conduit -import Data.Default import Data.List.Split as L import Data.Maybe import Data.Text as Text @@ -32,14 +29,17 @@ data JID = JID { node :: Maybe Text -- ^ Resource name } instance Show JID where - show = Text.unpack . toText + show (JID nd domain res) = + maybe "" ((++ "@") . Text.unpack) nd ++ + (Text.unpack domain) ++ + maybe "" (('/' :) . Text.unpack) res type XMPPMonad a = StateT XMPPState (ResourceT IO) a data XMPPState = XMPPState { sConSrc :: BufferedSource IO Event , sRawSrc :: BufferedSource IO BS.ByteString - , sConSink :: BS.ByteString -> ResourceT IO () + , sConPush :: BS.ByteString -> IO () , sConHandle :: Maybe Handle , sFeatures :: ServerFeatures , sHaveTLS :: Bool @@ -54,12 +54,12 @@ data ServerFeatures = SF , other :: [Element] } deriving Show -instance Default ServerFeatures where - def = SF - { stls = Nothing - , saslMechanisms = [] - , other = [] - } + +def = SF + { stls = Nothing + , saslMechanisms = [] + , other = [] + } -- Ugh, that smells a bit. diff --git a/src/Network/XMPPConduit.hs b/src/Network/XMPPConduit.hs deleted file mode 100644 index 1b1be17..0000000 --- a/src/Network/XMPPConduit.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} -module Network.XMPPConduit where - -import Control.Monad -import Control.Monad.Trans -import Control.Monad.Trans.State - -import qualified Data.ByteString as BS -import Data.Text as Text - -import Network -import Network.XMPP.Monad -import Network.XMPP.TLS -import Network.XMPP.Stream -import Network.XMPP.SASL -import Network.XMPP.Types -import Network.XMPP.Bind - - -import System.IO - -fromHandle :: Handle -> Text -> Text -> Text -> Maybe Text -> IO ((), XMPPState) -fromHandle handle hostname username password resource = - xmppFromHandle handle hostname username resource $ do - xmppStartStream - -- this will check whether the server supports tls - -- on it's own - xmppStartTLS exampleParams - xmppSASL password - xmppBind - gets sResource >>= liftIO . print - gets sHaveTLS >>= liftIO . print - forever $ pullE >>= liftIO . print - return () - -main = do - con <- connectTo "localhost" (PortNumber 5222) - hSetBuffering con NoBuffering - (fs,st) <- fromHandle con "species64739.dyndns.org" "bot" "pwd" (Just "botr") - print $ sHaveTLS st - putStrLn "" - hGetContents con >>= putStrLn - diff --git a/xmpp-lib.cabal b/xmpp-lib.cabal index e69de29..ae42c30 100644 --- a/xmpp-lib.cabal +++ b/xmpp-lib.cabal @@ -0,0 +1,58 @@ +Name: xmpp-lib +Version: 0.0.0.1 +License: MIT +License-File: LICENSE +Author: Philipp Balzarek +Maintainer: Philipp Balzarek +Category: Network +Copyright: (c) 2012 Philipp Balzarek +Stability: Experimental +Cabal-version: >=1.6 +Tested-with: GHC==7.4.1 +Build-type: Simple +Bug-reports: mailto: p.balzarek@googlemail.com +Extra-source-files: README + +Synopsis: Haskell XMPP (eXtensible Message Passing Protocol, a.k.a. Jabber) library +Description: Haskell XMPP (eXtensible Message Passing Protocol, a.k.a. Jabber) library + . + This library is not yet stable + +source-repository head + type: git + location: https://github.com/Philonous/xmpp-lib + +library + hs-source-dirs: src + Build-Depends: base >3 && <5 + , conduit -any + , random -any + , hexpat -any + , hexpat-pickle -any + , tls -any + , tls-extra -any + , pureMD5 -any + , base64-bytestring -any + , binary -any + , attoparsec -any + , crypto-api -any + , text -any + , bytestring -any + , transformers -any + , network -any + , split -any + , stm -any + Exposed-modules: Network.XMPP + , Network.XMPP.Types + , Network.XMPP.SASL + , Network.XMPP.Stream + , Network.XMPP.Pickle + , Network.XMPP.Marshal + , Network.XMPP.Monad + , Network.XMPP.Concurrent + , Network.XMPP.TLS + , Network.XMPP.Bind + , Network.XMPP.Session + , Data.Conduit.Hexpat + , Data.Conduit.TLS + GHC-Options: -Wall From f27b0075205e69fec61f6d5975b39b4c84eefae8 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 22 Mar 2012 00:32:38 +0100 Subject: [PATCH 07/26] top level types --- LICENSE | 9 ++ src/Data/Conduit/Hexpat.hs | 3 + src/Network/XMPP.hs | 45 ++++++++++ src/Network/XMPP/Bind.hs | 3 + src/Network/XMPP/Concurrent.hs | 154 +++++++++++++++++++++++++++++++++ src/Network/XMPP/Marshal.hs | 5 ++ src/Network/XMPP/Monad.hs | 3 + src/Network/XMPP/Pickle.hs | 16 +++- src/Network/XMPP/SASL.hs | 9 ++ src/Network/XMPP/Session.hs | 32 +++++++ src/Network/XMPP/Stream.hs | 6 ++ src/Network/XMPP/TLS.hs | 6 ++ 12 files changed, 290 insertions(+), 1 deletion(-) create mode 100644 LICENSE create mode 100644 src/Network/XMPP.hs create mode 100644 src/Network/XMPP/Concurrent.hs create mode 100644 src/Network/XMPP/Session.hs diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..d53ad5c --- /dev/null +++ b/LICENSE @@ -0,0 +1,9 @@ +The MIT License + +Copyright (c) 2012 Philipp Balzarek + +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/src/Data/Conduit/Hexpat.hs b/src/Data/Conduit/Hexpat.hs index e62de16..1c4eef4 100644 --- a/src/Data/Conduit/Hexpat.hs +++ b/src/Data/Conduit/Hexpat.hs @@ -181,5 +181,8 @@ throwOutJunk = do Just (StartElement _ _) -> return () _ -> CL.drop 1 >> throwOutJunk +saxToElements + :: (Eq tag, Show tag, MonadIO m, Resource m) => + Conduit (SAXEvent tag text) m (Node tag text) saxToElements = C.sequence $ throwOutJunk >> elementFromEvents diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs new file mode 100644 index 0000000..7f00330 --- /dev/null +++ b/src/Network/XMPP.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} +module Network.XMPP where + +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.State + +import qualified Data.ByteString as BS +import Data.Text as Text + +import Network +import Network.XMPP.Concurrent +import Network.XMPP.Monad +import Network.XMPP.TLS +import Network.XMPP.Stream +import Network.XMPP.SASL +import Network.XMPP.Types +import Network.XMPP.Bind +import Network.XMPP.Session + + +import System.IO + +--fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> IO ((), XMPPState) +fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> XMPPThread a + -> IO ((), XMPPState) +fromHandle handle hostname username resource password a = + xmppFromHandle handle hostname username resource $ do + xmppStartStream + -- this will check whether the server supports tls + -- on it's own + xmppStartTLS exampleParams + xmppSASL password + xmppBind + xmppSession + runThreaded a + return () + +connectXMPP :: HostName -> Text -> Text -> Maybe Text + -> Text -> XMPPThread a -> IO ((), XMPPState) +connectXMPP host hostname username resource passwd a = do + con <- connectTo host (PortNumber 5222) + hSetBuffering con NoBuffering + fromHandle con hostname username resource passwd a + diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index b56d055..8857bcd 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -13,6 +13,7 @@ import Network.XMPP.Marshal import Text.XML.Expat.Pickle +bindReqIQ :: Maybe Text -> Stanza bindReqIQ resource= SIQ $ IQ Nothing Nothing "bind" Set (pickleElem (bindP . xpOption @@ -23,6 +24,7 @@ bindReqIQ resource= SIQ $ IQ Nothing Nothing "bind" Set jidP :: PU [Node Text Text] JID jidP = bindP $ xpElemNodes "jid" (xpContent xpPrim) +xmppBind :: XMPPMonad () xmppBind = do res <- gets sResource push $ bindReqIQ res @@ -31,6 +33,7 @@ xmppBind = do let (JID n d (Just r)) = unpickleElem jidP b modify (\s -> s{sResource = Just r}) +bindP :: PU [Node Text.Text Text.Text] b -> PU [Node Text.Text Text.Text] b bindP c = ignoreAttrs $ xpElemNs "bind" "urn:ietf:params:xml:ns:xmpp-bind" xpUnit c diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs new file mode 100644 index 0000000..5fe1519 --- /dev/null +++ b/src/Network/XMPP/Concurrent.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module Network.XMPP.Concurrent + where + +-- import Network.XMPP.Stream +import Network.XMPP.Types + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Concurrent.STM.TChan +import Control.Concurrent.STM.TMVar +import Control.Monad.IO.Class +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Resource +import Control.Monad.Trans.State + + +import qualified Data.ByteString as BS +import Data.Maybe +import Data.IORef + +import Network.XMPP.Types +import Network.XMPP.Monad +import Network.XMPP.Marshal +import Network.XMPP.Pickle + + +import System.IO + +import Text.XML.Expat.Format +import Text.XML.Expat.Pickle + +data Thread = Thread { messagesRef :: IORef (Maybe (TChan Message)) + , presenceRef :: IORef (Maybe (TChan Presence)) + , mShadow :: TChan Stanza -- the original chan + , pShadow :: TChan Stanza -- the original chan + , outCh :: TChan Stanza + } + +type XMPPThread a = ReaderT Thread IO a + +-- Two streams: input and output. Threads read from input stream and write to output stream. +-- | Runs thread in XmppState monad +-- returns channel of incoming and outgoing stances, respectively +-- and an Action to stop the Threads and close the connection +startThreads :: XMPPMonad (TChan Stanza, TChan Stanza, IO ()) +startThreads = do + writeLock <- liftIO $ newTMVarIO () + messagesC <- liftIO newTChanIO + presenceC <- liftIO newTChanIO + iqC <- liftIO newTChanIO + outC <- liftIO newTChanIO + iqHandlers <- liftIO newTVarIO + pushBS <- gets sConPush + lw <- liftIO . forkIO $ loopWrite writeLock pushBS outC + cp <- liftIO . forkIO $ connPersist pushBS writeLock + s <- get + rd <- lift . resourceForkIO . void . flip runStateT s . forever $ do + s <- pull + case s of + SMessage m -> liftIO . atomically $ writeTChan messageC m + SPresence p -> liftIO . atomically $ writeTChan presenceC p + SIQ i -> liftIO . atomically $ writeTChan presenceC i + return (inC, outC, killConnection writeLock [lw, rd, cp]) + where + loopWrite writeLock pushBS out' = forever $ do + next <- liftIO . atomically $ ( takeTMVar writeLock >> readTChan out') + liftIO . pushBS . formatNode' $ pickleElem stanzaP next + liftIO . atomically $ putTMVar writeLock () + iqHandler handlers iqC = forever $ do + iq <- liftIO . atomically $ readTChan iqC + + + killConnection writeLock threads = liftIO $ do + atomically $ takeTMVar writeLock + forM threads killThread + return() + +runThreaded :: XMPPThread a + -> XMPPMonad ThreadId +runThreaded a = do + (inC, outC, stopThreads) <- startThreads + workerInCh <- liftIO . newIORef $ Just inC + worker <- liftIO . forkIO $ do + runReaderT a (Thread workerInCh inC outC) + return () + return worker + + +-- | get the inbound stanza channel, duplicate from master if necessary +-- please note that once duplicated it will keep filling up +getInChan = do + inChR <- asks inChRef + inCh <- liftIO $ readIORef inChR + case inCh of + Nothing -> do + shadow <- asks shadowInCh + inCh' <- liftIO $ atomically $ dupTChan shadow + liftIO $ writeIORef inChR (Just inCh') + return inCh' + Just inCh -> return inCh + + +-- | Drop the local end of the inbound stanza channel +-- from our context so it can be GC-ed +dropInChan :: XMPPThread () +dropInChan = do + r <- asks inChRef + liftIO $ writeIORef r Nothing + + +-- | Read an element from the inbound stanza channel, acquiring a copy +-- of the channel as necessary +pullS :: XMPPThread Stanza +pullS = do + c <- getInChan + st <- liftIO $ atomically $ readTChan c + return st + +-- | Send a stanza to the server +sendS :: Stanza -> XMPPThread () +sendS a = do + out <- asks outCh + liftIO . atomically $ writeTChan out a + return () + +-- | Fork a new thread +withNewThread :: XMPPThread () -> XMPPThread ThreadId +withNewThread a = do + thread <- ask + inCH' <- liftIO $ newIORef Nothing + liftIO $ forkIO $ runReaderT a (thread {inChRef = inCH'}) + +waitFor :: (Stanza -> Bool) -> XMPPThread Stanza +waitFor f = do + s <- pullS + if (f s) then + return s + else do + waitFor f + +connPersist :: (BS.ByteString -> IO ()) -> TMVar () -> IO () +connPersist pushBS lock = forever $ do + atomically $ takeTMVar lock + pushBS " " + atomically $ putTMVar lock () +-- putStrLn "" + threadDelay 30000000 + + diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index 48695d2..c95ce3c 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/src/Network/XMPP/Marshal.hs @@ -5,6 +5,7 @@ module Network.XMPP.Marshal where import Control.Applicative((<$>)) import Data.Maybe +import Data.Text(Text) import qualified Data.Text as Text @@ -17,12 +18,14 @@ stanzaSel (SMessage _ )= 0 stanzaSel (SPresence _ )= 1 stanzaSel (SIQ _ )= 2 +stanzaP :: PU [Node Text Text] Stanza stanzaP = xpAlt stanzaSel [ xpWrap (SMessage , (\(SMessage m) -> m)) messageP , xpWrap (SPresence , (\(SPresence p) -> p)) presenceP , xpWrap (SIQ , (\(SIQ i) -> i)) iqP ] +messageP :: PU [Node Text Text] Message messageP = xpWrap ( (\((from, to, id, tp),(sub, body, thr,ext)) -> Message from to id tp sub body thr ext) , (\(Message from to id tp sub body thr ext) @@ -42,6 +45,7 @@ messageP = xpWrap ( (\((from, to, id, tp),(sub, body, thr,ext)) xpTrees ) +presenceP :: PU [Node Text Text] Presence presenceP = xpWrap ( (\((from, to, id, tp),(shw, stat, prio, ext)) -> Presence from to id tp shw stat prio ext) , (\(Presence from to id tp shw stat prio ext) @@ -61,6 +65,7 @@ presenceP = xpWrap ( (\((from, to, id, tp),(shw, stat, prio, ext)) xpTrees ) +iqP :: PU [Node Text Text] IQ iqP = xpWrap ( (\((from, to, id, tp),body) -> IQ from to id tp body) , (\(IQ from to id tp body) -> ((from, to, id, tp), body)) ) $ diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 262bad9..2db6c84 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -27,9 +27,11 @@ import Network.XMPP.Pickle import System.IO import Text.XML.Expat.SAX +import Text.XML.Expat.Pickle(PU) import Text.XML.Expat.Tree import Text.XML.Expat.Format +parseOpts :: ParseOptions tag text parseOpts = ParseOptions (Just UTF8) Nothing pushN :: Element -> XMPPMonad () @@ -58,6 +60,7 @@ pullE :: XMPPMonad Element pullE = do pulls elementFromEvents +pullPickle :: PU [Node Text Text] b -> XMPPMonad b pullPickle p = unpickleElem p <$> pullE pull :: XMPPMonad Stanza diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index 3b39058..d171a6e 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -23,14 +23,18 @@ import Text.XML.Expat.Tree mbToBool (Just _) = True mbToBool _ = False +xpElemEmpty :: Text -> PU [Node Text Text] () xpElemEmpty name = xpWrap (\((),()) -> () , \() -> ((),())) $ xpElem name xpUnit xpUnit +xpElemExists :: Text -> PU [Node Text Text] Bool xpElemExists name = xpWrap (\x -> mbToBool x ,\x -> if x then Just () else Nothing) $ xpOption (xpElemEmpty name) + +ignoreAttrs :: PU t ((), b) -> PU t b ignoreAttrs = xpWrap (snd, ((),)) mbl (Just l) = l @@ -42,9 +46,14 @@ lmb x = Just x right (Left l) = error l right (Right r) = r + +unpickleElem :: PU [Node tag text] c -> Node tag text -> c unpickleElem p = right . unpickleTree' (xpRoot p) + +pickleElem :: PU [Node tag text] a -> a -> Node tag text pickleElem p = pickleTree $ xpRoot p +xpEither :: PU n t1 -> PU n t2 -> PU n (Either t1 t2) xpEither l r = xpAlt eitherSel [xpWrap (\x -> Left x, \(Left x) -> x) l ,xpWrap (\x -> Right x, \(Right x) -> x) r @@ -54,7 +63,12 @@ xpEither l r = xpAlt eitherSel eitherSel (Right _) = 1 - +xpElemNs :: + Text + -> Text + -> PU [(Text, Text)] t1 + -> PU [Node Text Text] t2 + -> PU [Node Text Text] (t1, t2) xpElemNs name ns attrs nodes = xpWrap (\(((),a),n) -> (a,n), \(a,n) -> (((),a),n)) $ xpElem name diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index a8aaf67..21a8632 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -21,6 +21,7 @@ import qualified Data.Digest.Pure.MD5 as MD5 import Data.List import qualified Data.Text as Text +import Data.Text (Text) import qualified Data.Text.Encoding as Text import Network.XMPP.Monad @@ -35,6 +36,7 @@ import qualified System.Random as Random import Text.XML.Expat.Pickle import Text.XML.Expat.Tree +saslInitE :: Text -> Node Text Text saslInitE mechanism = Element "auth" [ ("xmlns","urn:ietf:params:xml:ns:xmpp-sasl") @@ -42,16 +44,19 @@ saslInitE mechanism = ] [] +saslResponseE :: Text -> Node Text Text saslResponseE resp = Element "response" [("xmlns","urn:ietf:params:xml:ns:xmpp-sasl")] [Text resp] +saslResponse2E :: Node Text Text saslResponse2E = Element "response" [("xmlns","urn:ietf:params:xml:ns:xmpp-sasl")] [] +xmppSASL :: Text -> XMPPMonad () xmppSASL passwd = do mechanisms <- gets $ saslMechanisms . sFeatures unless ("DIGEST-MD5" `elem` mechanisms) $ error "No usable auth mechanism" @@ -68,6 +73,7 @@ xmppSASL passwd = do xmppRestartStream return () +createResponse :: Text -> [(BS8.ByteString, BS8.ByteString)] -> XMPPMonad Text createResponse passwd' pairs = do let Just qop = L.lookup "qop" pairs let Just nonce = L.lookup "nonce" pairs @@ -112,9 +118,11 @@ toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do when quote . void $ AP.char '"' return (name,content) +hash :: [BS8.ByteString] -> BS8.ByteString hash = BS8.pack . show . (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":") +hashRaw :: [BS8.ByteString] -> BS8.ByteString hashRaw = toStrict . Binary.encode . (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":") @@ -128,6 +136,7 @@ md5Digest uname realm password digestURI nc qop nonce cnonce= -- Pickling +failurePickle :: PU [Node Text Text] (Node Text Text) failurePickle = ignoreAttrs $ xpElem "failure" (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-sasl") diff --git a/src/Network/XMPP/Session.hs b/src/Network/XMPP/Session.hs new file mode 100644 index 0000000..6d90975 --- /dev/null +++ b/src/Network/XMPP/Session.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.XMPP.Session where + +import Control.Monad.Trans.State + +import Data.Text as Text + +import Network.XMPP.Monad +import Network.XMPP.Types +import Network.XMPP.Pickle +import Network.XMPP.Marshal + +import Text.XML.Expat.Pickle + + +sessionIQ :: Stanza +sessionIQ = SIQ $ IQ Nothing Nothing "sess" Set + (pickleElem + (xpElemNs "session" + "urn:ietf:params:xml:ns:xmpp-session" + xpUnit + xpUnit) + ((),()) + ) + +xmppSession :: XMPPMonad () +xmppSession = do + push $ sessionIQ + answer <- pull + let SIQ (IQ Nothing Nothing "sess" Result b) = answer + return () \ No newline at end of file diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index f21beab..223fc89 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -24,6 +24,7 @@ import Text.XML.Expat.Pickle -- import Text.XML.Stream.Elements +xmppStartStream :: XMPPMonad () xmppStartStream = do hostname <- gets sHostname pushOpen $ pickleElem pickleStream ("1.0",Nothing, Just hostname) @@ -31,6 +32,7 @@ xmppStartStream = do modify (\s -> s {sFeatures = features}) return () +xmppRestartStream :: XMPPMonad () xmppRestartStream = do raw <- gets sRawSrc src <- gets sConSrc @@ -58,6 +60,7 @@ xmppStreamFeatures = unpickleElem pickleStreamFeatures <$> elementFromEvents -- Pickling +pickleStream :: PU [Node Text Text] (Text, Maybe Text, Maybe Text) pickleStream = xpWrap (snd, (((),()),)) . xpElemAttrs "stream:stream" $ xpPair @@ -71,17 +74,20 @@ pickleStream = xpWrap (snd, (((),()),)) . (xpOption $ xpAttr "to" xpText) ) +pickleTLSFeature :: PU [Node Text Text] Bool pickleTLSFeature = ignoreAttrs $ xpElem "starttls" (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-tls") (xpElemExists "required") +pickleSaslFeature :: PU [Node Text Text] [Text] pickleSaslFeature = ignoreAttrs $ xpElem "mechanisms" (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-sasl") (xpList0 $ xpElemNodes "mechanism" (xpContent xpText) ) +pickleStreamFeatures :: PU [Node Text Text] ServerFeatures pickleStreamFeatures = xpWrap ( \(tls, sasl, rest) -> SF tls (mbl sasl) rest , (\(SF tls sasl rest) -> (tls, lmb sasl, rest)) ) $ diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index a9d2a57..de310a4 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -7,6 +7,8 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.State +import Data.Text(Text) + import Network.XMPP.Monad import Network.XMPP.Stream import Network.XMPP.Types @@ -20,11 +22,15 @@ import qualified Data.List as L import Text.XML.Expat.Tree +starttlsE :: Node Text Text starttlsE = Element "starttls" [("xmlns", "urn:ietf:params:xml:ns:xmpp-tls")] [] + +exampleParams :: TLSParams exampleParams = TLS.defaultParams {TLS.pCiphers = TLS.ciphersuite_strong} +xmppStartTLS :: TLSParams -> XMPPMonad Bool xmppStartTLS params = do features <- gets sFeatures unless (stls features == Nothing) $ do From ac8e907e5c173e27a76c79d2f93c915ba2c9678e Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 26 Mar 2012 22:33:57 +0200 Subject: [PATCH 08/26] compiles... again --- src/Data/Conduit/TLS.hs | 23 +++-- src/Network/XMPP/Bind.hs | 15 ++-- src/Network/XMPP/Concurrent.hs | 153 ++++++++++++++++++++++---------- src/Network/XMPP/Marshal.hs | 62 ++++++------- src/Network/XMPP/Monad.hs | 36 ++++---- src/Network/XMPP/Pickle.hs | 71 +++++++-------- src/Network/XMPP/SASL.hs | 49 +++++----- src/Network/XMPP/Session.hs | 12 ++- src/Network/XMPP/Stream.hs | 55 ++++++++---- src/Network/XMPP/TLS.hs | 19 ++-- src/Network/XMPP/Types.hs | 29 +++--- src/Text/XML/Stream/Elements.hs | 78 ++++++++++++++++ 12 files changed, 381 insertions(+), 221 deletions(-) create mode 100644 src/Text/XML/Stream/Elements.hs diff --git a/src/Data/Conduit/TLS.hs b/src/Data/Conduit/TLS.hs index 261464b..917eb5e 100644 --- a/src/Data/Conduit/TLS.hs +++ b/src/Data/Conduit/TLS.hs @@ -1,3 +1,4 @@ +{-# Language NoMonomorphismRestriction #-} module Data.Conduit.TLS ( tlsinit , module TLS @@ -8,6 +9,7 @@ module Data.Conduit.TLS import Control.Applicative import Control.Monad.IO.Class import Control.Monad.Trans.Class +import Control.Monad.Trans.Resource import Crypto.Random @@ -24,9 +26,11 @@ import System.Random import System.IO tlsinit - :: (MonadIO m, ResourceIO m1) => - TLSParams -> Handle - -> m (Source m1 BS.ByteString, (BS.ByteString -> IO ())) + :: (MonadIO m, MonadIO m1, MonadResource m1) => + TLSParams + -> Handle -> m ( Source m1 BS.ByteString + , Sink BS.ByteString m1 () + , BS.ByteString -> IO ()) tlsinit tlsParams handle = do gen <- liftIO $ (newGenIO :: IO SystemRandom) -- TODO: Find better random source? clientContext <- client tlsParams gen handle @@ -35,13 +39,20 @@ tlsinit tlsParams handle = do (return clientContext) (bye) (\con -> IOOpen <$> recvData con) - return (src + let snk = sinkIO + (return clientContext) + (\_ -> return ()) + (\con bs -> sendData clientContext (BL.fromChunks [bs]) + >> return IOProcessing ) + (\_ -> return ()) + return ( src + , snk , \s -> sendData clientContext $ BL.fromChunks [s] ) -- TODO: remove -conduitStdout :: ResourceIO m - => Conduit BS.ByteString m BS.ByteString +conduitStdout + :: MonadResource m => Conduit BS.ByteString m BS.ByteString conduitStdout = conduitIO (return ()) (\_ -> return ()) diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index 8857bcd..249b122 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -6,22 +6,25 @@ import Control.Monad.Trans.State import Data.Text as Text +import Data.XML.Pickle +import Data.XML.Types + import Network.XMPP.Monad import Network.XMPP.Types import Network.XMPP.Pickle import Network.XMPP.Marshal -import Text.XML.Expat.Pickle + bindReqIQ :: Maybe Text -> Stanza bindReqIQ resource= SIQ $ IQ Nothing Nothing "bind" Set (pickleElem (bindP . xpOption - $ xpElemNodes "resource" (xpContent xpText)) + $ xpElemNodes "resource" (xpContent xpId)) resource ) -jidP :: PU [Node Text Text] JID +jidP :: PU [Node] JID jidP = bindP $ xpElemNodes "jid" (xpContent xpPrim) xmppBind :: XMPPMonad () @@ -33,9 +36,7 @@ xmppBind = do let (JID n d (Just r)) = unpickleElem jidP b modify (\s -> s{sResource = Just r}) -bindP :: PU [Node Text.Text Text.Text] b -> PU [Node Text.Text Text.Text] b -bindP c = ignoreAttrs $ xpElemNs "bind" "urn:ietf:params:xml:ns:xmpp-bind" - xpUnit - c +bindP :: PU [Node] b -> PU [Node] b +bindP c = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-bind}bind" c diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs index 5fe1519..a1e82a4 100644 --- a/src/Network/XMPP/Concurrent.hs +++ b/src/Network/XMPP/Concurrent.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} module Network.XMPP.Concurrent @@ -20,24 +21,26 @@ import Control.Monad.Trans.State import qualified Data.ByteString as BS +import qualified Data.Map as Map import Data.Maybe import Data.IORef +import Data.Text(Text) + +import Data.XML.Types import Network.XMPP.Types import Network.XMPP.Monad import Network.XMPP.Marshal import Network.XMPP.Pickle - import System.IO -import Text.XML.Expat.Format -import Text.XML.Expat.Pickle +import Text.XML.Stream.Elements data Thread = Thread { messagesRef :: IORef (Maybe (TChan Message)) , presenceRef :: IORef (Maybe (TChan Presence)) - , mShadow :: TChan Stanza -- the original chan - , pShadow :: TChan Stanza -- the original chan + , mShadow :: TChan Message -- the original chan + , pShadow :: TChan Presence -- the original chan , outCh :: TChan Stanza } @@ -47,34 +50,56 @@ type XMPPThread a = ReaderT Thread IO a -- | Runs thread in XmppState monad -- returns channel of incoming and outgoing stances, respectively -- and an Action to stop the Threads and close the connection -startThreads :: XMPPMonad (TChan Stanza, TChan Stanza, IO ()) +startThreads + :: XMPPMonad ( TChan Message + , TChan Presence + , TVar ( Map.Map (IQType, Text) (TChan IQ) + , Map.Map Text (TMVar IQ) + ) + , TChan Stanza, IO () + ) startThreads = do writeLock <- liftIO $ newTMVarIO () - messagesC <- liftIO newTChanIO + messageC <- liftIO newTChanIO presenceC <- liftIO newTChanIO iqC <- liftIO newTChanIO outC <- liftIO newTChanIO - iqHandlers <- liftIO newTVarIO - pushBS <- gets sConPush - lw <- liftIO . forkIO $ loopWrite writeLock pushBS outC + iqHandlers <- liftIO $ newTVarIO ( Map.empty, Map.empty) + pushEvents <- gets sConPush + pushBS <- gets sConPushBS + lw <- lift . resourceForkIO $ loopWrite writeLock pushEvents outC cp <- liftIO . forkIO $ connPersist pushBS writeLock + iqh <- lift . resourceForkIO $ handleIQs iqHandlers iqC s <- get rd <- lift . resourceForkIO . void . flip runStateT s . forever $ do - s <- pull - case s of + sta <- pull + case sta of SMessage m -> liftIO . atomically $ writeTChan messageC m SPresence p -> liftIO . atomically $ writeTChan presenceC p - SIQ i -> liftIO . atomically $ writeTChan presenceC i - return (inC, outC, killConnection writeLock [lw, rd, cp]) + SIQ i -> liftIO . atomically $ writeTChan iqC i + return (messageC, presenceC, iqHandlers, outC, killConnection writeLock [lw, rd, cp]) where - loopWrite writeLock pushBS out' = forever $ do - next <- liftIO . atomically $ ( takeTMVar writeLock >> readTChan out') - liftIO . pushBS . formatNode' $ pickleElem stanzaP next + loopWrite writeLock pushEvents out' = forever $ do + next <- liftIO . atomically $ ( takeTMVar writeLock + >> readTChan out') + pushEvents . elementToEvents $ pickleElem stanzaP next liftIO . atomically $ putTMVar writeLock () - iqHandler handlers iqC = forever $ do - iq <- liftIO . atomically $ readTChan iqC - - + handleIQs handlers iqC = liftIO . forever . atomically $ do + iq <- readTChan iqC + (byNS, byID) <- readTVar handlers + let iqNS' = nameNamespace . elementName . iqBody $ iq + case iqNS' of + Nothing -> return () -- TODO: send error stanza + Just iqNS -> case iqType iq of + Get -> case Map.lookup (Get, iqNS) byNS of + Nothing -> return () -- TODO: send error stanza + Just ch -> writeTChan ch iq + Set -> case Map.lookup (Set, iqNS) byNS of + Nothing -> return () -- TODO: send error stanza + Just ch -> writeTChan ch iq + Result -> case Map.lookup (iqId iq) byID of + Nothing -> return () -- ?? Should we be sending an error? + Just tmvar -> putTMVar tmvar iq killConnection writeLock threads = liftIO $ do atomically $ takeTMVar writeLock forM threads killThread @@ -83,44 +108,70 @@ startThreads = do runThreaded :: XMPPThread a -> XMPPMonad ThreadId runThreaded a = do - (inC, outC, stopThreads) <- startThreads - workerInCh <- liftIO . newIORef $ Just inC + (mC, pC, hand, outC, stopThreads) <- startThreads + workermCh <- liftIO . newIORef $ Just mC + workerpCh <- liftIO . newIORef $ Just pC worker <- liftIO . forkIO $ do - runReaderT a (Thread workerInCh inC outC) + runReaderT a (Thread workermCh workerpCh mC pC outC) return () return worker -- | get the inbound stanza channel, duplicate from master if necessary -- please note that once duplicated it will keep filling up -getInChan = do - inChR <- asks inChRef - inCh <- liftIO $ readIORef inChR - case inCh of +getMessageChan = do + mChR <- asks messagesRef + mCh <- liftIO $ readIORef mChR + case mCh of Nothing -> do - shadow <- asks shadowInCh - inCh' <- liftIO $ atomically $ dupTChan shadow - liftIO $ writeIORef inChR (Just inCh') - return inCh' - Just inCh -> return inCh + shadow <- asks mShadow + mCh' <- liftIO $ atomically $ dupTChan shadow + liftIO $ writeIORef mChR (Just mCh') + return mCh' + Just mCh -> return mCh +-- | get the inbound stanza channel, duplicate from master if necessary +-- please note that once duplicated it will keep filling up +getPresenceChan = do + pChR <- asks presenceRef + pCh <- liftIO $ readIORef pChR + case pCh of + Nothing -> do + shadow <- asks pShadow + pCh' <- liftIO $ atomically $ dupTChan shadow + liftIO $ writeIORef pChR (Just pCh') + return pCh' + Just pCh -> return pCh -- | Drop the local end of the inbound stanza channel -- from our context so it can be GC-ed -dropInChan :: XMPPThread () -dropInChan = do - r <- asks inChRef +dropMessageChan :: XMPPThread () +dropMessageChan = do + r <- asks messagesRef + liftIO $ writeIORef r Nothing + +dropPresenceChan :: XMPPThread () +dropPresenceChan = do + r <- asks presenceRef liftIO $ writeIORef r Nothing +-- | Read an element from the inbound stanza channel, acquiring a copy +-- of the channel as necessary +pullMessage :: XMPPThread Message +pullMessage = do + c <- getMessageChan + st <- liftIO $ atomically $ readTChan c + return st -- | Read an element from the inbound stanza channel, acquiring a copy -- of the channel as necessary -pullS :: XMPPThread Stanza -pullS = do - c <- getInChan +pullPresence :: XMPPThread Presence +pullPresence = do + c <- getPresenceChan st <- liftIO $ atomically $ readTChan c return st + -- | Send a stanza to the server sendS :: Stanza -> XMPPThread () sendS a = do @@ -132,16 +183,28 @@ sendS a = do withNewThread :: XMPPThread () -> XMPPThread ThreadId withNewThread a = do thread <- ask - inCH' <- liftIO $ newIORef Nothing - liftIO $ forkIO $ runReaderT a (thread {inChRef = inCH'}) + mCH' <- liftIO $ newIORef Nothing + pCH' <- liftIO $ newIORef Nothing + liftIO $ forkIO $ runReaderT a (thread {messagesRef = mCH' + ,presenceRef = pCH' + }) + +waitForMessage :: (Message -> Bool) -> XMPPThread Message +waitForMessage f = do + s <- pullMessage + if (f s) then + return s + else do + waitForMessage f -waitFor :: (Stanza -> Bool) -> XMPPThread Stanza -waitFor f = do - s <- pullS +waitForPresence :: (Presence -> Bool) -> XMPPThread Presence +waitForPresence f = do + s <- pullPresence if (f s) then return s else do - waitFor f + waitForPresence f + connPersist :: (BS.ByteString -> IO ()) -> TMVar () -> IO () connPersist pushBS lock = forever $ do diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index c95ce3c..18b5600 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/src/Network/XMPP/Marshal.hs @@ -7,73 +7,75 @@ import Control.Applicative((<$>)) import Data.Maybe import Data.Text(Text) +import Data.XML.Types +import Data.XML.Pickle + import qualified Data.Text as Text import Network.XMPP.Pickle import Network.XMPP.Types -import Text.XML.Expat.Pickle -stanzaSel (SMessage _ )= 0 -stanzaSel (SPresence _ )= 1 -stanzaSel (SIQ _ )= 2 +stanzaSel (SMessage _) = 0 +stanzaSel (SPresence _) = 1 +stanzaSel (SIQ _) = 2 -stanzaP :: PU [Node Text Text] Stanza +stanzaP :: PU [Node] Stanza stanzaP = xpAlt stanzaSel - [ xpWrap (SMessage , (\(SMessage m) -> m)) messageP - , xpWrap (SPresence , (\(SPresence p) -> p)) presenceP - , xpWrap (SIQ , (\(SIQ i) -> i)) iqP + [ xpWrap SMessage (\(SMessage m) -> m) messageP + , xpWrap SPresence (\(SPresence p) -> p) presenceP + , xpWrap SIQ (\(SIQ i) -> i) iqP ] -messageP :: PU [Node Text Text] Message -messageP = xpWrap ( (\((from, to, id, tp),(sub, body, thr,ext)) +messageP :: PU [Node] Message +messageP = xpWrap (\((from, to, id, tp),(sub, body, thr,ext)) -> Message from to id tp sub body thr ext) - , (\(Message from to id tp sub body thr ext) + (\(Message from to id tp sub body thr ext) -> ((from, to, id, tp), (sub, body, thr,ext))) - ) $ + $ xpElem "message" (xp4Tuple (xpAttrImplied "from" xpPrim) (xpAttr "to" xpPrim) - (xpAttrImplied "id" xpText) + (xpAttrImplied "id" xpId) (xpAttrImplied "type" xpPrim) ) (xp4Tuple - (xpOption . xpElemNodes "subject" $ xpContent xpText) - (xpOption . xpElemNodes "body" $ xpContent xpText) - (xpOption . xpElemNodes "thread" $ xpContent xpText) - xpTrees + (xpOption . xpElemNodes "subject" $ xpContent xpId) + (xpOption . xpElemNodes "body" $ xpContent xpId) + (xpOption . xpElemNodes "thread" $ xpContent xpId) + (xpAll xpElemVerbatim) ) -presenceP :: PU [Node Text Text] Presence -presenceP = xpWrap ( (\((from, to, id, tp),(shw, stat, prio, ext)) +presenceP :: PU [Node] Presence +presenceP = xpWrap (\((from, to, id, tp),(shw, stat, prio, ext)) -> Presence from to id tp shw stat prio ext) - , (\(Presence from to id tp shw stat prio ext) + (\(Presence from to id tp shw stat prio ext) -> ((from, to, id, tp), (shw, stat, prio, ext))) - ) $ + $ xpElem "presence" (xp4Tuple (xpAttrImplied "from" xpPrim) (xpAttrImplied "to" xpPrim) - (xpAttrImplied "id" xpText) + (xpAttrImplied "id" xpId) (xpAttrImplied "type" xpPrim) ) (xp4Tuple (xpOption . xpElemNodes "show" $ xpContent xpPrim) - (xpOption . xpElemNodes "status" $ xpContent xpText) + (xpOption . xpElemNodes "status" $ xpContent xpId) (xpOption . xpElemNodes "priority" $ xpContent xpPrim) - xpTrees + (xpAll xpElemVerbatim) ) -iqP :: PU [Node Text Text] IQ -iqP = xpWrap ( (\((from, to, id, tp),body) -> IQ from to id tp body) - , (\(IQ from to id tp body) -> ((from, to, id, tp), body)) - ) $ +iqP :: PU [Node] IQ +iqP = xpWrap (\((from, to, id, tp),body) -> IQ from to id tp body) + (\(IQ from to id tp body) -> ((from, to, id, tp), body)) + $ xpElem "iq" (xp4Tuple (xpAttrImplied "from" xpPrim) (xpAttrImplied "to" xpPrim) - (xpAttr "id" xpText) + (xpAttr "id" xpId) (xpAttr "type" xpPrim)) - (xpTree) + (xpElemVerbatim) diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 2db6c84..9121a0a 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -7,6 +7,7 @@ import Control.Applicative((<$>)) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class +import Control.Monad.Trans.Resource import Control.Monad.Trans.State import Data.ByteString as BS @@ -14,10 +15,16 @@ import Data.Text(Text) import Data.Conduit import Data.Conduit.Binary as CB -import Data.Conduit.Hexpat as HXC import Data.Conduit.List as CL import Data.Conduit.Text as CT +import Data.XML.Pickle +import Data.XML.Types +import Text.XML.Unresolved +import Text.XML.Stream.Parse +import Text.XML.Stream.Render as XR +import Text.XML.Stream.Elements + import qualified Data.Text as Text import Network.XMPP.Types @@ -26,32 +33,25 @@ import Network.XMPP.Pickle import System.IO -import Text.XML.Expat.SAX -import Text.XML.Expat.Pickle(PU) -import Text.XML.Expat.Tree -import Text.XML.Expat.Format - -parseOpts :: ParseOptions tag text -parseOpts = ParseOptions (Just UTF8) Nothing +-- parseOpts :: ParseOptions tag text +-- parseOpts = ParseOptions (Just UTF8) Nothing pushN :: Element -> XMPPMonad () pushN x = do sink <- gets sConPush - liftIO . sink $ formatNode' x + lift . sink $ elementToEvents x push :: Stanza -> XMPPMonad () push = pushN . pickleElem stanzaP pushOpen :: Element -> XMPPMonad () -pushOpen (Element name attrs children) = do +pushOpen e = do sink <- gets sConPush - let sax = StartElement name attrs - liftIO . sink $ formatSAX' [sax] - forM children pushN + lift . sink $ openElementToEvents e return () -pulls :: Sink Event IO a -> XMPPMonad a +pulls :: Sink Event (ResourceT IO) a -> XMPPMonad a pulls snk = do source <- gets sConSrc lift $ source $$ snk @@ -60,7 +60,7 @@ pullE :: XMPPMonad Element pullE = do pulls elementFromEvents -pullPickle :: PU [Node Text Text] b -> XMPPMonad b +pullPickle :: PU [Node] b -> XMPPMonad b pullPickle p = unpickleElem p <$> pullE pull :: XMPPMonad Stanza @@ -76,11 +76,13 @@ xmppFromHandle xmppFromHandle handle hostname username resource f = runResourceT $ do liftIO $ hSetBuffering handle NoBuffering raw <- bufferSource $ CB.sourceHandle handle - src <- bufferSource $ raw $= HXC.parseBS parseOpts + src <- bufferSource $ raw $= parseBytes def let st = XMPPState src raw - (liftIO . BS.hPut handle) + (\xs -> CL.sourceList xs + $$ XR.renderBytes def =$ CB.sinkHandle handle) + (BS.hPut handle) (Just handle) def False diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index d171a6e..37ef35c 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -11,31 +11,42 @@ import Control.Applicative((<$>)) import qualified Data.ByteString as BS -import Data.Text as Text +import qualified Data.Text as Text import Data.Text.Encoding as Text +import Data.XML.Types +import Data.XML.Pickle + import Network.XMPP.Types -import Text.XML.Expat.Pickle -import Text.XML.Expat.Tree mbToBool (Just _) = True mbToBool _ = False -xpElemEmpty :: Text -> PU [Node Text Text] () -xpElemEmpty name = xpWrap (\((),()) -> () , - \() -> ((),())) $ +xpElemEmpty :: Name -> PU [Node] () +xpElemEmpty name = xpWrap (\((),()) -> ()) + (\() -> ((),())) $ xpElem name xpUnit xpUnit -xpElemExists :: Text -> PU [Node Text Text] Bool -xpElemExists name = xpWrap (\x -> mbToBool x - ,\x -> if x then Just () else Nothing) $ - xpOption (xpElemEmpty name) +-- xpElemExists :: Name -> PU [Node] Bool +-- xpElemExists name = xpWrap (\x -> mbToBool x) +-- (\x -> if x then Just () else Nothing) $ +-- xpOption (xpElemEmpty name) + +xpNodeElem :: PU [Node] a -> PU Element a +xpNodeElem xp = PU { pickleTree = \x -> head $ (pickleTree xp x) >>= \y -> + case y of + NodeContent _ -> [] + NodeElement e -> [e] + , unpickleTree = \x -> case unpickleTree xp $ [NodeElement x] of + Left l -> Left l + Right (a,(_,c)) -> Right (a,(Nothing,c)) + } ignoreAttrs :: PU t ((), b) -> PU t b -ignoreAttrs = xpWrap (snd, ((),)) +ignoreAttrs = xpWrap snd ((),) mbl (Just l) = l mbl Nothing = [] @@ -47,33 +58,11 @@ right (Left l) = error l right (Right r) = r -unpickleElem :: PU [Node tag text] c -> Node tag text -> c -unpickleElem p = right . unpickleTree' (xpRoot p) - -pickleElem :: PU [Node tag text] a -> a -> Node tag text -pickleElem p = pickleTree $ xpRoot p - -xpEither :: PU n t1 -> PU n t2 -> PU n (Either t1 t2) -xpEither l r = xpAlt eitherSel - [xpWrap (\x -> Left x, \(Left x) -> x) l - ,xpWrap (\x -> Right x, \(Right x) -> x) r - ] - where - eitherSel (Left _) = 0 - eitherSel (Right _) = 1 - - -xpElemNs :: - Text - -> Text - -> PU [(Text, Text)] t1 - -> PU [Node Text Text] t2 - -> PU [Node Text Text] (t1, t2) -xpElemNs name ns attrs nodes = - xpWrap (\(((),a),n) -> (a,n), \(a,n) -> (((),a),n)) $ - xpElem name - (xpPair - (xpAttrFixed "xmlns" ns) - attrs - ) - nodes \ No newline at end of file +unpickleElem :: PU [Node] c -> Element -> c +unpickleElem p = right . unpickle (xpNodeElem p) + +pickleElem :: PU [Node] a -> a -> Element +pickleElem p = pickle $ xpNodeElem p + + + diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 21a8632..3066c3b 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -19,8 +19,11 @@ import qualified Data.ByteString.Base64 as B64 import qualified Data.List as L import qualified Data.Digest.Pure.MD5 as MD5 import Data.List +import Data.XML.Pickle +import Data.XML.Types import qualified Data.Text as Text +import Data.Text(Text) import Data.Text (Text) import qualified Data.Text.Encoding as Text @@ -29,31 +32,27 @@ import Network.XMPP.Pickle import Network.XMPP.Stream import Network.XMPP.Types -import Numeric -- +import Numeric import qualified System.Random as Random -import Text.XML.Expat.Pickle -import Text.XML.Expat.Tree -saslInitE :: Text -> Node Text Text +saslInitE :: Text -> Element saslInitE mechanism = - Element "auth" - [ ("xmlns","urn:ietf:params:xml:ns:xmpp-sasl") - , ("mechanism", mechanism) - ] + Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth" + [ ("mechanism", [ContentText mechanism]) ] [] -saslResponseE :: Text -> Node Text Text +saslResponseE :: Text -> Element saslResponseE resp = - Element "response" - [("xmlns","urn:ietf:params:xml:ns:xmpp-sasl")] - [Text resp] + Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" + [] + [NodeContent $ ContentText resp] -saslResponse2E :: Node Text Text +saslResponse2E :: Element saslResponse2E = - Element "response" - [("xmlns","urn:ietf:params:xml:ns:xmpp-sasl")] + Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" + [] [] xmppSASL :: Text -> XMPPMonad () @@ -69,7 +68,7 @@ xmppSASL passwd = do Left x -> error $ show x Right c -> return () pushN saslResponse2E - Element "success" [("xmlns","urn:ietf:params:xml:ns:xmpp-sasl")] [] <- pullE + Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pullE xmppRestartStream return () @@ -136,15 +135,11 @@ md5Digest uname realm password digestURI nc qop nonce cnonce= -- Pickling -failurePickle :: PU [Node Text Text] (Node Text Text) -failurePickle = ignoreAttrs $ - xpElem "failure" - (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-sasl") - (xpTree) - -challengePickle :: PU [Node Text.Text Text.Text] Text.Text -challengePickle = ignoreAttrs $ - xpElem "challenge" - (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-sasl") - (xpContent xpText0) +failurePickle :: PU [Node] (Element) +failurePickle = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}failure" + (xpIsolate xpElemVerbatim) + +challengePickle :: PU [Node] Text.Text +challengePickle = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" + (xpIsolate $ xpContent xpId) diff --git a/src/Network/XMPP/Session.hs b/src/Network/XMPP/Session.hs index 6d90975..fe8a696 100644 --- a/src/Network/XMPP/Session.hs +++ b/src/Network/XMPP/Session.hs @@ -6,22 +6,20 @@ import Control.Monad.Trans.State import Data.Text as Text +import Data.XML.Pickle +import Data.XML.Types + import Network.XMPP.Monad import Network.XMPP.Types import Network.XMPP.Pickle import Network.XMPP.Marshal -import Text.XML.Expat.Pickle - sessionIQ :: Stanza sessionIQ = SIQ $ IQ Nothing Nothing "sess" Set (pickleElem - (xpElemNs "session" - "urn:ietf:params:xml:ns:xmpp-session" - xpUnit - xpUnit) - ((),()) + (xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session") + () ) xmppSession :: XMPPMonad () diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index 223fc89..bdd04ad 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -14,15 +14,31 @@ import Network.XMPP.Pickle import Network.XMPP.Types import Data.Conduit -import Data.Conduit.Hexpat as HXC import Data.Conduit.List as CL +import Data.Default(def) import qualified Data.List as L import Data.Text as T +import Data.XML.Types +import Data.XML.Pickle + +import qualified Text.XML.Stream.Parse as XP +import Text.XML.Stream.Elements -import Text.XML.Expat.Pickle -- import Text.XML.Stream.Elements +throwOutJunk = do + next <- peek + case next of + Nothing -> return () + Just (EventBeginElement _ _) -> return () + _ -> CL.drop 1 >> throwOutJunk + +openElementFromEvents = do + throwOutJunk + Just (EventBeginElement name attrs) <- CL.head + return $ Element name attrs [] + xmppStartStream :: XMPPMonad () xmppStartStream = do @@ -36,17 +52,18 @@ xmppRestartStream :: XMPPMonad () xmppRestartStream = do raw <- gets sRawSrc src <- gets sConSrc - newsrc <- lift (bufferSource $ raw $= HXC.parseBS parseOpts) + + newsrc <- lift (bufferSource $ raw $= XP.parseBytes def) modify (\s -> s{sConSrc = newsrc}) xmppStartStream -xmppStream :: Sink Event IO ServerFeatures +xmppStream :: Sink Event (ResourceT IO) ServerFeatures xmppStream = do xmppStreamHeader xmppStreamFeatures -xmppStreamHeader :: Sink Event IO () +xmppStreamHeader :: Sink Event (ResourceT IO) () xmppStreamHeader = do throwOutJunk (ver, _, _) <- unpickleElem pickleStream <$> openElementFromEvents @@ -54,14 +71,14 @@ xmppStreamHeader = do return() -xmppStreamFeatures :: Sink Event IO ServerFeatures +xmppStreamFeatures :: Sink Event (ResourceT IO) ServerFeatures xmppStreamFeatures = unpickleElem pickleStreamFeatures <$> elementFromEvents -- Pickling -pickleStream :: PU [Node Text Text] (Text, Maybe Text, Maybe Text) -pickleStream = xpWrap (snd, (((),()),)) . +pickleStream :: PU [Node] (Text, Maybe Text, Maybe Text) +pickleStream = xpWrap snd (((),()),) . xpElemAttrs "stream:stream" $ xpPair (xpPair @@ -69,32 +86,32 @@ pickleStream = xpWrap (snd, (((),()),)) . (xpAttrFixed "xmlns:stream" "http://etherx.jabber.org/streams" ) ) (xpTriple - (xpAttr "version" xpText) - (xpOption $ xpAttr "from" xpText) - (xpOption $ xpAttr "to" xpText) + (xpAttr "version" xpId) + (xpOption $ xpAttr "from" xpId) + (xpOption $ xpAttr "to" xpId) ) -pickleTLSFeature :: PU [Node Text Text] Bool +pickleTLSFeature :: PU [Node] Bool pickleTLSFeature = ignoreAttrs $ xpElem "starttls" (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-tls") (xpElemExists "required") -pickleSaslFeature :: PU [Node Text Text] [Text] +pickleSaslFeature :: PU [Node] [Text] pickleSaslFeature = ignoreAttrs $ xpElem "mechanisms" (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-sasl") (xpList0 $ - xpElemNodes "mechanism" (xpContent xpText) ) + xpElemNodes "mechanism" (xpContent xpId) ) -pickleStreamFeatures :: PU [Node Text Text] ServerFeatures -pickleStreamFeatures = xpWrap ( \(tls, sasl, rest) -> SF tls (mbl sasl) rest - , (\(SF tls sasl rest) -> (tls, lmb sasl, rest)) - ) $ +pickleStreamFeatures :: PU [Node] ServerFeatures +pickleStreamFeatures = xpWrap ( \(tls, sasl, rest) -> SF tls (mbl sasl) rest) + (\(SF tls sasl rest) -> (tls, lmb sasl, rest)) + $ xpElemNodes "stream:features" (xpTriple (xpOption pickleTLSFeature) (xpOption pickleSaslFeature) - xpTrees + (xpAll xpElemVerbatim) ) diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index de310a4..3ab79c8 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -5,26 +5,29 @@ module Network.XMPP.TLS where import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class +import Control.Monad.Trans.Resource import Control.Monad.Trans.State +import Data.Default import Data.Text(Text) +import Data.XML.Types import Network.XMPP.Monad import Network.XMPP.Stream import Network.XMPP.Types import Data.Conduit -import Data.Conduit.Hexpat as HX import Data.Conduit.Text as CT import Data.Conduit.TLS as TLS import Data.Conduit.List as CL import qualified Data.List as L -import Text.XML.Expat.Tree +import qualified Text.XML.Stream.Render as XR -starttlsE :: Node Text Text + +starttlsE :: Element starttlsE = - Element "starttls" [("xmlns", "urn:ietf:params:xml:ns:xmpp-tls")] [] + Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] exampleParams :: TLSParams @@ -35,15 +38,17 @@ xmppStartTLS params = do features <- gets sFeatures unless (stls features == Nothing) $ do pushN starttlsE - Element "proceed" [("xmlns", "urn:ietf:params:xml:ns:xmpp-tls")] [] <- pullE + Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pullE Just handle <- gets sConHandle - (raw', snk) <- lift $ TLS.tlsinit params handle + (raw', snk, push) <- lift $ TLS.tlsinit params handle raw <- lift . bufferSource $ raw' modify (\x -> x { sRawSrc = raw -- , sConSrc = -- Note: this momentarily leaves us in an -- inconsistent state - , sConPush = liftIO . snk + , sConPush = \xs -> CL.sourceList xs + $$ XR.renderBytes def =$ snk + , sConPushBS = push }) xmppRestartStream modify (\s -> s{sHaveTLS = True}) diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index 846e757..76ec5db 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -7,18 +7,15 @@ import Control.Monad.Trans.State import qualified Data.ByteString as BS import Data.Conduit +import Data.Default import Data.List.Split as L import Data.Maybe import Data.Text as Text import Data.String as Str -import System.IO - -import Text.XML.Expat.SAX -import Text.XML.Expat.Tree +import Data.XML.Types -type Element = Node Text.Text Text.Text -type Event = SAXEvent Text.Text Text.Text +import System.IO -- | Jabber ID (JID) datatype data JID = JID { node :: Maybe Text @@ -37,9 +34,10 @@ instance Show JID where type XMPPMonad a = StateT XMPPState (ResourceT IO) a data XMPPState = XMPPState - { sConSrc :: BufferedSource IO Event - , sRawSrc :: BufferedSource IO BS.ByteString - , sConPush :: BS.ByteString -> IO () + { sConSrc :: BufferedSource (ResourceT IO) Event + , sRawSrc :: BufferedSource (ResourceT IO) BS.ByteString + , sConPush :: [Event] -> ResourceT IO () + , sConPushBS :: BS.ByteString -> IO () , sConHandle :: Maybe Handle , sFeatures :: ServerFeatures , sHaveTLS :: Bool @@ -55,11 +53,12 @@ data ServerFeatures = SF } deriving Show -def = SF - { stls = Nothing - , saslMechanisms = [] - , other = [] - } +instance Default ServerFeatures where + def = SF + { stls = Nothing + , saslMechanisms = [] + , other = [] + } -- Ugh, that smells a bit. @@ -130,7 +129,7 @@ data MessageType = Chat | GroupChat | Headline | Normal | MessageError deriving data PresenceType = Default | Unavailable | Subscribe | Subscribed | Unsubscribe | Unsubscribed | Probe | PresenceError deriving Eq -data IQType = Get | Result | Set | IQError deriving Eq +data IQType = Get | Result | Set | IQError deriving (Eq, Ord) data ShowType = Available | Away | FreeChat | DND | XAway deriving Eq diff --git a/src/Text/XML/Stream/Elements.hs b/src/Text/XML/Stream/Elements.hs new file mode 100644 index 0000000..3812752 --- /dev/null +++ b/src/Text/XML/Stream/Elements.hs @@ -0,0 +1,78 @@ +module Text.XML.Stream.Elements where + +import Control.Applicative ((<$>)) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Resource as R + +import Data.Text as T +import Text.XML.Unresolved +import Data.XML.Types + +import Data.Conduit as C +import Data.Conduit.List as CL + +import Text.XML.Stream.Parse + +compressNodes :: [Node] -> [Node] +compressNodes [] = [] +compressNodes [x] = [x] +compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) = + compressNodes $ NodeContent (ContentText $ x `T.append` y) : z +compressNodes (x:xs) = x : compressNodes xs + +elementFromEvents :: R.MonadThrow m => C.Sink Event m Element +elementFromEvents = do + x <- CL.peek + case x of + Just (EventBeginElement n as) -> goE n as + _ -> lift $ R.monadThrow $ InvalidEventStream $ "not an element: " ++ show x + where + many f = + go id + where + go front = do + x <- f + case x of + Nothing -> return $ front [] + Just y -> go (front . (:) y) + dropReturn x = CL.drop 1 >> return x + goE n as = do + CL.drop 1 + ns <- many goN + y <- CL.head + if y == Just (EventEndElement n) + then return $ Element n as $ compressNodes ns + else lift $ R.monadThrow $ InvalidEventStream $ "Missing end element for " ++ show n ++ ", got: " ++ show y + goN = do + x <- CL.peek + case x of + Just (EventBeginElement n as) -> (Just . NodeElement) <$> goE n as + Just (EventInstruction i) -> dropReturn $ Just $ NodeInstruction i + Just (EventContent c) -> dropReturn $ Just $ NodeContent c + Just (EventComment t) -> dropReturn $ Just $ NodeComment t + Just (EventCDATA t) -> dropReturn $ Just $ NodeContent $ ContentText t + _ -> return Nothing + + +openElementToEvents :: Element -> [Event] +openElementToEvents (Element name as ns) = EventBeginElement name as : goN ns [] + where + goM [] = id + goM [x] = (goM' x :) + goM (x:xs) = (goM' x :) . goM xs + goM' (MiscInstruction i) = EventInstruction i + goM' (MiscComment t) = EventComment t + goE (Element name as ns) = + (EventBeginElement name as :) + . goN ns + . (EventEndElement name :) + goN [] = id + goN [x] = goN' x + goN (x:xs) = goN' x . goN xs + goN' (NodeElement e) = goE e + goN' (NodeInstruction i) = (EventInstruction i :) + goN' (NodeContent c) = (EventContent c :) + goN' (NodeComment t) = (EventComment t :) + +elementToEvents :: Element -> [Event] +elementToEvents e@(Element name _ _) = openElementToEvents e ++ [EventEndElement name] From f0c05132ff381db1ae044ce7204e11e0a3c3bff5 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 28 Mar 2012 12:48:42 +0200 Subject: [PATCH 09/26] squash! some conduit weirdness (blocking where it shouldn't) --- .gitignore | 1 + src/Data/Conduit/Hexpat.hs | 188 ------------------------------------- src/Data/Conduit/TLS.hs | 3 +- src/Main.hs | 78 +++++++++++++++ src/Network/XMPP.hs | 32 +++---- src/Network/XMPP/Monad.hs | 51 ++++++++-- src/Network/XMPP/Stream.hs | 29 +++--- xmpp-lib.cabal | 10 +- 8 files changed, 166 insertions(+), 226 deletions(-) delete mode 100644 src/Data/Conduit/Hexpat.hs create mode 100644 src/Main.hs diff --git a/.gitignore b/.gitignore index a0ba28c..72042eb 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ +cabal-dev/ dist/ *.o *.hi diff --git a/src/Data/Conduit/Hexpat.hs b/src/Data/Conduit/Hexpat.hs deleted file mode 100644 index 1c4eef4..0000000 --- a/src/Data/Conduit/Hexpat.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, NoMonomorphismRestriction #-} - -module Data.Conduit.Hexpat where - -import Control.Applicative((<$>)) -import Control.Exception -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Class - -import qualified Data.ByteString as BS -import Data.Conduit as C -import Data.Conduit.List as CL -import Data.Maybe -import Data.Typeable - -import Text.XML.Expat.Internal.IO hiding (parse) -import Text.XML.Expat.SAX -import Text.XML.Expat.Tree - -import Foreign.Ptr - -import Data.IORef --- adapted from parseG - --- | Parse a generalized list of ByteStrings containing XML to SAX events. --- In the event of an error, FailDocument is the last element of the output list. --- parseG :: forall tag text l . (GenericXMLString tag, GenericXMLString text, List l) => --- ParseOptions tag text -- ^ Parse options --- -> l ByteString -- ^ Input text (a lazy ByteString) --- -> l (SAXEvent tag text) --- parseG opts inputBlocks = runParser inputBlocks parser queueRef cacheRef --- where - -data HexpatParser tag text a = HexpatParser - { hParser :: Parser - , hQueueRef :: IORef [SAXEvent tag text] - } - -createParser - :: (GenericXMLString tag, GenericXMLString text) => - ParseOptions tag text -> IO (HexpatParser tag text a) -createParser opts = do - let enc = overrideEncoding opts - let mEntityDecoder = entityDecoder opts - - parser <- newParser enc - queueRef <- newIORef [] - - case mEntityDecoder of - Just deco -> setEntityDecoder parser deco $ \_ txt -> do - modifyIORef queueRef (CharacterData txt:) - Nothing -> return () - - setXMLDeclarationHandler parser $ \_ cVer cEnc cSd -> do - ver <- textFromCString cVer - mEnc <- if cEnc == nullPtr - then return Nothing - else Just <$> textFromCString cEnc - let sd = if cSd < 0 - then Nothing - else Just $ if cSd /= 0 then True else False - modifyIORef queueRef (XMLDeclaration ver mEnc sd:) - return True - - setStartElementHandler parser $ \_ cName cAttrs -> do - name <- textFromCString cName - attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do - attrName <- textFromCString cAttrName - attrValue <- textFromCString cAttrValue - return (attrName, attrValue) - modifyIORef queueRef (StartElement name attrs:) - return True - - setEndElementHandler parser $ \_ cName -> do - name <- textFromCString cName - modifyIORef queueRef (EndElement name:) - return True - - setCharacterDataHandler parser $ \_ cText -> do - txt <- gxFromCStringLen cText - modifyIORef queueRef (CharacterData txt:) - return True - - setStartCDataHandler parser $ \_ -> do - modifyIORef queueRef (StartCData :) - return True - - setEndCDataHandler parser $ \_ -> do - modifyIORef queueRef (EndCData :) - return True - - setProcessingInstructionHandler parser $ \_ cTarget cText -> do - target <- textFromCString cTarget - txt <- textFromCString cText - modifyIORef queueRef (ProcessingInstruction target txt :) - return True - - setCommentHandler parser $ \_ cText -> do - txt <- textFromCString cText - modifyIORef queueRef (Comment txt :) - return True - - return (HexpatParser parser queueRef) - -data HexpatParseException = HexpatParseExceptio String deriving (Typeable, Show) -instance Exception HexpatParseException - -parseBS - :: (GenericXMLString text, GenericXMLString tag) => - ParseOptions tag text - -> Conduit BS.ByteString IO (SAXEvent tag text) -parseBS opts = conduitIO - (createParser opts) - (\_ -> return ()) - (\(HexpatParser parser queueRef) input -> do - error <- withParser parser $ \pp -> parseChunk pp input False - case error of - Nothing -> return () - Just (XMLParseError err _) -> - resourceThrow $ HexpatParseExceptio err - queue <- readIORef queueRef - writeIORef queueRef [] - return . IOProducing $ reverse queue - ) - (\(HexpatParser parser queueRef) -> do - error <- withParser parser $ \pp -> parseChunk pp BS.empty True - case error of - Nothing -> return () - Just (XMLParseError err _) -> - resourceThrow $ HexpatParseExceptio err - queue <- readIORef queueRef - writeIORef queueRef [] - return $ reverse queue - ) - -whileJust :: Monad m => m (Maybe a) -> m [a] -whileJust f = do - f' <- f - case f' of - Just x -> liftM (x :) $ whileJust f - Nothing -> return [] - - - -data StreamUnfinishedException = StreamUnfinishedException deriving (Typeable, Show) -instance Exception StreamUnfinishedException - - -elementFromEvents - :: (Eq tag, Show tag, MonadIO m, Resource m) => - Sink (SAXEvent tag text) m (NodeG [] tag text) -elementFromEvents = do - Just (StartElement name attrs) <- CL.head - children <- liftM catMaybes . whileJust $ do - next' <- CL.peek - next <- case next' of - Nothing -> liftIO . throwIO $ StreamUnfinishedException - Just n -> return n - case next of - StartElement _ _ -> Just . Just <$> elementFromEvents - EndElement n -> if n == name then CL.drop 1 >> return Nothing - else error $ "closing wrong element: " - ++ show n ++ " instead of " ++ show name - CharacterData txt -> CL.drop 1 >> (return . Just . Just $ Text txt) - _ -> return $ Just Nothing - return $ Element name attrs children - -openElementFromEvents - :: Resource m => Sink (SAXEvent tag text) m (NodeG [] tag text) -openElementFromEvents = do - throwOutJunk - Just (StartElement name attrs) <- CL.head - return $ Element name attrs [] - -throwOutJunk :: Resource m => Sink (SAXEvent t t1) m () -throwOutJunk = do - next <- peek - case next of - Nothing -> return () - Just (StartElement _ _) -> return () - _ -> CL.drop 1 >> throwOutJunk - -saxToElements - :: (Eq tag, Show tag, MonadIO m, Resource m) => - Conduit (SAXEvent tag text) m (Node tag text) -saxToElements = C.sequence $ throwOutJunk >> elementFromEvents - diff --git a/src/Data/Conduit/TLS.hs b/src/Data/Conduit/TLS.hs index 917eb5e..51e7358 100644 --- a/src/Data/Conduit/TLS.hs +++ b/src/Data/Conduit/TLS.hs @@ -1,6 +1,7 @@ {-# Language NoMonomorphismRestriction #-} module Data.Conduit.TLS ( tlsinit + , conduitStdout , module TLS , module TLSExtra ) @@ -45,7 +46,7 @@ tlsinit tlsParams handle = do (\con bs -> sendData clientContext (BL.fromChunks [bs]) >> return IOProcessing ) (\_ -> return ()) - return ( src + return ( src $= conduitStdout , snk , \s -> sendData clientContext $ BL.fromChunks [s] ) diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..9937806 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE PackageImports, OverloadedStrings #-} +module Main where + +import Data.Text as T + +import Network.XMPP +import Network.XMPP.Concurrent +import Network.XMPP.Types +import Network +import GHC.IO.Handle +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.Trans.State +import Control.Monad.IO.Class + +philonous :: JID +philonous = read "uart14@species64739.dyndns.org" + +attXmpp :: STM a -> XMPPThread a +attXmpp = liftIO . atomically + +autoAccept :: XMPPThread () +autoAccept = forever $ do + st <- pullPresence + case st of + Presence from _ id (Just Subscribe) _ _ _ _ -> + sendS . SPresence $ + Presence Nothing from id (Just Subscribed) Nothing Nothing Nothing [] + _ -> return () + +mirror :: XMPPThread () +mirror = forever $ do + st <- pullMessage + case st of + Message (Just from) _ id tp subject (Just bd) thr _ -> + sendS . SMessage $ + Message Nothing from id tp subject + (Just $ "you wrote: " `T.append` bd) thr [] + _ -> return () + +-- killer = forever $ do +-- st <- readChanS +-- case st of +-- Message _ _ id tp subject "kill" thr _ -> +-- killConnection >> return () +-- _ -> return () + +main :: IO () +main = do + putStrLn "hello world" + wait <- newEmptyMVar + connectXMPP "localhost" "species64739.dyndns.org" "bot" (Just "botsi") "pwd" + $ do + liftIO $ putStrLn "----------------------------" + -- sendS . SPresence $ + -- Presence Nothing Nothing Nothing Nothing (Just Available) Nothing Nothing [] + withNewThread autoAccept + withNewThread mirror +-- withNewThread killer + sendS . SPresence $ Presence Nothing Nothing Nothing Nothing + (Just Available) Nothing Nothing [] + liftIO $ putStrLn "----------------------------" + + sendS . SMessage $ Message Nothing philonous Nothing Nothing Nothing + (Just "bla") Nothing [] + forever $ pullMessage >>= liftIO . print +-- withNewThread . void $ (liftIO $ threadDelay 15000000) >> killConnection + + -- forever $ do + -- next <- nextM + -- outStanza $ Message Nothing philonous "" Chat "" "pong!" "" [] + -- liftIO $ print next + liftIO $ putMVar wait () + return () + takeMVar wait + return () + diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index 7f00330..3e44d90 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -1,31 +1,32 @@ {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} module Network.XMPP where -import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.State +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.State import qualified Data.ByteString as BS -import Data.Text as Text +import Data.Text as Text -import Network -import Network.XMPP.Concurrent -import Network.XMPP.Monad -import Network.XMPP.TLS -import Network.XMPP.Stream -import Network.XMPP.SASL -import Network.XMPP.Types -import Network.XMPP.Bind -import Network.XMPP.Session +import Network +import Network.XMPP.Bind +import Network.XMPP.Concurrent +import Network.XMPP.Monad +import Network.XMPP.SASL +import Network.XMPP.Session +import Network.XMPP.Stream +import Network.XMPP.TLS +import Network.XMPP.Types - -import System.IO +import System.IO --fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> IO ((), XMPPState) fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> XMPPThread a -> IO ((), XMPPState) fromHandle handle hostname username resource password a = xmppFromHandle handle hostname username resource $ do + liftIO $ putStrLn "start stream" xmppStartStream -- this will check whether the server supports tls -- on it's own @@ -42,4 +43,3 @@ connectXMPP host hostname username resource passwd a = do con <- connectTo host (PortNumber 5222) hSetBuffering con NoBuffering fromHandle con hostname username resource passwd a - diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 9121a0a..7a4b868 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -17,11 +17,11 @@ import Data.Conduit import Data.Conduit.Binary as CB import Data.Conduit.List as CL import Data.Conduit.Text as CT +import Data.Conduit.TLS import Data.XML.Pickle import Data.XML.Types -import Text.XML.Unresolved -import Text.XML.Stream.Parse +import Text.XML.Stream.Parse as XP import Text.XML.Stream.Render as XR import Text.XML.Stream.Elements @@ -75,13 +75,16 @@ xmppFromHandle -> IO (a, XMPPState) xmppFromHandle handle hostname username resource f = runResourceT $ do liftIO $ hSetBuffering handle NoBuffering - raw <- bufferSource $ CB.sourceHandle handle - src <- bufferSource $ raw $= parseBytes def + let raw = CB.sourceHandle handle -- $= conduitStdout + liftIO $ BS.hPut handle "" + src <- bufferSource $ raw $= CT.decode CT.utf8 $= XP.parseText def + src $= CL.map (Text.pack . show) $= CT.encode CT.utf8 $$ sinkHandle stdout + error "done" let st = XMPPState src - raw + undefined -- raw (\xs -> CL.sourceList xs - $$ XR.renderBytes def =$ CB.sinkHandle handle) + $$ XR.renderBytes def =$ conduitStdout =$ CB.sinkHandle handle) (BS.hPut handle) (Just handle) def @@ -90,3 +93,39 @@ xmppFromHandle handle hostname username resource f = runResourceT $ do username resource runStateT f st + +xml = + [ "" + , "" + , "" + , "" + , "" + , "PLAIN" + , "" + , "DIGEST-MD5" + , "" + , "SCRAM-SHA-1" + , "" + , "" + , "" + , "" + , "" + , error "Booh!" + ] :: [ByteString] + +xml2 = BS.concat ["" + ,"PLAINDIGEST-MD5SCRAM-SHA-1"] + +fooS sr = sr $= CT.decode CT.utf8 $= XP.parseText def +blarg = forever $ do + p <- CL.peek + case p of + Nothing -> error "end" + Just p' -> liftIO $ print p + CL.drop 1 + + +test :: Source (ResourceT IO) ByteString -> ResourceT IO () +test sr = fooS sr $$ blarg \ No newline at end of file diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index bdd04ad..d25fd75 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -4,7 +4,7 @@ module Network.XMPP.Stream where import Control.Applicative((<$>)) -import Control.Monad(unless) +import Control.Monad(unless, forever) import Control.Monad.Trans.Class import Control.Monad.Trans.State import Control.Monad.IO.Class @@ -17,6 +17,7 @@ import Data.Conduit import Data.Conduit.List as CL import Data.Default(def) import qualified Data.List as L +import Data.Conduit.Text as CT import Data.Text as T import Data.XML.Types import Data.XML.Pickle @@ -28,7 +29,13 @@ import Text.XML.Stream.Elements -- import Text.XML.Stream.Elements throwOutJunk = do - next <- peek + liftIO $ putStrLn "peeking..." + next <- CL.peek + liftIO $ putStrLn "peeked." + liftIO $ do + putStrLn "peek:" + print next + putStrLn "==========" case next of Nothing -> return () Just (EventBeginElement _ _) -> return () @@ -36,6 +43,7 @@ throwOutJunk = do openElementFromEvents = do throwOutJunk + liftIO $ putStrLn "starting ------" Just (EventBeginElement name attrs) <- CL.head return $ Element name attrs [] @@ -65,7 +73,9 @@ xmppStream = do xmppStreamHeader :: Sink Event (ResourceT IO) () xmppStreamHeader = do - throwOutJunk + liftIO $ putStrLn "throwing junk!" +-- throwOutJunk + liftIO $ putStrLn "junk thrown" (ver, _, _) <- unpickleElem pickleStream <$> openElementFromEvents unless (ver == "1.0") $ error "Not XMPP version 1.0 " return() @@ -92,17 +102,12 @@ pickleStream = xpWrap snd (((),()),) . ) pickleTLSFeature :: PU [Node] Bool -pickleTLSFeature = ignoreAttrs $ - xpElem "starttls" - (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-tls") - (xpElemExists "required") +pickleTLSFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls" + (xpElemExists "required") pickleSaslFeature :: PU [Node] [Text] -pickleSaslFeature = ignoreAttrs $ - xpElem "mechanisms" - (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-sasl") - (xpList0 $ - xpElemNodes "mechanism" (xpContent xpId) ) +pickleSaslFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms" + (xpAll $ xpElemNodes "mechanism" (xpContent xpId) ) pickleStreamFeatures :: PU [Node] ServerFeatures pickleStreamFeatures = xpWrap ( \(tls, sasl, rest) -> SF tls (mbl sasl) rest) diff --git a/xmpp-lib.cabal b/xmpp-lib.cabal index ae42c30..6f0f043 100644 --- a/xmpp-lib.cabal +++ b/xmpp-lib.cabal @@ -26,9 +26,9 @@ library hs-source-dirs: src Build-Depends: base >3 && <5 , conduit -any + , resourcet -any + , containers -any , random -any - , hexpat -any - , hexpat-pickle -any , tls -any , tls-extra -any , pureMD5 -any @@ -42,6 +42,10 @@ library , network -any , split -any , stm -any + , xml-types -any + , xml-conduit -any + , xml-types-pickle -any + , data-default -any Exposed-modules: Network.XMPP , Network.XMPP.Types , Network.XMPP.SASL @@ -53,6 +57,6 @@ library , Network.XMPP.TLS , Network.XMPP.Bind , Network.XMPP.Session - , Data.Conduit.Hexpat + , Text.XML.Stream.Elements , Data.Conduit.TLS GHC-Options: -Wall From f54b50d609f83901595930baa17be2dd0bf160c0 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 1 Apr 2012 21:12:03 +0200 Subject: [PATCH 10/26] switched to hexpat-internals --- .gitignore | 5 +- src/Data/Conduit/Hexpat.hs | 141 ++++++++++++++++++++++++++++++++++++ src/Data/Conduit/TLS.hs | 2 +- src/Main.hs | 5 +- src/Network/XMPP.hs | 1 - src/Network/XMPP/Marshal.hs | 21 +++--- src/Network/XMPP/Monad.hs | 62 +++------------- src/Network/XMPP/SASL.hs | 2 +- src/Network/XMPP/Stream.hs | 66 +++++++---------- xmpp-lib.cabal | 1 + 10 files changed, 196 insertions(+), 110 deletions(-) create mode 100644 src/Data/Conduit/Hexpat.hs diff --git a/.gitignore b/.gitignore index 72042eb..d7ddec5 100644 --- a/.gitignore +++ b/.gitignore @@ -1,7 +1,8 @@ -cabal-dev/ dist/ +cabal-dev/ *.o *.hi *~ *# -*.#* \ No newline at end of file +*.#* +*_flymake.hs \ No newline at end of file diff --git a/src/Data/Conduit/Hexpat.hs b/src/Data/Conduit/Hexpat.hs new file mode 100644 index 0000000..f236a7c --- /dev/null +++ b/src/Data/Conduit/Hexpat.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE DeriveDataTypeable, NoMonomorphismRestriction #-} + +module Data.Conduit.Hexpat + ( ParseOptions(..) + , defaultParseOptions + , parseBS + ) + + where + +import Control.Applicative((<$>)) +import Control.Exception +import Control.Monad +import Control.Monad.Trans.Class + +import qualified Data.ByteString as BS +import Data.Conduit as C +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TE +import Data.Text(Text) +import Data.Typeable +import Data.XML.Types as XML + +import Text.XML.Expat.Internal.IO hiding (parse) + +import Data.IORef +-- adapted from parseG + +-- | Parse a generalized list of ByteStrings containing XML to SAX events. +-- In the event of an error, FailDocument is the last element of the output list. + +data HexpatParser = HexpatParser + { hParser :: Parser + , hQueueRef :: IORef [XML.Event] + } + +splitName :: Text -> Name +splitName name = case Text.split (=='}') name of + [n] -> case Text.split (==':') n of + [n'] -> Name n' Nothing Nothing + [p,n'] -> Name n' Nothing (Just p) + _ -> throw . HexpatParseException + $ "Error parsing name: " ++ show name + [ns,n] -> Name n (Just ns) Nothing + _ -> throw . HexpatParseException + $ "Error parsing name: " ++ show name + +createParser :: ParseOptions -> Maybe Char -> IO (HexpatParser) +createParser opts delim = do + let enc = overrideEncoding opts +-- let mEntityDecoder = entityDecoder opts + parser <- newParser enc delim + queueRef <- newIORef [] + + -- setXMLDeclarationHandler parser $ \_ cVer cEnc cSd -> do + -- ver <- textFromCString cVer + -- mEnc <- if cEnc == nullPtr + -- then return Nothing + -- else Just <$> textFromCString cEnc + -- let sd = if cSd < 0 + -- then Nothing + -- else Just $ if cSd /= 0 then True else False + -- modifyIORef queueRef (XMLDeclaration ver mEnc sd:) + -- TODO: What to do here? + -- return True + + setStartElementHandler parser $ \_ cName cAttrs -> do + name <- splitName <$> textFromCString cName + attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do + attrName <- splitName <$> textFromCString cAttrName + attrValue <- ContentText <$> textFromCString cAttrValue + return (attrName, [attrValue]) + modifyIORef queueRef (EventBeginElement name attrs:) + return True + + setEndElementHandler parser $ \_ cName -> do + name <- splitName <$> textFromCString cName + modifyIORef queueRef (EventEndElement name:) + return True + + setCharacterDataHandler parser $ \_ cText -> do + txt <- TE.decodeUtf8 <$> BS.packCStringLen cText + modifyIORef queueRef ((EventContent $ ContentText txt):) + return True + + setProcessingInstructionHandler parser $ \_ cTarget cText -> do + target <- textFromCString cTarget + txt <- textFromCString cText + modifyIORef queueRef (EventInstruction (Instruction target txt) :) + return True + + setCommentHandler parser $ \_ cText -> do + txt <- textFromCString cText + modifyIORef queueRef (EventComment txt :) + return True + + return (HexpatParser parser queueRef) + +data HexpatParseException = HexpatParseException String deriving (Typeable, Show) +instance Exception HexpatParseException + +parseBS + :: (MonadResource (t IO), MonadTrans t) => + ParseOptions -> Conduit BS.ByteString (t IO) Event +parseBS opts = conduitIO + (createParser opts (Just '}')) + (\_ -> return ()) + (\(HexpatParser parser queueRef) input -> lift $ do + e <- withParser parser $ \pp -> parseChunk pp input False + case e of + Nothing -> return () + Just (XMLParseError err _) -> + throwIO $ HexpatParseException err + queue <- readIORef queueRef + writeIORef queueRef [] + return . IOProducing $ reverse queue + ) + (\(HexpatParser parser queueRef) -> lift $ do + e <- withParser parser $ \pp -> parseChunk pp BS.empty True + case e of + Nothing -> return () + Just (XMLParseError err _) -> + throwIO $ HexpatParseException err + queue <- readIORef queueRef + writeIORef queueRef [] + return $ reverse queue + ) + +whileJust :: Monad m => m (Maybe a) -> m [a] +whileJust f = do + f' <- f + case f' of + Just x -> liftM (x :) $ whileJust f + Nothing -> return [] + + + +data StreamUnfinishedException = StreamUnfinishedException deriving (Typeable, Show) +instance Exception StreamUnfinishedException + + diff --git a/src/Data/Conduit/TLS.hs b/src/Data/Conduit/TLS.hs index 51e7358..61aeb5e 100644 --- a/src/Data/Conduit/TLS.hs +++ b/src/Data/Conduit/TLS.hs @@ -46,7 +46,7 @@ tlsinit tlsParams handle = do (\con bs -> sendData clientContext (BL.fromChunks [bs]) >> return IOProcessing ) (\_ -> return ()) - return ( src $= conduitStdout + return ( src , snk , \s -> sendData clientContext $ BL.fromChunks [s] ) diff --git a/src/Main.hs b/src/Main.hs index 9937806..71ca0b2 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -53,7 +53,8 @@ main = do connectXMPP "localhost" "species64739.dyndns.org" "bot" (Just "botsi") "pwd" $ do liftIO $ putStrLn "----------------------------" - -- sendS . SPresence $ + +-- sendS . SPresence $ -- Presence Nothing Nothing Nothing Nothing (Just Available) Nothing Nothing [] withNewThread autoAccept withNewThread mirror @@ -64,7 +65,7 @@ main = do sendS . SMessage $ Message Nothing philonous Nothing Nothing Nothing (Just "bla") Nothing [] - forever $ pullMessage >>= liftIO . print +-- forever $ pullMessage >>= liftIO . print -- withNewThread . void $ (liftIO $ threadDelay 15000000) >> killConnection -- forever $ do diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index 3e44d90..25f54b6 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -26,7 +26,6 @@ fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> XMPPThread a -> IO ((), XMPPState) fromHandle handle hostname username resource password a = xmppFromHandle handle hostname username resource $ do - liftIO $ putStrLn "start stream" xmppStartStream -- this will check whether the server supports tls -- on it's own diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index 18b5600..b507230 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/src/Network/XMPP/Marshal.hs @@ -33,7 +33,7 @@ messageP = xpWrap (\((from, to, id, tp),(sub, body, thr,ext)) (\(Message from to id tp sub body thr ext) -> ((from, to, id, tp), (sub, body, thr,ext))) $ - xpElem "message" + xpElem "{jabber:client}message" (xp4Tuple (xpAttrImplied "from" xpPrim) (xpAttr "to" xpPrim) @@ -41,9 +41,9 @@ messageP = xpWrap (\((from, to, id, tp),(sub, body, thr,ext)) (xpAttrImplied "type" xpPrim) ) (xp4Tuple - (xpOption . xpElemNodes "subject" $ xpContent xpId) - (xpOption . xpElemNodes "body" $ xpContent xpId) - (xpOption . xpElemNodes "thread" $ xpContent xpId) + (xpOption . xpElemNodes "{jabber:client}subject" $ xpContent xpId) + (xpOption . xpElemNodes "{jabber:client}body" $ xpContent xpId) + (xpOption . xpElemNodes "{jabber:client}thread" $ xpContent xpId) (xpAll xpElemVerbatim) ) @@ -53,7 +53,7 @@ presenceP = xpWrap (\((from, to, id, tp),(shw, stat, prio, ext)) (\(Presence from to id tp shw stat prio ext) -> ((from, to, id, tp), (shw, stat, prio, ext))) $ - xpElem "presence" + xpElem "{jabber:client}presence" (xp4Tuple (xpAttrImplied "from" xpPrim) (xpAttrImplied "to" xpPrim) @@ -61,9 +61,9 @@ presenceP = xpWrap (\((from, to, id, tp),(shw, stat, prio, ext)) (xpAttrImplied "type" xpPrim) ) (xp4Tuple - (xpOption . xpElemNodes "show" $ xpContent xpPrim) - (xpOption . xpElemNodes "status" $ xpContent xpId) - (xpOption . xpElemNodes "priority" $ xpContent xpPrim) + (xpOption . xpElemNodes "{jabber:client}show" $ xpContent xpPrim) + (xpOption . xpElemNodes "{jabber:client}status" $ xpContent xpId) + (xpOption . xpElemNodes "{jabber:client}priority" $ xpContent xpPrim) (xpAll xpElemVerbatim) ) @@ -71,11 +71,12 @@ iqP :: PU [Node] IQ iqP = xpWrap (\((from, to, id, tp),body) -> IQ from to id tp body) (\(IQ from to id tp body) -> ((from, to, id, tp), body)) $ - xpElem "iq" + xpElem "{jabber:client}iq" (xp4Tuple (xpAttrImplied "from" xpPrim) (xpAttrImplied "to" xpPrim) (xpAttr "id" xpId) - (xpAttr "type" xpPrim)) + ((xpAttr "type" xpPrim) :: PU [(Name,[Content])] IQType) + ) (xpElemVerbatim) diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 7a4b868..127c5d8 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -15,16 +15,18 @@ import Data.Text(Text) import Data.Conduit import Data.Conduit.Binary as CB +import Data.Conduit.Hexpat as CH import Data.Conduit.List as CL import Data.Conduit.Text as CT import Data.Conduit.TLS import Data.XML.Pickle import Data.XML.Types -import Text.XML.Stream.Parse as XP +--import Text.XML.Stream.Parse as XP import Text.XML.Stream.Render as XR import Text.XML.Stream.Elements + import qualified Data.Text as Text import Network.XMPP.Types @@ -33,9 +35,6 @@ import Network.XMPP.Pickle import System.IO --- parseOpts :: ParseOptions tag text --- parseOpts = ParseOptions (Just UTF8) Nothing - pushN :: Element -> XMPPMonad () pushN x = do sink <- gets sConPush @@ -57,34 +56,27 @@ pulls snk = do lift $ source $$ snk pullE :: XMPPMonad Element -pullE = do - pulls elementFromEvents +pullE = pulls elementFromEvents -pullPickle :: PU [Node] b -> XMPPMonad b +pullPickle :: Show b => PU [Node] b -> XMPPMonad b pullPickle p = unpickleElem p <$> pullE pull :: XMPPMonad Stanza pull = pullPickle stanzaP --- pull :: XMPPMonad Stanza --- pull = elementToStanza <$> pullE - xmppFromHandle :: Handle -> Text -> Text -> Maybe Text -> XMPPMonad a -> IO (a, XMPPState) xmppFromHandle handle hostname username resource f = runResourceT $ do liftIO $ hSetBuffering handle NoBuffering - let raw = CB.sourceHandle handle -- $= conduitStdout - liftIO $ BS.hPut handle "" - src <- bufferSource $ raw $= CT.decode CT.utf8 $= XP.parseText def - src $= CL.map (Text.pack . show) $= CT.encode CT.utf8 $$ sinkHandle stdout - error "done" + raw <- bufferSource $ CB.sourceHandle handle + src <- bufferSource $ raw $= CH.parseBS defaultParseOptions let st = XMPPState src - undefined -- raw + raw (\xs -> CL.sourceList xs - $$ XR.renderBytes def =$ conduitStdout =$ CB.sinkHandle handle) + $$ XR.renderBytes def =$ CB.sinkHandle handle) (BS.hPut handle) (Just handle) def @@ -93,39 +85,3 @@ xmppFromHandle handle hostname username resource f = runResourceT $ do username resource runStateT f st - -xml = - [ "" - , "" - , "" - , "" - , "" - , "PLAIN" - , "" - , "DIGEST-MD5" - , "" - , "SCRAM-SHA-1" - , "" - , "" - , "" - , "" - , "" - , error "Booh!" - ] :: [ByteString] - -xml2 = BS.concat ["" - ,"PLAINDIGEST-MD5SCRAM-SHA-1"] - -fooS sr = sr $= CT.decode CT.utf8 $= XP.parseText def -blarg = forever $ do - p <- CL.peek - case p of - Nothing -> error "end" - Just p' -> liftIO $ print p - CL.drop 1 - - -test :: Source (ResourceT IO) ByteString -> ResourceT IO () -test sr = fooS sr $$ blarg \ No newline at end of file diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 3066c3b..71b00b8 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -58,7 +58,7 @@ saslResponse2E = xmppSASL :: Text -> XMPPMonad () xmppSASL passwd = do mechanisms <- gets $ saslMechanisms . sFeatures - unless ("DIGEST-MD5" `elem` mechanisms) $ error "No usable auth mechanism" + unless ("DIGEST-MD5" `elem` mechanisms) . error $ "No usable auth mechanism: " ++ show mechanisms pushN $ saslInitE "DIGEST-MD5" Right challenge <- B64.decode . Text.encodeUtf8<$> pullPickle challengePickle let Right pairs = toPairs challenge diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index d25fd75..f8f773e 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -3,39 +3,34 @@ module Network.XMPP.Stream where -import Control.Applicative((<$>)) -import Control.Monad(unless, forever) -import Control.Monad.Trans.Class -import Control.Monad.Trans.State -import Control.Monad.IO.Class - -import Network.XMPP.Monad -import Network.XMPP.Pickle -import Network.XMPP.Types - -import Data.Conduit -import Data.Conduit.List as CL -import Data.Default(def) +import Control.Applicative((<$>)) +import Control.Monad(unless, forever) +import Control.Monad.Trans.Class +import Control.Monad.Trans.State +import Control.Monad.IO.Class + +import Network.XMPP.Monad +import Network.XMPP.Pickle +import Network.XMPP.Types + +import Data.Conduit +import qualified Data.Conduit.Hexpat as CH +import Data.Conduit.List as CL +import Data.Conduit.Text as CT +import Data.Default(def) import qualified Data.List as L -import Data.Conduit.Text as CT -import Data.Text as T -import Data.XML.Types -import Data.XML.Pickle +import Data.Text as T +import Data.XML.Pickle +import Data.XML.Types -import qualified Text.XML.Stream.Parse as XP -import Text.XML.Stream.Elements +-- import qualified Text.XML.Stream.Parse as XP +import Text.XML.Stream.Elements -- import Text.XML.Stream.Elements throwOutJunk = do - liftIO $ putStrLn "peeking..." next <- CL.peek - liftIO $ putStrLn "peeked." - liftIO $ do - putStrLn "peek:" - print next - putStrLn "==========" case next of Nothing -> return () Just (EventBeginElement _ _) -> return () @@ -43,7 +38,6 @@ throwOutJunk = do openElementFromEvents = do throwOutJunk - liftIO $ putStrLn "starting ------" Just (EventBeginElement name attrs) <- CL.head return $ Element name attrs [] @@ -60,8 +54,7 @@ xmppRestartStream :: XMPPMonad () xmppRestartStream = do raw <- gets sRawSrc src <- gets sConSrc - - newsrc <- lift (bufferSource $ raw $= XP.parseBytes def) + newsrc <- lift (bufferSource $ raw $= CH.parseBS CH.defaultParseOptions) modify (\s -> s{sConSrc = newsrc}) xmppStartStream @@ -73,9 +66,7 @@ xmppStream = do xmppStreamHeader :: Sink Event (ResourceT IO) () xmppStreamHeader = do - liftIO $ putStrLn "throwing junk!" --- throwOutJunk - liftIO $ putStrLn "junk thrown" + throwOutJunk (ver, _, _) <- unpickleElem pickleStream <$> openElementFromEvents unless (ver == "1.0") $ error "Not XMPP version 1.0 " return() @@ -88,13 +79,7 @@ xmppStreamFeatures = unpickleElem pickleStreamFeatures <$> elementFromEvents -- Pickling pickleStream :: PU [Node] (Text, Maybe Text, Maybe Text) -pickleStream = xpWrap snd (((),()),) . - xpElemAttrs "stream:stream" $ - xpPair - (xpPair - (xpAttrFixed "xmlns" "jabber:client" ) - (xpAttrFixed "xmlns:stream" "http://etherx.jabber.org/streams" ) - ) +pickleStream = xpElemAttrs (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) (xpTriple (xpAttr "version" xpId) (xpOption $ xpAttr "from" xpId) @@ -107,13 +92,14 @@ pickleTLSFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls" pickleSaslFeature :: PU [Node] [Text] pickleSaslFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms" - (xpAll $ xpElemNodes "mechanism" (xpContent xpId) ) + (xpAll $ xpElemNodes + "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId) ) pickleStreamFeatures :: PU [Node] ServerFeatures pickleStreamFeatures = xpWrap ( \(tls, sasl, rest) -> SF tls (mbl sasl) rest) (\(SF tls sasl rest) -> (tls, lmb sasl, rest)) $ - xpElemNodes "stream:features" + xpElemNodes (Name "features" (Just "http://etherx.jabber.org/streams") (Just "stream")) (xpTriple (xpOption pickleTLSFeature) (xpOption pickleSaslFeature) diff --git a/xmpp-lib.cabal b/xmpp-lib.cabal index 6f0f043..9771727 100644 --- a/xmpp-lib.cabal +++ b/xmpp-lib.cabal @@ -29,6 +29,7 @@ library , resourcet -any , containers -any , random -any + , hexpat-internals -any , tls -any , tls-extra -any , pureMD5 -any From 79b98e8814706995fd8de775770c3abc6aebf416 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 3 Apr 2012 11:30:24 +0200 Subject: [PATCH 11/26] added some preliminary IQ-handling support --- src/Network/XMPP/Concurrent.hs | 32 ++++++++++++++++++++++++++++---- 1 file changed, 28 insertions(+), 4 deletions(-) diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs index a1e82a4..8e518c8 100644 --- a/src/Network/XMPP/Concurrent.hs +++ b/src/Network/XMPP/Concurrent.hs @@ -42,6 +42,9 @@ data Thread = Thread { messagesRef :: IORef (Maybe (TChan Message)) , mShadow :: TChan Message -- the original chan , pShadow :: TChan Presence -- the original chan , outCh :: TChan Stanza + , iqHandlers :: TVar ( Map.Map (IQType, Text) (TChan IQ) + , Map.Map Text (TMVar IQ) + ) } type XMPPThread a = ReaderT Thread IO a @@ -97,14 +100,34 @@ startThreads = do Set -> case Map.lookup (Set, iqNS) byNS of Nothing -> return () -- TODO: send error stanza Just ch -> writeTChan ch iq - Result -> case Map.lookup (iqId iq) byID of - Nothing -> return () -- ?? Should we be sending an error? - Just tmvar -> putTMVar tmvar iq + Result -> case Map.updateLookupWithKey (\_ _ -> Nothing) + (iqId iq) byID of + (Nothing, _) -> return () -- we are not supposed + -- to send an error + (Just tmvar, byID') -> do + tryPutTMVar tmvar iq -- don't block + writeTVar handlers (byNS, byID) + killConnection writeLock threads = liftIO $ do atomically $ takeTMVar writeLock forM threads killThread return() +addIQChan :: IQType -> Text -> XMPPThread (Bool, TChan IQ) +addIQChan tp ns = do + handlers <- asks iqHandlers + liftIO . atomically $ do + (byNS, byID) <- readTVar handlers + iqCh <- newTChan + let (present, byNS') = Map.insertLookupWithKey' (\_ new _ -> new) + (tp,ns) iqCh byNS + writeTVar handlers (byNS', byID) + return $ case present of + Nothing -> (False, iqCh) + Just iqCh' -> (True, iqCh') + + + runThreaded :: XMPPThread a -> XMPPMonad ThreadId runThreaded a = do @@ -112,7 +135,7 @@ runThreaded a = do workermCh <- liftIO . newIORef $ Just mC workerpCh <- liftIO . newIORef $ Just pC worker <- liftIO . forkIO $ do - runReaderT a (Thread workermCh workerpCh mC pC outC) + runReaderT a (Thread workermCh workerpCh mC pC outC hand) return () return worker @@ -215,3 +238,4 @@ connPersist pushBS lock = forever $ do threadDelay 30000000 + From 7b8dea4af12dc34e508d9a4dcc746b5e55e1b08b Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 3 Apr 2012 11:44:39 +0200 Subject: [PATCH 12/26] added submodules --- .gitmodules | 9 +++++++++ hexpat-internals | 1 + xml | 1 + xml-types-pickle | 1 + 4 files changed, 12 insertions(+) create mode 100644 .gitmodules create mode 160000 hexpat-internals create mode 160000 xml create mode 160000 xml-types-pickle diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..f6255f8 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,9 @@ +[submodule "xml"] + path = xml + url = https://github.com/snoyberg/xml.git +[submodule "xml-types-pickle"] + path = xml-types-pickle + url = git@github.com:Philonous/xml-types-pickle.git +[submodule "hexpat-internals"] + path = hexpat-internals + url = git@github.com:Philonous/hexpat-internals.git diff --git a/hexpat-internals b/hexpat-internals new file mode 160000 index 0000000..55c95b0 --- /dev/null +++ b/hexpat-internals @@ -0,0 +1 @@ +Subproject commit 55c95b082eaa37836822d23bf3313cc8b1ad71af diff --git a/xml b/xml new file mode 160000 index 0000000..e5b4238 --- /dev/null +++ b/xml @@ -0,0 +1 @@ +Subproject commit e5b4238b214f288cea822222876baf7d3f02699a diff --git a/xml-types-pickle b/xml-types-pickle new file mode 160000 index 0000000..950653f --- /dev/null +++ b/xml-types-pickle @@ -0,0 +1 @@ +Subproject commit 950653f0e4266ff4eb1573959b1d584f4e3062a1 From 9fd7e8daff55e2cbee878cc89bd4063683e64e14 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 3 Apr 2012 13:59:27 +0200 Subject: [PATCH 13/26] conduit 0.4, switched back to xml-conduit --- src/Network/XMPP/Monad.hs | 37 ++++++++++++++++++++++++++++--------- src/Network/XMPP/Stream.hs | 7 ++++--- src/Network/XMPP/TLS.hs | 3 +-- src/Network/XMPP/Types.hs | 4 ++-- src/xml-conduit-testcase.hs | 22 ++++++++++++++++++++++ 5 files changed, 57 insertions(+), 16 deletions(-) create mode 100644 src/xml-conduit-testcase.hs diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 127c5d8..f80a17c 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -11,18 +11,19 @@ import Control.Monad.Trans.Resource import Control.Monad.Trans.State import Data.ByteString as BS +import Data.Default(def) import Data.Text(Text) import Data.Conduit import Data.Conduit.Binary as CB -import Data.Conduit.Hexpat as CH +-- import Data.Conduit.Hexpat as CH import Data.Conduit.List as CL import Data.Conduit.Text as CT import Data.Conduit.TLS import Data.XML.Pickle import Data.XML.Types ---import Text.XML.Stream.Parse as XP +import Text.XML.Stream.Parse as XP import Text.XML.Stream.Render as XR import Text.XML.Stream.Elements @@ -49,14 +50,15 @@ pushOpen e = do lift . sink $ openElementToEvents e return () - pulls :: Sink Event (ResourceT IO) a -> XMPPMonad a pulls snk = do source <- gets sConSrc - lift $ source $$ snk + (src', r) <- lift $ source $$+ snk + modify $ (\s -> s {sConSrc = src'}) + return r pullE :: XMPPMonad Element -pullE = pulls elementFromEvents +pullE = pulls elementFromEvents pullPickle :: Show b => PU [Node] b -> XMPPMonad b pullPickle p = unpickleElem p <$> pullE @@ -70,13 +72,13 @@ xmppFromHandle -> IO (a, XMPPState) xmppFromHandle handle hostname username resource f = runResourceT $ do liftIO $ hSetBuffering handle NoBuffering - raw <- bufferSource $ CB.sourceHandle handle - src <- bufferSource $ raw $= CH.parseBS defaultParseOptions + let raw = CB.sourceHandle handle $= conduitStdout + let src = raw $= XP.parseBytes def let st = XMPPState src - raw + (raw) (\xs -> CL.sourceList xs - $$ XR.renderBytes def =$ CB.sinkHandle handle) + $$ XR.renderBytes def =$ conduitStdout =$ CB.sinkHandle handle) (BS.hPut handle) (Just handle) def @@ -85,3 +87,20 @@ xmppFromHandle handle hostname username resource f = runResourceT $ do username resource runStateT f st + + +xml = + [ "" + , "" + , "" + , "" + , error "Booh!" + ] :: [BS.ByteString] + + +main :: IO () +main = (runResourceT $ CL.sourceList xml $= XP.parseBytes def $$ CL.take 2 ) + >>= print + diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index f8f773e..3bf5e98 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -14,7 +14,8 @@ import Network.XMPP.Pickle import Network.XMPP.Types import Data.Conduit -import qualified Data.Conduit.Hexpat as CH +import Data.Default(def) +-- import qualified Data.Conduit.Hexpat as CH import Data.Conduit.List as CL import Data.Conduit.Text as CT import Data.Default(def) @@ -25,7 +26,7 @@ import Data.XML.Types -- import qualified Text.XML.Stream.Parse as XP import Text.XML.Stream.Elements - +import Text.XML.Stream.Parse as XP -- import Text.XML.Stream.Elements @@ -54,7 +55,7 @@ xmppRestartStream :: XMPPMonad () xmppRestartStream = do raw <- gets sRawSrc src <- gets sConSrc - newsrc <- lift (bufferSource $ raw $= CH.parseBS CH.defaultParseOptions) + let newsrc = raw $= XP.parseBytes def modify (\s -> s{sConSrc = newsrc}) xmppStartStream diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index 3ab79c8..d9387b9 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -40,8 +40,7 @@ xmppStartTLS params = do pushN starttlsE Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pullE Just handle <- gets sConHandle - (raw', snk, push) <- lift $ TLS.tlsinit params handle - raw <- lift . bufferSource $ raw' + (raw, snk, push) <- lift $ TLS.tlsinit params handle modify (\x -> x { sRawSrc = raw -- , sConSrc = -- Note: this momentarily leaves us in an diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index 76ec5db..ecfa840 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -34,8 +34,8 @@ instance Show JID where type XMPPMonad a = StateT XMPPState (ResourceT IO) a data XMPPState = XMPPState - { sConSrc :: BufferedSource (ResourceT IO) Event - , sRawSrc :: BufferedSource (ResourceT IO) BS.ByteString + { sConSrc :: Source (ResourceT IO) Event + , sRawSrc :: Source (ResourceT IO) BS.ByteString , sConPush :: [Event] -> ResourceT IO () , sConPushBS :: BS.ByteString -> IO () , sConHandle :: Maybe Handle diff --git a/src/xml-conduit-testcase.hs b/src/xml-conduit-testcase.hs new file mode 100644 index 0000000..427d032 --- /dev/null +++ b/src/xml-conduit-testcase.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} +module Test where + +import qualified Data.ByteString as BS +import Data.Conduit +import Data.Default +import qualified Data.Conduit.List as CL +import qualified Text.XML.Stream.Parse as XP + +xml = + [ "" + , "" + , "" + , "" + , error "Booh!" + ] :: [BS.ByteString] + +main :: IO () +main = (runResourceT $ CL.sourceList xml $= XP.parseBytes def $$ CL.take 2 ) + >>= print \ No newline at end of file From 7013553deec42e19124e5ffa88c2d8c78ba92beb Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 3 Apr 2012 17:41:58 +0200 Subject: [PATCH 14/26] some cleanup --- .gitmodules | 10 +-- hexpat-internals | 1 - src/Data/Conduit/Hexpat.hs | 141 ------------------------------------ src/xml-conduit-testcase.hs | 22 ------ xml | 1 - xmpp-lib.cabal | 1 - 6 files changed, 2 insertions(+), 174 deletions(-) delete mode 160000 hexpat-internals delete mode 100644 src/Data/Conduit/Hexpat.hs delete mode 100644 src/xml-conduit-testcase.hs delete mode 160000 xml diff --git a/.gitmodules b/.gitmodules index f6255f8..a3c8b33 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,9 +1,3 @@ -[submodule "xml"] - path = xml - url = https://github.com/snoyberg/xml.git [submodule "xml-types-pickle"] - path = xml-types-pickle - url = git@github.com:Philonous/xml-types-pickle.git -[submodule "hexpat-internals"] - path = hexpat-internals - url = git@github.com:Philonous/hexpat-internals.git + path = xml-types-pickle + url = git@github.com:Philonous/xml-types-pickle.git diff --git a/hexpat-internals b/hexpat-internals deleted file mode 160000 index 55c95b0..0000000 --- a/hexpat-internals +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 55c95b082eaa37836822d23bf3313cc8b1ad71af diff --git a/src/Data/Conduit/Hexpat.hs b/src/Data/Conduit/Hexpat.hs deleted file mode 100644 index f236a7c..0000000 --- a/src/Data/Conduit/Hexpat.hs +++ /dev/null @@ -1,141 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, NoMonomorphismRestriction #-} - -module Data.Conduit.Hexpat - ( ParseOptions(..) - , defaultParseOptions - , parseBS - ) - - where - -import Control.Applicative((<$>)) -import Control.Exception -import Control.Monad -import Control.Monad.Trans.Class - -import qualified Data.ByteString as BS -import Data.Conduit as C -import qualified Data.Text as Text -import qualified Data.Text.Encoding as TE -import Data.Text(Text) -import Data.Typeable -import Data.XML.Types as XML - -import Text.XML.Expat.Internal.IO hiding (parse) - -import Data.IORef --- adapted from parseG - --- | Parse a generalized list of ByteStrings containing XML to SAX events. --- In the event of an error, FailDocument is the last element of the output list. - -data HexpatParser = HexpatParser - { hParser :: Parser - , hQueueRef :: IORef [XML.Event] - } - -splitName :: Text -> Name -splitName name = case Text.split (=='}') name of - [n] -> case Text.split (==':') n of - [n'] -> Name n' Nothing Nothing - [p,n'] -> Name n' Nothing (Just p) - _ -> throw . HexpatParseException - $ "Error parsing name: " ++ show name - [ns,n] -> Name n (Just ns) Nothing - _ -> throw . HexpatParseException - $ "Error parsing name: " ++ show name - -createParser :: ParseOptions -> Maybe Char -> IO (HexpatParser) -createParser opts delim = do - let enc = overrideEncoding opts --- let mEntityDecoder = entityDecoder opts - parser <- newParser enc delim - queueRef <- newIORef [] - - -- setXMLDeclarationHandler parser $ \_ cVer cEnc cSd -> do - -- ver <- textFromCString cVer - -- mEnc <- if cEnc == nullPtr - -- then return Nothing - -- else Just <$> textFromCString cEnc - -- let sd = if cSd < 0 - -- then Nothing - -- else Just $ if cSd /= 0 then True else False - -- modifyIORef queueRef (XMLDeclaration ver mEnc sd:) - -- TODO: What to do here? - -- return True - - setStartElementHandler parser $ \_ cName cAttrs -> do - name <- splitName <$> textFromCString cName - attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do - attrName <- splitName <$> textFromCString cAttrName - attrValue <- ContentText <$> textFromCString cAttrValue - return (attrName, [attrValue]) - modifyIORef queueRef (EventBeginElement name attrs:) - return True - - setEndElementHandler parser $ \_ cName -> do - name <- splitName <$> textFromCString cName - modifyIORef queueRef (EventEndElement name:) - return True - - setCharacterDataHandler parser $ \_ cText -> do - txt <- TE.decodeUtf8 <$> BS.packCStringLen cText - modifyIORef queueRef ((EventContent $ ContentText txt):) - return True - - setProcessingInstructionHandler parser $ \_ cTarget cText -> do - target <- textFromCString cTarget - txt <- textFromCString cText - modifyIORef queueRef (EventInstruction (Instruction target txt) :) - return True - - setCommentHandler parser $ \_ cText -> do - txt <- textFromCString cText - modifyIORef queueRef (EventComment txt :) - return True - - return (HexpatParser parser queueRef) - -data HexpatParseException = HexpatParseException String deriving (Typeable, Show) -instance Exception HexpatParseException - -parseBS - :: (MonadResource (t IO), MonadTrans t) => - ParseOptions -> Conduit BS.ByteString (t IO) Event -parseBS opts = conduitIO - (createParser opts (Just '}')) - (\_ -> return ()) - (\(HexpatParser parser queueRef) input -> lift $ do - e <- withParser parser $ \pp -> parseChunk pp input False - case e of - Nothing -> return () - Just (XMLParseError err _) -> - throwIO $ HexpatParseException err - queue <- readIORef queueRef - writeIORef queueRef [] - return . IOProducing $ reverse queue - ) - (\(HexpatParser parser queueRef) -> lift $ do - e <- withParser parser $ \pp -> parseChunk pp BS.empty True - case e of - Nothing -> return () - Just (XMLParseError err _) -> - throwIO $ HexpatParseException err - queue <- readIORef queueRef - writeIORef queueRef [] - return $ reverse queue - ) - -whileJust :: Monad m => m (Maybe a) -> m [a] -whileJust f = do - f' <- f - case f' of - Just x -> liftM (x :) $ whileJust f - Nothing -> return [] - - - -data StreamUnfinishedException = StreamUnfinishedException deriving (Typeable, Show) -instance Exception StreamUnfinishedException - - diff --git a/src/xml-conduit-testcase.hs b/src/xml-conduit-testcase.hs deleted file mode 100644 index 427d032..0000000 --- a/src/xml-conduit-testcase.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Test where - -import qualified Data.ByteString as BS -import Data.Conduit -import Data.Default -import qualified Data.Conduit.List as CL -import qualified Text.XML.Stream.Parse as XP - -xml = - [ "" - , "" - , "" - , "" - , error "Booh!" - ] :: [BS.ByteString] - -main :: IO () -main = (runResourceT $ CL.sourceList xml $= XP.parseBytes def $$ CL.take 2 ) - >>= print \ No newline at end of file diff --git a/xml b/xml deleted file mode 160000 index e5b4238..0000000 --- a/xml +++ /dev/null @@ -1 +0,0 @@ -Subproject commit e5b4238b214f288cea822222876baf7d3f02699a diff --git a/xmpp-lib.cabal b/xmpp-lib.cabal index 9771727..6f0f043 100644 --- a/xmpp-lib.cabal +++ b/xmpp-lib.cabal @@ -29,7 +29,6 @@ library , resourcet -any , containers -any , random -any - , hexpat-internals -any , tls -any , tls-extra -any , pureMD5 -any From 5cbec3efb26885e0dc7d05c66404fc9802fec0e6 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 4 Apr 2012 16:43:03 +0200 Subject: [PATCH 15/26] error types --- src/Network/XMPP/Types.hs | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index ecfa840..47fb28a 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -133,6 +133,19 @@ data IQType = Get | Result | Set | IQError deriving (Eq, Ord) data ShowType = Available | Away | FreeChat | DND | XAway deriving Eq +data ErrorType = Auth -- retry after providing credentials + | Cancel -- do not retry (the error cannot be remedied) + | Continue -- proceed (the condition was only a warning) + | Modify -- retry after changing the data sent + | Wait -- retry after waiting (the error is temporary) + +instance Show ErrorType where + show Auth = "auth" + show Cancel = "cancel" + show Continue = "continue" + show Modify = "modify" + show Wait = "wait" + instance Show MessageType where show Chat = "chat" show GroupChat = "groupchat" @@ -203,6 +216,13 @@ instance Read ShowType where readsPrec _ "invisible" = [( Available ,"")] readsPrec _ _ = error "incorrect value" +instance Read ErrorType where + readsPrec _ "auth" = [( Auth , "")] + readsPrec _ "cancel" = [( Cancel , "")] + readsPrec _ "continue" = [( Continue, "")] + readsPrec _ "modify" = [( Modify , "")] + readsPrec _ "wait" = [( Wait , "")] + readsPrec _ _ = error "incorrect value" toText :: Show a => a -> Text toText = Text.pack . show From d925ccddb69c9d34468aa5d7a26bc4b3e53d0757 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 4 Apr 2012 23:22:06 +0200 Subject: [PATCH 16/26] enforcing single threads --- src/Main.hs | 4 +- src/Network/XMPP.hs | 18 +++- src/Network/XMPP/Concurrent.hs | 175 +++++++++++++++++++++------------ src/Network/XMPP/Types.hs | 15 ++- xmpp-lib.cabal | 1 + 5 files changed, 138 insertions(+), 75 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 71ca0b2..b69dcd3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -56,8 +56,8 @@ main = do -- sendS . SPresence $ -- Presence Nothing Nothing Nothing Nothing (Just Available) Nothing Nothing [] - withNewThread autoAccept - withNewThread mirror + forkXMPP autoAccept + forkXMPP mirror -- withNewThread killer sendS . SPresence $ Presence Nothing Nothing Nothing Nothing (Just Available) Nothing Nothing [] diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index 25f54b6..40152b2 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -36,9 +36,25 @@ fromHandle handle hostname username resource password a = runThreaded a return () +--fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> IO ((), XMPPState) +fromHandle' :: Handle -> Text -> Text -> Maybe Text -> Text -> XMPPThread a + -> IO ((), XMPPState) +fromHandle' handle hostname username resource password a = + xmppFromHandle handle hostname username resource $ do + xmppStartStream + runThreaded $ do + -- this will check whether the server supports tls + -- on it's own + singleThreaded $ xmppStartTLS exampleParams + singleThreaded $ xmppSASL password + singleThreaded $ xmppBind + singleThreaded $ xmppSession + a + return () + connectXMPP :: HostName -> Text -> Text -> Maybe Text -> Text -> XMPPThread a -> IO ((), XMPPState) connectXMPP host hostname username resource passwd a = do con <- connectTo host (PortNumber 5222) hSetBuffering con NoBuffering - fromHandle con hostname username resource passwd a + fromHandle' con hostname username resource passwd a diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs index 8e518c8..c67f0d2 100644 --- a/src/Network/XMPP/Concurrent.hs +++ b/src/Network/XMPP/Concurrent.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction #-} @@ -6,36 +7,44 @@ module Network.XMPP.Concurrent where -- import Network.XMPP.Stream -import Network.XMPP.Types - -import Control.Concurrent -import Control.Concurrent.STM -import Control.Concurrent.STM.TChan -import Control.Concurrent.STM.TMVar -import Control.Monad.IO.Class -import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Resource -import Control.Monad.Trans.State +import Network.XMPP.Types + +import Control.Applicative((<$>),(<*>)) +import Control.Concurrent +import Control.Concurrent.STM +import Control.Concurrent.STM.TChan +import Control.Concurrent.STM.TMVar +import Control.Exception (throwTo) +import qualified Control.Exception.Lifted as Ex +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Resource +import Control.Monad.Trans.State import qualified Data.ByteString as BS +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Default (def) +import Data.IORef import qualified Data.Map as Map -import Data.Maybe -import Data.IORef -import Data.Text(Text) +import Data.Maybe +import Data.Text(Text) +import Data.Typeable -import Data.XML.Types +import Data.XML.Types -import Network.XMPP.Types -import Network.XMPP.Monad -import Network.XMPP.Marshal -import Network.XMPP.Pickle +import Network.XMPP.Types +import Network.XMPP.Monad +import Network.XMPP.Marshal +import Network.XMPP.Pickle -import System.IO +import System.IO -import Text.XML.Stream.Elements +import Text.XML.Stream.Elements +import qualified Text.XML.Stream.Render as XR data Thread = Thread { messagesRef :: IORef (Maybe (TChan Message)) , presenceRef :: IORef (Maybe (TChan Presence)) @@ -45,10 +54,63 @@ data Thread = Thread { messagesRef :: IORef (Maybe (TChan Message)) , iqHandlers :: TVar ( Map.Map (IQType, Text) (TChan IQ) , Map.Map Text (TMVar IQ) ) + , writeRef :: TMVar (BS.ByteString -> IO () ) + , readerThread :: ThreadId } type XMPPThread a = ReaderT Thread IO a + +data ReaderSignal = ReaderSignal (XMPPMonad ()) deriving Typeable +instance Show ReaderSignal where show _ = "" +instance Ex.Exception ReaderSignal + +readWorker :: TChan Message -> TChan Presence -> TChan IQ -> XMPPState -> ResourceT IO () +readWorker messageC presenceC iqC s = Ex.catch (forever . flip runStateT s $ do + sta <- pull + case sta of + SMessage m -> liftIO . atomically $ writeTChan messageC m + SPresence p -> liftIO . atomically $ writeTChan presenceC p + SIQ i -> liftIO . atomically $ writeTChan iqC i + ) + ( \(ReaderSignal a) -> do + ((),s') <- runStateT a s + readWorker messageC presenceC iqC s' + ) + +writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO ()) -> IO () +writeWorker stCh writeRef = forever $ do + (write, next) <- atomically $ (,) <$> + takeTMVar writeRef <*> + readTChan stCh + outBS <- CL.sourceList (elementToEvents $ pickleElem stanzaP next) + $= XR.renderBytes def $$ CL.consume + forM outBS write + atomically $ putTMVar writeRef write + + +handleIQs handlers iqC = liftIO . forever . atomically $ do + iq <- readTChan iqC + (byNS, byID) <- readTVar handlers + let iqNS' = nameNamespace . elementName . iqBody $ iq + case iqNS' of + Nothing -> return () -- TODO: send error stanza + Just iqNS -> case iqType iq of + Get -> case Map.lookup (Get, iqNS) byNS of + Nothing -> return () -- TODO: send error stanza + Just ch -> writeTChan ch iq + Set -> case Map.lookup (Set, iqNS) byNS of + Nothing -> return () -- TODO: send error stanza + Just ch -> writeTChan ch iq + Result -> case Map.updateLookupWithKey (\_ _ -> Nothing) + (iqId iq) byID of + (Nothing, _) -> return () -- we are not supposed + -- to send an error + (Just tmvar, byID') -> do + tryPutTMVar tmvar iq -- don't block + writeTVar handlers (byNS, byID) + + -- Two streams: input and output. Threads read from input stream and write to output stream. -- | Runs thread in XmppState monad -- returns channel of incoming and outgoing stances, respectively @@ -60,9 +122,13 @@ startThreads , Map.Map Text (TMVar IQ) ) , TChan Stanza, IO () + , TMVar (BS.ByteString -> IO ()) + , ThreadId ) + + startThreads = do - writeLock <- liftIO $ newTMVarIO () + writeLock <- liftIO . newTMVarIO =<< gets sConPushBS messageC <- liftIO newTChanIO presenceC <- liftIO newTChanIO iqC <- liftIO newTChanIO @@ -70,43 +136,18 @@ startThreads = do iqHandlers <- liftIO $ newTVarIO ( Map.empty, Map.empty) pushEvents <- gets sConPush pushBS <- gets sConPushBS - lw <- lift . resourceForkIO $ loopWrite writeLock pushEvents outC - cp <- liftIO . forkIO $ connPersist pushBS writeLock - iqh <- lift . resourceForkIO $ handleIQs iqHandlers iqC + lw <- liftIO . forkIO $ writeWorker outC writeLock + cp <- liftIO . forkIO $ connPersist writeLock + iqh <- liftIO . forkIO $ handleIQs iqHandlers iqC s <- get - rd <- lift . resourceForkIO . void . flip runStateT s . forever $ do - sta <- pull - case sta of - SMessage m -> liftIO . atomically $ writeTChan messageC m - SPresence p -> liftIO . atomically $ writeTChan presenceC p - SIQ i -> liftIO . atomically $ writeTChan iqC i - return (messageC, presenceC, iqHandlers, outC, killConnection writeLock [lw, rd, cp]) + rd <- lift . resourceForkIO $ readWorker messageC presenceC iqC s + return (messageC, presenceC, iqHandlers, outC, killConnection writeLock [lw, rd, cp], writeLock, rd) where loopWrite writeLock pushEvents out' = forever $ do next <- liftIO . atomically $ ( takeTMVar writeLock >> readTChan out') pushEvents . elementToEvents $ pickleElem stanzaP next liftIO . atomically $ putTMVar writeLock () - handleIQs handlers iqC = liftIO . forever . atomically $ do - iq <- readTChan iqC - (byNS, byID) <- readTVar handlers - let iqNS' = nameNamespace . elementName . iqBody $ iq - case iqNS' of - Nothing -> return () -- TODO: send error stanza - Just iqNS -> case iqType iq of - Get -> case Map.lookup (Get, iqNS) byNS of - Nothing -> return () -- TODO: send error stanza - Just ch -> writeTChan ch iq - Set -> case Map.lookup (Set, iqNS) byNS of - Nothing -> return () -- TODO: send error stanza - Just ch -> writeTChan ch iq - Result -> case Map.updateLookupWithKey (\_ _ -> Nothing) - (iqId iq) byID of - (Nothing, _) -> return () -- we are not supposed - -- to send an error - (Just tmvar, byID') -> do - tryPutTMVar tmvar iq -- don't block - writeTVar handlers (byNS, byID) killConnection writeLock threads = liftIO $ do atomically $ takeTMVar writeLock @@ -126,16 +167,15 @@ addIQChan tp ns = do Nothing -> (False, iqCh) Just iqCh' -> (True, iqCh') - - runThreaded :: XMPPThread a -> XMPPMonad ThreadId runThreaded a = do - (mC, pC, hand, outC, stopThreads) <- startThreads + (mC, pC, hand, outC, stopThreads, writeR, reader ) <- startThreads workermCh <- liftIO . newIORef $ Just mC workerpCh <- liftIO . newIORef $ Just pC worker <- liftIO . forkIO $ do - runReaderT a (Thread workermCh workerpCh mC pC outC hand) + runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR + reader) return () return worker @@ -203,8 +243,8 @@ sendS a = do return () -- | Fork a new thread -withNewThread :: XMPPThread () -> XMPPThread ThreadId -withNewThread a = do +forkXMPP :: XMPPThread () -> XMPPThread ThreadId +forkXMPP a = do thread <- ask mCH' <- liftIO $ newIORef Nothing pCH' <- liftIO $ newIORef Nothing @@ -229,13 +269,22 @@ waitForPresence f = do waitForPresence f -connPersist :: (BS.ByteString -> IO ()) -> TMVar () -> IO () -connPersist pushBS lock = forever $ do - atomically $ takeTMVar lock +connPersist :: TMVar (BS.ByteString -> IO ()) -> IO () +connPersist lock = forever $ do + pushBS <- atomically $ takeTMVar lock pushBS " " - atomically $ putTMVar lock () + atomically $ putTMVar lock pushBS -- putStrLn "" threadDelay 30000000 +singleThreaded a = do + writeLock <- asks writeRef + reader <- asks readerThread + liftIO . atomically $ takeTMVar writeLock + liftIO . throwTo reader . ReaderSignal $ do + a + out <- gets sConPushBS + liftIO . atomically $ putTMVar writeLock out + diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index 47fb28a..f4a5eeb 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -1,17 +1,13 @@ module Network.XMPP.Types where -- proudly "borrowed" from haskell-xmpp -import Control.Applicative((<$>)) -import Control.Monad import Control.Monad.Trans.State import qualified Data.ByteString as BS import Data.Conduit import Data.Default import Data.List.Split as L -import Data.Maybe import Data.Text as Text -import Data.String as Str import Data.XML.Types @@ -26,9 +22,9 @@ data JID = JID { node :: Maybe Text -- ^ Resource name } instance Show JID where - show (JID nd domain res) = + show (JID nd dmn res) = maybe "" ((++ "@") . Text.unpack) nd ++ - (Text.unpack domain) ++ + (Text.unpack dmn) ++ maybe "" (('/' :) . Text.unpack) res type XMPPMonad a = StateT XMPPState (ResourceT IO) a @@ -62,14 +58,15 @@ instance Default ServerFeatures where -- Ugh, that smells a bit. +parseJID :: [Char] -> JID parseJID jid = let (jid', rst) = case L.splitOn "@" jid of [rest] -> (JID Nothing, rest) - [node,rest] -> (JID (Just (Text.pack node)), rest) + [nd,rest] -> (JID (Just (Text.pack nd)), rest) _ -> error $ "Couldn't parse JID: \"" ++ jid ++ "\"" in case L.splitOn "/" rst of - [domain] -> jid' (Text.pack domain) Nothing - [domain, resource] -> jid' (Text.pack domain) (Just (Text.pack resource)) + [dmn] -> jid' (Text.pack dmn) Nothing + [dmn, rsrc] -> jid' (Text.pack dmn) (Just (Text.pack rsrc)) _ -> error $ "Couldn't parse JID: \"" ++ jid ++ "\"" instance Read JID where diff --git a/xmpp-lib.cabal b/xmpp-lib.cabal index 6f0f043..8422964 100644 --- a/xmpp-lib.cabal +++ b/xmpp-lib.cabal @@ -40,6 +40,7 @@ library , bytestring -any , transformers -any , network -any + , lifted-base -any , split -any , stm -any , xml-types -any From 5547a7025999e10635369184ebe1ae437e770985 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 5 Apr 2012 00:31:06 +0200 Subject: [PATCH 17/26] sendIQ, unique ID generation, channel autodrop, some documentation --- src/Network/XMPP/Concurrent.hs | 83 +++++++++++++++++++++++++++------- 1 file changed, 66 insertions(+), 17 deletions(-) diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs index c67f0d2..9909069 100644 --- a/src/Network/XMPP/Concurrent.hs +++ b/src/Network/XMPP/Concurrent.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction #-} @@ -31,6 +32,7 @@ import Data.Default (def) import Data.IORef import qualified Data.Map as Map import Data.Maybe +import qualified Data.Text as Text import Data.Text(Text) import Data.Typeable @@ -56,6 +58,7 @@ data Thread = Thread { messagesRef :: IORef (Maybe (TChan Message)) ) , writeRef :: TMVar (BS.ByteString -> IO () ) , readerThread :: ThreadId + , idGenerator :: IO Text } type XMPPThread a = ReaderT Thread IO a @@ -69,9 +72,22 @@ readWorker :: TChan Message -> TChan Presence -> TChan IQ -> XMPPState -> Resour readWorker messageC presenceC iqC s = Ex.catch (forever . flip runStateT s $ do sta <- pull case sta of - SMessage m -> liftIO . atomically $ writeTChan messageC m - SPresence p -> liftIO . atomically $ writeTChan presenceC p - SIQ i -> liftIO . atomically $ writeTChan iqC i + SMessage m -> liftIO . atomically $ do + writeTChan messageC m + _ <- readTChan messageC -- Sic! + return () + -- this may seem ridiculous, but to prevent + -- the channel from filling up we immedtiately remove the + -- Stanza we just put in. It will still be + -- available in duplicates. + SPresence p -> liftIO . atomically $ do + writeTChan presenceC p + _ <- readTChan presenceC + return () + SIQ i -> liftIO . atomically $ do + writeTChan iqC i + _ <-readTChan iqC + return () ) ( \(ReaderSignal a) -> do ((),s') <- runStateT a s @@ -154,8 +170,15 @@ startThreads = do forM threads killThread return() -addIQChan :: IQType -> Text -> XMPPThread (Bool, TChan IQ) -addIQChan tp ns = do + +-- | Register a new IQ listener. IQ matching the type and namespace will +-- be put in the channel. IQ of type Result and Error will never be put +-- into channels, even though this function won't stop you from registering +-- them +listenIQChan :: IQType -- ^ type of IQs to receive (Get / Set) + -> Text -- ^ namespace of the child element + -> XMPPThread (Bool, TChan IQ) +listenIQChan tp ns = do handlers <- asks iqHandlers liftIO . atomically $ do (byNS, byID) <- readTVar handlers @@ -167,21 +190,26 @@ addIQChan tp ns = do Nothing -> (False, iqCh) Just iqCh' -> (True, iqCh') +-- | Start worker threads and run action. The supplied action will run +-- in the calling thread. use 'forkXMPP' to start another thread. runThreaded :: XMPPThread a - -> XMPPMonad ThreadId + -> XMPPMonad a runThreaded a = do (mC, pC, hand, outC, stopThreads, writeR, reader ) <- startThreads - workermCh <- liftIO . newIORef $ Just mC - workerpCh <- liftIO . newIORef $ Just pC - worker <- liftIO . forkIO $ do - runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR - reader) - return () - return worker + workermCh <- liftIO . newIORef $ Nothing + workerpCh <- liftIO . newIORef $ Nothing + idRef <- liftIO $ newTVarIO 1 + let getId = atomically $ do + curId <- readTVar idRef + writeTVar idRef (curId + 1 :: Integer) + return . Text.pack $ show curId + liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR reader getId) + --- | get the inbound stanza channel, duplicate from master if necessary --- please note that once duplicated it will keep filling up +-- | get the inbound stanza channel, duplicates from master if necessary +-- please note that once duplicated it will keep filling up, call +-- 'dropMessageChan' to allow it to be garbage collected getMessageChan = do mChR <- asks messagesRef mCh <- liftIO $ readIORef mChR @@ -193,8 +221,7 @@ getMessageChan = do return mCh' Just mCh -> return mCh --- | get the inbound stanza channel, duplicate from master if necessary --- please note that once duplicated it will keep filling up +-- | see 'getMessageChan' getPresenceChan = do pChR <- asks presenceRef pCh <- liftIO $ readIORef pChR @@ -213,6 +240,7 @@ dropMessageChan = do r <- asks messagesRef liftIO $ writeIORef r Nothing +-- | see 'dropMessageChan' dropPresenceChan :: XMPPThread () dropPresenceChan = do r <- asks presenceRef @@ -277,6 +305,12 @@ connPersist lock = forever $ do -- putStrLn "" threadDelay 30000000 + +-- | Run an XMPPMonad action in isolation. +-- Reader and writer workers will be temporarily stopped +-- and resumed with the new session details once the action returns. +-- The Action will run in the reader thread. +singleThreaded :: XMPPMonad () -> XMPPThread () singleThreaded a = do writeLock <- asks writeRef reader <- asks readerThread @@ -285,6 +319,21 @@ singleThreaded a = do a out <- gets sConPushBS liftIO . atomically $ putTMVar writeLock out + return () +-- | Sends an IQ, returns a 'TMVar' that will be filled with the first inbound +-- IQ with a matching ID that has type @result@ or @error@ +sendIQ :: JID -> IQType -> Element -> XMPPThread (TMVar IQ) +sendIQ to tp body = do -- TODO: add timeout + newId <- liftIO =<< asks idGenerator + handlers <- asks iqHandlers + ref <- liftIO . atomically $ do + resRef <- newEmptyTMVar + (byNS, byId) <- readTVar handlers + writeTVar handlers (byNS, Map.insert newId resRef byId) + -- TODO: Check for id collisions (shouldn't happen?) + return resRef + sendS . SIQ $ IQ Nothing (Just to) newId tp body + return (readTMVar ref) From 5eab69b427f200bfdc06af77b061e66c02436682 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 5 Apr 2012 01:08:12 +0200 Subject: [PATCH 18/26] updated example, cleanup --- src/Main.hs | 32 ++++++-------------------------- src/Network/XMPP.hs | 25 ++++++++++++++++++++++--- src/Network/XMPP/Bind.hs | 5 ++--- src/Network/XMPP/Concurrent.hs | 2 +- src/Network/XMPP/Monad.hs | 16 ---------------- src/Network/XMPP/TLS.hs | 4 ++-- 6 files changed, 33 insertions(+), 51 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index b69dcd3..1cff5af 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -39,41 +39,21 @@ mirror = forever $ do (Just $ "you wrote: " `T.append` bd) thr [] _ -> return () --- killer = forever $ do --- st <- readChanS --- case st of --- Message _ _ id tp subject "kill" thr _ -> --- killConnection >> return () --- _ -> return () main :: IO () main = do - putStrLn "hello world" - wait <- newEmptyMVar - connectXMPP "localhost" "species64739.dyndns.org" "bot" (Just "botsi") "pwd" - $ do - liftIO $ putStrLn "----------------------------" - --- sendS . SPresence $ - -- Presence Nothing Nothing Nothing Nothing (Just Available) Nothing Nothing [] + sessionConnect "localhost" "species64739.dyndns.org" "bot" Nothing $ do + singleThreaded $ xmppStartTLS exampleParams + singleThreaded $ xmppSASL "pwd" + singleThreaded $ xmppBind (Just "botsi") + singleThreaded $ xmppSession forkXMPP autoAccept forkXMPP mirror --- withNewThread killer sendS . SPresence $ Presence Nothing Nothing Nothing Nothing (Just Available) Nothing Nothing [] - liftIO $ putStrLn "----------------------------" - sendS . SMessage $ Message Nothing philonous Nothing Nothing Nothing (Just "bla") Nothing [] --- forever $ pullMessage >>= liftIO . print --- withNewThread . void $ (liftIO $ threadDelay 15000000) >> killConnection - - -- forever $ do - -- next <- nextM - -- outStanza $ Message Nothing philonous "" Chat "" "pong!" "" [] - -- liftIO $ print next - liftIO $ putMVar wait () + liftIO . forever $ threadDelay 1000000 return () - takeMVar wait return () diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index 40152b2..dd5ba75 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -1,5 +1,16 @@ {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} -module Network.XMPP where +module Network.XMPP + ( module Network.XMPP.Bind + , module Network.XMPP.Concurrent + , module Network.XMPP.Monad + , module Network.XMPP.SASL + , module Network.XMPP.Session + , module Network.XMPP.Stream + , module Network.XMPP.TLS + , module Network.XMPP.Types + , connectXMPP + , sessionConnect + ) where import Control.Monad import Control.Monad.IO.Class @@ -31,7 +42,7 @@ fromHandle handle hostname username resource password a = -- on it's own xmppStartTLS exampleParams xmppSASL password - xmppBind + xmppBind resource xmppSession runThreaded a return () @@ -47,7 +58,7 @@ fromHandle' handle hostname username resource password a = -- on it's own singleThreaded $ xmppStartTLS exampleParams singleThreaded $ xmppSASL password - singleThreaded $ xmppBind + singleThreaded $ xmppBind resource singleThreaded $ xmppSession a return () @@ -58,3 +69,11 @@ connectXMPP host hostname username resource passwd a = do con <- connectTo host (PortNumber 5222) hSetBuffering con NoBuffering fromHandle' con hostname username resource passwd a + +sessionConnect :: HostName -> Text -> Text + -> Maybe Text -> XMPPThread a -> IO (a, XMPPState) +sessionConnect host hostname username resource a = do + con <- connectTo host (PortNumber 5222) + hSetBuffering con NoBuffering + xmppFromHandle con hostname username resource $ + xmppStartStream >> runThreaded a diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index 249b122..4d1e812 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -27,9 +27,8 @@ bindReqIQ resource= SIQ $ IQ Nothing Nothing "bind" Set jidP :: PU [Node] JID jidP = bindP $ xpElemNodes "jid" (xpContent xpPrim) -xmppBind :: XMPPMonad () -xmppBind = do - res <- gets sResource +xmppBind :: Maybe Text -> XMPPMonad () +xmppBind res = do push $ bindReqIQ res answer <- pull let SIQ (IQ Nothing Nothing _ Result b) = answer diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs index 9909069..c2b6a96 100644 --- a/src/Network/XMPP/Concurrent.hs +++ b/src/Network/XMPP/Concurrent.hs @@ -334,6 +334,6 @@ sendIQ to tp body = do -- TODO: add timeout -- TODO: Check for id collisions (shouldn't happen?) return resRef sendS . SIQ $ IQ Nothing (Just to) newId tp body - return (readTMVar ref) + return ref diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index f80a17c..4449b8d 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -88,19 +88,3 @@ xmppFromHandle handle hostname username resource f = runResourceT $ do resource runStateT f st - -xml = - [ "" - , "" - , "" - , "" - , error "Booh!" - ] :: [BS.ByteString] - - -main :: IO () -main = (runResourceT $ CL.sourceList xml $= XP.parseBytes def $$ CL.take 2 ) - >>= print - diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index d9387b9..c71338d 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -33,7 +33,7 @@ starttlsE = exampleParams :: TLSParams exampleParams = TLS.defaultParams {TLS.pCiphers = TLS.ciphersuite_strong} -xmppStartTLS :: TLSParams -> XMPPMonad Bool +xmppStartTLS :: TLSParams -> XMPPMonad () xmppStartTLS params = do features <- gets sFeatures unless (stls features == Nothing) $ do @@ -51,5 +51,5 @@ xmppStartTLS params = do }) xmppRestartStream modify (\s -> s{sHaveTLS = True}) - gets sHaveTLS + return () From 19a3005db61081b171718ed6f3dcdc568c66cf2e Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 5 Apr 2012 13:12:06 +0200 Subject: [PATCH 19/26] warning clean --- src/{Main.hs => Example.hs} | 15 +++----- src/Network/XMPP.hs | 38 +++++--------------- src/Network/XMPP/Bind.hs | 8 ++--- src/Network/XMPP/Concurrent.hs | 66 +++++++++++++++------------------- src/Network/XMPP/Marshal.hs | 35 ++++++++---------- src/Network/XMPP/Monad.hs | 24 +++++-------- src/Network/XMPP/Pickle.hs | 16 +++------ src/Network/XMPP/SASL.hs | 47 +++++++++++++----------- src/Network/XMPP/Session.hs | 11 ++---- src/Network/XMPP/Stream.hs | 43 ++++++++++------------ src/Network/XMPP/TLS.hs | 36 ++++++++----------- 11 files changed, 132 insertions(+), 207 deletions(-) rename src/{Main.hs => Example.hs} (76%) diff --git a/src/Main.hs b/src/Example.hs similarity index 76% rename from src/Main.hs rename to src/Example.hs index 1cff5af..c17b738 100644 --- a/src/Main.hs +++ b/src/Example.hs @@ -1,17 +1,12 @@ {-# LANGUAGE PackageImports, OverloadedStrings #-} -module Main where +module Example where import Data.Text as T import Network.XMPP -import Network.XMPP.Concurrent -import Network.XMPP.Types -import Network -import GHC.IO.Handle import Control.Concurrent import Control.Concurrent.STM import Control.Monad -import Control.Monad.Trans.State import Control.Monad.IO.Class philonous :: JID @@ -24,18 +19,18 @@ autoAccept :: XMPPThread () autoAccept = forever $ do st <- pullPresence case st of - Presence from _ id (Just Subscribe) _ _ _ _ -> + Presence from _ idq (Just Subscribe) _ _ _ _ -> sendS . SPresence $ - Presence Nothing from id (Just Subscribed) Nothing Nothing Nothing [] + Presence Nothing from idq (Just Subscribed) Nothing Nothing Nothing [] _ -> return () mirror :: XMPPThread () mirror = forever $ do st <- pullMessage case st of - Message (Just from) _ id tp subject (Just bd) thr _ -> + Message (Just from) _ idq tp subject (Just bd) thr _ -> sendS . SMessage $ - Message Nothing from id tp subject + Message Nothing from idq tp subject (Just $ "you wrote: " `T.append` bd) thr [] _ -> return () diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index dd5ba75..2680dbe 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -12,12 +12,6 @@ module Network.XMPP , sessionConnect ) where -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.State - -import qualified Data.ByteString as BS import Data.Text as Text import Network @@ -35,45 +29,29 @@ import System.IO --fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> IO ((), XMPPState) fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> XMPPThread a -> IO ((), XMPPState) -fromHandle handle hostname username resource password a = - xmppFromHandle handle hostname username resource $ do +fromHandle handle hostname username rsrc password a = + xmppFromHandle handle hostname username rsrc $ do xmppStartStream -- this will check whether the server supports tls -- on it's own xmppStartTLS exampleParams xmppSASL password - xmppBind resource + xmppBind rsrc xmppSession - runThreaded a - return () - ---fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> IO ((), XMPPState) -fromHandle' :: Handle -> Text -> Text -> Maybe Text -> Text -> XMPPThread a - -> IO ((), XMPPState) -fromHandle' handle hostname username resource password a = - xmppFromHandle handle hostname username resource $ do - xmppStartStream - runThreaded $ do - -- this will check whether the server supports tls - -- on it's own - singleThreaded $ xmppStartTLS exampleParams - singleThreaded $ xmppSASL password - singleThreaded $ xmppBind resource - singleThreaded $ xmppSession - a + _ <- runThreaded a return () connectXMPP :: HostName -> Text -> Text -> Maybe Text -> Text -> XMPPThread a -> IO ((), XMPPState) -connectXMPP host hostname username resource passwd a = do +connectXMPP host hostname username rsrc passwd a = do con <- connectTo host (PortNumber 5222) hSetBuffering con NoBuffering - fromHandle' con hostname username resource passwd a + fromHandle con hostname username rsrc passwd a sessionConnect :: HostName -> Text -> Text -> Maybe Text -> XMPPThread a -> IO (a, XMPPState) -sessionConnect host hostname username resource a = do +sessionConnect host hostname username rsrc a = do con <- connectTo host (PortNumber 5222) hSetBuffering con NoBuffering - xmppFromHandle con hostname username resource $ + xmppFromHandle con hostname username rsrc $ xmppStartStream >> runThreaded a diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index 4d1e812..1434e79 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -12,16 +12,14 @@ import Data.XML.Types import Network.XMPP.Monad import Network.XMPP.Types import Network.XMPP.Pickle -import Network.XMPP.Marshal - bindReqIQ :: Maybe Text -> Stanza -bindReqIQ resource= SIQ $ IQ Nothing Nothing "bind" Set +bindReqIQ rsrc= SIQ $ IQ Nothing Nothing "bind" Set (pickleElem (bindP . xpOption $ xpElemNodes "resource" (xpContent xpId)) - resource + rsrc ) jidP :: PU [Node] JID @@ -32,7 +30,7 @@ xmppBind res = do push $ bindReqIQ res answer <- pull let SIQ (IQ Nothing Nothing _ Result b) = answer - let (JID n d (Just r)) = unpickleElem jidP b + let (JID _n _d (Just r)) = unpickleElem jidP b modify (\s -> s{sResource = Just r}) bindP :: PU [Node] b -> PU [Node] b diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs index c2b6a96..9c9299b 100644 --- a/src/Network/XMPP/Concurrent.hs +++ b/src/Network/XMPP/Concurrent.hs @@ -13,9 +13,6 @@ import Network.XMPP.Types import Control.Applicative((<$>),(<*>)) import Control.Concurrent import Control.Concurrent.STM -import Control.Concurrent.STM.TChan -import Control.Concurrent.STM.TMVar -import Control.Exception (throwTo) import qualified Control.Exception.Lifted as Ex import Control.Monad import Control.Monad.IO.Class @@ -24,38 +21,33 @@ import Control.Monad.Trans.Reader import Control.Monad.Trans.Resource import Control.Monad.Trans.State - import qualified Data.ByteString as BS import Data.Conduit import qualified Data.Conduit.List as CL import Data.Default (def) import Data.IORef import qualified Data.Map as Map -import Data.Maybe import qualified Data.Text as Text import Data.Text(Text) import Data.Typeable import Data.XML.Types -import Network.XMPP.Types import Network.XMPP.Monad import Network.XMPP.Marshal import Network.XMPP.Pickle -import System.IO - import Text.XML.Stream.Elements import qualified Text.XML.Stream.Render as XR +type IQHandlers = (Map.Map (IQType, Text) (TChan IQ), Map.Map Text (TMVar IQ)) + data Thread = Thread { messagesRef :: IORef (Maybe (TChan Message)) , presenceRef :: IORef (Maybe (TChan Presence)) , mShadow :: TChan Message -- the original chan , pShadow :: TChan Presence -- the original chan , outCh :: TChan Stanza - , iqHandlers :: TVar ( Map.Map (IQType, Text) (TChan IQ) - , Map.Map Text (TMVar IQ) - ) + , iqHandlers :: TVar IQHandlers , writeRef :: TMVar (BS.ByteString -> IO () ) , readerThread :: ThreadId , idGenerator :: IO Text @@ -95,16 +87,17 @@ readWorker messageC presenceC iqC s = Ex.catch (forever . flip runStateT s $ do ) writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO ()) -> IO () -writeWorker stCh writeRef = forever $ do +writeWorker stCh writeR = forever $ do (write, next) <- atomically $ (,) <$> - takeTMVar writeRef <*> + takeTMVar writeR <*> readTChan stCh outBS <- CL.sourceList (elementToEvents $ pickleElem stanzaP next) $= XR.renderBytes def $$ CL.consume - forM outBS write - atomically $ putTMVar writeRef write + _ <- forM outBS write + atomically $ putTMVar writeR write +handleIQs :: MonadIO m => TVar IQHandlers -> TChan IQ -> m a handleIQs handlers iqC = liftIO . forever . atomically $ do iq <- readTChan iqC (byNS, byID) <- readTVar handlers @@ -118,13 +111,15 @@ handleIQs handlers iqC = liftIO . forever . atomically $ do Set -> case Map.lookup (Set, iqNS) byNS of Nothing -> return () -- TODO: send error stanza Just ch -> writeTChan ch iq - Result -> case Map.updateLookupWithKey (\_ _ -> Nothing) + -- Result / Error : + _ -> case Map.updateLookupWithKey (\_ _ -> Nothing) (iqId iq) byID of (Nothing, _) -> return () -- we are not supposed -- to send an error (Just tmvar, byID') -> do - tryPutTMVar tmvar iq -- don't block - writeTVar handlers (byNS, byID) + _ <- tryPutTMVar tmvar iq -- don't block + writeTVar handlers (byNS, byID') + -- Two streams: input and output. Threads read from input stream and write to output stream. @@ -149,25 +144,17 @@ startThreads = do presenceC <- liftIO newTChanIO iqC <- liftIO newTChanIO outC <- liftIO newTChanIO - iqHandlers <- liftIO $ newTVarIO ( Map.empty, Map.empty) - pushEvents <- gets sConPush - pushBS <- gets sConPushBS + handlers <- liftIO $ newTVarIO ( Map.empty, Map.empty) lw <- liftIO . forkIO $ writeWorker outC writeLock cp <- liftIO . forkIO $ connPersist writeLock - iqh <- liftIO . forkIO $ handleIQs iqHandlers iqC + iqh <- liftIO . forkIO $ handleIQs handlers iqC s <- get rd <- lift . resourceForkIO $ readWorker messageC presenceC iqC s - return (messageC, presenceC, iqHandlers, outC, killConnection writeLock [lw, rd, cp], writeLock, rd) + return (messageC, presenceC, handlers, outC, killConnection writeLock [lw, rd, cp, iqh], writeLock, rd) where - loopWrite writeLock pushEvents out' = forever $ do - next <- liftIO . atomically $ ( takeTMVar writeLock - >> readTChan out') - pushEvents . elementToEvents $ pickleElem stanzaP next - liftIO . atomically $ putTMVar writeLock () - killConnection writeLock threads = liftIO $ do - atomically $ takeTMVar writeLock - forM threads killThread + _ <- atomically $ takeTMVar writeLock -- Should we put it back? + _ <- forM threads killThread return() @@ -195,7 +182,7 @@ listenIQChan tp ns = do runThreaded :: XMPPThread a -> XMPPMonad a runThreaded a = do - (mC, pC, hand, outC, stopThreads, writeR, reader ) <- startThreads + (mC, pC, hand, outC, _stopThreads, writeR, rdr ) <- startThreads workermCh <- liftIO . newIORef $ Nothing workerpCh <- liftIO . newIORef $ Nothing idRef <- liftIO $ newTVarIO 1 @@ -203,13 +190,14 @@ runThreaded a = do curId <- readTVar idRef writeTVar idRef (curId + 1 :: Integer) return . Text.pack $ show curId - liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR reader getId) + liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR rdr getId) -- | get the inbound stanza channel, duplicates from master if necessary -- please note that once duplicated it will keep filling up, call -- 'dropMessageChan' to allow it to be garbage collected +getMessageChan :: XMPPThread (TChan Message) getMessageChan = do mChR <- asks messagesRef mCh <- liftIO $ readIORef mChR @@ -219,9 +207,10 @@ getMessageChan = do mCh' <- liftIO $ atomically $ dupTChan shadow liftIO $ writeIORef mChR (Just mCh') return mCh' - Just mCh -> return mCh + Just mCh' -> return mCh' -- | see 'getMessageChan' +getPresenceChan :: XMPPThread (TChan Presence) getPresenceChan = do pChR <- asks presenceRef pCh <- liftIO $ readIORef pChR @@ -231,7 +220,7 @@ getPresenceChan = do pCh' <- liftIO $ atomically $ dupTChan shadow liftIO $ writeIORef pChR (Just pCh') return pCh' - Just pCh -> return pCh + Just pCh' -> return pCh' -- | Drop the local end of the inbound stanza channel -- from our context so it can be GC-ed @@ -313,9 +302,10 @@ connPersist lock = forever $ do singleThreaded :: XMPPMonad () -> XMPPThread () singleThreaded a = do writeLock <- asks writeRef - reader <- asks readerThread - liftIO . atomically $ takeTMVar writeLock - liftIO . throwTo reader . ReaderSignal $ do + rdr <- asks readerThread + _ <- liftIO . atomically $ takeTMVar writeLock -- we replace it with the + -- one returned by a + liftIO . throwTo rdr . ReaderSignal $ do a out <- gets sConPushBS liftIO . atomically $ putTMVar writeLock out diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index b507230..b079e36 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/src/Network/XMPP/Marshal.hs @@ -2,20 +2,13 @@ module Network.XMPP.Marshal where -import Control.Applicative((<$>)) +import Data.XML.Pickle +import Data.XML.Types -import Data.Maybe -import Data.Text(Text) - -import Data.XML.Types -import Data.XML.Pickle - -import qualified Data.Text as Text - -import Network.XMPP.Pickle -import Network.XMPP.Types +import Network.XMPP.Types +stanzaSel :: Num a => Stanza -> a stanzaSel (SMessage _) = 0 stanzaSel (SPresence _) = 1 stanzaSel (SIQ _) = 2 @@ -28,10 +21,10 @@ stanzaP = xpAlt stanzaSel ] messageP :: PU [Node] Message -messageP = xpWrap (\((from, to, id, tp),(sub, body, thr,ext)) - -> Message from to id tp sub body thr ext) - (\(Message from to id tp sub body thr ext) - -> ((from, to, id, tp), (sub, body, thr,ext))) +messageP = xpWrap (\((from, to, qid, tp),(sub, body, thr,ext)) + -> Message from to qid tp sub body thr ext) + (\(Message from to qid tp sub body thr ext) + -> ((from, to, qid, tp), (sub, body, thr,ext))) $ xpElem "{jabber:client}message" (xp4Tuple @@ -48,10 +41,10 @@ messageP = xpWrap (\((from, to, id, tp),(sub, body, thr,ext)) ) presenceP :: PU [Node] Presence -presenceP = xpWrap (\((from, to, id, tp),(shw, stat, prio, ext)) - -> Presence from to id tp shw stat prio ext) - (\(Presence from to id tp shw stat prio ext) - -> ((from, to, id, tp), (shw, stat, prio, ext))) +presenceP = xpWrap (\((from, to, qid, tp),(shw, stat, prio, ext)) + -> Presence from to qid tp shw stat prio ext) + (\(Presence from to qid tp shw stat prio ext) + -> ((from, to, qid, tp), (shw, stat, prio, ext))) $ xpElem "{jabber:client}presence" (xp4Tuple @@ -68,8 +61,8 @@ presenceP = xpWrap (\((from, to, id, tp),(shw, stat, prio, ext)) ) iqP :: PU [Node] IQ -iqP = xpWrap (\((from, to, id, tp),body) -> IQ from to id tp body) - (\(IQ from to id tp body) -> ((from, to, id, tp), body)) +iqP = xpWrap (\((from, to, qid, tp),body) -> IQ from to qid tp body) + (\(IQ from to qid tp body) -> ((from, to, qid, tp), body)) $ xpElem "{jabber:client}iq" (xp4Tuple diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 4449b8d..dac363a 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -3,32 +3,19 @@ module Network.XMPP.Monad where import Control.Applicative((<$>)) - -import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Resource import Control.Monad.Trans.State import Data.ByteString as BS -import Data.Default(def) -import Data.Text(Text) - import Data.Conduit import Data.Conduit.Binary as CB --- import Data.Conduit.Hexpat as CH import Data.Conduit.List as CL -import Data.Conduit.Text as CT import Data.Conduit.TLS - +import Data.Text(Text) import Data.XML.Pickle import Data.XML.Types -import Text.XML.Stream.Parse as XP -import Text.XML.Stream.Render as XR -import Text.XML.Stream.Elements - - -import qualified Data.Text as Text import Network.XMPP.Types import Network.XMPP.Marshal @@ -36,6 +23,11 @@ import Network.XMPP.Pickle import System.IO +import Text.XML.Stream.Elements +import Text.XML.Stream.Parse as XP +import Text.XML.Stream.Render as XR + + pushN :: Element -> XMPPMonad () pushN x = do sink <- gets sConPush @@ -70,7 +62,7 @@ xmppFromHandle :: Handle -> Text -> Text -> Maybe Text -> XMPPMonad a -> IO (a, XMPPState) -xmppFromHandle handle hostname username resource f = runResourceT $ do +xmppFromHandle handle hostname username res f = runResourceT $ do liftIO $ hSetBuffering handle NoBuffering let raw = CB.sourceHandle handle $= conduitStdout let src = raw $= XP.parseBytes def @@ -85,6 +77,6 @@ xmppFromHandle handle hostname username resource f = runResourceT $ do False hostname username - resource + res runStateT f st diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index 37ef35c..4260086 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -7,20 +7,11 @@ module Network.XMPP.Pickle where -import Control.Applicative((<$>)) - -import qualified Data.ByteString as BS - -import qualified Data.Text as Text -import Data.Text.Encoding as Text - import Data.XML.Types import Data.XML.Pickle -import Network.XMPP.Types - - +mbToBool :: Maybe t -> Bool mbToBool (Just _) = True mbToBool _ = False @@ -38,8 +29,8 @@ xpElemEmpty name = xpWrap (\((),()) -> ()) xpNodeElem :: PU [Node] a -> PU Element a xpNodeElem xp = PU { pickleTree = \x -> head $ (pickleTree xp x) >>= \y -> case y of - NodeContent _ -> [] NodeElement e -> [e] + _ -> [] , unpickleTree = \x -> case unpickleTree xp $ [NodeElement x] of Left l -> Left l Right (a,(_,c)) -> Right (a,(Nothing,c)) @@ -48,12 +39,15 @@ xpNodeElem xp = PU { pickleTree = \x -> head $ (pickleTree xp x) >>= \y -> ignoreAttrs :: PU t ((), b) -> PU t b ignoreAttrs = xpWrap snd ((),) +mbl :: Maybe [a] -> [a] mbl (Just l) = l mbl Nothing = [] +lmb :: [t] -> Maybe [t] lmb [] = Nothing lmb x = Just x +right :: Either [Char] t -> t right (Left l) = error l right (Right r) = r diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 71b00b8..db91276 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -1,38 +1,31 @@ {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} module Network.XMPP.SASL where -import Control.Applicative -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.State +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.State import qualified Crypto.Classes as CC import qualified Data.Attoparsec.ByteString.Char8 as AP import qualified Data.Binary as Binary import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BL8 -import qualified Data.ByteString.Base64 as B64 -import qualified Data.List as L import qualified Data.Digest.Pure.MD5 as MD5 -import Data.List -import Data.XML.Pickle -import Data.XML.Types +import qualified Data.List as L +import Data.XML.Pickle +import Data.XML.Types import qualified Data.Text as Text -import Data.Text(Text) -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text.Encoding as Text -import Network.XMPP.Monad -import Network.XMPP.Pickle -import Network.XMPP.Stream -import Network.XMPP.Types - -import Numeric +import Network.XMPP.Monad +import Network.XMPP.Stream +import Network.XMPP.Types import qualified System.Random as Random @@ -66,7 +59,7 @@ xmppSASL passwd = do challenge2 <- pullPickle (xpEither failurePickle challengePickle) case challenge2 of Left x -> error $ show x - Right c -> return () + Right _ -> return () pushN saslResponse2E Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pullE xmppRestartStream @@ -111,7 +104,7 @@ toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)] toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do AP.skipSpace name <- AP.takeWhile1 (/= '=') - AP.char '=' + _ <- AP.char '=' quote <- ((AP.char '"' >> return True) `mplus` return False) content <- AP.takeWhile1 (AP.notInClass ",\"" ) when quote . void $ AP.char '"' @@ -125,8 +118,20 @@ hashRaw :: [BS8.ByteString] -> BS8.ByteString hashRaw = toStrict . Binary.encode . (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":") +toStrict :: BL.ByteString -> BS8.ByteString toStrict = BS.concat . BL.toChunks + -- TODO: this only handles MD5-sess + +md5Digest :: BS8.ByteString + -> BS8.ByteString + -> BS8.ByteString + -> BS8.ByteString + -> BS8.ByteString + -> BS8.ByteString + -> BS8.ByteString + -> BS8.ByteString + -> BS8.ByteString md5Digest uname realm password digestURI nc qop nonce cnonce= let ha1 = hash [hashRaw [uname,realm,password], nonce, cnonce] ha2 = hash ["AUTHENTICATE", digestURI] diff --git a/src/Network/XMPP/Session.hs b/src/Network/XMPP/Session.hs index fe8a696..a9b5e1c 100644 --- a/src/Network/XMPP/Session.hs +++ b/src/Network/XMPP/Session.hs @@ -2,18 +2,11 @@ module Network.XMPP.Session where -import Control.Monad.Trans.State - -import Data.Text as Text - import Data.XML.Pickle -import Data.XML.Types import Network.XMPP.Monad -import Network.XMPP.Types import Network.XMPP.Pickle -import Network.XMPP.Marshal - +import Network.XMPP.Types sessionIQ :: Stanza sessionIQ = SIQ $ IQ Nothing Nothing "sess" Set @@ -26,5 +19,5 @@ xmppSession :: XMPPMonad () xmppSession = do push $ sessionIQ answer <- pull - let SIQ (IQ Nothing Nothing "sess" Result b) = answer + let SIQ (IQ Nothing Nothing "sess" Result _body) = answer return () \ No newline at end of file diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index 3bf5e98..1f4f285 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -3,33 +3,26 @@ module Network.XMPP.Stream where -import Control.Applicative((<$>)) -import Control.Monad(unless, forever) -import Control.Monad.Trans.Class -import Control.Monad.Trans.State -import Control.Monad.IO.Class - -import Network.XMPP.Monad -import Network.XMPP.Pickle -import Network.XMPP.Types - -import Data.Conduit -import Data.Default(def) --- import qualified Data.Conduit.Hexpat as CH -import Data.Conduit.List as CL -import Data.Conduit.Text as CT -import Data.Default(def) -import qualified Data.List as L -import Data.Text as T -import Data.XML.Pickle -import Data.XML.Types - --- import qualified Text.XML.Stream.Parse as XP -import Text.XML.Stream.Elements -import Text.XML.Stream.Parse as XP +import Control.Applicative((<$>)) +import Control.Monad(unless) +import Control.Monad.Trans.State + +import Data.Conduit +import Data.Conduit.List as CL +import Data.Text as T +import Data.XML.Pickle +import Data.XML.Types + +import Network.XMPP.Monad +import Network.XMPP.Pickle +import Network.XMPP.Types + +import Text.XML.Stream.Elements +import Text.XML.Stream.Parse as XP -- import Text.XML.Stream.Elements +throwOutJunk :: Monad m => Sink Event m () throwOutJunk = do next <- CL.peek case next of @@ -37,6 +30,7 @@ throwOutJunk = do Just (EventBeginElement _ _) -> return () _ -> CL.drop 1 >> throwOutJunk +openElementFromEvents :: Monad m => Sink Event m Element openElementFromEvents = do throwOutJunk Just (EventBeginElement name attrs) <- CL.head @@ -54,7 +48,6 @@ xmppStartStream = do xmppRestartStream :: XMPPMonad () xmppRestartStream = do raw <- gets sRawSrc - src <- gets sConSrc let newsrc = raw $= XP.parseBytes def modify (\s -> s{sConSrc = newsrc}) xmppStartStream diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index c71338d..fde5633 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -2,25 +2,19 @@ module Network.XMPP.TLS where -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Resource -import Control.Monad.Trans.State - -import Data.Default -import Data.Text(Text) -import Data.XML.Types - -import Network.XMPP.Monad -import Network.XMPP.Stream -import Network.XMPP.Types - -import Data.Conduit -import Data.Conduit.Text as CT -import Data.Conduit.TLS as TLS -import Data.Conduit.List as CL -import qualified Data.List as L +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.State + +import Data.Conduit +import Data.Conduit.List as CL +import Data.Conduit.TLS as TLS +import Data.Default +import Data.XML.Types + +import Network.XMPP.Monad +import Network.XMPP.Stream +import Network.XMPP.Types import qualified Text.XML.Stream.Render as XR @@ -40,14 +34,14 @@ xmppStartTLS params = do pushN starttlsE Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pullE Just handle <- gets sConHandle - (raw, snk, push) <- lift $ TLS.tlsinit params handle + (raw, snk, psh) <- lift $ TLS.tlsinit params handle modify (\x -> x { sRawSrc = raw -- , sConSrc = -- Note: this momentarily leaves us in an -- inconsistent state , sConPush = \xs -> CL.sourceList xs $$ XR.renderBytes def =$ snk - , sConPushBS = push + , sConPushBS = psh }) xmppRestartStream modify (\s -> s{sHaveTLS = True}) From 7f22610d7c5284f4413fd5a888cb1a593f849559 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 5 Apr 2012 20:49:40 +0200 Subject: [PATCH 20/26] fixed IQ handling --- src/Example.hs | 5 ++-- src/Network/XMPP/Bind.hs | 26 ++++++++++++++---- src/Network/XMPP/Concurrent.hs | 50 ++++++++++++++++++---------------- 3 files changed, 50 insertions(+), 31 deletions(-) diff --git a/src/Example.hs b/src/Example.hs index c17b738..916ceb2 100644 --- a/src/Example.hs +++ b/src/Example.hs @@ -38,9 +38,10 @@ mirror = forever $ do main :: IO () main = do sessionConnect "localhost" "species64739.dyndns.org" "bot" Nothing $ do - singleThreaded $ xmppStartTLS exampleParams +-- singleThreaded $ xmppStartTLS exampleParams singleThreaded $ xmppSASL "pwd" - singleThreaded $ xmppBind (Just "botsi") + xmppThreadedBind (Just "botsi") +-- singleThreaded $ xmppBind (Just "botsi") singleThreaded $ xmppSession forkXMPP autoAccept forkXMPP mirror diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index 1434e79..e8610df 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -12,15 +12,18 @@ import Data.XML.Types import Network.XMPP.Monad import Network.XMPP.Types import Network.XMPP.Pickle +import Network.XMPP.Concurrent +import Control.Monad.IO.Class + +bindBody :: Maybe Text -> Element +bindBody rsrc = (pickleElem + (bindP . xpOption $ xpElemNodes "resource" (xpContent xpId)) + rsrc + ) bindReqIQ :: Maybe Text -> Stanza -bindReqIQ rsrc= SIQ $ IQ Nothing Nothing "bind" Set - (pickleElem - (bindP . xpOption - $ xpElemNodes "resource" (xpContent xpId)) - rsrc - ) +bindReqIQ rsrc= SIQ $ IQ Nothing Nothing "bind" Set (bindBody rsrc) jidP :: PU [Node] JID jidP = bindP $ xpElemNodes "jid" (xpContent xpPrim) @@ -37,3 +40,14 @@ bindP :: PU [Node] b -> PU [Node] b bindP c = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-bind}bind" c +xmppThreadedBind :: Maybe Text -> XMPPThread Text +xmppThreadedBind rsrc = do + liftIO $ putStrLn "bind..." + answer <- sendIQ' Nothing Set (bindBody rsrc) + liftIO . putStrLn $ "Answer: " ++ show answer + let (IQ Nothing Nothing _ Result b) = answer + let (JID _n _d (Just r)) = unpickleElem jidP b + return r + + + diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs index 9c9299b..595d154 100644 --- a/src/Network/XMPP/Concurrent.hs +++ b/src/Network/XMPP/Concurrent.hs @@ -27,6 +27,7 @@ import qualified Data.Conduit.List as CL import Data.Default (def) import Data.IORef import qualified Data.Map as Map +import Data.Maybe import qualified Data.Text as Text import Data.Text(Text) import Data.Typeable @@ -78,7 +79,6 @@ readWorker messageC presenceC iqC s = Ex.catch (forever . flip runStateT s $ do return () SIQ i -> liftIO . atomically $ do writeTChan iqC i - _ <-readTChan iqC return () ) ( \(ReaderSignal a) -> do @@ -96,29 +96,26 @@ writeWorker stCh writeR = forever $ do _ <- forM outBS write atomically $ putTMVar writeR write - handleIQs :: MonadIO m => TVar IQHandlers -> TChan IQ -> m a handleIQs handlers iqC = liftIO . forever . atomically $ do iq <- readTChan iqC (byNS, byID) <- readTVar handlers - let iqNS' = nameNamespace . elementName . iqBody $ iq - case iqNS' of - Nothing -> return () -- TODO: send error stanza - Just iqNS -> case iqType iq of - Get -> case Map.lookup (Get, iqNS) byNS of - Nothing -> return () -- TODO: send error stanza - Just ch -> writeTChan ch iq - Set -> case Map.lookup (Set, iqNS) byNS of - Nothing -> return () -- TODO: send error stanza - Just ch -> writeTChan ch iq - -- Result / Error : - _ -> case Map.updateLookupWithKey (\_ _ -> Nothing) - (iqId iq) byID of - (Nothing, _) -> return () -- we are not supposed - -- to send an error - (Just tmvar, byID') -> do - _ <- tryPutTMVar tmvar iq -- don't block - writeTVar handlers (byNS, byID') + let iqNS = fromMaybe ("") (nameNamespace . elementName . iqBody $ iq) + case iqType iq of + Get -> case Map.lookup (Get, iqNS) byNS of + Nothing -> return () -- TODO: send error stanza + Just ch -> writeTChan ch iq + Set -> case Map.lookup (Set, iqNS) byNS of + Nothing -> return () -- TODO: send error stanza + Just ch -> writeTChan ch iq + -- Result / Error : + _ -> case Map.updateLookupWithKey (\_ _ -> Nothing) + (iqId iq) byID of + (Nothing, _) -> return () -- we are not supposed + -- to send an error + (Just tmvar, byID') -> do + _ <- tryPutTMVar tmvar iq -- don't block + writeTVar handlers (byNS, byID') @@ -313,7 +310,10 @@ singleThreaded a = do -- | Sends an IQ, returns a 'TMVar' that will be filled with the first inbound -- IQ with a matching ID that has type @result@ or @error@ -sendIQ :: JID -> IQType -> Element -> XMPPThread (TMVar IQ) +sendIQ :: Maybe JID -- ^ Recipient (to) + -> IQType -- ^ IQ type (Get or Set) + -> Element -- ^ The iq body (there has to be exactly one) + -> XMPPThread (TMVar IQ) sendIQ to tp body = do -- TODO: add timeout newId <- liftIO =<< asks idGenerator handlers <- asks iqHandlers @@ -323,7 +323,11 @@ sendIQ to tp body = do -- TODO: add timeout writeTVar handlers (byNS, Map.insert newId resRef byId) -- TODO: Check for id collisions (shouldn't happen?) return resRef - sendS . SIQ $ IQ Nothing (Just to) newId tp body + sendS . SIQ $ IQ Nothing (to) newId tp body return ref - +-- | like 'sendIQ', but waits for the answer IQ +sendIQ' :: Maybe JID -> IQType -> Element -> XMPPThread IQ +sendIQ' to tp body = do + ref <- sendIQ to tp body + liftIO . atomically $ takeTMVar ref \ No newline at end of file From 4e5dc2e31ed46ad1fccc8adc06d7ced14abf589b Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sat, 7 Apr 2012 17:08:39 +0200 Subject: [PATCH 21/26] added test client added IQ answering mechanism improved error reporting un unpickling failures (will show offending element) general cleanups --- src/Data/Conduit/TLS.hs | 13 +--- src/Network/XMPP/Bind.hs | 2 - src/Network/XMPP/Concurrent.hs | 56 ++++++++------- src/Network/XMPP/Monad.hs | 5 +- src/Network/XMPP/Pickle.hs | 4 +- src/Network/XMPP/Types.hs | 14 ++-- src/Tests.hs | 121 +++++++++++++++++++++++++++++++++ 7 files changed, 167 insertions(+), 48 deletions(-) create mode 100644 src/Tests.hs diff --git a/src/Data/Conduit/TLS.hs b/src/Data/Conduit/TLS.hs index 61aeb5e..141eeb0 100644 --- a/src/Data/Conduit/TLS.hs +++ b/src/Data/Conduit/TLS.hs @@ -1,7 +1,7 @@ {-# Language NoMonomorphismRestriction #-} module Data.Conduit.TLS ( tlsinit - , conduitStdout +-- , conduitStdout , module TLS , module TLSExtra ) @@ -50,14 +50,3 @@ tlsinit tlsParams handle = do , snk , \s -> sendData clientContext $ BL.fromChunks [s] ) --- TODO: remove - -conduitStdout - :: MonadResource m => Conduit BS.ByteString m BS.ByteString -conduitStdout = conduitIO - (return ()) - (\_ -> return ()) - (\_ bs -> do - liftIO $ BS.putStrLn bs - return $ IOProducing [bs]) - (const $ return []) \ No newline at end of file diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index e8610df..10cdf60 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -42,9 +42,7 @@ bindP c = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-bind}bind" c xmppThreadedBind :: Maybe Text -> XMPPThread Text xmppThreadedBind rsrc = do - liftIO $ putStrLn "bind..." answer <- sendIQ' Nothing Set (bindBody rsrc) - liftIO . putStrLn $ "Answer: " ++ show answer let (IQ Nothing Nothing _ Result b) = answer let (JID _n _d (Just r)) = unpickleElem jidP b return r diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs index 595d154..cd1cf74 100644 --- a/src/Network/XMPP/Concurrent.hs +++ b/src/Network/XMPP/Concurrent.hs @@ -41,7 +41,9 @@ import Network.XMPP.Pickle import Text.XML.Stream.Elements import qualified Text.XML.Stream.Render as XR -type IQHandlers = (Map.Map (IQType, Text) (TChan IQ), Map.Map Text (TMVar IQ)) +type IQHandlers = (Map.Map (IQType, Text) (TChan (IQ, TVar Bool)) + , Map.Map Text (TMVar IQ) + ) data Thread = Thread { messagesRef :: IORef (Maybe (TChan Message)) , presenceRef :: IORef (Maybe (TChan Presence)) @@ -101,21 +103,19 @@ handleIQs handlers iqC = liftIO . forever . atomically $ do iq <- readTChan iqC (byNS, byID) <- readTVar handlers let iqNS = fromMaybe ("") (nameNamespace . elementName . iqBody $ iq) - case iqType iq of - Get -> case Map.lookup (Get, iqNS) byNS of - Nothing -> return () -- TODO: send error stanza - Just ch -> writeTChan ch iq - Set -> case Map.lookup (Set, iqNS) byNS of - Nothing -> return () -- TODO: send error stanza - Just ch -> writeTChan ch iq - -- Result / Error : - _ -> case Map.updateLookupWithKey (\_ _ -> Nothing) - (iqId iq) byID of - (Nothing, _) -> return () -- we are not supposed - -- to send an error - (Just tmvar, byID') -> do - _ <- tryPutTMVar tmvar iq -- don't block - writeTVar handlers (byNS, byID') + case () of () | (iqType iq) `elem` [Get, Set] -> + case Map.lookup (Get, iqNS) byNS of + Nothing -> return () -- TODO: send error stanza + Just ch -> do + sent <- newTVar False + writeTChan ch (iq, sent) + | otherwise -> case Map.updateLookupWithKey (\_ _ -> Nothing) + (iqId iq) byID of + (Nothing, _) -> return () -- we are not supposed + -- to send an error + (Just tmvar, byID') -> do + _ <- tryPutTMVar tmvar iq -- don't block + writeTVar handlers (byNS, byID') @@ -126,9 +126,7 @@ handleIQs handlers iqC = liftIO . forever . atomically $ do startThreads :: XMPPMonad ( TChan Message , TChan Presence - , TVar ( Map.Map (IQType, Text) (TChan IQ) - , Map.Map Text (TMVar IQ) - ) + , TVar IQHandlers , TChan Stanza, IO () , TMVar (BS.ByteString -> IO ()) , ThreadId @@ -161,7 +159,7 @@ startThreads = do -- them listenIQChan :: IQType -- ^ type of IQs to receive (Get / Set) -> Text -- ^ namespace of the child element - -> XMPPThread (Bool, TChan IQ) + -> XMPPThread (Bool, TChan (IQ, TVar Bool)) listenIQChan tp ns = do handlers <- asks iqHandlers liftIO . atomically $ do @@ -171,8 +169,8 @@ listenIQChan tp ns = do (tp,ns) iqCh byNS writeTVar handlers (byNS', byID) return $ case present of - Nothing -> (False, iqCh) - Just iqCh' -> (True, iqCh') + Nothing -> (True, iqCh) + Just iqCh' -> (False, iqCh') -- | Start worker threads and run action. The supplied action will run -- in the calling thread. use 'forkXMPP' to start another thread. @@ -330,4 +328,16 @@ sendIQ to tp body = do -- TODO: add timeout sendIQ' :: Maybe JID -> IQType -> Element -> XMPPThread IQ sendIQ' to tp body = do ref <- sendIQ to tp body - liftIO . atomically $ takeTMVar ref \ No newline at end of file + liftIO . atomically $ takeTMVar ref + +answerIQ :: MonadIO m => (IQ, TVar Bool) -> Element -> ReaderT Thread m Bool +answerIQ ((IQ from _to id _tp _bd), sentRef) body = do + out <- asks outCh + liftIO . atomically $ do + sent <- readTVar sentRef + case sent of + False -> do + writeTVar sentRef True + writeTChan out . SIQ $ IQ Nothing from id Result body + return True + True -> return False diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index dac363a..5e1631a 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -12,7 +12,6 @@ import Data.ByteString as BS import Data.Conduit import Data.Conduit.Binary as CB import Data.Conduit.List as CL -import Data.Conduit.TLS import Data.Text(Text) import Data.XML.Pickle import Data.XML.Types @@ -64,13 +63,13 @@ xmppFromHandle -> IO (a, XMPPState) xmppFromHandle handle hostname username res f = runResourceT $ do liftIO $ hSetBuffering handle NoBuffering - let raw = CB.sourceHandle handle $= conduitStdout + let raw = CB.sourceHandle handle let src = raw $= XP.parseBytes def let st = XMPPState src (raw) (\xs -> CL.sourceList xs - $$ XR.renderBytes def =$ conduitStdout =$ CB.sinkHandle handle) + $$ XR.renderBytes def =$ CB.sinkHandle handle) (BS.hPut handle) (Just handle) def diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index 4260086..c1b15c9 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -53,7 +53,9 @@ right (Right r) = r unpickleElem :: PU [Node] c -> Element -> c -unpickleElem p = right . unpickle (xpNodeElem p) +unpickleElem p x = case unpickle (xpNodeElem p) x of + Left l -> error $ l ++ "\n saw: " ++ show x + Right r -> r pickleElem :: PU [Node] a -> a -> Element pickleElem p = pickle $ xpNodeElem p diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index f4a5eeb..205454a 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -1,17 +1,17 @@ module Network.XMPP.Types where -- proudly "borrowed" from haskell-xmpp -import Control.Monad.Trans.State +import Control.Monad.Trans.State import qualified Data.ByteString as BS -import Data.Conduit -import Data.Default -import Data.List.Split as L -import Data.Text as Text +import Data.Conduit +import Data.Default +import Data.List.Split as L +import Data.Text as Text -import Data.XML.Types +import Data.XML.Types -import System.IO +import System.IO -- | Jabber ID (JID) datatype data JID = JID { node :: Maybe Text diff --git a/src/Tests.hs b/src/Tests.hs new file mode 100644 index 0000000..f18c6b9 --- /dev/null +++ b/src/Tests.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE PackageImports, OverloadedStrings #-} +module Example where + +import Network.XMPP +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.IO.Class + +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as Text +import Data.XML.Pickle +import Data.XML.Types + +import Network.XMPP.Pickle + +import System.Environment + +testUser1 :: JID +testUser1 = read "testuser1@species64739.dyndns.org/bot1" + +testUser2 :: JID +testUser2 = read "testuser2@species64739.dyndns.org/bot2" + +superviser :: JID +superviser = read "uart14@species64739.dyndns.org" + + +attXmpp :: STM a -> XMPPThread a +attXmpp = liftIO . atomically + +testNS :: Text +testNS = "xmpp:library:test" + +data Payload = Payload Int Bool Text deriving (Eq, Show) + +payloadP = xpWrap (\((counter,flag) , message) -> Payload counter flag message) + (\(Payload counter flag message) ->((counter,flag) , message)) $ + xpElem (Name "request" (Just testNS) Nothing) + (xpPair + (xpAttr "counter" xpPrim) + (xpAttr "flag" xpPrim) + ) + (xpElemNodes (Name "message" (Just testNS) Nothing) + (xpContent xpId)) + +invertPayload (Payload count flag message) = Payload (count + 1) (not flag) (Text.reverse message) + +iqResponder = do + (free, chan) <- listenIQChan Get testNS + unless free $ liftIO $ putStrLn "Channel was already taken" + >> error "hanging up" + forever $ do + next@(iq,_) <- liftIO . atomically $ readTChan chan + let payload = unpickleElem payloadP $ iqBody iq + let answerPayload = invertPayload payload + let answerBody = pickleElem payloadP answerPayload + answerIQ next answerBody + +autoAccept :: XMPPThread () +autoAccept = forever $ do + st <- pullPresence + case st of + Presence from _ idq (Just Subscribe) _ _ _ _ -> + sendS . SPresence $ + Presence Nothing from idq (Just Subscribed) Nothing Nothing Nothing [] + _ -> return () + +sendUser txt = sendS . SMessage $ Message Nothing superviser Nothing Nothing Nothing + (Just (Text.pack txt)) Nothing [] + + +expect debug x y | x == y = debug "Ok." + | otherwise = do + let failMSG = "failed" ++ show x ++ " /= " ++ show y + debug failMSG + sendUser failMSG + + + +runMain :: (String -> STM ()) -> Int -> IO () +runMain debug number = do + let (we, them, active) = case number of + 1 -> (testUser1, testUser2,True) + 2 -> (testUser2, testUser1,False) + _ -> error "Need either 1 or 2" + sessionConnect "localhost" + "species64739.dyndns.org" + (fromJust $ node we) (resource we) $ do + let debug' = liftIO . atomically . debug . + (("Thread " ++ show number ++ ":") ++) + singleThreaded $ xmppSASL "pwd" + xmppThreadedBind (resource we) + singleThreaded $ xmppSession + sendS . SPresence $ Presence Nothing Nothing Nothing Nothing (Just Available) Nothing Nothing [] + forkXMPP autoAccept + forkXMPP iqResponder + -- sendS . SPresence $ Presence Nothing (Just them) Nothing (Just Subscribe) Nothing Nothing Nothing [] + let delay = if active then 1000000 else 5000000 + when active . void . forkXMPP . void . forM [1..10] $ \count -> do + let message = Text.pack . show $ node we + let payload = Payload count (even count) (Text.pack $ show count) + let body = pickleElem payloadP payload + answer <- sendIQ' (Just them) Get body + let answerPayload = unpickleElem payloadP (iqBody answer) + expect debug' (invertPayload payload) answerPayload + liftIO $ threadDelay delay + sendUser "All tests done" + liftIO . forever $ threadDelay 10000000 + return () + return () + + +main = do + out <- newTChanIO + forkIO . forever $ atomically (readTChan out) >>= putStrLn + let debugOut = writeTChan out + forkIO $ runMain debugOut 1 + runMain debugOut 2 + From bcd67d306eaf0fdb35e2e64452b8afb4de200354 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 8 Apr 2012 00:35:20 +0200 Subject: [PATCH 22/26] split Concurrent --- src/Data/Conduit/TLS.hs | 6 +- src/Network/XMPP/Bind.hs | 2 - src/Network/XMPP/Concurrent.hs | 343 +------------------------ src/Network/XMPP/Concurrent/IQ.hs | 48 ++++ src/Network/XMPP/Concurrent/Monad.hs | 143 +++++++++++ src/Network/XMPP/Concurrent/Threads.hs | 147 +++++++++++ src/Network/XMPP/Concurrent/Types.hs | 40 +++ 7 files changed, 388 insertions(+), 341 deletions(-) create mode 100644 src/Network/XMPP/Concurrent/IQ.hs create mode 100644 src/Network/XMPP/Concurrent/Monad.hs create mode 100644 src/Network/XMPP/Concurrent/Threads.hs create mode 100644 src/Network/XMPP/Concurrent/Types.hs diff --git a/src/Data/Conduit/TLS.hs b/src/Data/Conduit/TLS.hs index 141eeb0..bf2adf1 100644 --- a/src/Data/Conduit/TLS.hs +++ b/src/Data/Conduit/TLS.hs @@ -9,7 +9,6 @@ module Data.Conduit.TLS import Control.Applicative import Control.Monad.IO.Class -import Control.Monad.Trans.Class import Control.Monad.Trans.Resource import Crypto.Random @@ -22,9 +21,6 @@ import Network.TLS as TLS import Network.TLS.Extra as TLSExtra import System.IO(Handle) -import System.Random - -import System.IO tlsinit :: (MonadIO m, MonadIO m1, MonadResource m1) => @@ -43,7 +39,7 @@ tlsinit tlsParams handle = do let snk = sinkIO (return clientContext) (\_ -> return ()) - (\con bs -> sendData clientContext (BL.fromChunks [bs]) + (\con bs -> sendData con (BL.fromChunks [bs]) >> return IOProcessing ) (\_ -> return ()) return ( src diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index 10cdf60..7f198d4 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -14,8 +14,6 @@ import Network.XMPP.Types import Network.XMPP.Pickle import Network.XMPP.Concurrent -import Control.Monad.IO.Class - bindBody :: Maybe Text -> Element bindBody rsrc = (pickleElem (bindP . xpOption $ xpElemNodes "resource" (xpContent xpId)) diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs index cd1cf74..19f4ef7 100644 --- a/src/Network/XMPP/Concurrent.hs +++ b/src/Network/XMPP/Concurrent.hs @@ -1,343 +1,18 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoMonomorphismRestriction #-} - - module Network.XMPP.Concurrent - where - --- import Network.XMPP.Stream -import Network.XMPP.Types - -import Control.Applicative((<$>),(<*>)) -import Control.Concurrent -import Control.Concurrent.STM -import qualified Control.Exception.Lifted as Ex -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Resource -import Control.Monad.Trans.State - -import qualified Data.ByteString as BS -import Data.Conduit -import qualified Data.Conduit.List as CL -import Data.Default (def) -import Data.IORef -import qualified Data.Map as Map -import Data.Maybe -import qualified Data.Text as Text -import Data.Text(Text) -import Data.Typeable - -import Data.XML.Types - -import Network.XMPP.Monad -import Network.XMPP.Marshal -import Network.XMPP.Pickle - -import Text.XML.Stream.Elements -import qualified Text.XML.Stream.Render as XR - -type IQHandlers = (Map.Map (IQType, Text) (TChan (IQ, TVar Bool)) - , Map.Map Text (TMVar IQ) - ) - -data Thread = Thread { messagesRef :: IORef (Maybe (TChan Message)) - , presenceRef :: IORef (Maybe (TChan Presence)) - , mShadow :: TChan Message -- the original chan - , pShadow :: TChan Presence -- the original chan - , outCh :: TChan Stanza - , iqHandlers :: TVar IQHandlers - , writeRef :: TMVar (BS.ByteString -> IO () ) - , readerThread :: ThreadId - , idGenerator :: IO Text - } - -type XMPPThread a = ReaderT Thread IO a - - -data ReaderSignal = ReaderSignal (XMPPMonad ()) deriving Typeable -instance Show ReaderSignal where show _ = "" -instance Ex.Exception ReaderSignal - -readWorker :: TChan Message -> TChan Presence -> TChan IQ -> XMPPState -> ResourceT IO () -readWorker messageC presenceC iqC s = Ex.catch (forever . flip runStateT s $ do - sta <- pull - case sta of - SMessage m -> liftIO . atomically $ do - writeTChan messageC m - _ <- readTChan messageC -- Sic! - return () - -- this may seem ridiculous, but to prevent - -- the channel from filling up we immedtiately remove the - -- Stanza we just put in. It will still be - -- available in duplicates. - SPresence p -> liftIO . atomically $ do - writeTChan presenceC p - _ <- readTChan presenceC - return () - SIQ i -> liftIO . atomically $ do - writeTChan iqC i - return () - ) - ( \(ReaderSignal a) -> do - ((),s') <- runStateT a s - readWorker messageC presenceC iqC s' - ) - -writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO ()) -> IO () -writeWorker stCh writeR = forever $ do - (write, next) <- atomically $ (,) <$> - takeTMVar writeR <*> - readTChan stCh - outBS <- CL.sourceList (elementToEvents $ pickleElem stanzaP next) - $= XR.renderBytes def $$ CL.consume - _ <- forM outBS write - atomically $ putTMVar writeR write - -handleIQs :: MonadIO m => TVar IQHandlers -> TChan IQ -> m a -handleIQs handlers iqC = liftIO . forever . atomically $ do - iq <- readTChan iqC - (byNS, byID) <- readTVar handlers - let iqNS = fromMaybe ("") (nameNamespace . elementName . iqBody $ iq) - case () of () | (iqType iq) `elem` [Get, Set] -> - case Map.lookup (Get, iqNS) byNS of - Nothing -> return () -- TODO: send error stanza - Just ch -> do - sent <- newTVar False - writeTChan ch (iq, sent) - | otherwise -> case Map.updateLookupWithKey (\_ _ -> Nothing) - (iqId iq) byID of - (Nothing, _) -> return () -- we are not supposed - -- to send an error - (Just tmvar, byID') -> do - _ <- tryPutTMVar tmvar iq -- don't block - writeTVar handlers (byNS, byID') - - - --- Two streams: input and output. Threads read from input stream and write to output stream. --- | Runs thread in XmppState monad --- returns channel of incoming and outgoing stances, respectively --- and an Action to stop the Threads and close the connection -startThreads - :: XMPPMonad ( TChan Message - , TChan Presence - , TVar IQHandlers - , TChan Stanza, IO () - , TMVar (BS.ByteString -> IO ()) - , ThreadId - ) - - -startThreads = do - writeLock <- liftIO . newTMVarIO =<< gets sConPushBS - messageC <- liftIO newTChanIO - presenceC <- liftIO newTChanIO - iqC <- liftIO newTChanIO - outC <- liftIO newTChanIO - handlers <- liftIO $ newTVarIO ( Map.empty, Map.empty) - lw <- liftIO . forkIO $ writeWorker outC writeLock - cp <- liftIO . forkIO $ connPersist writeLock - iqh <- liftIO . forkIO $ handleIQs handlers iqC - s <- get - rd <- lift . resourceForkIO $ readWorker messageC presenceC iqC s - return (messageC, presenceC, handlers, outC, killConnection writeLock [lw, rd, cp, iqh], writeLock, rd) - where - killConnection writeLock threads = liftIO $ do - _ <- atomically $ takeTMVar writeLock -- Should we put it back? - _ <- forM threads killThread - return() - - --- | Register a new IQ listener. IQ matching the type and namespace will --- be put in the channel. IQ of type Result and Error will never be put --- into channels, even though this function won't stop you from registering --- them -listenIQChan :: IQType -- ^ type of IQs to receive (Get / Set) - -> Text -- ^ namespace of the child element - -> XMPPThread (Bool, TChan (IQ, TVar Bool)) -listenIQChan tp ns = do - handlers <- asks iqHandlers - liftIO . atomically $ do - (byNS, byID) <- readTVar handlers - iqCh <- newTChan - let (present, byNS') = Map.insertLookupWithKey' (\_ new _ -> new) - (tp,ns) iqCh byNS - writeTVar handlers (byNS', byID) - return $ case present of - Nothing -> (True, iqCh) - Just iqCh' -> (False, iqCh') - --- | Start worker threads and run action. The supplied action will run --- in the calling thread. use 'forkXMPP' to start another thread. -runThreaded :: XMPPThread a - -> XMPPMonad a -runThreaded a = do - (mC, pC, hand, outC, _stopThreads, writeR, rdr ) <- startThreads - workermCh <- liftIO . newIORef $ Nothing - workerpCh <- liftIO . newIORef $ Nothing - idRef <- liftIO $ newTVarIO 1 - let getId = atomically $ do - curId <- readTVar idRef - writeTVar idRef (curId + 1 :: Integer) - return . Text.pack $ show curId - liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR rdr getId) - - - --- | get the inbound stanza channel, duplicates from master if necessary --- please note that once duplicated it will keep filling up, call --- 'dropMessageChan' to allow it to be garbage collected -getMessageChan :: XMPPThread (TChan Message) -getMessageChan = do - mChR <- asks messagesRef - mCh <- liftIO $ readIORef mChR - case mCh of - Nothing -> do - shadow <- asks mShadow - mCh' <- liftIO $ atomically $ dupTChan shadow - liftIO $ writeIORef mChR (Just mCh') - return mCh' - Just mCh' -> return mCh' - --- | see 'getMessageChan' -getPresenceChan :: XMPPThread (TChan Presence) -getPresenceChan = do - pChR <- asks presenceRef - pCh <- liftIO $ readIORef pChR - case pCh of - Nothing -> do - shadow <- asks pShadow - pCh' <- liftIO $ atomically $ dupTChan shadow - liftIO $ writeIORef pChR (Just pCh') - return pCh' - Just pCh' -> return pCh' - --- | Drop the local end of the inbound stanza channel --- from our context so it can be GC-ed -dropMessageChan :: XMPPThread () -dropMessageChan = do - r <- asks messagesRef - liftIO $ writeIORef r Nothing - --- | see 'dropMessageChan' -dropPresenceChan :: XMPPThread () -dropPresenceChan = do - r <- asks presenceRef - liftIO $ writeIORef r Nothing - --- | Read an element from the inbound stanza channel, acquiring a copy --- of the channel as necessary -pullMessage :: XMPPThread Message -pullMessage = do - c <- getMessageChan - st <- liftIO $ atomically $ readTChan c - return st - --- | Read an element from the inbound stanza channel, acquiring a copy --- of the channel as necessary -pullPresence :: XMPPThread Presence -pullPresence = do - c <- getPresenceChan - st <- liftIO $ atomically $ readTChan c - return st - - --- | Send a stanza to the server -sendS :: Stanza -> XMPPThread () -sendS a = do - out <- asks outCh - liftIO . atomically $ writeTChan out a - return () - --- | Fork a new thread -forkXMPP :: XMPPThread () -> XMPPThread ThreadId -forkXMPP a = do - thread <- ask - mCH' <- liftIO $ newIORef Nothing - pCH' <- liftIO $ newIORef Nothing - liftIO $ forkIO $ runReaderT a (thread {messagesRef = mCH' - ,presenceRef = pCH' - }) - -waitForMessage :: (Message -> Bool) -> XMPPThread Message -waitForMessage f = do - s <- pullMessage - if (f s) then - return s - else do - waitForMessage f +( module Network.XMPP.Concurrent.Types +, module Network.XMPP.Concurrent.Monad +, module Network.XMPP.Concurrent.Threads +, module Network.XMPP.Concurrent.IQ +) where -waitForPresence :: (Presence -> Bool) -> XMPPThread Presence -waitForPresence f = do - s <- pullPresence - if (f s) then - return s - else do - waitForPresence f +import Network.XMPP.Concurrent.Types +import Network.XMPP.Concurrent.Monad +import Network.XMPP.Concurrent.Threads +import Network.XMPP.Concurrent.IQ -connPersist :: TMVar (BS.ByteString -> IO ()) -> IO () -connPersist lock = forever $ do - pushBS <- atomically $ takeTMVar lock - pushBS " " - atomically $ putTMVar lock pushBS --- putStrLn "" - threadDelay 30000000 --- | Run an XMPPMonad action in isolation. --- Reader and writer workers will be temporarily stopped --- and resumed with the new session details once the action returns. --- The Action will run in the reader thread. -singleThreaded :: XMPPMonad () -> XMPPThread () -singleThreaded a = do - writeLock <- asks writeRef - rdr <- asks readerThread - _ <- liftIO . atomically $ takeTMVar writeLock -- we replace it with the - -- one returned by a - liftIO . throwTo rdr . ReaderSignal $ do - a - out <- gets sConPushBS - liftIO . atomically $ putTMVar writeLock out - return () --- | Sends an IQ, returns a 'TMVar' that will be filled with the first inbound --- IQ with a matching ID that has type @result@ or @error@ -sendIQ :: Maybe JID -- ^ Recipient (to) - -> IQType -- ^ IQ type (Get or Set) - -> Element -- ^ The iq body (there has to be exactly one) - -> XMPPThread (TMVar IQ) -sendIQ to tp body = do -- TODO: add timeout - newId <- liftIO =<< asks idGenerator - handlers <- asks iqHandlers - ref <- liftIO . atomically $ do - resRef <- newEmptyTMVar - (byNS, byId) <- readTVar handlers - writeTVar handlers (byNS, Map.insert newId resRef byId) - -- TODO: Check for id collisions (shouldn't happen?) - return resRef - sendS . SIQ $ IQ Nothing (to) newId tp body - return ref --- | like 'sendIQ', but waits for the answer IQ -sendIQ' :: Maybe JID -> IQType -> Element -> XMPPThread IQ -sendIQ' to tp body = do - ref <- sendIQ to tp body - liftIO . atomically $ takeTMVar ref -answerIQ :: MonadIO m => (IQ, TVar Bool) -> Element -> ReaderT Thread m Bool -answerIQ ((IQ from _to id _tp _bd), sentRef) body = do - out <- asks outCh - liftIO . atomically $ do - sent <- readTVar sentRef - case sent of - False -> do - writeTVar sentRef True - writeTChan out . SIQ $ IQ Nothing from id Result body - return True - True -> return False diff --git a/src/Network/XMPP/Concurrent/IQ.hs b/src/Network/XMPP/Concurrent/IQ.hs new file mode 100644 index 0000000..2609a14 --- /dev/null +++ b/src/Network/XMPP/Concurrent/IQ.hs @@ -0,0 +1,48 @@ +module Network.XMPP.Concurrent.IQ where + +import Control.Concurrent.STM +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader + +import Data.XML.Types +import qualified Data.Map as Map + +import Network.XMPP.Concurrent.Types +import Network.XMPP.Concurrent.Monad +import Network.XMPP.Types + +-- | Sends an IQ, returns a 'TMVar' that will be filled with the first inbound +-- IQ with a matching ID that has type @result@ or @error@ +sendIQ :: Maybe JID -- ^ Recipient (to) + -> IQType -- ^ IQ type (Get or Set) + -> Element -- ^ The iq body (there has to be exactly one) + -> XMPPThread (TMVar IQ) +sendIQ to tp body = do -- TODO: add timeout + newId <- liftIO =<< asks idGenerator + handlers <- asks iqHandlers + ref <- liftIO . atomically $ do + resRef <- newEmptyTMVar + (byNS, byId) <- readTVar handlers + writeTVar handlers (byNS, Map.insert newId resRef byId) + -- TODO: Check for id collisions (shouldn't happen?) + return resRef + sendS . SIQ $ IQ Nothing (to) newId tp body + return ref + +-- | like 'sendIQ', but waits for the answer IQ +sendIQ' :: Maybe JID -> IQType -> Element -> XMPPThread IQ +sendIQ' to tp body = do + ref <- sendIQ to tp body + liftIO . atomically $ takeTMVar ref + +answerIQ :: MonadIO m => (IQ, TVar Bool) -> Element -> ReaderT Thread m Bool +answerIQ ((IQ from _to iqid _tp _bd), sentRef) body = do + out <- asks outCh + liftIO . atomically $ do + sent <- readTVar sentRef + case sent of + False -> do + writeTVar sentRef True + writeTChan out . SIQ $ IQ Nothing from iqid Result body + return True + True -> return False diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs new file mode 100644 index 0000000..7b09cdb --- /dev/null +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -0,0 +1,143 @@ +module Network.XMPP.Concurrent.Monad where + +import Network.XMPP.Types + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State + +import Data.IORef +import qualified Data.Map as Map +import Data.Text(Text) + +import Network.XMPP.Concurrent.Types + +-- | Register a new IQ listener. IQ matching the type and namespace will +-- be put in the channel. IQ of type Result and Error will never be put +-- into channels, even though this function won't stop you from registering +-- them +listenIQChan :: IQType -- ^ type of IQs to receive (Get / Set) + -> Text -- ^ namespace of the child element + -> XMPPThread (Bool, TChan (IQ, TVar Bool)) +listenIQChan tp ns = do + handlers <- asks iqHandlers + liftIO . atomically $ do + (byNS, byID) <- readTVar handlers + iqCh <- newTChan + let (present, byNS') = Map.insertLookupWithKey' (\_ new _ -> new) + (tp,ns) iqCh byNS + writeTVar handlers (byNS', byID) + return $ case present of + Nothing -> (True, iqCh) + Just iqCh' -> (False, iqCh') + +-- | get the inbound stanza channel, duplicates from master if necessary +-- please note that once duplicated it will keep filling up, call +-- 'dropMessageChan' to allow it to be garbage collected +getMessageChan :: XMPPThread (TChan Message) +getMessageChan = do + mChR <- asks messagesRef + mCh <- liftIO $ readIORef mChR + case mCh of + Nothing -> do + shadow <- asks mShadow + mCh' <- liftIO $ atomically $ dupTChan shadow + liftIO $ writeIORef mChR (Just mCh') + return mCh' + Just mCh' -> return mCh' + +-- | see 'getMessageChan' +getPresenceChan :: XMPPThread (TChan Presence) +getPresenceChan = do + pChR <- asks presenceRef + pCh <- liftIO $ readIORef pChR + case pCh of + Nothing -> do + shadow <- asks pShadow + pCh' <- liftIO $ atomically $ dupTChan shadow + liftIO $ writeIORef pChR (Just pCh') + return pCh' + Just pCh' -> return pCh' + +-- | Drop the local end of the inbound stanza channel +-- from our context so it can be GC-ed +dropMessageChan :: XMPPThread () +dropMessageChan = do + r <- asks messagesRef + liftIO $ writeIORef r Nothing + +-- | see 'dropMessageChan' +dropPresenceChan :: XMPPThread () +dropPresenceChan = do + r <- asks presenceRef + liftIO $ writeIORef r Nothing + +-- | Read an element from the inbound stanza channel, acquiring a copy +-- of the channel as necessary +pullMessage :: XMPPThread Message +pullMessage = do + c <- getMessageChan + st <- liftIO $ atomically $ readTChan c + return st + +-- | Read an element from the inbound stanza channel, acquiring a copy +-- of the channel as necessary +pullPresence :: XMPPThread Presence +pullPresence = do + c <- getPresenceChan + st <- liftIO $ atomically $ readTChan c + return st + + +-- | Send a stanza to the server +sendS :: Stanza -> XMPPThread () +sendS a = do + out <- asks outCh + liftIO . atomically $ writeTChan out a + return () + +-- | Fork a new thread +forkXMPP :: XMPPThread () -> XMPPThread ThreadId +forkXMPP a = do + thread <- ask + mCH' <- liftIO $ newIORef Nothing + pCH' <- liftIO $ newIORef Nothing + liftIO $ forkIO $ runReaderT a (thread {messagesRef = mCH' + ,presenceRef = pCH' + }) + +waitForMessage :: (Message -> Bool) -> XMPPThread Message +waitForMessage f = do + s <- pullMessage + if (f s) then + return s + else do + waitForMessage f + +waitForPresence :: (Presence -> Bool) -> XMPPThread Presence +waitForPresence f = do + s <- pullPresence + if (f s) then + return s + else do + waitForPresence f + + +-- | Run an XMPPMonad action in isolation. +-- Reader and writer workers will be temporarily stopped +-- and resumed with the new session details once the action returns. +-- The Action will run in the reader thread. +singleThreaded :: XMPPMonad () -> XMPPThread () +singleThreaded a = do + writeLock <- asks writeRef + rdr <- asks readerThread + _ <- liftIO . atomically $ takeTMVar writeLock -- we replace it with the + -- one returned by a + liftIO . throwTo rdr . ReaderSignal $ do + a + out <- gets sConPushBS + liftIO . atomically $ putTMVar writeLock out + return () + diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs new file mode 100644 index 0000000..474b6cf --- /dev/null +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.XMPP.Concurrent.Threads where + +import Network.XMPP.Types + +import Control.Applicative((<$>),(<*>)) +import Control.Concurrent +import Control.Concurrent.STM +import qualified Control.Exception.Lifted as Ex +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Resource +import Control.Monad.Trans.State + +import qualified Data.ByteString as BS +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Default (def) +import Data.IORef +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Text as Text + +import Data.XML.Types + +import Network.XMPP.Monad +import Network.XMPP.Marshal +import Network.XMPP.Pickle +import Network.XMPP.Concurrent.Types + +import Text.XML.Stream.Elements +import qualified Text.XML.Stream.Render as XR + +readWorker :: TChan Message -> TChan Presence -> TChan IQ -> XMPPState -> ResourceT IO () +readWorker messageC presenceC iqC s = Ex.catch (forever . flip runStateT s $ do + sta <- pull + case sta of + SMessage m -> liftIO . atomically $ do + writeTChan messageC m + _ <- readTChan messageC -- Sic! + return () + -- this may seem ridiculous, but to prevent + -- the channel from filling up we immedtiately remove the + -- Stanza we just put in. It will still be + -- available in duplicates. + SPresence p -> liftIO . atomically $ do + writeTChan presenceC p + _ <- readTChan presenceC + return () + SIQ i -> liftIO . atomically $ do + writeTChan iqC i + return () + ) + ( \(ReaderSignal a) -> do + ((),s') <- runStateT a s + readWorker messageC presenceC iqC s' + ) + +writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO ()) -> IO () +writeWorker stCh writeR = forever $ do + (write, next) <- atomically $ (,) <$> + takeTMVar writeR <*> + readTChan stCh + outBS <- CL.sourceList (elementToEvents $ pickleElem stanzaP next) + $= XR.renderBytes def $$ CL.consume + _ <- forM outBS write + atomically $ putTMVar writeR write + +handleIQs :: MonadIO m => TVar IQHandlers -> TChan IQ -> m a +handleIQs handlers iqC = liftIO . forever . atomically $ do + iq <- readTChan iqC + (byNS, byID) <- readTVar handlers + let iqNS = fromMaybe ("") (nameNamespace . elementName . iqBody $ iq) + case () of () | (iqType iq) `elem` [Get, Set] -> + case Map.lookup (Get, iqNS) byNS of + Nothing -> return () -- TODO: send error stanza + Just ch -> do + sent <- newTVar False + writeTChan ch (iq, sent) + | otherwise -> case Map.updateLookupWithKey (\_ _ -> Nothing) + (iqId iq) byID of + (Nothing, _) -> return () -- we are not supposed + -- to send an error + (Just tmvar, byID') -> do + _ <- tryPutTMVar tmvar iq -- don't block + writeTVar handlers (byNS, byID') + + + +-- Two streams: input and output. Threads read from input stream and write to output stream. +-- | Runs thread in XmppState monad +-- returns channel of incoming and outgoing stances, respectively +-- and an Action to stop the Threads and close the connection +startThreads + :: XMPPMonad ( TChan Message + , TChan Presence + , TVar IQHandlers + , TChan Stanza, IO () + , TMVar (BS.ByteString -> IO ()) + , ThreadId + ) + +startThreads = do + writeLock <- liftIO . newTMVarIO =<< gets sConPushBS + messageC <- liftIO newTChanIO + presenceC <- liftIO newTChanIO + iqC <- liftIO newTChanIO + outC <- liftIO newTChanIO + handlers <- liftIO $ newTVarIO ( Map.empty, Map.empty) + lw <- liftIO . forkIO $ writeWorker outC writeLock + cp <- liftIO . forkIO $ connPersist writeLock + iqh <- liftIO . forkIO $ handleIQs handlers iqC + s <- get + rd <- lift . resourceForkIO $ readWorker messageC presenceC iqC s + return (messageC, presenceC, handlers, outC, killConnection writeLock [lw, rd, cp, iqh], writeLock, rd) + where + killConnection writeLock threads = liftIO $ do + _ <- atomically $ takeTMVar writeLock -- Should we put it back? + _ <- forM threads killThread + return() + + +-- | Start worker threads and run action. The supplied action will run +-- in the calling thread. use 'forkXMPP' to start another thread. +runThreaded :: XMPPThread a + -> XMPPMonad a +runThreaded a = do + (mC, pC, hand, outC, _stopThreads, writeR, rdr ) <- startThreads + workermCh <- liftIO . newIORef $ Nothing + workerpCh <- liftIO . newIORef $ Nothing + idRef <- liftIO $ newTVarIO 1 + let getId = atomically $ do + curId <- readTVar idRef + writeTVar idRef (curId + 1 :: Integer) + return . Text.pack $ show curId + liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR rdr getId) + +-- | Sends a blank space every 30 seconds to keep the connection alive +connPersist :: TMVar (BS.ByteString -> IO ()) -> IO () +connPersist lock = forever $ do + pushBS <- atomically $ takeTMVar lock + pushBS " " + atomically $ putTMVar lock pushBS +-- putStrLn "" + threadDelay 30000000 diff --git a/src/Network/XMPP/Concurrent/Types.hs b/src/Network/XMPP/Concurrent/Types.hs new file mode 100644 index 0000000..b848e43 --- /dev/null +++ b/src/Network/XMPP/Concurrent/Types.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Network.XMPP.Concurrent.Types where + +import qualified Control.Exception.Lifted as Ex +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad.Trans.Reader + +import qualified Data.ByteString as BS +import Data.IORef +import qualified Data.Map as Map +import Data.Text(Text) +import Data.Typeable + + +import Network.XMPP.Types + + +type IQHandlers = (Map.Map (IQType, Text) (TChan (IQ, TVar Bool)) + , Map.Map Text (TMVar IQ) + ) + +data Thread = Thread { messagesRef :: IORef (Maybe (TChan Message)) + , presenceRef :: IORef (Maybe (TChan Presence)) + , mShadow :: TChan Message -- the original chan + , pShadow :: TChan Presence -- the original chan + , outCh :: TChan Stanza + , iqHandlers :: TVar IQHandlers + , writeRef :: TMVar (BS.ByteString -> IO () ) + , readerThread :: ThreadId + , idGenerator :: IO Text + } + +type XMPPThread a = ReaderT Thread IO a + + +data ReaderSignal = ReaderSignal (XMPPMonad ()) deriving Typeable +instance Show ReaderSignal where show _ = "" +instance Ex.Exception ReaderSignal From d8abc3f9569323acc2dcc564b3f3e385eb6bcfe8 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 9 Apr 2012 16:25:20 +0200 Subject: [PATCH 23/26] added some helper functions --- src/Network/XMPP.hs | 26 +++++++------ src/Network/XMPP/Concurrent/Monad.hs | 6 ++- src/Network/XMPP/Message.hs | 15 ++++++++ src/Network/XMPP/Presence.hs | 56 ++++++++++++++++++++++++++++ src/Tests.hs | 32 +++++++--------- 5 files changed, 104 insertions(+), 31 deletions(-) create mode 100644 src/Network/XMPP/Message.hs create mode 100644 src/Network/XMPP/Presence.hs diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index 2680dbe..f24ace8 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -8,23 +8,27 @@ module Network.XMPP , module Network.XMPP.Stream , module Network.XMPP.TLS , module Network.XMPP.Types + , module Network.XMPP.Presence + , module Network.XMPP.Message , connectXMPP , sessionConnect ) where -import Data.Text as Text +import Data.Text as Text -import Network -import Network.XMPP.Bind -import Network.XMPP.Concurrent -import Network.XMPP.Monad -import Network.XMPP.SASL -import Network.XMPP.Session -import Network.XMPP.Stream -import Network.XMPP.TLS -import Network.XMPP.Types +import Network +import Network.XMPP.Bind +import Network.XMPP.Concurrent +import Network.XMPP.Message +import Network.XMPP.Monad +import Network.XMPP.Presence +import Network.XMPP.SASL +import Network.XMPP.Session +import Network.XMPP.Stream +import Network.XMPP.TLS +import Network.XMPP.Types -import System.IO +import System.IO --fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> IO ((), XMPPState) fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> XMPPThread a diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index 7b09cdb..8dd0ced 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -124,7 +124,6 @@ waitForPresence f = do else do waitForPresence f - -- | Run an XMPPMonad action in isolation. -- Reader and writer workers will be temporarily stopped -- and resumed with the new session details once the action returns. @@ -141,3 +140,8 @@ singleThreaded a = do liftIO . atomically $ putTMVar writeLock out return () +sendPresence :: Presence -> XMPPThread () +sendPresence = sendS . SPresence + +sendMessage :: Message -> XMPPThread () +sendMessage = sendS . SMessage \ No newline at end of file diff --git a/src/Network/XMPP/Message.hs b/src/Network/XMPP/Message.hs new file mode 100644 index 0000000..e2a9e17 --- /dev/null +++ b/src/Network/XMPP/Message.hs @@ -0,0 +1,15 @@ +module Network.XMPP.Message where + +import Data.Text(Text) +import Data.XML.Types + +import Network.XMPP.Types + +simpleMessage :: JID -> Text -> Message +simpleMessage to txt = + Message Nothing to Nothing Nothing Nothing (Just txt) Nothing [] + +answerMessage :: Message -> Text -> [Element] -> Maybe Message +answerMessage (Message (Just frm) _to id tp subject _txt thread _ext) txt bodies = + Just $ Message Nothing frm id tp subject (Just txt) thread bodies +answerMessage _ _ _ = Nothing \ No newline at end of file diff --git a/src/Network/XMPP/Presence.hs b/src/Network/XMPP/Presence.hs new file mode 100644 index 0000000..dc41198 --- /dev/null +++ b/src/Network/XMPP/Presence.hs @@ -0,0 +1,56 @@ +module Network.XMPP.Presence where + +import Data.Text(Text) +import Network.XMPP.Types + +presenceSubscribe :: JID -> Presence +presenceSubscribe to = Presence Nothing (Just to) Nothing (Just Subscribe) Nothing Nothing Nothing [] + +-- | Is presence a subscription request +isPresenceSubscribe :: Presence -> Bool +isPresenceSubscribe pres = pType pres == (Just Subscribe) + +-- | Approve a subscripton of an entity +presenceSubscribed :: JID -> Presence +presenceSubscribed to = Presence Nothing (Just to) Nothing (Just Subscribed) Nothing Nothing Nothing [] + +-- | Is presence a subscription approval +isPresenceSubscribed :: Presence -> Bool +isPresenceSubscribed pres = pType pres == (Just Subscribed) + +-- | End a subscription with an entity +presenceUnsubscribe :: JID -> Presence +presenceUnsubscribe to = Presence Nothing (Just to) Nothing (Just Unsubscribe) Nothing Nothing Nothing [] + +-- | Is presence an unsubscription request +isPresenceUnsubscribe :: Presence -> Bool +isPresenceUnsubscribe pres = pType pres == (Just Unsubscribe) + +-- | Signals to the server that the client is available for communication +presenceOnline :: Presence +presenceOnline = Presence Nothing Nothing Nothing Nothing Nothing Nothing Nothing [] + +-- | Signals to the server that the client is no longer available for communication. +presenceOffline :: Presence +presenceOffline = Presence Nothing Nothing Nothing (Just Unavailable) Nothing Nothing Nothing [] + +presence + :: Maybe Text -- ^ Status message + -> Maybe ShowType -- ^ Status Type + -> Maybe Int -- ^ Priority + -> Presence +presence txt showType priority = Presence Nothing Nothing Nothing Nothing showType txt priority [] + +-- | Sets the current availability status. This implicitly sets the clients +-- status online +presenceAvail :: ShowType -> Presence +presenceAvail showType = presence Nothing (Just showType) Nothing + +-- | Sets the current status message. This implicitly sets the clients +-- status online +presenceMessage :: Text -> Presence +presenceMessage txt = presence (Just txt) Nothing Nothing + +-- | Adds a recipient to a presence notification +presenceTo :: Presence -> JID -> Presence +presenceTo pres to = pres{pTo = Just to} \ No newline at end of file diff --git a/src/Tests.hs b/src/Tests.hs index f18c6b9..2cc06af 100644 --- a/src/Tests.hs +++ b/src/Tests.hs @@ -60,16 +60,10 @@ iqResponder = do autoAccept :: XMPPThread () autoAccept = forever $ do - st <- pullPresence - case st of - Presence from _ idq (Just Subscribe) _ _ _ _ -> - sendS . SPresence $ - Presence Nothing from idq (Just Subscribed) Nothing Nothing Nothing [] - _ -> return () - -sendUser txt = sendS . SMessage $ Message Nothing superviser Nothing Nothing Nothing - (Just (Text.pack txt)) Nothing [] + st <- waitForPresence isPresenceSubscribe + sendPresence $ presenceSubscribed (fromJust $ pFrom st) +sendUser = sendMessage . simpleMessage superviser . Text.pack expect debug x y | x == y = debug "Ok." | otherwise = do @@ -78,7 +72,6 @@ expect debug x y | x == y = debug "Ok." sendUser failMSG - runMain :: (String -> STM ()) -> Int -> IO () runMain debug number = do let (we, them, active) = case number of @@ -93,19 +86,20 @@ runMain debug number = do singleThreaded $ xmppSASL "pwd" xmppThreadedBind (resource we) singleThreaded $ xmppSession - sendS . SPresence $ Presence Nothing Nothing Nothing Nothing (Just Available) Nothing Nothing [] + sendPresence presenceOnline forkXMPP autoAccept forkXMPP iqResponder -- sendS . SPresence $ Presence Nothing (Just them) Nothing (Just Subscribe) Nothing Nothing Nothing [] let delay = if active then 1000000 else 5000000 - when active . void . forkXMPP . void . forM [1..10] $ \count -> do - let message = Text.pack . show $ node we - let payload = Payload count (even count) (Text.pack $ show count) - let body = pickleElem payloadP payload - answer <- sendIQ' (Just them) Get body - let answerPayload = unpickleElem payloadP (iqBody answer) - expect debug' (invertPayload payload) answerPayload - liftIO $ threadDelay delay + when active . void . forkXMPP $ do + forM [1..10] $ \count -> do + let message = Text.pack . show $ node we + let payload = Payload count (even count) (Text.pack $ show count) + let body = pickleElem payloadP payload + answer <- sendIQ' (Just them) Get body + let answerPayload = unpickleElem payloadP (iqBody answer) + expect debug' (invertPayload payload) answerPayload + liftIO $ threadDelay delay sendUser "All tests done" liftIO . forever $ threadDelay 10000000 return () From dd1aeb4be1cedece9c84691121c85a6fb03f3514 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 10 Apr 2012 14:52:43 +0200 Subject: [PATCH 24/26] prepare merge --- .gitignore | 8 ++ {Network => src/Network}/XMPP.hs | 0 {Network => src/Network}/XMPP/Address.hs | 0 {Network => src/Network}/XMPP/SASL.hs | 0 {Network => src/Network}/XMPP/Session.hs | 0 {Network => src/Network}/XMPP/SessionOld.hs | 0 {Network => src/Network}/XMPP/Stanza.hs | 0 {Network => src/Network}/XMPP/Stream.hs | 0 {Network => src/Network}/XMPP/TLS.hs | 0 src/Network/XMPP/TLS_flymake.hs | 30 +++++++ {Network => src/Network}/XMPP/Types.hs | 0 {Network => src/Network}/XMPP/Utilities.hs | 0 src/Network/XMPP_flymake.hs | 89 +++++++++++++++++++++ 13 files changed, 127 insertions(+) create mode 100644 .gitignore rename {Network => src/Network}/XMPP.hs (100%) rename {Network => src/Network}/XMPP/Address.hs (100%) rename {Network => src/Network}/XMPP/SASL.hs (100%) rename {Network => src/Network}/XMPP/Session.hs (100%) rename {Network => src/Network}/XMPP/SessionOld.hs (100%) rename {Network => src/Network}/XMPP/Stanza.hs (100%) rename {Network => src/Network}/XMPP/Stream.hs (100%) rename {Network => src/Network}/XMPP/TLS.hs (100%) create mode 100644 src/Network/XMPP/TLS_flymake.hs rename {Network => src/Network}/XMPP/Types.hs (100%) rename {Network => src/Network}/XMPP/Utilities.hs (100%) create mode 100644 src/Network/XMPP_flymake.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..d7ddec5 --- /dev/null +++ b/.gitignore @@ -0,0 +1,8 @@ +dist/ +cabal-dev/ +*.o +*.hi +*~ +*# +*.#* +*_flymake.hs \ No newline at end of file diff --git a/Network/XMPP.hs b/src/Network/XMPP.hs similarity index 100% rename from Network/XMPP.hs rename to src/Network/XMPP.hs diff --git a/Network/XMPP/Address.hs b/src/Network/XMPP/Address.hs similarity index 100% rename from Network/XMPP/Address.hs rename to src/Network/XMPP/Address.hs diff --git a/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs similarity index 100% rename from Network/XMPP/SASL.hs rename to src/Network/XMPP/SASL.hs diff --git a/Network/XMPP/Session.hs b/src/Network/XMPP/Session.hs similarity index 100% rename from Network/XMPP/Session.hs rename to src/Network/XMPP/Session.hs diff --git a/Network/XMPP/SessionOld.hs b/src/Network/XMPP/SessionOld.hs similarity index 100% rename from Network/XMPP/SessionOld.hs rename to src/Network/XMPP/SessionOld.hs diff --git a/Network/XMPP/Stanza.hs b/src/Network/XMPP/Stanza.hs similarity index 100% rename from Network/XMPP/Stanza.hs rename to src/Network/XMPP/Stanza.hs diff --git a/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs similarity index 100% rename from Network/XMPP/Stream.hs rename to src/Network/XMPP/Stream.hs diff --git a/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs similarity index 100% rename from Network/XMPP/TLS.hs rename to src/Network/XMPP/TLS.hs diff --git a/src/Network/XMPP/TLS_flymake.hs b/src/Network/XMPP/TLS_flymake.hs new file mode 100644 index 0000000..a0ac88b --- /dev/null +++ b/src/Network/XMPP/TLS_flymake.hs @@ -0,0 +1,30 @@ +-- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the +-- Pontarius distribution for more details. + +-- TODO: TLS12 when supported in tls; TODO: TLS11 results in a read error - bug? +-- TODO: cipher_AES128_SHA1 = TLS_RSA_WITH_AES_128_CBC_SHA? +-- TODO: Compression? +-- TODO: Validate certificate + +{-# OPTIONS_HADDOCK hide #-} + +module Network.XMPP.TLS (tlsParams) where + +import Network.TLS (TLSCertificateUsage (CertificateUsageAccept), + TLSParams (..), Version (SSL3, TLS10, TLS11), + defaultLogging, nullCompression) +import Network.TLS.Extra (cipher_AES128_SHA1) + + +tlsParams :: TLSParams + +tlsParams = TLSParams { pConnectVersion = TLS10 + , pAllowedVersions = [SSL3, TLS10,TLS11] + , pCiphers = [cipher_AES128_SHA1] + , pCompressions = [nullCompression] + , pWantClientCert = False -- Used for servers + , pUseSecureRenegotiation = False -- No renegotiation + , pCertificates = [] -- TODO + , pLogging = defaultLogging -- TODO + , onCertificatesRecv = \ certificate -> + return CertificateUsageAccept } diff --git a/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs similarity index 100% rename from Network/XMPP/Types.hs rename to src/Network/XMPP/Types.hs diff --git a/Network/XMPP/Utilities.hs b/src/Network/XMPP/Utilities.hs similarity index 100% rename from Network/XMPP/Utilities.hs rename to src/Network/XMPP/Utilities.hs diff --git a/src/Network/XMPP_flymake.hs b/src/Network/XMPP_flymake.hs new file mode 100644 index 0000000..57be806 --- /dev/null +++ b/src/Network/XMPP_flymake.hs @@ -0,0 +1,89 @@ +-- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the +-- Pontarius distribution for more details. + +-- | +-- Module: $Header$ +-- Description: Pontarius API +-- Copyright: Copyright © 2010-2012 Jon Kristensen +-- License: Apache License 2.0 +-- +-- Maintainer: jon.kristensen@nejla.com +-- Stability: unstable +-- Portability: portable +-- +-- XMPP is an open standard, extendable, and secure communications +-- protocol designed on top of XML, TLS, and SASL. Pontarius XMPP is +-- an XMPP client library, implementing the core capabilities of XMPP +-- (RFC 6120). +-- +-- Developers using this library are assumed to understand how XMPP +-- works. +-- +-- This module will be documented soon. +-- +-- Note that we are not recommending anyone to use Pontarius XMPP at +-- this time as it's still in an experimental stage and will have its +-- API and data types modified frequently. + +module Network.XMPP ( -- Network.XMPP.JID + Address (..) + , Localpart + , Domainpart + , Resourcepart + , isFull + , isBare + , fromString + , fromStrings + + -- Network.XMPP.Session + , runXMPPT + , hookStreamsOpenedEvent + , hookDisconnectedEvent + , destroy + , openStreams + , create + + -- , ClientHandler (..) + -- , ClientState (..) + -- , ConnectResult (..) + -- , HostName + -- , Password + -- , PortNumber + -- , Resource + -- , Session + -- , TerminationReason + -- , UserName + -- , sendIQ + -- , sendPresence + -- , sendMessage + -- , connect + -- , openStreams + -- , tlsSecureStreams + -- , authenticate + -- , session + -- , OpenStreamResult (..) + -- , SecureWithTLSResult (..) + -- , AuthenticateResult (..) + + -- Network.XMPP.Stanza + , StanzaID (SID) + , From + , To + , LangTag + , MessageType (..) + , Message (..) + , PresenceType (..) + , Presence (..) + , IQ (..) + , iqPayloadNamespace + , iqPayload ) where + +import Network.XMPP.Address +-- import Network.XMPP.SASL +import Network.XMPP.Session +import Network.XMPP.Stanza +import Network.XMPP.Utilities +import Network.XMPP.Types +-- import Network.XMPP.TLS +import Network.XMPP.Stream + From c856d332a26c17f23d048a4d70c92a79973e154d Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sat, 14 Apr 2012 16:18:39 +0200 Subject: [PATCH 25/26] removed dependency on ResourceT changed withConnection to run in the caller thread --- src/Data/Conduit/TLS.hs | 19 ++--- src/Network/XMPP/Concurrent/Monad.hs | 31 +++++--- src/Network/XMPP/Concurrent/Threads.hs | 101 +++++++++++++++---------- src/Network/XMPP/Concurrent/Types.hs | 8 +- src/Network/XMPP/Monad.hs | 61 +++++++++++++-- src/Network/XMPP/Stream.hs | 6 +- src/Network/XMPP/Types.hs | 8 +- src/Tests.hs | 7 +- 8 files changed, 159 insertions(+), 82 deletions(-) diff --git a/src/Data/Conduit/TLS.hs b/src/Data/Conduit/TLS.hs index bf2adf1..4a7d4f0 100644 --- a/src/Data/Conduit/TLS.hs +++ b/src/Data/Conduit/TLS.hs @@ -7,9 +7,8 @@ module Data.Conduit.TLS ) where -import Control.Applicative +import Control.Monad(liftM) import Control.Monad.IO.Class -import Control.Monad.Trans.Resource import Crypto.Random @@ -23,7 +22,7 @@ import Network.TLS.Extra as TLSExtra import System.IO(Handle) tlsinit - :: (MonadIO m, MonadIO m1, MonadResource m1) => + :: (MonadIO m, MonadIO m1) => TLSParams -> Handle -> m ( Source m1 BS.ByteString , Sink BS.ByteString m1 () @@ -32,15 +31,13 @@ tlsinit tlsParams handle = do gen <- liftIO $ (newGenIO :: IO SystemRandom) -- TODO: Find better random source? clientContext <- client tlsParams gen handle handshake clientContext - let src = sourceIO - (return clientContext) - (bye) - (\con -> IOOpen <$> recvData con) - let snk = sinkIO - (return clientContext) - (\_ -> return ()) + let src = sourceState + clientContext + (\con -> StateOpen con `liftM` recvData con) + let snk = sinkState + clientContext (\con bs -> sendData con (BL.fromChunks [bs]) - >> return IOProcessing ) + >> return (StateProcessing con)) (\_ -> return ()) return ( src , snk diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index 69b2f29..a92af43 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -4,6 +4,7 @@ import Network.XMPP.Types import Control.Concurrent import Control.Concurrent.STM +import qualified Control.Exception.Lifted as Ex import Control.Monad.IO.Class import Control.Monad.Trans.Reader import Control.Monad.Trans.State @@ -141,18 +142,26 @@ waitForPresence f = do -- | Run an XMPPMonad action in isolation. -- Reader and writer workers will be temporarily stopped -- and resumed with the new session details once the action returns. --- The Action will run in the reader thread. -withConnection :: XMPPConMonad () -> XMPPThread () +-- The Action will run in the calling thread/ +-- NB: This will /not/ catch any exceptions. If you action dies, deadlocks +-- or otherwisely exits abnormaly the XMPP session will be dead. +withConnection :: XMPPConMonad a -> XMPPThread a withConnection a = do - writeLock <- asks writeRef - rdr <- asks readerThread - _ <- liftIO . atomically $ takeTMVar writeLock -- we replace it with the - -- one returned by a - liftIO . throwTo rdr . ReaderSignal $ do - a - out <- gets sConPushBS - liftIO . atomically $ putTMVar writeLock out - return () + readerId <- asks readerThread + stateRef <- asks conStateRef + write <- asks writeRef + wait <- liftIO $ newEmptyTMVarIO + liftIO . throwTo readerId $ Interrupt wait + s <- liftIO . atomically $ do + putTMVar wait () + takeTMVar write + takeTMVar stateRef + (res, s') <- liftIO $ runStateT a s + liftIO . atomically $ do + putTMVar write (sConPushBS s') + putTMVar stateRef s' + return res + sendPresence :: Presence -> XMPPThread () sendPresence = sendS . PresenceS diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index ad59d02..db9b0ca 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} module Network.XMPP.Concurrent.Threads where @@ -36,40 +37,51 @@ import qualified Text.XML.Stream.Render as XR readWorker :: TChan (Either MessageError Message) -> TChan (Either PresenceError Presence) -> TVar IQHandlers - -> XMPPConState - -> ResourceT IO () -readWorker messageC presenceC handlers s = Ex.catch - (forever . flip runStateT s $ do - sta <- pull - liftIO .atomically $ do - case sta of - MessageS m -> do writeTChan messageC $ Right m - _ <- readTChan messageC -- Sic! - return () - -- this may seem ridiculous, but to prevent - -- the channel from filling up we immedtiately remove the - -- Stanza we just put in. It will still be - -- available in duplicates. - MessageErrorS m -> do writeTChan messageC $ Left m - _ <- readTChan messageC - return () - PresenceS p -> do - writeTChan presenceC $ Right p - _ <- readTChan presenceC - return () - PresenceErrorS p -> do - writeTChan presenceC $ Left p - _ <- readTChan presenceC - return () - - IQRequestS i -> handleIQRequest handlers i - IQResultS i -> handleIQResponse handlers (Right i) - IQErrorS i -> handleIQResponse handlers (Left i) - ) - ( \(ReaderSignal a) -> do - ((),s') <- runStateT a s - readWorker messageC presenceC handlers s' - ) + -> TMVar XMPPConState + -> IO () +readWorker messageC presenceC handlers stateRef = + Ex.mask_ . forever $ do + s <- liftIO . atomically $ takeTMVar stateRef + (sta', s') <- flip runStateT s $ Ex.catch ( do + -- we don't know whether pull will necessarily be interruptible + liftIO $ Ex.allowInterrupt + Just <$> pull + ) + (\(Interrupt t) -> do + liftIO . atomically $ + putTMVar stateRef s + liftIO . atomically $ takeTMVar t + return Nothing + ) + liftIO . atomically $ do + case sta' of + Nothing -> return () + Just sta -> do + putTMVar stateRef s' + case sta of + MessageS m -> do writeTChan messageC $ Right m + _ <- readTChan messageC -- Sic! + return () + -- this may seem ridiculous, but to prevent + -- the channel from filling up we immedtiately remove the + -- Stanza we just put in. It will still be + -- available in duplicates. + MessageErrorS m -> do writeTChan messageC $ Left m + _ <- readTChan messageC + return () + PresenceS p -> do + writeTChan presenceC $ Right p + _ <- readTChan presenceC + return () + PresenceErrorS p -> do + writeTChan presenceC $ Left p + _ <- readTChan presenceC + return () + + IQRequestS i -> handleIQRequest handlers i + IQResultS i -> handleIQResponse handlers (Right i) + IQErrorS i -> handleIQResponse handlers (Left i) + handleIQRequest handlers iq = do (byNS, _) <- readTVar handlers @@ -110,8 +122,10 @@ startThreads :: XMPPConMonad ( TChan (Either MessageError Message) , TChan (Either PresenceError Presence) , TVar IQHandlers - , TChan Stanza, IO () + , TChan Stanza + , IO () , TMVar (BS.ByteString -> IO ()) + , TMVar XMPPConState , ThreadId ) @@ -122,24 +136,28 @@ startThreads = do iqC <- liftIO newTChanIO outC <- liftIO newTChanIO handlers <- liftIO $ newTVarIO ( Map.empty, Map.empty) + conS <- liftIO . newTMVarIO =<< get lw <- liftIO . forkIO $ writeWorker outC writeLock cp <- liftIO . forkIO $ connPersist writeLock s <- get - rd <- lift . resourceForkIO $ readWorker messageC presenceC handlers s - return (messageC, presenceC, handlers, outC, killConnection writeLock [lw, rd, cp], writeLock, rd) + rd <- liftIO . forkIO $ readWorker messageC presenceC handlers conS + return (messageC, presenceC, handlers, outC + , killConnection writeLock [lw, rd, cp] + , writeLock, conS ,rd) where killConnection writeLock threads = liftIO $ do _ <- atomically $ takeTMVar writeLock -- Should we put it back? _ <- forM threads killThread return() - -- | Start worker threads and run action. The supplied action will run -- in the calling thread. use 'forkXMPP' to start another thread. runThreaded :: XMPPThread a -> XMPPConMonad a runThreaded a = do - (mC, pC, hand, outC, _stopThreads, writeR, rdr ) <- startThreads + liftIO . putStrLn $ "starting threads" + (mC, pC, hand, outC, _stopThreads, writeR, conS, rdr ) <- startThreads + liftIO . putStrLn $ "threads running" workermCh <- liftIO . newIORef $ Nothing workerpCh <- liftIO . newIORef $ Nothing idRef <- liftIO $ newTVarIO 1 @@ -147,7 +165,10 @@ runThreaded a = do curId <- readTVar idRef writeTVar idRef (curId + 1 :: Integer) return . read. show $ curId - liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR rdr getId) + s <- get + liftIO . putStrLn $ "starting application" + liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR rdr getId conS) + -- | Sends a blank space every 30 seconds to keep the connection alive connPersist :: TMVar (BS.ByteString -> IO ()) -> IO () diff --git a/src/Network/XMPP/Concurrent/Types.hs b/src/Network/XMPP/Concurrent/Types.hs index 889638b..14f0d04 100644 --- a/src/Network/XMPP/Concurrent/Types.hs +++ b/src/Network/XMPP/Concurrent/Types.hs @@ -38,11 +38,11 @@ data Thread = Thread { messagesRef :: IORef (Maybe ( TChan (Either , writeRef :: TMVar (BS.ByteString -> IO () ) , readerThread :: ThreadId , idGenerator :: IO StanzaId + , conStateRef :: TMVar XMPPConState } type XMPPThread a = ReaderT Thread IO a - -data ReaderSignal = ReaderSignal (XMPPConMonad ()) deriving Typeable -instance Show ReaderSignal where show _ = "" -instance Ex.Exception ReaderSignal +data Interrupt = Interrupt (TMVar ()) deriving Typeable +instance Show Interrupt where show _ = "" +instance Ex.Exception Interrupt diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index ff3aded..50ef734 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -5,7 +5,7 @@ module Network.XMPP.Monad where import Control.Applicative((<$>)) import Control.Monad.IO.Class import Control.Monad.Trans.Class -import Control.Monad.Trans.Resource +--import Control.Monad.Trans.Resource import Control.Monad.Trans.State import Data.ByteString as BS @@ -16,6 +16,7 @@ import Data.Text(Text) import Data.XML.Pickle import Data.XML.Types +import Network import Network.XMPP.Types import Network.XMPP.Marshal import Network.XMPP.Pickle @@ -41,7 +42,7 @@ pushOpen e = do lift . sink $ openElementToEvents e return () -pulls :: Sink Event (ResourceT IO) b -> XMPPConMonad b +pulls :: Sink Event IO b -> XMPPConMonad b pulls snk = do source <- gets sConSrc (src', r) <- lift $ source $$+ snk @@ -63,15 +64,15 @@ xmppFromHandle :: Handle -> Maybe Text -> XMPPConMonad a -> IO (a, XMPPConState) -xmppFromHandle handle hostname username res f = runResourceT $ do +xmppFromHandle handle hostname username res f = do liftIO $ hSetBuffering handle NoBuffering - let raw = CB.sourceHandle handle + let raw = sourceHandle' handle let src = raw $= XP.parseBytes def let st = XMPPConState src (raw) (\xs -> CL.sourceList xs - $$ XR.renderBytes def =$ CB.sinkHandle handle) + $$ XR.renderBytes def =$ sinkHandle' handle) (BS.hPut handle) (Just handle) (SF Nothing [] []) @@ -81,3 +82,53 @@ xmppFromHandle handle hostname username res f = runResourceT $ do res runStateT f st +-- TODO: Once pullrequest has been merged, switch back to upstream +sourceHandle' :: MonadIO m => Handle -> Source m BS.ByteString +sourceHandle' h = + src + where + src = PipeM pull close + + pull = do + bs <- liftIO (BS.hGetSome h 4096) + if BS.null bs + then return $ Done Nothing () + else return $ HaveOutput src close bs + + close = return () + +sinkHandle' :: MonadIO m + => Handle + -> Sink BS.ByteString m () +sinkHandle' h = + NeedInput push close + where + push input = PipeM + (liftIO (BS.hPut h input) >> return (NeedInput push close)) + (return ()) + close = return () + +xmppConnect :: HostName -> Text -> XMPPConMonad () +xmppConnect host hostname = do + uname <- gets sUsername + con <- liftIO $ do + con <- connectTo host (PortNumber 5222) + hSetBuffering con NoBuffering + return con + let raw = sourceHandle' con + let src = raw $= XP.parseBytes def + let st = XMPPConState + src + (raw) + (\xs -> CL.sourceList xs + $$ XR.renderBytes def =$ sinkHandle' con) + (BS.hPut con) + (Just con) + (SF Nothing [] []) + False + hostname + uname + Nothing + put st + return () + diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index a54e6ae..3bc4188 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -53,12 +53,12 @@ xmppRestartStream = do xmppStartStream -xmppStream :: Sink Event (ResourceT IO) ServerFeatures +xmppStream :: Sink Event IO ServerFeatures xmppStream = do xmppStreamHeader xmppStreamFeatures -xmppStreamHeader :: Sink Event (ResourceT IO) () +xmppStreamHeader :: Sink Event IO () xmppStreamHeader = do throwOutJunk (ver, _, _) <- unpickleElem pickleStream <$> openElementFromEvents @@ -66,7 +66,7 @@ xmppStreamHeader = do return() -xmppStreamFeatures :: Sink Event (ResourceT IO) ServerFeatures +xmppStreamFeatures :: Sink Event IO ServerFeatures xmppStreamFeatures = unpickleElem pickleStreamFeatures <$> elementFromEvents diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index cd3f164..49cac1f 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -608,9 +608,9 @@ data ServerFeatures = SF } deriving Show data XMPPConState = XMPPConState - { sConSrc :: Source (ResourceT IO) Event - , sRawSrc :: Source (ResourceT IO) BS.ByteString - , sConPush :: [Event] -> ResourceT IO () + { sConSrc :: Source IO Event + , sRawSrc :: Source IO BS.ByteString + , sConPush :: [Event] -> IO () , sConPushBS :: BS.ByteString -> IO () , sConHandle :: Maybe Handle , sFeatures :: ServerFeatures @@ -627,7 +627,7 @@ data XMPPConState = XMPPConState newtype XMPPT m a = XMPPT { runXMPPT :: StateT XMPPConState m a } deriving (Monad, MonadIO) -type XMPPConMonad a = StateT XMPPConState (ResourceT IO) a +type XMPPConMonad a = StateT XMPPConState IO a -- Make XMPPT derive the Monad and MonadIO instances. diff --git a/src/Tests.hs b/src/Tests.hs index 6043679..b9d553d 100644 --- a/src/Tests.hs +++ b/src/Tests.hs @@ -78,11 +78,11 @@ runMain debug number = do 1 -> (testUser1, testUser2,True) 2 -> (testUser2, testUser1,False) _ -> error "Need either 1 or 2" + let debug' = liftIO . atomically . + debug . (("Thread " ++ show number ++ ":") ++) sessionConnect "localhost" "species64739.dyndns.org" (fromJust $ node we) (resource we) $ do - let debug' = liftIO . atomically . debug . - (("Thread " ++ show number ++ ":") ++) withConnection $ xmppSASL "pwd" xmppThreadedBind (resource we) withConnection $ xmppSession @@ -90,7 +90,6 @@ runMain debug number = do forkXMPP autoAccept forkXMPP iqResponder -- sendS . SPresence $ Presence Nothing (Just them) Nothing (Just Subscribe) Nothing Nothing Nothing [] - let delay = if active then 1000000 else 5000000 when active . void . forkXMPP $ do forM [1..10] $ \count -> do let message = Text.pack . show $ node we @@ -100,7 +99,7 @@ runMain debug number = do let answerPayload = unpickleElem payloadP (fromJust $ iqResultPayload answer) expect debug' (invertPayload payload) answerPayload - liftIO $ threadDelay delay + liftIO $ threadDelay 500000 sendUser "All tests done" liftIO . forever $ threadDelay 10000000 return () From e0b97dacf817d4bbc9f7142bc826f1de753a0f42 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sat, 14 Apr 2012 21:39:43 +0200 Subject: [PATCH 26/26] removed sConPush, session now starts without connection, added inline connection method xml-types-pickle updated --- src/Network/XMPP.hs | 39 +++---------------- src/Network/XMPP/Concurrent/Monad.hs | 1 - src/Network/XMPP/Concurrent/Threads.hs | 4 +- src/Network/XMPP/Monad.hs | 44 +++++++++++++++------- src/Network/XMPP/Pickle.hs | 6 +-- src/Network/XMPP/SASL.hs | 31 +++++++++++---- src/Network/XMPP/Stream.hs | 2 +- src/Network/XMPP/TLS.hs | 8 ++-- src/Network/XMPP/Types.hs | 5 +-- src/Tests.hs | 25 +++++++++---- src/Text/XML/Stream/Elements.hs | 52 +++++++++++++++----------- xml-types-pickle | 2 +- 12 files changed, 119 insertions(+), 100 deletions(-) diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index d2e96b5..51c84d7 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -40,8 +40,8 @@ module Network.XMPP , module Network.XMPP.Types , module Network.XMPP.Presence , module Network.XMPP.Message --- , connectXMPP - , sessionConnect + , xmppConnect + , xmppNewSession ) where import Data.Text as Text @@ -58,35 +58,8 @@ import Network.XMPP.Stream import Network.XMPP.TLS import Network.XMPP.Types -import System.IO - ---fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> IO ((), XMPPState) --- fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> XMPPThread a --- -> IO ((), XMPPState) --- fromHandle handle hostname username rsrc password a = --- xmppFromHandle handle hostname username rsrc $ do --- xmppStartStream --- -- this will check whether the server supports tls --- -- on it's own --- xmppStartTLS exampleParams --- xmppSASL password --- xmppBind rsrc --- xmppSession --- _ <- runThreaded a --- return () - --- connectXMPP :: HostName -> Text -> Text -> Maybe Text --- -> Text -> XMPPThread a -> IO ((), XMPPState) --- connectXMPP host hostname username rsrc passwd a = do --- con <- connectTo host (PortNumber 5222) --- hSetBuffering con NoBuffering --- fromHandle con hostname username rsrc passwd a - -sessionConnect :: HostName -> Text -> Text - -> Maybe Text -> XMPPThread a -> IO (a, XMPPConState) -sessionConnect host hostname username rsrc a = do - con <- connectTo host (PortNumber 5222) - hSetBuffering con NoBuffering - xmppFromHandle con hostname username rsrc $ - xmppStartStream >> runThreaded a +xmppConnect :: HostName -> Text -> XMPPConMonad () +xmppConnect address hostname = xmppRawConnect address hostname >> xmppStartStream +xmppNewSession :: XMPPThread a -> IO (a, XMPPConState) +xmppNewSession = withNewSession . runThreaded \ No newline at end of file diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index a92af43..a7ccb62 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -162,7 +162,6 @@ withConnection a = do putTMVar stateRef s' return res - sendPresence :: Presence -> XMPPThread () sendPresence = sendS . PresenceS diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index db9b0ca..40669e3 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -109,9 +109,7 @@ writeWorker stCh writeR = forever $ do (write, next) <- atomically $ (,) <$> takeTMVar writeR <*> readTChan stCh - outBS <- CL.sourceList (elementToEvents $ pickleElem stanzaP next) - $= XR.renderBytes def $$ CL.consume - _ <- forM outBS write + _ <- write $ renderElement (pickleElem stanzaP next) atomically $ putTMVar writeR write -- Two streams: input and output. Threads read from input stream and write to output stream. diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 50ef734..c080f53 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -3,9 +3,11 @@ module Network.XMPP.Monad where import Control.Applicative((<$>)) +import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class --import Control.Monad.Trans.Resource +import Control.Concurrent import Control.Monad.Trans.State import Data.ByteString as BS @@ -30,16 +32,16 @@ import Text.XML.Stream.Render as XR pushN :: Element -> XMPPConMonad () pushN x = do - sink <- gets sConPush - lift . sink $ elementToEvents x + sink <- gets sConPushBS + liftIO . sink $ renderElement x push :: Stanza -> XMPPConMonad () push = pushN . pickleElem stanzaP pushOpen :: Element -> XMPPConMonad () pushOpen e = do - sink <- gets sConPush - lift . sink $ openElementToEvents e + sink <- gets sConPushBS + liftIO . sink $ renderOpenElement e return () pulls :: Sink Event IO b -> XMPPConMonad b @@ -71,14 +73,12 @@ xmppFromHandle handle hostname username res f = do let st = XMPPConState src (raw) - (\xs -> CL.sourceList xs - $$ XR.renderBytes def =$ sinkHandle' handle) (BS.hPut handle) (Just handle) (SF Nothing [] []) False - hostname - username + (Just hostname) + (Just username) res runStateT f st @@ -108,8 +108,24 @@ sinkHandle' h = (return ()) close = return () -xmppConnect :: HostName -> Text -> XMPPConMonad () -xmppConnect host hostname = do +zeroSource :: Source IO output +zeroSource = sourceState () (\_ -> forever $ threadDelay 10000000) + +xmppZeroConState :: XMPPConState +xmppZeroConState = XMPPConState + { sConSrc = zeroSource + , sRawSrc = zeroSource + , sConPushBS = (\_ -> return ()) + , sConHandle = Nothing + , sFeatures = SF Nothing [] [] + , sHaveTLS = False + , sHostname = Nothing + , sUsername = Nothing + , sResource = Nothing + } + +xmppRawConnect :: HostName -> Text -> XMPPConMonad () +xmppRawConnect host hostname = do uname <- gets sUsername con <- liftIO $ do con <- connectTo host (PortNumber 5222) @@ -120,15 +136,15 @@ xmppConnect host hostname = do let st = XMPPConState src (raw) - (\xs -> CL.sourceList xs - $$ XR.renderBytes def =$ sinkHandle' con) (BS.hPut con) (Just con) (SF Nothing [] []) False - hostname + (Just hostname) uname Nothing put st - return () +withNewSession :: XMPPConMonad a -> IO (a, XMPPConState) +withNewSession action = do + runStateT action xmppZeroConState diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index c1b15c9..a999956 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -10,6 +10,7 @@ module Network.XMPP.Pickle where import Data.XML.Types import Data.XML.Pickle +import Text.XML.Stream.Elements mbToBool :: Maybe t -> Bool mbToBool (Just _) = True @@ -51,14 +52,11 @@ right :: Either [Char] t -> t right (Left l) = error l right (Right r) = r - unpickleElem :: PU [Node] c -> Element -> c unpickleElem p x = case unpickle (xpNodeElem p) x of - Left l -> error $ l ++ "\n saw: " ++ show x + Left l -> error $ l ++ "\n saw: " ++ ppElement x Right r -> r pickleElem :: PU [Node] a -> a -> Element pickleElem p = pickle $ xpNodeElem p - - diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index d893150..53b6c2e 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -48,14 +48,27 @@ saslResponse2E = [] [] -xmppSASL :: Text -> XMPPConMonad () -xmppSASL passwd = do +xmppSASL:: Text -> Text -> XMPPConMonad (Either String Text) +xmppSASL uname passwd = do + realm <- gets sHostname + case realm of + Just realm' -> do + xmppStartSASL realm' uname passwd + modify (\s -> s{sUsername = Just uname}) + return $ Right uname + Nothing -> return $ Left "No connection found" + +xmppStartSASL :: Text + -> Text + -> Text + -> XMPPConMonad () +xmppStartSASL realm username passwd = do mechanisms <- gets $ saslMechanisms . sFeatures unless ("DIGEST-MD5" `elem` mechanisms) . error $ "No usable auth mechanism: " ++ show mechanisms pushN $ saslInitE "DIGEST-MD5" Right challenge <- B64.decode . Text.encodeUtf8<$> pullPickle challengePickle let Right pairs = toPairs challenge - pushN . saslResponseE =<< createResponse passwd pairs + pushN . saslResponseE =<< createResponse realm username passwd pairs challenge2 <- pullPickle (xpEither failurePickle challengePickle) case challenge2 of Left x -> error $ show x @@ -65,13 +78,17 @@ xmppSASL passwd = do xmppRestartStream return () -createResponse :: Text -> [(BS8.ByteString, BS8.ByteString)] -> XMPPConMonad Text -createResponse passwd' pairs = do +createResponse :: Text + -> Text + -> Text + -> [(BS8.ByteString, BS8.ByteString)] + -> XMPPConMonad Text +createResponse hostname username passwd' pairs = do let Just qop = L.lookup "qop" pairs let Just nonce = L.lookup "nonce" pairs - uname <- Text.encodeUtf8 <$> gets sUsername + let uname = Text.encodeUtf8 username let passwd = Text.encodeUtf8 passwd' - realm <- Text.encodeUtf8 <$> gets sHostname + let realm = Text.encodeUtf8 hostname g <- liftIO $ Random.newStdGen let cnonce = BS.tail . BS.init . B64.encode . BS.pack . take 8 $ Random.randoms g diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index 3bc4188..b95706a 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -40,7 +40,7 @@ openElementFromEvents = do xmppStartStream :: XMPPConMonad () xmppStartStream = do hostname <- gets sHostname - pushOpen $ pickleElem pickleStream ("1.0",Nothing, Just hostname) + pushOpen $ pickleElem pickleStream ("1.0",Nothing, hostname) features <- pulls xmppStream modify (\s -> s {sFeatures = features}) return () diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index a536bb8..55884d5 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -26,7 +26,8 @@ starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] exampleParams :: TLS.TLSParams -exampleParams = TLS.TLSParams { pConnectVersion = TLS.TLS10 +exampleParams = TLS.defaultParams + {pConnectVersion = TLS.TLS10 , pAllowedVersions = [TLS.SSL3, TLS.TLS10, TLS.TLS11] , pCiphers = [TLS.cipher_AES128_SHA1] , pCompressions = [TLS.nullCompression] @@ -35,7 +36,8 @@ exampleParams = TLS.TLSParams { pConnectVersion = TLS.TLS10 , pCertificates = [] -- TODO , pLogging = TLS.defaultLogging -- TODO , onCertificatesRecv = \ certificate -> - return TLS.CertificateUsageAccept } + return TLS.CertificateUsageAccept + } xmppStartTLS :: TLS.TLSParams -> XMPPConMonad () xmppStartTLS params = do @@ -49,8 +51,6 @@ xmppStartTLS params = do { sRawSrc = raw -- , sConSrc = -- Note: this momentarily leaves us in an -- inconsistent state - , sConPush = \xs -> CL.sourceList xs - $$ XR.renderBytes def =$ snk , sConPushBS = psh }) xmppRestartStream diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index 49cac1f..e948756 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -610,13 +610,12 @@ data ServerFeatures = SF data XMPPConState = XMPPConState { sConSrc :: Source IO Event , sRawSrc :: Source IO BS.ByteString - , sConPush :: [Event] -> IO () , sConPushBS :: BS.ByteString -> IO () , sConHandle :: Maybe Handle , sFeatures :: ServerFeatures , sHaveTLS :: Bool - , sHostname :: Text - , sUsername :: Text + , sHostname :: Maybe Text + , sUsername :: Maybe Text , sResource :: Maybe Text } diff --git a/src/Tests.hs b/src/Tests.hs index b9d553d..e3438f3 100644 --- a/src/Tests.hs +++ b/src/Tests.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE PackageImports, OverloadedStrings #-} +{-# LANGUAGE PackageImports, OverloadedStrings, NoMonomorphismRestriction #-} module Example where -import Network.XMPP import Control.Concurrent import Control.Concurrent.STM import Control.Monad @@ -13,9 +12,11 @@ import qualified Data.Text as Text import Data.XML.Pickle import Data.XML.Types +import Network.XMPP import Network.XMPP.Pickle import System.Environment +import Text.XML.Stream.Elements testUser1 :: JID testUser1 = read "testuser1@species64739.dyndns.org/bot1" @@ -72,6 +73,9 @@ expect debug x y | x == y = debug "Ok." sendUser failMSG +wait3 :: MonadIO m => m () +wait3 = liftIO $ threadDelay 1000000 + runMain :: (String -> STM ()) -> Int -> IO () runMain debug number = do let (we, them, active) = case number of @@ -80,16 +84,21 @@ runMain debug number = do _ -> error "Need either 1 or 2" let debug' = liftIO . atomically . debug . (("Thread " ++ show number ++ ":") ++) - sessionConnect "localhost" - "species64739.dyndns.org" - (fromJust $ node we) (resource we) $ do - withConnection $ xmppSASL "pwd" + xmppNewSession $ do + debug' "running" + withConnection $ do + xmppConnect "localhost" "species64739.dyndns.org" + xmppStartTLS exampleParams + saslResponse <- xmppSASL (fromJust $ node we) "pwd" + case saslResponse of + Right _ -> return () + Left e -> error e xmppThreadedBind (resource we) withConnection $ xmppSession + debug' "session standing" sendPresence presenceOnline forkXMPP autoAccept forkXMPP iqResponder - -- sendS . SPresence $ Presence Nothing (Just them) Nothing (Just Subscribe) Nothing Nothing Nothing [] when active . void . forkXMPP $ do forM [1..10] $ \count -> do let message = Text.pack . show $ node we @@ -99,7 +108,7 @@ runMain debug number = do let answerPayload = unpickleElem payloadP (fromJust $ iqResultPayload answer) expect debug' (invertPayload payload) answerPayload - liftIO $ threadDelay 500000 + liftIO $ threadDelay 100000 sendUser "All tests done" liftIO . forever $ threadDelay 10000000 return () diff --git a/src/Text/XML/Stream/Elements.hs b/src/Text/XML/Stream/Elements.hs index 3812752..952854d 100644 --- a/src/Text/XML/Stream/Elements.hs +++ b/src/Text/XML/Stream/Elements.hs @@ -1,23 +1,26 @@ module Text.XML.Stream.Elements where -import Control.Applicative ((<$>)) -import Control.Monad.Trans.Class -import Control.Monad.Trans.Resource as R +import Control.Applicative ((<$>)) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Resource as R -import Data.Text as T -import Text.XML.Unresolved -import Data.XML.Types +import qualified Data.ByteString as BS +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.XML.Types +import qualified Text.XML.Stream.Render as TXSR +import Text.XML.Unresolved as TXU -import Data.Conduit as C -import Data.Conduit.List as CL +import Data.Conduit as C +import Data.Conduit.List as CL -import Text.XML.Stream.Parse +import System.IO.Unsafe(unsafePerformIO) compressNodes :: [Node] -> [Node] compressNodes [] = [] compressNodes [x] = [x] compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) = - compressNodes $ NodeContent (ContentText $ x `T.append` y) : z + compressNodes $ NodeContent (ContentText $ x `Text.append` y) : z compressNodes (x:xs) = x : compressNodes xs elementFromEvents :: R.MonadThrow m => C.Sink Event m Element @@ -27,7 +30,7 @@ elementFromEvents = do Just (EventBeginElement n as) -> goE n as _ -> lift $ R.monadThrow $ InvalidEventStream $ "not an element: " ++ show x where - many f = + many' f = go id where go front = do @@ -38,7 +41,7 @@ elementFromEvents = do dropReturn x = CL.drop 1 >> return x goE n as = do CL.drop 1 - ns <- many goN + ns <- many' goN y <- CL.head if y == Just (EventEndElement n) then return $ Element n as $ compressNodes ns @@ -57,15 +60,10 @@ elementFromEvents = do openElementToEvents :: Element -> [Event] openElementToEvents (Element name as ns) = EventBeginElement name as : goN ns [] where - goM [] = id - goM [x] = (goM' x :) - goM (x:xs) = (goM' x :) . goM xs - goM' (MiscInstruction i) = EventInstruction i - goM' (MiscComment t) = EventComment t - goE (Element name as ns) = - (EventBeginElement name as :) - . goN ns - . (EventEndElement name :) + goE (Element name' as' ns') = + (EventBeginElement name' as' :) + . goN ns' + . (EventEndElement name' :) goN [] = id goN [x] = goN' x goN (x:xs) = goN' x . goN xs @@ -76,3 +74,15 @@ openElementToEvents (Element name as ns) = EventBeginElement name as : goN ns [] elementToEvents :: Element -> [Event] elementToEvents e@(Element name _ _) = openElementToEvents e ++ [EventEndElement name] + + +renderOpenElement :: Element -> BS.ByteString +renderOpenElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO + $ CL.sourceList (openElementToEvents e) $$ TXSR.renderText def =$ CL.consume + +renderElement :: Element -> BS.ByteString +renderElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO + $ CL.sourceList (elementToEvents e) $$ TXSR.renderText def =$ CL.consume + +ppElement :: Element -> String +ppElement = Text.unpack . Text.decodeUtf8 . renderElement \ No newline at end of file diff --git a/xml-types-pickle b/xml-types-pickle index e417f9d..73f8cae 160000 --- a/xml-types-pickle +++ b/xml-types-pickle @@ -1 +1 @@ -Subproject commit e417f9ddc6cc74dc06fabadad810da10b8e25d84 +Subproject commit 73f8caedfe389646647354badc7700eccf40442f