From 19a3005db61081b171718ed6f3dcdc568c66cf2e Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 5 Apr 2012 13:12:06 +0200 Subject: [PATCH] warning clean --- src/{Main.hs => Example.hs} | 15 +++----- src/Network/XMPP.hs | 38 +++++--------------- src/Network/XMPP/Bind.hs | 8 ++--- src/Network/XMPP/Concurrent.hs | 66 +++++++++++++++------------------- src/Network/XMPP/Marshal.hs | 35 ++++++++---------- src/Network/XMPP/Monad.hs | 24 +++++-------- src/Network/XMPP/Pickle.hs | 16 +++------ src/Network/XMPP/SASL.hs | 47 +++++++++++++----------- src/Network/XMPP/Session.hs | 11 ++---- src/Network/XMPP/Stream.hs | 43 ++++++++++------------ src/Network/XMPP/TLS.hs | 36 ++++++++----------- 11 files changed, 132 insertions(+), 207 deletions(-) rename src/{Main.hs => Example.hs} (76%) diff --git a/src/Main.hs b/src/Example.hs similarity index 76% rename from src/Main.hs rename to src/Example.hs index 1cff5af..c17b738 100644 --- a/src/Main.hs +++ b/src/Example.hs @@ -1,17 +1,12 @@ {-# LANGUAGE PackageImports, OverloadedStrings #-} -module Main where +module Example where import Data.Text as T import Network.XMPP -import Network.XMPP.Concurrent -import Network.XMPP.Types -import Network -import GHC.IO.Handle import Control.Concurrent import Control.Concurrent.STM import Control.Monad -import Control.Monad.Trans.State import Control.Monad.IO.Class philonous :: JID @@ -24,18 +19,18 @@ autoAccept :: XMPPThread () autoAccept = forever $ do st <- pullPresence case st of - Presence from _ id (Just Subscribe) _ _ _ _ -> + Presence from _ idq (Just Subscribe) _ _ _ _ -> sendS . SPresence $ - Presence Nothing from id (Just Subscribed) Nothing Nothing Nothing [] + Presence Nothing from idq (Just Subscribed) Nothing Nothing Nothing [] _ -> return () mirror :: XMPPThread () mirror = forever $ do st <- pullMessage case st of - Message (Just from) _ id tp subject (Just bd) thr _ -> + Message (Just from) _ idq tp subject (Just bd) thr _ -> sendS . SMessage $ - Message Nothing from id tp subject + Message Nothing from idq tp subject (Just $ "you wrote: " `T.append` bd) thr [] _ -> return () diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index dd5ba75..2680dbe 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -12,12 +12,6 @@ module Network.XMPP , sessionConnect ) where -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.State - -import qualified Data.ByteString as BS import Data.Text as Text import Network @@ -35,45 +29,29 @@ import System.IO --fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> IO ((), XMPPState) fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> XMPPThread a -> IO ((), XMPPState) -fromHandle handle hostname username resource password a = - xmppFromHandle handle hostname username resource $ do +fromHandle handle hostname username rsrc password a = + xmppFromHandle handle hostname username rsrc $ do xmppStartStream -- this will check whether the server supports tls -- on it's own xmppStartTLS exampleParams xmppSASL password - xmppBind resource + xmppBind rsrc xmppSession - runThreaded a - return () - ---fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> IO ((), XMPPState) -fromHandle' :: Handle -> Text -> Text -> Maybe Text -> Text -> XMPPThread a - -> IO ((), XMPPState) -fromHandle' handle hostname username resource password a = - xmppFromHandle handle hostname username resource $ do - xmppStartStream - runThreaded $ do - -- this will check whether the server supports tls - -- on it's own - singleThreaded $ xmppStartTLS exampleParams - singleThreaded $ xmppSASL password - singleThreaded $ xmppBind resource - singleThreaded $ xmppSession - a + _ <- runThreaded a return () connectXMPP :: HostName -> Text -> Text -> Maybe Text -> Text -> XMPPThread a -> IO ((), XMPPState) -connectXMPP host hostname username resource passwd a = do +connectXMPP host hostname username rsrc passwd a = do con <- connectTo host (PortNumber 5222) hSetBuffering con NoBuffering - fromHandle' con hostname username resource passwd a + fromHandle con hostname username rsrc passwd a sessionConnect :: HostName -> Text -> Text -> Maybe Text -> XMPPThread a -> IO (a, XMPPState) -sessionConnect host hostname username resource a = do +sessionConnect host hostname username rsrc a = do con <- connectTo host (PortNumber 5222) hSetBuffering con NoBuffering - xmppFromHandle con hostname username resource $ + xmppFromHandle con hostname username rsrc $ xmppStartStream >> runThreaded a diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index 4d1e812..1434e79 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -12,16 +12,14 @@ import Data.XML.Types import Network.XMPP.Monad import Network.XMPP.Types import Network.XMPP.Pickle -import Network.XMPP.Marshal - bindReqIQ :: Maybe Text -> Stanza -bindReqIQ resource= SIQ $ IQ Nothing Nothing "bind" Set +bindReqIQ rsrc= SIQ $ IQ Nothing Nothing "bind" Set (pickleElem (bindP . xpOption $ xpElemNodes "resource" (xpContent xpId)) - resource + rsrc ) jidP :: PU [Node] JID @@ -32,7 +30,7 @@ xmppBind res = do push $ bindReqIQ res answer <- pull let SIQ (IQ Nothing Nothing _ Result b) = answer - let (JID n d (Just r)) = unpickleElem jidP b + let (JID _n _d (Just r)) = unpickleElem jidP b modify (\s -> s{sResource = Just r}) bindP :: PU [Node] b -> PU [Node] b diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs index c2b6a96..9c9299b 100644 --- a/src/Network/XMPP/Concurrent.hs +++ b/src/Network/XMPP/Concurrent.hs @@ -13,9 +13,6 @@ import Network.XMPP.Types import Control.Applicative((<$>),(<*>)) import Control.Concurrent import Control.Concurrent.STM -import Control.Concurrent.STM.TChan -import Control.Concurrent.STM.TMVar -import Control.Exception (throwTo) import qualified Control.Exception.Lifted as Ex import Control.Monad import Control.Monad.IO.Class @@ -24,38 +21,33 @@ import Control.Monad.Trans.Reader import Control.Monad.Trans.Resource import Control.Monad.Trans.State - import qualified Data.ByteString as BS import Data.Conduit import qualified Data.Conduit.List as CL import Data.Default (def) import Data.IORef import qualified Data.Map as Map -import Data.Maybe import qualified Data.Text as Text import Data.Text(Text) import Data.Typeable 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.Stream.Elements import qualified Text.XML.Stream.Render as XR +type IQHandlers = (Map.Map (IQType, Text) (TChan IQ), Map.Map Text (TMVar IQ)) + data Thread = Thread { messagesRef :: IORef (Maybe (TChan Message)) , presenceRef :: IORef (Maybe (TChan Presence)) , mShadow :: TChan Message -- the original chan , pShadow :: TChan Presence -- the original chan , outCh :: TChan Stanza - , iqHandlers :: TVar ( Map.Map (IQType, Text) (TChan IQ) - , Map.Map Text (TMVar IQ) - ) + , iqHandlers :: TVar IQHandlers , writeRef :: TMVar (BS.ByteString -> IO () ) , readerThread :: ThreadId , idGenerator :: IO Text @@ -95,16 +87,17 @@ readWorker messageC presenceC iqC s = Ex.catch (forever . flip runStateT s $ do ) writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO ()) -> IO () -writeWorker stCh writeRef = forever $ do +writeWorker stCh writeR = forever $ do (write, next) <- atomically $ (,) <$> - takeTMVar writeRef <*> + takeTMVar writeR <*> readTChan stCh outBS <- CL.sourceList (elementToEvents $ pickleElem stanzaP next) $= XR.renderBytes def $$ CL.consume - forM outBS write - atomically $ putTMVar writeRef write + _ <- forM outBS write + atomically $ putTMVar writeR write +handleIQs :: MonadIO m => TVar IQHandlers -> TChan IQ -> m a handleIQs handlers iqC = liftIO . forever . atomically $ do iq <- readTChan iqC (byNS, byID) <- readTVar handlers @@ -118,13 +111,15 @@ handleIQs handlers iqC = liftIO . forever . atomically $ do Set -> case Map.lookup (Set, iqNS) byNS of Nothing -> return () -- TODO: send error stanza Just ch -> writeTChan ch iq - Result -> case Map.updateLookupWithKey (\_ _ -> Nothing) + -- Result / Error : + _ -> case Map.updateLookupWithKey (\_ _ -> Nothing) (iqId iq) byID of (Nothing, _) -> return () -- we are not supposed -- to send an error (Just tmvar, byID') -> do - tryPutTMVar tmvar iq -- don't block - writeTVar handlers (byNS, byID) + _ <- tryPutTMVar tmvar iq -- don't block + writeTVar handlers (byNS, byID') + -- Two streams: input and output. Threads read from input stream and write to output stream. @@ -149,25 +144,17 @@ startThreads = do presenceC <- liftIO newTChanIO iqC <- liftIO newTChanIO outC <- liftIO newTChanIO - iqHandlers <- liftIO $ newTVarIO ( Map.empty, Map.empty) - pushEvents <- gets sConPush - pushBS <- gets sConPushBS + handlers <- liftIO $ newTVarIO ( Map.empty, Map.empty) lw <- liftIO . forkIO $ writeWorker outC writeLock cp <- liftIO . forkIO $ connPersist writeLock - iqh <- liftIO . forkIO $ handleIQs iqHandlers iqC + iqh <- liftIO . forkIO $ handleIQs handlers iqC s <- get rd <- lift . resourceForkIO $ readWorker messageC presenceC iqC s - return (messageC, presenceC, iqHandlers, outC, killConnection writeLock [lw, rd, cp], writeLock, rd) + return (messageC, presenceC, handlers, outC, killConnection writeLock [lw, rd, cp, iqh], writeLock, rd) where - loopWrite writeLock pushEvents out' = forever $ do - next <- liftIO . atomically $ ( takeTMVar writeLock - >> readTChan out') - pushEvents . elementToEvents $ pickleElem stanzaP next - liftIO . atomically $ putTMVar writeLock () - killConnection writeLock threads = liftIO $ do - atomically $ takeTMVar writeLock - forM threads killThread + _ <- atomically $ takeTMVar writeLock -- Should we put it back? + _ <- forM threads killThread return() @@ -195,7 +182,7 @@ listenIQChan tp ns = do runThreaded :: XMPPThread a -> XMPPMonad a runThreaded a = do - (mC, pC, hand, outC, stopThreads, writeR, reader ) <- startThreads + (mC, pC, hand, outC, _stopThreads, writeR, rdr ) <- startThreads workermCh <- liftIO . newIORef $ Nothing workerpCh <- liftIO . newIORef $ Nothing idRef <- liftIO $ newTVarIO 1 @@ -203,13 +190,14 @@ runThreaded a = do curId <- readTVar idRef writeTVar idRef (curId + 1 :: Integer) return . Text.pack $ show curId - liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR reader getId) + liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR rdr getId) -- | get the inbound stanza channel, duplicates from master if necessary -- please note that once duplicated it will keep filling up, call -- 'dropMessageChan' to allow it to be garbage collected +getMessageChan :: XMPPThread (TChan Message) getMessageChan = do mChR <- asks messagesRef mCh <- liftIO $ readIORef mChR @@ -219,9 +207,10 @@ getMessageChan = do mCh' <- liftIO $ atomically $ dupTChan shadow liftIO $ writeIORef mChR (Just mCh') return mCh' - Just mCh -> return mCh + Just mCh' -> return mCh' -- | see 'getMessageChan' +getPresenceChan :: XMPPThread (TChan Presence) getPresenceChan = do pChR <- asks presenceRef pCh <- liftIO $ readIORef pChR @@ -231,7 +220,7 @@ getPresenceChan = do pCh' <- liftIO $ atomically $ dupTChan shadow liftIO $ writeIORef pChR (Just pCh') return pCh' - 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 @@ -313,9 +302,10 @@ connPersist lock = forever $ do singleThreaded :: XMPPMonad () -> XMPPThread () singleThreaded a = do writeLock <- asks writeRef - reader <- asks readerThread - liftIO . atomically $ takeTMVar writeLock - liftIO . throwTo reader . ReaderSignal $ do + rdr <- asks readerThread + _ <- liftIO . atomically $ takeTMVar writeLock -- we replace it with the + -- one returned by a + liftIO . throwTo rdr . ReaderSignal $ do a out <- gets sConPushBS liftIO . atomically $ putTMVar writeLock out diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index b507230..b079e36 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/src/Network/XMPP/Marshal.hs @@ -2,20 +2,13 @@ module Network.XMPP.Marshal where -import Control.Applicative((<$>)) +import Data.XML.Pickle +import Data.XML.Types -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 Network.XMPP.Types +stanzaSel :: Num a => Stanza -> a stanzaSel (SMessage _) = 0 stanzaSel (SPresence _) = 1 stanzaSel (SIQ _) = 2 @@ -28,10 +21,10 @@ stanzaP = xpAlt stanzaSel ] 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) - -> ((from, to, id, tp), (sub, body, thr,ext))) +messageP = xpWrap (\((from, to, qid, tp),(sub, body, thr,ext)) + -> Message from to qid tp sub body thr ext) + (\(Message from to qid tp sub body thr ext) + -> ((from, to, qid, tp), (sub, body, thr,ext))) $ xpElem "{jabber:client}message" (xp4Tuple @@ -48,10 +41,10 @@ messageP = xpWrap (\((from, to, id, tp),(sub, body, thr,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) - -> ((from, to, id, tp), (shw, stat, prio, ext))) +presenceP = xpWrap (\((from, to, qid, tp),(shw, stat, prio, ext)) + -> Presence from to qid tp shw stat prio ext) + (\(Presence from to qid tp shw stat prio ext) + -> ((from, to, qid, tp), (shw, stat, prio, ext))) $ xpElem "{jabber:client}presence" (xp4Tuple @@ -68,8 +61,8 @@ presenceP = xpWrap (\((from, to, id, tp),(shw, stat, prio, ext)) ) 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)) +iqP = xpWrap (\((from, to, qid, tp),body) -> IQ from to qid tp body) + (\(IQ from to qid tp body) -> ((from, to, qid, tp), body)) $ xpElem "{jabber:client}iq" (xp4Tuple diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 4449b8d..dac363a 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -3,32 +3,19 @@ module Network.XMPP.Monad where 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 -import Data.Default(def) -import Data.Text(Text) - import Data.Conduit import Data.Conduit.Binary as CB --- import Data.Conduit.Hexpat as CH import Data.Conduit.List as CL -import Data.Conduit.Text as CT import Data.Conduit.TLS - +import Data.Text(Text) import Data.XML.Pickle import Data.XML.Types -import Text.XML.Stream.Parse as XP -import Text.XML.Stream.Render as XR -import Text.XML.Stream.Elements - - -import qualified Data.Text as Text import Network.XMPP.Types import Network.XMPP.Marshal @@ -36,6 +23,11 @@ import Network.XMPP.Pickle import System.IO +import Text.XML.Stream.Elements +import Text.XML.Stream.Parse as XP +import Text.XML.Stream.Render as XR + + pushN :: Element -> XMPPMonad () pushN x = do sink <- gets sConPush @@ -70,7 +62,7 @@ xmppFromHandle :: Handle -> Text -> Text -> Maybe Text -> XMPPMonad a -> IO (a, XMPPState) -xmppFromHandle handle hostname username resource f = runResourceT $ do +xmppFromHandle handle hostname username res f = runResourceT $ do liftIO $ hSetBuffering handle NoBuffering let raw = CB.sourceHandle handle $= conduitStdout let src = raw $= XP.parseBytes def @@ -85,6 +77,6 @@ xmppFromHandle handle hostname username resource f = runResourceT $ do False hostname username - resource + res runStateT f st diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index 37ef35c..4260086 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -7,20 +7,11 @@ module Network.XMPP.Pickle where -import Control.Applicative((<$>)) - -import qualified Data.ByteString as BS - -import qualified Data.Text as Text -import Data.Text.Encoding as Text - import Data.XML.Types import Data.XML.Pickle -import Network.XMPP.Types - - +mbToBool :: Maybe t -> Bool mbToBool (Just _) = True mbToBool _ = False @@ -38,8 +29,8 @@ xpElemEmpty name = xpWrap (\((),()) -> ()) 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)) @@ -48,12 +39,15 @@ xpNodeElem xp = PU { pickleTree = \x -> head $ (pickleTree xp x) >>= \y -> ignoreAttrs :: PU t ((), b) -> PU t b ignoreAttrs = xpWrap snd ((),) +mbl :: Maybe [a] -> [a] mbl (Just l) = l mbl Nothing = [] +lmb :: [t] -> Maybe [t] lmb [] = Nothing lmb x = Just x +right :: Either [Char] t -> t right (Left l) = error l right (Right r) = r diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 71b00b8..db91276 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -1,38 +1,31 @@ {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} module Network.XMPP.SASL where -import Control.Applicative -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.State +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.State import qualified Crypto.Classes as CC import qualified Data.Attoparsec.ByteString.Char8 as AP import qualified Data.Binary as Binary import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BL8 -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.List as L +import Data.XML.Pickle +import Data.XML.Types import qualified Data.Text as Text -import Data.Text(Text) -import Data.Text (Text) +import Data.Text (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 +import Network.XMPP.Monad +import Network.XMPP.Stream +import Network.XMPP.Types import qualified System.Random as Random @@ -66,7 +59,7 @@ xmppSASL passwd = do challenge2 <- pullPickle (xpEither failurePickle challengePickle) case challenge2 of Left x -> error $ show x - Right c -> return () + Right _ -> return () pushN saslResponse2E Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pullE xmppRestartStream @@ -111,7 +104,7 @@ toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)] toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do AP.skipSpace name <- AP.takeWhile1 (/= '=') - AP.char '=' + _ <- AP.char '=' quote <- ((AP.char '"' >> return True) `mplus` return False) content <- AP.takeWhile1 (AP.notInClass ",\"" ) when quote . void $ AP.char '"' @@ -125,8 +118,20 @@ hashRaw :: [BS8.ByteString] -> BS8.ByteString hashRaw = toStrict . Binary.encode . (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":") +toStrict :: BL.ByteString -> BS8.ByteString toStrict = BS.concat . BL.toChunks + -- TODO: this only handles MD5-sess + +md5Digest :: BS8.ByteString + -> BS8.ByteString + -> BS8.ByteString + -> BS8.ByteString + -> BS8.ByteString + -> BS8.ByteString + -> BS8.ByteString + -> BS8.ByteString + -> BS8.ByteString md5Digest uname realm password digestURI nc qop nonce cnonce= let ha1 = hash [hashRaw [uname,realm,password], nonce, cnonce] ha2 = hash ["AUTHENTICATE", digestURI] diff --git a/src/Network/XMPP/Session.hs b/src/Network/XMPP/Session.hs index fe8a696..a9b5e1c 100644 --- a/src/Network/XMPP/Session.hs +++ b/src/Network/XMPP/Session.hs @@ -2,18 +2,11 @@ module Network.XMPP.Session where -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 Network.XMPP.Types sessionIQ :: Stanza sessionIQ = SIQ $ IQ Nothing Nothing "sess" Set @@ -26,5 +19,5 @@ xmppSession :: XMPPMonad () xmppSession = do push $ sessionIQ answer <- pull - let SIQ (IQ Nothing Nothing "sess" Result b) = answer + let SIQ (IQ Nothing Nothing "sess" Result _body) = answer return () \ No newline at end of file diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index 3bf5e98..1f4f285 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -3,33 +3,26 @@ module Network.XMPP.Stream where -import Control.Applicative((<$>)) -import Control.Monad(unless, forever) -import Control.Monad.Trans.Class -import Control.Monad.Trans.State -import Control.Monad.IO.Class - -import Network.XMPP.Monad -import Network.XMPP.Pickle -import Network.XMPP.Types - -import Data.Conduit -import Data.Default(def) --- import qualified Data.Conduit.Hexpat as CH -import Data.Conduit.List as CL -import Data.Conduit.Text as CT -import Data.Default(def) -import qualified Data.List as L -import Data.Text as T -import Data.XML.Pickle -import Data.XML.Types - --- import qualified Text.XML.Stream.Parse as XP -import Text.XML.Stream.Elements -import Text.XML.Stream.Parse as XP +import Control.Applicative((<$>)) +import Control.Monad(unless) +import Control.Monad.Trans.State + +import Data.Conduit +import Data.Conduit.List as CL +import Data.Text as T +import Data.XML.Pickle +import Data.XML.Types + +import Network.XMPP.Monad +import Network.XMPP.Pickle +import Network.XMPP.Types + +import Text.XML.Stream.Elements +import Text.XML.Stream.Parse as XP -- import Text.XML.Stream.Elements +throwOutJunk :: Monad m => Sink Event m () throwOutJunk = do next <- CL.peek case next of @@ -37,6 +30,7 @@ throwOutJunk = do Just (EventBeginElement _ _) -> return () _ -> CL.drop 1 >> throwOutJunk +openElementFromEvents :: Monad m => Sink Event m Element openElementFromEvents = do throwOutJunk Just (EventBeginElement name attrs) <- CL.head @@ -54,7 +48,6 @@ xmppStartStream = do xmppRestartStream :: XMPPMonad () xmppRestartStream = do raw <- gets sRawSrc - src <- gets sConSrc let newsrc = raw $= XP.parseBytes def modify (\s -> s{sConSrc = newsrc}) xmppStartStream diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index c71338d..fde5633 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -2,25 +2,19 @@ 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.Text as CT -import Data.Conduit.TLS as TLS -import Data.Conduit.List as CL -import qualified Data.List as L +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.State + +import Data.Conduit +import Data.Conduit.List as CL +import Data.Conduit.TLS as TLS +import Data.Default +import Data.XML.Types + +import Network.XMPP.Monad +import Network.XMPP.Stream +import Network.XMPP.Types import qualified Text.XML.Stream.Render as XR @@ -40,14 +34,14 @@ xmppStartTLS params = do pushN starttlsE Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pullE Just handle <- gets sConHandle - (raw, snk, push) <- lift $ TLS.tlsinit params handle + (raw, snk, psh) <- lift $ TLS.tlsinit params handle modify (\x -> x { sRawSrc = raw -- , sConSrc = -- Note: this momentarily leaves us in an -- inconsistent state , sConPush = \xs -> CL.sourceList xs $$ XR.renderBytes def =$ snk - , sConPushBS = push + , sConPushBS = psh }) xmppRestartStream modify (\s -> s{sHaveTLS = True})