From ac8e907e5c173e27a76c79d2f93c915ba2c9678e Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 26 Mar 2012 22:33:57 +0200 Subject: [PATCH] compiles... again --- src/Data/Conduit/TLS.hs | 23 +++-- src/Network/XMPP/Bind.hs | 15 ++-- src/Network/XMPP/Concurrent.hs | 153 ++++++++++++++++++++++---------- src/Network/XMPP/Marshal.hs | 62 ++++++------- src/Network/XMPP/Monad.hs | 36 ++++---- src/Network/XMPP/Pickle.hs | 71 +++++++-------- src/Network/XMPP/SASL.hs | 49 +++++----- src/Network/XMPP/Session.hs | 12 ++- src/Network/XMPP/Stream.hs | 55 ++++++++---- src/Network/XMPP/TLS.hs | 19 ++-- src/Network/XMPP/Types.hs | 29 +++--- src/Text/XML/Stream/Elements.hs | 78 ++++++++++++++++ 12 files changed, 381 insertions(+), 221 deletions(-) create mode 100644 src/Text/XML/Stream/Elements.hs diff --git a/src/Data/Conduit/TLS.hs b/src/Data/Conduit/TLS.hs index 261464b..917eb5e 100644 --- a/src/Data/Conduit/TLS.hs +++ b/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) - return (src + 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 ()) diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index 8857bcd..249b122 100644 --- a/src/Network/XMPP/Bind.hs +++ b/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 diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs index 5fe1519..a1e82a4 100644 --- a/src/Network/XMPP/Concurrent.hs +++ b/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 diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index c95ce3c..18b5600 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/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 +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) diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 2db6c84..9121a0a 100644 --- a/src/Network/XMPP/Monad.hs +++ b/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 diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index d171a6e..37ef35c 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/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 \ No newline at end of file +unpickleElem :: PU [Node] c -> Element -> c +unpickleElem p = right . unpickle (xpNodeElem p) + +pickleElem :: PU [Node] a -> a -> Element +pickleElem p = pickle $ xpNodeElem p + + + diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 21a8632..3066c3b 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -19,8 +19,11 @@ 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 @@ -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) diff --git a/src/Network/XMPP/Session.hs b/src/Network/XMPP/Session.hs index 6d90975..fe8a696 100644 --- a/src/Network/XMPP/Session.hs +++ b/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 () diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index 223fc89..bdd04ad 100644 --- a/src/Network/XMPP/Stream.hs +++ b/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) ) diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index de310a4..3ab79c8 100644 --- a/src/Network/XMPP/TLS.hs +++ b/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}) diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index 846e757..76ec5db 100644 --- a/src/Network/XMPP/Types.hs +++ b/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,11 +53,12 @@ data ServerFeatures = SF } deriving Show -def = SF - { stls = Nothing - , saslMechanisms = [] - , other = [] - } +instance Default ServerFeatures where + def = SF + { stls = Nothing + , saslMechanisms = [] + , other = [] + } -- Ugh, that smells a bit. @@ -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 diff --git a/src/Text/XML/Stream/Elements.hs b/src/Text/XML/Stream/Elements.hs new file mode 100644 index 0000000..3812752 --- /dev/null +++ b/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]