switched to hexpat

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
+

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 (src $= conduitStdout
-                (return clientContext)
+           , \s -> sendData clientContext $ BL.fromChunks [s] )
-                (\_ -> return ())
-                (\ctx dt -> sendData ctx (BL.fromChunks [dt]) >> return IOProcessing)
-                (\_ -> return ())
-    return (src $= conduitStdout , snk)
 
 -- TODO: remove
 

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
+import Text.XML.Expat.Pickle
-           (Element "{urn:ietf:params:xml:ns:xmpp-bind}bind"
+
-            []
+bindReqIQ resource= SIQ $ IQ Nothing Nothing "bind" Set
-            (maybe [] (return . textToNode)  resource))
+                    (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
+  push $ bindReqIQ res
-  SIQ (IQ Nothing Nothing _ Result r) <- pull
+  answer <- pull
-  (JID n d (Just r)) <- case r of
+  liftIO $ print answer
-    Element "{urn:ietf:params:xml:ns:xmpp-bind}bind" []
+  let SIQ (IQ Nothing Nothing _ Result b) = answer
-       [NodeElement
+  let (JID n d (Just r)) = unpickleElem jidP b
-        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})
 
+bindP c = ignoreAttrs $ xpElemNs "bind" "urn:ietf:params:xml:ns:xmpp-bind"
+                          xpUnit
+                          c
+
 

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
+import Text.XML.Expat.Pickle
-stanzaToElement (SPresence m) = presenceToElement m
+
-stanzaToElement (SIQ       m) = iqToElement m
+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)

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.Expat.SAX
-import Text.XML.Stream.Render as XR
+import Text.XML.Expat.Tree
-import Text.XML.Stream.Parse
+import Text.XML.Expat.Format
-
+
-type XMPPMonad a = StateT XMPPState (ResourceT IO) a
+parseOpts = ParseOptions (Just UTF8) Nothing
-
+
-data XMPPState = XMPPState
+pushN :: Element -> XMPPMonad ()
-                   { sConSrc    :: BufferedSource IO Event
+pushN x = do
-                   , 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
   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

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

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"
+    Element "auth"
-        [("mechanism", [ContentText mechanism])
+        [ ("xmlns","urn:ietf:params:xml:ns:xmpp-sasl")
+        ,  ("mechanism", mechanism)
         ]
         []
 
 saslResponseE resp =
-    Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" []
+    Element "response"
-    [NodeContent $ ContentText resp]
+    [("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"
+  liftIO $ putStrLn "saslinit"
-  Element "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" []
+  pushN $ saslInitE "DIGEST-MD5"
-    [NodeContent (ContentText content)] <- pullE
+  liftIO $ putStrLn "saslinit sent"
-  let (Right challenge) = B64.decode . Text.encodeUtf8 $ content
+  Right challenge <- B64.decode . Text.encodeUtf8<$> pullPickle challengePickle
   let Right pairs = toPairs challenge
-  pushE . saslResponseE =<< createResponse passwd pairs
+  pushN . saslResponseE =<< createResponse passwd pairs
-  Element name attrs content <- pullE
+  challenge2 <- pullPickle (xpEither failurePickle challengePickle)
-  when (name == "{urn:ietf:params:xml:ns:xmpp-sasl}failure") $
+  case challenge2 of
-    (error $ show content)
+    Left x -> error $ show x
-  pushE saslResponse2E
+    Right c -> return ()
-  Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pullE
+  pushN saslResponse2E
-  xmppStartStream
+  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)
+

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 :: Sink Event IO ()
-xmppStreamHeader :: Resource m => Sink Event m ()
 xmppStreamHeader = do
-  hd <- CL.peek
+  throwOutJunk
-  case hd of
+  (ver, _, _) <- unpickleElem pickleStream <$> openElementFromEvents
-    Just EventBeginDocument -> CL.drop 1
+  unless (ver == "1.0")  $ error  "Not XMPP version 1.0 "
-    _ -> return ()
+  return()
-  Just (EventBeginElement "{http://etherx.jabber.org/streams}stream" streamAttrs) <- CL.head
+
-  unless (checkVersion streamAttrs)  $ error  "Not XMPP version 1.0 "
+
-  return ()
+xmppStreamFeatures :: Sink Event IO ServerFeatures
-  where
+xmppStreamFeatures = unpickleElem pickleStreamFeatures <$> elementFromEvents
-    checkVersion = L.any (\x -> (fst x == "version") && (snd x == [ContentText "1.0"]))
+
-
+
-
+-- Pickling
-xmppStreamFeatures
+
-  :: ResourceThrow m => Sink Event m ServerFeatures
+pickleStream = xpWrap (snd, (((),()),)) .
-xmppStreamFeatures = do
+  xpElemAttrs "stream:stream" $
-  Element "{http://etherx.jabber.org/streams}features" [] features' <- elementFromEvents
+    xpPair
-  let features = do
+      (xpPair
-       f <- features'
+        (xpAttrFixed "xmlns" "jabber:client" )
-       case f of
+        (xpAttrFixed "xmlns:stream" "http://etherx.jabber.org/streams" )
-         NodeElement e -> [e]
+      )
-         _ -> []
+      (xpTriple
-  let starttls = features >>= isNamed "{urn:ietf:params:xml:ns:xmpp-tls}starttls"
+       (xpAttr "version" xpText)
-  let starttlsRequired = starttls
+       (xpOption $ xpAttr "from" xpText)
-        >>= elementChildren
+       (xpOption $ xpAttr "to" xpText)
-        >>= isNamed "{urn:ietf:params:xml:ns:xmpp-tls}required"
+       )
-  let mechanisms = features
+
-                 >>= isNamed "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms"
+pickleTLSFeature = ignoreAttrs $
-                 >>= elementChildren
+  xpElem "starttls"
-                 >>= isNamed "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism"
+    (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-tls")
-                 >>= elementText
+    (xpElemExists "required")
-  return SF { stls = not $ L.null starttls
+
-            , stlsRequired = not $ L.null starttlsRequired
+pickleSaslFeature = ignoreAttrs $
-            , saslMechanisms = mechanisms
+  xpElem "mechanisms"
-            , other = features
+    (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-sasl")
-            }
+    (xpList0 $
-
+     xpElemNodes "mechanism" (xpContent xpText) )
-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])
-     ]
-     []
 
+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
+      )
 

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
+  unless (stls features == Nothing) $ do
-      pushE starttlsE
+      pushN starttlsE
-      Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pullE
+      Element "proceed" [("xmlns", "urn:ietf:params:xml:ns:xmpp-tls")] [] <- pullE
       Just handle <- gets sConHandle
-      (src', snk) <- lift $ TLS.tlsinit params handle
+      (raw', snk) <- lift $ TLS.tlsinit params handle
-      src <- lift . bufferSource $ src' $= CT.decode CT.utf8 $= parseText def
+      raw <- lift . bufferSource $ raw'
       modify (\x -> x
-                     { sConSrc = src
+                     { sRawSrc = raw
-                     , sConSink = XR.renderBytes def =$ snk
+--                   , sConSrc =  -- Note: this momentarily leaves us in an
+                                  -- inconsistent state
+                     , sConSink = liftIO . snk
                      })
-      xmppStartStream
+      xmppRestartStream
       modify (\s -> s{sHaveTLS = True})
   gets sHaveTLS
 

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
+import System.IO
-  toText :: a -> Text
 
-class FromText a where
+import Text.XML.Expat.SAX
-  fromText :: Text -> a
+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)
+                      [node,rest] -> (JID (Just (Text.pack node)), rest)
-                      _ -> error $  "Couldn't parse JID: \"" ++ Text.unpack jid ++ "\""
+                      _ -> error $  "Couldn't parse JID: \"" ++ jid ++ "\""
-  in case Text.splitOn "/" rst of
+  in case L.splitOn "/" rst of
-      [domain] -> jid' domain Nothing
+      [domain] -> jid' (Text.pack domain) Nothing
-      [domain, resource] -> jid' domain (Just resource)
+      [domain, resource] -> jid' (Text.pack domain) (Just (Text.pack resource))
-      _ -> error $ "Couldn't parse JID: \"" ++ Text.unpack jid ++ "\""
+      _ -> error $ "Couldn't parse JID: \"" ++ jid ++ "\""
 
-instance IsString JID where
+instance Read JID where
-  fromString = parseJID . Text.pack
+  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
+instance Show MessageType where
-  toText Chat = "chat"
+  show Chat = "chat"
-  toText GroupChat = "groupchat"
+  show GroupChat = "groupchat"
-  toText Headline = "headline"
+  show Headline = "headline"
-  toText Normal = "normal"
+  show Normal = "normal"
-  toText MessageError = "error"
+  show MessageError = "error"
-
+
-instance ToText PresenceType where
+instance Show PresenceType where
-  toText Default = ""
+  show Default = ""
-  toText Unavailable = "unavailable"
+  show Unavailable = "unavailable"
-  toText Subscribe = "subscribe"
+  show Subscribe = "subscribe"
-  toText Subscribed = "subscribed"
+  show Subscribed = "subscribed"
-  toText Unsubscribe = "unsubscribe"
+  show Unsubscribe = "unsubscribe"
-  toText Unsubscribed = "unsubscribed"
+  show Unsubscribed = "unsubscribed"
-  toText Probe = "probe"
+  show Probe = "probe"
-  toText PresenceError = "error"
+  show PresenceError = "error"
-
+
-instance ToText IQType where
+instance Show IQType where
-  toText Get = "get"
+  show Get = "get"
-  toText Result = "result"
+  show Result = "result"
-  toText Set = "set"
+  show Set = "set"
-  toText IQError = "error"
+  show IQError = "error"
-
+
-instance ToText ShowType where
+instance Show ShowType where
-  toText Available = ""
+  show Available = ""
-  toText Away = "away"
+  show Away = "away"
-  toText FreeChat = "chat"
+  show FreeChat = "chat"
-  toText DND = "dnd"
+  show DND = "dnd"
-  toText XAway = "xa"
+  show XAway = "xa"
-
+
-
+
-instance FromText MessageType where
+instance Read MessageType where
-  fromText "chat" = Chat
+  readsPrec _  "chat"         = [( Chat ,"")]
-  fromText "groupchat" = GroupChat
+  readsPrec _  "groupchat"    = [( GroupChat ,"")]
-  fromText "headline" = Headline
+  readsPrec _  "headline"     = [( Headline ,"")]
-  fromText "normal" = Normal
+  readsPrec _  "normal"       = [( Normal ,"")]
-  fromText "error" = MessageError
+  readsPrec _  "error"        = [( MessageError ,"")]
-  fromText "" = Chat
+  readsPrec _  ""             = [( Chat ,"")]
-  fromText _ = error "incorrect message type"
+  readsPrec _  _              = error "incorrect message type"
-
+
-instance FromText PresenceType where
+instance Read PresenceType where
-  fromText "" = Default
+  readsPrec _  ""             = [( Default ,"")]
-  fromText "available" = Default
+  readsPrec _  "available"    = [( Default ,"")]
-  fromText "unavailable" = Unavailable
+  readsPrec _  "unavailable"  = [( Unavailable ,"")]
-  fromText "subscribe" = Subscribe
+  readsPrec _  "subscribe"    = [( Subscribe ,"")]
-  fromText "subscribed" = Subscribed
+  readsPrec _  "subscribed"   = [( Subscribed ,"")]
-  fromText "unsubscribe" = Unsubscribe
+  readsPrec _  "unsubscribe"  = [( Unsubscribe ,"")]
-  fromText "unsubscribed" = Unsubscribed
+  readsPrec _  "unsubscribed" = [( Unsubscribed ,"")]
-  fromText "probe" = Probe
+  readsPrec _  "probe"        = [( Probe ,"")]
-  fromText "error" = PresenceError
+  readsPrec _  "error"        = [( PresenceError ,"")]
-  fromText _ = error "incorrect presence type"
+  readsPrec _  _              =  error "incorrect presence type"
-
+
-instance FromText IQType where
+instance Read IQType where
-  fromText "get" = Get
+  readsPrec _  "get"          = [( Get ,"")]
-  fromText "result" = Result
+  readsPrec _  "result"       = [( Result ,"")]
-  fromText "set" = Set
+  readsPrec _  "set"          = [( Set ,"")]
-  fromText "error" = IQError
+  readsPrec _  "error"        = [( IQError ,"")]
-  fromText "" = Get
+  readsPrec _  ""             = [( Get ,"")]
-  fromText _ = error "incorrect iq type"
+  readsPrec _  _              =  error "incorrect iq type"
-
+
-instance FromText ShowType where
+instance Read ShowType where
-  fromText "" = Available
+  readsPrec _  ""             = [( Available ,"")]
-  fromText "available" = Available
+  readsPrec _  "available"    = [( Available ,"")]
-  fromText "away" = Away
+  readsPrec _  "away"         = [( Away ,"")]
-  fromText "chat" = FreeChat
+  readsPrec _  "chat"         = [( FreeChat ,"")]
-  fromText "dnd" = DND
+  readsPrec _  "dnd"          = [( DND ,"")]
-  fromText "xa" = XAway
+  readsPrec _  "xa"           = [( XAway ,"")]
-  fromText "invisible" = Available
+  readsPrec _  "invisible"    = [( Available ,"")]
-  fromText _ = error "incorrect <show> value"
+  readsPrec _  _              =  error "incorrect <show> value"
-
+
+
+toText :: Show a => a -> Text
+toText   = Text.pack . show
+
+fromText :: Read a => Text -> a
+fromText = read . Text.unpack

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 -> Text -> Text -> Text -> Maybe Text -> IO ((), XMPPState)
-fromHandle handle hostname username password =
+fromHandle handle hostname username password resource =
-  xmppFromHandle handle hostname username Nothing $ do
+  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

src/Text/XML/Stream/Elements.hs

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

src/Utils.hs

@@ -0,0 +1,7 @@
+module Utils where
+
+whileJust f = do
+  f' <- f
+  case f' of
+    Just x -> x : whileJust f
+    Nothing -> []