From 7a5699ee9b7fb7107ee487d1f642aace914273ae Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 19 Mar 2013 19:28:13 +0100 Subject: [PATCH 01/11] 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 92d9a40..de22e26 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 3d0c5cc72b0f6b6591e2a0286badb32204d415e3 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 19 Mar 2013 19:28:40 +0100 Subject: [PATCH 02/11] 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 652384c4b0124f355709b7194575f52fd027a1f2 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 19 Mar 2013 19:28:58 +0100 Subject: [PATCH 03/11] 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 de22e26..c1e9857 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 74f4b409c12274b92d6c54d494215744aa89dbc1 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 20 Mar 2013 13:51:00 +0100 Subject: [PATCH 04/11] 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 c1e9857..7fe243b 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 e865796c2d66e098782906f682263de61fa2c60b Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Wed, 20 Mar 2013 13:56:07 +0100 Subject: [PATCH 05/11] 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 299d04842340efea3a3d0e8032ae58bab3fa016b Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Wed, 20 Mar 2013 13:57:21 +0100 Subject: [PATCH 06/11] 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 43b5d667a3c846889891ea43b369b77bfe826a32 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Wed, 20 Mar 2013 14:03:23 +0100 Subject: [PATCH 07/11] 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 cd251b3eddc26cd7936c1539454652d4fe815515 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Tue, 14 May 2013 15:30:32 +0200 Subject: [PATCH 08/11] Bumbed dependencies of `containers' and `network' We need 0.5 of `containers' to get Data.Map.Strict We need 2.4.1 of `network' to get Show instance of PortID --- pontarius-xmpp.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 81680b1..f8c1bea 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -34,7 +34,7 @@ Library , binary >=0.4.1 , bytestring >=0.9.1.9 , conduit >=0.5 - , containers >=0.4.0.0 + , containers >=0.5.0.0 , crypto-api >=0.9 , crypto-random-api >=0.2 , cryptohash >=0.6.1 @@ -45,7 +45,7 @@ Library , iproute >=1.2.4 , lifted-base >=0.1.0.1 , mtl >=2.0.0.0 - , network >=2.3 + , network >=2.4.1.0 , pureMD5 >=2.1.2.1 , resourcet >=0.3.0 , random >=1.0.0.0 From f0346b92e9528d2324089de0ef8de2d19d536528 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Wed, 15 May 2013 15:12:48 +0200 Subject: [PATCH 09/11] answerMessage: Set "from" to Nothing For some reason, answerMessage used to set messageFrom = messageTo, while I believe that it should just set it to Nothing (the server will set the "from" attribute for us). Fixes #7. --- source/Network/Xmpp/Stanza.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/source/Network/Xmpp/Stanza.hs b/source/Network/Xmpp/Stanza.hs index ab3c68f..4f35021 100644 --- a/source/Network/Xmpp/Stanza.hs +++ b/source/Network/Xmpp/Stanza.hs @@ -58,12 +58,13 @@ presenceOnline = presence presenceOffline :: Presence presenceOffline = presence {presenceType = Just Unavailable} --- | Produce an answer message with the given payload, switching the "from" and +-- | Produce an answer message with the given payload, setting "from" to the -- "to" attributes in the original message. Produces a 'Nothing' value of the --- provided message message has no from attribute. +-- provided message message has no "from" attribute. Sets the "from" attribute +-- to 'Nothing' to let the server assign one. answerMessage :: Message -> [Element] -> Maybe Message answerMessage Message{messageFrom = Just frm, ..} payload = - Just Message{ messageFrom = messageTo + Just Message{ messageFrom = Nothing , messageID = Nothing , messageTo = Just frm , messagePayload = payload From b64c61299c1f241146467fd8b40a3b89be0ecb65 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Sun, 19 May 2013 11:43:21 +0200 Subject: [PATCH 10/11] Export various types Types that are exported are: Network.Xmpp: * SaslFailure (..) * StanzaHandler (..) Network.Xmpp.Internal * ConnectionState (..) * Stanza (..) * TlsBehaviour (..) Network.Xmpp.IM * InstantMessage (..) * Subscription (..) Fixes #10. Fixes #12. Fixes #16. --- source/Network/Xmpp.hs | 2 ++ source/Network/Xmpp/IM.hs | 2 ++ source/Network/Xmpp/Internal.hs | 3 +++ 3 files changed, 7 insertions(+) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index bc8281b..45524e2 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -151,6 +151,7 @@ module Network.Xmpp , StanzaError(..) , StanzaErrorType(..) , StanzaErrorCondition(..) + , SaslFailure(..) -- * Threads , dupSession -- * Miscellaneous @@ -162,6 +163,7 @@ module Network.Xmpp , AuthSaslFailure , AuthIllegalCredentials , AuthOtherFailure ) + , SaslHandler(..) ) where import Network.Xmpp.Concurrent diff --git a/source/Network/Xmpp/IM.hs b/source/Network/Xmpp/IM.hs index 2f5bf08..38730e9 100644 --- a/source/Network/Xmpp/IM.hs +++ b/source/Network/Xmpp/IM.hs @@ -5,6 +5,8 @@ module Network.Xmpp.IM MessageBody(..) , MessageThread(..) , MessageSubject(..) + , InstantMessage (..) + , Subscription(..) , instantMessage , getIM , withIM diff --git a/source/Network/Xmpp/Internal.hs b/source/Network/Xmpp/Internal.hs index c06d06e..8e4ec66 100644 --- a/source/Network/Xmpp/Internal.hs +++ b/source/Network/Xmpp/Internal.hs @@ -31,6 +31,9 @@ module Network.Xmpp.Internal , pushIQ , SaslHandler , StanzaID(..) + , ConnectionState(..) + , Stanza(..) + , TlsBehaviour(..) ) where From fc2ececcf4215b63376fa789844f962a18371142 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Sun, 19 May 2013 12:14:23 +0200 Subject: [PATCH 11/11] Modify `PresenceType'; update pickler; skip Maybe in `presenceType' Fixes #15. --- source/Network/Xmpp/Marshal.hs | 2 +- source/Network/Xmpp/Stanza.hs | 10 +++++----- source/Network/Xmpp/Types.hs | 11 ++++++----- 3 files changed, 12 insertions(+), 11 deletions(-) diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs index 1360e56..dad82d4 100644 --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -65,7 +65,7 @@ xpPresence = ("xpPresence" , "") xpWrap (xpAttrImplied "from" xpPrim) (xpAttrImplied "to" xpPrim) xpLangTag - (xpAttrImplied "type" xpPrim) + (xpAttr "type" $ xpWithDefault Available xpPrim) ) (xpAll xpElemVerbatim) ) diff --git a/source/Network/Xmpp/Stanza.hs b/source/Network/Xmpp/Stanza.hs index 4f35021..aee5582 100644 --- a/source/Network/Xmpp/Stanza.hs +++ b/source/Network/Xmpp/Stanza.hs @@ -27,26 +27,26 @@ presence = Presence { presenceID = Nothing , presenceFrom = Nothing , presenceTo = Nothing , presenceLangTag = Nothing - , presenceType = Nothing + , presenceType = Available , presencePayload = [] } -- | Request subscription with an entity. presenceSubscribe :: Jid -> Presence presenceSubscribe to = presence { presenceTo = Just to - , presenceType = Just Subscribe + , presenceType = Subscribe } -- | Approve a subscripton of an entity. presenceSubscribed :: Jid -> Presence presenceSubscribed to = presence { presenceTo = Just to - , presenceType = Just Subscribed + , presenceType = Subscribed } -- | End a subscription with an entity. presenceUnsubscribe :: Jid -> Presence presenceUnsubscribe to = presence { presenceTo = Just to - , presenceType = Just Unsubscribed + , presenceType = Unsubscribed } -- | Signal to the server that the client is available for communication. @@ -56,7 +56,7 @@ presenceOnline = presence -- | Signal to the server that the client is no longer available for -- communication. presenceOffline :: Presence -presenceOffline = presence {presenceType = Just Unavailable} +presenceOffline = presence {presenceType = Unavailable} -- | Produce an answer message with the given payload, setting "from" to the -- "to" attributes in the original message. Produces a 'Nothing' value of the diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 6720061..99b7108 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -220,7 +220,7 @@ data Presence = Presence { presenceID :: !(Maybe StanzaID) , presenceFrom :: !(Maybe Jid) , presenceTo :: !(Maybe Jid) , presenceLangTag :: !(Maybe LangTag) - , presenceType :: !(Maybe PresenceType) + , presenceType :: !PresenceType , presencePayload :: ![Element] } deriving Show @@ -243,7 +243,8 @@ data PresenceType = Subscribe | -- ^ Sender wants to subscribe to presence -- subscription Probe | -- ^ Sender requests current presence; -- should only be used by servers - Default | + Available | -- ^ Sender wants to express availability + -- (no type attribute is defined) Unavailable deriving (Eq) instance Show PresenceType where @@ -252,12 +253,12 @@ instance Show PresenceType where show Unsubscribe = "unsubscribe" show Unsubscribed = "unsubscribed" show Probe = "probe" - show Default = "" + show Available = "" show Unavailable = "unavailable" instance Read PresenceType where - readsPrec _ "" = [(Default, "")] - readsPrec _ "available" = [(Default, "")] + readsPrec _ "" = [(Available, "")] + readsPrec _ "available" = [(Available, "")] readsPrec _ "unavailable" = [(Unavailable, "")] readsPrec _ "subscribe" = [(Subscribe, "")] readsPrec _ "subscribed" = [(Subscribed, "")]