From f54b50d609f83901595930baa17be2dd0bf160c0 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 1 Apr 2012 21:12:03 +0200 Subject: [PATCH] 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