squash! some conduit weirdness (blocking where it shouldn't)

.gitignore

@@ -1,3 +1,4 @@
+cabal-dev/
 dist/
 *.o
 *.hi

src/Data/Conduit/Hexpat.hs

@@ -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
-

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] )
 

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 ()
+

src/Network/XMPP.hs

@@ -1,31 +1,32 @@
 {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings  #-}
 module Network.XMPP where
 
-import Control.Monad
+import           Control.Monad
-import Control.Monad.Trans.Class
+import           Control.Monad.IO.Class
-import Control.Monad.Trans.State
+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
-import Network.XMPP.Concurrent
+import           Network.XMPP.Bind
-import Network.XMPP.Monad
+import           Network.XMPP.Concurrent
-import Network.XMPP.TLS
+import           Network.XMPP.Monad
-import Network.XMPP.Stream
+import           Network.XMPP.SASL
-import Network.XMPP.SASL
+import           Network.XMPP.Session
-import Network.XMPP.Types
+import           Network.XMPP.Stream
-import Network.XMPP.Bind
+import           Network.XMPP.TLS
-import Network.XMPP.Session
+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
-

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 as XP
-import Text.XML.Stream.Parse
 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
+  let raw = CB.sourceHandle handle --  $= conduitStdout
-  src <- bufferSource $ raw $= parseBytes def
+  liftIO $ BS.hPut handle "<stream:stream xmlns=\"jabber:client\" xmlns:stream=\"http://etherx.jabber.org/streams\" version=\"1.0\" to=\"species64739.dyndns.org\">"
+  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 =
+   [ "<?xml version='1.0'?>"
+   , "<stream:stream xmlns='JABBER15:client' "
+   , "xmlns:stream='http://etherx.jabber.org/streams' id='1365401808' "
+   , "from='species64739.dyndns.org' version='1.0' xml:lang='en'>"
+   , "<stream:features>"
+   , "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>"
+   , "<mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>"
+   , "<mechanism>PLAIN"
+   , "</mechanism>"
+   , "<mechanism>DIGEST-MD5"
+   , "</mechanism>"
+   , "<mechanism>SCRAM-SHA-1"
+   , "</mechanism>"
+   , "</mechanisms>"
+   , "<c xmlns='http://jabber.org/protocol/caps' hash='sha-1' node='http://www.process-one.net/en/ejabberd/' ver='yy7di5kE0syuCXOQTXNBTclpNTo='/>"
+   , "<register xmlns='http://jabber.org/features/iq-register'/>"
+   , "</stream:features>"
+   , error "Booh!"
+   ] :: [ByteString]
+
+xml2 = BS.concat ["<?xml version='1.0'?><stream:stream xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams' id='2181744549' from='species64739.dyndns.org' version='1.0' xml:lang='en'>"
+  ,"<stream:features><starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/><mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'><mechanism>PLAIN</mechanism><mechanism>DIGEST-MD5</mechanism><mechanism>SCRAM-SHA-1</mechanism></mechanisms><c xmlns='http://jabber.org/protocol/caps' hash='sha-1' node='http://www.process-one.net/en/ejabberd/' ver='yy7di5kE0syuCXOQTXNBTclpNTo='/><register xmlns='http://jabber.org/features/iq-register'/></stream:features>"]
+
+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

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 $
+pickleTLSFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls"
-  xpElem "starttls"
+                      (xpElemExists "required")
-    (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-tls")
-    (xpElemExists "required")
 
 pickleSaslFeature :: PU [Node] [Text]
-pickleSaslFeature = ignoreAttrs $
+pickleSaslFeature =  xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms"
-  xpElem "mechanisms"
+                       (xpAll $ xpElemNodes "mechanism" (xpContent xpId) )
-    (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-sasl")
-    (xpList0 $
-     xpElemNodes "mechanism" (xpContent xpId) )
 
 pickleStreamFeatures :: PU [Node] ServerFeatures
 pickleStreamFeatures = xpWrap ( \(tls, sasl, rest) -> SF tls (mbl sasl) rest)

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