From f0c05132ff381db1ae044ce7204e11e0a3c3bff5 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 28 Mar 2012 12:48:42 +0200 Subject: [PATCH] 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