compiles... again

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

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
 
 

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

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

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

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
+unpickleElem :: PU [Node] c -> Element -> c
+unpickleElem p = right . unpickle (xpNodeElem p)
+
+pickleElem :: PU [Node] a -> a -> Element
+pickleElem p = pickle  $ xpNodeElem p
+
+
+

src/Network/XMPP/SASL.hs

@@ -19,9 +19,12 @@ 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
 
 import Network.XMPP.Monad
@@ -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)
 

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

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

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

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,6 +53,7 @@ data ServerFeatures = SF
   } deriving Show
 
 
+instance Default ServerFeatures where
   def = SF
     { stls  = Nothing
     , saslMechanisms = []
@@ -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
 

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]