From 113ca4034fca122d0a0a9b48dec77cb9913ff1a3 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 18 Apr 2012 19:28:01 +0200 Subject: [PATCH 01/29] work in JID.hs --- src/Network/XMPP/JID.hs | 232 ++++++++++++++++------------------------ 1 file changed, 93 insertions(+), 139 deletions(-) diff --git a/src/Network/XMPP/JID.hs b/src/Network/XMPP/JID.hs index 2076f94..5b6f1fd 100644 --- a/src/Network/XMPP/JID.hs +++ b/src/Network/XMPP/JID.hs @@ -15,183 +15,137 @@ -- -- This module does not internationalize hostnames. - module Network.XMPP.JID (fromString, fromStrings, isBare, isFull) where -import Network.XMPP.Types - -import Data.Maybe (fromJust, isJust) -import Text.Parsec ((<|>), anyToken, char, eof, many, noneOf, parse) -import Text.Parsec.ByteString (GenParser) +import Control.Applicative ((<$>),(<|>)) +import Control.Monad(guard) -import Text.StringPrep (StringPrepProfile (..), a1, b1, b2, c11, c12, c21, c22, - c3, c4, c5, c6, c7, c8, c9, runStringPrep) -import Text.NamePrep (namePrepProfile) +import qualified Data.Attoparsec.Text as AP +import Data.Text (Text) +import qualified Data.Text as Text -import Network.URI (isIPv4address, isIPv6address) - -import qualified Data.ByteString.Char8 as DBC (pack) -import qualified Data.Text as DT (pack, unpack) +-- import Network.URI (isIPv4address, isIPv6address) +import Network.XMPP.Types +import qualified Text.NamePrep as SP +import qualified Text.StringPrep as SP -- | -- Converts a string to a JID. - fromString :: String -> Maybe JID - -fromString s = fromStrings localpart domainpart resourcepart +fromString s = fromStrings l d r where - Right (localpart, domainpart, resourcepart) = - parse jidParts "" (DBC.pack s) - + Right (l, d, r) = + AP.parseOnly jidParts (Text.pack s) -- | -- Converts localpart, domainpart, and resourcepart strings to a JID. - -- Runs the appropriate stringprep profiles and validates the parts. - -fromStrings :: Maybe String -> String -> Maybe String -> Maybe JID - -fromStrings l s r - | domainpart == Nothing = Nothing - | otherwise = if validateNonDomainpart localpart && - isJust domainpart' && - validateNonDomainpart resourcepart - then Just (JID localpart (fromJust domainpart') resourcepart) - else Nothing +fromStrings :: Maybe Text -> Text -> Maybe Text -> Maybe JID +fromStrings l d r = do + localPart <- case l of + Nothing -> return Nothing + Just l'-> do + l'' <- SP.runStringPrep nodeprepProfile l' + guard $ validPartLength l'' + return $ Just l'' + domainPart <- SP.runStringPrep (SP.namePrepProfile False) d + guard $ validDomainPart domainPart + resourcePart <- case r of + Nothing -> return Nothing + Just r' -> do + r'' <- SP.runStringPrep resourceprepProfile r' + guard $ validPartLength r'' + return $ Just r'' + return $ JID localPart domainPart resourcePart where - - -- Applies the nodeprep profile on the localpart string, if any. - localpart :: Maybe String - localpart = case l of - Just l' -> case runStringPrep nodeprepProfile (DT.pack l') of - Just l'' -> Just $ DT.unpack l'' - Nothing -> Nothing - Nothing -> Nothing - - -- Applies the nameprep profile on the domainpart string. - -- TODO: Allow unassigned? - domainpart :: Maybe String - domainpart = case runStringPrep (namePrepProfile False) (DT.pack s) of - Just s' -> Just $ DT.unpack s' - Nothing -> Nothing - - -- Applies the resourceprep profile on the resourcepart string, if - -- any. - resourcepart :: Maybe String - resourcepart = case r of - Just r' -> case runStringPrep resourceprepProfile (DT.pack r') of - Just r'' -> Just $ DT.unpack r'' - Nothing -> Nothing - Nothing -> Nothing - -- Returns the domainpart if it was a valid IP or if the toASCII -- function was successful, or Nothing otherwise. - domainpart' :: Maybe String - domainpart' | isIPv4address s || isIPv6address s = Just s - | validHostname s = Just s - | otherwise = Nothing - - -- Validates that non-domainpart strings have an appropriate - -- length. - validateNonDomainpart :: Maybe String -> Bool - validateNonDomainpart Nothing = True - validateNonDomainpart (Just l) = validPartLength l - where - validPartLength :: String -> Bool - validPartLength p = length p > 0 && length p < 1024 + validDomainPart _s = True -- TODO + -- isIPv4address s || isIPv6address s || validHostname s + validPartLength :: Text -> Bool + validPartLength p = Text.length p > 0 && Text.length p < 1024 -- Validates a host name - validHostname :: String -> Bool - validHostname _ = True -- TODO - + -- validHostname :: Text -> Bool + -- validHostname _ = True -- TODO -- | Returns True if the JID is `bare', and False otherwise. - isBare :: JID -> Bool - isBare j | resourcepart j == Nothing = True | otherwise = False - -- | Returns True if the JID is `full', and False otherwise. - isFull :: JID -> Bool - isFull jid = not $ isBare jid - -- Parses an JID string and returns its three parts. It performs no -- validation or transformations. We are using Parsec to parse the -- JIDs. There is no input for which 'jidParts' fails. - -jidParts :: GenParser Char st (Maybe String, String, Maybe String) - +jidParts :: AP.Parser (Maybe Text, Text, Maybe Text) jidParts = do - - -- Read until we reach an '@', a '/', or EOF. - a <- many $ noneOf ['@', '/'] - - -- Case 1: We found an '@', and thus the localpart. At least the - -- domainpart is remaining. Read the '@' and until a '/' or EOF. - do - char '@' - b <- many $ noneOf ['/'] - - -- Case 1A: We found a '/' and thus have all the JID parts. Read - -- the '/' and until EOF. - do - char '/' -- Resourcepart remaining - c <- many $ anyToken -- Parse resourcepart - eof - return (Just a, b, Just c) - - -- Case 1B: We have reached EOF; the JID is in the form - -- localpart@domainpart. - <|> do - eof - return (Just a, b, Nothing) - - -- Case 2: We found a '/'; the JID is in the form - -- domainpart/resourcepart. - <|> do - char '/' - b <- many $ anyToken - eof - return (Nothing, a, Just b) - - -- Case 3: We have reached EOF; we have an JID consisting of only - -- a domainpart. - <|> do - eof - return (Nothing, a, Nothing) - - -nodeprepProfile :: StringPrepProfile - -nodeprepProfile = Profile { maps = [b1, b2] - , shouldNormalize = True - , prohibited = [a1] ++ [c11, c12, c21, c22, - c3, c4, c5, c6, c7, - c8, c9] - , shouldCheckBidi = True } - + a <- firstPartP + b <- Just <$> domainPartP <|> (return Nothing) + c <- Just <$> resourcePartP <|> (return Nothing) + case (a,b,c) of + -- Whether or not we have a resource part, if there is no "@" + -- x is the domain + (x, Nothing, z) -> return (Nothing, x, z) + -- When we do have an "@", x is the localpart + (x, Just y, z) -> return (Just x, y, z) + where + firstPartP = AP.takeWhile1 (AP.notInClass ['@', '/']) + domainPartP = do + _ <- AP.char '@' + AP.takeWhile1 (/= '/') + resourcePartP = do + _ <- AP.char '/' + AP.takeText + + +nodeprepProfile :: SP.StringPrepProfile +nodeprepProfile = SP.Profile + { SP.maps = [SP.b1, SP.b2] + , SP.shouldNormalize = True + , SP.prohibited = [SP.a1 + , SP.c3 + , SP.c4 + , SP.c5 + , SP.c6 + , SP.c7 + , SP.c8 + , SP.c9 + , SP.c11 + , SP.c12 + , SP.c21 + , SP.c22 + ] + , SP.shouldCheckBidi = True + } -- These needs to be checked for after normalization. We could also -- look up the Unicode mappings and include a list of characters in -- the prohibited field above. Let's defer that until we know that we -- are going to use stringprep. - +nodeprepExtraProhibitedCharacters :: [Char] nodeprepExtraProhibitedCharacters = ['\x22', '\x26', '\x27', '\x2F', '\x3A', '\x3C', '\x3E', '\x40'] - - -resourceprepProfile :: StringPrepProfile - -resourceprepProfile = Profile { maps = [b1] - , shouldNormalize = True - , prohibited = [a1] ++ [c12, c21, c22, - c3, c4, c5, c6, - c7, c8, c9] - , shouldCheckBidi = True } +resourceprepProfile :: SP.StringPrepProfile +resourceprepProfile = SP.Profile + { SP.maps = [SP.b1] + , SP.shouldNormalize = True + , SP.prohibited = [ SP.a1 + , SP.c3 + , SP.c4 + , SP.c5 + , SP.c6 + , SP.c7 + , SP.c8 + , SP.c9 + , SP.c12 + , SP.c21 + , SP.c22 + ] + , SP.shouldCheckBidi = True + } From 2f13935c0ba25ef13d963e7f9db72fde55b4402d Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 18 Apr 2012 20:29:46 +0200 Subject: [PATCH 02/29] fixed JID parsing, moved JID to JID.hs --- src/Network/XMPP/JID.hs | 107 +++++++++++++++++++++++++------------- src/Network/XMPP/Types.hs | 34 +----------- 2 files changed, 74 insertions(+), 67 deletions(-) diff --git a/src/Network/XMPP/JID.hs b/src/Network/XMPP/JID.hs index 5b6f1fd..b1f0783 100644 --- a/src/Network/XMPP/JID.hs +++ b/src/Network/XMPP/JID.hs @@ -15,28 +15,64 @@ -- -- This module does not internationalize hostnames. -module Network.XMPP.JID (fromString, fromStrings, isBare, isFull) where +module Network.XMPP.JID + ( JID(..) + , fromText + , fromStrings + , isBare + , isFull) where import Control.Applicative ((<$>),(<|>)) import Control.Monad(guard) import qualified Data.Attoparsec.Text as AP +import Data.Maybe(fromJust) +import qualified Data.Set as Set +import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as Text -- import Network.URI (isIPv4address, isIPv6address) -import Network.XMPP.Types import qualified Text.NamePrep as SP import qualified Text.StringPrep as SP +-- | +-- @From@ is a readability type synonym for @Address@. + +-- | Jabber ID (JID) datatype +data JID = JID { localpart :: !(Maybe Text) + -- ^ Account name + , domainpart :: !Text + -- ^ Server adress + , resourcepart :: !(Maybe Text) + -- ^ Resource name + } + +instance Show JID where + show (JID nd dmn res) = + maybe "" ((++ "@") . Text.unpack) nd ++ + (Text.unpack dmn) ++ + maybe "" (('/' :) . Text.unpack) res + +instance Read JID where + readsPrec _ x = case fromText (Text.pack x) of + Nothing -> [] + Just j -> [(j,"")] + + +instance IsString JID where + fromString = fromJust . fromText . Text.pack + -- | -- Converts a string to a JID. -fromString :: String -> Maybe JID -fromString s = fromStrings l d r - where - Right (l, d, r) = - AP.parseOnly jidParts (Text.pack s) +fromText :: Text -> Maybe JID +fromText t = do + (l, d, r) <- eitherToMaybe $ AP.parseOnly jidParts t + fromStrings l d r + where + eitherToMaybe = either (const Nothing) Just + -- | -- Converts localpart, domainpart, and resourcepart strings to a JID. @@ -48,6 +84,8 @@ fromStrings l d r = do Just l'-> do l'' <- SP.runStringPrep nodeprepProfile l' guard $ validPartLength l'' + let prohibMap = Set.fromList nodeprepExtraProhibitedCharacters + guard $ Text.all (`Set.notMember` prohibMap) l'' return $ Just l'' domainPart <- SP.runStringPrep (SP.namePrepProfile False) d guard $ validDomainPart domainPart @@ -93,33 +131,32 @@ jidParts = do (x, Nothing, z) -> return (Nothing, x, z) -- When we do have an "@", x is the localpart (x, Just y, z) -> return (Just x, y, z) - where - firstPartP = AP.takeWhile1 (AP.notInClass ['@', '/']) - domainPartP = do + +firstPartP = AP.takeWhile1 (AP.notInClass ['@', '/']) +domainPartP = do _ <- AP.char '@' AP.takeWhile1 (/= '/') - resourcePartP = do +resourcePartP = do _ <- AP.char '/' AP.takeText - nodeprepProfile :: SP.StringPrepProfile nodeprepProfile = SP.Profile { SP.maps = [SP.b1, SP.b2] , SP.shouldNormalize = True , SP.prohibited = [SP.a1 - , SP.c3 - , SP.c4 - , SP.c5 - , SP.c6 - , SP.c7 - , SP.c8 - , SP.c9 - , SP.c11 - , SP.c12 - , SP.c21 - , SP.c22 - ] + , SP.c11 + , SP.c12 + , SP.c21 + , SP.c22 + , SP.c3 + , SP.c4 + , SP.c5 + , SP.c6 + , SP.c7 + , SP.c8 + , SP.c9 + ] , SP.shouldCheckBidi = True } @@ -136,16 +173,16 @@ resourceprepProfile = SP.Profile { SP.maps = [SP.b1] , SP.shouldNormalize = True , SP.prohibited = [ SP.a1 - , SP.c3 - , SP.c4 - , SP.c5 - , SP.c6 - , SP.c7 - , SP.c8 - , SP.c9 - , SP.c12 - , SP.c21 - , SP.c22 - ] + , SP.c12 + , SP.c21 + , SP.c22 + , SP.c3 + , SP.c4 + , SP.c5 + , SP.c6 + , SP.c7 + , SP.c8 + , SP.c9 + ] , SP.shouldCheckBidi = True } diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index a3e827c..834c265 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -33,6 +33,8 @@ import Data.XML.Types import qualified Network as N +import Network.XMPP.JID + import System.IO @@ -74,38 +76,6 @@ instance Read StanzaId where instance IsString StanzaId where fromString = SI . Text.pack --- | --- @From@ is a readability type synonym for @Address@. - --- | Jabber ID (JID) datatype -data JID = JID { localpart :: !(Maybe Text) - -- ^ Account name - , domainpart :: !Text - -- ^ Server adress - , resourcepart :: !(Maybe Text) - -- ^ Resource name - } - -instance Show JID where - show (JID nd dmn res) = - maybe "" ((++ "@") . Text.unpack) nd ++ - (Text.unpack dmn) ++ - maybe "" (('/' :) . Text.unpack) res - -parseJID :: [Char] -> [JID] -parseJID jid = do - (jid', rst) <- case L.splitOn "@" jid of - [rest] -> [(JID Nothing, rest)] - [nd,rest] -> [(JID (Just (Text.pack nd)), rest)] - _ -> [] - case L.splitOn "/" rst of - [dmn] -> [jid' (Text.pack dmn) Nothing] - [dmn, rsrc] -> [jid' (Text.pack dmn) (Just (Text.pack rsrc))] - _ -> [] - -instance Read JID where - readsPrec _ x = (,"") <$> parseJID x - -- An Info/Query (IQ) stanza is either of the type "request" ("get" or -- "set") or "response" ("result" or "error"). The @IQ@ type wraps -- these two sub-types. From a7c8ca2202b58312b50ca75b47d34763f62fc981 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 19 Apr 2012 11:29:18 +0200 Subject: [PATCH 03/29] Explicit export list for Network.XMPP.Types --- src/Network/XMPP/Types.hs | 34 +++++++++++++++++++++++++++++++++- 1 file changed, 33 insertions(+), 1 deletion(-) diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index 834c265..f514950 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -11,7 +11,39 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.XMPP.Types where +module Network.XMPP.Types + ( IQError(..) + , IQRequest(..) + , IQRequestType(..) + , IQResponse(..) + , IQResult(..) + , IdGenerator(..) + , LangTag(..) + , Message(..) + , MessageError(..) + , MessageType(..) + , Presence(..) + , PresenceError(..) + , PresenceType(..) + , SASLError(..) + , SASLFailure(..) + , ServerAddress(..) + , ServerFeatures(..) + , ShowType(..) + , Stanza(..) + , StanzaError(..) + , StanzaErrorCondition(..) + , StanzaErrorType(..) + , StanzaId(..) + , StreamError(..) + , Version(..) + , XMPPConMonad(..) + , XMPPConState(..) + , XMPPT(..) + , parseLangTag + , module Network.XMPP.JID + ) + where -- import Network.XMPP.Utilities (idGenerator) From ec9c7cf030daf15d492a136dce23b1052036a038 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Thu, 19 Apr 2012 12:05:52 +0200 Subject: [PATCH 04/29] Char instead of Word8 for random 1.0.0.0 (ghc 7) compatibility --- src/Network/XMPP/SASL.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index c325d89..f7e28c3 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -92,8 +92,12 @@ createResponse g hostname username passwd' pairs = let uname = Text.encodeUtf8 username passwd = Text.encodeUtf8 passwd' realm = Text.encodeUtf8 hostname + + -- Using Char instead of Word8 for random 1.0.0.0 (GHC 7) + -- compatibility. cnonce = BS.tail . BS.init . - B64.encode . BS.pack . take 8 $ Random.randoms g + B64.encode . BS8.pack . take 8 $ Random.randoms g + nc = "00000001" digestURI = ("xmpp/" `BS.append` realm) digest = md5Digest From b3c73c17743851704b14f9f34b71dafd2b9d4228 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Thu, 19 Apr 2012 12:06:29 +0200 Subject: [PATCH 05/29] an Control.Exception.allowInterrupt equivalent for ghc 7 compatibility --- src/Network/XMPP/Concurrent/Threads.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index b40024b..04ab8d6 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -33,6 +33,8 @@ import Network.XMPP.Concurrent.Types import Text.XML.Stream.Elements import qualified Text.XML.Stream.Render as XR +import GHC.IO (unsafeUnmask) + readWorker :: TChan (Either MessageError Message) -> TChan (Either PresenceError Presence) -> TVar IQHandlers @@ -43,7 +45,7 @@ readWorker messageC presenceC handlers stateRef = s <- liftIO . atomically $ takeTMVar stateRef (sta', s') <- flip runStateT s $ Ex.catch ( do -- we don't know whether pull will necessarily be interruptible - liftIO $ Ex.allowInterrupt + liftIO $ allowInterrupt Just <$> pull ) (\(Interrupt t) -> do @@ -80,7 +82,11 @@ readWorker messageC presenceC handlers stateRef = IQRequestS i -> handleIQRequest handlers i IQResultS i -> handleIQResponse handlers (Right i) IQErrorS i -> handleIQResponse handlers (Left i) - + where + -- Defining an Control.Exception.allowInterrupt equivalent for + -- GHC 7 compatibility. + allowInterrupt :: IO () + allowInterrupt = unsafeUnmask $ return () handleIQRequest handlers iq = do (byNS, _) <- readTVar handlers From f97d5c31c61dfb87dc19db6acd44592e7179168f Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 19 Apr 2012 12:52:53 +0200 Subject: [PATCH 06/29] added pickler for SASLError --- src/Network/XMPP/Marshal.hs | 7 +--- src/Network/XMPP/Pickle.hs | 8 ++++ src/Network/XMPP/SASL.hs | 25 ++++++++++--- src/Network/XMPP/Types.hs | 75 +++++++++++++++++++++++++------------ 4 files changed, 81 insertions(+), 34 deletions(-) diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index 6f32fde..3d694e2 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/src/Network/XMPP/Marshal.hs @@ -5,6 +5,7 @@ module Network.XMPP.Marshal where import Data.XML.Pickle import Data.XML.Types +import Network.XMPP.Pickle import Network.XMPP.Types stanzaSel :: Stanza -> Int @@ -27,12 +28,6 @@ stanzaP = xpAlt stanzaSel , xpWrap PresenceErrorS (\(PresenceErrorS x) -> x) xpPresenceError ] -xmlLang :: Name -xmlLang = Name "lang" Nothing (Just "xml") - -xpLangTag :: PU [Attribute] (Maybe LangTag) -xpLangTag = xpAttrImplied xmlLang xpPrim - xpMessage :: PU [Node] (Message) xpMessage = xpWrap (\((tp, qid, from, to, lang), (sub, body, thr, ext)) -> Message qid from to lang tp sub thr body ext) diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index 97d3989..45eeab2 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -10,6 +10,8 @@ module Network.XMPP.Pickle where import Data.XML.Types import Data.XML.Pickle +import Network.XMPP.Types + import Text.XML.Stream.Elements mbToBool :: Maybe t -> Bool @@ -21,6 +23,12 @@ xpElemEmpty name = xpWrap (\((),()) -> ()) (\() -> ((),())) $ xpElem name xpUnit xpUnit +xmlLang :: Name +xmlLang = Name "lang" Nothing (Just "xml") + +xpLangTag :: PU [Attribute] (Maybe LangTag) +xpLangTag = xpAttrImplied xmlLang xpPrim + -- xpElemExists :: Name -> PU [Node] Bool -- xpElemExists name = xpWrap (\x -> mbToBool x) -- (\x -> if x then Just () else Nothing) $ diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index f7e28c3..bff4caa 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -26,6 +26,7 @@ import qualified Data.Text.Encoding as Text import Network.XMPP.Monad import Network.XMPP.Stream import Network.XMPP.Types +import Network.XMPP.Pickle import qualified System.Random as Random @@ -92,12 +93,12 @@ createResponse g hostname username passwd' pairs = let uname = Text.encodeUtf8 username passwd = Text.encodeUtf8 passwd' realm = Text.encodeUtf8 hostname - + -- Using Char instead of Word8 for random 1.0.0.0 (GHC 7) -- compatibility. cnonce = BS.tail . BS.init . B64.encode . BS8.pack . take 8 $ Random.randoms g - + nc = "00000001" digestURI = ("xmpp/" `BS.append` realm) digest = md5Digest @@ -163,10 +164,24 @@ md5Digest uname realm password digestURI nc qop nonce cnonce= -- Pickling +failurePickle :: PU [Node] (SASLFailure) +failurePickle = xpWrap (\(txt,(failure,_,_)) + -> SASLFailure failure txt) + (\(SASLFailure failure txt) + -> (txt,(failure,(),()))) + (xpElemNodes + "{urn:ietf:params:xml:ns:xmpp-sasl}failure" + (xp2Tuple + (xpOption $ xpElem + "{urn:ietf:params:xml:ns:xmpp-sasl}text" + xpLangTag + (xpContent xpId)) + (xpElemByNamespace + "urn:ietf:params:xml:ns:xmpp-sasl" + xpPrim + (xpUnit) + (xpUnit)))) -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" diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index f514950..f4ea65f 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -18,7 +18,7 @@ module Network.XMPP.Types , IQResponse(..) , IQResult(..) , IdGenerator(..) - , LangTag(..) + , LangTag (..) , Message(..) , MessageError(..) , MessageType(..) @@ -474,39 +474,68 @@ instance Read StanzaErrorCondition where -- ============================================================================= data SASLFailure = SASLFailure { saslFailureCondition :: SASLError - , saslFailureText :: Maybe Text } -- TODO: XMLLang + , saslFailureText :: Maybe ( Maybe LangTag + , Text + ) + } deriving Show -data SASLError = -- SASLAborted | -- Client aborted - should not happen - SASLAccountDisabled | -- ^ The account has been temporarily - -- disabled - SASLCredentialsExpired | -- ^ The authentication failed because +data SASLError = SASLAborted -- ^ Client aborted + | SASLAccountDisabled -- ^ The account has been temporarily + -- disabled + | SASLCredentialsExpired -- ^ The authentication failed because -- the credentials have expired - SASLEncryptionRequired | -- ^ The mechanism requested cannot be + | SASLEncryptionRequired -- ^ The mechanism requested cannot be -- used the confidentiality and -- integrity of the underlying -- stream is protected (typically -- with TLS) - -- SASLIncorrectEncoding | -- The base64 encoding is incorrect - -- - should not happen - -- SASLInvalidAuthzid | -- The authzid has an incorrect format, - -- or the initiating entity does not - -- have the appropriate permissions to - -- authorize that ID - SASLInvalidMechanism | -- ^ The mechanism is not supported by - -- the receiving entity - -- SASLMalformedRequest | -- Invalid syntax - should not happen - SASLMechanismTooWeak | -- ^ The receiving entity policy - -- requires a stronger mechanism - SASLNotAuthorized (Maybe Text) | -- ^ Invalid credentials - -- provided, or some - -- generic authentication - -- failure has occurred - SASLTemporaryAuthFailure -- ^ There receiving entity reported a + | SASLIncorrectEncoding -- ^ The base64 encoding is incorrect + | SASLInvalidAuthzid -- ^ The authzid has an incorrect + -- format or the initiating entity does + -- not have the appropriate permissions + -- to authorize that ID + | SASLInvalidMechanism -- ^ The mechanism is not supported by + -- the receiving entity + | SASLMalformedRequest -- ^ Invalid syntax + | SASLMechanismTooWeak -- ^ The receiving entity policy + -- requires a stronger mechanism + | SASLNotAuthorized -- ^ Invalid credentials + -- provided, or some + -- generic authentication + -- failure has occurred + | SASLTemporaryAuthFailure -- ^ There receiving entity reported a -- temporary error condition; the -- initiating entity is recommended -- to try again later +instance Show SASLError where + show SASLAborted = "aborted" + show SASLAccountDisabled = "account-disabled" + show SASLCredentialsExpired = "credentials-expired" + show SASLEncryptionRequired = "encryption-required" + show SASLIncorrectEncoding = "incorrect-encoding" + show SASLInvalidAuthzid = "invalid-authzid" + show SASLInvalidMechanism = "invalid-mechanism" + show SASLMalformedRequest = "malformed-request" + show SASLMechanismTooWeak = "mechanism-too-weak" + show SASLNotAuthorized = "not-authorized" + show SASLTemporaryAuthFailure = "temporary-auth-failure" + +instance Read SASLError where + readsPrec _ "aborted" = [(SASLAborted , "")] + readsPrec _ "account-disabled" = [(SASLAccountDisabled , "")] + readsPrec _ "credentials-expired" = [(SASLCredentialsExpired , "")] + readsPrec _ "encryption-required" = [(SASLEncryptionRequired , "")] + readsPrec _ "incorrect-encoding" = [(SASLIncorrectEncoding , "")] + readsPrec _ "invalid-authzid" = [(SASLInvalidAuthzid , "")] + readsPrec _ "invalid-mechanism" = [(SASLInvalidMechanism , "")] + readsPrec _ "malformed-request" = [(SASLMalformedRequest , "")] + readsPrec _ "mechanism-too-weak" = [(SASLMechanismTooWeak , "")] + readsPrec _ "not-authorized" = [(SASLNotAuthorized , "")] + readsPrec _ "temporary-auth-failure" = [(SASLTemporaryAuthFailure , "")] + + -- | Readability type for host name Texts. From 6c6f99c60005985932f94bba7b5e16d7b897f076 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 19 Apr 2012 13:43:34 +0200 Subject: [PATCH 07/29] fixed word8 problem in SASL --- src/Network/XMPP/SASL.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index bff4caa..15de4c2 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -93,12 +93,10 @@ createResponse g hostname username passwd' pairs = let uname = Text.encodeUtf8 username passwd = Text.encodeUtf8 passwd' realm = Text.encodeUtf8 hostname - -- Using Char instead of Word8 for random 1.0.0.0 (GHC 7) -- compatibility. cnonce = BS.tail . BS.init . - B64.encode . BS8.pack . take 8 $ Random.randoms g - + B64.encode . BS.pack . map toWord8 . take 8 $ Random.randoms g nc = "00000001" digestURI = ("xmpp/" `BS.append` realm) digest = md5Digest @@ -124,6 +122,7 @@ createResponse g hostname username passwd' pairs = let in Text.decodeUtf8 $ B64.encode response where quote x = BS.concat ["\"",x,"\""] + toWord8 x = fromIntegral (abs (x :: Int) `mod` 256) :: Binary.Word8 toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)] toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do @@ -143,6 +142,7 @@ 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 From fc14fb11970f59d15cdef0eb67df4d3237ae61b6 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 19 Apr 2012 13:48:48 +0200 Subject: [PATCH 08/29] SASL alignment, simplified conversion --- src/Network/XMPP/SASL.hs | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 15de4c2..bd9d713 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -16,6 +16,7 @@ import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BL import qualified Data.Digest.Pure.MD5 as MD5 import qualified Data.List as L +import Data.Word (Word8) import Data.XML.Pickle import Data.XML.Types @@ -88,18 +89,18 @@ createResponse :: Random.RandomGen g -> [(BS8.ByteString, BS8.ByteString)] -> Text createResponse g hostname username passwd' pairs = let - Just qop = L.lookup "qop" pairs + Just qop = L.lookup "qop" pairs Just nonce = L.lookup "nonce" pairs - uname = Text.encodeUtf8 username - passwd = Text.encodeUtf8 passwd' - realm = Text.encodeUtf8 hostname - -- Using Char instead of Word8 for random 1.0.0.0 (GHC 7) + uname = Text.encodeUtf8 username + passwd = Text.encodeUtf8 passwd' + realm = Text.encodeUtf8 hostname + -- Using Int instead of Word8 for random 1.0.0.0 (GHC 7) -- compatibility. - cnonce = BS.tail . BS.init . + cnonce = BS.tail . BS.init . B64.encode . BS.pack . map toWord8 . take 8 $ Random.randoms g - nc = "00000001" - digestURI = ("xmpp/" `BS.append` realm) - digest = md5Digest + nc = "00000001" + digestURI = ("xmpp/" `BS.append` realm) + digest = md5Digest uname realm passwd @@ -122,7 +123,7 @@ createResponse g hostname username passwd' pairs = let in Text.decodeUtf8 $ B64.encode response where quote x = BS.concat ["\"",x,"\""] - toWord8 x = fromIntegral (abs (x :: Int) `mod` 256) :: Binary.Word8 + toWord8 x = fromIntegral (x :: Int) :: Word8 toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)] toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do From 2ad95ba1b45cff7c08b662adfa5d2bfcf6c5870e Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 19 Apr 2012 19:14:31 +0200 Subject: [PATCH 09/29] added EventHandlers, endSession, closeConnection --- src/Data/Conduit/TLS.hs | 8 +++++-- src/Network/XMPP/Concurrent/Monad.hs | 31 +++++++++++++++++++++++++- src/Network/XMPP/Concurrent/Threads.hs | 8 ++++--- src/Network/XMPP/Concurrent/Types.hs | 12 ++++++++++ src/Network/XMPP/Monad.hs | 12 +++++++++- src/Network/XMPP/SASL.hs | 1 - src/Network/XMPP/TLS.hs | 3 ++- src/Network/XMPP/Types.hs | 3 +-- 8 files changed, 67 insertions(+), 11 deletions(-) diff --git a/src/Data/Conduit/TLS.hs b/src/Data/Conduit/TLS.hs index 4a7d4f0..642ba6e 100644 --- a/src/Data/Conduit/TLS.hs +++ b/src/Data/Conduit/TLS.hs @@ -26,7 +26,9 @@ tlsinit TLSParams -> Handle -> m ( Source m1 BS.ByteString , Sink BS.ByteString m1 () - , BS.ByteString -> IO ()) + , BS.ByteString -> IO () + , TLSCtx Handle + ) tlsinit tlsParams handle = do gen <- liftIO $ (newGenIO :: IO SystemRandom) -- TODO: Find better random source? clientContext <- client tlsParams gen handle @@ -41,5 +43,7 @@ tlsinit tlsParams handle = do (\_ -> return ()) return ( src , snk - , \s -> sendData clientContext $ BL.fromChunks [s] ) + , \s -> sendData clientContext $ BL.fromChunks [s] + , clientContext + ) diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index a39ce1b..017db4e 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -14,6 +14,7 @@ import qualified Data.Map as Map import Data.Text(Text) import Network.XMPP.Concurrent.Types +import Network.XMPP.Monad -- | Register a new IQ listener. IQ requests matching the type and namespace will -- be put in the channel. @@ -162,8 +163,36 @@ withConnection a = do putTMVar stateRef s' return res +-- | Send a presence Stanza sendPresence :: Presence -> XMPPThread () sendPresence = sendS . PresenceS +-- | Send a Message Stanza sendMessage :: Message -> XMPPThread () -sendMessage = sendS . MessageS \ No newline at end of file +sendMessage = sendS . MessageS + + +modifyHandlers :: (EventHandlers -> EventHandlers) -> XMPPThread () +modifyHandlers f = do + eh <- asks eventHandlers + liftIO . atomically $ modifyTVar eh f + +setSessionEndHandler :: XMPPThread () -> XMPPThread () +setSessionEndHandler eh = modifyHandlers (\s -> s{sessionEndHandler = eh}) + +-- | run an event handler +runHandler :: (EventHandlers -> XMPPThread a) -> XMPPThread a +runHandler h = do + eh <- liftIO . atomically . readTVar =<< asks eventHandlers + h eh + +-- | End the current xmpp session +endSession :: XMPPThread () +endSession = do -- TODO: This has to be idempotent (is it?) + withConnection xmppKillConnection + liftIO =<< asks stopThreads + runHandler sessionEndHandler + +-- | Close the connection to the server +closeConnection :: XMPPThread () +closeConnection = withConnection xmppKillConnection diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index 04ab8d6..961fd68 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -130,6 +130,7 @@ startThreads , TMVar (BS.ByteString -> IO ()) , TMVar XMPPConState , ThreadId + , TVar EventHandlers ) startThreads = do @@ -139,6 +140,7 @@ startThreads = do iqC <- liftIO newTChanIO outC <- liftIO newTChanIO handlers <- liftIO $ newTVarIO ( Map.empty, Map.empty) + eh <- liftIO $ newTVarIO zeroEventHandlers conS <- liftIO . newTMVarIO =<< get lw <- liftIO . forkIO $ writeWorker outC writeLock cp <- liftIO . forkIO $ connPersist writeLock @@ -146,7 +148,7 @@ startThreads = do rd <- liftIO . forkIO $ readWorker messageC presenceC handlers conS return (messageC, presenceC, handlers, outC , killConnection writeLock [lw, rd, cp] - , writeLock, conS ,rd) + , writeLock, conS ,rd, eh) where killConnection writeLock threads = liftIO $ do _ <- atomically $ takeTMVar writeLock -- Should we put it back? @@ -159,7 +161,7 @@ runThreaded :: XMPPThread a -> XMPPConMonad a runThreaded a = do liftIO . putStrLn $ "starting threads" - (mC, pC, hand, outC, _stopThreads, writeR, conS, rdr ) <- startThreads + (mC, pC, hand, outC, stopThreads', writeR, conS, rdr, eh) <- startThreads liftIO . putStrLn $ "threads running" workermCh <- liftIO . newIORef $ Nothing workerpCh <- liftIO . newIORef $ Nothing @@ -170,7 +172,7 @@ runThreaded a = do return . read. show $ curId s <- get liftIO . putStrLn $ "starting application" - liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR rdr getId conS) + liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR rdr getId conS eh stopThreads') -- | Sends a blank space every 30 seconds to keep the connection alive diff --git a/src/Network/XMPP/Concurrent/Types.hs b/src/Network/XMPP/Concurrent/Types.hs index 14f0d04..26b9418 100644 --- a/src/Network/XMPP/Concurrent/Types.hs +++ b/src/Network/XMPP/Concurrent/Types.hs @@ -21,6 +21,16 @@ type IQHandlers = (Map.Map (IQRequestType, Text) (TChan (IQRequest, TVar Bool)) , Map.Map StanzaId (TMVar IQResponse) ) +data EventHandlers = EventHandlers + { sessionEndHandler :: XMPPThread () + , connectionClosedHandler :: XMPPThread () + } + +zeroEventHandlers = EventHandlers + { sessionEndHandler = return () + , connectionClosedHandler = return () + } + data Thread = Thread { messagesRef :: IORef (Maybe ( TChan (Either MessageError Message @@ -39,6 +49,8 @@ data Thread = Thread { messagesRef :: IORef (Maybe ( TChan (Either , readerThread :: ThreadId , idGenerator :: IO StanzaId , conStateRef :: TMVar XMPPConState + , eventHandlers :: TVar EventHandlers + , stopThreads :: IO () } type XMPPThread a = ReaderT Thread IO a diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index cf3b634..2ff458e 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -80,10 +80,11 @@ xmppFromHandle handle hostname username res f = do (Just hostname) (Just username) res + (hClose handle) runStateT f st zeroSource :: Source IO output -zeroSource = sourceState () (\_ -> forever $ threadDelay 10000000) +zeroSource = liftIO . forever $ threadDelay 10000000 xmppZeroConState :: XMPPConState xmppZeroConState = XMPPConState @@ -96,6 +97,7 @@ xmppZeroConState = XMPPConState , sHostname = Nothing , sUsername = Nothing , sResource = Nothing + , sCloseConnection = return () } xmppRawConnect :: HostName -> Text -> XMPPConMonad () @@ -117,8 +119,16 @@ xmppRawConnect host hostname = do (Just hostname) uname Nothing + (hClose con) put st + withNewSession :: XMPPConMonad a -> IO (a, XMPPConState) withNewSession action = do runStateT action xmppZeroConState + +xmppKillConnection :: XMPPConMonad () +xmppKillConnection = do + cc <- gets sCloseConnection + liftIO cc + put xmppZeroConState diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index bd9d713..589146d 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -163,7 +163,6 @@ md5Digest uname realm password digestURI nc qop nonce cnonce= ha2 = hash ["AUTHENTICATE", digestURI] in hash [ha1,nonce, nc, cnonce,qop,ha2] - -- Pickling failurePickle :: PU [Node] (SASLFailure) failurePickle = xpWrap (\(txt,(failure,_,_)) diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index 7b9f159..df88b46 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -68,12 +68,13 @@ xmppStartTLS params = Ex.handle (return . Left . TLSError) case answer of Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return () _ -> throwError $ TLSStreamError StreamXMLError - (raw, snk, psh) <- lift $ TLS.tlsinit params handle + (raw, snk, psh, ctx) <- lift $ TLS.tlsinit params handle lift $ modify (\x -> x { sRawSrc = raw -- , sConSrc = -- Note: this momentarily leaves us in an -- inconsistent state , sConPushBS = psh + , sCloseConnection = TLS.bye ctx >> sCloseConnection x }) ErrorT $ (left TLSStreamError) <$> xmppRestartStream modify (\s -> s{sHaveTLS = True}) diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index f4ea65f..e6eace6 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -535,8 +535,6 @@ instance Read SASLError where readsPrec _ "not-authorized" = [(SASLNotAuthorized , "")] readsPrec _ "temporary-auth-failure" = [(SASLTemporaryAuthFailure , "")] - - -- | Readability type for host name Texts. -- type HostName = Text -- This is defined in Network as well @@ -659,6 +657,7 @@ data XMPPConState = XMPPConState , sHostname :: Maybe Text , sUsername :: Maybe Text , sResource :: Maybe Text + , sCloseConnection :: IO () } -- | From c17c62985ba329a59e7711635bc0c0de0e5b621f Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 19 Apr 2012 19:39:27 +0200 Subject: [PATCH 10/29] lifted xmppConnect (connect), xmppStartTLS(startTLS) and xmppSASL(auth) --- .gitignore | 1 + src/Network/XMPP.hs | 16 +++++++++++++++- src/Network/XMPP/Concurrent.hs | 14 ++++---------- src/Network/XMPP/Concurrent/Monad.hs | 2 ++ src/Tests.hs | 9 ++++----- 5 files changed, 26 insertions(+), 16 deletions(-) diff --git a/.gitignore b/.gitignore index d7ddec5..f684ca1 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,6 @@ dist/ cabal-dev/ +wiki/ *.o *.hi *~ diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index 8c531e3..76d87a8 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -42,11 +42,15 @@ module Network.XMPP , module Network.XMPP.Message , xmppConnect , xmppNewSession + , connect + , startTLS + , auth ) where import Data.Text as Text import Network +import qualified Network.TLS as TLS import Network.XMPP.Bind import Network.XMPP.Concurrent import Network.XMPP.Message @@ -62,4 +66,14 @@ xmppConnect :: HostName -> Text -> XMPPConMonad (Either StreamError ()) xmppConnect address hostname = xmppRawConnect address hostname >> xmppStartStream xmppNewSession :: XMPPThread a -> IO (a, XMPPConState) -xmppNewSession = withNewSession . runThreaded \ No newline at end of file +xmppNewSession = withNewSession . runThreaded + + +startTLS :: TLS.TLSParams -> XMPPThread (Either XMPPTLSError ()) +startTLS = withConnection . xmppStartTLS + +auth :: Text.Text -> Text.Text -> XMPPThread (Either String Text.Text) +auth username passwd = withConnection $ xmppSASL username passwd + +connect :: HostName -> Text -> XMPPThread (Either StreamError ()) +connect address hostname = withConnection $ xmppConnect address hostname diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs index 19f4ef7..c360236 100644 --- a/src/Network/XMPP/Concurrent.hs +++ b/src/Network/XMPP/Concurrent.hs @@ -5,14 +5,8 @@ module Network.XMPP.Concurrent , module Network.XMPP.Concurrent.IQ ) where -import Network.XMPP.Concurrent.Types -import Network.XMPP.Concurrent.Monad -import Network.XMPP.Concurrent.Threads -import Network.XMPP.Concurrent.IQ - - - - - - +import Network.XMPP.Concurrent.Types +import Network.XMPP.Concurrent.Monad +import Network.XMPP.Concurrent.Threads +import Network.XMPP.Concurrent.IQ diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index 017db4e..f9a2d75 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -16,6 +16,7 @@ import Data.Text(Text) import Network.XMPP.Concurrent.Types import Network.XMPP.Monad + -- | Register a new IQ listener. IQ requests matching the type and namespace will -- be put in the channel. listenIQChan :: IQRequestType -- ^ type of IQs to receive (Get / Set) @@ -196,3 +197,4 @@ endSession = do -- TODO: This has to be idempotent (is it?) -- | Close the connection to the server closeConnection :: XMPPThread () closeConnection = withConnection xmppKillConnection + diff --git a/src/Tests.hs b/src/Tests.hs index 07b5602..3b46959 100644 --- a/src/Tests.hs +++ b/src/Tests.hs @@ -86,11 +86,10 @@ runMain debug number = do debug . (("Thread " ++ show number ++ ":") ++) xmppNewSession $ do debug' "running" - withConnection $ do - xmppConnect "localhost" "species64739.dyndns.org" - xmppStartTLS exampleParams - saslResponse <- xmppSASL (fromJust $ localpart we) "pwd" - case saslResponse of + connect "localhost" "species64739.dyndns.org" + startTLS exampleParams + saslResponse <- auth (fromJust $ localpart we) "pwd" + case saslResponse of Right _ -> return () Left e -> error e xmppThreadedBind (resourcepart we) From 79e23b8cdde99d0120bec88992c1053ae1d04200 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Fri, 20 Apr 2012 12:02:55 +0200 Subject: [PATCH 11/29] added concurrent startSession added pickler testcase updated test client --- src/Network/XMPP/Pickle.hs | 6 ------ src/Network/XMPP/Session.hs | 11 +++++++--- src/Network/XMPP/Types.hs | 1 + src/Tests.hs | 41 ++++++++++++++++++++++++------------- tests/Stanzas.hs | 17 +++++++++++++++ 5 files changed, 53 insertions(+), 23 deletions(-) create mode 100644 tests/Stanzas.hs diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index 45eeab2..347e8a5 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -29,12 +29,6 @@ xmlLang = Name "lang" Nothing (Just "xml") xpLangTag :: PU [Attribute] (Maybe LangTag) xpLangTag = xpAttrImplied xmlLang xpPrim --- 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 diff --git a/src/Network/XMPP/Session.hs b/src/Network/XMPP/Session.hs index 7b37a44..5a355b0 100644 --- a/src/Network/XMPP/Session.hs +++ b/src/Network/XMPP/Session.hs @@ -8,15 +8,14 @@ import Data.XML.Types(Element) import Network.XMPP.Monad import Network.XMPP.Pickle import Network.XMPP.Types +import Network.XMPP.Concurrent + sessionXML :: Element sessionXML = pickleElem (xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session" ) () - - - sessionIQ :: Stanza sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" , iqRequestFrom = Nothing @@ -33,3 +32,9 @@ xmppSession = do let IQResultS (IQResult "sess" Nothing Nothing _lang _body) = answer return () +startSession :: XMPPThread () +startSession = do + answer <- sendIQ' Nothing Set Nothing sessionXML + case answer of + Left e -> error $ show e + Right _ -> return () diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index e6eace6..1f59194 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -122,6 +122,7 @@ data Stanza = IQRequestS IQRequest | MessageErrorS MessageError | PresenceS Presence | PresenceErrorS PresenceError + deriving Show -- | -- A "request" Info/Query (IQ) stanza is one with either "get" or diff --git a/src/Tests.hs b/src/Tests.hs index 3b46959..d5621ab 100644 --- a/src/Tests.hs +++ b/src/Tests.hs @@ -34,7 +34,11 @@ attXmpp = liftIO . atomically testNS :: Text testNS = "xmpp:library:test" -data Payload = Payload Int Bool Text deriving (Eq, Show) +data Payload = Payload + { payloadCounter ::Int + , payloadFlag :: Bool + , payloadText :: Text + } deriving (Eq, Show) payloadP = xpWrap (\((counter,flag) , message) -> Payload counter flag message) (\(Payload counter flag message) ->((counter,flag) , message)) $ @@ -58,6 +62,7 @@ iqResponder = do let answerPayload = invertPayload payload let answerBody = pickleElem payloadP answerPayload answerIQ next (Right $ Just answerBody) + when (payloadCounter payload == 10) endSession autoAccept :: XMPPThread () autoAccept = forever $ do @@ -84,7 +89,9 @@ runMain debug number = do _ -> error "Need either 1 or 2" let debug' = liftIO . atomically . debug . (("Thread " ++ show number ++ ":") ++) + wait <- newEmptyTMVarIO xmppNewSession $ do + setSessionEndHandler (liftIO . atomically $ putTMVar wait ()) debug' "running" connect "localhost" "species64739.dyndns.org" startTLS exampleParams @@ -93,23 +100,29 @@ runMain debug number = do Right _ -> return () Left e -> error e xmppThreadedBind (resourcepart we) - withConnection $ xmppSession +-- startSession debug' "session standing" sendPresence presenceOnline forkXMPP autoAccept + sendPresence $ presenceSubscribe them forkXMPP iqResponder - when active . void . forkXMPP $ do - forM [1..10] $ \count -> do - let message = Text.pack . show $ localpart we - let payload = Payload count (even count) (Text.pack $ show count) - let body = pickleElem payloadP payload - Right answer <- sendIQ' (Just them) Get Nothing body - let Right answerPayload = unpickleElem payloadP - (fromJust $ iqResultPayload answer) - expect debug' (invertPayload payload) answerPayload - liftIO $ threadDelay 100000 - sendUser "All tests done" - liftIO . forever $ threadDelay 10000000 + when active $ do + liftIO $ threadDelay 1000000 -- Wait for the other thread to go online + void . forkXMPP $ do + forM [1..10] $ \count -> do + let message = Text.pack . show $ localpart we + let payload = Payload count (even count) (Text.pack $ show count) + let body = pickleElem payloadP payload + debug' "sending" + Right answer <- sendIQ' (Just them) Get Nothing body + debug' "received" + let Right answerPayload = unpickleElem payloadP + (fromJust $ iqResultPayload answer) + expect debug' (invertPayload payload) answerPayload + liftIO $ threadDelay 100000 + sendUser "All tests done" + endSession + liftIO . atomically $ takeTMVar wait return () return () diff --git a/tests/Stanzas.hs b/tests/Stanzas.hs new file mode 100644 index 0000000..23f6250 --- /dev/null +++ b/tests/Stanzas.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} +module Tests.Stanzas where + +import Data.Either +import Data.XML.Types +import Network.XMPP +import Network.XMPP.Marshal +import Network.XMPP.Pickle +import Network.XMPP.Types + +xml1 = Element {elementName = Name {nameLocalName = "iq", nameNamespace = Just "jabber:client", namePrefix = Nothing}, elementAttributes = [(Name {nameLocalName = "id", nameNamespace = Nothing, namePrefix = Nothing},[ContentText "2"]), (Name {nameLocalName = "type", nameNamespace = Nothing, namePrefix = Nothing},[ContentText "error"]),(Name {nameLocalName = "to", nameNamespace = Nothing, namePrefix = Nothing},[ContentText "testuser1@species64739.dyndns.org/bot1"]),(Name {nameLocalName = "from", nameNamespace = Nothing, namePrefix = Nothing},[ContentText "testuser2@species64739.dyndns.org/bot2"])], elementNodes = [NodeElement (Element {elementName = Name {nameLocalName = "error", nameNamespace = Just "jabber:client", namePrefix = Nothing}, elementAttributes = [(Name {nameLocalName = "type", nameNamespace = Nothing, namePrefix = Nothing},[ContentText "cancel"])], elementNodes = [NodeElement (Element {elementName = Name {nameLocalName = "service-unavailable", nameNamespace = Just "urn:ietf:params:xml:ns:xmpp-stanzas", namePrefix = Nothing}, elementAttributes = [], elementNodes = []})]})]} + +isRight (Right _) = True +isRight _ = False + + +testXML1 = isRight $ unpickleElem stanzaP xml1 \ No newline at end of file From 716e4476ee454cfb667ab6a030deb4dad302a36b Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Fri, 20 Apr 2012 12:19:20 +0200 Subject: [PATCH 12/29] Warning clean --- src/Network/XMPP/Concurrent/Monad.hs | 3 +- src/Network/XMPP/Concurrent/Threads.hs | 17 +++------- src/Network/XMPP/Concurrent/Types.hs | 1 + src/Network/XMPP/Monad.hs | 3 -- src/Network/XMPP/SASL.hs | 2 +- src/Network/XMPP/Stream.hs | 3 -- src/Network/XMPP/TLS.hs | 13 ++------ src/Network/XMPP/Types.hs | 44 +++----------------------- src/Tests.hs | 2 +- 9 files changed, 15 insertions(+), 73 deletions(-) diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index f9a2d75..7cd3d40 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -4,7 +4,6 @@ import Network.XMPP.Types import Control.Concurrent import Control.Concurrent.STM -import qualified Control.Exception.Lifted as Ex import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.State.Strict @@ -156,7 +155,7 @@ withConnection a = do liftIO . throwTo readerId $ Interrupt wait s <- liftIO . atomically $ do putTMVar wait () - takeTMVar write + _ <- takeTMVar write takeTMVar stateRef (res, s') <- liftIO $ runStateT a s liftIO . atomically $ do diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index 961fd68..a801b05 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -10,18 +10,13 @@ import Control.Concurrent.STM import qualified Control.Exception.Lifted as Ex import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Trans import Control.Monad.Reader import Control.Monad.State.Strict 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.XML.Types @@ -31,7 +26,6 @@ import Network.XMPP.Pickle import Network.XMPP.Concurrent.Types import Text.XML.Stream.Elements -import qualified Text.XML.Stream.Render as XR import GHC.IO (unsafeUnmask) @@ -64,7 +58,8 @@ readWorker messageC presenceC handlers stateRef = _ <- readTChan messageC -- Sic! return () -- this may seem ridiculous, but to prevent - -- the channel from filling up we immedtiately remove the + -- the channel from filling up we + -- immedtiately remove the -- Stanza we just put in. It will still be -- available in duplicates. MessageErrorS m -> do writeTChan messageC $ Left m @@ -88,6 +83,7 @@ readWorker messageC presenceC handlers stateRef = allowInterrupt :: IO () allowInterrupt = unsafeUnmask $ return () +handleIQRequest :: TVar IQHandlers -> IQRequest -> STM () handleIQRequest handlers iq = do (byNS, _) <- readTVar handlers let iqNS = fromMaybe "" (nameNamespace . elementName $ iqRequestPayload iq) @@ -97,6 +93,7 @@ handleIQRequest handlers iq = do sent <- newTVar False writeTChan ch (iq, sent) +handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> STM () handleIQResponse handlers iq = do (byNS, byID) <- readTVar handlers case Map.updateLookupWithKey (\_ _ -> Nothing) (iqID iq) byID of @@ -107,7 +104,7 @@ handleIQResponse handlers iq = do writeTVar handlers (byNS, byID') where iqID (Left err) = iqErrorID err - iqID (Right iq) = iqResultID iq + iqID (Right iq') = iqResultID iq' writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO ()) -> IO () writeWorker stCh writeR = forever $ do @@ -137,14 +134,12 @@ startThreads = do writeLock <- liftIO . newTMVarIO =<< gets sConPushBS messageC <- liftIO newTChanIO presenceC <- liftIO newTChanIO - iqC <- liftIO newTChanIO outC <- liftIO newTChanIO handlers <- liftIO $ newTVarIO ( Map.empty, Map.empty) eh <- liftIO $ newTVarIO zeroEventHandlers conS <- liftIO . newTMVarIO =<< get lw <- liftIO . forkIO $ writeWorker outC writeLock cp <- liftIO . forkIO $ connPersist writeLock - s <- get rd <- liftIO . forkIO $ readWorker messageC presenceC handlers conS return (messageC, presenceC, handlers, outC , killConnection writeLock [lw, rd, cp] @@ -170,7 +165,6 @@ runThreaded a = do curId <- readTVar idRef writeTVar idRef (curId + 1 :: Integer) return . read. show $ curId - s <- get liftIO . putStrLn $ "starting application" liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR rdr getId conS eh stopThreads') @@ -181,5 +175,4 @@ connPersist lock = forever $ do pushBS <- atomically $ takeTMVar lock pushBS " " atomically $ putTMVar lock pushBS --- putStrLn "" threadDelay 30000000 diff --git a/src/Network/XMPP/Concurrent/Types.hs b/src/Network/XMPP/Concurrent/Types.hs index 26b9418..3f741f1 100644 --- a/src/Network/XMPP/Concurrent/Types.hs +++ b/src/Network/XMPP/Concurrent/Types.hs @@ -26,6 +26,7 @@ data EventHandlers = EventHandlers , connectionClosedHandler :: XMPPThread () } +zeroEventHandlers :: EventHandlers zeroEventHandlers = EventHandlers { sessionEndHandler = return () , connectionClosedHandler = return () diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 2ff458e..f860c15 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -13,7 +13,6 @@ import Control.Monad.State.Strict import Data.ByteString as BS import Data.Conduit import Data.Conduit.Binary as CB -import Data.Conduit.List as CL import Data.Text(Text) import Data.XML.Pickle import Data.XML.Types @@ -27,8 +26,6 @@ import System.IO import Text.XML.Stream.Elements import Text.XML.Stream.Parse as XP -import Text.XML.Stream.Render as XR - pushN :: Element -> XMPPConMonad () pushN x = do diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 589146d..6dc8ec6 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -78,7 +78,7 @@ xmppStartSASL realm username passwd = do Right _ -> return () pushN saslResponse2E Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pullE - xmppRestartStream + _ <- xmppRestartStream return () createResponse :: Random.RandomGen g diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index 6f750e4..c192116 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -3,9 +3,6 @@ module Network.XMPP.Stream where -import Control.Applicative((<$>)) -import Control.Exception(throwIO) -import Control.Monad(unless) import Control.Monad.Error import Control.Monad.State.Strict diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index df88b46..b5a91a4 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -9,24 +9,15 @@ import qualified Control.Exception.Lifted as Ex import Control.Monad import Control.Monad.Error import Control.Monad.State.Strict -import Control.Monad.Trans -import Data.Conduit -import Data.Conduit.List as CL import Data.Conduit.TLS as TLS -import Data.Default import Data.Typeable import Data.XML.Types -import qualified Network.TLS as TLS -import qualified Network.TLS.Extra as TLS import Network.XMPP.Monad import Network.XMPP.Stream import Network.XMPP.Types -import qualified Text.XML.Stream.Render as XR - - starttlsE :: Element starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] @@ -41,7 +32,7 @@ exampleParams = TLS.defaultParams , pUseSecureRenegotiation = False -- No renegotiation , pCertificates = [] -- TODO , pLogging = TLS.defaultLogging -- TODO - , onCertificatesRecv = \ certificate -> + , onCertificatesRecv = \ _certificate -> return TLS.CertificateUsageAccept } @@ -68,7 +59,7 @@ xmppStartTLS params = Ex.handle (return . Left . TLSError) case answer of Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return () _ -> throwError $ TLSStreamError StreamXMLError - (raw, snk, psh, ctx) <- lift $ TLS.tlsinit params handle + (raw, _snk, psh, ctx) <- lift $ TLS.tlsinit params handle lift $ modify (\x -> x { sRawSrc = raw -- , sConSrc = -- Note: this momentarily leaves us in an diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index 1f59194..b08d15e 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -15,7 +15,7 @@ module Network.XMPP.Types ( IQError(..) , IQRequest(..) , IQRequestType(..) - , IQResponse(..) + , IQResponse , IQResult(..) , IdGenerator(..) , LangTag (..) @@ -37,7 +37,7 @@ module Network.XMPP.Types , StanzaId(..) , StreamError(..) , Version(..) - , XMPPConMonad(..) + , XMPPConMonad , XMPPConState(..) , XMPPT(..) , parseLangTag @@ -56,7 +56,6 @@ import Control.Monad.Error import qualified Data.ByteString as BS import Data.Conduit -import Data.List.Split as L import Data.String(IsString(..)) import Data.Text (Text) import qualified Data.Text as Text @@ -69,15 +68,6 @@ import Network.XMPP.JID import System.IO - --- | The string prefix MUST be - -data SessionSettings = - SessionSettings { ssIdPrefix :: String - , ssIdGenerator :: IdGenerator - , ssStreamLang :: LangTag } - - -- ============================================================================= -- STANZA TYPES -- ============================================================================= @@ -535,39 +525,14 @@ instance Read SASLError where readsPrec _ "mechanism-too-weak" = [(SASLMechanismTooWeak , "")] readsPrec _ "not-authorized" = [(SASLNotAuthorized , "")] readsPrec _ "temporary-auth-failure" = [(SASLTemporaryAuthFailure , "")] + readsPrec _ _ = [] -- | Readability type for host name Texts. -- type HostName = Text -- This is defined in Network as well - --- | Readability type for port number Integers. - -type PortNumber = Integer -- We use N(etwork).PortID (PortNumber) internally - - --- | Readability type for user name Texts. - -type UserName = Text - - --- | Readability type for password Texts. - -type Password = Text - - --- | Readability type for (Address) resource identifier Texts. - -type Resource = Text - - -type StreamID = Text - - data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq) -type Timeout = Int - data StreamError = StreamError String | StreamWrongVersion Text | StreamXMLError @@ -640,8 +605,6 @@ instance Read LangTag where -- all (\ (a, b) -> map toLower a == map toLower b) $ zip as bs -- | otherwise = False - - data ServerFeatures = SF { stls :: Maybe Bool , saslMechanisms :: [Text.Text] @@ -659,6 +622,7 @@ data XMPPConState = XMPPConState , sUsername :: Maybe Text , sResource :: Maybe Text , sCloseConnection :: IO () + -- TODO: add default Language } -- | diff --git a/src/Tests.hs b/src/Tests.hs index d5621ab..ff194c4 100644 --- a/src/Tests.hs +++ b/src/Tests.hs @@ -100,7 +100,7 @@ runMain debug number = do Right _ -> return () Left e -> error e xmppThreadedBind (resourcepart we) --- startSession + startSession debug' "session standing" sendPresence presenceOnline forkXMPP autoAccept From 7487b1ab3bfab8a54469e0e6c6155dfd622eca16 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Sat, 21 Apr 2012 17:41:56 +0200 Subject: [PATCH 13/29] rewrote the id generation code to adhere to the IdGenerator newtype used in Types.hs, and to use stm and (for the most part) Text --- src/Network/XMPP/Utilities.hs | 114 +++++++++------------------------- 1 file changed, 31 insertions(+), 83 deletions(-) diff --git a/src/Network/XMPP/Utilities.hs b/src/Network/XMPP/Utilities.hs index 8e53b7c..794fe0f 100644 --- a/src/Network/XMPP/Utilities.hs +++ b/src/Network/XMPP/Utilities.hs @@ -1,64 +1,57 @@ --- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the --- Pontarius distribution for more details. +-- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the Pontarius +-- distribution for more details. --- This module currently converts XML elements to strings. - --- TODO: Use -fno-cse? http://cvs.haskell.org/Hugs/pages/libraries/base/System-IO-Unsafe.html --- TODO: Remove elementsToString? +-- TODO: More efficient to use Text instead of Strings for ID generation? {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings #-} -module Network.XMPP.Utilities ( idGenerator - , nextId - -- elementToString - -- , elementsToString ) where - ) where +module Network.XMPP.Utilities (idGenerator) where import Network.XMPP.Types -import Prelude hiding (concat) - -import Data.ByteString (ByteString, concat) -import Data.ByteString.Char8 (unpack) - -import Data.Enumerator (($$), Stream (Chunks), Enumerator, Step (Continue), joinI, run_, returnI) -import Data.Enumerator.List (consume) - -import Data.XML.Types (Document (..), Element (..), Event (..), Name (..), Prologue (..)) - -import Data.IORef (atomicModifyIORef, newIORef) - - --- import Text.XML.Enumerator.Render (renderBytes) --- import Text.XML.Enumerator.Document (toEvents) +import Control.Monad.STM +import Control.Concurrent.STM.TVar +import Prelude -import System.IO.Unsafe (unsafePerformIO) +import qualified Data.Text as Text -- | --- Creates a new stanza "IdGenerator". Internally, it will maintain an infinite --- list of stanza IDs ('[\'a\', \'b\', \'c\'...]'). +-- Creates a new @IdGenerator@. Internally, it will maintain an infinite list of +-- IDs ('[\'a\', \'b\', \'c\'...]'). The argument is a prefix to prepend the IDs +-- with. Calling the function will extract an ID and update the generator's +-- internal state so that the same ID will not be generated again. -idGenerator :: String -> IO IdGenerator +idGenerator :: Text.Text -> IO IdGenerator -idGenerator p = newIORef (ids p) >>= \ ioRef -> return $ IdGenerator ioRef +idGenerator prefix = atomically $ do + tvar <- newTVar $ ids prefix + return $ IdGenerator $ next tvar where - -- Generates an infinite and predictable list of IDs, all - -- beginning with the provided prefix. + -- Transactionally extract the next ID from the infinite list of IDs. - ids :: String -> [String] + next :: TVar [Text.Text] -> IO Text.Text + next tvar = atomically $ do + list <- readTVar tvar + writeTVar tvar $ tail list + return $ head list + + -- Generates an infinite and predictable list of IDs, all beginning with the + -- provided prefix. + + ids :: Text.Text -> [Text.Text] -- Adds the prefix to all combinations of IDs (ids'). - ids p = map (\ id -> p ++ id) ids' + ids p = map (\ id -> Text.append p id) ids' where -- Generate all combinations of IDs, with increasing length. - ids' :: [String] - ids' = concatMap ids'' [1..] + ids' :: [Text.Text] + ids' = map Text.pack $ concatMap ids'' [1..] -- Generates all combinations of IDs with the given length. ids'' :: Integer -> [String] @@ -67,49 +60,4 @@ idGenerator p = newIORef (ids p) >>= \ ioRef -> return $ IdGenerator ioRef -- Characters allowed in IDs. repertoire :: String - repertoire = ['a'..'z'] - - - --- | --- Extracts an ID from the "IDGenerator", and updates the generators internal --- state so that the same ID will not be generated again. - -nextId :: IdGenerator -> IO String - -nextId g = let IdGenerator ioRef = g - in atomicModifyIORef ioRef (\ (i:is) -> (is, i)) - - - --- Converts the Element objects to a document, converts it into Events, strips --- the DocumentBegin event, generates a ByteString, and converts it into a --- String, aggregates the results and returns a string. - --- elementsToString :: [Element] -> String - --- elementsToString [] = "" --- elementsToString (e:es) = (elementToString (Just e)) ++ (elementsToString es) - - --- Converts the Element object to a document, converts it into Events, strips --- the DocumentBegin event, generates a ByteString, and converts it into a --- String. - --- {-# NOINLINE elementToString #-} - --- elementToString :: Maybe Element -> String - --- elementToString Nothing = "" --- elementToString (Just elem) = unpack $ concat $ unsafePerformIO $ do --- r <- run_ $ events $$ (joinI $ renderBytes $$ consume) --- return r --- where - - -- Enumerator that "produces" the events to convert to the document --- events :: Enumerator Event IO [ByteString] --- events (Continue more) = more $ Chunks (tail $ toEvents $ dummyDoc elem) --- events step = returnI step - --- dummyDoc :: Element -> Document --- dummyDoc e = Document (Prologue [] Nothing []) elem [] + repertoire = ['a'..'z'] \ No newline at end of file From 0e412cd782f319b89e73334627111907a8bc471a Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sat, 21 Apr 2012 19:12:13 +0200 Subject: [PATCH 14/29] replaced jidParts by a more readble Version --- src/Network/XMPP/JID.hs | 54 +++++++++++++++++++++++++++-------------- 1 file changed, 36 insertions(+), 18 deletions(-) diff --git a/src/Network/XMPP/JID.hs b/src/Network/XMPP/JID.hs index b1f0783..f481433 100644 --- a/src/Network/XMPP/JID.hs +++ b/src/Network/XMPP/JID.hs @@ -120,25 +120,43 @@ isFull jid = not $ isBare jid -- Parses an JID string and returns its three parts. It performs no -- validation or transformations. We are using Parsec to parse the -- JIDs. There is no input for which 'jidParts' fails. -jidParts :: AP.Parser (Maybe Text, Text, Maybe Text) + jidParts = do - a <- firstPartP - b <- Just <$> domainPartP <|> (return Nothing) - c <- Just <$> resourcePartP <|> (return Nothing) - case (a,b,c) of - -- Whether or not we have a resource part, if there is no "@" - -- x is the domain - (x, Nothing, z) -> return (Nothing, x, z) - -- When we do have an "@", x is the localpart - (x, Just y, z) -> return (Just x, y, z) - -firstPartP = AP.takeWhile1 (AP.notInClass ['@', '/']) -domainPartP = do - _ <- AP.char '@' - AP.takeWhile1 (/= '/') -resourcePartP = do - _ <- AP.char '/' - AP.takeText + -- Read until we reach an '@', a '/', or EOF. + a <- AP.takeWhile1 (AP.notInClass ['@', '/']) + -- Case 1: We found an '@', and thus the localpart. At least the + -- domainpart is remaining. Read the '@' and until a '/' or EOF. + do + b <- domainPartP + -- Case 1A: We found a '/' and thus have all the JID parts. Read + -- the '/' and until EOF. + do + c <- resourcePartP -- Parse resourcepart + return (Just a, b, Just c) + -- Case 1B: We have reached EOF; the JID is in the form + -- localpart@domainpart. + <|> do + AP.endOfInput + return (Just a, b, Nothing) + -- Case 2: We found a '/'; the JID is in the form + -- domainpart/resourcepart. + <|> do + b <- resourcePartP + AP.endOfInput + return (Nothing, a, Just b) + -- Case 3: We have reached EOF; we have an JID consisting of only + -- a domainpart. + <|> do + AP.endOfInput + return (Nothing, a, Nothing) + where + domainPartP = do + _ <- AP.char '@' + AP.takeWhile1 (/= '/') + resourcePartP = do + _ <- AP.char '/' + AP.takeText + nodeprepProfile :: SP.StringPrepProfile nodeprepProfile = SP.Profile From fc74d2df894a0aad13811822cdfcd01200bc1e1b Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Sat, 21 Apr 2012 19:18:43 +0200 Subject: [PATCH 15/29] recommitted version functions, rewritten to work with Text and attoparsec --- src/Network/XMPP/Utilities.hs | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/src/Network/XMPP/Utilities.hs b/src/Network/XMPP/Utilities.hs index 794fe0f..7841698 100644 --- a/src/Network/XMPP/Utilities.hs +++ b/src/Network/XMPP/Utilities.hs @@ -15,6 +15,7 @@ import Control.Monad.STM import Control.Concurrent.STM.TVar import Prelude +import qualified Data.Attoparsec.Text as AP import qualified Data.Text as Text @@ -60,4 +61,26 @@ idGenerator prefix = atomically $ do -- Characters allowed in IDs. repertoire :: String - repertoire = ['a'..'z'] \ No newline at end of file + repertoire = ['a'..'z'] + + +-- Converts a "." numeric version number to a @Version@ object. +versionFromString :: Text.Text -> Maybe Version +versionFromString s = case AP.parseOnly versionParser s of + Right version -> Just version + Left _ -> Nothing + + +-- Constructs a "Version" based on the major and minor version numbers. +versionFromNumbers :: Integer -> Integer -> Version +versionFromNumbers major minor = Version major minor + + +-- Read numbers, a dot, more numbers, and end-of-file. +versionParser :: AP.Parser Version +versionParser = do + major <- AP.many1 AP.digit + AP.skip (\ c -> c == '.') + minor <- AP.many1 AP.digit + AP.endOfInput + return $ Version (read major) (read minor) \ No newline at end of file From d33f32d5cc06179e1367214100bb5e39ea4c02bf Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Sat, 21 Apr 2012 19:23:48 +0200 Subject: [PATCH 16/29] removed head and tail --- src/Network/XMPP/Utilities.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Network/XMPP/Utilities.hs b/src/Network/XMPP/Utilities.hs index 7841698..039924a 100644 --- a/src/Network/XMPP/Utilities.hs +++ b/src/Network/XMPP/Utilities.hs @@ -38,8 +38,11 @@ idGenerator prefix = atomically $ do next :: TVar [Text.Text] -> IO Text.Text next tvar = atomically $ do list <- readTVar tvar - writeTVar tvar $ tail list - return $ head list + case list of + [] -> error "empty list in Utilities.hs" + (x:xs) -> do + writeTVar tvar xs + return x -- Generates an infinite and predictable list of IDs, all beginning with the -- provided prefix. From 6b9ebabc0179dbde99108b2635dd5f0e4895bc23 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Sat, 21 Apr 2012 20:38:31 +0200 Subject: [PATCH 17/29] added rewritten langtag functions using Text and attoparsec --- src/Network/XMPP/Utilities.hs | 35 +++++++++++++++++++++++++++++++++-- 1 file changed, 33 insertions(+), 2 deletions(-) diff --git a/src/Network/XMPP/Utilities.hs b/src/Network/XMPP/Utilities.hs index 039924a..7be7b6a 100644 --- a/src/Network/XMPP/Utilities.hs +++ b/src/Network/XMPP/Utilities.hs @@ -14,6 +14,7 @@ import Network.XMPP.Types import Control.Monad.STM import Control.Concurrent.STM.TVar import Prelude +import Control.Applicative (many) import qualified Data.Attoparsec.Text as AP import qualified Data.Text as Text @@ -83,7 +84,37 @@ versionFromNumbers major minor = Version major minor versionParser :: AP.Parser Version versionParser = do major <- AP.many1 AP.digit - AP.skip (\ c -> c == '.') + AP.skip (== '.') minor <- AP.many1 AP.digit AP.endOfInput - return $ Version (read major) (read minor) \ No newline at end of file + return $ Version (read major) (read minor) + + +-- | Parses, validates, and possibly constructs a "LangTag" object. +langTag :: Text.Text -> Maybe LangTag +langTag s = case AP.parseOnly langTagParser s of + Right tag -> Just tag + Left _ -> Nothing + + +-- Parses a language tag as defined by RFC 1766 and constructs a LangTag object. +langTagParser :: AP.Parser LangTag +langTagParser = do + -- Read until we reach a '-' character, or EOF. This is the `primary tag'. + primTag <- tag + -- Read zero or more subtags. + subTags <- many subtag + AP.endOfInput + return $ LangTag primTag subTags + where + tag :: AP.Parser Text.Text + tag = do + t <- AP.takeWhile1 $ AP.inClass tagChars + return t + subtag :: AP.Parser Text.Text + subtag = do + AP.skip (== '-') + subtag <- tag + return subtag + tagChars :: [Char] + tagChars = ['a'..'z'] ++ ['A'..'Z'] \ No newline at end of file From b9774d297a912e1ead9bce1820a032b18b272ae4 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 23 Apr 2012 13:08:28 +0200 Subject: [PATCH 18/29] Added some SASL failure handling --- src/Network/XMPP/JID.hs | 1 - src/Network/XMPP/SASL.hs | 84 +++++++++++++++++++++++++--------------- 2 files changed, 53 insertions(+), 32 deletions(-) diff --git a/src/Network/XMPP/JID.hs b/src/Network/XMPP/JID.hs index f481433..304a098 100644 --- a/src/Network/XMPP/JID.hs +++ b/src/Network/XMPP/JID.hs @@ -120,7 +120,6 @@ isFull jid = not $ isBare jid -- Parses an JID string and returns its three parts. It performs no -- validation or transformations. We are using Parsec to parse the -- JIDs. There is no input for which 'jidParts' fails. - jidParts = do -- Read until we reach an '@', a '/', or EOF. a <- AP.takeWhile1 (AP.notInClass ['@', '/']) diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 6dc8ec6..24f4288 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -2,7 +2,9 @@ module Network.XMPP.SASL where import Control.Applicative +import Control.Arrow (left) import Control.Monad +import Control.Monad.Error import Control.Monad.IO.Class import Control.Monad.State.Strict @@ -50,35 +52,53 @@ saslResponse2E = [] [] -xmppSASL:: Text -> Text -> XMPPConMonad (Either String Text) -xmppSASL uname passwd = do +data SaslError = SaslXmlError + | SaslMechanismError [Text] + | SaslChallengeError + | SaslStreamError StreamError + | SaslConnectionError + +instance Error SaslError where + noMsg = SaslXmlError + +xmppSASL:: Text -> Text -> XMPPConMonad (Either SaslError Text) +xmppSASL uname passwd = runErrorT $ do realm <- gets sHostname case realm of Just realm' -> do - xmppStartSASL realm' uname passwd + ErrorT $ xmppStartSASL realm' uname passwd modify (\s -> s{sUsername = Just uname}) - return $ Right uname - Nothing -> return $ Left "No connection found" + return uname + Nothing -> throwError SaslConnectionError xmppStartSASL :: Text -> Text -> Text - -> XMPPConMonad () -xmppStartSASL realm username passwd = do + -> XMPPConMonad (Either SaslError ()) +xmppStartSASL realm username passwd = runErrorT $ do mechanisms <- gets $ saslMechanisms . sFeatures - unless ("DIGEST-MD5" `elem` mechanisms) . error $ "No usable auth mechanism: " ++ show mechanisms - pushN $ saslInitE "DIGEST-MD5" - Right challenge <- B64.decode . Text.encodeUtf8<$> pullPickle challengePickle - let Right pairs = toPairs challenge + unless ("DIGEST-MD5" `elem` mechanisms) + . throwError $ SaslMechanismError mechanisms + lift . pushN $ saslInitE "DIGEST-MD5" + challenge' <- lift $ B64.decode . Text.encodeUtf8<$> pullPickle challengePickle + challenge <- case challenge' of + Left _e -> throwError SaslChallengeError + Right r -> return r + pairs <- case toPairs challenge of + Left _ -> throwError SaslChallengeError + Right p -> return p g <- liftIO $ Random.newStdGen - pushN . saslResponseE $ createResponse g realm username passwd pairs - challenge2 <- pullPickle (xpEither failurePickle challengePickle) + lift . pushN . saslResponseE $ createResponse g realm username passwd pairs + challenge2 <- lift $ pullPickle (xpEither failurePickle challengePickle) case challenge2 of - Left x -> error $ show x + Left _x -> throwError $ SaslXmlError Right _ -> return () - pushN saslResponse2E - Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pullE - _ <- xmppRestartStream + lift $ pushN saslResponse2E + e <- lift pullE + case e of + Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] -> return () + _ -> throwError SaslXmlError -- TODO: investigate + _ <- ErrorT $ left SaslStreamError <$> xmppRestartStream return () createResponse :: Random.RandomGen g @@ -93,16 +113,15 @@ createResponse g hostname username passwd' pairs = let Just nonce = L.lookup "nonce" pairs uname = Text.encodeUtf8 username passwd = Text.encodeUtf8 passwd' - realm = Text.encodeUtf8 hostname -- Using Int instead of Word8 for random 1.0.0.0 (GHC 7) -- compatibility. cnonce = BS.tail . BS.init . B64.encode . BS.pack . map toWord8 . take 8 $ Random.randoms g nc = "00000001" - digestURI = ("xmpp/" `BS.append` realm) + digestURI = ("xmpp/" `BS.append` (Text.encodeUtf8 hostname)) digest = md5Digest uname - realm + (lookup "realm" pairs) passwd digestURI nc @@ -110,15 +129,18 @@ createResponse g hostname username passwd' pairs = let nonce cnonce response = BS.intercalate"," . map (BS.intercalate "=") $ - [["username" , quote uname ] - ,["realm" , quote realm ] - ,["nonce" , quote nonce ] - ,["cnonce" , quote cnonce ] - ,["nc" , nc ] - ,["qop" , qop ] - ,["digest-uri", quote digestURI ] - ,["response" , digest ] - ,["charset" , "utf-8" ] + [ ["username" , quote uname ]] + ++ case L.lookup "realm" pairs of + Just realm -> [["realm" , quote realm ]] + Nothing -> [] + ++ + [ ["nonce" , quote nonce ] + , ["cnonce" , quote cnonce ] + , ["nc" , nc ] + , ["qop" , qop ] + , ["digest-uri", quote digestURI ] + , ["response" , digest ] + , ["charset" , "utf-8" ] ] in Text.decodeUtf8 $ B64.encode response where @@ -150,7 +172,7 @@ toStrict = BS.concat . BL.toChunks -- TODO: this only handles MD5-sess md5Digest :: BS8.ByteString - -> BS8.ByteString + -> Maybe BS8.ByteString -> BS8.ByteString -> BS8.ByteString -> BS8.ByteString @@ -159,7 +181,7 @@ md5Digest :: BS8.ByteString -> BS8.ByteString -> BS8.ByteString md5Digest uname realm password digestURI nc qop nonce cnonce= - let ha1 = hash [hashRaw [uname,realm,password], nonce, cnonce] + let ha1 = hash [hashRaw [uname, maybe "" id realm, password], nonce, cnonce] ha2 = hash ["AUTHENTICATE", digestURI] in hash [ha1,nonce, nc, cnonce,qop,ha2] From b22ed42f5aacf3ba6adc35fb5ca786d3d8c813b1 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 24 Apr 2012 14:34:07 +0200 Subject: [PATCH 19/29] STM 2.2 compatibility --- src/Network/XMPP/Concurrent/Monad.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index 7cd3d40..4ec4c78 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -175,7 +175,7 @@ sendMessage = sendS . MessageS modifyHandlers :: (EventHandlers -> EventHandlers) -> XMPPThread () modifyHandlers f = do eh <- asks eventHandlers - liftIO . atomically $ modifyTVar eh f + liftIO . atomically $ writeTVar eh . f =<< readTVar eh setSessionEndHandler :: XMPPThread () -> XMPPThread () setSessionEndHandler eh = modifyHandlers (\s -> s{sessionEndHandler = eh}) From f2ab31fe71cc9c428154be1fe31fd6dab573d0f1 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 24 Apr 2012 23:12:31 +0200 Subject: [PATCH 20/29] preliminary shaping of API structure, documentation --- pontarius.cabal | 8 +- src/Data/Conduit/TLS.hs | 1 + src/Network/XMPP.hs | 152 +++++++++++++++++++++++---- src/Network/XMPP/Bind.hs | 4 +- src/Network/XMPP/Concurrent.hs | 11 +- src/Network/XMPP/Concurrent/Monad.hs | 11 +- src/Network/XMPP/Concurrent/Types.hs | 1 + src/Network/XMPP/JID.hs | 50 ++++++--- src/Network/XMPP/Message.hs | 18 +++- src/Network/XMPP/Presence.hs | 15 +-- src/Network/XMPP/TLS.hs | 1 + src/Network/XMPP/Types.hs | 92 ++++++++-------- src/Tests.hs | 14 +-- src/Text/XML/Stream/Elements.hs | 1 + 14 files changed, 271 insertions(+), 108 deletions(-) diff --git a/pontarius.cabal b/pontarius.cabal index 5240d2f..e555639 100644 --- a/pontarius.cabal +++ b/pontarius.cabal @@ -12,7 +12,7 @@ Stability: alpha Bug-Reports: mailto:jon.kristensen@nejla.com -- Package-URL: Synopsis: An incomplete implementation of RFC 6120 (XMPP: Core) -Description: Pontarius is a work in progress of an implementation of +Description: Pontarius is a work in progress implementation of RFC 6120 (XMPP: Core). Category: Network Tested-With: GHC == 7.4.1 @@ -61,8 +61,10 @@ Library , Network.XMPP.TLS , Network.XMPP.Bind , Network.XMPP.Session - , Text.XML.Stream.Elements - , Data.Conduit.TLS + Other-modules: Network.XMPP.JID + , Network.XMPP.Concurrent.IQ + , Network.XMPP.Concurrent.Threads + , Network.XMPP.Concurrent.Monad GHC-Options: -Wall diff --git a/src/Data/Conduit/TLS.hs b/src/Data/Conduit/TLS.hs index 642ba6e..4673353 100644 --- a/src/Data/Conduit/TLS.hs +++ b/src/Data/Conduit/TLS.hs @@ -1,4 +1,5 @@ {-# Language NoMonomorphismRestriction #-} +{-# OPTIONS_HADDOCK hide #-} module Data.Conduit.TLS ( tlsinit -- , conduitStdout diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index 76d87a8..1a78a42 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -13,9 +13,12 @@ -- Stability: unstable -- Portability: portable -- --- XMPP is an open standard, extendable, and secure communications --- protocol designed on top of XML, TLS, and SASL. Pontarius XMPP is --- an XMPP client library, implementing the core capabilities of XMPP +-- The Extensible Messaging and Presence Protocol (XMPP) is an open technology for +-- real-time communication, which powers a wide range of applications including +-- instant messaging, presence, multi-party chat, voice and video calls, +-- collaboration, lightweight middleware, content syndication, and generalized +-- routing of XML data. +-- Pontarius an XMPP client library, implementing the core capabilities of XMPP -- (RFC 6120). -- -- Developers using this library are assumed to understand how XMPP @@ -30,21 +33,109 @@ {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} module Network.XMPP - ( module Network.XMPP.Bind - , module Network.XMPP.Concurrent - , module Network.XMPP.Monad - , module Network.XMPP.SASL - , module Network.XMPP.Session - , module Network.XMPP.Stream - , module Network.XMPP.TLS - , module Network.XMPP.Types - , module Network.XMPP.Presence - , module Network.XMPP.Message - , xmppConnect - , xmppNewSession + ( -- * Session management + xmppNewSession , connect , startTLS , auth + , endSession + , setSessionEndHandler + -- * JID + -- | A JID (historically: Jabber ID) is XMPPs native format + -- for addressing entities in the network. It is somewhat similar to an + -- email-address but contains three parts instead of two: + , JID(..) + -- * Stanzas + -- | @Stanzas@ are the the smallest unit of communication in @XMPP@. They + -- come in 3 flavors: + -- + -- * @'Message'@, for traditional IM-style message passing between peers + -- + -- * @'Presence'@, for communicating status updates + -- + -- * IQ (info/query), with a request-response semantics + -- + -- All stanza types have the following attributes in common: + -- + -- * The /id/ attribute is used by the originating entity to track + -- any response or error stanza that it might receive in relation to + -- the generated stanza from another entity (such as an intermediate + -- server or the intended recipient). It is up to the originating + -- entity whether the value of the 'id' attribute is unique only + -- within its current stream or unique globally. + -- + -- * The /from/ attribute specifies the JID of the sender. + -- + -- * The /to/ attribute specifies the JID of the intended recipient + -- for the stanza. + -- + -- * The /type/ attribute specifies the purpose or context of the + -- message, presence, or IQ stanza. The particular allowable values + -- for the 'type' attribute vary depending on whether the stanza is + -- a message, presence, or IQ stanza. + + -- ** Messages + -- | The /message/ stanza is a /push/ mechanism whereby one entity pushes + -- information to another entity, similar to the communications that occur in + -- a system such as email. + -- + -- + , Message + , MessageError + -- *** creating + , module Network.XMPP.Message + -- *** sending + , sendMessage + -- *** receiving + , pullMessage + , waitForMessage + , waitForMessageError + , filterMessages + -- ** Presence + -- | The /presence/ stanza is a specialized /broadcast/ + -- or /publish-subscribe/ mechanism, whereby multiple entities + -- receive information about an entity to which they have + -- subscribed. + -- + -- + , Presence(..) + , PresenceError(..) + , ShowType(..) + -- *** creating + , module Network.XMPP.Presence + -- *** sending + , sendPresence + -- *** receiving + , pullPresence + , waitForPresence + -- ** IQ + -- | Info\/Query, or IQ, is a /request-response/ mechanism, similar in some + -- ways to the Hypertext Transfer Protocol @HTTP@. The semantics of IQ enable + -- an entity to make a request of, and receive a response from, another + -- entity. The data content and precise semantics of the request and response + -- is defined by the schema or other structural definition associated with the + -- XML namespace that + -- qualifies the direct child element of the IQ element. IQ interactions + -- follow a common pattern of structured data + -- exchange such as get/result or set/result (although an error can be returned + -- in reply to a request if appropriate) + -- + -- + , IQRequest(..) + , IQRequestType(..) + , IQResult(..) + , IQError(..) + , sendIQ + , sendIQ' + , answerIQ + , listenIQChan + , iqRequestPayload + , iqResultPayload + -- * Threads + , XMPPThread + , forkXMPP + -- * Misc + , exampleParams ) where import Data.Text as Text @@ -53,27 +144,46 @@ import Network import qualified Network.TLS as TLS import Network.XMPP.Bind import Network.XMPP.Concurrent -import Network.XMPP.Message +import Network.XMPP.Message hiding (message) import Network.XMPP.Monad -import Network.XMPP.Presence +import Network.XMPP.Presence hiding (presence) import Network.XMPP.SASL import Network.XMPP.Session import Network.XMPP.Stream import Network.XMPP.TLS import Network.XMPP.Types -xmppConnect :: HostName -> Text -> XMPPConMonad (Either StreamError ()) -xmppConnect address hostname = xmppRawConnect address hostname >> xmppStartStream +import Control.Monad.Error +-- | Create a new, pristine session without an active connection. xmppNewSession :: XMPPThread a -> IO (a, XMPPConState) xmppNewSession = withNewSession . runThreaded +-- | Connect to host with given address. +xmppConnect :: HostName -> Text -> XMPPConMonad (Either StreamError ()) +xmppConnect address hostname = xmppRawConnect address hostname >> xmppStartStream +-- | Attempts to secure the connection using TLS. Will return +-- 'TLSNoServerSupport' when the server does not offer TLS or does not +-- expect it at this time. startTLS :: TLS.TLSParams -> XMPPThread (Either XMPPTLSError ()) startTLS = withConnection . xmppStartTLS -auth :: Text.Text -> Text.Text -> XMPPThread (Either String Text.Text) -auth username passwd = withConnection $ xmppSASL username passwd + +-- | Authenticate to the server with the given username and password +-- and bind a resource +auth :: Text.Text -- ^ The username + -> Text.Text -- ^ The password + -> Maybe Text -- ^ The desired resource or 'Nothing' to let the server + -- assign one + -> XMPPThread (Either SaslError Text.Text) +auth username passwd resource = runErrorT $ do + ErrorT . withConnection $ xmppSASL username passwd + res <- lift $ xmppBind resource + lift $ startSession + return res + +-- | Connect to an xmpp server connect :: HostName -> Text -> XMPPThread (Either StreamError ()) connect address hostname = withConnection $ xmppConnect address hostname diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index 51be0c3..b525923 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -40,8 +40,8 @@ jidP = bindP $ xpElemNodes "jid" (xpContent xpPrim) -- server-generated resource and extract the JID from the non-error -- response. -xmppThreadedBind :: Maybe Text -> XMPPThread Text -xmppThreadedBind rsrc = do +xmppBind :: Maybe Text -> XMPPThread Text +xmppBind rsrc = do answer <- sendIQ' Nothing Set Nothing (bindBody rsrc) let (Right IQResult{iqResultPayload = Just b}) = answer -- TODO: Error handling let Right (JID _n _d (Just r)) = unpickleElem jidP b diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs index c360236..fe15713 100644 --- a/src/Network/XMPP/Concurrent.hs +++ b/src/Network/XMPP/Concurrent.hs @@ -1,9 +1,10 @@ module Network.XMPP.Concurrent -( module Network.XMPP.Concurrent.Types -, module Network.XMPP.Concurrent.Monad -, module Network.XMPP.Concurrent.Threads -, module Network.XMPP.Concurrent.IQ -) where + ( Thread + , XMPPThread + , module Network.XMPP.Concurrent.Monad + , module Network.XMPP.Concurrent.Threads + , module Network.XMPP.Concurrent.IQ + ) where import Network.XMPP.Concurrent.Types import Network.XMPP.Concurrent.Monad diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index 4ec4c78..f4a9f23 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -18,20 +18,23 @@ import Network.XMPP.Monad -- | Register a new IQ listener. IQ requests matching the type and namespace will -- be put in the channel. +-- +-- Return the new channel or Nothing if this namespace/'IQRequestType' +-- combination was alread handled listenIQChan :: IQRequestType -- ^ type of IQs to receive (Get / Set) -> Text -- ^ namespace of the child element - -> XMPPThread (Bool, TChan (IQRequest, TVar Bool)) + -> XMPPThread (Maybe ( TChan (IQRequest, TVar Bool))) listenIQChan tp ns = do handlers <- asks iqHandlers liftIO . atomically $ do (byNS, byID) <- readTVar handlers iqCh <- newTChan - let (present, byNS') = Map.insertLookupWithKey' (\_ new _ -> new) + let (present, byNS') = Map.insertLookupWithKey' (\_ _ old -> old) (tp,ns) iqCh byNS writeTVar handlers (byNS', byID) return $ case present of - Nothing -> (True, iqCh) - Just iqCh' -> (False, iqCh') + Nothing -> Just iqCh + Just iqCh' -> Nothing -- | get the inbound stanza channel, duplicates from master if necessary -- please note that once duplicated it will keep filling up, call diff --git a/src/Network/XMPP/Concurrent/Types.hs b/src/Network/XMPP/Concurrent/Types.hs index 3f741f1..fa15f7e 100644 --- a/src/Network/XMPP/Concurrent/Types.hs +++ b/src/Network/XMPP/Concurrent/Types.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE DeriveDataTypeable #-} module Network.XMPP.Concurrent.Types where diff --git a/src/Network/XMPP/JID.hs b/src/Network/XMPP/JID.hs index 304a098..9d44130 100644 --- a/src/Network/XMPP/JID.hs +++ b/src/Network/XMPP/JID.hs @@ -37,16 +37,41 @@ import qualified Data.Text as Text import qualified Text.NamePrep as SP import qualified Text.StringPrep as SP --- | --- @From@ is a readability type synonym for @Address@. - --- | Jabber ID (JID) datatype -data JID = JID { localpart :: !(Maybe Text) - -- ^ Account name +data JID = JID { + -- | The @localpart@ of a JID is an optional identifier + -- placed before the domainpart and separated from the + -- latter by a \'\@\' character. Typically a + -- localpart uniquely identifies the entity requesting + -- and using network access provided by a server + -- (i.e., a local account), although it can also + -- represent other kinds of entities (e.g., a chat + -- room associated with a multi-user chat service). + -- The entity represented by an XMPP localpart is + -- addressed within the context of a specific domain + -- (i.e., @localpart\@domainpart@). + + localpart :: !(Maybe Text) + -- | The domainpart typically identifies the /home/ + -- server to which clients connect for XML routing and + -- data management functionality. However, it is not + -- necessary for an XMPP domainpart to identify an + -- entity that provides core XMPP server functionality + -- (e.g., a domainpart can identify an entity such as a + -- multi-user chat service, a publish-subscribe + -- service, or a user directory). , domainpart :: !Text - -- ^ Server adress + -- | The resourcepart of a JID is an optional + -- identifier placed after the domainpart and + -- separated from the latter by the \'\/\' character. A + -- resourcepart can modify either a + -- @localpart\@domainpart@ address or a mere + -- @domainpart@ address. Typically a resourcepart + -- uniquely identifies a specific connection (e.g., a + -- device or location) or object (e.g., an occupant + -- in a multi-user chat room) belonging to the entity + -- associated with an XMPP localpart at a domain + -- (i.e., @localpart\@domainpart/resourcepart@). , resourcepart :: !(Maybe Text) - -- ^ Resource name } instance Show JID where @@ -64,8 +89,7 @@ instance Read JID where instance IsString JID where fromString = fromJust . fromText . Text.pack --- | --- Converts a string to a JID. +-- | Converts a Text to a JID. fromText :: Text -> Maybe JID fromText t = do (l, d, r) <- eitherToMaybe $ AP.parseOnly jidParts t @@ -73,9 +97,7 @@ fromText t = do where eitherToMaybe = either (const Nothing) Just - --- | --- Converts localpart, domainpart, and resourcepart strings to a JID. +-- | Converts localpart, domainpart, and resourcepart strings to a JID. -- Runs the appropriate stringprep profiles and validates the parts. fromStrings :: Maybe Text -> Text -> Maybe Text -> Maybe JID fromStrings l d r = do @@ -108,7 +130,7 @@ fromStrings l d r = do -- validHostname :: Text -> Bool -- validHostname _ = True -- TODO --- | Returns True if the JID is `bare', and False otherwise. +-- | Returns True if the JID is /bare/, and False otherwise. isBare :: JID -> Bool isBare j | resourcepart j == Nothing = True | otherwise = False diff --git a/src/Network/XMPP/Message.hs b/src/Network/XMPP/Message.hs index 6d1dadc..b472dba 100644 --- a/src/Network/XMPP/Message.hs +++ b/src/Network/XMPP/Message.hs @@ -1,11 +1,21 @@ {-# LANGUAGE RecordWildCards #-} -module Network.XMPP.Message where +-- | Message handling +module Network.XMPP.Message + ( Message(..) + , MessageType(..) + , MessageError(..) + , message + , simpleMessage + , answerMessage + ) + where import Data.Text(Text) import Data.XML.Types import Network.XMPP.Types +-- The empty message message :: Message message = Message { messageID = Nothing , messageFrom = Nothing @@ -18,7 +28,11 @@ message = Message { messageID = Nothing , messagePayload = [] } -simpleMessage :: JID -> Text -> Message + +-- | Create simple message, containing nothing but a body text +simpleMessage :: JID -- ^ Recipient + -> Text -- ^ Myssage body + -> Message simpleMessage to txt = message { messageTo = Just to , messageBody = Just txt } diff --git a/src/Network/XMPP/Presence.hs b/src/Network/XMPP/Presence.hs index f948596..501f60f 100644 --- a/src/Network/XMPP/Presence.hs +++ b/src/Network/XMPP/Presence.hs @@ -1,9 +1,10 @@ +{-# OPTIONS_HADDOCK hide #-} module Network.XMPP.Presence where import Data.Text(Text) import Network.XMPP.Types - +-- | The empty presence. presence :: Presence presence = Presence { presenceID = Nothing , presenceFrom = Nothing @@ -16,6 +17,7 @@ presence = Presence { presenceID = Nothing , presencePayload = [] } +-- | Request subscription with an entity presenceSubscribe :: JID -> Presence presenceSubscribe to = presence { presenceTo = Just to , presenceType = Just Subscribe @@ -45,14 +47,15 @@ presenceUnsubscribe to = presence { presenceTo = Just to isPresenceUnsubscribe :: Presence -> Bool isPresenceUnsubscribe pres = presenceType pres == (Just Unsubscribe) --- | Signals to the server that the client is available for communication +-- | Signal to the server that the client is available for communication presenceOnline :: Presence presenceOnline = presence --- | Signals to the server that the client is no longer available for communication. +-- | Signal to the server that the client is no longer available for communication. presenceOffline :: Presence presenceOffline = presence {presenceType = Just Unavailable} +-- Change your status status :: Maybe Text -- ^ Status message -> Maybe ShowType -- ^ Status Type @@ -63,16 +66,16 @@ status txt showType prio = presence { presenceShowType = showType , presenceStatus = txt } --- | Sets the current availability status. This implicitly sets the clients +-- | Set the current availability status. This implicitly sets the clients -- status online presenceAvail :: ShowType -> Presence presenceAvail showType = status Nothing (Just showType) Nothing --- | Sets the current status message. This implicitly sets the clients +-- | Set the current status message. This implicitly sets the clients -- status online presenceMessage :: Text -> Presence presenceMessage txt = status (Just txt) Nothing Nothing --- | Adds a recipient to a presence notification +-- | Add a recipient to a presence notification presTo :: Presence -> JID -> Presence presTo pres to = pres{presenceTo = Just to} \ No newline at end of file diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index b5a91a4..8cfc0a4 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -36,6 +36,7 @@ exampleParams = TLS.defaultParams return TLS.CertificateUsageAccept } +-- | Error conditions that may arise during TLS negotiation. data XMPPTLSError = TLSError TLSError | TLSNoServerSupport | TLSNoConnection diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index b08d15e..c8f4619 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -117,10 +117,6 @@ data Stanza = IQRequestS IQRequest -- | -- A "request" Info/Query (IQ) stanza is one with either "get" or -- "set" as type. They are guaranteed to always contain a payload. --- --- Objects of this type cannot be generated by Pontarius applications, --- but are only created internally. - data IQRequest = IQRequest { iqRequestID :: StanzaId , iqRequestFrom :: Maybe JID , iqRequestTo :: Maybe JID @@ -130,7 +126,7 @@ data IQRequest = IQRequest { iqRequestID :: StanzaId } deriving (Show) - +-- | The type of request that is made data IQRequestType = Get | Set deriving (Eq, Ord) instance Show IQRequestType where @@ -142,21 +138,12 @@ instance Read IQRequestType where readsPrec _ "set" = [(Set, "")] readsPrec _ _ = [] - --- | --- A "response" Info/Query (IQ) stanza is one with either "result" or --- "error" as type. We have devided IQ responses into two types. --- --- Objects of this type cannot be generated by Pontarius applications, --- but are only created internally. +-- | A "response" Info/Query (IQ) stanza is eitheran 'IQError' or an IQ stanza +-- with the type "result" ('IQResult') type IQResponse = Either IQError IQResult - --- | --- Objects of this type cannot be generated by Pontarius applications, --- but are only created internally. - +-- | The answer to an IQ request data IQResult = IQResult { iqResultID :: StanzaId , iqResultFrom :: Maybe JID , iqResultTo :: Maybe JID @@ -164,11 +151,7 @@ data IQResult = IQResult { iqResultID :: StanzaId , iqResultPayload :: Maybe Element } deriving (Show) - --- | --- Objects of this type cannot be generated by Pontarius applications, --- but are only created internally. - +-- | The answer to an IQ request that generated an error data IQError = IQError { iqErrorID :: StanzaId , iqErrorFrom :: Maybe JID , iqErrorTo :: Maybe JID @@ -178,12 +161,7 @@ data IQError = IQError { iqErrorID :: StanzaId } deriving (Show) --- | --- A non-error message stanza. --- --- Objects of this type cannot be generated by Pontarius applications, --- but are only created internally. - +-- | The message stanza. Used for /push/ type communication data Message = Message { messageID :: Maybe StanzaId , messageFrom :: Maybe JID , messageTo :: Maybe JID @@ -196,13 +174,7 @@ data Message = Message { messageID :: Maybe StanzaId } deriving (Show) - --- | --- An error message stanza. --- --- Objects of this type cannot be generated by Pontarius applications, --- but are only created internally. - +-- | An error stanza generated in response to a 'Message' data MessageError = MessageError { messageErrorID :: Maybe StanzaId , messageErrorFrom :: Maybe JID , messageErrorTo :: Maybe JID @@ -213,15 +185,47 @@ data MessageError = MessageError { messageErrorID :: Maybe StanzaId deriving (Show) --- | --- @MessageType@ holds XMPP message types as defined in XMPP-IM. The --- "error" message type is left out as errors are wrapped in --- @MessageError@. - -data MessageType = Chat | -- ^ - GroupChat | -- ^ - Headline | -- ^ - Normal -- ^ The default message type +-- | The type of a Message being sent +-- () +data MessageType = -- | The message is sent in the context of a one-to-one chat + -- session. Typically an interactive client will present a + -- message of type /chat/ in an interface that enables + -- one-to-one chat between the two parties, including an + -- appropriate conversation history. + Chat + -- | The message is sent in the context of a + -- multi-user chat environment (similar to that of + -- @IRC@). Typically a receiving client will + -- present a message of type /groupchat/ in an + -- interface that enables many-to-many chat + -- between the parties, including a roster of + -- parties in the chatroom and an appropriate + -- conversation history. + | GroupChat + -- | The message provides an alert, a + -- notification, or other transient information to + -- which no reply is expected (e.g., news + -- headlines, sports updates, near-real-time + -- market data, or syndicated content). Because no + -- reply to the message is expected, typically a + -- receiving client will present a message of type + -- /headline/ in an interface that appropriately + -- differentiates the message from standalone + -- messages, chat messages, and groupchat messages + -- (e.g., by not providing the recipient with the + -- ability to reply). + | Headline + -- | The message is a standalone message that is + -- sent outside the context of a one-to-one + -- conversation or groupchat, and to which it is + -- expected that the recipient will + -- reply. Typically a receiving client will + -- present a message of type /normal/ in an + -- interface that enables the recipient to reply, + -- but without a conversation history. + -- + -- This is the /default/ value + | Normal deriving (Eq) diff --git a/src/Tests.hs b/src/Tests.hs index ff194c4..cca1d1f 100644 --- a/src/Tests.hs +++ b/src/Tests.hs @@ -53,9 +53,11 @@ payloadP = xpWrap (\((counter,flag) , message) -> Payload counter flag message) invertPayload (Payload count flag message) = Payload (count + 1) (not flag) (Text.reverse message) iqResponder = do - (free, chan) <- listenIQChan Get testNS - unless free $ liftIO $ putStrLn "Channel was already taken" - >> error "hanging up" + chan' <- listenIQChan Get testNS + chan <- case chan' of + Nothing -> liftIO $ putStrLn "Channel was already taken" + >> error "hanging up" + Just c -> return c forever $ do next@(iq,_) <- liftIO . atomically $ readTChan chan let Right payload = unpickleElem payloadP $ iqRequestPayload iq @@ -95,12 +97,10 @@ runMain debug number = do debug' "running" connect "localhost" "species64739.dyndns.org" startTLS exampleParams - saslResponse <- auth (fromJust $ localpart we) "pwd" + saslResponse <- auth (fromJust $ localpart we) "pwd" (resourcepart we) case saslResponse of Right _ -> return () - Left e -> error e - xmppThreadedBind (resourcepart we) - startSession + Left e -> error "saslerror" debug' "session standing" sendPresence presenceOnline forkXMPP autoAccept diff --git a/src/Text/XML/Stream/Elements.hs b/src/Text/XML/Stream/Elements.hs index 952854d..4be9ff6 100644 --- a/src/Text/XML/Stream/Elements.hs +++ b/src/Text/XML/Stream/Elements.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} module Text.XML.Stream.Elements where import Control.Applicative ((<$>)) From 70d9b5b47d44f9f99f21514ea6bdd765012ea99f Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 25 Apr 2012 11:43:35 +0200 Subject: [PATCH 21/29] renamed XMPPThread to XMPP renamed Thread to Session split runThreaded in newSession and WithNewSession --- src/Network/XMPP.hs | 16 ++----- src/Network/XMPP/Bind.hs | 2 +- src/Network/XMPP/Concurrent.hs | 4 +- src/Network/XMPP/Concurrent/IQ.hs | 6 +-- src/Network/XMPP/Concurrent/Monad.hs | 42 ++++++++--------- src/Network/XMPP/Concurrent/Threads.hs | 64 +++++++++++++------------- src/Network/XMPP/Concurrent/Types.hs | 46 +++++++++--------- src/Network/XMPP/Monad.hs | 4 +- src/Network/XMPP/Session.hs | 2 +- 9 files changed, 90 insertions(+), 96 deletions(-) diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index 1a78a42..b2a1e54 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -34,7 +34,7 @@ module Network.XMPP ( -- * Session management - xmppNewSession + withNewSession , connect , startTLS , auth @@ -132,7 +132,7 @@ module Network.XMPP , iqRequestPayload , iqResultPayload -- * Threads - , XMPPThread + , XMPP , forkXMPP -- * Misc , exampleParams @@ -155,10 +155,6 @@ import Network.XMPP.Types import Control.Monad.Error --- | Create a new, pristine session without an active connection. -xmppNewSession :: XMPPThread a -> IO (a, XMPPConState) -xmppNewSession = withNewSession . runThreaded - -- | Connect to host with given address. xmppConnect :: HostName -> Text -> XMPPConMonad (Either StreamError ()) xmppConnect address hostname = xmppRawConnect address hostname >> xmppStartStream @@ -166,18 +162,16 @@ xmppConnect address hostname = xmppRawConnect address hostname >> xmppStartStre -- | Attempts to secure the connection using TLS. Will return -- 'TLSNoServerSupport' when the server does not offer TLS or does not -- expect it at this time. -startTLS :: TLS.TLSParams -> XMPPThread (Either XMPPTLSError ()) +startTLS :: TLS.TLSParams -> XMPP (Either XMPPTLSError ()) startTLS = withConnection . xmppStartTLS - - -- | Authenticate to the server with the given username and password -- and bind a resource auth :: Text.Text -- ^ The username -> Text.Text -- ^ The password -> Maybe Text -- ^ The desired resource or 'Nothing' to let the server -- assign one - -> XMPPThread (Either SaslError Text.Text) + -> XMPP (Either SaslError Text.Text) auth username passwd resource = runErrorT $ do ErrorT . withConnection $ xmppSASL username passwd res <- lift $ xmppBind resource @@ -185,5 +179,5 @@ auth username passwd resource = runErrorT $ do return res -- | Connect to an xmpp server -connect :: HostName -> Text -> XMPPThread (Either StreamError ()) +connect :: HostName -> Text -> XMPP (Either StreamError ()) connect address hostname = withConnection $ xmppConnect address hostname diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index b525923..77b25c3 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -40,7 +40,7 @@ jidP = bindP $ xpElemNodes "jid" (xpContent xpPrim) -- server-generated resource and extract the JID from the non-error -- response. -xmppBind :: Maybe Text -> XMPPThread Text +xmppBind :: Maybe Text -> XMPP Text xmppBind rsrc = do answer <- sendIQ' Nothing Set Nothing (bindBody rsrc) let (Right IQResult{iqResultPayload = Just b}) = answer -- TODO: Error handling diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs index fe15713..2750ff1 100644 --- a/src/Network/XMPP/Concurrent.hs +++ b/src/Network/XMPP/Concurrent.hs @@ -1,6 +1,6 @@ module Network.XMPP.Concurrent - ( Thread - , XMPPThread + ( Session + , XMPP , module Network.XMPP.Concurrent.Monad , module Network.XMPP.Concurrent.Threads , module Network.XMPP.Concurrent.IQ diff --git a/src/Network/XMPP/Concurrent/IQ.hs b/src/Network/XMPP/Concurrent/IQ.hs index cc97898..6693397 100644 --- a/src/Network/XMPP/Concurrent/IQ.hs +++ b/src/Network/XMPP/Concurrent/IQ.hs @@ -17,7 +17,7 @@ sendIQ :: Maybe JID -- ^ Recipient (to) -> IQRequestType -- ^ IQ type (Get or Set) -> Maybe LangTag -- ^ Language tag of the payload (Nothing for default) -> Element -- ^ The iq body (there has to be exactly one) - -> XMPPThread (TMVar IQResponse) + -> XMPP (TMVar IQResponse) sendIQ to tp lang body = do -- TODO: add timeout newId <- liftIO =<< asks idGenerator handlers <- asks iqHandlers @@ -35,14 +35,14 @@ sendIQ' :: Maybe JID -> IQRequestType -> Maybe LangTag -> Element - -> XMPPThread IQResponse + -> XMPP IQResponse sendIQ' to tp lang body = do ref <- sendIQ to tp lang body liftIO . atomically $ takeTMVar ref answerIQ :: (IQRequest, TVar Bool) -> Either StanzaError (Maybe Element) - -> XMPPThread Bool + -> XMPP Bool answerIQ ((IQRequest iqid from _to lang _tp bd), sentRef) answer = do out <- asks outCh let response = case answer of diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index f4a9f23..2d97372 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -23,7 +23,7 @@ import Network.XMPP.Monad -- combination was alread handled listenIQChan :: IQRequestType -- ^ type of IQs to receive (Get / Set) -> Text -- ^ namespace of the child element - -> XMPPThread (Maybe ( TChan (IQRequest, TVar Bool))) + -> XMPP (Maybe ( TChan (IQRequest, TVar Bool))) listenIQChan tp ns = do handlers <- asks iqHandlers liftIO . atomically $ do @@ -39,7 +39,7 @@ listenIQChan tp ns = do -- | 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 (Either MessageError Message)) +getMessageChan :: XMPP (TChan (Either MessageError Message)) getMessageChan = do mChR <- asks messagesRef mCh <- liftIO $ readIORef mChR @@ -52,7 +52,7 @@ getMessageChan = do Just mCh' -> return mCh' -- | see 'getMessageChan' -getPresenceChan :: XMPPThread (TChan (Either PresenceError Presence)) +getPresenceChan :: XMPP (TChan (Either PresenceError Presence)) getPresenceChan = do pChR <- asks presenceRef pCh <- liftIO $ readIORef pChR @@ -66,40 +66,40 @@ getPresenceChan = do -- | Drop the local end of the inbound stanza channel -- from our context so it can be GC-ed -dropMessageChan :: XMPPThread () +dropMessageChan :: XMPP () dropMessageChan = do r <- asks messagesRef liftIO $ writeIORef r Nothing -- | see 'dropMessageChan' -dropPresenceChan :: XMPPThread () +dropPresenceChan :: XMPP () 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 (Either MessageError Message) +pullMessage :: XMPP (Either MessageError Message) pullMessage = do c <- getMessageChan liftIO $ atomically $ readTChan c -- | Read an element from the inbound stanza channel, acquiring a copy -- of the channel as necessary -pullPresence :: XMPPThread (Either PresenceError Presence) +pullPresence :: XMPP (Either PresenceError Presence) pullPresence = do c <- getPresenceChan liftIO $ atomically $ readTChan c -- | Send a stanza to the server -sendS :: Stanza -> XMPPThread () +sendS :: Stanza -> XMPP () sendS a = do out <- asks outCh liftIO . atomically $ writeTChan out a return () -- | Fork a new thread -forkXMPP :: XMPPThread () -> XMPPThread ThreadId +forkXMPP :: XMPP () -> XMPP ThreadId forkXMPP a = do thread <- ask mCH' <- liftIO $ newIORef Nothing @@ -110,7 +110,7 @@ forkXMPP a = do filterMessages :: (MessageError -> Bool) -> (Message -> Bool) - -> XMPPThread (Either MessageError Message) + -> XMPP (Either MessageError Message) filterMessages f g = do s <- pullMessage case s of @@ -119,7 +119,7 @@ filterMessages f g = do Right m | g m -> return $ Right m | otherwise -> filterMessages f g -waitForMessage :: (Message -> Bool) -> XMPPThread Message +waitForMessage :: (Message -> Bool) -> XMPP Message waitForMessage f = do s <- pullMessage case s of @@ -127,7 +127,7 @@ waitForMessage f = do Right m | f m -> return m | otherwise -> waitForMessage f -waitForMessageError :: (MessageError -> Bool) -> XMPPThread MessageError +waitForMessageError :: (MessageError -> Bool) -> XMPP MessageError waitForMessageError f = do s <- pullMessage case s of @@ -135,7 +135,7 @@ waitForMessageError f = do Left m | f m -> return m | otherwise -> waitForMessageError f -waitForPresence :: (Presence -> Bool) -> XMPPThread Presence +waitForPresence :: (Presence -> Bool) -> XMPP Presence waitForPresence f = do s <- pullPresence case s of @@ -149,7 +149,7 @@ waitForPresence f = do -- The Action will run in the calling thread/ -- NB: This will /not/ catch any exceptions. If you action dies, deadlocks -- or otherwisely exits abnormaly the XMPP session will be dead. -withConnection :: XMPPConMonad a -> XMPPThread a +withConnection :: XMPPConMonad a -> XMPP a withConnection a = do readerId <- asks readerThread stateRef <- asks conStateRef @@ -167,36 +167,36 @@ withConnection a = do return res -- | Send a presence Stanza -sendPresence :: Presence -> XMPPThread () +sendPresence :: Presence -> XMPP () sendPresence = sendS . PresenceS -- | Send a Message Stanza -sendMessage :: Message -> XMPPThread () +sendMessage :: Message -> XMPP () sendMessage = sendS . MessageS -modifyHandlers :: (EventHandlers -> EventHandlers) -> XMPPThread () +modifyHandlers :: (EventHandlers -> EventHandlers) -> XMPP () modifyHandlers f = do eh <- asks eventHandlers liftIO . atomically $ writeTVar eh . f =<< readTVar eh -setSessionEndHandler :: XMPPThread () -> XMPPThread () +setSessionEndHandler :: XMPP () -> XMPP () setSessionEndHandler eh = modifyHandlers (\s -> s{sessionEndHandler = eh}) -- | run an event handler -runHandler :: (EventHandlers -> XMPPThread a) -> XMPPThread a +runHandler :: (EventHandlers -> XMPP a) -> XMPP a runHandler h = do eh <- liftIO . atomically . readTVar =<< asks eventHandlers h eh -- | End the current xmpp session -endSession :: XMPPThread () +endSession :: XMPP () endSession = do -- TODO: This has to be idempotent (is it?) withConnection xmppKillConnection liftIO =<< asks stopThreads runHandler sessionEndHandler -- | Close the connection to the server -closeConnection :: XMPPThread () +closeConnection :: XMPP () closeConnection = withConnection xmppKillConnection diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index a801b05..7a4309a 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -119,28 +119,28 @@ writeWorker stCh writeR = forever $ do -- returns channel of incoming and outgoing stances, respectively -- and an Action to stop the Threads and close the connection startThreads - :: XMPPConMonad ( TChan (Either MessageError Message) - , TChan (Either PresenceError Presence) - , TVar IQHandlers - , TChan Stanza - , IO () - , TMVar (BS.ByteString -> IO ()) - , TMVar XMPPConState - , ThreadId - , TVar EventHandlers - ) + :: IO ( TChan (Either MessageError Message) + , TChan (Either PresenceError Presence) + , TVar IQHandlers + , TChan Stanza + , IO () + , TMVar (BS.ByteString -> IO ()) + , TMVar XMPPConState + , ThreadId + , TVar EventHandlers + ) startThreads = do - writeLock <- liftIO . newTMVarIO =<< gets sConPushBS - messageC <- liftIO newTChanIO - presenceC <- liftIO newTChanIO - outC <- liftIO newTChanIO - handlers <- liftIO $ newTVarIO ( Map.empty, Map.empty) - eh <- liftIO $ newTVarIO zeroEventHandlers - conS <- liftIO . newTMVarIO =<< get - lw <- liftIO . forkIO $ writeWorker outC writeLock - cp <- liftIO . forkIO $ connPersist writeLock - rd <- liftIO . forkIO $ readWorker messageC presenceC handlers conS + writeLock <- newEmptyTMVarIO + messageC <- newTChanIO + presenceC <- newTChanIO + outC <- newTChanIO + handlers <- newTVarIO ( Map.empty, Map.empty) + eh <- newTVarIO zeroEventHandlers + conS <- newEmptyTMVarIO + lw <- forkIO $ writeWorker outC writeLock + cp <- forkIO $ connPersist writeLock + rd <- forkIO $ readWorker messageC presenceC handlers conS return (messageC, presenceC, handlers, outC , killConnection writeLock [lw, rd, cp] , writeLock, conS ,rd, eh) @@ -150,24 +150,24 @@ startThreads = do _ <- forM threads killThread return() --- | Start worker threads and run action. The supplied action will run --- in the calling thread. use 'forkXMPP' to start another thread. -runThreaded :: XMPPThread a - -> XMPPConMonad a -runThreaded a = do - liftIO . putStrLn $ "starting threads" +-- | Creates and initializes a new XMPP session. +newSession :: IO Session +newSession = do (mC, pC, hand, outC, stopThreads', writeR, conS, rdr, eh) <- startThreads - liftIO . putStrLn $ "threads running" - workermCh <- liftIO . newIORef $ Nothing - workerpCh <- liftIO . newIORef $ Nothing - idRef <- liftIO $ newTVarIO 1 + workermCh <- newIORef $ Nothing + workerpCh <- newIORef $ Nothing + idRef <- newTVarIO 1 let getId = atomically $ do curId <- readTVar idRef writeTVar idRef (curId + 1 :: Integer) return . read. show $ curId - liftIO . putStrLn $ "starting application" - liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR rdr getId conS eh stopThreads') + return (Session workermCh workerpCh mC pC outC hand writeR rdr getId conS eh stopThreads') +withNewSession :: XMPP b -> IO b +withNewSession a = newSession >>= runReaderT a + +withSession :: Session -> XMPP a -> IO a +withSession = flip runReaderT -- | Sends a blank space every 30 seconds to keep the connection alive connPersist :: TMVar (BS.ByteString -> IO ()) -> IO () diff --git a/src/Network/XMPP/Concurrent/Types.hs b/src/Network/XMPP/Concurrent/Types.hs index fa15f7e..37aa821 100644 --- a/src/Network/XMPP/Concurrent/Types.hs +++ b/src/Network/XMPP/Concurrent/Types.hs @@ -23,8 +23,8 @@ type IQHandlers = (Map.Map (IQRequestType, Text) (TChan (IQRequest, TVar Bool)) ) data EventHandlers = EventHandlers - { sessionEndHandler :: XMPPThread () - , connectionClosedHandler :: XMPPThread () + { sessionEndHandler :: XMPP () + , connectionClosedHandler :: XMPP () } zeroEventHandlers :: EventHandlers @@ -33,29 +33,29 @@ zeroEventHandlers = EventHandlers , connectionClosedHandler = return () } -data Thread = Thread { messagesRef :: IORef (Maybe ( TChan (Either +data Session = Session { messagesRef :: IORef (Maybe ( TChan (Either MessageError Message - ))) - , presenceRef :: IORef (Maybe (TChan (Either - PresenceError - Presence - ))) - , mShadow :: TChan (Either MessageError - Message) -- the original chan - , pShadow :: TChan (Either PresenceError - Presence) -- the original chan - , outCh :: TChan Stanza - , iqHandlers :: TVar IQHandlers - , writeRef :: TMVar (BS.ByteString -> IO () ) - , readerThread :: ThreadId - , idGenerator :: IO StanzaId - , conStateRef :: TMVar XMPPConState - , eventHandlers :: TVar EventHandlers - , stopThreads :: IO () - } - -type XMPPThread a = ReaderT Thread IO a + ))) + , presenceRef :: IORef (Maybe (TChan (Either + PresenceError Presence ))) + , mShadow :: TChan (Either MessageError + Message) + -- the original chan + , pShadow :: TChan (Either PresenceError + Presence) + -- the original chan + , outCh :: TChan Stanza + , iqHandlers :: TVar IQHandlers + , writeRef :: TMVar (BS.ByteString -> IO () ) + , readerThread :: ThreadId + , idGenerator :: IO StanzaId + , conStateRef :: TMVar XMPPConState + , eventHandlers :: TVar EventHandlers + , stopThreads :: IO () + } + +type XMPP a = ReaderT Session IO a data Interrupt = Interrupt (TMVar ()) deriving Typeable instance Show Interrupt where show _ = "" diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index f860c15..013f186 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -120,8 +120,8 @@ xmppRawConnect host hostname = do put st -withNewSession :: XMPPConMonad a -> IO (a, XMPPConState) -withNewSession action = do +xmppNewSession :: XMPPConMonad a -> IO (a, XMPPConState) +xmppNewSession action = do runStateT action xmppZeroConState xmppKillConnection :: XMPPConMonad () diff --git a/src/Network/XMPP/Session.hs b/src/Network/XMPP/Session.hs index 5a355b0..8e3082f 100644 --- a/src/Network/XMPP/Session.hs +++ b/src/Network/XMPP/Session.hs @@ -32,7 +32,7 @@ xmppSession = do let IQResultS (IQResult "sess" Nothing Nothing _lang _body) = answer return () -startSession :: XMPPThread () +startSession :: XMPP () startSession = do answer <- sendIQ' Nothing Set Nothing sessionXML case answer of From 6c50dfb3b739954d39db14e308c721b64344ec9b Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 25 Apr 2012 11:49:47 +0200 Subject: [PATCH 22/29] added forkSession renamed forkXMPP to fork --- src/Network/XMPP.hs | 3 ++- src/Network/XMPP/Concurrent/Monad.hs | 20 ++++++++++++-------- 2 files changed, 14 insertions(+), 9 deletions(-) diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index b2a1e54..af4ed0a 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -133,7 +133,8 @@ module Network.XMPP , iqResultPayload -- * Threads , XMPP - , forkXMPP + , fork + , forkSession -- * Misc , exampleParams ) where diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index 2d97372..84cb77e 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -98,15 +98,19 @@ sendS a = do liftIO . atomically $ writeTChan out a return () +-- | Create a forked session object without forking a thread +forkSession :: Session -> IO Session +forkSession sess = do + mCH' <- newIORef Nothing + pCH' <- newIORef Nothing + return $ sess {messagesRef = mCH' ,presenceRef = pCH'} + -- | Fork a new thread -forkXMPP :: XMPP () -> XMPP ThreadId -forkXMPP a = do - thread <- ask - mCH' <- liftIO $ newIORef Nothing - pCH' <- liftIO $ newIORef Nothing - liftIO $ forkIO $ runReaderT a (thread {messagesRef = mCH' - ,presenceRef = pCH' - }) +fork :: XMPP () -> XMPP ThreadId +fork a = do + sess <- ask + sess' <- liftIO $ forkSession sess + liftIO $ forkIO $ runReaderT a sess' filterMessages :: (MessageError -> Bool) -> (Message -> Bool) From 6cc097fa370954ebdf62af6a95ee4e21e2bda75d Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Fri, 27 Apr 2012 14:59:20 +0200 Subject: [PATCH 23/29] reader fixes: catch exceptions while blocking on readTMVar catch exceptiosn while waiting for semaphores --- src/Network/XMPP/Concurrent/Threads.hs | 38 ++++++++++++++++---------- 1 file changed, 24 insertions(+), 14 deletions(-) diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index 7a4309a..6a57dbb 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -29,6 +29,13 @@ import Text.XML.Stream.Elements import GHC.IO (unsafeUnmask) +-- While waiting for the first semaphore(s) to flip we might receive +-- another interrupt. When that happens we add it's semaphore to the +-- list and retry waiting +handleInterrupts ts = + Ex.catch (atomically $ forM ts takeTMVar) + ( \(Interrupt t) -> handleInterrupts (t:ts)) + readWorker :: TChan (Either MessageError Message) -> TChan (Either PresenceError Presence) -> TVar IQHandlers @@ -36,22 +43,25 @@ readWorker :: TChan (Either MessageError Message) -> IO () readWorker messageC presenceC handlers stateRef = Ex.mask_ . forever $ do - s <- liftIO . atomically $ takeTMVar stateRef - (sta', s') <- flip runStateT s $ Ex.catch ( do - -- we don't know whether pull will necessarily be interruptible - liftIO $ allowInterrupt - Just <$> pull - ) - (\(Interrupt t) -> do - liftIO . atomically $ - putTMVar stateRef s - liftIO . atomically $ takeTMVar t - return Nothing - ) + res <- liftIO $ Ex.catch ( + Ex.bracket + (atomically $ takeTMVar stateRef) + (atomically . putTMVar stateRef ) + (\s -> do + -- we don't know whether pull will + -- necessarily be interruptible + allowInterrupt + Just <$> runStateT pull s + ) + ) + (\(Interrupt t) -> do + handleInterrupts [t] + return Nothing + ) liftIO . atomically $ do - case sta' of + case res of Nothing -> return () - Just sta -> do + Just (sta, s') -> do putTMVar stateRef s' case sta of MessageS m -> do writeTChan messageC $ Right m From f3d1a37146f7ed82ffde9453e6081ca3f51c58ce Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sat, 28 Apr 2012 12:34:40 +0200 Subject: [PATCH 24/29] protected withConnection from asynchronous exceptions (may beed more work) renamed picklers to adhere to the xpPicklername schema added xmpp stream error data type and pickler changed fatal errors throw exceptions rather than ErrorT errors renamed pulls to pullSink renamed pullE pullElement renamed pull to pullStanza renamed sendS to sendStanza --- pontarius.cabal | 19 +++-- src/Network/XMPP.hs | 2 + src/Network/XMPP/Concurrent/IQ.hs | 2 +- src/Network/XMPP/Concurrent/Monad.hs | 45 ++++++++---- src/Network/XMPP/Concurrent/Threads.hs | 18 +++-- src/Network/XMPP/Marshal.hs | 31 +++++++- src/Network/XMPP/Monad.hs | 66 +++++++++-------- src/Network/XMPP/Pickle.hs | 17 ++++- src/Network/XMPP/SASL.hs | 6 +- src/Network/XMPP/Session.hs | 2 +- src/Network/XMPP/Stream.hs | 4 +- src/Network/XMPP/TLS.hs | 14 ++-- src/Network/XMPP/Types.hs | 99 ++++++++++++++++++++++++-- 13 files changed, 246 insertions(+), 79 deletions(-) diff --git a/pontarius.cabal b/pontarius.cabal index e555639..8dc8918 100644 --- a/pontarius.cabal +++ b/pontarius.cabal @@ -51,20 +51,25 @@ Library , data-default -any , stringprep >= 0.1.5 Exposed-modules: Network.XMPP - , Network.XMPP.Types - , Network.XMPP.SASL - , Network.XMPP.Stream - , Network.XMPP.Pickle + , Network.XMPP.Bind + , Network.XMPP.Concurrent , Network.XMPP.Marshal , Network.XMPP.Monad - , Network.XMPP.Concurrent - , Network.XMPP.TLS - , Network.XMPP.Bind + , Network.XMPP.Message + , Network.XMPP.Pickle + , Network.XMPP.Presence + , Network.XMPP.SASL , Network.XMPP.Session + , Network.XMPP.Stream + , Network.XMPP.TLS + , Network.XMPP.Types Other-modules: Network.XMPP.JID + , Network.XMPP.Concurrent.Types , Network.XMPP.Concurrent.IQ , Network.XMPP.Concurrent.Threads , Network.XMPP.Concurrent.Monad + , Text.XML.Stream.Elements + , Data.Conduit.TLS GHC-Options: -Wall diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index af4ed0a..1c87cb9 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -35,6 +35,8 @@ module Network.XMPP ( -- * Session management withNewSession + , withSession + , newSession , connect , startTLS , auth diff --git a/src/Network/XMPP/Concurrent/IQ.hs b/src/Network/XMPP/Concurrent/IQ.hs index 6693397..500719c 100644 --- a/src/Network/XMPP/Concurrent/IQ.hs +++ b/src/Network/XMPP/Concurrent/IQ.hs @@ -27,7 +27,7 @@ sendIQ to tp lang body = do -- TODO: add timeout writeTVar handlers (byNS, Map.insert newId resRef byId) -- TODO: Check for id collisions (shouldn't happen?) return resRef - sendS . IQRequestS $ IQRequest newId Nothing to lang tp body + sendStanza . IQRequestS $ IQRequest newId Nothing to lang tp body return ref -- | like 'sendIQ', but waits for the answer IQ diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index 84cb77e..515d55b 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -4,6 +4,7 @@ import Network.XMPP.Types import Control.Concurrent import Control.Concurrent.STM +import qualified Control.Exception.Lifted as Ex import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.State.Strict @@ -34,7 +35,7 @@ listenIQChan tp ns = do writeTVar handlers (byNS', byID) return $ case present of Nothing -> Just iqCh - Just iqCh' -> Nothing + Just _iqCh' -> Nothing -- | get the inbound stanza channel, duplicates from master if necessary -- please note that once duplicated it will keep filling up, call @@ -92,8 +93,8 @@ pullPresence = do liftIO $ atomically $ readTChan c -- | Send a stanza to the server -sendS :: Stanza -> XMPP () -sendS a = do +sendStanza :: Stanza -> XMPP () +sendStanza a = do out <- asks outCh liftIO . atomically $ writeTChan out a return () @@ -159,24 +160,38 @@ withConnection a = do stateRef <- asks conStateRef write <- asks writeRef wait <- liftIO $ newEmptyTMVarIO - liftIO . throwTo readerId $ Interrupt wait - s <- liftIO . atomically $ do - putTMVar wait () - _ <- takeTMVar write - takeTMVar stateRef - (res, s') <- liftIO $ runStateT a s - liftIO . atomically $ do - putTMVar write (sConPushBS s') - putTMVar stateRef s' - return res + liftIO . Ex.mask_ $ do + throwTo readerId $ Interrupt wait + s <- Ex.catch ( atomically $ do + _ <- takeTMVar write + s <- takeTMVar stateRef + putTMVar wait () + return s + ) + (\e -> atomically (putTMVar wait ()) + >> Ex.throwIO (e :: Ex.SomeException) + -- No MVar taken + ) + Ex.catch ( do + (res, s') <- runStateT a s + atomically $ do + _ <- tryPutTMVar write (sConPushBS s') + _ <- tryPutTMVar stateRef s' + return () + return res + ) + -- we treat all Exceptions as fatal + (\e -> runStateT xmppKillConnection s + >> Ex.throwIO (e :: Ex.SomeException) + ) -- | Send a presence Stanza sendPresence :: Presence -> XMPP () -sendPresence = sendS . PresenceS +sendPresence = sendStanza . PresenceS -- | Send a Message Stanza sendMessage :: Message -> XMPP () -sendMessage = sendS . MessageS +sendMessage = sendStanza . MessageS modifyHandlers :: (EventHandlers -> EventHandlers) -> XMPP () diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index 6a57dbb..7230205 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -32,6 +32,7 @@ import GHC.IO (unsafeUnmask) -- While waiting for the first semaphore(s) to flip we might receive -- another interrupt. When that happens we add it's semaphore to the -- list and retry waiting +handleInterrupts :: [TMVar ()] -> IO [()] handleInterrupts ts = Ex.catch (atomically $ forM ts takeTMVar) ( \(Interrupt t) -> handleInterrupts (t:ts)) @@ -51,11 +52,11 @@ readWorker messageC presenceC handlers stateRef = -- we don't know whether pull will -- necessarily be interruptible allowInterrupt - Just <$> runStateT pull s + Just <$> runStateT pullStanza s ) ) (\(Interrupt t) -> do - handleInterrupts [t] + void $ handleInterrupts [t] return Nothing ) liftIO . atomically $ do @@ -121,7 +122,7 @@ writeWorker stCh writeR = forever $ do (write, next) <- atomically $ (,) <$> takeTMVar writeR <*> readTChan stCh - _ <- write $ renderElement (pickleElem stanzaP next) + _ <- write $ renderElement (pickleElem xpStanza next) atomically $ putTMVar writeR write -- Two streams: input and output. Threads read from input stream and write to output stream. @@ -141,13 +142,13 @@ startThreads ) startThreads = do - writeLock <- newEmptyTMVarIO + writeLock <- newTMVarIO (\_ -> return ()) messageC <- newTChanIO presenceC <- newTChanIO outC <- newTChanIO handlers <- newTVarIO ( Map.empty, Map.empty) eh <- newTVarIO zeroEventHandlers - conS <- newEmptyTMVarIO + conS <- newTMVarIO xmppZeroConState lw <- forkIO $ writeWorker outC writeLock cp <- forkIO $ connPersist writeLock rd <- forkIO $ readWorker messageC presenceC handlers conS @@ -173,8 +174,11 @@ newSession = do return . read. show $ curId return (Session workermCh workerpCh mC pC outC hand writeR rdr getId conS eh stopThreads') -withNewSession :: XMPP b -> IO b -withNewSession a = newSession >>= runReaderT a +withNewSession :: XMPP b -> IO (Session, b) +withNewSession a = do + sess <- newSession + ret <- runReaderT a sess + return (sess, ret) withSession :: Session -> XMPP a -> IO a withSession = flip runReaderT diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index 3d694e2..165a963 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/src/Network/XMPP/Marshal.hs @@ -8,6 +8,9 @@ import Data.XML.Types import Network.XMPP.Pickle import Network.XMPP.Types +xpStreamEntity :: PU [Node] (Either XmppStreamError Stanza) +xpStreamEntity = xpEither xpStreamError xpStanza + stanzaSel :: Stanza -> Int stanzaSel (IQRequestS _) = 0 stanzaSel (IQResultS _) = 1 @@ -17,8 +20,8 @@ stanzaSel (MessageErrorS _) = 4 stanzaSel (PresenceS _) = 5 stanzaSel (PresenceErrorS _) = 6 -stanzaP :: PU [Node] Stanza -stanzaP = xpAlt stanzaSel +xpStanza :: PU [Node] Stanza +xpStanza = xpAlt stanzaSel [ xpWrap IQRequestS (\(IQRequestS x) -> x) xpIQRequest , xpWrap IQResultS (\(IQResultS x) -> x) xpIQResult , xpWrap IQErrorS (\(IQErrorS x) -> x) xpIQError @@ -188,3 +191,27 @@ xpIQError = xpWrap (\((qid, from, to, lang, _tp),(err, body)) (xpOption xpElemVerbatim) ) +xpStreamError :: PU [Node] XmppStreamError +xpStreamError = xpWrap + (\((cond,() ,()), txt, el) -> XmppStreamError cond txt el) + (\(XmppStreamError cond txt el) ->((cond,() ,()), txt, el)) + (xpElemNodes + (Name "error" + (Just "http://etherx.jabber.org/streams") + (Just "stream") + ) $ xp3Tuple + (xpElemByNamespace + "urn:ietf:params:xml:ns:xmpp-streams" xpPrim + xpUnit + xpUnit + ) + (xpOption $ xpElem + "{urn:ietf:params:xml:ns:xmpp-streams}text" + xpLangTag + (xpContent xpId)) + ( xpOption xpElemVerbatim + -- application specific error conditions + ) + ) + + diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 013f186..e5a8b23 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -2,30 +2,31 @@ module Network.XMPP.Monad where -import Control.Applicative((<$>)) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Class +import Control.Applicative((<$>)) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class --import Control.Monad.Trans.Resource -import Control.Concurrent -import Control.Monad.State.Strict +import Control.Concurrent +import qualified Control.Exception as Ex +import Control.Monad.State.Strict -import Data.ByteString as BS -import Data.Conduit -import Data.Conduit.Binary as CB -import Data.Text(Text) -import Data.XML.Pickle -import Data.XML.Types +import Data.ByteString as BS +import Data.Conduit +import Data.Conduit.Binary as CB +import Data.Text(Text) +import Data.XML.Pickle +import Data.XML.Types -import Network -import Network.XMPP.Types -import Network.XMPP.Marshal -import Network.XMPP.Pickle +import Network +import Network.XMPP.Types +import Network.XMPP.Marshal +import Network.XMPP.Pickle -import System.IO +import System.IO -import Text.XML.Stream.Elements -import Text.XML.Stream.Parse as XP +import Text.XML.Stream.Elements +import Text.XML.Stream.Parse as XP pushN :: Element -> XMPPConMonad () pushN x = do @@ -33,7 +34,7 @@ pushN x = do liftIO . sink $ renderElement x push :: Stanza -> XMPPConMonad () -push = pushN . pickleElem stanzaP +push = pushN . pickleElem xpStanza pushOpen :: Element -> XMPPConMonad () pushOpen e = do @@ -41,21 +42,29 @@ pushOpen e = do liftIO . sink $ renderOpenElement e return () -pulls :: Sink Event IO b -> XMPPConMonad b -pulls snk = do +pullSink :: Sink Event IO b -> XMPPConMonad b +pullSink snk = do source <- gets sConSrc (src', r) <- lift $ source $$+ snk modify $ (\s -> s {sConSrc = src'}) return r -pullE :: XMPPConMonad Element -pullE = pulls elementFromEvents +pullElement :: XMPPConMonad Element +pullElement = pullSink elementFromEvents pullPickle :: PU [Node] a -> XMPPConMonad a -pullPickle p = unpickleElem' p <$> pullE - -pull :: XMPPConMonad Stanza -pull = pullPickle stanzaP +pullPickle p = do + res <- unpickleElem p <$> pullElement + case res of + Left e -> liftIO . Ex.throwIO $ StreamXMLError e + Right r -> return r + +pullStanza :: XMPPConMonad Stanza +pullStanza = do + res <- pullPickle xpStreamEntity + case res of + Left e -> liftIO . Ex.throwIO $ StreamError e + Right r -> return r xmppFromHandle :: Handle -> Text @@ -119,7 +128,6 @@ xmppRawConnect host hostname = do (hClose con) put st - xmppNewSession :: XMPPConMonad a -> IO (a, XMPPConState) xmppNewSession action = do runStateT action xmppZeroConState diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index 347e8a5..bc611d8 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -5,7 +5,21 @@ -- Marshalling between XML and Native Types -module Network.XMPP.Pickle where +module Network.XMPP.Pickle + ( mbToBool + , xpElemEmpty + , xmlLang + , xpLangTag + , xpNodeElem + , ignoreAttrs + , mbl + , lmb + , right + , unpickleElem' + , unpickleElem + , pickleElem + , ppElement + ) where import Data.XML.Types import Data.XML.Pickle @@ -65,3 +79,4 @@ unpickleElem p x = unpickle (xpNodeElem p) x 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 24f4288..87e3325 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -5,7 +5,6 @@ import Control.Applicative import Control.Arrow (left) import Control.Monad import Control.Monad.Error -import Control.Monad.IO.Class import Control.Monad.State.Strict import qualified Crypto.Classes as CC @@ -80,7 +79,8 @@ xmppStartSASL realm username passwd = runErrorT $ do unless ("DIGEST-MD5" `elem` mechanisms) . throwError $ SaslMechanismError mechanisms lift . pushN $ saslInitE "DIGEST-MD5" - challenge' <- lift $ B64.decode . Text.encodeUtf8<$> pullPickle challengePickle + challenge' <- lift $ B64.decode . Text.encodeUtf8 + <$> pullPickle challengePickle challenge <- case challenge' of Left _e -> throwError SaslChallengeError Right r -> return r @@ -94,7 +94,7 @@ xmppStartSASL realm username passwd = runErrorT $ do Left _x -> throwError $ SaslXmlError Right _ -> return () lift $ pushN saslResponse2E - e <- lift pullE + e <- lift pullElement case e of Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] -> return () _ -> throwError SaslXmlError -- TODO: investigate diff --git a/src/Network/XMPP/Session.hs b/src/Network/XMPP/Session.hs index 8e3082f..b21c265 100644 --- a/src/Network/XMPP/Session.hs +++ b/src/Network/XMPP/Session.hs @@ -28,7 +28,7 @@ sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" xmppSession :: XMPPConMonad () xmppSession = do push $ sessionIQ - answer <- pull + answer <- pullStanza let IQResultS (IQResult "sess" Nothing Nothing _lang _body) = answer return () diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index c192116..be79acf 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -27,7 +27,7 @@ streamUnpickleElem :: PU [Node] a -> ErrorT StreamError (Pipe Event Void IO) a streamUnpickleElem p x = do case unpickleElem p x of - Left l -> throwError $ StreamUnpickleError l + Left l -> throwError $ StreamXMLError l Right r -> return r type StreamSink a = ErrorT StreamError (Pipe Event Void IO) a @@ -55,7 +55,7 @@ xmppStartStream = runErrorT $ do Nothing -> throwError StreamConnectionError Just hostname -> lift . pushOpen $ pickleElem pickleStream ("1.0",Nothing, Just hostname) - features <- ErrorT . pulls $ runErrorT xmppStream + features <- ErrorT . pullSink $ runErrorT xmppStream modify (\s -> s {sFeatures = features}) return () diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index 8cfc0a4..5d2418d 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -3,8 +3,6 @@ module Network.XMPP.TLS where -import Control.Applicative((<$>)) -import Control.Arrow(left) import qualified Control.Exception.Lifted as Ex import Control.Monad import Control.Monad.Error @@ -15,6 +13,7 @@ import Data.Typeable import Data.XML.Types import Network.XMPP.Monad +import Network.XMPP.Pickle(ppElement) import Network.XMPP.Stream import Network.XMPP.Types @@ -45,7 +44,6 @@ data XMPPTLSError = TLSError TLSError instance Error XMPPTLSError where noMsg = TLSNoConnection -- TODO: What should we choose here? -instance Ex.Exception XMPPTLSError xmppStartTLS :: TLS.TLSParams -> XMPPConMonad (Either XMPPTLSError ()) @@ -56,10 +54,14 @@ xmppStartTLS params = Ex.handle (return . Left . TLSError) handle <- maybe (throwError TLSNoConnection) return handle' when (stls features == Nothing) $ throwError TLSNoServerSupport lift $ pushN starttlsE - answer <- lift $ pullE + answer <- lift $ pullElement case answer of Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return () - _ -> throwError $ TLSStreamError StreamXMLError + Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _ + -> lift . Ex.throwIO $ StreamConnectionError + -- TODO: find something more suitable + e -> lift . Ex.throwIO . StreamXMLError + $ "Unexpected element: " ++ ppElement e (raw, _snk, psh, ctx) <- lift $ TLS.tlsinit params handle lift $ modify (\x -> x { sRawSrc = raw @@ -68,7 +70,7 @@ xmppStartTLS params = Ex.handle (return . Left . TLSError) , sConPushBS = psh , sCloseConnection = TLS.bye ctx >> sCloseConnection x }) - ErrorT $ (left TLSStreamError) <$> xmppRestartStream + either (lift . Ex.throwIO) return =<< lift xmppRestartStream modify (\s -> s{sHaveTLS = True}) return () diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index c8f4619..9013eb2 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -40,6 +40,7 @@ module Network.XMPP.Types , XMPPConMonad , XMPPConState(..) , XMPPT(..) + , XmppStreamError(..) , parseLangTag , module Network.XMPP.JID ) @@ -338,7 +339,6 @@ instance Read ShowType where -- wrapped in the @StanzaError@ type. -- TODO: Sender XML is (optional and is) not included. - data StanzaError = StanzaError { stanzaErrorType :: StanzaErrorType , stanzaErrorCondition :: StanzaErrorCondition , stanzaErrorText :: Maybe (Maybe LangTag, Text) @@ -537,14 +537,103 @@ instance Read SASLError where data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq) -data StreamError = StreamError String +-- TODO: document the error cases +data StreamErrorCondition = StreamBadFormat + | StreamBadNamespacePrefix + | StreamConflict + | StreamConnectionTimeout + | StreamHostGone + | StreamHostUnknown + | StreamImproperAddressing + | StreamInternalServerError + | StreamInvalidFrom + | StreamInvalidNamespace + | StreamInvalidXml + | StreamNotAuthorized + | StreamNotWellFormed + | StreamPolicyViolation + | StreamRemoteConnectionFailed + | StreamReset + | StreamResourceConstraint + | StreamRestrictedXml + | StreamSeeOtherHost + | StreamSystemShutdown + | StreamUndefinedCondition + | StreamUnsupportedEncoding + | StreamUnsupportedFeature + | StreamUnsupportedStanzaType + | StreamUnsupportedVersion + deriving Eq + +instance Show StreamErrorCondition where + show StreamBadFormat = "bad-format" + show StreamBadNamespacePrefix = "bad-namespace-prefix" + show StreamConflict = "conflict" + show StreamConnectionTimeout = "connection-timeout" + show StreamHostGone = "host-gone" + show StreamHostUnknown = "host-unknown" + show StreamImproperAddressing = "improper-addressing" + show StreamInternalServerError = "internal-server-error" + show StreamInvalidFrom = "invalid-from" + show StreamInvalidNamespace = "invalid-namespace" + show StreamInvalidXml = "invalid-xml" + show StreamNotAuthorized = "not-authorized" + show StreamNotWellFormed = "not-well-formed" + show StreamPolicyViolation = "policy-violation" + show StreamRemoteConnectionFailed = "remote-connection-failed" + show StreamReset = "reset" + show StreamResourceConstraint = "resource-constraint" + show StreamRestrictedXml = "restricted-xml" + show StreamSeeOtherHost = "see-other-host" + show StreamSystemShutdown = "system-shutdown" + show StreamUndefinedCondition = "undefined-condition" + show StreamUnsupportedEncoding = "unsupported-encoding" + show StreamUnsupportedFeature = "unsupported-feature" + show StreamUnsupportedStanzaType = "unsupported-stanza-type" + show StreamUnsupportedVersion = "unsupported-version" + +instance Read StreamErrorCondition where + readsPrec _ "bad-format" = [(StreamBadFormat , "")] + readsPrec _ "bad-namespace-prefix" = [(StreamBadNamespacePrefix , "")] + readsPrec _ "conflict" = [(StreamConflict , "")] + readsPrec _ "connection-timeout" = [(StreamConnectionTimeout , "")] + readsPrec _ "host-gone" = [(StreamHostGone , "")] + readsPrec _ "host-unknown" = [(StreamHostUnknown , "")] + readsPrec _ "improper-addressing" = [(StreamImproperAddressing , "")] + readsPrec _ "internal-server-error" = [(StreamInternalServerError , "")] + readsPrec _ "invalid-from" = [(StreamInvalidFrom , "")] + readsPrec _ "invalid-namespace" = [(StreamInvalidNamespace , "")] + readsPrec _ "invalid-xml" = [(StreamInvalidXml , "")] + readsPrec _ "not-authorized" = [(StreamNotAuthorized , "")] + readsPrec _ "not-well-formed" = [(StreamNotWellFormed , "")] + readsPrec _ "policy-violation" = [(StreamPolicyViolation , "")] + readsPrec _ "remote-connection-failed" = [(StreamRemoteConnectionFailed , "")] + readsPrec _ "reset" = [(StreamReset , "")] + readsPrec _ "resource-constraint" = [(StreamResourceConstraint , "")] + readsPrec _ "restricted-xml" = [(StreamRestrictedXml , "")] + readsPrec _ "see-other-host" = [(StreamSeeOtherHost , "")] + readsPrec _ "system-shutdown" = [(StreamSystemShutdown , "")] + readsPrec _ "undefined-condition" = [(StreamUndefinedCondition , "")] + readsPrec _ "unsupported-encoding" = [(StreamUnsupportedEncoding , "")] + readsPrec _ "unsupported-feature" = [(StreamUnsupportedFeature , "")] + readsPrec _ "unsupported-stanza-type" = [(StreamUnsupportedStanzaType , "")] + readsPrec _ "unsupported-version" = [(StreamUnsupportedVersion , "")] + readsPrec _ _ = [(StreamUndefinedCondition , "")] + +data XmppStreamError = XmppStreamError + { errorCondition :: StreamErrorCondition + , errorText :: Maybe (Maybe LangTag, Text) + , errorXML :: Maybe Element + } deriving (Show, Eq) + + +data StreamError = StreamError XmppStreamError | StreamWrongVersion Text - | StreamXMLError - | StreamUnpickleError String + | StreamXMLError String | StreamConnectionError deriving (Show, Eq, Typeable) instance Exception StreamError -instance Error StreamError where strMsg = StreamError +instance Error StreamError where noMsg = StreamConnectionError -- ============================================================================= -- XML TYPES From b4b2610880b9c8bfb661271ca0df585fb08f0449 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 29 Apr 2012 17:08:51 +0200 Subject: [PATCH 25/29] Renamed SaslError to AuthError Renamed SASLError to SaslError added BufferedSource Changed sources to be buffered reader now only reads the connection state in the beginning, doesn't need to put anything back Updated test client --- pontarius.cabal | 1 + src/Data/Conduit/BufferedSource.hs | 20 +++++++ src/Network/XMPP.hs | 6 +- src/Network/XMPP/Concurrent/Threads.hs | 21 +++---- src/Network/XMPP/Monad.hs | 6 +- src/Network/XMPP/SASL.hs | 39 ++++++------- src/Network/XMPP/Stream.hs | 5 +- src/Network/XMPP/Types.hs | 78 +++++++++++++------------- src/Tests.hs | 14 ++--- 9 files changed, 105 insertions(+), 85 deletions(-) create mode 100644 src/Data/Conduit/BufferedSource.hs diff --git a/pontarius.cabal b/pontarius.cabal index 8dc8918..ff0b9a8 100644 --- a/pontarius.cabal +++ b/pontarius.cabal @@ -69,6 +69,7 @@ Library , Network.XMPP.Concurrent.Threads , Network.XMPP.Concurrent.Monad , Text.XML.Stream.Elements + , Data.Conduit.BufferedSource , Data.Conduit.TLS GHC-Options: -Wall diff --git a/src/Data/Conduit/BufferedSource.hs b/src/Data/Conduit/BufferedSource.hs new file mode 100644 index 0000000..c755509 --- /dev/null +++ b/src/Data/Conduit/BufferedSource.hs @@ -0,0 +1,20 @@ +module Data.Conduit.BufferedSource where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.IORef +import Data.Conduit +import qualified Data.Conduit.List as CL + +-- | Buffered source from conduit 0.3 +bufferSource :: MonadIO m => Source m o -> IO (Source m o) +bufferSource s = do + srcRef <- newIORef s + return $ do + src <- liftIO $ readIORef srcRef + let go src = do + (src', res) <- lift $ src $$+ CL.head + case res of + Nothing -> return () + Just x -> liftIO (writeIORef srcRef src') >> yield x >> go src' + in go src diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index 1c87cb9..84bf2be 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -84,8 +84,10 @@ module Network.XMPP -- , Message , MessageError + , MessageType(..) -- *** creating - , module Network.XMPP.Message + , simpleMessage + , answerMessage -- *** sending , sendMessage -- *** receiving @@ -174,7 +176,7 @@ auth :: Text.Text -- ^ The username -> Text.Text -- ^ The password -> Maybe Text -- ^ The desired resource or 'Nothing' to let the server -- assign one - -> XMPP (Either SaslError Text.Text) + -> XMPP (Either AuthError Text.Text) auth username passwd resource = runErrorT $ do ErrorT . withConnection $ xmppSASL username passwd res <- lift $ xmppBind resource diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index 7230205..5377d37 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -44,17 +44,13 @@ readWorker :: TChan (Either MessageError Message) -> IO () readWorker messageC presenceC handlers stateRef = Ex.mask_ . forever $ do - res <- liftIO $ Ex.catch ( - Ex.bracket - (atomically $ takeTMVar stateRef) - (atomically . putTMVar stateRef ) - (\s -> do - -- we don't know whether pull will - -- necessarily be interruptible - allowInterrupt - Just <$> runStateT pullStanza s - ) - ) + res <- liftIO $ Ex.catch ( do + -- we don't know whether pull will + -- necessarily be interruptible + s <- liftIO . atomically $ readTMVar stateRef + allowInterrupt + Just <$> runStateT pullStanza s + ) (\(Interrupt t) -> do void $ handleInterrupts [t] return Nothing @@ -62,8 +58,7 @@ readWorker messageC presenceC handlers stateRef = liftIO . atomically $ do case res of Nothing -> return () - Just (sta, s') -> do - putTMVar stateRef s' + Just (sta, _s) -> do case sta of MessageS m -> do writeTChan messageC $ Right m _ <- readTChan messageC -- Sic! diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index e5a8b23..34bc566 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -13,6 +13,7 @@ import Control.Monad.State.Strict import Data.ByteString as BS import Data.Conduit +import Data.Conduit.BufferedSource import Data.Conduit.Binary as CB import Data.Text(Text) import Data.XML.Pickle @@ -45,8 +46,7 @@ pushOpen e = do pullSink :: Sink Event IO b -> XMPPConMonad b pullSink snk = do source <- gets sConSrc - (src', r) <- lift $ source $$+ snk - modify $ (\s -> s {sConSrc = src'}) + (_, r) <- lift $ source $$+ snk return r pullElement :: XMPPConMonad Element @@ -114,7 +114,7 @@ xmppRawConnect host hostname = do hSetBuffering con NoBuffering return con let raw = sourceHandle con - let src = raw $= XP.parseBytes def + src <- liftIO . bufferSource $ raw $= XP.parseBytes def let st = XMPPConState src (raw) diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 87e3325..b5897bf 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -51,16 +51,17 @@ saslResponse2E = [] [] -data SaslError = SaslXmlError - | SaslMechanismError [Text] - | SaslChallengeError - | SaslStreamError StreamError - | SaslConnectionError +data AuthError = AuthXmlError + | AuthMechanismError [Text] + | AuthChallengeError + | AuthStreamError StreamError + | AuthConnectionError + deriving Show -instance Error SaslError where - noMsg = SaslXmlError +instance Error AuthError where + noMsg = AuthXmlError -xmppSASL:: Text -> Text -> XMPPConMonad (Either SaslError Text) +xmppSASL:: Text -> Text -> XMPPConMonad (Either AuthError Text) xmppSASL uname passwd = runErrorT $ do realm <- gets sHostname case realm of @@ -68,37 +69,37 @@ xmppSASL uname passwd = runErrorT $ do ErrorT $ xmppStartSASL realm' uname passwd modify (\s -> s{sUsername = Just uname}) return uname - Nothing -> throwError SaslConnectionError + Nothing -> throwError AuthConnectionError xmppStartSASL :: Text -> Text -> Text - -> XMPPConMonad (Either SaslError ()) + -> XMPPConMonad (Either AuthError ()) xmppStartSASL realm username passwd = runErrorT $ do mechanisms <- gets $ saslMechanisms . sFeatures unless ("DIGEST-MD5" `elem` mechanisms) - . throwError $ SaslMechanismError mechanisms + . throwError $ AuthMechanismError mechanisms lift . pushN $ saslInitE "DIGEST-MD5" challenge' <- lift $ B64.decode . Text.encodeUtf8 <$> pullPickle challengePickle challenge <- case challenge' of - Left _e -> throwError SaslChallengeError + Left _e -> throwError AuthChallengeError Right r -> return r pairs <- case toPairs challenge of - Left _ -> throwError SaslChallengeError + Left _ -> throwError AuthChallengeError Right p -> return p g <- liftIO $ Random.newStdGen lift . pushN . saslResponseE $ createResponse g realm username passwd pairs challenge2 <- lift $ pullPickle (xpEither failurePickle challengePickle) case challenge2 of - Left _x -> throwError $ SaslXmlError + Left _x -> throwError $ AuthXmlError Right _ -> return () lift $ pushN saslResponse2E e <- lift pullElement case e of Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] -> return () - _ -> throwError SaslXmlError -- TODO: investigate - _ <- ErrorT $ left SaslStreamError <$> xmppRestartStream + _ -> throwError AuthXmlError -- TODO: investigate + _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream return () createResponse :: Random.RandomGen g @@ -186,10 +187,10 @@ md5Digest uname realm password digestURI nc qop nonce cnonce= in hash [ha1,nonce, nc, cnonce,qop,ha2] -- Pickling -failurePickle :: PU [Node] (SASLFailure) +failurePickle :: PU [Node] (SaslFailure) failurePickle = xpWrap (\(txt,(failure,_,_)) - -> SASLFailure failure txt) - (\(SASLFailure failure txt) + -> SaslFailure failure txt) + (\(SaslFailure failure txt) -> (txt,(failure,(),()))) (xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}failure" diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index be79acf..80f3462 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -7,6 +7,7 @@ import Control.Monad.Error import Control.Monad.State.Strict import Data.Conduit +import Data.Conduit.BufferedSource import Data.Conduit.List as CL import Data.Text as T import Data.XML.Pickle @@ -55,14 +56,14 @@ xmppStartStream = runErrorT $ do Nothing -> throwError StreamConnectionError Just hostname -> lift . pushOpen $ pickleElem pickleStream ("1.0",Nothing, Just hostname) - features <- ErrorT . pullSink $ runErrorT xmppStream + features <- ErrorT . pullSink $ runErrorT xmppStream modify (\s -> s {sFeatures = features}) return () xmppRestartStream :: XMPPConMonad (Either StreamError ()) xmppRestartStream = do raw <- gets sRawSrc - let newsrc = raw $= XP.parseBytes def + newsrc <- liftIO . bufferSource $ raw $= XP.parseBytes def modify (\s -> s{sConSrc = newsrc}) xmppStartStream diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index 9013eb2..52009ce 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -25,8 +25,8 @@ module Network.XMPP.Types , Presence(..) , PresenceError(..) , PresenceType(..) - , SASLError(..) - , SASLFailure(..) + , SaslError(..) + , SaslFailure(..) , ServerAddress(..) , ServerFeatures(..) , ShowType(..) @@ -468,67 +468,67 @@ instance Read StanzaErrorCondition where -- OTHER STUFF -- ============================================================================= -data SASLFailure = SASLFailure { saslFailureCondition :: SASLError +data SaslFailure = SaslFailure { saslFailureCondition :: SaslError , saslFailureText :: Maybe ( Maybe LangTag , Text ) } deriving Show -data SASLError = SASLAborted -- ^ Client aborted - | SASLAccountDisabled -- ^ The account has been temporarily +data SaslError = SaslAborted -- ^ Client aborted + | SaslAccountDisabled -- ^ The account has been temporarily -- disabled - | SASLCredentialsExpired -- ^ The authentication failed because + | SaslCredentialsExpired -- ^ The authentication failed because -- the credentials have expired - | SASLEncryptionRequired -- ^ The mechanism requested cannot be + | SaslEncryptionRequired -- ^ The mechanism requested cannot be -- used the confidentiality and -- integrity of the underlying -- stream is protected (typically -- with TLS) - | SASLIncorrectEncoding -- ^ The base64 encoding is incorrect - | SASLInvalidAuthzid -- ^ The authzid has an incorrect + | SaslIncorrectEncoding -- ^ The base64 encoding is incorrect + | SaslInvalidAuthzid -- ^ The authzid has an incorrect -- format or the initiating entity does -- not have the appropriate permissions -- to authorize that ID - | SASLInvalidMechanism -- ^ The mechanism is not supported by + | SaslInvalidMechanism -- ^ The mechanism is not supported by -- the receiving entity - | SASLMalformedRequest -- ^ Invalid syntax - | SASLMechanismTooWeak -- ^ The receiving entity policy + | SaslMalformedRequest -- ^ Invalid syntax + | SaslMechanismTooWeak -- ^ The receiving entity policy -- requires a stronger mechanism - | SASLNotAuthorized -- ^ Invalid credentials + | SaslNotAuthorized -- ^ Invalid credentials -- provided, or some -- generic authentication -- failure has occurred - | SASLTemporaryAuthFailure -- ^ There receiving entity reported a + | SaslTemporaryAuthFailure -- ^ There receiving entity reported a -- temporary error condition; the -- initiating entity is recommended -- to try again later -instance Show SASLError where - show SASLAborted = "aborted" - show SASLAccountDisabled = "account-disabled" - show SASLCredentialsExpired = "credentials-expired" - show SASLEncryptionRequired = "encryption-required" - show SASLIncorrectEncoding = "incorrect-encoding" - show SASLInvalidAuthzid = "invalid-authzid" - show SASLInvalidMechanism = "invalid-mechanism" - show SASLMalformedRequest = "malformed-request" - show SASLMechanismTooWeak = "mechanism-too-weak" - show SASLNotAuthorized = "not-authorized" - show SASLTemporaryAuthFailure = "temporary-auth-failure" - -instance Read SASLError where - readsPrec _ "aborted" = [(SASLAborted , "")] - readsPrec _ "account-disabled" = [(SASLAccountDisabled , "")] - readsPrec _ "credentials-expired" = [(SASLCredentialsExpired , "")] - readsPrec _ "encryption-required" = [(SASLEncryptionRequired , "")] - readsPrec _ "incorrect-encoding" = [(SASLIncorrectEncoding , "")] - readsPrec _ "invalid-authzid" = [(SASLInvalidAuthzid , "")] - readsPrec _ "invalid-mechanism" = [(SASLInvalidMechanism , "")] - readsPrec _ "malformed-request" = [(SASLMalformedRequest , "")] - readsPrec _ "mechanism-too-weak" = [(SASLMechanismTooWeak , "")] - readsPrec _ "not-authorized" = [(SASLNotAuthorized , "")] - readsPrec _ "temporary-auth-failure" = [(SASLTemporaryAuthFailure , "")] +instance Show SaslError where + show SaslAborted = "aborted" + show SaslAccountDisabled = "account-disabled" + show SaslCredentialsExpired = "credentials-expired" + show SaslEncryptionRequired = "encryption-required" + show SaslIncorrectEncoding = "incorrect-encoding" + show SaslInvalidAuthzid = "invalid-authzid" + show SaslInvalidMechanism = "invalid-mechanism" + show SaslMalformedRequest = "malformed-request" + show SaslMechanismTooWeak = "mechanism-too-weak" + show SaslNotAuthorized = "not-authorized" + show SaslTemporaryAuthFailure = "temporary-auth-failure" + +instance Read SaslError where + readsPrec _ "aborted" = [(SaslAborted , "")] + readsPrec _ "account-disabled" = [(SaslAccountDisabled , "")] + readsPrec _ "credentials-expired" = [(SaslCredentialsExpired , "")] + readsPrec _ "encryption-required" = [(SaslEncryptionRequired , "")] + readsPrec _ "incorrect-encoding" = [(SaslIncorrectEncoding , "")] + readsPrec _ "invalid-authzid" = [(SaslInvalidAuthzid , "")] + readsPrec _ "invalid-mechanism" = [(SaslInvalidMechanism , "")] + readsPrec _ "malformed-request" = [(SaslMalformedRequest , "")] + readsPrec _ "mechanism-too-weak" = [(SaslMechanismTooWeak , "")] + readsPrec _ "not-authorized" = [(SaslNotAuthorized , "")] + readsPrec _ "temporary-auth-failure" = [(SaslTemporaryAuthFailure , "")] readsPrec _ _ = [] -- | Readability type for host name Texts. diff --git a/src/Tests.hs b/src/Tests.hs index cca1d1f..ee381c4 100644 --- a/src/Tests.hs +++ b/src/Tests.hs @@ -28,7 +28,7 @@ supervisor :: JID supervisor = read "uart14@species64739.dyndns.org" -attXmpp :: STM a -> XMPPThread a +attXmpp :: STM a -> XMPP a attXmpp = liftIO . atomically testNS :: Text @@ -66,7 +66,7 @@ iqResponder = do answerIQ next (Right $ Just answerBody) when (payloadCounter payload == 10) endSession -autoAccept :: XMPPThread () +autoAccept :: XMPP () autoAccept = forever $ do st <- waitForPresence isPresenceSubscribe sendPresence $ presenceSubscribed (fromJust $ presenceFrom st) @@ -92,7 +92,7 @@ runMain debug number = do let debug' = liftIO . atomically . debug . (("Thread " ++ show number ++ ":") ++) wait <- newEmptyTMVarIO - xmppNewSession $ do + withNewSession $ do setSessionEndHandler (liftIO . atomically $ putTMVar wait ()) debug' "running" connect "localhost" "species64739.dyndns.org" @@ -100,15 +100,15 @@ runMain debug number = do saslResponse <- auth (fromJust $ localpart we) "pwd" (resourcepart we) case saslResponse of Right _ -> return () - Left e -> error "saslerror" + Left e -> error $ show e debug' "session standing" sendPresence presenceOnline - forkXMPP autoAccept + fork autoAccept sendPresence $ presenceSubscribe them - forkXMPP iqResponder + fork iqResponder when active $ do liftIO $ threadDelay 1000000 -- Wait for the other thread to go online - void . forkXMPP $ do + void . fork $ do forM [1..10] $ \count -> do let message = Text.pack . show $ localpart we let payload = Payload count (even count) (Text.pack $ show count) From fc63b62babd800789ea50aef11d2c42d3963839b Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 29 Apr 2012 18:25:16 +0200 Subject: [PATCH 26/29] unlifted connection handling exported withConnection --- src/Network/XMPP.hs | 25 ++++++++----------------- src/Network/XMPP/Bind.hs | 9 ++++----- src/Network/XMPP/Monad.hs | 13 +++++++++++++ src/Network/XMPP/Session.hs | 13 +++++++------ src/Network/XMPP/TLS.hs | 5 ++--- src/Tests.hs | 15 ++++++++------- 6 files changed, 42 insertions(+), 38 deletions(-) diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index 84bf2be..ecc7e5e 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -37,6 +37,7 @@ module Network.XMPP withNewSession , withSession , newSession + , withConnection , connect , startTLS , auth @@ -161,14 +162,8 @@ import Network.XMPP.Types import Control.Monad.Error -- | Connect to host with given address. -xmppConnect :: HostName -> Text -> XMPPConMonad (Either StreamError ()) -xmppConnect address hostname = xmppRawConnect address hostname >> xmppStartStream - --- | Attempts to secure the connection using TLS. Will return --- 'TLSNoServerSupport' when the server does not offer TLS or does not --- expect it at this time. -startTLS :: TLS.TLSParams -> XMPP (Either XMPPTLSError ()) -startTLS = withConnection . xmppStartTLS +connect :: HostName -> Text -> XMPPConMonad (Either StreamError ()) +connect address hostname = xmppRawConnect address hostname >> xmppStartStream -- | Authenticate to the server with the given username and password -- and bind a resource @@ -176,13 +171,9 @@ auth :: Text.Text -- ^ The username -> Text.Text -- ^ The password -> Maybe Text -- ^ The desired resource or 'Nothing' to let the server -- assign one - -> XMPP (Either AuthError Text.Text) + -> XMPPConMonad (Either AuthError Text.Text) auth username passwd resource = runErrorT $ do - ErrorT . withConnection $ xmppSASL username passwd - res <- lift $ xmppBind resource - lift $ startSession - return res - --- | Connect to an xmpp server -connect :: HostName -> Text -> XMPP (Either StreamError ()) -connect address hostname = withConnection $ xmppConnect address hostname + ErrorT $ xmppSASL username passwd + res <- lift $ xmppBind resource + lift $ xmppStartSession + return res diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index 77b25c3..b371883 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -11,7 +11,7 @@ import Data.XML.Types import Network.XMPP.Types import Network.XMPP.Pickle -import Network.XMPP.Concurrent +import Network.XMPP.Monad -- A `bind' element. @@ -29,7 +29,6 @@ bindBody rsrc = (pickleElem rsrc ) - -- Extracts the character data in the `jid' element. jidP :: PU [Node] JID @@ -39,10 +38,10 @@ jidP = bindP $ xpElemNodes "jid" (xpContent xpPrim) -- Sends a (synchronous) IQ set request for a (`Just') given or -- server-generated resource and extract the JID from the non-error -- response. - -xmppBind :: Maybe Text -> XMPP Text +xmppBind :: Maybe Text -> XMPPConMonad Text xmppBind rsrc = do - answer <- sendIQ' Nothing Set Nothing (bindBody rsrc) + answer <- xmppSendIQ' "bind" Nothing Set Nothing (bindBody rsrc) let (Right IQResult{iqResultPayload = Just b}) = answer -- TODO: Error handling let Right (JID _n _d (Just r)) = unpickleElem jidP b return r + diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 34bc566..d3a1108 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -137,3 +137,16 @@ xmppKillConnection = do cc <- gets sCloseConnection liftIO cc put xmppZeroConState + +xmppSendIQ' iqID to tp lang body = do + push . 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' + diff --git a/src/Network/XMPP/Session.hs b/src/Network/XMPP/Session.hs index b21c265..e164987 100644 --- a/src/Network/XMPP/Session.hs +++ b/src/Network/XMPP/Session.hs @@ -25,12 +25,13 @@ sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" , iqRequestPayload = sessionXML } -xmppSession :: XMPPConMonad () -xmppSession = do - push $ sessionIQ - answer <- pullStanza - let IQResultS (IQResult "sess" Nothing Nothing _lang _body) = answer - return () +xmppStartSession :: XMPPConMonad () +xmppStartSession = do + answer <- xmppSendIQ' "session" Nothing Set Nothing sessionXML + case answer of + Left e -> error $ show e + Right _ -> return () + startSession :: XMPP () startSession = do diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index 5d2418d..c80a8a5 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -45,9 +45,8 @@ data XMPPTLSError = TLSError TLSError instance Error XMPPTLSError where noMsg = TLSNoConnection -- TODO: What should we choose here? - -xmppStartTLS :: TLS.TLSParams -> XMPPConMonad (Either XMPPTLSError ()) -xmppStartTLS params = Ex.handle (return . Left . TLSError) +startTLS :: TLS.TLSParams -> XMPPConMonad (Either XMPPTLSError ()) +startTLS params = Ex.handle (return . Left . TLSError) . runErrorT $ do features <- lift $ gets sFeatures handle' <- lift $ gets sConHandle diff --git a/src/Tests.hs b/src/Tests.hs index ee381c4..d0b8c25 100644 --- a/src/Tests.hs +++ b/src/Tests.hs @@ -95,13 +95,14 @@ runMain debug number = do withNewSession $ do setSessionEndHandler (liftIO . atomically $ putTMVar wait ()) debug' "running" - connect "localhost" "species64739.dyndns.org" - startTLS exampleParams - saslResponse <- auth (fromJust $ localpart we) "pwd" (resourcepart we) - case saslResponse of - Right _ -> return () - Left e -> error $ show e - debug' "session standing" + withConnection $ do + connect "localhost" "species64739.dyndns.org" + startTLS exampleParams + saslResponse <- auth (fromJust $ localpart we) "pwd" (resourcepart we) + case saslResponse of + Right _ -> return () + Left e -> error $ show e + debug' "session standing" sendPresence presenceOnline fork autoAccept sendPresence $ presenceSubscribe them From bbf90aee452e6aed5f71a1bf7195a34c42327b92 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Fri, 4 May 2012 12:10:24 +0200 Subject: [PATCH 27/29] protect xmppKillConnection from exceptions --- src/Network/XMPP/Monad.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index d3a1108..163d091 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} module Network.XMPP.Monad where @@ -135,7 +136,7 @@ xmppNewSession action = do xmppKillConnection :: XMPPConMonad () xmppKillConnection = do cc <- gets sCloseConnection - liftIO cc + void . liftIO $ (Ex.try cc :: IO (Either Ex.SomeException ())) put xmppZeroConState xmppSendIQ' iqID to tp lang body = do From 3d8f0601162f448229793ca0bce0824cde84fac2 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Fri, 4 May 2012 11:35:57 +0200 Subject: [PATCH 28/29] removed two unused modules --- src/Network/XMPP/SessionOld.hs | 762 --------------------------------- src/Network/XMPP/Stanza.hs | 143 ------- 2 files changed, 905 deletions(-) delete mode 100644 src/Network/XMPP/SessionOld.hs delete mode 100644 src/Network/XMPP/Stanza.hs diff --git a/src/Network/XMPP/SessionOld.hs b/src/Network/XMPP/SessionOld.hs deleted file mode 100644 index 99f2bcc..0000000 --- a/src/Network/XMPP/SessionOld.hs +++ /dev/null @@ -1,762 +0,0 @@ --- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the --- Pontarius distribution for more details. - --- I believe we need to use the MultiParamTypeClasses extension to be able to --- work with arbitrary client states (solving the problem that the ClientState --- type class is solving). However, I would be happy if someone proved me wrong. - -{-# LANGUAGE MultiParamTypeClasses #-} - -{-# OPTIONS_HADDOCK hide #-} - --- This module provides the functions used by XMPP clients to manage their XMPP --- sessions. --- --- Working with Pontarius is mostly done asynchronously with callbacks; --- Pontarius "owns" the XMPP thread and carries the client state with it. A --- client consists of a list of client handlers to handle XMPP events. This is --- all set up through a @Session@ object, which a client can create by calling --- the (blocking) function @createSession@. --- --- The Pontarius XMPP functions operate in an arbitrary MonadIO monad. --- Typically, clients will use the IO monad. --- --- For more information, see the Pontarius manual. - --- TODO: Better functions and events for stanzas, IncomingIQ, OutgoingIQ, etc. (ClientSession, ClientStanza) - --- TODO: IO function to do everything related to the handle, instead of just connecting. - --- TODO: Enumerate in the same thread? Enumerate one element at the time, non-blocking? - -module Network.XMPP.Session ( ClientHandler (..) - , ClientState (..) - , ConnectResult (..) - , Session - , TerminationReason - , OpenStreamResult (..) - , SecureWithTLSResult (..) - , AuthenticateResult (..) - , sendPresence - , sendIQ - , sendMessage - , connect - , openStreams - , tlsSecureStreams - , authenticate - , session - , injectAction - , getID ) where - -import Network.XMPP.Address -import Network.XMPP.SASL -import Network.XMPP.Stanza -import Network.XMPP.Stream -import Network.XMPP.TLS -import Network.XMPP.Types -import Network.XMPP.Utilities - -import qualified Control.Exception as CE -import qualified Control.Exception.Base as CEB -- ? -import qualified Control.Monad.Error as CME -import qualified Control.Monad.State as CMS -import qualified Network as N - -------------- - -import Crypto.Random (newGenIO, SystemRandom) - -import Control.Concurrent.MVar - -import Codec.Binary.UTF8.String -import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) -import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay) -import Control.Monad.IO.Class (liftIO, MonadIO) -import Control.Monad.State hiding (State) -import Data.Enumerator (($$), Iteratee, continue, joinI, - run, run_, yield) -import Data.Enumerator.Binary (enumHandle, enumFile) -import Data.Maybe -import Data.String -import Data.XML.Types -import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput) -import Network.TLS -import Network.TLS.Cipher -import System.IO (BufferMode, BufferMode(NoBuffering)) --- import Text.XML.Enumerator.Parse (parseBytes, decodeEntities) --- import Text.XML.Enumerator.Document (fromEvents) -import qualified Codec.Binary.Base64.String as CBBS -import qualified Data.ByteString as DB -import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack, fromChunks, toChunks, null) -import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack) -import qualified Data.Enumerator as E -import qualified Data.Enumerator.List as EL -import qualified Data.List as DL -import qualified Data.Text as DT -import qualified Data.Text.Lazy as DTL - -import Data.Certificate.X509 (X509) - -import Data.UUID (UUID, toString) - -import System.Random (randomIO) - - - --- ============================================================================= --- EXPORTED TYPES AND FUNCTIONS --- ============================================================================= - - --- | The @Session@ object is used by clients when interacting with Pontarius. --- It holds information needed by Pontarius XMPP; its content is not --- accessible from the client. - --- data Session s m = Session { sessionChannel :: Chan (InternalEvent s m) --- , sessionIDGenerator :: IDGenerator } - - --- | A client typically needs one or more @ClientHandler@ objects to interact --- with Pontarius. Each client handler may provide four callback --- functions; the first three callbacks deals with received stanzas, and the --- last one is used when the session is terminated. --- --- These stanza functions takes the current client state and an object --- containing the details of the stanza in question. The boolean returned --- along with the possibly updated state signals whether or not the message --- should be blocked to client handlerss further down the stack. For example, --- an XEP-0030: Service Discovery handler may choose to hide disco\#info --- requests to handlers above it in the stack. --- --- The 'sessionTerminated' callback function takes a 'TerminationReason' value --- along with the state and will be sent to all client handlers. - --- data MonadIO m => ClientHandler s m = --- ClientHandler { messageReceived :: Maybe (Message -> StateT s m Bool) --- , presenceReceived :: Maybe (Presence -> StateT s m Bool) --- , iqReceived :: Maybe (IQ -> StateT s m Bool) --- , sessionTerminated :: Maybe (TerminationReason -> --- StateT s m ()) } - - --- | @TerminationReason@ contains information on why the XMPP session was --- terminated. - --- data TerminationReason = WhateverReason -- TODO - - --- | Creates an XMPP session. Blocks the current thread. The first parameter, --- @s@, is an arbitrary state that is defined by the client. This is the --- initial state, and it will be passed to the client (handlers) as XMPP --- events are emitted. The second parameter is the list of @ClientHandler@s; --- this is a way to provide a "layered" system of XMPP event handlers. For --- example, a client may have a dedicated handler to manage messages, --- implement a spam protection system, etc. Messages are piped through these --- handlers one by one, and any handler may block the message from being sent --- to the next handler(s) above in the stack. The third argument is a callback --- function that will be called when the session has been initialized, and --- this function should be used by the client to store the Session object in --- its state. - --- Creates the internal event channel, injects the Pontarius XMPP session object --- into the ClientState object, runs the "session created" client callback (in --- the new state context), and stores the updated client state in s''. Finally, --- we launch the (main) state loop of Pontarius XMPP. - -session :: (MonadIO m, ClientState s m) => s -> [ClientHandler s m] -> - (CMS.StateT s m ()) -> m () - -session s h c = do - threadID <- liftIO $ newEmptyMVar - chan <- liftIO $ newChan - idGenerator <- liftIO $ idGenerator "" -- TODO: Prefix - ((), clientState) <- runStateT c (putSession s $ session_ chan idGenerator) - (result, _) <- runStateT (stateLoop chan) - (defaultState chan threadID h clientState idGenerator) - case result of - Just (CE.SomeException e) -> do - liftIO $ putStrLn "Got an exception!" - threadID' <- liftIO $ tryTakeMVar threadID - case threadID' of - Nothing -> do - liftIO $ putStrLn "No thread ID to kill" - Just t -> do - liftIO $ putStrLn "Killing thread" - liftIO $ killThread t - CE.throw e - Nothing -> - return () - where - -- session :: Chan (InternalEvent m s) -> Session m s -- TODO - session_ c i = Session { sessionChannel = c, sessionIDGenerator = i } - - -defaultState :: (MonadIO m, ClientState s m) => Chan (InternalEvent s m) -> MVar ThreadId -> - [ClientHandler s m] -> s -> IDGenerator -> State s m - -defaultState c t h s i = State { stateClientHandlers = h - , stateClientState = s - , stateChannel = c - , stateConnectionState = Disconnected - , stateStreamState = PreStream - , stateTLSState = NoTLS - , stateOpenStreamsCallback = Nothing - , stateTLSSecureStreamsCallback = Nothing - , stateAuthenticateCallback = Nothing - , stateAuthenticationState = NoAuthentication - , stateResource = Nothing - , stateShouldExit = False - , stateThreadID = t - , statePresenceCallbacks = [] - , stateMessageCallbacks = [] - , stateIQCallbacks = [] - , stateTimeoutStanzaIDs = [] - , stateIDGenerator = i - , stateSASLRValue = Nothing } -- TODO: Prefix - - --- | --- Convenience function for calling "openStreams" and "tlsSecureStreams" and\/or --- "authenticate". See the documentation for the three separate functions for --- details on how they operate. - -connect :: MonadIO m => Session s m -> HostName -> PortNumber -> - Maybe (Maybe [X509], ([X509] -> Bool)) -> - Maybe (UserName, Password, Maybe Resource) -> - (ConnectResult -> StateT s m ()) -> StateT s m () - -connect s h p t a c = openStreams s h p connect' - where - connect' r = case r of - OpenStreamSuccess _ _ -> case t of -- TODO: Check for TLS support? - Just (certificate, certificateValidator) -> - tlsSecureStreams s certificate certificateValidator connect'' - Nothing -> connect'' (SecureWithTLSSuccess 1.0 "") -- TODO - OpenStreamFailure -> c ConnectOpenStreamFailure - connect'' r = case r of - SecureWithTLSSuccess _ _ -> case a of - Just (userName, password, resource) -> - authenticate s userName password resource connect''' - Nothing -> connect''' (AuthenticateSuccess 1.0 "" "todo") -- TODO - SecureWithTLSFailure -> c ConnectSecureWithTLSFailure - connect''' r = case r of - AuthenticateSuccess streamProperties streamFeatures resource -> - c (ConnectSuccess streamProperties streamFeatures (Just resource)) - AuthenticateFailure -> c ConnectAuthenticateFailure - - -openStreams :: MonadIO m => Session s m -> HostName -> PortNumber -> - (OpenStreamResult -> StateT s m ()) -> StateT s m () - -openStreams s h p c = CMS.get >>= - (\ state -> lift $ liftIO $ writeChan (sessionChannel s) - (IEC (CEOpenStream h p c))) - - --- | --- Tries to secure the connection with TLS. --- --- If the list of certificates is provided, they will be presented to the --- server. --- --- The third parameter is an optional custom validation function for the server --- certificates. Note that Pontarius will perform its own validation --- according to the RFC 6120, including comparing the domain name specified in --- the certificate against the connected server, as well as checking the --- integrity, and the certificate authorities. --- --- Note: The current implementation of `certificate' looks for trusted --- certificates in the /etc/ssl/certs directory. --- --- Note: The current implementation of `certificate' does not support parsing --- X509 extensions. Because of this, we will defer checking CRLs and/or OCSP --- services as well as checking for the basicConstraints cA boolean for the --- time-being. - -tlsSecureStreams :: MonadIO m => Session s m -> Maybe [X509] -> - ([X509] -> Bool) -> (SecureWithTLSResult -> StateT s m ()) -> StateT s m () - -tlsSecureStreams s c a c_ = CMS.get >>= - (\ state -> lift $ liftIO $ - writeChan (sessionChannel s) - (IEC (CESecureWithTLS c a c_))) - - --- | - -authenticate :: MonadIO m => Session s m -> UserName -> Password -> - Maybe Resource -> (AuthenticateResult -> StateT s m ()) -> - StateT s m () - -authenticate s u p r c = CMS.get >>= - (\ state -> lift $ liftIO $ - writeChan (sessionChannel s) - (IEC (CEAuthenticate u p r c))) - - -sendMessage :: MonadIO m => Session s m -> Message -> Maybe (Message -> StateT s m Bool) -> Maybe (Timeout, StateT s m ()) -> Maybe (StreamError -> StateT s m ()) -> StateT s m () -sendMessage se m c t st = CMS.get >>= - (\ state -> lift $ liftIO $ - writeChan (sessionChannel se) - (IEC (CEMessage m c t st))) - -sendPresence :: MonadIO m => Session s m -> Presence -> Maybe (Presence -> StateT s m Bool) -> Maybe (Timeout, StateT s m ()) -> Maybe (StreamError -> StateT s m ()) -> StateT s m () -sendPresence se p c t st = CMS.get >>= - (\ state -> lift $ liftIO $ - writeChan (sessionChannel se) - (IEC (CEPresence p c t st))) - -sendIQ :: MonadIO m => Session s m -> IQ -> Maybe (IQ -> StateT s m Bool) -> Maybe (Timeout, StateT s m ()) -> Maybe (StreamError -> StateT s m ()) -> StateT s m () -sendIQ se i c t st = CMS.get >>= - (\ state -> lift $ liftIO $ - writeChan (sessionChannel se) - (IEC (CEIQ i c t st))) - -injectAction :: MonadIO m => Session s m -> Maybe (StateT s m Bool) -> StateT s m () -> StateT s m () -injectAction s p a = CMS.get >>= - (\ state -> lift $ liftIO $ - writeChan (sessionChannel s) - (IEC (CEAction p a))) - -getID :: MonadIO m => Session s m -> StateT s m String -getID s = CMS.get >>= \ state -> lift $ liftIO $ nextID (sessionIDGenerator s) >>= \ id -> return id - --- xmppDisconnect :: MonadIO m => Session s m -> Maybe (s -> (Bool, s)) -> m () --- xmppDisconnect s c = xmppDisconnect s c - -class ClientState s m where - putSession :: s -> Session s m -> s - - --- ============================================================================= --- INTERNAL TYPES AND FUNCTIONS --- ============================================================================= - - -type OpenStreamCallback s m = Maybe (OpenStreamResult -> CMS.StateT s m ()) - -type SecureWithTLSCallback s m = Maybe (SecureWithTLSResult -> CMS.StateT s m ()) - -type AuthenticateCallback s m = Maybe (AuthenticateResult -> CMS.StateT s m ()) - - -isConnected :: ConnectionState -> Bool -isConnected Disconnected = True -isConnected (Connected _ _) = True - -data MonadIO m => State s m = - State { stateClientHandlers :: [ClientHandler s m] - , stateClientState :: s - , stateChannel :: Chan (InternalEvent s m) - , stateConnectionState :: ConnectionState -- s m - , stateTLSState :: TLSState - , stateStreamState :: StreamState - , stateOpenStreamsCallback :: OpenStreamCallback s m - , stateTLSSecureStreamsCallback :: SecureWithTLSCallback s m - , stateAuthenticateCallback :: AuthenticateCallback s m - , stateAuthenticationState :: AuthenticationState - , stateResource :: Maybe Resource - , stateShouldExit :: Bool - , stateThreadID :: MVar ThreadId - , statePresenceCallbacks :: [(StanzaID, (Presence -> StateT s m Bool))] - , stateMessageCallbacks :: [(StanzaID, (Message -> StateT s m Bool))] - , stateIQCallbacks :: [(StanzaID, (IQ -> StateT s m Bool))] - , stateTimeoutStanzaIDs :: [StanzaID] - , stateIDGenerator :: IDGenerator - , stateSASLRValue :: Maybe String - } - - --- Repeatedly reads internal events from the channel and processes them. This is --- the main loop of the XMPP session process. - --- The main loop of the XMPP library runs in the following monads: --- --- m, m => MonadIO (from the client) --- StateT --- ErrorT - --- TODO: Will >> carry the updated state? --- TODO: Should InternalState be in both places? - -stateLoop :: (MonadIO m, ClientState s m) => Chan (InternalEvent s m) -> - StateT (State s m) m (Maybe CE.SomeException) - -stateLoop c = do - event <- lift $ liftIO $ readChan c - lift $ liftIO $ putStrLn $ "Processing event " ++ (show event) ++ "." - result <- (processEvent event) - state <- get - case result of - Nothing -> do - case stateShouldExit state of - True -> - return $ Nothing - False -> - stateLoop c - Just e -> - return $ Just e - - --- Process an InternalEvent and performs the necessary IO and updates the state --- accordingly. - -processEvent :: (MonadIO m, ClientState s m) => (InternalEvent s m) -> - (StateT (State s m) m) (Maybe CE.SomeException) - -processEvent e = get >>= \ state -> - let handleOrTLSCtx = case stateTLSState state of - PostHandshake tlsCtx -> - Right tlsCtx - _ -> - let Connected _ handle = stateConnectionState state in Left handle - in case e of - - -- --------------------------------------------------------------------------- - -- CLIENT EVENTS - -- --------------------------------------------------------------------------- - -- - IEC (CEOpenStream hostName portNumber callback) -> do - - -- CEB.assert (stateConnectionState state == Disconnected) (return ()) - - -- let portNumber' = fromIntegral portNumber - - -- connectResult <- liftIO $ CE.try $ N.connectTo hostName - -- (N.PortNumber portNumber') - - -- case connectResult of - -- Right handle -> do - -- put $ state { stateConnectionState = Connected (ServerAddress hostName portNumber') handle - -- , stateStreamState = PreStream - -- , stateOpenStreamsCallback = Just callback } - -- lift $ liftIO $ hSetBuffering handle NoBuffering - -- lift $ liftIO $ send ("") (Left handle) - -- threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Left handle) - -- lift $ liftIO $ putMVar (stateThreadID state) threadID - -- return Nothing - Left e -> do - let clientState = stateClientState state - ((), clientState') <- lift $ runStateT (callback OpenStreamFailure) clientState - put $ state { stateShouldExit = True } - return $ Just e - - IEC (CESecureWithTLS certificate verifyCertificate callback) -> do - -- CEB.assert (not $ isTLSSecured (stateStreamState state)) (return ()) - let Connected _ handle = stateConnectionState state - lift $ liftIO $ send "" (Left handle) - put $ state { stateStreamState = PreStream - , stateTLSSecureStreamsCallback = Just callback } - return Nothing - --- TODO: Save callback in state. - IEC (CEAuthenticate userName password resource callback) -> do - -- CEB.assert (or [ stateConnectionState state == Connected - -- , stateConnectionState state == TLSSecured ]) (return ()) - -- CEB.assert (stateHandle state /= Nothing) (return ()) - -- let Connected (ServerAddress hostName _) _ = stateConnectionState state - rValue <- lift $ liftIO $ randomIO - put $ state { stateAuthenticationState = AuthenticatingPreChallenge1 userName password resource - , stateAuthenticateCallback = Just callback - , stateSASLRValue = Just (toString rValue) } - lift $ liftIO $ putStrLn $ "__________" ++ ("" ++ (CBBS.encode ("n,,n=" ++ userName ++ ",r=" ++ (toString rValue))) ++ "") - lift $ liftIO $ send ("" ++ (CBBS.encode ("n,,n=" ++ userName ++ ",r=" ++ (toString rValue))) ++ "") handleOrTLSCtx - return Nothing - - IEE (EnumeratorBeginStream from to id ver lang namespace) -> do - put $ state { stateStreamState = PreFeatures (1.0) } - return Nothing - --- IEE (EnumeratorXML (XEFeatures features)) -> do --- let PreFeatures streamProperties = stateStreamState state --- case stateTLSState state of --- NoTLS -> let callback = fromJust $ stateOpenStreamsCallback state in do --- ((), clientState) <- lift $ runStateT (callback $ OpenStreamSuccess streamProperties "TODO") (stateClientState state) --- put $ state { stateClientState = clientState --- , stateStreamState = PostFeatures streamProperties "TODO" } --- return Nothing --- _ -> case stateAuthenticationState state of --- AuthenticatedUnbound _ resource -> do -- TODO: resource --- case resource of --- Nothing -> do --- lift $ liftIO $ send ("") handleOrTLSCtx --- return () --- _ -> do --- lift $ liftIO $ send ("" ++ fromJust resource ++ "") handleOrTLSCtx --- return () --- id <- liftIO $ nextID $ stateIDGenerator state --- lift $ liftIO $ send ("" ++ "") handleOrTLSCtx --- --- -- TODO: Execute callback on iq result --- --- let callback = fromJust $ stateAuthenticateCallback state in do -- TODO: streamProperties "TODO" after success --- ((), clientState) <- lift $ runStateT (callback $ AuthenticateSuccess streamProperties "TODO" "todo") (stateClientState state) -- get proper resource value when moving to iq result --- put $ state { stateClientState = clientState --- , stateStreamState = PostFeatures streamProperties "TODO" } --- state' <- get --- return Nothing --- _ -> do --- let callback = fromJust $ stateTLSSecureStreamsCallback state in do --- ((), clientState) <- lift $ runStateT (callback $ SecureWithTLSSuccess streamProperties "TODO") (stateClientState state) --- put $ state { stateClientState = clientState --- , stateStreamState = PostFeatures streamProperties "TODO" } --- return Nothing --- --- -- TODO: Can we assume that it's safe to start to enumerate on handle when it --- -- might not have exited? --- IEE (EnumeratorXML XEProceed) -> do --- let Connected (ServerAddress hostName _) handle = stateConnectionState state --- tlsCtx <- lift $ liftIO $ do --- gen <- newGenIO :: IO SystemRandom -- TODO: Investigate limitations --- clientContext <- client tlsParams gen handle --- handshake clientContext --- return clientContext --- put $ (defaultState (stateChannel state) (stateThreadID state) (stateClientHandlers state) (stateClientState state) (stateIDGenerator state)) { stateTLSState = PostHandshake tlsCtx, stateConnectionState = (stateConnectionState state), stateTLSSecureStreamsCallback = (stateTLSSecureStreamsCallback state) } --- threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Right tlsCtx) -- double code --- lift $ liftIO $ putStrLn "00000000000000000000000000000000" --- lift $ liftIO $ swapMVar (stateThreadID state) threadID -- return value not used --- lift $ liftIO $ putStrLn "00000000000000000000000000000000" --- lift $ liftIO $ threadDelay 1000000 --- lift $ liftIO $ putStrLn "00000000000000000000000000000000" --- lift $ liftIO $ send ("") (Right tlsCtx) --- lift $ liftIO $ putStrLn "00000000000000000000000000000000" --- return Nothing --- --- IEE (EnumeratorXML (XEChallenge (Chal challenge))) -> do --- lift $ liftIO $ putStrLn challenge --- let Connected (ServerAddress hostName _) _ = stateConnectionState state --- let challenge' = CBBS.decode challenge --- case stateAuthenticationState state of --- AuthenticatingPreChallenge1 userName password resource -> do --- id <- liftIO $ nextID $ stateIDGenerator state --- -- TODO: replyToChallenge --- return () --- AuthenticatingPreChallenge2 userName password resource -> do --- -- This is not the first challenge; [...] --- -- TODO: Can we assume "rspauth"? --- lift $ liftIO $ send "" handleOrTLSCtx --- put $ state { stateAuthenticationState = AuthenticatingPreSuccess userName password resource } --- return () --- return Nothing --- --- -- We have received a SASL "success" message over a secured connection --- -- TODO: Parse the success message? --- -- TODO: ? --- IEE (EnumeratorXML (XESuccess (Succ _))) -> do --- let serverHost = "jonkristensen.com" --- let AuthenticatingPreSuccess userName _ resource = stateAuthenticationState state in do --- lift $ liftIO $ send ("") handleOrTLSCtx --- put $ state { stateAuthenticationState = AuthenticatedUnbound userName resource } --- return Nothing - - IEE EnumeratorDone -> - -- TODO: Exit? - return Nothing - - -- --------------------------------------------------------------------------- - -- XML EVENTS - -- --------------------------------------------------------------------------- - --- -- Ignore id="bind_1" and session IQ result, otherwise create client event --- IEE (EnumeratorXML (XEIQ iqEvent)) -> --- case shouldIgnoreIQ iqEvent of --- True -> --- return Nothing --- False -> do --- let stanzaID' = iqID iqEvent --- let newTimeouts = case stanzaID' of --- Just stanzaID'' -> --- case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of --- True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state) --- False -> (stateTimeoutStanzaIDs state) --- Nothing -> (stateTimeoutStanzaIDs state) --- let iqReceivedFunctions = map (\ x -> iqReceived x) (stateClientHandlers state) --- let functions = map (\ x -> case x of --- Just f -> Just (f iqEvent) --- Nothing -> Nothing) iqReceivedFunctions --- let functions' = case lookup (fromJust $ iqID $ iqEvent) (stateIQCallbacks state) of --- Just f -> (Just (f $ iqEvent)):functions --- Nothing -> functions --- let clientState = stateClientState state --- clientState' <- sendToClient functions' clientState --- put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts } --- return Nothing --- --- -- TODO: Known bug - does not work with PresenceError --- --- IEE (EnumeratorXML (XEPresence (Right presenceEvent))) -> do --- let stanzaID' = presenceID $ presenceEvent --- let newTimeouts = case stanzaID' of --- Just stanzaID'' -> --- case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of --- True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state) --- False -> (stateTimeoutStanzaIDs state) --- Nothing -> (stateTimeoutStanzaIDs state) --- let presenceReceivedFunctions = map (\ x -> presenceReceived x) (stateClientHandlers state) --- let functions = map (\ x -> case x of --- Just f -> Just (f presenceEvent) --- Nothing -> Nothing) presenceReceivedFunctions --- let clientState = stateClientState state -- ClientState s m --- clientState' <- sendToClient functions clientState --- put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts } --- return Nothing --- --- -- TODO: Does not work with message errors --- IEE (EnumeratorXML (XEMessage (Right messageEvent))) -> do --- let stanzaID' = messageID $ messageEvent --- let newTimeouts = case stanzaID' of --- Just stanzaID'' -> --- case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of --- True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state) --- False -> (stateTimeoutStanzaIDs state) --- Nothing -> (stateTimeoutStanzaIDs state) --- let messageReceivedFunctions = map (\ x -> messageReceived x) (stateClientHandlers state) --- let functions = map (\ x -> case x of --- Just f -> Just (f messageEvent) --- Nothing -> Nothing) messageReceivedFunctions --- let clientState = stateClientState state -- ClientState s m --- clientState' <- sendToClient functions clientState --- put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts } --- return Nothing - - IEC (CEPresence presence stanzaCallback timeoutCallback streamErrorCallback) -> do - presence' <- case presenceID $ presence of - Nothing -> do - id <- liftIO $ nextID $ stateIDGenerator state - return $ presence { presenceID = Just (SID id) } - _ -> return presence - case timeoutCallback of - Just (t, timeoutCallback') -> - let stanzaID' = (fromJust $ presenceID $ presence') in do - registerTimeout (stateChannel state) stanzaID' t timeoutCallback' - put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) } - Nothing -> - return () - let xml = presenceToXML (Right presence') (fromJust $ langTag "en") - lift $ liftIO $ send (elementToString $ Just xml) handleOrTLSCtx - return Nothing - - IEC (CEMessage message stanzaCallback timeoutCallback streamErrorCallback) -> do - message' <- case messageID message of - Nothing -> do - id <- liftIO $ nextID $ stateIDGenerator state - return $ message { messageID = Just (SID id) } - _ -> return message - case timeoutCallback of - Just (t, timeoutCallback') -> - let stanzaID' = (fromJust $ messageID message') in do - registerTimeout (stateChannel state) stanzaID' t timeoutCallback' - put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) } - Nothing -> - return () - let xml = messageToXML (Right message') (fromJust $ langTag "en") - lift $ liftIO $ send (elementToString $ Just xml) handleOrTLSCtx - return Nothing - - -- TODO: Known bugs until Session rewritten - new ID everytime, callback not called - - IEC (CEIQ iq stanzaCallback timeoutCallback stanzaErrorCallback) -> do - iq' <- do -- case iqID iq of - -- Nothing -> do - id <- liftIO $ nextID $ stateIDGenerator state - return iq - let callback' = fromJust stanzaCallback - put $ state { stateIQCallbacks = (fromJust $ iqID iq, callback'):(stateIQCallbacks state) } - case timeoutCallback of - Just (t, timeoutCallback') -> - let stanzaID' = (fromJust $ iqID iq') in do - registerTimeout (stateChannel state) stanzaID' t timeoutCallback' - put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) } - Nothing -> - return () - -- TODO: Bind ID to callback - let xml = iqToXML iq' (fromJust $ langTag "en") - lift $ liftIO $ send (elementToString $ Just xml) handleOrTLSCtx - return Nothing - - IEC (CEAction predicate callback) -> do - case predicate of - Just predicate' -> do - result <- runBoolClientCallback predicate' - case result of - True -> do - runUnitClientCallback callback - return Nothing - False -> return Nothing - Nothing -> do - runUnitClientCallback callback - return Nothing - - -- XOEDisconnect -> do - -- -- TODO: Close stream - -- return () - - IET (TimeoutEvent i t c) -> - case i `elem` (stateTimeoutStanzaIDs state) of - True -> do - runUnitClientCallback c - return Nothing - False -> return Nothing - - - e -> do - return Nothing - -- lift $ liftIO $ putStrLn $ "UNCAUGHT EVENT: " ++ (show e) - -- return $ Just (CE.SomeException $ CE.PatternMatchFail "processEvent") - where - -- Assumes handle is set - send :: String -> Either Handle TLSCtx -> IO () - send s o = case o of - Left handle -> do - -- liftIO $ hPutStr handle $ encodeString $ s - -- liftIO $ hFlush handle - return () - Right tlsCtx -> do - liftIO $ sendData tlsCtx $ DBLC.pack $ encodeString s - return () - shouldIgnoreIQ :: IQ -> Bool - shouldIgnoreIQ i = case iqPayload i of - Nothing -> False - Just e -> case nameNamespace $ elementName e of - Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-bind" -> True - Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-session" -> True - Just _ -> False - Nothing -> False - - -registerTimeout :: (ClientState s m, MonadIO m) => Chan (InternalEvent s m) -> StanzaID -> Timeout -> StateT s m () -> StateT (State s m) m () -registerTimeout ch i t ca = do - liftIO $ threadDelay $ t * 1000 - liftIO $ forkIO $ writeChan ch $ IET (TimeoutEvent i t ca) - return () - - -runBoolClientCallback :: (ClientState s m, MonadIO m) => StateT s m Bool -> StateT (State s m) m Bool -runBoolClientCallback c = do - state <- get - let clientState = stateClientState state - (bool, clientState') <- lift $ runStateT c clientState - put $ state { stateClientState = clientState' } - return bool - - -runUnitClientCallback :: (ClientState s m, MonadIO m) => StateT s m () -> StateT (State s m) m () -runUnitClientCallback c = do - state <- get - let clientState = stateClientState state - ((), clientState') <- lift $ runStateT c clientState - put $ state { stateClientState = clientState' } - - -sendToClient :: (MonadIO m, ClientState s m) => [Maybe (StateT s m Bool)] -> s -> (StateT (State s m) m) s -sendToClient [] s = return s -sendToClient (Nothing:fs) s = sendToClient fs s -sendToClient ((Just f):fs) s = do - (b, s') <- lift $ runStateT f s - case b of - True -> return s' - False -> sendToClient fs s' diff --git a/src/Network/XMPP/Stanza.hs b/src/Network/XMPP/Stanza.hs deleted file mode 100644 index 6666678..0000000 --- a/src/Network/XMPP/Stanza.hs +++ /dev/null @@ -1,143 +0,0 @@ --- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the --- Pontarius distribution for more details. - -{-# OPTIONS_HADDOCK hide #-} - --- The stanza record types are generally pretty convenient to work with. --- However, due to the fact that an "IQ" can be both an "IQRequest" and an --- "IQResponse" we provide some helper functions in this module that work on --- both types. --- --- We also provide functions to create a new stanza ID generator, and to --- generate new IDs. - -module Network.XMPP.Stanza ( -iqID, -iqFrom, -iqTo, -iqLangTag, -iqPayload, -iqPayloadNamespace, -iqRequestPayloadNamespace, -iqResponsePayloadNamespace -) where - -import Network.XMPP.Address -import Network.XMPP.Types - -import Data.XML.Types (Element, elementName, nameNamespace) -import Data.Text (unpack) - - --- | --- Returns the @StanzaID@ value of the @IQ@, if any. - -iqID :: IQ -> Maybe StanzaID - -iqID (Left req) = iqRequestID req -iqID (Right res) = iqResponseID res - - --- TODO: Maybe? - -iqResponseID :: IQResponse -> Maybe StanzaID - -iqResponseID (Left err) = iqErrorID err -iqResponseID (Right res) = iqResultID res - - --- | --- Returns the @From@ @JID@ value of the @IQ@, if any. - -iqFrom :: IQ -> Maybe From - -iqFrom (Left req) = iqRequestFrom req -iqFrom (Right res) = iqResponseFrom res - - --- | --- Returns the @To@ @JID@ value of the @IQ@, if any. - -iqTo :: IQ -> Maybe To - -iqTo (Left req) = iqRequestTo req -iqTo (Right res) = iqResponseTo res - - --- | --- Returns the @XMLLang@ value of the @IQ@, if any. - -iqLangTag :: IQ -> LangTag - -iqLangTag (Left req) = iqRequestLangTag req -iqLangTag (Right res) = iqResponseLangTag res - - -iqResponseLangTag :: IQResponse -> LangTag - -iqResponseLangTag (Left err) = iqErrorLangTag err -iqResponseLangTag (Right res) = iqResultLangTag res - - -iqResponseFrom :: IQResponse -> Maybe From - -iqResponseFrom (Left err) = iqErrorFrom err -iqResponseFrom (Right res) = iqResultFrom res - - -iqResponseTo :: IQResponse -> Maybe To - -iqResponseTo (Left err) = iqErrorTo err -iqResponseTo (Right res) = iqResultTo res - - - --- | --- Returns the @Element@ payload value of the @IQ@, if any. If the IQ in --- question is of the "request" type, use @iqRequestPayload@ instead. - -iqPayload :: IQ -> Maybe Element - -iqPayload (Left req) = Just (iqRequestPayload req) -iqPayload (Right res) = iqResponsePayload res - - -iqResponsePayload :: IQResponse -> Maybe Element - -iqResponsePayload (Left err) = iqErrorPayload err -iqResponsePayload (Right res) = iqResultPayload res - - --- | --- Returns the namespace of the element of the @IQ@, if any. - -iqPayloadNamespace :: IQ -> Maybe String - -iqPayloadNamespace i = case iqPayload i of - Nothing -> Nothing - Just p -> case nameNamespace $ elementName p of - Nothing -> Nothing - Just n -> Just (unpack n) - - --- | --- Returns the namespace of the element of the @IQRequest@, if any. - -iqRequestPayloadNamespace :: IQRequest -> Maybe String - -iqRequestPayloadNamespace i = let p = iqRequestPayload i in - case nameNamespace $ elementName p of - Nothing -> Nothing - Just n -> Just (unpack n) - - --- | --- Returns the namespace of the element of the @IQRequest@, if any. - -iqResponsePayloadNamespace :: IQResponse -> Maybe String - -iqResponsePayloadNamespace i = case iqResponsePayload i of - Nothing -> Nothing - Just p -> case nameNamespace $ elementName p of - Nothing -> Nothing - Just n -> Just (unpack n) \ No newline at end of file From 45edfcc56fc2910f2a7d7c0f1ae2a499a7b31326 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Fri, 4 May 2012 14:05:43 +0200 Subject: [PATCH 29/29] Add conection state to connection object, rename some types rename XMPPConState to XmppConnection rename xmppZeroCon to xmppNoConnection add XmppConnectionState remove sHaveTLS from XmppConnection add (sConnectionState :: XmppConnectionState) to XmppConnection --- src/Network/XMPP/Concurrent/Monad.hs | 3 +- src/Network/XMPP/Concurrent/Threads.hs | 6 ++-- src/Network/XMPP/Concurrent/Types.hs | 2 +- src/Network/XMPP/Monad.hs | 38 +++++++++++------------ src/Network/XMPP/TLS.hs | 2 +- src/Network/XMPP/Types.hs | 42 ++++++++++++++++---------- 6 files changed, 51 insertions(+), 42 deletions(-) diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index 515d55b..748ed9f 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -152,8 +152,7 @@ waitForPresence f = do -- Reader and writer workers will be temporarily stopped -- and resumed with the new session details once the action returns. -- The Action will run in the calling thread/ --- NB: This will /not/ catch any exceptions. If you action dies, deadlocks --- or otherwisely exits abnormaly the XMPP session will be dead. +-- Any uncaught exceptions will be interpreted as connection failure withConnection :: XMPPConMonad a -> XMPP a withConnection a = do readerId <- asks readerThread diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index 5377d37..f6e397f 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -40,7 +40,7 @@ handleInterrupts ts = readWorker :: TChan (Either MessageError Message) -> TChan (Either PresenceError Presence) -> TVar IQHandlers - -> TMVar XMPPConState + -> TMVar XmppConnection -> IO () readWorker messageC presenceC handlers stateRef = Ex.mask_ . forever $ do @@ -131,7 +131,7 @@ startThreads , TChan Stanza , IO () , TMVar (BS.ByteString -> IO ()) - , TMVar XMPPConState + , TMVar XmppConnection , ThreadId , TVar EventHandlers ) @@ -143,7 +143,7 @@ startThreads = do outC <- newTChanIO handlers <- newTVarIO ( Map.empty, Map.empty) eh <- newTVarIO zeroEventHandlers - conS <- newTMVarIO xmppZeroConState + conS <- newTMVarIO xmppNoConnection lw <- forkIO $ writeWorker outC writeLock cp <- forkIO $ connPersist writeLock rd <- forkIO $ readWorker messageC presenceC handlers conS diff --git a/src/Network/XMPP/Concurrent/Types.hs b/src/Network/XMPP/Concurrent/Types.hs index 37aa821..d075797 100644 --- a/src/Network/XMPP/Concurrent/Types.hs +++ b/src/Network/XMPP/Concurrent/Types.hs @@ -50,7 +50,7 @@ data Session = Session { messagesRef :: IORef (Maybe ( TChan (Either , writeRef :: TMVar (BS.ByteString -> IO () ) , readerThread :: ThreadId , idGenerator :: IO StanzaId - , conStateRef :: TMVar XMPPConState + , conStateRef :: TMVar XmppConnection , eventHandlers :: TVar EventHandlers , stopThreads :: IO () } diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 163d091..6621f12 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -8,7 +8,6 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class --import Control.Monad.Trans.Resource -import Control.Concurrent import qualified Control.Exception as Ex import Control.Monad.State.Strict @@ -69,38 +68,36 @@ pullStanza = do xmppFromHandle :: Handle -> Text - -> Text - -> Maybe Text -> XMPPConMonad a - -> IO (a, XMPPConState) -xmppFromHandle handle hostname username res f = do + -> IO (a, XmppConnection) +xmppFromHandle handle hostname f = do liftIO $ hSetBuffering handle NoBuffering let raw = sourceHandle handle let src = raw $= XP.parseBytes def - let st = XMPPConState + let st = XmppConnection src (raw) (BS.hPut handle) (Just handle) (SF Nothing [] []) - False + XmppConnectionPlain (Just hostname) - (Just username) - res + Nothing + Nothing (hClose handle) runStateT f st zeroSource :: Source IO output -zeroSource = liftIO . forever $ threadDelay 10000000 +zeroSource = liftIO . Ex.throwIO $ XmppNoConnection -xmppZeroConState :: XMPPConState -xmppZeroConState = XMPPConState +xmppNoConnection :: XmppConnection +xmppNoConnection = XmppConnection { sConSrc = zeroSource , sRawSrc = zeroSource - , sConPushBS = (\_ -> return ()) + , sConPushBS = \_ -> Ex.throwIO $ XmppNoConnection , sConHandle = Nothing , sFeatures = SF Nothing [] [] - , sHaveTLS = False + , sConnectionState = XmppConnectionClosed , sHostname = Nothing , sUsername = Nothing , sResource = Nothing @@ -116,29 +113,32 @@ xmppRawConnect host hostname = do return con let raw = sourceHandle con src <- liftIO . bufferSource $ raw $= XP.parseBytes def - let st = XMPPConState + let st = XmppConnection src (raw) (BS.hPut con) (Just con) (SF Nothing [] []) - False + XmppConnectionPlain (Just hostname) uname Nothing (hClose con) put st -xmppNewSession :: XMPPConMonad a -> IO (a, XMPPConState) +xmppNewSession :: XMPPConMonad a -> IO (a, XmppConnection) xmppNewSession action = do - runStateT action xmppZeroConState + runStateT action xmppNoConnection xmppKillConnection :: XMPPConMonad () xmppKillConnection = do cc <- gets sCloseConnection void . liftIO $ (Ex.try cc :: IO (Either Ex.SomeException ())) - put xmppZeroConState + put xmppNoConnection +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 res <- pullPickle $ xpEither xpIQError xpIQResult diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index c80a8a5..d4b8ce0 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -70,6 +70,6 @@ startTLS params = Ex.handle (return . Left . TLSError) , sCloseConnection = TLS.bye ctx >> sCloseConnection x }) either (lift . Ex.throwIO) return =<< lift xmppRestartStream - modify (\s -> s{sHaveTLS = True}) + modify (\s -> s{sConnectionState = XmppConnectionSecured}) return () diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index 52009ce..1c86f07 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -38,7 +38,9 @@ module Network.XMPP.Types , StreamError(..) , Version(..) , XMPPConMonad - , XMPPConState(..) + , XmppConnection(..) + , XmppConnectionState(..) + , XmppNoConnection(..) , XMPPT(..) , XmppStreamError(..) , parseLangTag @@ -704,16 +706,24 @@ data ServerFeatures = SF , other :: [Element] } deriving Show -data XMPPConState = XMPPConState - { sConSrc :: Source IO Event - , sRawSrc :: Source IO BS.ByteString - , sConPushBS :: BS.ByteString -> IO () - , sConHandle :: Maybe Handle - , sFeatures :: ServerFeatures - , sHaveTLS :: Bool - , sHostname :: Maybe Text - , sUsername :: Maybe Text - , sResource :: Maybe Text +data XmppConnectionState = XmppConnectionClosed -- ^ No connection at + -- this point + | XmppConnectionPlain -- ^ Connection + -- established, but + -- not secured + | XmppConnectionSecured -- ^ Connection + -- established and + -- secured via TLS +data XmppConnection = XmppConnection + { sConSrc :: Source IO Event + , sRawSrc :: Source IO BS.ByteString + , sConPushBS :: BS.ByteString -> IO () + , sConHandle :: Maybe Handle + , sFeatures :: ServerFeatures + , sConnectionState :: XmppConnectionState + , sHostname :: Maybe Text + , sUsername :: Maybe Text + , sResource :: Maybe Text , sCloseConnection :: IO () -- TODO: add default Language } @@ -723,14 +733,14 @@ data XMPPConState = XMPPConState -- work with Pontarius. Pontarius clients needs to operate in this -- context. -newtype XMPPT m a = XMPPT { runXMPPT :: StateT XMPPConState m a } deriving (Monad, MonadIO) +newtype XMPPT m a = XMPPT { runXMPPT :: StateT XmppConnection m a } deriving (Monad, MonadIO) -type XMPPConMonad a = StateT XMPPConState IO a +type XMPPConMonad a = StateT XmppConnection IO a -- Make XMPPT derive the Monad and MonadIO instances. -deriving instance (Monad m, MonadIO m) => MonadState (XMPPConState) (XMPPT m) +deriving instance (Monad m, MonadIO m) => MonadState (XmppConnection) (XMPPT m) +data XmppNoConnection = XmppNoConnection deriving (Show, Typeable) +instance Exception XmppNoConnection --- We need a channel because multiple threads needs to append events, --- and we need to wait for events when there are none.