From c9e0ddd1f829b495e891a0fb637e66f755f8518e Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 19 Mar 2013 19:28:13 +0100 Subject: [PATCH 01/26] Add support for reader plugins --- source/Network/Xmpp/Concurrent.hs | 64 +++++++++++++++++++------------ source/Network/Xmpp/Types.hs | 7 ++++ 2 files changed, 46 insertions(+), 25 deletions(-) diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 4344875..c40090f 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -8,14 +8,12 @@ module Network.Xmpp.Concurrent , module Network.Xmpp.Concurrent.Message , module Network.Xmpp.Concurrent.Presence , module Network.Xmpp.Concurrent.IQ - , toChans + , StanzaHandler , newSession , writeWorker , session ) where -import Network.Xmpp.Concurrent.Monad -import Network.Xmpp.Concurrent.Threads import Control.Applicative((<$>),(<*>)) import Control.Concurrent import Control.Concurrent.STM @@ -23,44 +21,56 @@ import Control.Monad import qualified Data.ByteString as BS import Data.IORef import qualified Data.Map as Map +import Data.Maybe import Data.Maybe (fromMaybe) +import Data.Text as Text import Data.XML.Types +import Network +import qualified Network.TLS as TLS import Network.Xmpp.Concurrent.Basic import Network.Xmpp.Concurrent.IQ import Network.Xmpp.Concurrent.Message +import Network.Xmpp.Concurrent.Monad import Network.Xmpp.Concurrent.Presence -import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Threads +import Network.Xmpp.Concurrent.Threads +import Network.Xmpp.Concurrent.Types import Network.Xmpp.Marshal -import Network.Xmpp.Types -import Network -import Data.Text as Text -import Network.Xmpp.Tls -import qualified Network.TLS as TLS import Network.Xmpp.Sasl import Network.Xmpp.Sasl.Mechanisms import Network.Xmpp.Sasl.Types -import Data.Maybe import Network.Xmpp.Stream +import Network.Xmpp.Tls +import Network.Xmpp.Types import Network.Xmpp.Utilities import Control.Monad.Error -import Data.Default -import System.Log.Logger -import Control.Monad.State.Strict +import Data.Default +import System.Log.Logger +import Control.Monad.State.Strict + +runHandlers :: (TChan Stanza) -> [StanzaHandler] -> Stanza -> IO () +runHandlers _ [] _ = return () +runHandlers outC (h:hands) sta = do + res <- h outC sta + case res of + True -> runHandlers outC hands sta + False -> return () + +toChan :: TChan Stanza -> StanzaHandler +toChan stanzaC _ sta = do + atomically $ writeTChan stanzaC sta + return True + -toChans :: TChan Stanza - -> TChan Stanza - -> TVar IQHandlers - -> Stanza - -> IO () -toChans stanzaC outC iqHands sta = atomically $ do - writeTChan stanzaC sta +handleIQ :: TVar IQHandlers + -> StanzaHandler +handleIQ iqHands outC sta = atomically $ do case sta of - IQRequestS i -> handleIQRequest iqHands i - IQResultS i -> handleIQResponse iqHands (Right i) - IQErrorS i -> handleIQResponse iqHands (Left i) - _ -> return () + IQRequestS i -> handleIQRequest iqHands i >> return False + IQResultS i -> handleIQResponse iqHands (Right i) >> return False + IQErrorS i -> handleIQResponse iqHands (Left i) >> return False + _ -> return True where -- If the IQ request has a namespace, send it through the appropriate channel. handleIQRequest :: TVar IQHandlers -> IQRequest -> STM () @@ -96,7 +106,11 @@ newSession stream config = runErrorT $ do stanzaChan <- lift newTChanIO iqHandlers <- lift $ newTVarIO (Map.empty, Map.empty) eh <- lift $ newTVarIO $ EventHandlers { connectionClosedHandler = sessionClosedHandler config } - let stanzaHandler = toChans stanzaChan outC iqHandlers + let stanzaHandler = runHandlers outC $ Prelude.concat [ [toChan stanzaChan] + , extraStanzaHandlers + config + , [handleIQ iqHandlers] + ] (kill, wLock, streamState, readerThread) <- ErrorT $ startThreadsWith stanzaHandler eh stream writer <- lift $ forkIO $ writeWorker outC wLock return $ Session { stanzaCh = stanzaChan diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 35c766c..e3f8340 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -36,6 +36,7 @@ module Network.Xmpp.Types , StreamState(..) , ConnectionState(..) , StreamErrorInfo(..) + , StanzaHandler , StreamConfiguration(..) , langTag , Jid(..) @@ -1105,6 +1106,10 @@ hostnameP = do then fail "Hostname too long." else return $ Text.concat [label, Text.pack ".", r] +type StanzaHandler = TChan Stanza -- ^ outgoing stanza + -> Stanza -- ^ stanza to handle + -> IO Bool -- ^ True when processing should continue + -- | Configuration for the @Session@ object. data SessionConfiguration = SessionConfiguration { -- | Configuration for the @Stream@ object. @@ -1113,6 +1118,7 @@ data SessionConfiguration = SessionConfiguration , sessionClosedHandler :: XmppFailure -> IO () -- | Function to generate the stream of stanza identifiers. , sessionStanzaIDs :: IO StanzaID + , extraStanzaHandlers :: [StanzaHandler] } instance Default SessionConfiguration where @@ -1124,6 +1130,7 @@ instance Default SessionConfiguration where curId <- readTVar idRef writeTVar idRef (curId + 1 :: Integer) return . read. show $ curId + , extraStanzaHandlers = [] } -- | How the client should behave in regards to TLS. From 79117606dc8f4a37a56493cf441a1ca841475fd3 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 19 Mar 2013 19:28:40 +0100 Subject: [PATCH 02/26] add roster handling --- source/Network/Xmpp/IM/Roster.hs | 170 +++++++++++++++++++++++++++++++ 1 file changed, 170 insertions(+) create mode 100644 source/Network/Xmpp/IM/Roster.hs diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs new file mode 100644 index 0000000..1f359f9 --- /dev/null +++ b/source/Network/Xmpp/IM/Roster.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Xmpp.IM.Roster +where + +import Control.Concurrent.STM +import Control.Monad +import Data.Text (Text) +import Data.XML.Pickle +import Data.XML.Types +import Network.Xmpp +import Network.Xmpp.Marshal +import System.Log.Logger +import qualified Data.Map.Strict as Map + +import Network.Xmpp.Types + +data Subscription = None | To | From | Both | Remove deriving Eq + +instance Show Subscription where + show None = "none" + show To = "to" + show From = "from" + show Both = "both" + show Remove = "remove" + +instance Read Subscription where + readsPrec _ "none" = [(None ,"")] + readsPrec _ "to" = [(To ,"")] + readsPrec _ "from" = [(From ,"")] + readsPrec _ "both" = [(Both ,"")] + readsPrec _ "remove" = [(Remove ,"")] + readsPrec _ _ = [] + +data Roster = Roster { ver :: Maybe Text + , items :: Map.Map Jid Item } + + +data Item = Item { approved :: Bool + , ask :: Bool + , jid :: Jid + , name :: Maybe Text + , subscription :: Subscription + , groups :: [Text] + } deriving Show + +data QueryItem = QueryItem { qiApproved :: Maybe Bool + , qiAsk :: Bool + , qiJid :: Jid + , qiName :: Maybe Text + , qiSubscription :: Maybe Subscription + , qiGroups :: [Text] + } deriving Show + +data Query = Query { queryVer :: Maybe Text + , queryItems :: [QueryItem] + } deriving Show + + +withRoster :: Maybe Roster + -> SessionConfiguration + -> (SessionConfiguration -> IO (Either XmppFailure Session)) + -> IO (Either XmppFailure (TVar Roster, Session)) +withRoster oldRoster conf startSession = do + rosterRef <- newTVarIO $ Roster Nothing Map.empty + mbSess <- startSession conf{extraStanzaHandlers = handleRoster rosterRef : + extraStanzaHandlers conf} + case mbSess of + Left e -> return $ Left e + Right sess -> do + mbRoster <- getRoster oldRoster sess + case mbRoster of + Nothing -> errorM "Pontarius.Xmpp" "Server did not return a roster" + Just roster -> atomically $ writeTVar rosterRef roster + return $ Right (rosterRef, sess) + +handleRoster :: TVar Roster -> TChan Stanza -> Stanza -> IO Bool +handleRoster rosterRef outC sta = do + case sta of + IQRequestS (iqr@IQRequest{iqRequestPayload = + iqb@Element{elementName = en}}) + | nameNamespace en == Just "jabber:iq:roster" -> do + case iqRequestFrom iqr of + Just _from -> return True -- Don't handle roster pushes from + -- unauthorized sources + Nothing -> case unpickleElem xpQuery iqb of + Right Query{ queryVer = v + , queryItems = [update] + } -> do + handleUpdate v update + atomically . writeTChan outC $ result iqr + return False + _ -> do + errorM "Pontarius.Xmpp" "Invalid roster query" + atomically . writeTChan outC $ badRequest iqr + return False + _ -> return True + where + handleUpdate v' update = atomically $ modifyTVar rosterRef $ \(Roster v is) -> + Roster (v' `mplus` v) $ case qiSubscription update of + Just Remove -> Map.delete (qiJid update) is + _ -> Map.insert (qiJid update) (toItem update) is + + badRequest (IQRequest iqid from _to lang _tp bd) = + IQErrorS $ IQError iqid Nothing from lang errBR (Just bd) + errBR = StanzaError Cancel BadRequest Nothing Nothing + result (IQRequest iqid from _to lang _tp _bd) = + IQResultS $ IQResult iqid Nothing from lang Nothing + +getRoster :: Maybe Roster -> Session -> IO (Maybe Roster) +getRoster oldRoster sess = do + res <- sendIQ' Nothing Get Nothing + (pickleElem xpQuery (Query (ver =<< oldRoster) [])) + sess + case res of + IQResponseResult (IQResult{iqResultPayload = Just ros}) + -> case unpickleElem xpQuery ros of + Left _e -> do + errorM "Pontarius.Xmpp.Roster" "getRoster: invalid query element" + return Nothing + Right roster -> return . Just $ toRoster roster + IQResponseResult (IQResult{iqResultPayload = Nothing}) -> do + return $ oldRoster + -- sever indicated that no roster updates are necessary + IQResponseTimeout -> do + errorM "Pontarius.Xmpp.Roster" "getRoster: request timed out" + return Nothing + IQResponseError e -> do + errorM "Pontarius.Xmpp.Roster" $ "getRoster: server returned error" + ++ show e + return Nothing + where + toRoster (Query v is) = Roster v (Map.fromList + $ map (\i -> (qiJid i, toItem i)) + is) + +toItem :: QueryItem -> Item +toItem qi = Item { approved = maybe False id (qiApproved qi) + , ask = qiAsk qi + , jid = qiJid qi + , name = qiName qi + , subscription = maybe None id (qiSubscription qi) + , groups = qiGroups qi + } + +xpItems :: PU [Node] [QueryItem] +xpItems = xpWrap (map (\((app_, ask_, jid_, name_, sub_), groups_) -> + QueryItem app_ ask_ jid_ name_ sub_ groups_)) + (map (\(QueryItem app_ ask_ jid_ name_ sub_ groups_) -> + ((app_, ask_, jid_, name_, sub_), groups_))) $ + xpElems "{jabber:iq:roster}item" + (xp5Tuple + (xpAttribute' "approved" xpBool) + (xpWrap (maybe False (const True)) + (\p -> if p then Just () else Nothing) $ + xpOption $ xpAttribute_ "ask" "subscribe") + (xpAttribute "jid" xpPrim) + (xpAttribute' "name" xpText) + (xpAttribute' "subscription" xpPrim) + ) + (xpFindMatches $ xpElemText "{jabber:iq:roster}group") + +xpQuery :: PU [Node] Query +xpQuery = xpWrap (\(ver_, items_) -> Query ver_ items_ ) + (\(Query ver_ items_) -> (ver_, items_)) $ + xpElem "{jabber:iq:roster}query" + (xpAttribute' "ver" xpText) + xpItems From c776cb6305b7988d21b13acb27c1b914c8cf9f92 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 19 Mar 2013 19:28:58 +0100 Subject: [PATCH 03/26] Make Network.Xmpp.Types warning-clean --- source/Network/Xmpp/Types.hs | 41 +++++++++++------------------------- 1 file changed, 12 insertions(+), 29 deletions(-) diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index e3f8340..19c9f0e 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -53,45 +53,29 @@ module Network.Xmpp.Types ) where +import Control.Applicative ((<$>), (<|>), many) import Control.Concurrent.STM import Control.Exception import Control.Monad.Error -import Control.Monad.IO.Class -import Control.Monad.State.Strict - import qualified Data.Attoparsec.Text as AP import qualified Data.ByteString as BS import Data.Conduit -import Data.IORef -import Data.Maybe (fromJust, fromMaybe, maybeToList) -import Data.String(IsString(..)) +import Data.Default +import Data.Maybe (fromJust, maybeToList) +import qualified Data.Set as Set +import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as Text import Data.Typeable(Typeable) import Data.XML.Types - +import Network +import Network.DNS +import Network.Socket import Network.TLS hiding (Version) import Network.TLS.Extra - -import qualified Network as N - -import System.IO - -import Control.Applicative ((<$>), (<|>), many) -import Control.Monad(guard) - -import qualified Data.Set as Set -import Data.String (IsString(..)) import qualified Text.NamePrep as SP import qualified Text.StringPrep as SP -import Network -import Network.DNS -import Network.Socket - -import Data.Default -import Data.IP - -- | -- Wraps a string of random characters that, when using an appropriate -- @IdGenerator@, is guaranteed to be unique for the Xmpp session. @@ -777,8 +761,7 @@ langTagParser = do subtag :: AP.Parser Text.Text subtag = do AP.skip (== '-') - subtag <- tag - return subtag + tag tagChars :: [Char] tagChars = ['a'..'z'] ++ ['A'..'Z'] @@ -875,7 +858,7 @@ data Jid = Jid { -- | The @localpart@ of a JID is an optional identifier placed -- the entity associated with an XMPP localpart at a domain -- (i.e., @localpart\@domainpart/resourcepart@). , resourcepart :: !(Maybe Text) - } deriving Eq + } deriving (Eq, Ord) instance Show Jid where show (Jid nd dmn res) = @@ -958,9 +941,9 @@ jidParts = do -- Case 2: We found a '/'; the JID is in the form -- domainpart/resourcepart. <|> do - b <- resourcePartP + b' <- resourcePartP AP.endOfInput - return (Nothing, a, Just b) + return (Nothing, a, Just b') -- Case 3: We have reached EOF; we have an JID consisting of only a -- domainpart. <|> do From 97bd16b6df1dbdb5796f527e6b831bcc94e02321 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 20 Mar 2013 13:51:00 +0100 Subject: [PATCH 04/26] fix stanza ID generator --- source/Network/Xmpp/Concurrent.hs | 3 ++- source/Network/Xmpp/Types.hs | 6 +++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index c40090f..9ff6ccc 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -113,12 +113,13 @@ newSession stream config = runErrorT $ do ] (kill, wLock, streamState, readerThread) <- ErrorT $ startThreadsWith stanzaHandler eh stream writer <- lift $ forkIO $ writeWorker outC wLock + idGen <- liftIO $ sessionStanzaIDs config return $ Session { stanzaCh = stanzaChan , outCh = outC , iqHandlers = iqHandlers , writeRef = wLock , readerThread = readerThread - , idGenerator = sessionStanzaIDs config + , idGenerator = idGen , streamRef = streamState , eventHandlers = eh , stopThreads = kill >> killThread writer diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 19c9f0e..5ad805d 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -1100,7 +1100,7 @@ data SessionConfiguration = SessionConfiguration -- | Handler to be run when the session ends (for whatever reason). , sessionClosedHandler :: XmppFailure -> IO () -- | Function to generate the stream of stanza identifiers. - , sessionStanzaIDs :: IO StanzaID + , sessionStanzaIDs :: IO (IO StanzaID) , extraStanzaHandlers :: [StanzaHandler] } @@ -1109,10 +1109,10 @@ instance Default SessionConfiguration where , sessionClosedHandler = \_ -> return () , sessionStanzaIDs = do idRef <- newTVarIO 1 - atomically $ do + return . atomically $ do curId <- readTVar idRef writeTVar idRef (curId + 1 :: Integer) - return . read. show $ curId + return . StanzaID . Text.pack . show $ curId , extraStanzaHandlers = [] } From 6668d4d12e9009e68f12ebe304e6e9652c9ce830 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Wed, 20 Mar 2013 13:56:07 +0100 Subject: [PATCH 05/26] Add minor tutorial change --- README.md | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index bfdbafd..90516b5 100644 --- a/README.md +++ b/README.md @@ -14,7 +14,11 @@ page](http://hackage.haskell.org/package/pontarius-xmpp/). _Note:_ Pontarius XMPP is still in its Alpha phase. Pontarius XMPP is not yet feature-complete, it may contain bugs, and its API may change between versions. -The first thing to do is to import the modules that we are going to use. +The first thing to do is to import the modules that we are going to use. We are +also using the OverloadedStrings LANGUAGE pragma in order to be able to type +Text values like strings. + + {-# LANGUAGE OverloadedStrings #-} import Network.Xmpp @@ -35,9 +39,6 @@ When this is done, a Session object can be acquired by calling def (Just ([scramSha1 "username" Nothing "password"], Nothing)) -_Tip:_ Note that the first parameter actually is a Text value. Import -Data.Text and use the OverloadedStrings LANGUAGE pragma. - The three parameters above are the XMPP server realm, the session configuration settings (set to the default settings), and a SASL handler (for authentication). session will perform the necessary DNS queries to find the address From 93bfcc561dbf226b076129e6b492eede49a3457e Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Wed, 20 Mar 2013 13:57:21 +0100 Subject: [PATCH 06/26] Version bump --- pontarius-xmpp.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index d86a53e..259d41b 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -1,5 +1,5 @@ Name: pontarius-xmpp -Version: 0.2.0.0 +Version: 0.2.0.1 Cabal-Version: >= 1.6 Build-Type: Simple License: OtherLicense @@ -11,7 +11,7 @@ Maintainer: info@jonkri.com Stability: alpha Homepage: https://github.com/jonkri/pontarius-xmpp/ Bug-Reports: mailto:info@jonkri.com -Package-URL: http://www.jonkri.com/releases/pontarius-xmpp-0.2.0.0.tar.gz +Package-URL: http://www.jonkri.com/releases/pontarius-xmpp-0.2.0.1.tar.gz Synopsis: An incomplete implementation of RFC 6120 (XMPP: Core) Description: Pontarius XMPP is a work in progress implementation of RFC 6120 (XMPP: Core). @@ -84,4 +84,4 @@ Source-Repository head Source-Repository this Type: git Location: git://github.com/jonkri/pontarius-xmpp.git - Tag: 0.2.0.0 + Tag: 0.2.0.1 From c4c0d029859d6bd3de2e6bcdef9da9d81b7264f8 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Wed, 20 Mar 2013 14:03:23 +0100 Subject: [PATCH 07/26] Add Extra-Source-Files entry --- pontarius-xmpp.cabal | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 259d41b..0c830c4 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -18,6 +18,13 @@ Description: Pontarius XMPP is a work in progress implementation of Category: Network Tested-With: GHC ==7.0.4, GHC ==7.4.1 +Extra-Source-Files: README.md + , examples/echoclient/echoclient.cabal + , examples/echoclient/LICENSE.md + , examples/echoclient/Main.hs + , examples/echoclient/README.md + , examples/echoclient/Setup.hs + Library hs-source-dirs: source Exposed: True From 477dbc14c7da04c5aa5048c326ff0f4886fa8bab Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 20 Mar 2013 15:45:49 +0100 Subject: [PATCH 08/26] elaborate connectionDetails add ConnectionDetails type remove Hostname type rename hostname to checkHostname --- source/Network/Xmpp.hs | 1 + source/Network/Xmpp/Stream.hs | 88 +++++++++++++++++------------------ source/Network/Xmpp/Types.hs | 32 +++++-------- 3 files changed, 56 insertions(+), 65 deletions(-) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 585039e..82e02ac 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -29,6 +29,7 @@ module Network.Xmpp , session , StreamConfiguration(..) , SessionConfiguration(..) + , ConnectionDetails(..) -- TODO: Close session, etc. -- ** Authentication handlers -- | The use of 'scramSha1' is /recommended/, but 'digestMd5' might be diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 86bc227..9077d5b 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -19,9 +19,10 @@ import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.State.Strict import Control.Monad.Trans.Class +import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Base64 -import Data.ByteString.Char8 as BSC8 +import qualified Data.ByteString.Char8 as BSC8 import Data.Conduit import Data.Conduit.Binary as CB import qualified Data.Conduit.Internal as DCI @@ -483,60 +484,50 @@ createStream realm config = do -- attempt has been made. Will return the Handle acquired, if any. connect :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (Maybe Handle) connect realm config = do - case socketDetails config of - -- Just (_, NS.SockAddrUnix _) -> do - -- lift $ errorM "Pontarius.Xmpp" "SockAddrUnix address provided." - -- throwError XmppIllegalTcpDetails - Just socketDetails' -> lift $ do - debugM "Pontarius.Xmpp" "Connecting to configured SockAddr address..." - connectTcp $ Left socketDetails' - Nothing -> do - case (readMaybe_ realm :: Maybe IPv6, readMaybe_ realm :: Maybe IPv4, hostname (Text.pack realm) :: Maybe Hostname) of - (Just ipv6, Nothing, _) -> lift $ connectTcp $ Right [(show ipv6, 5222)] - (Nothing, Just ipv4, _) -> lift $ connectTcp $ Right [(show ipv4, 5222)] - (Nothing, Nothing, Just (Hostname realm')) -> do - resolvSeed <- lift $ makeResolvSeed (resolvConf config) - lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..." - srvRecords <- srvLookup realm' resolvSeed - case srvRecords of - -- No SRV records. Try fallback lookup. - Nothing -> do - lift $ debugM "Pontarius.Xmpp" "No SRV records, using fallback process..." - lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ realm) 5222 - Just srvRecords' -> do - lift $ debugM "Pontarius.Xmpp" "SRV records found, performing A/AAAA lookups..." - lift $ resolvSrvsAndConnectTcp resolvSeed srvRecords' - (Nothing, Nothing, Nothing) -> do - lift $ errorM "Pontarius.Xmpp" "The hostname could not be validated." + case connectionDetails config of + UseHost host port -> lift $ do + debugM "Pontarius.Xmpp" "Connecting to configured address." + connectTcp $ [(host, port)] + UseSrv host -> connectSrv host + UseRealm -> connectSrv realm + where + connectSrv realm = do + case checkHostName (Text.pack realm) of + Just realm' -> do + resolvSeed <- lift $ makeResolvSeed (resolvConf config) + lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..." + srvRecords <- srvLookup realm' resolvSeed + case srvRecords of + Nothing -> do + lift $ debugM "Pontarius.Xmpp" + "No SRV records, using fallback process." + lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ realm) + 5222 + Just srvRecords' -> do + lift $ debugM "Pontarius.Xmpp" + "SRV records found, performing A/AAAA lookups." + lift $ resolvSrvsAndConnectTcp resolvSeed srvRecords' + Nothing -> do + lift $ errorM "Pontarius.Xmpp" + "The hostname could not be validated." throwError XmppIllegalTcpDetails -- Connects to a list of addresses and ports. Surpresses any exceptions from -- connectTcp. -connectTcp :: Either (NS.Socket, NS.SockAddr) [(HostName, Int)] -> IO (Maybe Handle) -connectTcp (Right []) = return Nothing -connectTcp (Right ((address, port):remainder)) = do +connectTcp :: [(HostName, PortID)] -> IO (Maybe Handle) +connectTcp [] = return Nothing +connectTcp ((address, port):remainder) = do result <- try $ (do - debugM "Pontarius.Xmpp" $ "Connecting to " ++ (address) ++ " on port " ++ + debugM "Pontarius.Xmpp" $ "Connecting to " ++ address ++ " on port " ++ (show port) ++ "." - connectTo address (PortNumber $ fromIntegral port)) :: IO (Either IOException Handle) + connectTo address port) :: IO (Either IOException Handle) case result of Right handle -> do debugM "Pontarius.Xmpp" "Successfully connected to HostName." return $ Just handle Left _ -> do debugM "Pontarius.Xmpp" "Connection to HostName could not be established." - connectTcp $ Right remainder -connectTcp (Left (sock, sockAddr)) = do - result <- try $ (do - NS.connect sock sockAddr - NS.socketToHandle sock ReadWriteMode) :: IO (Either IOException Handle) - case result of - Right handle -> do - debugM "Pontarius.Xmpp" "Successfully connected to SockAddr." - return $ Just handle - Left _ -> do - debugM "Pontarius.Xmpp" "Connection to SockAddr could not be established." - return Nothing + connectTcp remainder -- Makes an AAAA query to acquire a IPs, and tries to connect to all of them. If -- a handle can not be acquired this way, an analogous A query is performed. @@ -547,7 +538,10 @@ resolvAndConnectTcp resolvSeed domain port = do \resolver -> lookupAAAA resolver domain) :: IO (Either IOException (Maybe [IPv6])) handle <- case aaaaResults of Right Nothing -> return Nothing - Right (Just ipv6s) -> connectTcp $ Right $ Data.List.map (\ipv6 -> (show ipv6, port)) ipv6s + Right (Just ipv6s) -> connectTcp $ + map (\ipv6 -> ( show ipv6 + , PortNumber $ fromIntegral port)) + ipv6s Left e -> return Nothing case handle of Nothing -> do @@ -555,7 +549,11 @@ resolvAndConnectTcp resolvSeed domain port = do \resolver -> lookupA resolver domain) :: IO (Either IOException (Maybe [IPv4])) handle' <- case aResults of Right Nothing -> return Nothing - Right (Just ipv4s) -> connectTcp $ Right $ Data.List.map (\ipv4 -> (show ipv4, port)) ipv4s + Right (Just ipv4s) -> connectTcp $ + map (\ipv4 -> (show ipv4 + , PortNumber + $ fromIntegral port)) + ipv4s case handle' of Nothing -> return Nothing Just handle'' -> return $ Just handle'' diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 5ad805d..bab4d33 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -37,6 +37,7 @@ module Network.Xmpp.Types , ConnectionState(..) , StreamErrorInfo(..) , StanzaHandler + , ConnectionDetails(..) , StreamConfiguration(..) , langTag , Jid(..) @@ -46,8 +47,7 @@ module Network.Xmpp.Types , jidFromTexts , StreamEnd(..) , InvalidXmppXml(..) - , Hostname(..) - , hostname + , checkHostName , SessionConfiguration(..) , TlsBehaviour(..) ) @@ -70,7 +70,6 @@ import Data.Typeable(Typeable) import Data.XML.Types import Network import Network.DNS -import Network.Socket import Network.TLS hiding (Version) import Network.TLS.Extra import qualified Text.NamePrep as SP @@ -1012,6 +1011,10 @@ data InvalidXmppXml = InvalidXmppXml String deriving (Show, Typeable) instance Exception InvalidXmppXml +data ConnectionDetails = UseRealm -- ^ Use realm to resolv host + | UseSrv HostName -- ^ Use this hostname for a SRC lookup + | UseHost HostName PortID -- ^ Use specified host + -- | Configuration settings related to the stream. data StreamConfiguration = StreamConfiguration { -- | Default language when no language tag is set @@ -1026,7 +1029,7 @@ data StreamConfiguration = -- of the realm, as well as specify the use of a -- non-standard port when connecting by IP or -- connecting to a domain without SRV records. - , socketDetails :: Maybe (Socket, SockAddr) + , connectionDetails :: ConnectionDetails -- | DNS resolver configuration , resolvConf :: ResolvConf -- | Whether or not to perform the legacy @@ -1039,11 +1042,10 @@ data StreamConfiguration = , tlsParams :: TLSParams } - instance Default StreamConfiguration where def = StreamConfiguration { preferredLang = Nothing , toJid = Nothing - , socketDetails = Nothing + , connectionDetails = UseRealm , resolvConf = defaultResolvConf , establishSession = True , tlsBehaviour = PreferTls @@ -1053,22 +1055,12 @@ instance Default StreamConfiguration where } } -data Hostname = Hostname Text deriving (Eq, Show) - -instance Read Hostname where - readsPrec _ x = case hostname (Text.pack x) of - Nothing -> [] - Just h -> [(h,"")] - -instance IsString Hostname where - fromString = fromJust . hostname . Text.pack - -- | Validates the hostname string in accordance with RFC 1123. -hostname :: Text -> Maybe Hostname -hostname t = do - eitherToMaybeHostname $ AP.parseOnly hostnameP t +checkHostName :: Text -> Maybe Text +checkHostName t = do + eitherToMaybeHostName $ AP.parseOnly hostnameP t where - eitherToMaybeHostname = either (const Nothing) (Just . Hostname) + eitherToMaybeHostName = either (const Nothing) Just -- Validation of RFC 1123 hostnames. hostnameP :: AP.Parser Text From 48f1e515fcfb0bbaea51d29f29495a0ab9ea97ef Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 20 Mar 2013 15:46:57 +0100 Subject: [PATCH 09/26] clear modules necessare for cabal install of warnings clear Network.Xmpp of warnings clear Network.XMpp.Tls of Warnings clear Network.Xmpp.Utilities of Warnings clear Network.Xmpp.Stream of warnings clear Network.Xmpp.Sasl of warnings clear Network.Xmpp.Concurrent of warnings clear Network.Xmpp.Concurrent.IQ of warnings clear Network.Xmpp.Concurrent.Message of warnings clear Network.Xmpp.Concurrent.Monad of warnings clear Network.Xmpp.Concurrent.Presence of Warnings clear Network.Xmpp.Concurrent.Threads of warnings clear Network.Xmpp.Concurrent.Types of warnings clear Network.Xmpp.IM.Presence of warnings clear Network.Xmpp.Sasl.Common of warnings clear Network.Xmpp.Sasl.StringPrep of warnings clear Network.Xmpp.Sasl.Mechanisms.DIgestMd5 of warnings clear Network.Xmpp.Sasl.Mechanisms.Plain of warnings clear Network.Xmpp.Sasl.Mechanisms.Scram of warnings clear Network.Xmpp.Xep.DataForms of warnings clear Network.Xmpp.Internal of warnings --- source/Network/Xmpp.hs | 4 - source/Network/Xmpp/Concurrent.hs | 22 +- source/Network/Xmpp/Concurrent/IQ.hs | 8 +- source/Network/Xmpp/Concurrent/Message.hs | 2 - source/Network/Xmpp/Concurrent/Monad.hs | 8 +- source/Network/Xmpp/Concurrent/Presence.hs | 1 - source/Network/Xmpp/Concurrent/Threads.hs | 29 +-- source/Network/Xmpp/Concurrent/Types.hs | 10 +- source/Network/Xmpp/IM/Presence.hs | 1 - source/Network/Xmpp/Internal.hs | 5 +- source/Network/Xmpp/Sasl.hs | 96 +++------ source/Network/Xmpp/Sasl/Common.hs | 32 ++- .../Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs | 48 ++--- source/Network/Xmpp/Sasl/Mechanisms/Plain.hs | 53 ++--- source/Network/Xmpp/Sasl/Mechanisms/Scram.hs | 64 +++--- source/Network/Xmpp/Sasl/StringPrep.hs | 11 +- source/Network/Xmpp/Stream.hs | 204 +++++++++--------- source/Network/Xmpp/Tls.hs | 45 ++-- source/Network/Xmpp/Utilities.hs | 80 ++----- source/Network/Xmpp/Xep/DataForms.hs | 23 +- 20 files changed, 290 insertions(+), 456 deletions(-) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 82e02ac..cfb2c14 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -138,8 +138,6 @@ module Network.Xmpp , sendIQ' , answerIQ , listenIQChan - , iqRequestPayload - , iqResultPayload -- * Errors , StanzaError(..) , StanzaErrorType(..) @@ -157,10 +155,8 @@ module Network.Xmpp , AuthOtherFailure ) ) where -import Network import Network.Xmpp.Concurrent import Network.Xmpp.Utilities import Network.Xmpp.Sasl import Network.Xmpp.Sasl.Types -import Network.Xmpp.Tls import Network.Xmpp.Types diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 9ff6ccc..772ca34 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -18,36 +18,28 @@ import Control.Applicative((<$>),(<*>)) import Control.Concurrent import Control.Concurrent.STM import Control.Monad +import Control.Monad.Error import qualified Data.ByteString as BS -import Data.IORef import qualified Data.Map as Map import Data.Maybe -import Data.Maybe (fromMaybe) import Data.Text as Text import Data.XML.Types import Network -import qualified Network.TLS as TLS import Network.Xmpp.Concurrent.Basic import Network.Xmpp.Concurrent.IQ import Network.Xmpp.Concurrent.Message import Network.Xmpp.Concurrent.Monad import Network.Xmpp.Concurrent.Presence import Network.Xmpp.Concurrent.Threads -import Network.Xmpp.Concurrent.Threads import Network.Xmpp.Concurrent.Types import Network.Xmpp.Marshal import Network.Xmpp.Sasl -import Network.Xmpp.Sasl.Mechanisms import Network.Xmpp.Sasl.Types import Network.Xmpp.Stream import Network.Xmpp.Tls import Network.Xmpp.Types import Network.Xmpp.Utilities -import Control.Monad.Error -import Data.Default -import System.Log.Logger -import Control.Monad.State.Strict runHandlers :: (TChan Stanza) -> [StanzaHandler] -> Stanza -> IO () runHandlers _ [] _ = return () @@ -96,7 +88,7 @@ handleIQ iqHands outC sta = atomically $ do _ <- tryPutTMVar tmvar answer -- Don't block. writeTVar handlers (byNS, byID') where - iqID (Left err) = iqErrorID err + iqID (Left err') = iqErrorID err' iqID (Right iq') = iqResultID iq' -- | Creates and initializes a new Xmpp context. @@ -104,21 +96,21 @@ newSession :: Stream -> SessionConfiguration -> IO (Either XmppFailure Session) newSession stream config = runErrorT $ do outC <- lift newTChanIO stanzaChan <- lift newTChanIO - iqHandlers <- lift $ newTVarIO (Map.empty, Map.empty) + iqHands <- lift $ newTVarIO (Map.empty, Map.empty) eh <- lift $ newTVarIO $ EventHandlers { connectionClosedHandler = sessionClosedHandler config } let stanzaHandler = runHandlers outC $ Prelude.concat [ [toChan stanzaChan] , extraStanzaHandlers config - , [handleIQ iqHandlers] + , [handleIQ iqHands] ] - (kill, wLock, streamState, readerThread) <- ErrorT $ startThreadsWith stanzaHandler eh stream + (kill, wLock, streamState, reader) <- ErrorT $ startThreadsWith stanzaHandler eh stream writer <- lift $ forkIO $ writeWorker outC wLock idGen <- liftIO $ sessionStanzaIDs config return $ Session { stanzaCh = stanzaChan , outCh = outC - , iqHandlers = iqHandlers + , iqHandlers = iqHands , writeRef = wLock - , readerThread = readerThread + , readerThread = reader , idGenerator = idGen , streamRef = streamState , eventHandlers = eh diff --git a/source/Network/Xmpp/Concurrent/IQ.hs b/source/Network/Xmpp/Concurrent/IQ.hs index bd79061..d41e8cf 100644 --- a/source/Network/Xmpp/Concurrent/IQ.hs +++ b/source/Network/Xmpp/Concurrent/IQ.hs @@ -4,8 +4,6 @@ module Network.Xmpp.Concurrent.IQ where import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.STM import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Reader import qualified Data.Map as Map import Data.Text (Text) @@ -90,17 +88,17 @@ answerIQ :: IQRequestTicket -> Session -> IO Bool answerIQ (IQRequestTicket - sentRef + sRef (IQRequest iqid from _to lang _tp bd)) answer session = do let response = case answer of Left err -> IQErrorS $ IQError iqid Nothing from lang err (Just bd) Right res -> IQResultS $ IQResult iqid Nothing from lang res atomically $ do - sent <- readTVar sentRef + sent <- readTVar sRef case sent of False -> do - writeTVar sentRef True + writeTVar sRef True writeTChan (outCh session) response return True diff --git a/source/Network/Xmpp/Concurrent/Message.hs b/source/Network/Xmpp/Concurrent/Message.hs index 543303c..234484c 100644 --- a/source/Network/Xmpp/Concurrent/Message.hs +++ b/source/Network/Xmpp/Concurrent/Message.hs @@ -3,9 +3,7 @@ module Network.Xmpp.Concurrent.Message where import Network.Xmpp.Concurrent.Types import Control.Concurrent.STM -import Data.IORef import Network.Xmpp.Types -import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Basic -- | Read an element from the inbound stanza channel, discardes any diff --git a/source/Network/Xmpp/Concurrent/Monad.hs b/source/Network/Xmpp/Concurrent/Monad.hs index 5a1d627..9a61745 100644 --- a/source/Network/Xmpp/Concurrent/Monad.hs +++ b/source/Network/Xmpp/Concurrent/Monad.hs @@ -60,15 +60,15 @@ import Network.Xmpp.Stream -- | Executes a function to update the event handlers. modifyHandlers :: (EventHandlers -> EventHandlers) -> Session -> IO () -modifyHandlers f session = atomically $ modifyTVar (eventHandlers session) f +modifyHandlers f session = atomically $ modifyTVar_ (eventHandlers session) f where -- Borrowing modifyTVar from -- http://hackage.haskell.org/packages/archive/stm/2.4/doc/html/src/Control-Concurrent-STM-TVar.html -- as it's not available in GHC 7.0. - modifyTVar :: TVar a -> (a -> a) -> STM () - modifyTVar var f = do + modifyTVar_ :: TVar a -> (a -> a) -> STM () + modifyTVar_ var g = do x <- readTVar var - writeTVar var (f x) + writeTVar var (g x) -- | Sets the handler to be executed when the server connection is closed. setConnectionClosedHandler_ :: (XmppFailure -> Session -> IO ()) -> Session -> IO () diff --git a/source/Network/Xmpp/Concurrent/Presence.hs b/source/Network/Xmpp/Concurrent/Presence.hs index d9cfc6e..cb6a502 100644 --- a/source/Network/Xmpp/Concurrent/Presence.hs +++ b/source/Network/Xmpp/Concurrent/Presence.hs @@ -2,7 +2,6 @@ module Network.Xmpp.Concurrent.Presence where import Control.Concurrent.STM -import Data.IORef import Network.Xmpp.Types import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Basic diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs index f1ce15d..5c0b03b 100644 --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -4,25 +4,18 @@ module Network.Xmpp.Concurrent.Threads where -import Network.Xmpp.Types - import Control.Applicative((<$>)) import Control.Concurrent import Control.Concurrent.STM import qualified Control.Exception.Lifted as Ex import Control.Monad -import Control.Monad.IO.Class +import Control.Monad.Error import Control.Monad.State.Strict - import qualified Data.ByteString as BS +import GHC.IO (unsafeUnmask) import Network.Xmpp.Concurrent.Types import Network.Xmpp.Stream - -import Control.Concurrent.STM.TMVar - -import GHC.IO (unsafeUnmask) - -import Control.Monad.Error +import Network.Xmpp.Types import System.Log.Logger -- Worker to read stanzas from the stream and concurrently distribute them to @@ -38,8 +31,8 @@ readWorker onStanza onConnectionClosed stateRef = -- necessarily be interruptible s <- atomically $ do s@(Stream con) <- readTMVar stateRef - state <- streamConnectionState <$> readTMVar con - when (state == Closed) + scs <- streamConnectionState <$> readTMVar con + when (scs == Closed) retry return s allowInterrupt @@ -55,7 +48,7 @@ readWorker onStanza onConnectionClosed stateRef = ] case res of Nothing -> return () -- Caught an exception, nothing to do. TODO: Can this happen? - Just (Left e) -> return () + Just (Left _) -> return () Just (Right sta) -> onStanza sta where -- Defining an Control.Exception.allowInterrupt equivalent for GHC 7 @@ -85,19 +78,19 @@ startThreadsWith :: (Stanza -> IO ()) TMVar Stream, ThreadId)) startThreadsWith stanzaHandler eh con = do - read <- withStream' (gets $ streamSend . streamHandle >>= \d -> return $ Right d) con - case read of + rd <- withStream' (gets $ streamSend . streamHandle >>= \d -> return $ Right d) con + case rd of Left e -> return $ Left e Right read' -> do writeLock <- newTMVarIO read' conS <- newTMVarIO con -- lw <- forkIO $ writeWorker outC writeLock cp <- forkIO $ connPersist writeLock - rd <- forkIO $ readWorker stanzaHandler (noCon eh) conS - return $ Right ( killConnection writeLock [rd, cp] + rdw <- forkIO $ readWorker stanzaHandler (noCon eh) conS + return $ Right ( killConnection writeLock [rdw, cp] , writeLock , conS - , rd + , rdw ) where killConnection writeLock threads = liftIO $ do diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index 008d853..4a4b2e5 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -3,19 +3,13 @@ module Network.Xmpp.Concurrent.Types where -import qualified Control.Exception.Lifted as Ex import Control.Concurrent import Control.Concurrent.STM - +import qualified Control.Exception.Lifted as Ex import qualified Data.ByteString as BS -import Data.Typeable - -import Network.Xmpp.Types - -import Data.IORef import qualified Data.Map as Map import Data.Text (Text) - +import Data.Typeable import Network.Xmpp.Types -- | Handlers to be run when the Xmpp session ends and when the Xmpp connection is diff --git a/source/Network/Xmpp/IM/Presence.hs b/source/Network/Xmpp/IM/Presence.hs index 512da70..773c04d 100644 --- a/source/Network/Xmpp/IM/Presence.hs +++ b/source/Network/Xmpp/IM/Presence.hs @@ -2,7 +2,6 @@ module Network.Xmpp.IM.Presence where -import Data.Text(Text) import Network.Xmpp.Types -- | An empty presence. diff --git a/source/Network/Xmpp/Internal.hs b/source/Network/Xmpp/Internal.hs index 60f7fbc..c06d06e 100644 --- a/source/Network/Xmpp/Internal.hs +++ b/source/Network/Xmpp/Internal.hs @@ -29,7 +29,7 @@ module Network.Xmpp.Internal , pushStanza , pullStanza , pushIQ - , SaslHandler(..) + , SaslHandler , StanzaID(..) ) @@ -37,9 +37,6 @@ module Network.Xmpp.Internal import Network.Xmpp.Stream import Network.Xmpp.Sasl -import Network.Xmpp.Sasl.Common import Network.Xmpp.Sasl.Types import Network.Xmpp.Tls import Network.Xmpp.Types -import Network.Xmpp.Stream -import Network.Xmpp.Marshal diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index cab4c6d..d445cb9 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -1,6 +1,6 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} - +-- -- Submodule for functionality related to SASL negotation: -- authentication functions, SASL functionality, bind functionality, -- and the legacy `{urn:ietf:params:xml:ns:xmpp-session}session' @@ -14,51 +14,17 @@ module Network.Xmpp.Sasl , auth ) where -import Control.Applicative -import Control.Arrow (left) -import Control.Monad import Control.Monad.Error import Control.Monad.State.Strict -import Data.Maybe (fromJust, isJust) - -import qualified Crypto.Classes as CC - -import qualified Data.Binary as Binary -import qualified Data.ByteString.Base64 as B64 -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 qualified Data.Text as Text import Data.Text (Text) -import qualified Data.Text.Encoding as Text - -import Network.Xmpp.Stream -import Network.Xmpp.Types - -import System.Log.Logger (debugM, errorM) -import qualified System.Random as Random - -import Network.Xmpp.Sasl.Types -import Network.Xmpp.Sasl.Mechanisms - -import Control.Concurrent.STM.TMVar - -import Control.Exception - import Data.XML.Pickle import Data.XML.Types - -import Network.Xmpp.Types import Network.Xmpp.Marshal - -import Control.Monad.State(modify) - -import Control.Concurrent.STM.TMVar - -import Control.Monad.Error +import Network.Xmpp.Sasl.Mechanisms +import Network.Xmpp.Sasl.Types +import Network.Xmpp.Stream +import Network.Xmpp.Types +import System.Log.Logger (debugM, errorM, infoM) -- | Uses the first supported mechanism to authenticate, if any. Updates the -- state with non-password credentials and restarts the stream upon @@ -105,16 +71,18 @@ auth :: [SaslHandler] -> Stream -> IO (Either XmppFailure (Maybe AuthFailure)) auth mechanisms resource con = runErrorT $ do - ErrorT $ xmppSasl mechanisms con - jid <- ErrorT $ xmppBind resource con - ErrorT $ flip withStream con $ do - s <- get - case establishSession $ streamConfiguration s of - False -> return $ Right Nothing - True -> do - _ <- lift $ startSession con - return $ Right Nothing - return Nothing + mbAuthFail <- ErrorT $ xmppSasl mechanisms con + case mbAuthFail of + Nothing -> do + _jid <- ErrorT $ xmppBind resource con + ErrorT $ flip withStream con $ do + s <- get + case establishSession $ streamConfiguration s of + False -> return $ Right Nothing + True -> do + _ <-liftIO $ startSession con + return $ Right Nothing + f -> return f -- Produces a `bind' element, optionally wrapping a resource. bindBody :: Maybe Text -> Element @@ -137,16 +105,19 @@ xmppBind rsrc c = runErrorT $ do let jid = unpickleElem xpJid b case jid of Right jid' -> do - lift $ debugM "Pontarius.XMPP" $ "xmppBind: JID unpickled: " ++ show jid' - ErrorT $ withStream (do - modify $ \s -> s{streamJid = Just jid'} - return $ Right jid') c -- not pretty + lift $ infoM "Pontarius.XMPP" $ "Bound JID: " ++ show jid' + _ <- lift $ withStream ( do + modify $ \s -> + s{streamJid = Just jid'} + return $ Right ()) + c return jid' - otherwise -> do - lift $ errorM "Pontarius.XMPP" $ "xmppBind: JID could not be unpickled from: " - ++ show b + _ -> do + lift $ errorM "Pontarius.XMPP" + $ "xmppBind: JID could not be unpickled from: " + ++ show b throwError $ XmppOtherFailure - otherwise -> do + _ -> do lift $ errorM "Pontarius.XMPP" "xmppBind: IQ error received." throwError XmppOtherFailure where @@ -164,15 +135,6 @@ sessionXml = pickleElem (xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session") () -sessionIQ :: Stanza -sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" - , iqRequestFrom = Nothing - , iqRequestTo = Nothing - , iqRequestLangTag = Nothing - , iqRequestType = Set - , iqRequestPayload = sessionXml - } - -- Sends the session IQ set element and waits for an answer. Throws an error if -- if an IQ error stanza is returned from the server. startSession :: Stream -> IO Bool diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index 3a5382c..47f8744 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -4,28 +4,23 @@ module Network.Xmpp.Sasl.Common where -import Network.Xmpp.Types - import Control.Applicative ((<$>)) import Control.Monad.Error -import Control.Monad.State.Class - import qualified Data.Attoparsec.ByteString.Char8 as AP import Data.Bits import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64 -import Data.Maybe (fromMaybe) import Data.Maybe (maybeToList) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Word (Word8) import Data.XML.Pickle import Data.XML.Types - -import Network.Xmpp.Stream +import Network.Xmpp.Marshal import Network.Xmpp.Sasl.StringPrep import Network.Xmpp.Sasl.Types -import Network.Xmpp.Marshal +import Network.Xmpp.Stream +import Network.Xmpp.Types import qualified System.Random as Random @@ -66,9 +61,9 @@ pairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do AP.skipSpace name <- AP.takeWhile1 (/= '=') _ <- AP.char '=' - quote <- ((AP.char '"' >> return True) `mplus` return False) + qt <- ((AP.char '"' >> return True) `mplus` return False) content <- AP.takeWhile1 (AP.notInClass [',', '"']) - when quote . void $ AP.char '"' + when qt . void $ AP.char '"' return (name, content) -- Failure element pickler. @@ -108,19 +103,20 @@ xpSaslElement = xpAlt saslSel quote :: BS.ByteString -> BS.ByteString quote x = BS.concat ["\"",x,"\""] -saslInit :: Text.Text -> Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) Bool +saslInit :: Text.Text -> Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) () saslInit mechanism payload = do r <- lift . pushElement . saslInitE mechanism $ Text.decodeUtf8 . B64.encode <$> payload case r of - Left e -> throwError $ AuthStreamFailure e - Right b -> return b + Right True -> return () + Right False -> throwError $ AuthStreamFailure XmppNoStream + Left e -> throwError $ AuthStreamFailure e -- | Pull the next element. pullSaslElement :: ErrorT AuthFailure (StateT StreamState IO) SaslElement pullSaslElement = do - r <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement) - case r of + mbse <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement) + case mbse of Left e -> throwError $ AuthStreamFailure e Right (Left e) -> throwError $ AuthSaslFailure e Right (Right r) -> return r @@ -173,13 +169,13 @@ toPairs ctext = case pairs ctext of Right r -> return r -- | Send a SASL response element. The content will be base64-encoded. -respond :: Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) Bool +respond :: Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) () respond m = do r <- lift . pushElement . saslResponseE . fmap (Text.decodeUtf8 . B64.encode) $ m case r of Left e -> throwError $ AuthStreamFailure e - Right b -> return b - + Right False -> throwError $ AuthStreamFailure XmppNoStream + Right True -> return () -- | Run the appropriate stringprep profiles on the credentials. -- May fail with 'AuthStringPrepFailure' diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs index 7e7aca4..36e87eb 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs @@ -5,37 +5,21 @@ module Network.Xmpp.Sasl.Mechanisms.DigestMd5 ( digestMd5 ) where -import Control.Applicative -import Control.Arrow (left) -import Control.Monad import Control.Monad.Error import Control.Monad.State.Strict -import Data.Maybe (fromJust, isJust) - import qualified Crypto.Classes as CC - import qualified Data.Binary as Binary +import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BL import qualified Data.Digest.Pure.MD5 as MD5 import qualified Data.List as L - -import qualified Data.Text as Text import Data.Text (Text) import qualified Data.Text.Encoding as Text - -import Data.XML.Pickle - -import qualified Data.ByteString as BS - -import Data.XML.Types - -import Network.Xmpp.Stream -import Network.Xmpp.Types import Network.Xmpp.Sasl.Common -import Network.Xmpp.Sasl.StringPrep import Network.Xmpp.Sasl.Types +import Network.Xmpp.Types @@ -43,19 +27,19 @@ xmppDigestMd5 :: Text -- ^ Authentication identity (authzid or username) -> Maybe Text -- ^ Authorization identity (authcid) -> Text -- ^ Password (authzid) -> ErrorT AuthFailure (StateT StreamState IO) () -xmppDigestMd5 authcid authzid password = do - (ac, az, pw) <- prepCredentials authcid authzid password +xmppDigestMd5 authcid' authzid' password' = do + (ac, az, pw) <- prepCredentials authcid' authzid' password' Just address <- gets streamAddress xmppDigestMd5' address ac az pw where xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> ErrorT AuthFailure (StateT StreamState IO) () - xmppDigestMd5' hostname authcid authzid password = do + xmppDigestMd5' hostname authcid _authzid password = do -- TODO: use authzid? -- Push element and receive the challenge. _ <- saslInit "DIGEST-MD5" Nothing -- TODO: Check boolean? - pairs <- toPairs =<< saslFromJust =<< pullChallenge + prs <- toPairs =<< saslFromJust =<< pullChallenge cnonce <- liftIO $ makeNonce - _b <- respond . Just $ createResponse hostname pairs cnonce - challenge2 <- pullFinalMessage + _b <- respond . Just $ createResponse hostname prs cnonce + _challenge2 <- pullFinalMessage return () where -- Produce the response to the challenge. @@ -63,19 +47,19 @@ xmppDigestMd5 authcid authzid password = do -> Pairs -> BS.ByteString -- nonce -> BS.ByteString - createResponse hostname pairs cnonce = let - Just qop = L.lookup "qop" pairs -- TODO: proper handling - Just nonce = L.lookup "nonce" pairs + createResponse hname prs cnonce = let + Just qop = L.lookup "qop" prs -- TODO: proper handling + Just nonce = L.lookup "nonce" prs uname_ = Text.encodeUtf8 authcid passwd_ = Text.encodeUtf8 password -- Using Int instead of Word8 for random 1.0.0.0 (GHC 7) -- compatibility. nc = "00000001" - digestURI = "xmpp/" `BS.append` Text.encodeUtf8 hostname + digestURI = "xmpp/" `BS.append` Text.encodeUtf8 hname digest = md5Digest uname_ - (lookup "realm" pairs) + (lookup "realm" prs) passwd_ digestURI nc @@ -84,7 +68,7 @@ xmppDigestMd5 authcid authzid password = do cnonce response = BS.intercalate "," . map (BS.intercalate "=") $ [["username", quote uname_]] ++ - case L.lookup "realm" pairs of + case L.lookup "realm" prs of Just realm -> [["realm" , quote realm ]] Nothing -> [] ++ [ ["nonce" , quote nonce ] @@ -115,8 +99,8 @@ xmppDigestMd5 authcid authzid password = do -> BS8.ByteString -> BS8.ByteString -> BS8.ByteString - md5Digest uname realm password digestURI nc qop nonce cnonce = - let ha1 = hash [ hashRaw [uname, maybe "" id realm, password] + md5Digest uname realm pwd digestURI nc qop nonce cnonce = + let ha1 = hash [ hashRaw [uname, maybe "" id realm, pwd] , nonce , cnonce ] diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs index fa35be7..0c32793 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs @@ -8,51 +8,22 @@ module Network.Xmpp.Sasl.Mechanisms.Plain ( plain ) where -import Control.Applicative -import Control.Arrow (left) -import Control.Monad import Control.Monad.Error import Control.Monad.State.Strict -import Data.Maybe (fromJust, isJust) - -import qualified Crypto.Classes as CC - -import qualified Data.Binary as Binary -import qualified Data.ByteString.Base64 as B64 -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 qualified Data.Text as Text -import Data.Text (Text) -import qualified Data.Text.Encoding as Text - -import Data.XML.Pickle - import qualified Data.ByteString as BS - -import Data.XML.Types - -import Network.Xmpp.Stream -import Network.Xmpp.Types - -import qualified System.Random as Random - -import Data.Maybe (fromMaybe) import qualified Data.Text as Text - +import qualified Data.Text.Encoding as Text import Network.Xmpp.Sasl.Common import Network.Xmpp.Sasl.Types +import Network.Xmpp.Types -- TODO: stringprep xmppPlain :: Text.Text -- ^ Password -> Maybe Text.Text -- ^ Authorization identity (authzid) -> Text.Text -- ^ Authentication identity (authcid) -> ErrorT AuthFailure (StateT StreamState IO) () -xmppPlain authcid authzid password = do - (ac, az, pw) <- prepCredentials authcid authzid password +xmppPlain authcid' authzid' password = do + (ac, az, pw) <- prepCredentials authcid' authzid' password _ <- saslInit "PLAIN" ( Just $ plainMessage ac az pw) _ <- pullSuccess return () @@ -63,15 +34,15 @@ xmppPlain authcid authzid password = do -> Maybe Text.Text -- Authentication identity (authcid) -> Text.Text -- Password -> BS.ByteString -- The PLAIN message - plainMessage authcid authzid passwd = BS.concat $ - [ authzid' - , "\NUL" - , Text.encodeUtf8 $ authcid - , "\NUL" - , Text.encodeUtf8 $ passwd - ] + plainMessage authcid _authzid passwd = BS.concat $ + [ authzid'' + , "\NUL" + , Text.encodeUtf8 $ authcid + , "\NUL" + , Text.encodeUtf8 $ passwd + ] where - authzid' = maybe "" Text.encodeUtf8 authzid + authzid'' = maybe "" Text.encodeUtf8 authzid' plain :: Text.Text -- ^ authentication ID (username) -> Maybe Text.Text -- ^ authorization ID diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs index 84535dc..c7b2572 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs @@ -8,32 +8,20 @@ module Network.Xmpp.Sasl.Mechanisms.Scram import Control.Applicative ((<$>)) import Control.Monad.Error -import Control.Monad.Trans (liftIO) +import Control.Monad.State.Strict import qualified Crypto.Classes as Crypto import qualified Crypto.HMAC as Crypto import qualified Crypto.Hash.SHA1 as Crypto -import Data.Binary(Binary,encode) import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 as BS8 (unpack) -import qualified Data.ByteString.Lazy as LBS import Data.List (foldl1', genericTake) - -import qualified Data.Binary.Builder as Build - -import Data.Maybe (maybeToList) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import Data.Word(Word8) - import Network.Xmpp.Sasl.Common -import Network.Xmpp.Sasl.StringPrep import Network.Xmpp.Sasl.Types import Network.Xmpp.Types - -import Control.Monad.State.Strict - -- | A nicer name for undefined, for use as a dummy token to determin -- the hash function to use hashToken :: (Crypto.Hash ctx hash) => hash @@ -50,18 +38,18 @@ scram :: (Crypto.Hash ctx hash) -> Maybe Text.Text -- ^ Authorization ID -> Text.Text -- ^ Password -> ErrorT AuthFailure (StateT StreamState IO) () -scram hashToken authcid authzid password = do +scram hToken authcid authzid password = do (ac, az, pw) <- prepCredentials authcid authzid password - scramhelper hashToken ac az pw + scramhelper ac az pw where - scramhelper hashToken authcid authzid' password = do + scramhelper authcid' authzid' pwd = do cnonce <- liftIO $ makeNonce - saslInit "SCRAM-SHA-1" (Just $ cFirstMessage cnonce) + _ <- saslInit "SCRAM-SHA-1" (Just $ cFirstMessage cnonce) sFirstMessage <- saslFromJust =<< pullChallenge - pairs <- toPairs sFirstMessage - (nonce, salt, ic) <- fromPairs pairs cnonce + prs <- toPairs sFirstMessage + (nonce, salt, ic) <- fromPairs prs cnonce let (cfm, v) = cFinalMessageAndVerifier nonce salt ic sFirstMessage cnonce - respond $ Just cfm + _ <- respond $ Just cfm finalPairs <- toPairs =<< saslFromJust =<< pullFinalMessage unless (lookup "v" finalPairs == Just v) $ throwError AuthOtherFailure -- TODO: Log return () @@ -71,27 +59,27 @@ scram hashToken authcid authzid password = do encode _hashtoken = Crypto.encode hash :: BS.ByteString -> BS.ByteString - hash str = encode hashToken $ Crypto.hash' str + hash str = encode hToken $ Crypto.hash' str hmac :: BS.ByteString -> BS.ByteString -> BS.ByteString - hmac key str = encode hashToken $ Crypto.hmac' (Crypto.MacKey key) str + hmac key str = encode hToken $ Crypto.hmac' (Crypto.MacKey key) str - authzid :: Maybe BS.ByteString - authzid = (\z -> "a=" +++ Text.encodeUtf8 z) <$> authzid' + authzid'' :: Maybe BS.ByteString + authzid'' = (\z -> "a=" +++ Text.encodeUtf8 z) <$> authzid' gs2CbindFlag :: BS.ByteString gs2CbindFlag = "n" -- we don't support channel binding yet gs2Header :: BS.ByteString gs2Header = merge $ [ gs2CbindFlag - , maybe "" id authzid + , maybe "" id authzid'' , "" ] - cbindData :: BS.ByteString - cbindData = "" -- we don't support channel binding yet + -- cbindData :: BS.ByteString + -- cbindData = "" -- we don't support channel binding yet cFirstMessageBare :: BS.ByteString -> BS.ByteString - cFirstMessageBare cnonce = merge [ "n=" +++ Text.encodeUtf8 authcid + cFirstMessageBare cnonce = merge [ "n=" +++ Text.encodeUtf8 authcid' , "r=" +++ cnonce] cFirstMessage :: BS.ByteString -> BS.ByteString cFirstMessage cnonce = gs2Header +++ cFirstMessageBare cnonce @@ -99,13 +87,13 @@ scram hashToken authcid authzid password = do fromPairs :: Pairs -> BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) (BS.ByteString, BS.ByteString, Integer) - fromPairs pairs cnonce | Just nonce <- lookup "r" pairs - , cnonce `BS.isPrefixOf` nonce - , Just salt' <- lookup "s" pairs - , Right salt <- B64.decode salt' - , Just ic <- lookup "i" pairs - , [(i,"")] <- reads $ BS8.unpack ic - = return (nonce, salt, i) + fromPairs prs cnonce | Just nonce <- lookup "r" prs + , cnonce `BS.isPrefixOf` nonce + , Just salt' <- lookup "s" prs + , Right salt <- B64.decode salt' + , Just ic <- lookup "i" prs + , [(i,"")] <- reads $ BS8.unpack ic + = return (nonce, salt, i) fromPairs _ _ = throwError $ AuthOtherFailure -- TODO: Log cFinalMessageAndVerifier :: BS.ByteString @@ -126,7 +114,7 @@ scram hashToken authcid authzid password = do , "r=" +++ nonce] saltedPassword :: BS.ByteString - saltedPassword = hi (Text.encodeUtf8 password) salt ic + saltedPassword = hi (Text.encodeUtf8 pwd) salt ic clientKey :: BS.ByteString clientKey = hmac saltedPassword "Client Key" @@ -154,9 +142,9 @@ scram hashToken authcid authzid password = do -- helper hi :: BS.ByteString -> BS.ByteString -> Integer -> BS.ByteString - hi str salt ic = foldl1' xorBS (genericTake ic us) + hi str slt ic' = foldl1' xorBS (genericTake ic' us) where - u1 = hmac str (salt +++ (BS.pack [0,0,0,1])) + u1 = hmac str (slt +++ (BS.pack [0,0,0,1])) us = iterate (hmac str) u1 scramSha1 :: Text.Text -- ^ username diff --git a/source/Network/Xmpp/Sasl/StringPrep.hs b/source/Network/Xmpp/Sasl/StringPrep.hs index cff48a6..81f5117 100644 --- a/source/Network/Xmpp/Sasl/StringPrep.hs +++ b/source/Network/Xmpp/Sasl/StringPrep.hs @@ -4,27 +4,34 @@ module Network.Xmpp.Sasl.StringPrep where import Text.StringPrep import qualified Data.Set as Set -import Data.Text(singleton) +import Data.Text(Text, singleton) +nonAsciiSpaces :: Set.Set Char nonAsciiSpaces = Set.fromList [ '\x00A0', '\x1680', '\x2000', '\x2001', '\x2002' , '\x2003', '\x2004', '\x2005', '\x2006', '\x2007' , '\x2008', '\x2009', '\x200A', '\x200B', '\x202F' , '\x205F', '\x3000' ] +toSpace :: Char -> Text toSpace x = if x `Set.member` nonAsciiSpaces then " " else singleton x +saslPrepQuery :: StringPrepProfile saslPrepQuery = Profile [b1, toSpace] True [c12, c21, c22, c3, c4, c5, c6, c7, c8, c9] True +saslPrepStore :: StringPrepProfile saslPrepStore = Profile [b1, toSpace] True [a1, c12, c21, c22, c3, c4, c5, c6, c7, c8, c9] True +normalizePassword :: Text -> Maybe Text normalizePassword = runStringPrep saslPrepStore -normalizeUsername = runStringPrep saslPrepQuery \ No newline at end of file + +normalizeUsername :: Text -> Maybe Text +normalizeUsername = runStringPrep saslPrepQuery diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 9077d5b..1ee3266 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -7,27 +7,26 @@ module Network.Xmpp.Stream where -import Control.Applicative ((<$>), (<*>)) +import Control.Applicative ((<$>)) import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.STM import qualified Control.Exception as Ex -import Control.Exception.Base import qualified Control.Exception.Lifted as ExL import Control.Monad import Control.Monad.Error -import Control.Monad.IO.Class -import Control.Monad.Reader import Control.Monad.State.Strict -import Control.Monad.Trans.Class +import Control.Monad.Trans.Resource as R import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import Data.ByteString.Base64 import qualified Data.ByteString.Char8 as BSC8 import Data.Conduit import Data.Conduit.Binary as CB import qualified Data.Conduit.Internal as DCI import qualified Data.Conduit.List as CL -import Data.Maybe (fromJust, isJust, isNothing) +import Data.IP +import Data.List +import Data.Maybe +import Data.Ord import Data.Text (Text) import qualified Data.Text as Text import Data.Void (Void) @@ -35,27 +34,18 @@ import Data.XML.Pickle import Data.XML.Types import qualified GHC.IO.Exception as GIE import Network +import Network.DNS hiding (encode, lookup) import Network.Xmpp.Marshal import Network.Xmpp.Types import System.IO import System.IO.Error (tryIOError) import System.Log.Logger +import System.Random (randomRIO) import Text.XML.Stream.Parse as XP import Text.XML.Unresolved(InvalidEventStream(..)) -import Control.Monad.Trans.Resource as R import Network.Xmpp.Utilities -import Network.DNS hiding (encode, lookup) - -import Data.Ord -import Data.Maybe -import Data.List -import Data.IP -import System.Random - -import qualified Network.Socket as NS - -- "readMaybe" definition, as readMaybe is not introduced in the `base' package -- until version 4.6. readMaybe_ :: (Read a) => String -> Maybe a @@ -73,6 +63,17 @@ lmb :: [t] -> Maybe [t] lmb [] = Nothing lmb x = Just x +pushing :: MonadIO m => + m (Either XmppFailure Bool) + -> ErrorT XmppFailure m () +pushing m = do + res <- ErrorT m + case res of + True -> return () + False -> do + liftIO $ debugM "Pontarius.Xmpp" "Failed to send data." + throwError XmppOtherFailure + -- Unpickles and returns a stream element. streamUnpickleElem :: PU [Node] a -> Element @@ -115,33 +116,34 @@ openElementFromEvents = do startStream :: StateT StreamState IO (Either XmppFailure ()) startStream = runErrorT $ do lift $ lift $ debugM "Pontarius.Xmpp" "Starting stream..." - state <- lift $ get + st <- lift $ get -- Set the `from' (which is also the expected to) attribute depending on the -- state of the stream. - let expectedTo = case ( streamConnectionState state - , toJid $ streamConfiguration state) of - (Plain, (Just (jid, True))) -> Just jid - (Secured, (Just (jid, _))) -> Just jid - (Plain, Nothing) -> Nothing - (Secured, Nothing) -> Nothing - case streamAddress state of + let expectedTo = case ( streamConnectionState st + , toJid $ streamConfiguration st) of + (Plain , (Just (jid, True))) -> Just jid + (Plain , _ ) -> Nothing + (Secured, (Just (jid, _ ))) -> Just jid + (Secured, Nothing ) -> Nothing + (Closed , _ ) -> Nothing + case streamAddress st of Nothing -> do lift $ lift $ errorM "Pontarius.XMPP" "Server sent no hostname." throwError XmppOtherFailure - Just address -> lift $ do - pushXmlDecl - pushOpenElement $ + Just address -> do + pushing pushXmlDecl + pushing . pushOpenElement $ pickleElem xpStream ( "1.0" , expectedTo , Just (Jid Nothing address Nothing) , Nothing - , preferredLang $ streamConfiguration state + , preferredLang $ streamConfiguration st ) response <- ErrorT $ runEventsSink $ runErrorT $ streamS expectedTo case response of Left e -> throwError e -- Successful unpickling of stream element. - Right (Right (ver, from, to, id, lt, features)) + Right (Right (ver, from, to, sid, lt, features)) | (Text.unpack ver) /= "1.0" -> closeStreamWithError StreamUnsupportedVersion Nothing "Unknown version" @@ -149,7 +151,7 @@ startStream = runErrorT $ do closeStreamWithError StreamInvalidXml Nothing "Stream has no language tag" -- If `from' is set, we verify that it's the correct one. TODO: Should we check against the realm instead? - | isJust from && (from /= Just (Jid Nothing (fromJust $ streamAddress state) Nothing)) -> + | isJust from && (from /= Just (Jid Nothing (fromJust $ streamAddress st) Nothing)) -> closeStreamWithError StreamInvalidFrom Nothing "Stream from is invalid" | to /= expectedTo -> @@ -158,12 +160,12 @@ startStream = runErrorT $ do | otherwise -> do modify (\s -> s{ streamFeatures = features , streamLang = lt - , streamId = id + , streamId = sid , streamFrom = from } ) return () -- Unpickling failed - we investigate the element. - Right (Left (Element name attrs children)) + Right (Left (Element name attrs _children)) | (nameLocalName name /= "stream") -> closeStreamWithError StreamInvalidXml Nothing "Root element is not stream" @@ -180,10 +182,10 @@ startStream = runErrorT $ do closeStreamWithError :: StreamErrorCondition -> Maybe Element -> String -> ErrorT XmppFailure (StateT StreamState IO) () closeStreamWithError sec el msg = do - lift . pushElement . pickleElem xpStreamError + void . lift . pushElement . pickleElem xpStreamError $ StreamErrorInfo sec Nothing el - lift $ closeStreams' - lift $ lift $ errorM "Pontarius.XMPP" $ "closeStreamWithError: " ++ msg + void . lift $ closeStreams' + liftIO $ errorM "Pontarius.XMPP" $ "closeStreamWithError: " ++ msg throwError XmppOtherFailure checkchildren children = let to' = lookup "to" children @@ -207,12 +209,12 @@ startStream = runErrorT $ do "" safeRead x = case reads $ Text.unpack x of [] -> Nothing - [(y,_),_] -> Just y + ((y,_):_) -> Just y flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)] -flattenAttrs attrs = Prelude.map (\(name, content) -> +flattenAttrs attrs = Prelude.map (\(name, cont) -> ( name - , Text.concat $ Prelude.map uncontentify content) + , Text.concat $ Prelude.map uncontentify cont) ) attrs where @@ -230,11 +232,11 @@ restartStream = do modify (\s -> s{streamEventSource = newSource }) startStream where - loopRead read = do - bs <- liftIO (read 4096) + loopRead rd = do + bs <- liftIO (rd 4096) if BS.null bs then return () - else yield bs >> loopRead read + else yield bs >> loopRead rd -- Reads the (partial) stream:stream and the server features from the stream. -- Returns the (unvalidated) stream attributes, the unparsed element, or @@ -248,12 +250,12 @@ streamS :: Maybe Jid -> StreamSink (Either Element ( Text , Maybe Text , Maybe LangTag , StreamFeatures )) -streamS expectedTo = do - header <- xmppStreamHeader - case header of - Right (version, from, to, id, langTag) -> do +streamS _expectedTo = do -- TODO: check expectedTo + streamHeader <- xmppStreamHeader + case streamHeader of + Right (version, from, to, sid, lTag) -> do features <- xmppStreamFeatures - return $ Right (version, from, to, id, langTag, features) + return $ Right (version, from, to, sid, lTag, features) Left el -> return $ Left el where xmppStreamHeader :: StreamSink (Either Element (Text, Maybe Jid, Maybe Jid, Maybe Text.Text, Maybe LangTag)) @@ -281,7 +283,7 @@ openStream :: HostName -> StreamConfiguration -> IO (Either XmppFailure (Stream) openStream realm config = runErrorT $ do lift $ debugM "Pontarius.XMPP" "Opening stream..." stream' <- createStream realm config - result <- liftIO $ withStream startStream stream' + ErrorT . liftIO $ withStream startStream stream' return stream' -- | Send "" and wait for the server to finish processing and to @@ -290,14 +292,15 @@ openStream realm config = runErrorT $ do closeStreams :: Stream -> IO (Either XmppFailure [Element]) closeStreams = withStream closeStreams' +closeStreams' :: StateT StreamState IO (Either XmppFailure [Element]) closeStreams' = do lift $ debugM "Pontarius.XMPP" "Closing stream..." send <- gets (streamSend . streamHandle) cc <- gets (streamClose . streamHandle) - liftIO $ send "" + void . liftIO $ send "" void $ liftIO $ forkIO $ do threadDelay 3000000 -- TODO: Configurable value - (Ex.try cc) :: IO (Either Ex.SomeException ()) + void ((Ex.try cc) :: IO (Either Ex.SomeException ())) return () collectElems [] where @@ -379,8 +382,8 @@ pullElement = do -- Pulls an element and unpickles it. pullUnpickle :: PU [Node] a -> StateT StreamState IO (Either XmppFailure a) pullUnpickle p = do - elem <- pullElement - case elem of + el <- pullElement + case el of Left e -> return $ Left e Right elem' -> do let res = unpickleElem p elem' @@ -491,17 +494,17 @@ connect realm config = do UseSrv host -> connectSrv host UseRealm -> connectSrv realm where - connectSrv realm = do - case checkHostName (Text.pack realm) of - Just realm' -> do + connectSrv host = do + case checkHostName (Text.pack host) of + Just host' -> do resolvSeed <- lift $ makeResolvSeed (resolvConf config) lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..." - srvRecords <- srvLookup realm' resolvSeed + srvRecords <- srvLookup host' resolvSeed case srvRecords of Nothing -> do lift $ debugM "Pontarius.Xmpp" "No SRV records, using fallback process." - lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ realm) + lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ host) 5222 Just srvRecords' -> do lift $ debugM "Pontarius.Xmpp" @@ -517,10 +520,10 @@ connect realm config = do connectTcp :: [(HostName, PortID)] -> IO (Maybe Handle) connectTcp [] = return Nothing connectTcp ((address, port):remainder) = do - result <- try $ (do + result <- Ex.try $ (do debugM "Pontarius.Xmpp" $ "Connecting to " ++ address ++ " on port " ++ (show port) ++ "." - connectTo address port) :: IO (Either IOException Handle) + connectTo address port) :: IO (Either Ex.IOException Handle) case result of Right handle -> do debugM "Pontarius.Xmpp" "Successfully connected to HostName." @@ -534,23 +537,25 @@ connectTcp ((address, port):remainder) = do -- Surpresses all IO exceptions. resolvAndConnectTcp :: ResolvSeed -> Domain -> Int -> IO (Maybe Handle) resolvAndConnectTcp resolvSeed domain port = do - aaaaResults <- (try $ rethrowErrorCall $ withResolver resolvSeed $ - \resolver -> lookupAAAA resolver domain) :: IO (Either IOException (Maybe [IPv6])) + aaaaResults <- (Ex.try $ rethrowErrorCall $ withResolver resolvSeed $ + \resolver -> lookupAAAA resolver domain) :: IO (Either Ex.IOException (Maybe [IPv6])) handle <- case aaaaResults of Right Nothing -> return Nothing Right (Just ipv6s) -> connectTcp $ - map (\ipv6 -> ( show ipv6 + map (\ip -> ( show ip , PortNumber $ fromIntegral port)) ipv6s - Left e -> return Nothing + Left _e -> return Nothing case handle of Nothing -> do - aResults <- (try $ rethrowErrorCall $ withResolver resolvSeed $ - \resolver -> lookupA resolver domain) :: IO (Either IOException (Maybe [IPv4])) + aResults <- (Ex.try $ rethrowErrorCall $ withResolver resolvSeed $ + \resolver -> lookupA resolver domain) :: IO (Either Ex.IOException (Maybe [IPv4])) handle' <- case aResults of + Left _ -> return Nothing Right Nothing -> return Nothing + Right (Just ipv4s) -> connectTcp $ - map (\ipv4 -> (show ipv4 + map (\ip -> (show ip , PortNumber $ fromIntegral port)) ipv4s @@ -574,29 +579,30 @@ resolvSrvsAndConnectTcp resolvSeed ((domain, port):remaining) = do -- exceptions and rethrows them as IOExceptions. rethrowErrorCall :: IO a -> IO a rethrowErrorCall action = do - result <- try action + result <- Ex.try action case result of Right result' -> return result' - Left (ErrorCall e) -> ioError $ userError $ "rethrowErrorCall: " ++ e - Left e -> throwIO e + Left (Ex.ErrorCall e) -> Ex.ioError $ userError + $ "rethrowErrorCall: " ++ e -- Provides a list of A(AAA) names and port numbers upon a successful -- DNS-SRV request, or `Nothing' if the DNS-SRV request failed. srvLookup :: Text -> ResolvSeed -> ErrorT XmppFailure IO (Maybe [(Domain, Int)]) srvLookup realm resolvSeed = ErrorT $ do - result <- try $ rethrowErrorCall $ withResolver resolvSeed $ \resolver -> do + result <- Ex.try $ rethrowErrorCall $ withResolver resolvSeed + $ \resolver -> do srvResult <- lookupSRV resolver $ BSC8.pack $ "_xmpp-client._tcp." ++ (Text.unpack realm) ++ "." case srvResult of - Just srvResult -> do - debugM "Pontarius.Xmpp" $ "SRV result: " ++ (show srvResult) - -- Get [(Domain, PortNumber)] of SRV request, if any. - srvResult' <- orderSrvResult srvResult - return $ Just $ Prelude.map (\(_, _, port, domain) -> (domain, port)) srvResult' - -- The service is not available at this domain. - -- Sorts the records based on the priority value. Just [(_, _, _, ".")] -> do debugM "Pontarius.Xmpp" $ "\".\" SRV result returned." return $ Just [] + Just srvResult' -> do + debugM "Pontarius.Xmpp" $ "SRV result: " ++ (show srvResult') + -- Get [(Domain, PortNumber)] of SRV request, if any. + orderedSrvResult <- orderSrvResult srvResult' + return $ Just $ Prelude.map (\(_, _, port, domain) -> (domain, port)) orderedSrvResult + -- The service is not available at this domain. + -- Sorts the records based on the priority value. Nothing -> do debugM "Pontarius.Xmpp" "No SRV result returned." return Nothing @@ -627,7 +633,7 @@ srvLookup realm resolvSeed = ErrorT $ do orderSublist sublist = do -- Compute the running sum, as well as the total sum of -- the sublist. Add the running sum to the SRV tuples. - let (total, sublist') = Data.List.mapAccumL (\total (priority, weight, port, domain) -> (total + weight, (priority, weight, port, domain, total + weight))) 0 sublist + let (total, sublist') = Data.List.mapAccumL (\total' (priority, weight, port, domain) -> (total' + weight, (priority, weight, port, domain, total' + weight))) 0 sublist -- Choose a random number between 0 and the total sum -- (inclusive). randomNumber <- randomRIO (0, total) @@ -636,11 +642,11 @@ srvLookup realm resolvSeed = ErrorT $ do let (beginning, ((priority, weight, port, domain, _):end)) = Data.List.break (\(_, _, _, _, running) -> randomNumber <= running) sublist' -- Remove the running total number from the remaining -- elements. - let sublist'' = Data.List.map (\(priority, weight, port, domain, _) -> (priority, weight, port, domain)) (Data.List.concat [beginning, end]) + let sublist'' = Data.List.map (\(priority', weight', port', domain', _) -> (priority', weight', port', domain')) (Data.List.concat [beginning, end]) -- Repeat the ordering procedure on the remaining -- elements. - tail <- orderSublist sublist'' - return $ ((priority, weight, port, domain):tail) + rest <- orderSublist sublist'' + return $ ((priority, weight, port, domain):rest) -- Closes the connection and updates the XmppConMonad Stream state. -- killStream :: Stream -> IO (Either ExL.SomeException ()) @@ -661,23 +667,24 @@ pushIQ :: StanzaID -> Element -> Stream -> IO (Either XmppFailure (Either IQError IQResult)) -pushIQ iqID to tp lang body stream = do - pushStanza (IQRequestS $ IQRequest iqID Nothing to lang tp body) stream - res <- pullStanza stream +pushIQ iqID to tp lang body stream = runErrorT $ do + pushing $ pushStanza + (IQRequestS $ IQRequest iqID Nothing to lang tp body) stream + res <- lift $ pullStanza stream case res of - Left e -> return $ Left e - Right (IQErrorS e) -> return $ Right $ Left e + Left e -> throwError e + Right (IQErrorS e) -> return $ Left e Right (IQResultS r) -> do unless (iqID == iqResultID r) $ liftIO $ do - errorM "Pontarius.XMPP" $ "pushIQ: ID mismatch (" ++ (show iqID) ++ " /= " ++ (show $ iqResultID r) ++ ")." - ExL.throwIO XmppOtherFailure + liftIO $ errorM "Pontarius.XMPP" $ "pushIQ: ID mismatch (" ++ (show iqID) ++ " /= " ++ (show $ iqResultID r) ++ ")." + liftIO $ ExL.throwIO XmppOtherFailure -- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++ -- " /= " ++ show (iqResultID r) ++ " .") - return $ Right $ Right r + return $ Right r _ -> do - errorM "Pontarius.XMPP" $ "pushIQ: Unexpected stanza type." - return . Left $ XmppOtherFailure + liftIO $ errorM "Pontarius.XMPP" $ "pushIQ: Unexpected stanza type." + throwError XmppOtherFailure debugConduit :: Pipe l ByteString ByteString u IO b debugConduit = forever $ do @@ -695,7 +702,9 @@ elements = do Just (EventBeginElement n as) -> do goE n as >>= yield elements - Just (EventEndElement streamName) -> lift $ R.monadThrow StreamEnd + -- This might be an XML error if the end element tag is not + -- "". TODO: We might want to check this at a later time + Just (EventEndElement _) -> lift $ R.monadThrow StreamEnd Nothing -> return () _ -> lift $ R.monadThrow $ InvalidXmppXml $ "not an element: " ++ show x where @@ -705,8 +714,8 @@ elements = do go front = do x <- f case x of - Left x -> return $ (x, front []) - Right y -> go (front . (:) y) + Left l -> return $ (l, front []) + Right r -> go (front . (:) r) goE n as = do (y, ns) <- many' goN if y == Just (EventEndElement n) @@ -730,11 +739,8 @@ elements = do compressNodes $ NodeContent (ContentText $ x `Text.append` y) : z compressNodes (x:xs) = x : compressNodes xs - streamName :: Name - streamName = (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) - withStream :: StateT StreamState IO (Either XmppFailure c) -> Stream -> IO (Either XmppFailure c) -withStream action (Stream stream) = bracketOnError +withStream action (Stream stream) = Ex.bracketOnError (atomically $ takeTMVar stream ) (atomically . putTMVar stream) (\s -> do diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs index 71e9b8d..88b56f1 100644 --- a/source/Network/Xmpp/Tls.hs +++ b/source/Network/Xmpp/Tls.hs @@ -4,7 +4,6 @@ module Network.Xmpp.Tls where -import Control.Concurrent.STM.TMVar import qualified Control.Exception.Lifted as Ex import Control.Monad import Control.Monad.Error @@ -14,16 +13,14 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC8 import qualified Data.ByteString.Lazy as BL import Data.Conduit -import qualified Data.Conduit.Binary as CB import Data.IORef -import Data.Typeable import Data.XML.Types import Network.TLS -import Network.TLS.Extra import Network.Xmpp.Stream import Network.Xmpp.Types import System.Log.Logger (debugM, errorM) +mkBackend :: StreamHandle -> Backend mkBackend con = Backend { backendSend = \bs -> void (streamSend con bs) , backendRecv = streamReceive con , backendFlush = streamFlush con @@ -61,31 +58,39 @@ tls con = Ex.handle (return . Left . TlsError) where startTls = do params <- gets $ tlsParams . streamConfiguration - lift $ pushElement starttlsE + sent <- ErrorT $ pushElement starttlsE + unless sent $ do + liftIO $ errorM "Pontarius.XMPP" "startTls: Could not sent stanza." + throwError XmppOtherFailure answer <- lift $ pullElement case answer of - Left e -> return $ Left e + Left e -> throwError e Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] []) -> - return $ Right () + return () Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _) -> do liftIO $ errorM "Pontarius.XMPP" "startTls: TLS initiation failed." - return . Left $ XmppOtherFailure + throwError XmppOtherFailure + Right r -> + liftIO $ errorM "Pontarius.XMPP" $ + "startTls: Unexpected element: " ++ show r hand <- gets streamHandle - (raw, _snk, psh, read, ctx) <- lift $ tlsinit params (mkBackend hand) + (_raw, _snk, psh, recv, ctx) <- lift $ tlsinit params (mkBackend hand) let newHand = StreamHandle { streamSend = catchPush . psh - , streamReceive = read - , streamFlush = contextFlush ctx - , streamClose = bye ctx >> streamClose hand - } + , streamReceive = recv + , streamFlush = contextFlush ctx + , streamClose = bye ctx >> streamClose hand + } lift $ modify ( \x -> x {streamHandle = newHand}) either (lift . Ex.throwIO) return =<< lift restartStream modify (\s -> s{streamConnectionState = Secured}) return () +client :: (MonadIO m, CPRG rng) => Params -> rng -> Backend -> m Context client params gen backend = do contextNew backend params gen -defaultParams = defaultParamsClient +xmppDefaultParams :: Params +xmppDefaultParams = defaultParamsClient tlsinit :: (MonadIO m, MonadIO m1) => TLSParams @@ -96,10 +101,10 @@ tlsinit :: (MonadIO m, MonadIO m1) => , Int -> m1 BS.ByteString , Context ) -tlsinit tlsParams backend = do +tlsinit params backend = do liftIO $ debugM "Pontarius.Xmpp.TLS" "TLS with debug mode enabled." gen <- liftIO $ getSystemRandomGen -- TODO: Find better random source? - con <- client tlsParams gen backend + con <- client params gen backend handshake con let src = forever $ do dt <- liftIO $ recvData con @@ -114,22 +119,22 @@ tlsinit tlsParams backend = do liftIO $ debugM "Pontarius.Xmpp.TLS" ("out :" ++ BSC8.unpack x) snk - read <- liftIO $ mkReadBuffer (recvData con) + readWithBuffer <- liftIO $ mkReadBuffer (recvData con) return ( src , snk , \s -> do liftIO $ debugM "Pontarius.Xmpp.TLS" ("out :" ++ BSC8.unpack s) sendData con $ BL.fromChunks [s] - , liftIO . read + , liftIO . readWithBuffer , con ) mkReadBuffer :: IO BS.ByteString -> IO (Int -> IO BS.ByteString) -mkReadBuffer read = do +mkReadBuffer recv = do buffer <- newIORef BS.empty let read' n = do nc <- readIORef buffer - bs <- if BS.null nc then read + bs <- if BS.null nc then recv else return nc let (result, rest) = BS.splitAt n bs writeIORef buffer rest diff --git a/source/Network/Xmpp/Utilities.hs b/source/Network/Xmpp/Utilities.hs index 419bd6b..c11d58e 100644 --- a/source/Network/Xmpp/Utilities.hs +++ b/source/Network/Xmpp/Utilities.hs @@ -3,76 +3,27 @@ {-# OPTIONS_HADDOCK hide #-} -module Network.Xmpp.Utilities (presTo, message, answerMessage, openElementToEvents, renderOpenElement, renderElement) where - -import Network.Xmpp.Types - -import Control.Monad.STM -import Control.Concurrent.STM.TVar -import Prelude - -import Data.XML.Types - -import qualified Data.Attoparsec.Text as AP -import qualified Data.Text as Text - +module Network.Xmpp.Utilities + ( presTo + , message + , answerMessage + , openElementToEvents + , renderOpenElement + , renderElement) + where + +import Network.Xmpp.Types +import Prelude +import Data.XML.Types import qualified Data.ByteString as BS +import Data.Conduit as C +import Data.Conduit.List as CL import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import System.IO.Unsafe(unsafePerformIO) -import Data.Conduit.List as CL --- import Data.Typeable -import Control.Applicative ((<$>)) -import Control.Exception -import Control.Monad.Trans.Class - -import Data.Conduit as C -import Data.XML.Types - import qualified Text.XML.Stream.Render as TXSR import Text.XML.Unresolved as TXU - --- TODO: Not used, and should probably be removed. --- | 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 :: Text.Text -> IO IdGenerator -idGenerator prefix = atomically $ do - tvar <- newTVar $ ids prefix - return $ IdGenerator $ next tvar - where - -- Transactionally extract the next ID from the infinite list of IDs. - next :: TVar [Text.Text] -> IO Text.Text - next tvar = atomically $ do - list <- readTVar tvar - 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. Adds the prefix to all combinations of IDs (ids'). - ids :: Text.Text -> [Text.Text] - ids p = Prelude.map (\ id -> Text.append p id) ids' - where - -- Generate all combinations of IDs, with increasing length. - ids' :: [Text.Text] - ids' = Prelude.map Text.pack $ Prelude.concatMap ids'' [1..] - -- Generates all combinations of IDs with the given length. - ids'' :: Integer -> [String] - ids'' 0 = [""] - ids'' l = [x:xs | x <- repertoire, xs <- ids'' (l - 1)] - -- Characters allowed in IDs. - repertoire :: String - repertoire = ['a'..'z'] - --- Constructs a "Version" based on the major and minor version numbers. -versionFromNumbers :: Integer -> Integer -> Version -versionFromNumbers major minor = Version major minor - -- | Add a recipient to a presence notification. presTo :: Presence -> Jid -> Presence presTo pres to = pres{presenceTo = Just to} @@ -124,4 +75,5 @@ renderElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO $ CL.sourceList (elementToEvents e) $$ TXSR.renderText def =$ CL.consume where elementToEvents :: Element -> [Event] - elementToEvents e@(Element name _ _) = openElementToEvents e ++ [EventEndElement name] + elementToEvents el@(Element name _ _) = openElementToEvents el + ++ [EventEndElement name] diff --git a/source/Network/Xmpp/Xep/DataForms.hs b/source/Network/Xmpp/Xep/DataForms.hs index 9491acd..2c2b733 100644 --- a/source/Network/Xmpp/Xep/DataForms.hs +++ b/source/Network/Xmpp/Xep/DataForms.hs @@ -7,12 +7,9 @@ module Network.Xmpp.Xep.DataForms where import qualified Data.Text as Text +import Data.XML.Pickle import qualified Data.XML.Types as XML -import Data.XML.Pickle -import qualified Data.Text as Text - -import qualified Text.XML.Stream.Parse as Parse dataFormNs :: Text.Text dataFormNs = "jabber:x:data" @@ -95,12 +92,12 @@ instance Read FieldType where xpForm :: PU [XML.Node] Form -xpForm = xpWrap (\(tp , (title, instructions, fields, reported, items)) -> - Form tp title (map snd instructions) fields reported (map snd items)) - (\(Form tp title instructions fields reported items) -> +xpForm = xpWrap (\(tp , (ttl, ins, flds, rpd, its)) -> + Form tp ttl (map snd ins) flds rpd (map snd its)) + (\(Form tp ttl ins flds rpd its) -> (tp , - (title, map ((),) instructions - , fields, reported, map ((),) items))) + (ttl, map ((),) ins + , flds, rpd, map ((),) its))) $ xpElem (dataFormName "x") @@ -113,10 +110,10 @@ xpForm = xpWrap (\(tp , (title, instructions, fields, reported, items)) -> (xpElems (dataFormName "item") xpUnit xpFields)) xpFields :: PU [XML.Node] [Field] -xpFields = xpWrap (map $ \((var, tp, label),(desc, req, vals, opts)) - -> Field var label tp desc req vals opts) - (map $ \(Field var label tp desc req vals opts) - -> ((var, tp, label),(desc, req, vals, opts))) $ +xpFields = xpWrap (map $ \((var, tp, lbl),(desc, req, vals, opts)) + -> Field var lbl tp desc req vals opts) + (map $ \(Field var lbl tp desc req vals opts) + -> ((var, tp, lbl),(desc, req, vals, opts))) $ xpElems (dataFormName "field") (xp3Tuple (xpAttrImplied "var" xpId ) From 2be98f544a12c44c6f6b3e041781dca95db0f73d Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 21 Mar 2013 16:20:28 +0100 Subject: [PATCH 10/26] fix deadlock in Network.Xmpp.Sasl --- source/Network/Xmpp/Sasl.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index d445cb9..1c201af 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -75,7 +75,7 @@ auth mechanisms resource con = runErrorT $ do case mbAuthFail of Nothing -> do _jid <- ErrorT $ xmppBind resource con - ErrorT $ flip withStream con $ do + ErrorT $ flip withStream' con $ do s <- get case establishSession $ streamConfiguration s of False -> return $ Right Nothing From fea7e3f7ac3322b89321f16837ed0ff1d641d7ba Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 21 Mar 2013 16:21:21 +0100 Subject: [PATCH 11/26] fix debugging messaages in Network.Xmpp.Sasl and write inbound TCP messages to debug logger --- source/Network/Xmpp/Sasl.hs | 12 +++++------- source/Network/Xmpp/Stream.hs | 9 +++++++-- 2 files changed, 12 insertions(+), 9 deletions(-) diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index 1c201af..00df024 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -101,19 +101,17 @@ xmppBind rsrc c = runErrorT $ do answer <- ErrorT $ pushIQ "bind" Nothing Set Nothing (bindBody rsrc) c case answer of Right IQResult{iqResultPayload = Just b} -> do - lift $ debugM "Pontarius.XMPP" "xmppBind: IQ result received; unpickling JID..." + lift $ debugM "Pontarius.Xmpp" "xmppBind: IQ result received; unpickling JID..." let jid = unpickleElem xpJid b case jid of Right jid' -> do - lift $ infoM "Pontarius.XMPP" $ "Bound JID: " ++ show jid' - _ <- lift $ withStream ( do - modify $ \s -> - s{streamJid = Just jid'} - return $ Right ()) + lift $ infoM "Pontarius.Xmpp" $ "Bound JID: " ++ show jid' + _ <- lift $ withStream ( do modify $ \s -> + s{streamJid = Just jid'}) c return jid' _ -> do - lift $ errorM "Pontarius.XMPP" + lift $ errorM "Pontarius.Xmpp" $ "xmppBind: JID could not be unpickled from: " ++ show b throwError $ XmppOtherFailure diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 1ee3266..0349cb5 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -29,6 +29,7 @@ import Data.Maybe import Data.Ord import Data.Text (Text) import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import Data.Void (Void) import Data.XML.Pickle import Data.XML.Types @@ -236,7 +237,11 @@ restartStream = do bs <- liftIO (rd 4096) if BS.null bs then return () - else yield bs >> loopRead rd + else do + liftIO $ debugM "Pontarius.Xmpp" $ "in: " ++ + (Text.unpack . Text.decodeUtf8 $ bs) + yield bs + loopRead rd -- Reads the (partial) stream:stream and the server features from the stream. -- Returns the (unvalidated) stream attributes, the unparsed element, or @@ -739,7 +744,7 @@ elements = do compressNodes $ NodeContent (ContentText $ x `Text.append` y) : z compressNodes (x:xs) = x : compressNodes xs -withStream :: StateT StreamState IO (Either XmppFailure c) -> Stream -> IO (Either XmppFailure c) +withStream :: StateT StreamState IO a -> Stream -> IO a withStream action (Stream stream) = Ex.bracketOnError (atomically $ takeTMVar stream ) (atomically . putTMVar stream) From d8ae2d074eee80c6fa83c53f946a3faccf28f273 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Fri, 22 Mar 2013 13:15:49 +0100 Subject: [PATCH 12/26] integrate roster management --- pontarius-xmpp.cabal | 2 + source/Network/Xmpp/Concurrent.hs | 17 +++- source/Network/Xmpp/Concurrent/Types.hs | 3 + source/Network/Xmpp/IM.hs | 8 +- source/Network/Xmpp/IM/Roster.hs | 108 +++++++----------------- source/Network/Xmpp/IM/Roster/Types.hs | 47 +++++++++++ source/Network/Xmpp/Types.hs | 1 + 7 files changed, 105 insertions(+), 81 deletions(-) create mode 100644 source/Network/Xmpp/IM/Roster/Types.hs diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 0c830c4..a1d8ab3 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -82,6 +82,8 @@ Library , Network.Xmpp.Tls , Network.Xmpp.Types , Network.Xmpp.Utilities + , Network.Xmpp.IM.Roster + , Network.Xmpp.IM.Roster.Types GHC-Options: -Wall Source-Repository head diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 772ca34..eaa5943 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -32,6 +32,8 @@ import Network.Xmpp.Concurrent.Monad import Network.Xmpp.Concurrent.Presence import Network.Xmpp.Concurrent.Threads import Network.Xmpp.Concurrent.Types +import Network.Xmpp.IM.Roster.Types +import Network.Xmpp.IM.Roster import Network.Xmpp.Marshal import Network.Xmpp.Sasl import Network.Xmpp.Sasl.Types @@ -98,10 +100,15 @@ newSession stream config = runErrorT $ do stanzaChan <- lift newTChanIO iqHands <- lift $ newTVarIO (Map.empty, Map.empty) eh <- lift $ newTVarIO $ EventHandlers { connectionClosedHandler = sessionClosedHandler config } - let stanzaHandler = runHandlers outC $ Prelude.concat [ [toChan stanzaChan] + ros <- liftIO . newTVarIO $ Roster Nothing Map.empty + let rosterH = if (enableRoster config) then handleRoster ros + else \ _ _ -> return True + let stanzaHandler = runHandlers outC $ Prelude.concat [ [ toChan stanzaChan ] , extraStanzaHandlers config - , [handleIQ iqHands] + , [ handleIQ iqHands + , rosterH + ] ] (kill, wLock, streamState, reader) <- ErrorT $ startThreadsWith stanzaHandler eh stream writer <- lift $ forkIO $ writeWorker outC wLock @@ -116,6 +123,7 @@ newSession stream config = runErrorT $ do , eventHandlers = eh , stopThreads = kill >> killThread writer , conf = config + , rosterRef = ros } -- Worker to write stanzas to the stream concurrently. @@ -137,12 +145,12 @@ writeWorker stCh writeR = forever $ do -- third parameter is a 'Just' value, @session@ will attempt to authenticate and -- acquire an XMPP resource. session :: HostName -- ^ The hostname / realm - -> SessionConfiguration -- ^ configuration details -> Maybe ([SaslHandler], Maybe Text) -- ^ SASL handlers and the desired -- JID resource (or Nothing to let -- the server decide) + -> SessionConfiguration -- ^ configuration details -> IO (Either XmppFailure Session) -session realm config mbSasl = runErrorT $ do +session realm mbSasl config = runErrorT $ do stream <- ErrorT $ openStream realm (sessionStreamConfiguration config) ErrorT $ tls stream mbAuthError <- case mbSasl of @@ -152,4 +160,5 @@ session realm config mbSasl = runErrorT $ do Nothing -> return () Just _ -> throwError XmppAuthFailure ses <- ErrorT $ newSession stream config + liftIO $ when (enableRoster config) $ initRoster ses return ses diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index 4a4b2e5..c98e45c 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -10,6 +10,8 @@ import qualified Data.ByteString as BS import qualified Data.Map as Map import Data.Text (Text) import Data.Typeable + +import Network.Xmpp.IM.Roster.Types import Network.Xmpp.Types -- | Handlers to be run when the Xmpp session ends and when the Xmpp connection is @@ -41,6 +43,7 @@ data Session = Session , streamRef :: TMVar (Stream) , eventHandlers :: TVar EventHandlers , stopThreads :: IO () + , rosterRef :: TVar Roster , conf :: SessionConfiguration } diff --git a/source/Network/Xmpp/IM.hs b/source/Network/Xmpp/IM.hs index 35b2c9c..d8793a0 100644 --- a/source/Network/Xmpp/IM.hs +++ b/source/Network/Xmpp/IM.hs @@ -7,9 +7,15 @@ module Network.Xmpp.IM , newIM , simpleIM , answerIM - -- * Presence + -- * Presence , module Network.Xmpp.IM.Presence + -- * Roster + , Roster(..) + , Item(..) + , getRoster ) where import Network.Xmpp.IM.Message import Network.Xmpp.IM.Presence +import Network.Xmpp.IM.Roster +import Network.Xmpp.IM.Roster.Types diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs index 1f359f9..cd7a0ca 100644 --- a/source/Network/Xmpp/IM/Roster.hs +++ b/source/Network/Xmpp/IM/Roster.hs @@ -1,83 +1,39 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} -module Network.Xmpp.IM.Roster -where +module Network.Xmpp.IM.Roster where -import Control.Concurrent.STM -import Control.Monad -import Data.Text (Text) -import Data.XML.Pickle -import Data.XML.Types -import Network.Xmpp -import Network.Xmpp.Marshal -import System.Log.Logger +import Control.Concurrent.STM +import Control.Monad import qualified Data.Map.Strict as Map - -import Network.Xmpp.Types - -data Subscription = None | To | From | Both | Remove deriving Eq - -instance Show Subscription where - show None = "none" - show To = "to" - show From = "from" - show Both = "both" - show Remove = "remove" - -instance Read Subscription where - readsPrec _ "none" = [(None ,"")] - readsPrec _ "to" = [(To ,"")] - readsPrec _ "from" = [(From ,"")] - readsPrec _ "both" = [(Both ,"")] - readsPrec _ "remove" = [(Remove ,"")] - readsPrec _ _ = [] - -data Roster = Roster { ver :: Maybe Text - , items :: Map.Map Jid Item } - - -data Item = Item { approved :: Bool - , ask :: Bool - , jid :: Jid - , name :: Maybe Text - , subscription :: Subscription - , groups :: [Text] - } deriving Show - -data QueryItem = QueryItem { qiApproved :: Maybe Bool - , qiAsk :: Bool - , qiJid :: Jid - , qiName :: Maybe Text - , qiSubscription :: Maybe Subscription - , qiGroups :: [Text] - } deriving Show - -data Query = Query { queryVer :: Maybe Text - , queryItems :: [QueryItem] - } deriving Show - - -withRoster :: Maybe Roster - -> SessionConfiguration - -> (SessionConfiguration -> IO (Either XmppFailure Session)) - -> IO (Either XmppFailure (TVar Roster, Session)) -withRoster oldRoster conf startSession = do - rosterRef <- newTVarIO $ Roster Nothing Map.empty - mbSess <- startSession conf{extraStanzaHandlers = handleRoster rosterRef : - extraStanzaHandlers conf} - case mbSess of - Left e -> return $ Left e - Right sess -> do - mbRoster <- getRoster oldRoster sess - case mbRoster of - Nothing -> errorM "Pontarius.Xmpp" "Server did not return a roster" - Just roster -> atomically $ writeTVar rosterRef roster - return $ Right (rosterRef, sess) +import Data.Maybe (isJust) +import Data.XML.Pickle +import Data.XML.Types +import System.Log.Logger + +import Network.Xmpp.IM.Roster.Types +import Network.Xmpp.Marshal +import Network.Xmpp.Concurrent.Types +import Network.Xmpp.Types +import Network.Xmpp.Concurrent.IQ + +getRoster :: Session -> IO Roster +getRoster session = atomically $ readTVar (rosterRef session) + +initRoster :: Session -> IO () +initRoster session = do + oldRoster <- getRoster session + mbRoster <- retrieveRoster (if isJust (ver oldRoster) then Just oldRoster + else Nothing ) session + case mbRoster of + Nothing -> errorM "Pontarius.Xmpp" + "Server did not return a roster" + Just roster -> atomically $ writeTVar (rosterRef session) roster handleRoster :: TVar Roster -> TChan Stanza -> Stanza -> IO Bool -handleRoster rosterRef outC sta = do +handleRoster ref outC sta = do case sta of IQRequestS (iqr@IQRequest{iqRequestPayload = iqb@Element{elementName = en}}) @@ -98,7 +54,7 @@ handleRoster rosterRef outC sta = do return False _ -> return True where - handleUpdate v' update = atomically $ modifyTVar rosterRef $ \(Roster v is) -> + handleUpdate v' update = atomically $ modifyTVar ref $ \(Roster v is) -> Roster (v' `mplus` v) $ case qiSubscription update of Just Remove -> Map.delete (qiJid update) is _ -> Map.insert (qiJid update) (toItem update) is @@ -109,8 +65,8 @@ handleRoster rosterRef outC sta = do result (IQRequest iqid from _to lang _tp _bd) = IQResultS $ IQResult iqid Nothing from lang Nothing -getRoster :: Maybe Roster -> Session -> IO (Maybe Roster) -getRoster oldRoster sess = do +retrieveRoster :: Maybe Roster -> Session -> IO (Maybe Roster) +retrieveRoster oldRoster sess = do res <- sendIQ' Nothing Get Nothing (pickleElem xpQuery (Query (ver =<< oldRoster) [])) sess @@ -120,7 +76,7 @@ getRoster oldRoster sess = do Left _e -> do errorM "Pontarius.Xmpp.Roster" "getRoster: invalid query element" return Nothing - Right roster -> return . Just $ toRoster roster + Right ros' -> return . Just $ toRoster ros' IQResponseResult (IQResult{iqResultPayload = Nothing}) -> do return $ oldRoster -- sever indicated that no roster updates are necessary diff --git a/source/Network/Xmpp/IM/Roster/Types.hs b/source/Network/Xmpp/IM/Roster/Types.hs new file mode 100644 index 0000000..04854b4 --- /dev/null +++ b/source/Network/Xmpp/IM/Roster/Types.hs @@ -0,0 +1,47 @@ +module Network.Xmpp.IM.Roster.Types where + +import qualified Data.Map as Map +import Data.Text (Text) +import Network.Xmpp.Types + +data Subscription = None | To | From | Both | Remove deriving Eq + +instance Show Subscription where + show None = "none" + show To = "to" + show From = "from" + show Both = "both" + show Remove = "remove" + +instance Read Subscription where + readsPrec _ "none" = [(None ,"")] + readsPrec _ "to" = [(To ,"")] + readsPrec _ "from" = [(From ,"")] + readsPrec _ "both" = [(Both ,"")] + readsPrec _ "remove" = [(Remove ,"")] + readsPrec _ _ = [] + +data Roster = Roster { ver :: Maybe Text + , items :: Map.Map Jid Item } deriving Show + + + +data Item = Item { approved :: Bool + , ask :: Bool + , jid :: Jid + , name :: Maybe Text + , subscription :: Subscription + , groups :: [Text] + } deriving Show + +data QueryItem = QueryItem { qiApproved :: Maybe Bool + , qiAsk :: Bool + , qiJid :: Jid + , qiName :: Maybe Text + , qiSubscription :: Maybe Subscription + , qiGroups :: [Text] + } deriving Show + +data Query = Query { queryVer :: Maybe Text + , queryItems :: [QueryItem] + } deriving Show diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index bab4d33..8f4e9e1 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -1106,6 +1106,7 @@ instance Default SessionConfiguration where writeTVar idRef (curId + 1 :: Integer) return . StanzaID . Text.pack . show $ curId , extraStanzaHandlers = [] + , enableRoster = True } -- | How the client should behave in regards to TLS. From 1c5203204cbf9aeb72a38f2090f3f99998bff63f Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Fri, 22 Mar 2013 13:16:21 +0100 Subject: [PATCH 13/26] move host name checks from Network.Xmpp.Types to Network.Xmpp.Utilities --- source/Network/Xmpp/Types.hs | 34 ++++------------------------ source/Network/Xmpp/Utilities.hs | 39 ++++++++++++++++++++++++++++---- 2 files changed, 39 insertions(+), 34 deletions(-) diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 8f4e9e1..cc6e166 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -47,7 +47,6 @@ module Network.Xmpp.Types , jidFromTexts , StreamEnd(..) , InvalidXmppXml(..) - , checkHostName , SessionConfiguration(..) , TlsBehaviour(..) ) @@ -1055,32 +1054,6 @@ instance Default StreamConfiguration where } } --- | Validates the hostname string in accordance with RFC 1123. -checkHostName :: Text -> Maybe Text -checkHostName t = do - eitherToMaybeHostName $ AP.parseOnly hostnameP t - where - eitherToMaybeHostName = either (const Nothing) Just - --- Validation of RFC 1123 hostnames. -hostnameP :: AP.Parser Text -hostnameP = do - -- Hostnames may not begin with a hyphen. - h <- AP.satisfy $ AP.inClass $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] - t <- AP.takeWhile $ AP.inClass $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ ['-'] - let label = Text.concat [Text.pack [h], t] - if Text.length label > 63 - then fail "Label too long." - else do - AP.endOfInput - return label - <|> do - _ <- AP.satisfy (== '.') - r <- hostnameP - if (Text.length label) + 1 + (Text.length r) > 255 - then fail "Hostname too long." - else return $ Text.concat [label, Text.pack ".", r] - type StanzaHandler = TChan Stanza -- ^ outgoing stanza -> Stanza -- ^ stanza to handle -> IO Bool -- ^ True when processing should continue @@ -1090,10 +1063,11 @@ data SessionConfiguration = SessionConfiguration { -- | Configuration for the @Stream@ object. sessionStreamConfiguration :: StreamConfiguration -- | Handler to be run when the session ends (for whatever reason). - , sessionClosedHandler :: XmppFailure -> IO () + , sessionClosedHandler :: XmppFailure -> IO () -- | Function to generate the stream of stanza identifiers. - , sessionStanzaIDs :: IO (IO StanzaID) - , extraStanzaHandlers :: [StanzaHandler] + , sessionStanzaIDs :: IO (IO StanzaID) + , extraStanzaHandlers :: [StanzaHandler] + , enableRoster :: Bool } instance Default SessionConfiguration where diff --git a/source/Network/Xmpp/Utilities.hs b/source/Network/Xmpp/Utilities.hs index c11d58e..eef3c98 100644 --- a/source/Network/Xmpp/Utilities.hs +++ b/source/Network/Xmpp/Utilities.hs @@ -9,17 +9,22 @@ module Network.Xmpp.Utilities , answerMessage , openElementToEvents , renderOpenElement - , renderElement) + , renderElement + , checkHostName + ) where -import Network.Xmpp.Types -import Prelude -import Data.XML.Types +import Control.Applicative ((<|>)) +import qualified Data.Attoparsec.Text as AP import qualified Data.ByteString as BS import Data.Conduit as C import Data.Conduit.List as CL import qualified Data.Text as Text +import Data.Text(Text) import qualified Data.Text.Encoding as Text +import Data.XML.Types +import Network.Xmpp.Types +import Prelude import System.IO.Unsafe(unsafePerformIO) import qualified Text.XML.Stream.Render as TXSR import Text.XML.Unresolved as TXU @@ -77,3 +82,29 @@ renderElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO elementToEvents :: Element -> [Event] elementToEvents el@(Element name _ _) = openElementToEvents el ++ [EventEndElement name] + +-- | Validates the hostname string in accordance with RFC 1123. +checkHostName :: Text -> Maybe Text +checkHostName t = do + eitherToMaybeHostName $ AP.parseOnly hostnameP t + where + eitherToMaybeHostName = either (const Nothing) Just + +-- Validation of RFC 1123 hostnames. +hostnameP :: AP.Parser Text +hostnameP = do + -- Hostnames may not begin with a hyphen. + h <- AP.satisfy $ AP.inClass $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] + t <- AP.takeWhile $ AP.inClass $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ ['-'] + let label = Text.concat [Text.pack [h], t] + if Text.length label > 63 + then fail "Label too long." + else do + AP.endOfInput + return label + <|> do + _ <- AP.satisfy (== '.') + r <- hostnameP + if (Text.length label) + 1 + (Text.length r) > 255 + then fail "Hostname too long." + else return $ Text.concat [label, Text.pack ".", r] From 1e2772c2b76afe6115d1ef8c175ee05e3904f024 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sat, 23 Mar 2013 18:26:44 +0100 Subject: [PATCH 14/26] jabber.org compatibility --- source/Network/Xmpp/Stream.hs | 55 ++++++++++++++++++++++++++--------- source/Network/Xmpp/Tls.hs | 13 ++++++++- source/Network/Xmpp/Types.hs | 4 +-- 3 files changed, 56 insertions(+), 16 deletions(-) diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 0349cb5..2310131 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -133,7 +133,7 @@ startStream = runErrorT $ do throwError XmppOtherFailure Just address -> do pushing pushXmlDecl - pushing . pushOpenElement $ + pushing . pushOpenElement . streamNSHack $ pickleElem xpStream ( "1.0" , expectedTo , Just (Jid Nothing address Nothing) @@ -148,10 +148,15 @@ startStream = runErrorT $ do | (Text.unpack ver) /= "1.0" -> closeStreamWithError StreamUnsupportedVersion Nothing "Unknown version" - | lt == Nothing -> - closeStreamWithError StreamInvalidXml Nothing - "Stream has no language tag" - -- If `from' is set, we verify that it's the correct one. TODO: Should we check against the realm instead? + + -- HACK: We ignore MUST-strength requirement (section 4.7.4. of RFC + -- 6120) for the sake of compatibility with jabber.org + -- | lt == Nothing -> + -- closeStreamWithError StreamInvalidXml Nothing + -- "Stream has no language tag" + + -- If `from' is set, we verify that it's the correct one. TODO: Should we + -- check against the realm instead? | isJust from && (from /= Just (Jid Nothing (fromJust $ streamAddress st) Nothing)) -> closeStreamWithError StreamInvalidFrom Nothing "Stream from is invalid" @@ -159,6 +164,9 @@ startStream = runErrorT $ do closeStreamWithError StreamUndefinedCondition (Just $ Element "invalid-to" [] []) "Stream to invalid"-- TODO: Suitable? | otherwise -> do + -- HACK: (ignore section 4.7.4. of RFC 6120), see above + unless (isJust lt) $ liftIO $ warningM "Pontariusm.Xmpp" + "Stream has no language tag" modify (\s -> s{ streamFeatures = features , streamLang = lt , streamId = sid @@ -178,8 +186,10 @@ startStream = runErrorT $ do "Root name prefix set and not stream" | otherwise -> ErrorT $ checkchildren (flattenAttrs attrs) where - -- closeStreamWithError :: MonadIO m => Stream -> StreamErrorCondition -> - -- Maybe Element -> ErrorT XmppFailure m () + -- HACK: We include the default namespace to make isode's M-LINK server happy. + streamNSHack e = e{elementAttributes = elementAttributes e + ++ [( "xmlns" + , [ContentText "jabber:client"])]} closeStreamWithError :: StreamErrorCondition -> Maybe Element -> String -> ErrorT XmppFailure (StateT StreamState IO) () closeStreamWithError sec el msg = do @@ -320,6 +330,9 @@ closeStreams' = do Right e -> collectElems (e:es) -- TODO: Can the TLS send/recv functions throw something other than an IO error? +debugOut :: MonadIO m => ByteString -> m () +debugOut outData = liftIO $ debugM "Pontarius.Xmpp" + ("Out: " ++ (Text.unpack . Text.decodeUtf8 $ outData)) wrapIOException :: IO a -> StateT StreamState IO (Either XmppFailure a) wrapIOException action = do @@ -333,7 +346,21 @@ wrapIOException action = do pushElement :: Element -> StateT StreamState IO (Either XmppFailure Bool) pushElement x = do send <- gets (streamSend . streamHandle) - wrapIOException $ send $ renderElement x + let outData = renderElement $ nsHack x + debugOut outData + wrapIOException $ send outData + where + -- HACK: We remove the "jabber:client" namespace because it is set as + -- default in the stream. This is to make isode's M-LINK server happy and + -- should be removed once jabber.org accepts prefix-free canonicalization + nsHack e@(Element{elementName = n}) + | nameNamespace n == Just "jabber:client" = + e{ elementName = Name (nameLocalName n) Nothing Nothing + , elementNodes = map mapNSHack $ elementNodes e + } + | otherwise = e + mapNSHack (NodeElement e) = NodeElement $ nsHack e + mapNSHack n = n -- | Encode and send stanza pushStanza :: Stanza -> Stream -> IO (Either XmppFailure Bool) @@ -350,8 +377,10 @@ pushXmlDecl = do pushOpenElement :: Element -> StateT StreamState IO (Either XmppFailure Bool) pushOpenElement e = do - sink <- gets (streamSend . streamHandle) - wrapIOException $ sink $ renderOpenElement e + send <- gets (streamSend . streamHandle) + let outData = renderOpenElement e + debugOut outData + wrapIOException $ send outData -- `Connect-and-resumes' the given sink to the stream source, and pulls a -- `b' value. @@ -442,7 +471,7 @@ xmppNoStream = StreamState { where zeroSource :: Source IO output zeroSource = liftIO $ do - errorM "Pontarius.XMPP" "zeroSource utilized." + errorM "Pontarius.Xmpp" "zeroSource utilized." ExL.throwIO XmppOtherFailure createStream :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (Stream) @@ -481,7 +510,7 @@ createStream realm config = do where logConduit :: Conduit ByteString IO ByteString logConduit = CL.mapM $ \d -> do - debugM "Pontarius.Xmpp" $ "Received TCP data: " ++ (BSC8.unpack d) ++ + debugM "Pontarius.Xmpp" $ "In: " ++ (BSC8.unpack d) ++ "." return d @@ -755,7 +784,7 @@ withStream action (Stream stream) = Ex.bracketOnError ) -- nonblocking version. Changes to the connection are ignored! -withStream' :: StateT StreamState IO (Either XmppFailure b) -> Stream -> IO (Either XmppFailure b) +withStream' :: StateT StreamState IO a -> Stream -> IO a withStream' action (Stream stream) = do stream_ <- atomically $ readTMVar stream (r, _) <- runStateT action stream_ diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs index 88b56f1..c4e70b4 100644 --- a/source/Network/Xmpp/Tls.hs +++ b/source/Network/Xmpp/Tls.hs @@ -22,10 +22,21 @@ import System.Log.Logger (debugM, errorM) mkBackend :: StreamHandle -> Backend mkBackend con = Backend { backendSend = \bs -> void (streamSend con bs) - , backendRecv = streamReceive con + , backendRecv = bufferReceive (streamReceive con) , backendFlush = streamFlush con , backendClose = streamClose con } + where + bufferReceive _ 0 = return BS.empty + bufferReceive recv n = BS.concat `liftM` (go n) + where + go n = do + bs <- recv n + case BS.length bs of + 0 -> return [] + l -> if l < n + then (bs :) `liftM` go (n - l) + else return [bs] starttlsE :: Element starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index cc6e166..6720061 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -1048,8 +1048,8 @@ instance Default StreamConfiguration where , resolvConf = defaultResolvConf , establishSession = True , tlsBehaviour = PreferTls - , tlsParams = defaultParamsClient { pConnectVersion = TLS12 - , pAllowedVersions = [TLS12] + , tlsParams = defaultParamsClient { pConnectVersion = TLS10 + , pAllowedVersions = [TLS10, TLS11, TLS12] , pCiphers = ciphersuite_strong } } From c7c4a292195e12e16da93dbecb9a884acb765001 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sat, 23 Mar 2013 18:27:19 +0100 Subject: [PATCH 15/26] Fix loggin in Network.Xmpp.Tls and minor cleanups --- source/Network/Xmpp/Concurrent.hs | 1 - source/Network/Xmpp/Sasl/Common.hs | 12 ++++----- source/Network/Xmpp/Sasl/Mechanisms/Scram.hs | 6 ++--- source/Network/Xmpp/Tls.hs | 27 ++++++++++---------- 4 files changed, 22 insertions(+), 24 deletions(-) diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index eaa5943..6896473 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -42,7 +42,6 @@ import Network.Xmpp.Tls import Network.Xmpp.Types import Network.Xmpp.Utilities - runHandlers :: (TChan Stanza) -> [StanzaHandler] -> Stanza -> IO () runHandlers _ [] _ = return () runHandlers outC (h:hands) sta = do diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index 47f8744..fb15668 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -186,12 +186,12 @@ prepCredentials authcid authzid password = case credentials of Just creds -> return creds where credentials = do - ac <- normalizeUsername authcid - az <- case authzid of - Nothing -> Just Nothing - Just az' -> Just <$> normalizeUsername az' - pw <- normalizePassword password - return (ac, az, pw) + ac <- normalizeUsername authcid + az <- case authzid of + Nothing -> Just Nothing + Just az' -> Just <$> normalizeUsername az' + pw <- normalizePassword password + return (ac, az, pw) -- | Bit-wise xor of byte strings xorBS :: BS.ByteString -> BS.ByteString -> BS.ByteString diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs index c7b2572..d7a5515 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs @@ -72,9 +72,9 @@ scram hToken authcid authzid password = do gs2Header :: BS.ByteString gs2Header = merge $ [ gs2CbindFlag - , maybe "" id authzid'' - , "" - ] + , maybe "" id authzid'' + , "" + ] -- cbindData :: BS.ByteString -- cbindData = "" -- we don't support channel binding yet diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs index c4e70b4..3027b85 100644 --- a/source/Network/Xmpp/Tls.hs +++ b/source/Network/Xmpp/Tls.hs @@ -18,7 +18,7 @@ import Data.XML.Types import Network.TLS import Network.Xmpp.Stream import Network.Xmpp.Types -import System.Log.Logger (debugM, errorM) +import System.Log.Logger (debugM, errorM, infoM) mkBackend :: StreamHandle -> Backend mkBackend con = Backend { backendSend = \bs -> void (streamSend con bs) @@ -51,27 +51,29 @@ tls con = Ex.handle (return . Left . TlsError) case sState of Plain -> return () Closed -> do - liftIO $ errorM "Pontarius.XMPP" "startTls: The stream is closed." + liftIO $ errorM "Pontarius.Xmpp" "startTls: The stream is closed." throwError XmppNoStream Secured -> do - liftIO $ errorM "Pontarius.XMPP" "startTls: The stream is already secured." + liftIO $ errorM "Pontarius.Xmpp" "startTls: The stream is already secured." throwError TlsStreamSecured features <- lift $ gets streamFeatures case (tlsBehaviour conf, streamTls features) of (RequireTls , Just _ ) -> startTls (RequireTls , Nothing ) -> throwError TlsNoServerSupport (PreferTls , Just _ ) -> startTls - (PreferTls , Nothing ) -> return () + (PreferTls , Nothing ) -> skipTls (PreferPlain , Just True) -> startTls - (PreferPlain , _ ) -> return () + (PreferPlain , _ ) -> skipTls (RefuseTls , Just True) -> throwError XmppOtherFailure - (RefuseTls , _ ) -> return () + (RefuseTls , _ ) -> skipTls where + skipTls = liftIO $ infoM "Pontarius.Xmpp" "Skipping TLS negotiation" startTls = do + liftIO $ infoM "Pontarius.Xmpp" "Running StartTLS" params <- gets $ tlsParams . streamConfiguration sent <- ErrorT $ pushElement starttlsE unless sent $ do - liftIO $ errorM "Pontarius.XMPP" "startTls: Could not sent stanza." + liftIO $ errorM "Pontarius.Xmpp" "startTls: Could not sent stanza." throwError XmppOtherFailure answer <- lift $ pullElement case answer of @@ -79,10 +81,10 @@ tls con = Ex.handle (return . Left . TlsError) Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] []) -> return () Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _) -> do - liftIO $ errorM "Pontarius.XMPP" "startTls: TLS initiation failed." + liftIO $ errorM "Pontarius.Xmpp" "startTls: TLS initiation failed." throwError XmppOtherFailure Right r -> - liftIO $ errorM "Pontarius.XMPP" $ + liftIO $ errorM "Pontarius.Xmpp" $ "startTls: Unexpected element: " ++ show r hand <- gets streamHandle (_raw, _snk, psh, recv, ctx) <- lift $ tlsinit params (mkBackend hand) @@ -92,6 +94,7 @@ tls con = Ex.handle (return . Left . TlsError) , streamClose = bye ctx >> streamClose hand } lift $ modify ( \x -> x {streamHandle = newHand}) + liftIO $ infoM "Pontarius.Xmpp" "Stream Secured." either (lift . Ex.throwIO) return =<< lift restartStream modify (\s -> s{streamConnectionState = Secured}) return () @@ -127,15 +130,11 @@ tlsinit params backend = do Nothing -> return () Just x -> do sendData con (BL.fromChunks [x]) - liftIO $ debugM "Pontarius.Xmpp.TLS" - ("out :" ++ BSC8.unpack x) snk readWithBuffer <- liftIO $ mkReadBuffer (recvData con) return ( src , snk - , \s -> do - liftIO $ debugM "Pontarius.Xmpp.TLS" ("out :" ++ BSC8.unpack s) - sendData con $ BL.fromChunks [s] + , \s -> sendData con $ BL.fromChunks [s] , liftIO . readWithBuffer , con ) From 058d63f0e0037532557cbd0282b92733c0f57219 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sat, 23 Mar 2013 18:28:33 +0100 Subject: [PATCH 16/26] add rosterAdd and rosterRemove --- source/Network/Xmpp/IM.hs | 2 ++ source/Network/Xmpp/IM/Roster.hs | 54 +++++++++++++++++++++++++++++++- 2 files changed, 55 insertions(+), 1 deletion(-) diff --git a/source/Network/Xmpp/IM.hs b/source/Network/Xmpp/IM.hs index d8793a0..70d1510 100644 --- a/source/Network/Xmpp/IM.hs +++ b/source/Network/Xmpp/IM.hs @@ -13,6 +13,8 @@ module Network.Xmpp.IM , Roster(..) , Item(..) , getRoster + , rosterAdd + , rosterRemove ) where import Network.Xmpp.IM.Message diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs index cd7a0ca..6d20f2c 100644 --- a/source/Network/Xmpp/IM/Roster.hs +++ b/source/Network/Xmpp/IM/Roster.hs @@ -7,8 +7,10 @@ module Network.Xmpp.IM.Roster where import Control.Concurrent.STM import Control.Monad +import Data.List (nub) import qualified Data.Map.Strict as Map import Data.Maybe (isJust) +import Data.Text (Text) import Data.XML.Pickle import Data.XML.Types import System.Log.Logger @@ -19,6 +21,45 @@ import Network.Xmpp.Concurrent.Types import Network.Xmpp.Types import Network.Xmpp.Concurrent.IQ +-- | Push a roster item to the server. The values for approved and ask are +-- ignored and all values for subsciption except "remove" are ignored +rosterPush :: Item -> Session -> IO IQResponse +rosterPush item session = do + let el = pickleElem xpQuery (Query Nothing [fromItem item]) + sendIQ' Nothing Set Nothing el session + +-- | Add or update an item to the roster. +-- +-- To update the item just send the complete set of new data +rosterAdd :: Jid -- ^ JID of the item + -> Maybe Text -- ^ Name alias + -> [Text] -- ^ Groups (duplicates will be removed) + -> Session + -> IO IQResponse +rosterAdd j n gs session = do + let el = pickleElem xpQuery (Query Nothing + [QueryItem { qiApproved = Nothing + , qiAsk = False + , qiJid = j + , qiName = n + , qiSubscription = Nothing + , qiGroups = nub gs + }]) + sendIQ' Nothing Set Nothing el session + +-- | Remove an item from the roster. Return True when the item is sucessfully +-- removed or if it wasn't in the roster to begin with. +rosterRemove :: Jid -> Session -> IO Bool +rosterRemove j sess = do + roster <- getRoster sess + case Map.lookup j (items roster) of + Nothing -> return True -- jid is not on the Roster + Just _ -> do + res <- rosterPush (Item False False j Nothing Remove []) sess + case res of + IQResponseResult IQResult{} -> return True + _ -> return False + getRoster :: Session -> IO Roster getRoster session = atomically $ readTVar (rosterRef session) @@ -98,9 +139,20 @@ toItem qi = Item { approved = maybe False id (qiApproved qi) , jid = qiJid qi , name = qiName qi , subscription = maybe None id (qiSubscription qi) - , groups = qiGroups qi + , groups = nub $ qiGroups qi } +fromItem :: Item -> QueryItem +fromItem i = QueryItem { qiApproved = Nothing + , qiAsk = False + , qiJid = jid i + , qiName = name i + , qiSubscription = case subscription i of + Remove -> Just Remove + _ -> Nothing + , qiGroups = nub $ groups i + } + xpItems :: PU [Node] [QueryItem] xpItems = xpWrap (map (\((app_, ask_, jid_, name_, sub_), groups_) -> QueryItem app_ ask_ jid_ name_ sub_ groups_)) From 13b27686db1f0938c55260bb516f93181a7f230e Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sat, 23 Mar 2013 18:34:14 +0100 Subject: [PATCH 17/26] clear warning in Network.Xmpp.Tls --- source/Network/Xmpp/Tls.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs index 3027b85..f9f1745 100644 --- a/source/Network/Xmpp/Tls.hs +++ b/source/Network/Xmpp/Tls.hs @@ -30,12 +30,12 @@ mkBackend con = Backend { backendSend = \bs -> void (streamSend con bs) bufferReceive _ 0 = return BS.empty bufferReceive recv n = BS.concat `liftM` (go n) where - go n = do - bs <- recv n + go m = do + bs <- recv m case BS.length bs of 0 -> return [] - l -> if l < n - then (bs :) `liftM` go (n - l) + l -> if l < m + then (bs :) `liftM` go (m - l) else return [bs] starttlsE :: Element From fad5e3738404c1b8cb0d6c18cf2460812f81591b Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 24 Mar 2013 17:46:00 +0100 Subject: [PATCH 18/26] add dropIQChan --- source/Network/Xmpp.hs | 1 + source/Network/Xmpp/Concurrent/IQ.hs | 15 +++++++++++++++ 2 files changed, 16 insertions(+) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index cfb2c14..87d56f1 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -138,6 +138,7 @@ module Network.Xmpp , sendIQ' , answerIQ , listenIQChan + , dropIQChan -- * Errors , StanzaError(..) , StanzaErrorType(..) diff --git a/source/Network/Xmpp/Concurrent/IQ.hs b/source/Network/Xmpp/Concurrent/IQ.hs index d41e8cf..54f4a17 100644 --- a/source/Network/Xmpp/Concurrent/IQ.hs +++ b/source/Network/Xmpp/Concurrent/IQ.hs @@ -83,6 +83,21 @@ listenIQChan tp ns session = do Nothing -> Right iqCh Just iqCh' -> Left iqCh' +-- | Unregister a previously acquired IQ channel. Please make sure that you +-- where the one who acquired it in the first place as no check for ownership +-- can be made +dropIQChan :: IQRequestType -- ^ Type of IQ ('Get' or 'Set') + -> Text -- ^ Namespace of the child element + -> Session + -> IO () +dropIQChan tp ns session = do + let handlers = (iqHandlers session) + atomically $ do + (byNS, byID) <- readTVar handlers + let byNS' = Map.delete (tp, ns) byNS + writeTVar handlers (byNS', byID) + return () + answerIQ :: IQRequestTicket -> Either StanzaError (Maybe Element) -> Session From c0f97175d4db2f060f1a96b54f650704258615cc Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 24 Mar 2013 17:46:12 +0100 Subject: [PATCH 19/26] fix haddock documentation --- source/Network/Xmpp/Concurrent/IQ.hs | 9 +++++++-- source/Network/Xmpp/Stream.hs | 2 +- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/source/Network/Xmpp/Concurrent/IQ.hs b/source/Network/Xmpp/Concurrent/IQ.hs index 54f4a17..a3c1860 100644 --- a/source/Network/Xmpp/Concurrent/IQ.hs +++ b/source/Network/Xmpp/Concurrent/IQ.hs @@ -62,9 +62,14 @@ sendIQ' to tp lang body session = do -- | Retrieves an IQ listener channel. If the namespace/'IQRequestType' is not -- already handled, a new 'TChan' is created and returned as a 'Right' value. -- Otherwise, the already existing channel will be returned wrapped in a 'Left' --- value. Note that the 'Left' channel might need to be duplicated in order not +-- value. The 'Left' channel might need to be duplicated in order not -- to interfere with existing consumers. -listenIQChan :: IQRequestType -- ^ Type of IQs to receive (@Get@ or @Set@) +-- +-- Note thet every 'IQRequest' must be answered exactly once. To insure this, +-- the incoming requests are wrapped in an 'IQRequestTicket' that prevents +-- multiple responses. Use 'iqRequestBody' to extract the corresponding request +-- and 'answerIQ' to send the response +listenIQChan :: IQRequestType -- ^ Type of IQs to receive ('Get' or 'Set') -> Text -- ^ Namespace of the child element -> Session -> IO (Either (TChan IQRequestTicket) (TChan IQRequestTicket)) diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 2310131..110f0c2 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -151,7 +151,7 @@ startStream = runErrorT $ do -- HACK: We ignore MUST-strength requirement (section 4.7.4. of RFC -- 6120) for the sake of compatibility with jabber.org - -- | lt == Nothing -> + -- | lt == Nothing -> -- closeStreamWithError StreamInvalidXml Nothing -- "Stream has no language tag" From 520a2457f97b2f00de58f29ef0ce38d4aff18fbd Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 9 Apr 2013 17:18:59 +0200 Subject: [PATCH 20/26] update types for conduit 1.0 --- source/Network/Xmpp/Stream.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 110f0c2..b760483 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -88,7 +88,7 @@ streamUnpickleElem p x = do -- This is the conduit sink that handles the stream XML events. We extend it -- with ErrorT capabilities. -type StreamSink a = ErrorT XmppFailure (Pipe Event Event Void () IO) a +type StreamSink a = ErrorT XmppFailure (ConduitM Event Void IO) a -- Discards all events before the first EventBeginElement. throwOutJunk :: Monad m => Sink Event m () @@ -720,7 +720,7 @@ pushIQ iqID to tp lang body stream = runErrorT $ do liftIO $ errorM "Pontarius.XMPP" $ "pushIQ: Unexpected stanza type." throwError XmppOtherFailure -debugConduit :: Pipe l ByteString ByteString u IO b +debugConduit :: (Show o, MonadIO m) => ConduitM o o m b debugConduit = forever $ do s' <- await case s' of From 2303f31c2b22d0f4af93c44d18e064cbead85822 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 9 Apr 2013 17:22:56 +0200 Subject: [PATCH 21/26] use cryptohash-cryptoapi (cryptohash 0.9 deprecates cryptoapi api) --- source/Network/Xmpp/Sasl/Mechanisms/Scram.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs index d7a5515..01ce054 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs @@ -9,15 +9,15 @@ module Network.Xmpp.Sasl.Mechanisms.Scram import Control.Applicative ((<$>)) import Control.Monad.Error import Control.Monad.State.Strict -import qualified Crypto.Classes as Crypto -import qualified Crypto.HMAC as Crypto -import qualified Crypto.Hash.SHA1 as Crypto -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64 as B64 -import Data.ByteString.Char8 as BS8 (unpack) +import qualified Crypto.Classes as Crypto +import qualified Crypto.HMAC as Crypto +import qualified Crypto.Hash.CryptoAPI as Crypto +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import Data.ByteString.Char8 as BS8 (unpack) import Data.List (foldl1', genericTake) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import Network.Xmpp.Sasl.Common import Network.Xmpp.Sasl.Types import Network.Xmpp.Types From dbff66f559967be9d82ab75c0538e84031b34c3a Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Fri, 12 Apr 2013 20:21:39 +0200 Subject: [PATCH 22/26] update cabal file --- pontarius-xmpp.cabal | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index a1d8ab3..c12c252 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -33,11 +33,12 @@ Library , base64-bytestring >=0.1.0.0 , binary >=0.4.1 , bytestring >=0.9.1.9 - , conduit >=0.5 && <1.0 + , conduit >=0.5 , containers >=0.4.0.0 , crypto-api >=0.9 , crypto-random-api >=0.2 , cryptohash >=0.6.1 + , cryptohash-cryptoapi >=0.1 , data-default >=0.2 , dns >=0.3.0 , hslogger >=1.1.0 @@ -58,7 +59,7 @@ Library , void >=0.5.5 , xml-types >=0.3.1 , xml-conduit >=1.0 - , xml-picklers >=0.3 + , xml-picklers >=0.3.2 Exposed-modules: Network.Xmpp , Network.Xmpp.Internal Other-modules: Network.Xmpp.Concurrent From 570cdafd43737275e8ac9e179edfe738cbf9551f Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 14 Apr 2013 18:00:23 +0200 Subject: [PATCH 23/26] Improve RFC 6121 (XMPP-IM) code. Move the functionality from Network.Xmpp.IM.Message and *.Presence to Network.Xmpp.Stanza since it is not specific to RFC 6121. Implement presence functionality of RFC 6121 Fix hslint errors and warning --- pontarius-xmpp.cabal | 12 +- source/Network/Xmpp.hs | 10 +- source/Network/Xmpp/IM.hs | 23 ++-- source/Network/Xmpp/IM/Message.hs | 183 +++++++++++++---------------- source/Network/Xmpp/IM/Presence.hs | 113 ++++++++---------- source/Network/Xmpp/IM/Roster.hs | 52 ++++---- source/Network/Xmpp/Stanza.hs | 76 ++++++++++++ source/Network/Xmpp/Utilities.hs | 39 +----- 8 files changed, 268 insertions(+), 240 deletions(-) create mode 100644 source/Network/Xmpp/Stanza.hs diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index c12c252..81680b1 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -61,15 +61,20 @@ Library , xml-conduit >=1.0 , xml-picklers >=0.3.2 Exposed-modules: Network.Xmpp + , Network.Xmpp.IM , Network.Xmpp.Internal Other-modules: Network.Xmpp.Concurrent - , Network.Xmpp.Concurrent.Types , Network.Xmpp.Concurrent.Basic , Network.Xmpp.Concurrent.IQ , Network.Xmpp.Concurrent.Message + , Network.Xmpp.Concurrent.Monad , Network.Xmpp.Concurrent.Presence , Network.Xmpp.Concurrent.Threads - , Network.Xmpp.Concurrent.Monad + , Network.Xmpp.Concurrent.Types + , Network.Xmpp.IM.Message + , Network.Xmpp.IM.Presence + , Network.Xmpp.IM.Roster + , Network.Xmpp.IM.Roster.Types , Network.Xmpp.Marshal , Network.Xmpp.Sasl , Network.Xmpp.Sasl.Common @@ -79,12 +84,11 @@ Library , Network.Xmpp.Sasl.Mechanisms.Scram , Network.Xmpp.Sasl.StringPrep , Network.Xmpp.Sasl.Types + , Network.Xmpp.Stanza , Network.Xmpp.Stream , Network.Xmpp.Tls , Network.Xmpp.Types , Network.Xmpp.Utilities - , Network.Xmpp.IM.Roster - , Network.Xmpp.IM.Roster.Types GHC-Options: -Wall Source-Repository head diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 87d56f1..d864b26 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -82,6 +82,7 @@ module Network.Xmpp -- occur in a system such as email. It is not to be confused with -- /instant messaging/ which is handled in the 'Network.Xmpp.IM' module , Message(..) + , message , MessageError(..) , MessageType(..) -- *** Creating @@ -103,6 +104,12 @@ module Network.Xmpp , PresenceType(..) , PresenceError(..) -- *** Creating + , presence + , presenceOffline + , presenceOnline + , presenceSubscribe + , presenceSubscribed + , presenceUnsubscribe , presTo -- *** Sending -- | Sends a presence stanza. In general, the presence stanza should have no @@ -157,7 +164,8 @@ module Network.Xmpp ) where import Network.Xmpp.Concurrent -import Network.Xmpp.Utilities import Network.Xmpp.Sasl import Network.Xmpp.Sasl.Types +import Network.Xmpp.Stanza import Network.Xmpp.Types +import Network.Xmpp.Utilities diff --git a/source/Network/Xmpp/IM.hs b/source/Network/Xmpp/IM.hs index 70d1510..2f5bf08 100644 --- a/source/Network/Xmpp/IM.hs +++ b/source/Network/Xmpp/IM.hs @@ -1,14 +1,19 @@ +-- | RFC 6121: Instant Messaging and Presence +-- module Network.Xmpp.IM ( -- * Instant Messages - subject - , thread - , body - , bodies - , newIM - , simpleIM - , answerIM - -- * Presence - , module Network.Xmpp.IM.Presence + MessageBody(..) + , MessageThread(..) + , MessageSubject(..) + , instantMessage + , getIM + , withIM + -- * Presence + , ShowStatus(..) + , IMPresence(..) + , imPresence + , getIMPresence + , withIMPresence -- * Roster , Roster(..) , Item(..) diff --git a/source/Network/Xmpp/IM/Message.hs b/source/Network/Xmpp/IM/Message.hs index e5aa830..070a479 100644 --- a/source/Network/Xmpp/IM/Message.hs +++ b/source/Network/Xmpp/IM/Message.hs @@ -1,119 +1,64 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK hide #-} -module Network.Xmpp.IM.Message - where +module Network.Xmpp.IM.Message where -import Control.Applicative ((<$>)) - -import Data.Maybe (maybeToList, listToMaybe) import Data.Text (Text) import Data.XML.Pickle import Data.XML.Types - import Network.Xmpp.Marshal import Network.Xmpp.Types +import Network.Xmpp.Stanza +import Data.List +import Data.Function + -data MessageBody = MessageBody { bodyLang :: (Maybe LangTag) +data MessageBody = MessageBody { bodyLang :: Maybe LangTag , bodyContent :: Text } -data MessageThread = MessageThread { theadID :: Text - , threadParent :: (Maybe Text) +data MessageThread = MessageThread { theadID :: Text + , threadParent :: Maybe Text } -data MessageSubject = MessageSubject { subjectLang :: (Maybe LangTag) +data MessageSubject = MessageSubject { subjectLang :: Maybe LangTag , subjectContent :: Text } -xpMessageSubject :: PU [Element] MessageSubject -xpMessageSubject = xpUnliftElems . - xpWrap (\(l, s) -> MessageSubject l s) - (\(MessageSubject l s) -> (l,s)) - $ xpElem "{jabber:client}subject" xpLangTag $ xpContent xpId +-- | The instant message (IM) specific part of a message. +data InstantMessage = InstantMessage { imThread :: Maybe MessageThread + , imSubject :: [MessageSubject] + , imBody :: [MessageBody] + } -xpMessageBody :: PU [Element] MessageBody -xpMessageBody = xpUnliftElems . - xpWrap (\(l, s) -> MessageBody l s) - (\(MessageBody l s) -> (l,s)) - $ xpElem "{jabber:client}body" xpLangTag $ xpContent xpId +instantMessage :: InstantMessage +instantMessage = InstantMessage { imThread = Nothing + , imSubject = [] + , imBody = [] + } -xpMessageThread :: PU [Element] MessageThread -xpMessageThread = xpUnliftElems - . xpWrap (\(t, p) -> MessageThread p t) - (\(MessageThread p t) -> (t,p)) - $ xpElem "{jabber:client}thread" - (xpAttrImplied "parent" xpId) - (xpContent xpId) +-- | Get the IM specific parts of a message. Returns 'Nothing' when the received +-- payload is not valid IM data. +getIM :: Message -> Maybe InstantMessage +getIM im = either (const Nothing) Just . unpickle xpIM $ messagePayload im --- | Get the subject elements of a message (if any). Messages may --- contain multiple subjects if each of them has a distinct xml:lang --- attribute -subject :: Message -> [MessageSubject] -subject m = ms - where - -- xpFindMatches will _always_ return Right - Right ms = unpickle (xpFindMatches xpMessageSubject) $ messagePayload m - --- | Get the thread elements of a message (if any). The thread of a --- message is considered opaque, that is, no meaning, other than it's --- literal identity, may be derived from it and it is not human --- readable -thread :: Message -> Maybe MessageThread -thread m = ms - where - -- xpFindMatches will _always_ return Right - Right ms = unpickle (xpOption xpMessageThread) $ messagePayload m - --- | Get the body elements of a message (if any). Messages may contain --- multiple bodies if each of them has a distinct xml:lang attribute -bodies :: Message -> [MessageBody] -bodies m = ms - where - -- xpFindMatches will _always_ return Right - Right ms = unpickle (xpFindMatches xpMessageBody) $ messagePayload m - --- | Return the first body element, regardless of it's language. -body :: Message -> Maybe Text -body m = bodyContent <$> listToMaybe (bodies m) - --- | Generate a new instant message -newIM - :: Jid - -> Maybe StanzaID - -> Maybe LangTag - -> MessageType - -> Maybe MessageSubject - -> Maybe MessageThread - -> Maybe MessageBody - -> [Element] - -> Message -newIM t i lang tp sbj thrd bdy payload = Message - { messageID = i - , messageFrom = Nothing - , messageTo = Just t - , messageLangTag = lang - , messageType = tp - , messagePayload = concat $ - maybeToList (pickle xpMessageSubject <$> sbj) - ++ maybeToList (pickle xpMessageThread <$> thrd) - ++ maybeToList (pickle xpMessageBody <$> bdy) - ++ [payload] - } +sanitizeIM :: InstantMessage -> InstantMessage +sanitizeIM im = im{imBody = nubBy ((==) `on` bodyLang) $ imBody im} + +-- | Append IM data to a message +withIM :: Message -> InstantMessage -> Message +withIM m im = m{ messagePayload = messagePayload m + ++ pickleTree xpIM (sanitizeIM im) } + +imToElements :: InstantMessage -> [Element] +imToElements im = pickle xpIM (sanitizeIM im) -- | Generate a simple message simpleIM :: Jid -- ^ recipient -> Text -- ^ body -> Message -simpleIM t bd = newIM - t - Nothing - Nothing - Normal - Nothing - Nothing - (Just $ MessageBody Nothing bd) - [] +simpleIM to bd = withIM message{messageTo = Just to} + instantMessage{imBody = [MessageBody Nothing bd]} -- | Generate an answer from a received message. The recepient is -- taken from the original sender, the sender is set to Nothing, @@ -121,17 +66,47 @@ simpleIM t bd = newIM -- thread are inherited, the remaining payload is replaced by the -- given one. -- --- If multiple message bodies are given they must have different language tags -answerIM :: [MessageBody] -> [Element] -> Message -> Message -answerIM bd payload msg = Message - { messageID = messageID msg - , messageFrom = Nothing - , messageTo = messageFrom msg - , messageLangTag = messageLangTag msg - , messageType = messageType msg - , messagePayload = concat $ - (pickle xpMessageSubject <$> subject msg) - ++ maybeToList (pickle xpMessageThread <$> thread msg) - ++ (pickle xpMessageBody <$> bd) - ++ [payload] - } +-- If multiple message bodies are given they MUST have different language tags +answerIM :: [MessageBody] -> Message -> Maybe Message +answerIM bd msg = case getIM msg of + Nothing -> Nothing + Just im -> Just $ flip withIM (im{imBody = bd}) $ + message { messageID = messageID msg + , messageFrom = Nothing + , messageTo = messageFrom msg + , messageLangTag = messageLangTag msg + , messageType = messageType msg + } + +-------------------------- +-- Picklers -------------- +-------------------------- +xpIM :: PU [Element] InstantMessage +xpIM = xpWrap (\(t, s, b) -> InstantMessage t s b) + (\(InstantMessage t s b) -> (t, s, b)) $ + xp3Tuple + xpMessageThread + xpMessageSubject + xpMessageBody + + +xpMessageSubject :: PU [Element] [MessageSubject] +xpMessageSubject = xpUnliftElems . + xpWrap (map $ \(l, s) -> MessageSubject l s) + (map $ \(MessageSubject l s) -> (l,s)) + $ xpElems "{jabber:client}subject" xpLangTag $ xpContent xpId + +xpMessageBody :: PU [Element] [MessageBody] +xpMessageBody = xpUnliftElems . + xpWrap (map $ \(l, s) -> MessageBody l s) + (map $ \(MessageBody l s) -> (l,s)) + $ xpElems "{jabber:client}body" xpLangTag $ xpContent xpId + +xpMessageThread :: PU [Element] (Maybe MessageThread) +xpMessageThread = xpUnliftElems + . xpOption + . xpWrap (\(t, p) -> MessageThread p t) + (\(MessageThread p t) -> (t,p)) + $ xpElem "{jabber:client}thread" + (xpAttrImplied "parent" xpId) + (xpContent xpId) diff --git a/source/Network/Xmpp/IM/Presence.hs b/source/Network/Xmpp/IM/Presence.hs index 773c04d..c8fdb9d 100644 --- a/source/Network/Xmpp/IM/Presence.hs +++ b/source/Network/Xmpp/IM/Presence.hs @@ -1,75 +1,66 @@ {-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} module Network.Xmpp.IM.Presence where -import Network.Xmpp.Types +import Data.Text (Text) +import Data.XML.Pickle +import Data.XML.Types +import Network.Xmpp.Types --- | An empty presence. -presence :: Presence -presence = Presence { presenceID = Nothing - , presenceFrom = Nothing - , presenceTo = Nothing - , presenceLangTag = Nothing - , presenceType = Nothing - , presencePayload = [] - } +data ShowStatus = StatusAway + | StatusChat + | StatusDnd + | StatusXa --- | Request subscription with an entity. -presenceSubscribe :: Jid -> Presence -presenceSubscribe to = presence { presenceTo = Just to - , presenceType = Just Subscribe - } +instance Show ShowStatus where + show StatusAway = "away" + show StatusChat = "chat" + show StatusDnd = "dnd" + show StatusXa = "xa" --- | Is presence a subscription request? -isPresenceSubscribe :: Presence -> Bool -isPresenceSubscribe pres = presenceType pres == (Just Subscribe) +instance Read ShowStatus where + readsPrec _ "away" = [(StatusAway, "")] + readsPrec _ "chat" = [(StatusChat, "")] + readsPrec _ "dnd" = [(StatusDnd , "")] + readsPrec _ "xa" = [(StatusXa , "")] + readsPrec _ _ = [] --- | Approve a subscripton of an entity. -presenceSubscribed :: Jid -> Presence -presenceSubscribed to = presence { presenceTo = Just to - , presenceType = Just Subscribed - } +data IMPresence = IMP { showStatus :: Maybe ShowStatus + , status :: Maybe Text + , priority :: Maybe Int + } --- | Is presence a subscription approval? -isPresenceSubscribed :: Presence -> Bool -isPresenceSubscribed pres = presenceType pres == (Just Subscribed) +imPresence :: IMPresence +imPresence = IMP { showStatus = Nothing + , status = Nothing + , priority = Nothing + } --- | End a subscription with an entity. -presenceUnsubscribe :: Jid -> Presence -presenceUnsubscribe to = presence { presenceTo = Just to - , presenceType = Just Unsubscribed - } --- | Is presence an unsubscription request? -isPresenceUnsubscribe :: Presence -> Bool -isPresenceUnsubscribe pres = presenceType pres == (Just Unsubscribe) +getIMPresence :: Presence -> Maybe IMPresence +getIMPresence pres = case unpickle xpIMPresence (presencePayload pres) of + Left _ -> Nothing + Right r -> Just r --- | Signal to the server that the client is available for communication. -presenceOnline :: Presence -presenceOnline = presence +withIMPresence :: IMPresence -> Presence -> Presence +withIMPresence imPres pres = pres{presencePayload = presencePayload pres + ++ pickleTree xpIMPresence + imPres} --- | Signal to the server that the client is no longer available for --- communication. -presenceOffline :: Presence -presenceOffline = presence {presenceType = Just Unavailable} +-- +-- Picklers +-- ----- Change your status ---status --- :: Maybe Text -- ^ Status message --- -> Maybe ShowType -- ^ Status Type --- -> Maybe Int -- ^ Priority --- -> Presence ---status txt showType prio = presence { presenceShowType = showType --- , presencePriority = prio --- , presenceStatus = txt --- } - --- | Set the current availability status. This implicitly sets the client's --- status online. ---presenceAvail :: ShowType -> Presence ---presenceAvail showType = status Nothing (Just showType) Nothing - --- | Set the current status message. This implicitly sets the client's status --- online. ---presenceMessage :: Text -> Presence ---presenceMessage txt = status (Just txt) Nothing Nothing +xpIMPresence :: PU [Element] IMPresence +xpIMPresence = xpUnliftElems $ + xpWrap (\(s, st, p) -> IMP s st p) + (\(IMP s st p) -> (s, st, p)) $ + xp3Tuple + (xpOption $ xpElemNodes "{jabber:client}show" + (xpContent xpPrim)) + (xpOption $ xpElemNodes "{jabber:client}status" + (xpContent xpText)) + (xpOption $ xpElemNodes "{jabber:client}priority" + (xpContent xpPrim)) diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs index 6d20f2c..7658bc3 100644 --- a/source/Network/Xmpp/IM/Roster.hs +++ b/source/Network/Xmpp/IM/Roster.hs @@ -1,5 +1,4 @@ {-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} @@ -9,7 +8,7 @@ import Control.Concurrent.STM import Control.Monad import Data.List (nub) import qualified Data.Map.Strict as Map -import Data.Maybe (isJust) +import Data.Maybe (isJust, fromMaybe) import Data.Text (Text) import Data.XML.Pickle import Data.XML.Types @@ -60,9 +59,11 @@ rosterRemove j sess = do IQResponseResult IQResult{} -> return True _ -> return False +-- | Retrieve the current Roster state getRoster :: Session -> IO Roster getRoster session = atomically $ readTVar (rosterRef session) +-- | Get the initial roster / refresh the roster. You don't need to call this on your own initRoster :: Session -> IO () initRoster session = do oldRoster <- getRoster session @@ -74,26 +75,25 @@ initRoster session = do Just roster -> atomically $ writeTVar (rosterRef session) roster handleRoster :: TVar Roster -> TChan Stanza -> Stanza -> IO Bool -handleRoster ref outC sta = do - case sta of - IQRequestS (iqr@IQRequest{iqRequestPayload = - iqb@Element{elementName = en}}) - | nameNamespace en == Just "jabber:iq:roster" -> do - case iqRequestFrom iqr of - Just _from -> return True -- Don't handle roster pushes from - -- unauthorized sources - Nothing -> case unpickleElem xpQuery iqb of - Right Query{ queryVer = v - , queryItems = [update] - } -> do - handleUpdate v update - atomically . writeTChan outC $ result iqr - return False - _ -> do - errorM "Pontarius.Xmpp" "Invalid roster query" - atomically . writeTChan outC $ badRequest iqr - return False - _ -> return True +handleRoster ref outC sta = case sta of + IQRequestS (iqr@IQRequest{iqRequestPayload = + iqb@Element{elementName = en}}) + | nameNamespace en == Just "jabber:iq:roster" -> do + case iqRequestFrom iqr of + Just _from -> return True -- Don't handle roster pushes from + -- unauthorized sources + Nothing -> case unpickleElem xpQuery iqb of + Right Query{ queryVer = v + , queryItems = [update] + } -> do + handleUpdate v update + atomically . writeTChan outC $ result iqr + return False + _ -> do + errorM "Pontarius.Xmpp" "Invalid roster query" + atomically . writeTChan outC $ badRequest iqr + return False + _ -> return True where handleUpdate v' update = atomically $ modifyTVar ref $ \(Roster v is) -> Roster (v' `mplus` v) $ case qiSubscription update of @@ -119,7 +119,7 @@ retrieveRoster oldRoster sess = do return Nothing Right ros' -> return . Just $ toRoster ros' IQResponseResult (IQResult{iqResultPayload = Nothing}) -> do - return $ oldRoster + return oldRoster -- sever indicated that no roster updates are necessary IQResponseTimeout -> do errorM "Pontarius.Xmpp.Roster" "getRoster: request timed out" @@ -134,11 +134,11 @@ retrieveRoster oldRoster sess = do is) toItem :: QueryItem -> Item -toItem qi = Item { approved = maybe False id (qiApproved qi) +toItem qi = Item { approved = fromMaybe False (qiApproved qi) , ask = qiAsk qi , jid = qiJid qi , name = qiName qi - , subscription = maybe None id (qiSubscription qi) + , subscription = fromMaybe None (qiSubscription qi) , groups = nub $ qiGroups qi } @@ -161,7 +161,7 @@ xpItems = xpWrap (map (\((app_, ask_, jid_, name_, sub_), groups_) -> xpElems "{jabber:iq:roster}item" (xp5Tuple (xpAttribute' "approved" xpBool) - (xpWrap (maybe False (const True)) + (xpWrap isJust (\p -> if p then Just () else Nothing) $ xpOption $ xpAttribute_ "ask" "subscribe") (xpAttribute "jid" xpPrim) diff --git a/source/Network/Xmpp/Stanza.hs b/source/Network/Xmpp/Stanza.hs new file mode 100644 index 0000000..ab3c68f --- /dev/null +++ b/source/Network/Xmpp/Stanza.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS_HADDOCK hide #-} + +-- | Stanza related functions and constants +-- + +module Network.Xmpp.Stanza where + +import Data.XML.Types +import Network.Xmpp.Types + + +-- | An empty message +message :: Message +message = Message { messageID = Nothing + , messageFrom = Nothing + , messageTo = Nothing + , messageLangTag = Nothing + , messageType = Normal + , messagePayload = [] + } + +-- | An empty presence. +presence :: Presence +presence = Presence { presenceID = Nothing + , presenceFrom = Nothing + , presenceTo = Nothing + , presenceLangTag = Nothing + , presenceType = Nothing + , presencePayload = [] + } + +-- | Request subscription with an entity. +presenceSubscribe :: Jid -> Presence +presenceSubscribe to = presence { presenceTo = Just to + , presenceType = Just Subscribe + } + +-- | Approve a subscripton of an entity. +presenceSubscribed :: Jid -> Presence +presenceSubscribed to = presence { presenceTo = Just to + , presenceType = Just Subscribed + } + +-- | End a subscription with an entity. +presenceUnsubscribe :: Jid -> Presence +presenceUnsubscribe to = presence { presenceTo = Just to + , presenceType = Just Unsubscribed + } + +-- | Signal to the server that the client is available for communication. +presenceOnline :: Presence +presenceOnline = presence + +-- | Signal to the server that the client is no longer available for +-- communication. +presenceOffline :: Presence +presenceOffline = presence {presenceType = Just Unavailable} + +-- | Produce an answer message with the given payload, switching the "from" and +-- "to" attributes in the original message. Produces a 'Nothing' value of the +-- provided message message has no from attribute. +answerMessage :: Message -> [Element] -> Maybe Message +answerMessage Message{messageFrom = Just frm, ..} payload = + Just Message{ messageFrom = messageTo + , messageID = Nothing + , messageTo = Just frm + , messagePayload = payload + , .. + } +answerMessage _ _ = Nothing + +-- | Add a recipient to a presence notification. +presTo :: Presence -> Jid -> Presence +presTo pres to = pres{presenceTo = Just to} diff --git a/source/Network/Xmpp/Utilities.hs b/source/Network/Xmpp/Utilities.hs index eef3c98..6d4cee3 100644 --- a/source/Network/Xmpp/Utilities.hs +++ b/source/Network/Xmpp/Utilities.hs @@ -1,13 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_HADDOCK hide #-} + module Network.Xmpp.Utilities - ( presTo - , message - , answerMessage - , openElementToEvents + ( openElementToEvents , renderOpenElement , renderElement , checkHostName @@ -23,39 +20,11 @@ import qualified Data.Text as Text import Data.Text(Text) import qualified Data.Text.Encoding as Text import Data.XML.Types -import Network.Xmpp.Types import Prelude import System.IO.Unsafe(unsafePerformIO) import qualified Text.XML.Stream.Render as TXSR import Text.XML.Unresolved as TXU --- | Add a recipient to a presence notification. -presTo :: Presence -> Jid -> Presence -presTo pres to = pres{presenceTo = Just to} - --- | An empty message. -message :: Message -message = Message { messageID = Nothing - , messageFrom = Nothing - , messageTo = Nothing - , messageLangTag = Nothing - , messageType = Normal - , messagePayload = [] - } - --- | Produce an answer message with the given payload, switching the "from" and --- "to" attributes in the original message. Produces a 'Nothing' value of the --- provided message message has no from attribute. -answerMessage :: Message -> [Element] -> Maybe Message -answerMessage Message{messageFrom = Just frm, ..} payload = - Just Message{ messageFrom = messageTo - , messageID = Nothing - , messageTo = Just frm - , messagePayload = payload - , .. - } -answerMessage _ _ = Nothing - openElementToEvents :: Element -> [Event] openElementToEvents (Element name as ns) = EventBeginElement name as : goN ns [] where @@ -85,7 +54,7 @@ renderElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO -- | Validates the hostname string in accordance with RFC 1123. checkHostName :: Text -> Maybe Text -checkHostName t = do +checkHostName t = eitherToMaybeHostName $ AP.parseOnly hostnameP t where eitherToMaybeHostName = either (const Nothing) Just @@ -105,6 +74,6 @@ hostnameP = do <|> do _ <- AP.satisfy (== '.') r <- hostnameP - if (Text.length label) + 1 + (Text.length r) > 255 + if Text.length label + 1 + Text.length r > 255 then fail "Hostname too long." else return $ Text.concat [label, Text.pack ".", r] From 48d0f6dbbb06f8e56fbdbd8ee2bf3de342a6275c Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 14 Apr 2013 23:51:46 +0200 Subject: [PATCH 24/26] fix IM Message and Presence pickler Avoid errors when there are other elements as well --- source/Network/Xmpp/IM/Message.hs | 5 +++-- source/Network/Xmpp/IM/Presence.hs | 5 +++-- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/source/Network/Xmpp/IM/Message.hs b/source/Network/Xmpp/IM/Message.hs index 070a479..7d5a4b2 100644 --- a/source/Network/Xmpp/IM/Message.hs +++ b/source/Network/Xmpp/IM/Message.hs @@ -83,8 +83,9 @@ answerIM bd msg = case getIM msg of -------------------------- xpIM :: PU [Element] InstantMessage xpIM = xpWrap (\(t, s, b) -> InstantMessage t s b) - (\(InstantMessage t s b) -> (t, s, b)) $ - xp3Tuple + (\(InstantMessage t s b) -> (t, s, b)) + . xpClean + $ xp3Tuple xpMessageThread xpMessageSubject xpMessageBody diff --git a/source/Network/Xmpp/IM/Presence.hs b/source/Network/Xmpp/IM/Presence.hs index c8fdb9d..dbfc4f5 100644 --- a/source/Network/Xmpp/IM/Presence.hs +++ b/source/Network/Xmpp/IM/Presence.hs @@ -54,9 +54,10 @@ withIMPresence imPres pres = pres{presencePayload = presencePayload pres -- xpIMPresence :: PU [Element] IMPresence -xpIMPresence = xpUnliftElems $ +xpIMPresence = xpUnliftElems . xpWrap (\(s, st, p) -> IMP s st p) - (\(IMP s st p) -> (s, st, p)) $ + (\(IMP s st p) -> (s, st, p)) . + xpClean $ xp3Tuple (xpOption $ xpElemNodes "{jabber:client}show" (xpContent xpPrim)) From b83de8a11bf631835ee146e51bd7d953c6cb8e60 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 30 Apr 2013 15:27:20 +0200 Subject: [PATCH 25/26] add getJid --- source/Network/Xmpp.hs | 1 + source/Network/Xmpp/Concurrent/Basic.hs | 8 ++++++++ 2 files changed, 9 insertions(+) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index d864b26..bc8281b 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -46,6 +46,7 @@ module Network.Xmpp , isFull , jidFromText , jidFromTexts + , getJid -- * Stanzas -- | The basic protocol data unit in XMPP is the XML stanza. The stanza is -- essentially a fragment of XML that is sent over a stream. @Stanzas@ come in diff --git a/source/Network/Xmpp/Concurrent/Basic.hs b/source/Network/Xmpp/Concurrent/Basic.hs index 5b16e4e..912cba5 100644 --- a/source/Network/Xmpp/Concurrent/Basic.hs +++ b/source/Network/Xmpp/Concurrent/Basic.hs @@ -3,7 +3,9 @@ module Network.Xmpp.Concurrent.Basic where import Control.Concurrent.STM import Network.Xmpp.Concurrent.Types +import Network.Xmpp.Stream import Network.Xmpp.Types +import Control.Monad.State.Strict -- | Send a stanza to the server. sendStanza :: Stanza -> Session -> IO () @@ -14,3 +16,9 @@ dupSession :: Session -> IO Session dupSession session = do stanzaCh' <- atomically $ dupTChan (stanzaCh session) return $ session {stanzaCh = stanzaCh'} + +-- | Return the JID assigned to us by the server +getJid :: Session -> IO (Maybe Jid) +getJid Session{streamRef = st} = do + s <- atomically $ readTMVar st + withStream' (gets streamJid) s From 0bb4f4dabb88b4f7b2901aae443386c0e214c78b Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 30 Apr 2013 15:29:01 +0200 Subject: [PATCH 26/26] refactor answerIQ. The ticket now contains the method to answer itself, so tickets can now be answered without needing access to the unerlying session. --- source/Network/Xmpp/Concurrent.hs | 20 ++++++++++++++++++-- source/Network/Xmpp/Concurrent/IQ.hs | 24 ++++-------------------- source/Network/Xmpp/Concurrent/Types.hs | 3 ++- 3 files changed, 24 insertions(+), 23 deletions(-) diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 6896473..c91c1c1 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -73,8 +73,24 @@ handleIQ iqHands outC sta = atomically $ do case Map.lookup (iqRequestType iq, iqNS) byNS of Nothing -> writeTChan outC $ serviceUnavailable iq Just ch -> do - sent <- newTVar False - writeTChan ch $ IQRequestTicket sent iq + sentRef <- newTVar False + let answerT answer = do + let IQRequest iqid from _to lang _tp bd = iq + response = case answer of + Left er -> IQErrorS $ IQError iqid Nothing + from lang er + (Just bd) + Right res -> IQResultS $ IQResult iqid Nothing + from lang res + atomically $ do + sent <- readTVar sentRef + case sent of + False -> do + writeTVar sentRef True + writeTChan outC response + return True + True -> return False + writeTChan ch $ IQRequestTicket answerT iq serviceUnavailable (IQRequest iqid from _to lang _tp bd) = IQErrorS $ IQError iqid Nothing from lang err (Just bd) err = StanzaError Cancel ServiceUnavailable Nothing Nothing diff --git a/source/Network/Xmpp/Concurrent/IQ.hs b/source/Network/Xmpp/Concurrent/IQ.hs index a3c1860..4b6c462 100644 --- a/source/Network/Xmpp/Concurrent/IQ.hs +++ b/source/Network/Xmpp/Concurrent/IQ.hs @@ -103,23 +103,7 @@ dropIQChan tp ns session = do writeTVar handlers (byNS', byID) return () -answerIQ :: IQRequestTicket - -> Either StanzaError (Maybe Element) - -> Session - -> IO Bool -answerIQ (IQRequestTicket - sRef - (IQRequest iqid from _to lang _tp bd)) - answer session = do - let response = case answer of - Left err -> IQErrorS $ IQError iqid Nothing from lang err (Just bd) - Right res -> IQResultS $ IQResult iqid Nothing from lang res - atomically $ do - sent <- readTVar sRef - case sent of - False -> do - writeTVar sRef True - - writeTChan (outCh session) response - return True - True -> return False +-- | Answer an IQ request. Only the first answer ist sent and then True is +-- returned. Subsequent answers are dropped and (False is returned in that case) +answerIQ :: IQRequestTicket -> Either StanzaError (Maybe Element) -> IO Bool +answerIQ ticket = answerTicket ticket diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index c98e45c..c2b97b8 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -10,6 +10,7 @@ import qualified Data.ByteString as BS import qualified Data.Map as Map import Data.Text (Text) import Data.Typeable +import Data.XML.Types (Element) import Network.Xmpp.IM.Roster.Types import Network.Xmpp.Types @@ -56,6 +57,6 @@ type IQHandlers = (Map.Map (IQRequestType, Text) (TChan IQRequestTicket) -- | Contains whether or not a reply has been sent, and the IQ request body to -- reply to. data IQRequestTicket = IQRequestTicket - { sentRef :: (TVar Bool) + { answerTicket :: Either StanzaError (Maybe Element) -> IO Bool , iqRequestBody :: IQRequest }