From f0ebab5774396dc6d22a0dfc2eb4227885f28a1b Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Wed, 9 May 2012 15:36:21 +0200 Subject: [PATCH] renames (pushN -> pushElement, push -> pushStanza, pushOpen -> pushOpenElement, pullSink -> pullToSink, xpStreamEntity -> xpStreamStanza); minor formatting and documentation additions in Monad --- src/Network/XMPP/Marshal.hs | 4 +- src/Network/XMPP/Monad.hs | 140 ++++++++++++++++++++---------------- src/Network/XMPP/Pickle.hs | 1 + src/Network/XMPP/SASL.hs | 6 +- src/Network/XMPP/Stream.hs | 4 +- src/Network/XMPP/TLS.hs | 2 +- 6 files changed, 87 insertions(+), 70 deletions(-) diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index b10db9d..bc46f8a 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/src/Network/XMPP/Marshal.hs @@ -14,8 +14,8 @@ import Data.XML.Types import Network.XMPP.Pickle import Network.XMPP.Types -xpStreamEntity :: PU [Node] (Either XmppStreamError Stanza) -xpStreamEntity = xpEither xpStreamError xpStanza +xpStreamStanza :: PU [Node] (Either XmppStreamError Stanza) +xpStreamStanza = xpEither xpStreamError xpStanza xpStanza :: PU [Node] Stanza xpStanza = xpAlt stanzaSel diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 9b9e65c..9d3297d 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -32,36 +32,38 @@ import Text.XML.Stream.Elements import Text.XML.Stream.Parse as XP import Text.XML.Unresolved(InvalidEventStream(..)) -pushN :: Element -> XMPPConMonad Bool -pushN x = do - sink <- gets sConPushBS - liftIO . sink $ renderElement x - -push :: Stanza -> XMPPConMonad Bool -push = pushN . pickleElem xpStanza - -pushOpen :: Element -> XMPPConMonad Bool -pushOpen e = do - sink <- gets sConPushBS - liftIO . sink $ renderOpenElement e - -pullSink :: Sink Event IO b -> XMPPConMonad b -pullSink snk = do - source <- gets sConSrc - (_, r) <- lift $ source $$+ snk - return r +pushElement :: Element -> XMPPConMonad Bool +pushElement x = do + sink <- gets sConPushBS + liftIO . sink $ renderElement x + +pushStanza :: Stanza -> XMPPConMonad Bool +pushStanza = pushElement . pickleElem xpStanza + +pushOpenElement :: Element -> XMPPConMonad Bool +pushOpenElement e = do + sink <- gets sConPushBS + liftIO . sink $ renderOpenElement e + +-- `Connect-and-resumes' the given sink to the connection source, and pulls a +-- `b' value. +pullToSink :: Sink Event IO b -> XMPPConMonad b +pullToSink snk = do + source <- gets sConSrc + (_, r) <- lift $ source $$+ snk + return r pullElement :: XMPPConMonad Element pullElement = do Ex.catch (do - e <- pullSink (elements =$ CL.head) + e <- pullToSink (elements =$ CL.head) case e of Nothing -> liftIO $ Ex.throwIO StreamConnectionError Just r -> return r ) (\(InvalidEventStream s) -> liftIO . Ex.throwIO $ StreamXMLError s) - +-- Pulls an element and unpickles it. pullPickle :: PU [Node] a -> XMPPConMonad a pullPickle p = do res <- unpickleElem p <$> pullElement @@ -69,27 +71,30 @@ pullPickle p = do Left e -> liftIO . Ex.throwIO $ StreamXMLError e Right r -> return r +-- Pulls a stanza from the stream. Throws an error on failure. pullStanza :: XMPPConMonad Stanza pullStanza = do - res <- pullPickle xpStreamEntity + res <- pullPickle xpStreamStanza case res of Left e -> liftIO . Ex.throwIO $ StreamError e Right r -> return r -catchPush p = Ex.catch (p >> return True) - (\e -> case GIE.ioe_type e of - GIE.ResourceVanished -> return False - _ -> Ex.throwIO e - ) - -zeroSource :: Source IO output -zeroSource = liftIO . Ex.throwIO $ StreamConnectionError - +-- Performs the given IO operation, catches any errors and re-throws everything +-- except the `ResourceVanished' error. +catchPush :: IO () -> IO Bool +catchPush p = Ex.catch + (p >> return True) + (\e -> case GIE.ioe_type e of + GIE.ResourceVanished -> return False + _ -> Ex.throwIO e + ) + +-- XmppConnection state used when there is no connection. xmppNoConnection :: XmppConnection xmppNoConnection = XmppConnection { sConSrc = zeroSource , sRawSrc = zeroSource - , sConPushBS = \_ -> return False + , sConPushBS = \_ -> return False -- Nothing has been sent. , sConHandle = Nothing , sFeatures = SF Nothing [] [] , sConnectionState = XmppConnectionClosed @@ -98,51 +103,62 @@ xmppNoConnection = XmppConnection , sResource = Nothing , sCloseConnection = return () } + where + zeroSource :: Source IO output + zeroSource = liftIO . Ex.throwIO $ StreamConnectionError +-- Connects to the given hostname on port 5222 (TODO: Make this dynamic) and +-- updates the XMPPConMonad XmppConnection state. xmppRawConnect :: HostName -> Text -> XMPPConMonad () xmppRawConnect host hostname = do - uname <- gets sUsername - con <- liftIO $ do - con <- connectTo host (PortNumber 5222) - hSetBuffering con NoBuffering - return con - let raw = sourceHandle con - src <- liftIO . bufferSource $ raw $= XP.parseBytes def - let st = XmppConnection - src - (raw) - (catchPush . BS.hPut con) - (Just con) - (SF Nothing [] []) - XmppConnectionPlain - (Just hostname) - uname - Nothing - (hClose con) - put st - + uname <- gets sUsername + con <- liftIO $ do + con <- connectTo host (PortNumber 5222) + hSetBuffering con NoBuffering + return con + let raw = sourceHandle con + src <- liftIO . bufferSource $ raw $= XP.parseBytes def + let st = XmppConnection + src + raw + (catchPush . BS.hPut con) + (Just con) + (SF Nothing [] []) + XmppConnectionPlain + (Just hostname) + uname + Nothing + (hClose con) + put st + +-- Execute a XMPPConMonad computation. xmppNewSession :: XMPPConMonad a -> IO (a, XmppConnection) -xmppNewSession action = do - runStateT action xmppNoConnection +xmppNewSession action = runStateT action xmppNoConnection +-- Closes the connection and updates the XMPPConMonad XmppConnection state. xmppKillConnection :: XMPPConMonad () xmppKillConnection = do cc <- gets sCloseConnection void . liftIO $ (Ex.try cc :: IO (Either Ex.SomeException ())) put xmppNoConnection -xmppSendIQ' :: StanzaId -> Maybe JID -> IQRequestType - -> Maybe LangTag -> Element +-- Sends an IQ request and waits for the response. If the response ID does not +-- match the outgoing ID, an error is thrown. +xmppSendIQ' :: StanzaId + -> Maybe JID + -> IQRequestType + -> Maybe LangTag + -> Element -> XMPPConMonad (Either IQError IQResult) xmppSendIQ' iqID to tp lang body = do - push . IQRequestS $ IQRequest iqID Nothing to lang tp body + pushStanza . IQRequestS $ IQRequest iqID Nothing to lang tp body res <- pullPickle $ xpEither xpIQError xpIQResult case res of Left e -> return $ Left e Right iq' -> do - unless (iqID == iqResultID iq') . liftIO . Ex.throwIO $ - StreamXMLError - ("In xmppSendIQ' IDs don't match: " ++ show iqID ++ - " /= " ++ show (iqResultID iq') ++ " .") - return $ Right iq' - + unless + (iqID == iqResultID iq') . liftIO . Ex.throwIO $ + StreamXMLError + ("In xmppSendIQ' IDs don't match: " ++ show iqID ++ " /= " ++ + show (iqResultID iq') ++ " .") + return $ Right iq' \ No newline at end of file diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index 035fb12..e922903 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -73,6 +73,7 @@ unpickleElem' p x = case unpickle (xpNodeElem p) x of Left l -> error $ l ++ "\n saw: " ++ ppElement x Right r -> r +-- Given a pickler and an element, produces an object. unpickleElem :: PU [Node] a -> Element -> Either String a unpickleElem p x = unpickle (xpNodeElem p) x diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index a820f1d..7fb1b99 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -66,7 +66,7 @@ xmppSASL uname passwd = runErrorT $ do unless ("DIGEST-MD5" `elem` mechanisms) . throwError $ AuthMechanismError mechanisms -- Push element and receive the challenge (in XMPPConMonad). - _ <- lift . pushN $ saslInitE "DIGEST-MD5" -- TODO: Check boolean? + _ <- lift . pushElement $ saslInitE "DIGEST-MD5" -- TODO: Check boolean? challenge' <- lift $ B64.decode . Text.encodeUtf8 <$> pullPickle challengePickle challenge <- case challenge' of @@ -76,13 +76,13 @@ xmppSASL uname passwd = runErrorT $ do Left _ -> throwError AuthChallengeError Right p -> return p g <- liftIO Random.newStdGen - _ <- lift . pushN . -- TODO: Check boolean? + _ <- lift . pushElement . -- TODO: Check boolean? saslResponseE $ createResponse g realm pairs challenge2 <- lift $ pullPickle (xpEither failurePickle challengePickle) case challenge2 of Left _x -> throwError AuthXmlError Right _ -> return () - lift $ pushN saslResponse2E + lift $ pushElement saslResponse2E e <- lift pullElement case e of Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] -> diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index 62c5fb6..94da48f 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -61,9 +61,9 @@ xmppStartStream = runErrorT $ do hostname' <- gets sHostname case hostname' of Nothing -> throwError StreamConnectionError - Just hostname -> lift . pushOpen $ + Just hostname -> lift . pushOpenElement $ pickleElem pickleStream ("1.0", Nothing, Just hostname) - features <- ErrorT . pullSink $ runErrorT xmppStream + features <- ErrorT . pullToSink $ runErrorT xmppStream modify (\s -> s {sFeatures = features}) return () diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index 21e49c9..c74c251 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -53,7 +53,7 @@ startTLS params = Ex.handle (return . Left . TLSError) . runErrorT $ do handle' <- lift $ gets sConHandle handle <- maybe (throwError TLSNoConnection) return handle' when (stls features == Nothing) $ throwError TLSNoServerSupport - lift $ pushN starttlsE + lift $ pushElement starttlsE answer <- lift $ pullElement case answer of Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return ()