From adedc3079ad9fbad417f67f0d58fda38484c0031 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Mon, 24 Jun 2013 12:53:36 +0200 Subject: [PATCH 1/7] Disable TH for GHC <7.6 When `template-haskell' has been built against `containers' <0.5 (as is the case with GHC <7.6), building Pontarius XMPP (that requires `containers' >= 0.5) will force a rebuild of `template-haskell'. This seems to break GHC (and might likely also break `template-haskell'). --- pontarius-xmpp.cabal | 113 +++++++++++++++++++++++------------ source/Network/Xmpp.hs | 4 +- source/Network/Xmpp/Types.hs | 13 +++- 3 files changed, 91 insertions(+), 39 deletions(-) diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 84f7d23..86044ee 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -28,9 +28,11 @@ Extra-Source-Files: README.md Library hs-source-dirs: source Exposed: True + -- The only different between the below two blocks is that the first one caps - -- the range for the `bytestring' package. - If impl(ghc == 7.0.1) + -- the range for the `bytestring' package, and that the second one includes + -- `template-haskell' for GHC 7.6.1 and above. + If impl(ghc ==7.0.1) { Build-Depends: attoparsec >=0.10.0.3 , base >4 && <5 @@ -56,7 +58,6 @@ Library , split >=0.1.2.3 , stm >=2.1.2.1 , stringprep >=0.1.3 - , template-haskell >=2.5 , text >=0.11.1.5 , tls >=1.1.0 , tls-extra >=0.5.0 @@ -66,41 +67,79 @@ Library , xml-conduit >=1.0 , xml-picklers >=0.3.3 } - else + Else { - Build-Depends: attoparsec >=0.10.0.3 - , base >4 && <5 - , base64-bytestring >=0.1.0.0 - , binary >=0.4.1 - , bytestring >=0.9.1.9 - , conduit >=0.5 - , containers >=0.5.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 - , iproute >=1.2.4 - , lifted-base >=0.1.0.1 - , mtl >=2.0.0.0 - , network >=2.4.1.0 - , pureMD5 >=2.1.2.1 - , resourcet >=0.3.0 - , random >=1.0.0.0 - , split >=0.1.2.3 - , stm >=2.1.2.1 - , stringprep >=0.1.3 - , template-haskell >=2.5 - , text >=0.11.1.5 - , tls >=1.1.0 - , tls-extra >=0.5.0 - , transformers >=0.2.2.0 - , void >=0.5.5 - , xml-types >=0.3.1 - , xml-conduit >=1.0 - , xml-picklers >=0.3.3 + If impl(ghc >=7.6.1) + { + Build-Depends: attoparsec >=0.10.0.3 + , base >4 && <5 + , base64-bytestring >=0.1.0.0 + , binary >=0.4.1 + , bytestring >=0.9.1.9 + , conduit >=0.5 + , containers >=0.5.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 + , iproute >=1.2.4 + , lifted-base >=0.1.0.1 + , mtl >=2.0.0.0 + , network >=2.4.1.0 + , pureMD5 >=2.1.2.1 + , resourcet >=0.3.0 + , random >=1.0.0.0 + , split >=0.1.2.3 + , stm >=2.1.2.1 + , stringprep >=0.1.3 + , template-haskell >=2.5 + , text >=0.11.1.5 + , tls >=1.1.0 + , tls-extra >=0.5.0 + , transformers >=0.2.2.0 + , void >=0.5.5 + , xml-types >=0.3.1 + , xml-conduit >=1.0 + , xml-picklers >=0.3.3 + } + Else + { + Build-Depends: attoparsec >=0.10.0.3 + , base >4 && <5 + , base64-bytestring >=0.1.0.0 + , binary >=0.4.1 + , bytestring >=0.9.1.9 + , conduit >=0.5 + , containers >=0.5.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 + , iproute >=1.2.4 + , lifted-base >=0.1.0.1 + , mtl >=2.0.0.0 + , network >=2.4.1.0 + , pureMD5 >=2.1.2.1 + , resourcet >=0.3.0 + , random >=1.0.0.0 + , split >=0.1.2.3 + , stm >=2.1.2.1 + , stringprep >=0.1.3 + , text >=0.11.1.5 + , tls >=1.1.0 + , tls-extra >=0.5.0 + , transformers >=0.2.2.0 + , void >=0.5.5 + , xml-types >=0.3.1 + , xml-conduit >=1.0 + , xml-picklers >=0.3.3 + } } Exposed-modules: Network.Xmpp , Network.Xmpp.IM diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 0ea3561..a08a972 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -21,7 +21,7 @@ -- For low-level access to Pontarius XMPP, see the "Network.Xmpp.Internal" -- module. -{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} +{-# LANGUAGE CPP, NoMonomorphismRestriction, OverloadedStrings #-} module Network.Xmpp ( -- * Session management @@ -46,7 +46,9 @@ module Network.Xmpp -- for addressing entities in the network. It is somewhat similar to an e-mail -- address, but contains three parts instead of two. , Jid +#if __GLASGOW_HASKELL >= 706 , jidQ +#endif , isBare , isFull , jidFromText diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 4ee22ce..28372e9 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -1,6 +1,11 @@ +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL >= 706 +{-# LANGUAGE TemplateHaskell #-} +#endif + {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} @@ -44,7 +49,9 @@ module Network.Xmpp.Types , StreamConfiguration(..) , langTag , Jid(..) +#if __GLASGOW_HASKELL >= 706 , jidQ +#endif , isBare , isFull , jidFromText @@ -78,8 +85,10 @@ import Data.Text (Text) import qualified Data.Text as Text import Data.Typeable(Typeable) import Data.XML.Types +#if __GLASGOW_HASKELL >= 706 import Language.Haskell.TH import Language.Haskell.TH.Quote +#endif import Network import Network.DNS import Network.TLS hiding (Version) @@ -962,6 +971,7 @@ instance Read Jid where [(parseJid (read s' :: String), r)] -- May fail with "Prelude.read: no parse" -- or the `parseJid' error message (see below) +#if __GLASGOW_HASKELL >= 706 jidQ :: QuasiQuoter jidQ = QuasiQuoter { quoteExp = \s -> do when (head s == ' ') . fail $ "Leading whitespaces in JID" ++ show s @@ -981,6 +991,7 @@ jidQ = QuasiQuoter { quoteExp = \s -> do textE t = [| Text.pack $(stringE $ Text.unpack t) |] mbTextE Nothing = [| Nothing |] mbTextE (Just s) = [| Just $(textE s) |] +#endif -- | Parses a JID string. -- From 9f53fb1246559f07f2b2d36fa3a10468df7341a7 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Mon, 24 Jun 2013 21:25:41 +0200 Subject: [PATCH 2/7] Specify Conduit >=1.0.1 dependency Fixes #36. --- pontarius-xmpp.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 86044ee..08956ca 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -39,7 +39,7 @@ Library , base64-bytestring >=0.1.0.0 , binary >=0.4.1 , bytestring >=0.9.1.9 && <=0.9.2.1 - , conduit >=0.5 + , conduit >=1.0.1 , containers >=0.5.0.0 , crypto-api >=0.9 , crypto-random-api >=0.2 @@ -76,7 +76,7 @@ Library , base64-bytestring >=0.1.0.0 , binary >=0.4.1 , bytestring >=0.9.1.9 - , conduit >=0.5 + , conduit >=1.0.1 , containers >=0.5.0.0 , crypto-api >=0.9 , crypto-random-api >=0.2 @@ -112,7 +112,7 @@ Library , base64-bytestring >=0.1.0.0 , binary >=0.4.1 , bytestring >=0.9.1.9 - , conduit >=0.5 + , conduit >=1.0.1 , containers >=0.5.0.0 , crypto-api >=0.9 , crypto-random-api >=0.2 From 932953274d82fd49f29afd4b426b58bb2956b533 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Wed, 26 Jun 2013 18:36:14 +0200 Subject: [PATCH 3/7] Change Read/Show instances, update picklers and change LangTag exports The reason for removing these instances are the same as in #24. Affected types are: StanzaID, IQRequestType, MessageType, PresenceType, StanzaErrorType, StanzaErrorCondition, SaslError, StreamErrorCondition, Version, and LangTag. It's quite boilerplate and ugly, but I think that it will do for now. --- source/Network/Xmpp.hs | 4 +- source/Network/Xmpp/Marshal.hs | 263 +++++++++++++++++++++++++++++++-- source/Network/Xmpp/Types.hs | 247 ++++--------------------------- 3 files changed, 275 insertions(+), 239 deletions(-) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index a08a972..f230e8f 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -171,7 +171,9 @@ module Network.Xmpp -- * Threads , dupSession -- * Miscellaneous - , LangTag(..) + , LangTag + , langTagFromText + , langTagToText , XmppFailure(..) , StreamErrorInfo(..) , StreamErrorCondition(..) diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs index f594783..a7ff049 100644 --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -47,8 +47,8 @@ xpMessage = ("xpMessage" , "") xpWrap (\(Message qid from to lang tp ext) -> ((tp, qid, from, to, lang), ext)) (xpElem "{jabber:client}message" (xp5Tuple - (xpDefault Normal $ xpAttr "type" xpPrim) - (xpAttrImplied "id" xpPrim) + (xpDefault Normal $ xpAttr "type" xpMessageType) + (xpAttrImplied "id" xpStanzaID) (xpAttrImplied "from" xpJid) (xpAttrImplied "to" xpJid) xpLangTag @@ -63,11 +63,11 @@ xpPresence = ("xpPresence" , "") xpWrap (\(Presence qid from to lang tp ext) -> ((qid, from, to, lang, tp), ext)) (xpElem "{jabber:client}presence" (xp5Tuple - (xpAttrImplied "id" xpPrim) + (xpAttrImplied "id" xpStanzaID) (xpAttrImplied "from" xpJid) (xpAttrImplied "to" xpJid) xpLangTag - (xpDefault Available $ xpAttr "type" xpPrim) + (xpDefault Available $ xpAttr "type" xpPresenceType) ) (xpAll xpElemVerbatim) ) @@ -78,11 +78,11 @@ xpIQRequest = ("xpIQRequest" , "") xpWrap (\(IQRequest qid from to lang tp body) -> ((qid, from, to, lang, tp), body)) (xpElem "{jabber:client}iq" (xp5Tuple - (xpAttr "id" xpPrim) + (xpAttr "id" xpStanzaID) (xpAttrImplied "from" xpJid) (xpAttrImplied "to" xpJid) xpLangTag - ((xpAttr "type" xpPrim)) + ((xpAttr "type" xpIQRequestType)) ) xpElemVerbatim ) @@ -93,7 +93,7 @@ xpIQResult = ("xpIQResult" , "") xpWrap (\(IQResult qid from to lang body) -> ((qid, from, to, lang, ()), body)) (xpElem "{jabber:client}iq" (xp5Tuple - (xpAttr "id" xpPrim) + (xpAttr "id" xpStanzaID) (xpAttrImplied "from" xpJid) (xpAttrImplied "to" xpJid) xpLangTag @@ -112,7 +112,7 @@ xpErrorCondition = ("xpErrorCondition" , "") xpWrap (\cond -> (cond, (), ())) (xpElemByNamespace "urn:ietf:params:xml:ns:xmpp-stanzas" - xpPrim + xpStanzaErrorCondition xpUnit xpUnit ) @@ -122,11 +122,11 @@ xpStanzaError = ("xpStanzaError" , "") xpWrap (\(tp, (cond, txt, ext)) -> StanzaError tp cond txt ext) (\(StanzaError tp cond txt ext) -> (tp, (cond, txt, ext))) (xpElem "{jabber:client}error" - (xpAttr "type" xpPrim) + (xpAttr "type" xpStanzaErrorType) (xp3Tuple xpErrorCondition (xpOption $ xpElem "{jabber:client}text" - (xpAttrImplied xmlLang xpPrim) + (xpAttrImplied xmlLang xpLang) (xpContent xpId) ) (xpOption xpElemVerbatim) @@ -142,10 +142,10 @@ xpMessageError = ("xpMessageError" , "") xpWrap (xpElem "{jabber:client}message" (xp5Tuple (xpAttrFixed "type" "error") - (xpAttrImplied "id" xpPrim) + (xpAttrImplied "id" xpStanzaID) (xpAttrImplied "from" xpJid) (xpAttrImplied "to" xpJid) - (xpAttrImplied xmlLang xpPrim) + (xpAttrImplied xmlLang xpLang) -- TODO: NS? ) (xp2Tuple xpStanzaError (xpAll xpElemVerbatim)) @@ -159,7 +159,7 @@ xpPresenceError = ("xpPresenceError" , "") xpWrap ((qid, from, to, lang, ()), (err, ext))) (xpElem "{jabber:client}presence" (xp5Tuple - (xpAttrImplied "id" xpPrim) + (xpAttrImplied "id" xpStanzaID) (xpAttrImplied "from" xpJid) (xpAttrImplied "to" xpJid) xpLangTag @@ -176,7 +176,7 @@ xpIQError = ("xpIQError" , "") xpWrap ((qid, from, to, lang, ()), (err, body))) (xpElem "{jabber:client}iq" (xp5Tuple - (xpAttr "id" xpPrim) + (xpAttr "id" xpStanzaID) (xpAttrImplied "from" xpJid) (xpAttrImplied "to" xpJid) xpLangTag @@ -198,7 +198,7 @@ xpStreamError = ("xpStreamError" , "") xpWrap (xp3Tuple (xpElemByNamespace "urn:ietf:params:xml:ns:xmpp-streams" - xpPrim + xpStreamErrorCondition xpUnit xpUnit ) @@ -212,7 +212,14 @@ xpStreamError = ("xpStreamError" , "") xpWrap ) xpLangTag :: PU [Attribute] (Maybe LangTag) -xpLangTag = xpAttrImplied xmlLang xpPrim +xpLangTag = xpAttrImplied xmlLang xpLang + +xpLang :: PU Text LangTag +xpLang = ("xpLang", "") + xpPartial ( \input -> case langTagFromText input of + Nothing -> Left "Could not parse language tag." + Just j -> Right j) + langTagToText xmlLang :: Name xmlLang = Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml") @@ -284,3 +291,227 @@ xpJid = ("xpJid", "") Nothing -> Left "Could not parse JID." Just j -> Right j) jidToText + +xpStanzaID :: PU Text StanzaID +xpStanzaID = ("xpStanzaID", "") + xpPartial ( \input -> case stanzaIDFromText input of + Nothing -> Left "Could not parse StanzaID." + Just j -> Right j) + stanzaIDToText + where + stanzaIDFromText t = Just $ StanzaID t + stanzaIDToText (StanzaID s) = s + +xpIQRequestType :: PU Text IQRequestType +xpIQRequestType = ("xpIQRequestType", "") + xpPartial ( \input -> case iqRequestTypeFromText input of + Nothing -> Left "Could not parse IQ request type." + Just j -> Right j) + iqRequestTypeToText + where + iqRequestTypeFromText "get" = Just Get + iqRequestTypeFromText "set" = Just Set + iqRequestTypeFromText _ = Nothing + iqRequestTypeToText Get = "get" + iqRequestTypeToText Set = "set" + +xpMessageType :: PU Text MessageType +xpMessageType = ("xpMessageType", "") + xpPartial ( \input -> case messageTypeFromText input of + Nothing -> Left "Could not parse message type." + Just j -> Right j) + messageTypeToText + where + messageTypeFromText "chat" = Just Chat + messageTypeFromText "groupchat" = Just GroupChat + messageTypeFromText "headline" = Just Headline + messageTypeFromText "normal" = Just Normal + messageTypeFromText _ = Just Normal + messageTypeToText Chat = "chat" + messageTypeToText GroupChat = "groupchat" + messageTypeToText Headline = "headline" + messageTypeToText Normal = "normal" + +xpPresenceType :: PU Text PresenceType +xpPresenceType = ("xpPresenceType", "") + xpPartial ( \input -> case presenceTypeFromText input of + Nothing -> Left "Could not parse presence type." + Just j -> Right j) + presenceTypeToText + where + presenceTypeFromText "" = Just Available + presenceTypeFromText "available" = Just Available + presenceTypeFromText "unavailable" = Just Unavailable + presenceTypeFromText "subscribe" = Just Subscribe + presenceTypeFromText "subscribed" = Just Subscribed + presenceTypeFromText "unsubscribe" = Just Unsubscribe + presenceTypeFromText "unsubscribed" = Just Unsubscribed + presenceTypeFromText "probe" = Just Probe + presenceTypeToText Available = "available" + presenceTypeToText Unavailable = "unavailable" + presenceTypeToText Subscribe = "subscribe" + presenceTypeToText Subscribed = "subscribed" + presenceTypeToText Unsubscribe = "unsubscribe" + presenceTypeToText Unsubscribed = "unsubscribed" + presenceTypeToText Probe = "probe" + +xpStanzaErrorType :: PU Text StanzaErrorType +xpStanzaErrorType = ("xpStanzaErrorType", "") + xpPartial ( \input -> case stanzaErrorTypeFromText input of + Nothing -> Left "Could not parse stanza error type." + Just j -> Right j) + stanzaErrorTypeToText + where + stanzaErrorTypeFromText "auth" = Just Auth + stanzaErrorTypeFromText "cancel" = Just Cancel + stanzaErrorTypeFromText "continue" = Just Continue + stanzaErrorTypeFromText "modify" = Just Modify + stanzaErrorTypeFromText "wait" = Just Wait + stanzaErrorTypeFromText _ = Nothing + stanzaErrorTypeToText Auth = "auth" + stanzaErrorTypeToText Cancel = "cancel" + stanzaErrorTypeToText Continue = "continue" + stanzaErrorTypeToText Modify = "modify" + stanzaErrorTypeToText Wait = "wait" + +xpStanzaErrorCondition :: PU Text StanzaErrorCondition +xpStanzaErrorCondition = ("xpStanzaErrorCondition", "") + xpPartial ( \input -> case stanzaErrorConditionFromText input of + Nothing -> Left "Could not parse stanza error condition." + Just j -> Right j) + stanzaErrorConditionToText + where + stanzaErrorConditionToText BadRequest = "bad-request" + stanzaErrorConditionToText Conflict = "conflict" + stanzaErrorConditionToText FeatureNotImplemented = "feature-not-implemented" + stanzaErrorConditionToText Forbidden = "forbidden" + stanzaErrorConditionToText Gone = "gone" + stanzaErrorConditionToText InternalServerError = "internal-server-error" + stanzaErrorConditionToText ItemNotFound = "item-not-found" + stanzaErrorConditionToText JidMalformed = "jid-malformed" + stanzaErrorConditionToText NotAcceptable = "not-acceptable" + stanzaErrorConditionToText NotAllowed = "not-allowed" + stanzaErrorConditionToText NotAuthorized = "not-authorized" + stanzaErrorConditionToText PaymentRequired = "payment-required" + stanzaErrorConditionToText RecipientUnavailable = "recipient-unavailable" + stanzaErrorConditionToText Redirect = "redirect" + stanzaErrorConditionToText RegistrationRequired = "registration-required" + stanzaErrorConditionToText RemoteServerNotFound = "remote-server-not-found" + stanzaErrorConditionToText RemoteServerTimeout = "remote-server-timeout" + stanzaErrorConditionToText ResourceConstraint = "resource-constraint" + stanzaErrorConditionToText ServiceUnavailable = "service-unavailable" + stanzaErrorConditionToText SubscriptionRequired = "subscription-required" + stanzaErrorConditionToText UndefinedCondition = "undefined-condition" + stanzaErrorConditionToText UnexpectedRequest = "unexpected-request" + stanzaErrorConditionFromText "bad-request" = Just BadRequest + stanzaErrorConditionFromText "conflict" = Just Conflict + stanzaErrorConditionFromText "feature-not-implemented" = Just FeatureNotImplemented + stanzaErrorConditionFromText "forbidden" = Just Forbidden + stanzaErrorConditionFromText "gone" = Just Gone + stanzaErrorConditionFromText "internal-server-error" = Just InternalServerError + stanzaErrorConditionFromText "item-not-found" = Just ItemNotFound + stanzaErrorConditionFromText "jid-malformed" = Just JidMalformed + stanzaErrorConditionFromText "not-acceptable" = Just NotAcceptable + stanzaErrorConditionFromText "not-allowed" = Just NotAllowed + stanzaErrorConditionFromText "not-authorized" = Just NotAuthorized + stanzaErrorConditionFromText "payment-required" = Just PaymentRequired + stanzaErrorConditionFromText "recipient-unavailable" = Just RecipientUnavailable + stanzaErrorConditionFromText "redirect" = Just Redirect + stanzaErrorConditionFromText "registration-required" = Just RegistrationRequired + stanzaErrorConditionFromText "remote-server-not-found" = Just RemoteServerNotFound + stanzaErrorConditionFromText "remote-server-timeout" = Just RemoteServerTimeout + stanzaErrorConditionFromText "resource-constraint" = Just ResourceConstraint + stanzaErrorConditionFromText "service-unavailable" = Just ServiceUnavailable + stanzaErrorConditionFromText "subscription-required" = Just SubscriptionRequired + stanzaErrorConditionFromText "undefined-condition" = Just UndefinedCondition + stanzaErrorConditionFromText "unexpected-request" = Just UnexpectedRequest + stanzaErrorConditionFromText _ = Nothing + +xpSaslError :: PU Text SaslError +xpSaslError = ("xpSaslError", "") + xpPartial ( \input -> case saslErrorFromText input of + Nothing -> Left "Could not parse SASL error." + Just j -> Right j) + saslErrorToText + where + saslErrorToText SaslAborted = "aborted" + saslErrorToText SaslAccountDisabled = "account-disabled" + saslErrorToText SaslCredentialsExpired = "credentials-expired" + saslErrorToText SaslEncryptionRequired = "encryption-required" + saslErrorToText SaslIncorrectEncoding = "incorrect-encoding" + saslErrorToText SaslInvalidAuthzid = "invalid-authzid" + saslErrorToText SaslInvalidMechanism = "invalid-mechanism" + saslErrorToText SaslMalformedRequest = "malformed-request" + saslErrorToText SaslMechanismTooWeak = "mechanism-too-weak" + saslErrorToText SaslNotAuthorized = "not-authorized" + saslErrorToText SaslTemporaryAuthFailure = "temporary-auth-failure" + saslErrorFromText "aborted" = Just SaslAborted + saslErrorFromText "account-disabled" = Just SaslAccountDisabled + saslErrorFromText "credentials-expired" = Just SaslCredentialsExpired + saslErrorFromText "encryption-required" = Just SaslEncryptionRequired + saslErrorFromText "incorrect-encoding" = Just SaslIncorrectEncoding + saslErrorFromText "invalid-authzid" = Just SaslInvalidAuthzid + saslErrorFromText "invalid-mechanism" = Just SaslInvalidMechanism + saslErrorFromText "malformed-request" = Just SaslMalformedRequest + saslErrorFromText "mechanism-too-weak" = Just SaslMechanismTooWeak + saslErrorFromText "not-authorized" = Just SaslNotAuthorized + saslErrorFromText "temporary-auth-failure" = Just SaslTemporaryAuthFailure + +xpStreamErrorCondition :: PU Text StreamErrorCondition +xpStreamErrorCondition = ("xpStreamErrorCondition", "") + xpPartial ( \input -> case streamErrorConditionFromText input of + Nothing -> Left "Could not parse stream error condition." + Just j -> Right j) + streamErrorConditionToText + where + streamErrorConditionToText StreamBadFormat = "bad-format" + streamErrorConditionToText StreamBadNamespacePrefix = "bad-namespace-prefix" + streamErrorConditionToText StreamConflict = "conflict" + streamErrorConditionToText StreamConnectionTimeout = "connection-timeout" + streamErrorConditionToText StreamHostGone = "host-gone" + streamErrorConditionToText StreamHostUnknown = "host-unknown" + streamErrorConditionToText StreamImproperAddressing = "improper-addressing" + streamErrorConditionToText StreamInternalServerError = "internal-server-error" + streamErrorConditionToText StreamInvalidFrom = "invalid-from" + streamErrorConditionToText StreamInvalidNamespace = "invalid-namespace" + streamErrorConditionToText StreamInvalidXml = "invalid-xml" + streamErrorConditionToText StreamNotAuthorized = "not-authorized" + streamErrorConditionToText StreamNotWellFormed = "not-well-formed" + streamErrorConditionToText StreamPolicyViolation = "policy-violation" + streamErrorConditionToText StreamRemoteConnectionFailed = "remote-connection-failed" + streamErrorConditionToText StreamReset = "reset" + streamErrorConditionToText StreamResourceConstraint = "resource-constraint" + streamErrorConditionToText StreamRestrictedXml = "restricted-xml" + streamErrorConditionToText StreamSeeOtherHost = "see-other-host" + streamErrorConditionToText StreamSystemShutdown = "system-shutdown" + streamErrorConditionToText StreamUndefinedCondition = "undefined-condition" + streamErrorConditionToText StreamUnsupportedEncoding = "unsupported-encoding" + streamErrorConditionToText StreamUnsupportedFeature = "unsupported-feature" + streamErrorConditionToText StreamUnsupportedStanzaType = "unsupported-stanza-type" + streamErrorConditionToText StreamUnsupportedVersion = "unsupported-version" + streamErrorConditionFromText "bad-format" = Just StreamBadFormat + streamErrorConditionFromText "bad-namespace-prefix" = Just StreamBadNamespacePrefix + streamErrorConditionFromText "conflict" = Just StreamConflict + streamErrorConditionFromText "connection-timeout" = Just StreamConnectionTimeout + streamErrorConditionFromText "host-gone" = Just StreamHostGone + streamErrorConditionFromText "host-unknown" = Just StreamHostUnknown + streamErrorConditionFromText "improper-addressing" = Just StreamImproperAddressing + streamErrorConditionFromText "internal-server-error" = Just StreamInternalServerError + streamErrorConditionFromText "invalid-from" = Just StreamInvalidFrom + streamErrorConditionFromText "invalid-namespace" = Just StreamInvalidNamespace + streamErrorConditionFromText "invalid-xml" = Just StreamInvalidXml + streamErrorConditionFromText "not-authorized" = Just StreamNotAuthorized + streamErrorConditionFromText "not-well-formed" = Just StreamNotWellFormed + streamErrorConditionFromText "policy-violation" = Just StreamPolicyViolation + streamErrorConditionFromText "remote-connection-failed" = Just StreamRemoteConnectionFailed + streamErrorConditionFromText "reset" = Just StreamReset + streamErrorConditionFromText "resource-constraint" = Just StreamResourceConstraint + streamErrorConditionFromText "restricted-xml" = Just StreamRestrictedXml + streamErrorConditionFromText "see-other-host" = Just StreamSeeOtherHost + streamErrorConditionFromText "system-shutdown" = Just StreamSystemShutdown + streamErrorConditionFromText "undefined-condition" = Just StreamUndefinedCondition + streamErrorConditionFromText "unsupported-encoding" = Just StreamUnsupportedEncoding + streamErrorConditionFromText "unsupported-feature" = Just StreamUnsupportedFeature + streamErrorConditionFromText "unsupported-stanza-type" = Just StreamUnsupportedStanzaType + streamErrorConditionFromText "unsupported-version" = Just StreamUnsupportedVersion + streamErrorConditionFromText _ = Nothing diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 28372e9..8181c34 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -20,6 +20,8 @@ module Network.Xmpp.Types , IQResult(..) , IdGenerator(..) , LangTag (..) + , langTagFromText + , langTagToText , Message(..) , message , MessageError(..) @@ -47,7 +49,6 @@ module Network.Xmpp.Types , StanzaHandler , ConnectionDetails(..) , StreamConfiguration(..) - , langTag , Jid(..) #if __GLASGOW_HASKELL >= 706 , jidQ @@ -100,13 +101,7 @@ import qualified Text.StringPrep as SP -- Wraps a string of random characters that, when using an appropriate -- @IdGenerator@, is guaranteed to be unique for the Xmpp session. -data StanzaID = StanzaID !Text deriving (Eq, Ord) - -instance Show StanzaID where - show (StanzaID s) = Text.unpack s - -instance Read StanzaID where - readsPrec _ x = [(StanzaID $ Text.pack x, "")] +data StanzaID = StanzaID !Text deriving (Eq, Ord, Read, Show) instance IsString StanzaID where fromString = StanzaID . Text.pack @@ -133,16 +128,7 @@ data IQRequest = IQRequest { iqRequestID :: !StanzaID } deriving Show -- | The type of IQ request that is made. -data IQRequestType = Get | Set deriving (Eq, Ord) - -instance Show IQRequestType where - show Get = "get" - show Set = "set" - -instance Read IQRequestType where - readsPrec _ "get" = [(Get, "")] - readsPrec _ "set" = [(Set, "")] - readsPrec _ _ = [] +data IQRequestType = Get | Set deriving (Eq, Ord, Read, Show) -- | A "response" Info/Query (IQ) stanza is either an 'IQError', an IQ stanza -- of type "result" ('IQResult') or a Timeout. @@ -237,20 +223,7 @@ data MessageType = -- | The message is sent in the context of a one-to-one chat -- -- This is the /default/ value. | Normal - deriving (Eq) - -instance Show MessageType where - show Chat = "chat" - show GroupChat = "groupchat" - show Headline = "headline" - show Normal = "normal" - -instance Read MessageType where - readsPrec _ "chat" = [(Chat, "")] - readsPrec _ "groupchat" = [(GroupChat, "")] - readsPrec _ "headline" = [(Headline, "")] - readsPrec _ "normal" = [(Normal, "")] - readsPrec _ _ = [(Normal, "")] + deriving (Eq, Read, Show) -- | The presence stanza. Used for communicating status updates. data Presence = Presence { presenceID :: !(Maybe StanzaID) @@ -294,27 +267,7 @@ data PresenceType = Subscribe | -- ^ Sender wants to subscribe to presence -- should only be used by servers Available | -- ^ Sender wants to express availability -- (no type attribute is defined) - Unavailable deriving (Eq) - -instance Show PresenceType where - show Subscribe = "subscribe" - show Subscribed = "subscribed" - show Unsubscribe = "unsubscribe" - show Unsubscribed = "unsubscribed" - show Probe = "probe" - show Available = "" - show Unavailable = "unavailable" - -instance Read PresenceType where - readsPrec _ "" = [(Available, "")] - readsPrec _ "available" = [(Available, "")] - readsPrec _ "unavailable" = [(Unavailable, "")] - readsPrec _ "subscribe" = [(Subscribe, "")] - readsPrec _ "subscribed" = [(Subscribed, "")] - readsPrec _ "unsubscribe" = [(Unsubscribe, "")] - readsPrec _ "unsubscribed" = [(Unsubscribed, "")] - readsPrec _ "probe" = [(Probe, "")] - readsPrec _ _ = [] + Unavailable deriving (Eq, Read, Show) -- | All stanzas (IQ, message, presence) can cause errors, which in the Xmpp -- stream looks like . These errors are @@ -333,22 +286,7 @@ data StanzaErrorType = Cancel | -- ^ Error is unrecoverable - do not retry Modify | -- ^ Change the data and retry Auth | -- ^ Provide credentials and retry Wait -- ^ Error is temporary - wait and retry - deriving (Eq) - -instance Show StanzaErrorType where - show Cancel = "cancel" - show Continue = "continue" - show Modify = "modify" - show Auth = "auth" - show Wait = "wait" - -instance Read StanzaErrorType where - readsPrec _ "auth" = [( Auth , "")] - readsPrec _ "cancel" = [( Cancel , "")] - readsPrec _ "continue" = [( Continue, "")] - readsPrec _ "modify" = [( Modify , "")] - readsPrec _ "wait" = [( Wait , "")] - readsPrec _ _ = [] + deriving (Eq, Read, Show) -- | Stanza errors are accommodated with one of the error conditions listed -- below. @@ -385,56 +323,7 @@ data StanzaErrorCondition = BadRequest -- ^ Malformed XML. | UndefinedCondition -- ^ Application-specific -- condition. | UnexpectedRequest -- ^ Badly timed request. - deriving Eq - -instance Show StanzaErrorCondition where - show BadRequest = "bad-request" - show Conflict = "conflict" - show FeatureNotImplemented = "feature-not-implemented" - show Forbidden = "forbidden" - show Gone = "gone" - show InternalServerError = "internal-server-error" - show ItemNotFound = "item-not-found" - show JidMalformed = "jid-malformed" - show NotAcceptable = "not-acceptable" - show NotAllowed = "not-allowed" - show NotAuthorized = "not-authorized" - show PaymentRequired = "payment-required" - show RecipientUnavailable = "recipient-unavailable" - show Redirect = "redirect" - show RegistrationRequired = "registration-required" - show RemoteServerNotFound = "remote-server-not-found" - show RemoteServerTimeout = "remote-server-timeout" - show ResourceConstraint = "resource-constraint" - show ServiceUnavailable = "service-unavailable" - show SubscriptionRequired = "subscription-required" - show UndefinedCondition = "undefined-condition" - show UnexpectedRequest = "unexpected-request" - -instance Read StanzaErrorCondition where - readsPrec _ "bad-request" = [(BadRequest , "")] - readsPrec _ "conflict" = [(Conflict , "")] - readsPrec _ "feature-not-implemented" = [(FeatureNotImplemented, "")] - readsPrec _ "forbidden" = [(Forbidden , "")] - readsPrec _ "gone" = [(Gone , "")] - readsPrec _ "internal-server-error" = [(InternalServerError , "")] - readsPrec _ "item-not-found" = [(ItemNotFound , "")] - readsPrec _ "jid-malformed" = [(JidMalformed , "")] - readsPrec _ "not-acceptable" = [(NotAcceptable , "")] - readsPrec _ "not-allowed" = [(NotAllowed , "")] - readsPrec _ "not-authorized" = [(NotAuthorized , "")] - readsPrec _ "payment-required" = [(PaymentRequired , "")] - readsPrec _ "recipient-unavailable" = [(RecipientUnavailable , "")] - readsPrec _ "redirect" = [(Redirect , "")] - readsPrec _ "registration-required" = [(RegistrationRequired , "")] - readsPrec _ "remote-server-not-found" = [(RemoteServerNotFound , "")] - readsPrec _ "remote-server-timeout" = [(RemoteServerTimeout , "")] - readsPrec _ "resource-constraint" = [(ResourceConstraint , "")] - readsPrec _ "service-unavailable" = [(ServiceUnavailable , "")] - readsPrec _ "subscription-required" = [(SubscriptionRequired , "")] - readsPrec _ "unexpected-request" = [(UnexpectedRequest , "")] - readsPrec _ "undefined-condition" = [(UndefinedCondition , "")] - readsPrec _ _ = [(UndefinedCondition , "")] + deriving (Eq, Read, Show) -- ============================================================================= -- OTHER STUFF @@ -473,34 +362,7 @@ data SaslError = SaslAborted -- ^ Client aborted. -- temporary error condition; the -- initiating entity is recommended -- to try again later. - deriving Eq - -instance Show SaslError where - show SaslAborted = "aborted" - show SaslAccountDisabled = "account-disabled" - show SaslCredentialsExpired = "credentials-expired" - show SaslEncryptionRequired = "encryption-required" - show SaslIncorrectEncoding = "incorrect-encoding" - show SaslInvalidAuthzid = "invalid-authzid" - show SaslInvalidMechanism = "invalid-mechanism" - show SaslMalformedRequest = "malformed-request" - show SaslMechanismTooWeak = "mechanism-too-weak" - show SaslNotAuthorized = "not-authorized" - show SaslTemporaryAuthFailure = "temporary-auth-failure" - -instance Read SaslError where - readsPrec _ "aborted" = [(SaslAborted , "")] - readsPrec _ "account-disabled" = [(SaslAccountDisabled , "")] - readsPrec _ "credentials-expired" = [(SaslCredentialsExpired , "")] - readsPrec _ "encryption-required" = [(SaslEncryptionRequired , "")] - readsPrec _ "incorrect-encoding" = [(SaslIncorrectEncoding , "")] - readsPrec _ "invalid-authzid" = [(SaslInvalidAuthzid , "")] - readsPrec _ "invalid-mechanism" = [(SaslInvalidMechanism , "")] - readsPrec _ "malformed-request" = [(SaslMalformedRequest , "")] - readsPrec _ "mechanism-too-weak" = [(SaslMechanismTooWeak , "")] - readsPrec _ "not-authorized" = [(SaslNotAuthorized , "")] - readsPrec _ "temporary-auth-failure" = [(SaslTemporaryAuthFailure , "")] - readsPrec _ _ = [] + deriving (Eq, Read, Show) -- The documentation of StreamErrorConditions is copied from -- http://xmpp.org/rfcs/rfc6120.html#streams-error-conditions @@ -617,63 +479,7 @@ data StreamErrorCondition -- initiating entity in the stream header -- specifies a version of XMPP that is not -- supported by the server. - deriving Eq - -instance Show StreamErrorCondition where - show StreamBadFormat = "bad-format" - show StreamBadNamespacePrefix = "bad-namespace-prefix" - show StreamConflict = "conflict" - show StreamConnectionTimeout = "connection-timeout" - show StreamHostGone = "host-gone" - show StreamHostUnknown = "host-unknown" - show StreamImproperAddressing = "improper-addressing" - show StreamInternalServerError = "internal-server-error" - show StreamInvalidFrom = "invalid-from" - show StreamInvalidNamespace = "invalid-namespace" - show StreamInvalidXml = "invalid-xml" - show StreamNotAuthorized = "not-authorized" - show StreamNotWellFormed = "not-well-formed" - show StreamPolicyViolation = "policy-violation" - show StreamRemoteConnectionFailed = "remote-connection-failed" - show StreamReset = "reset" - show StreamResourceConstraint = "resource-constraint" - show StreamRestrictedXml = "restricted-xml" - show StreamSeeOtherHost = "see-other-host" - show StreamSystemShutdown = "system-shutdown" - show StreamUndefinedCondition = "undefined-condition" - show StreamUnsupportedEncoding = "unsupported-encoding" - show StreamUnsupportedFeature = "unsupported-feature" - show StreamUnsupportedStanzaType = "unsupported-stanza-type" - show StreamUnsupportedVersion = "unsupported-version" - -instance Read StreamErrorCondition where - readsPrec _ "bad-format" = [(StreamBadFormat , "")] - readsPrec _ "bad-namespace-prefix" = [(StreamBadNamespacePrefix , "")] - readsPrec _ "conflict" = [(StreamConflict , "")] - readsPrec _ "connection-timeout" = [(StreamConnectionTimeout , "")] - readsPrec _ "host-gone" = [(StreamHostGone , "")] - readsPrec _ "host-unknown" = [(StreamHostUnknown , "")] - readsPrec _ "improper-addressing" = [(StreamImproperAddressing , "")] - readsPrec _ "internal-server-error" = [(StreamInternalServerError , "")] - readsPrec _ "invalid-from" = [(StreamInvalidFrom , "")] - readsPrec _ "invalid-namespace" = [(StreamInvalidNamespace , "")] - readsPrec _ "invalid-xml" = [(StreamInvalidXml , "")] - readsPrec _ "not-authorized" = [(StreamNotAuthorized , "")] - readsPrec _ "not-well-formed" = [(StreamNotWellFormed , "")] - readsPrec _ "policy-violation" = [(StreamPolicyViolation , "")] - readsPrec _ "remote-connection-failed" = - [(StreamRemoteConnectionFailed, "")] - readsPrec _ "reset" = [(StreamReset , "")] - readsPrec _ "resource-constraint" = [(StreamResourceConstraint , "")] - readsPrec _ "restricted-xml" = [(StreamRestrictedXml , "")] - readsPrec _ "see-other-host" = [(StreamSeeOtherHost , "")] - readsPrec _ "system-shutdown" = [(StreamSystemShutdown , "")] - readsPrec _ "undefined-condition" = [(StreamUndefinedCondition , "")] - readsPrec _ "unsupported-encoding" = [(StreamUnsupportedEncoding , "")] - readsPrec _ "unsupported-feature" = [(StreamUnsupportedFeature , "")] - readsPrec _ "unsupported-stanza-type" = [(StreamUnsupportedStanzaType, "")] - readsPrec _ "unsupported-version" = [(StreamUnsupportedVersion , "")] - readsPrec _ _ = [(StreamUndefinedCondition , "")] + deriving (Eq, Read, Show) -- | Encapsulates information about an XMPP stream error. data StreamErrorInfo = StreamErrorInfo @@ -758,7 +564,7 @@ newtype IdGenerator = IdGenerator (IO Text) -- 2.13, which in turn is lesser than 12.3. data Version = Version { majorVersion :: !Integer - , minorVersion :: !Integer } deriving (Eq) + , minorVersion :: !Integer } deriving (Eq, Read, Show) -- If the major version numbers are not equal, compare them. Otherwise, compare -- the minor version numbers. @@ -767,11 +573,11 @@ instance Ord Version where | amajor /= bmajor = compare amajor bmajor | otherwise = compare aminor bminor -instance Read Version where - readsPrec _ txt = (,"") <$> maybeToList (versionFromText $ Text.pack txt) +-- instance Read Version where +-- readsPrec _ txt = (,"") <$> maybeToList (versionFromText $ Text.pack txt) -instance Show Version where - show (Version major minor) = (show major) ++ "." ++ (show minor) +-- instance Show Version where +-- show (Version major minor) = (show major) ++ "." ++ (show minor) -- Converts a "." numeric version number to a @Version@ object. versionFromText :: Text.Text -> Maybe Version @@ -792,25 +598,22 @@ versionParser = do -- has a primary tag and a number of subtags. Two language tags are considered -- equal if and only if they contain the same tags (case-insensitive). data LangTag = LangTag { primaryTag :: !Text - , subtags :: ![Text] } + , subtags :: ![Text] } deriving (Read, Show) +-- Equals for language tags is not case-sensitive. instance Eq LangTag where LangTag p s == LangTag q t = Text.toLower p == Text.toLower q && map Text.toLower s == map Text.toLower t -instance Read LangTag where - readsPrec _ txt = (,"") <$> maybeToList (langTag $ Text.pack txt) - -instance Show LangTag where - show (LangTag p []) = Text.unpack p - show (LangTag p s) = Text.unpack . Text.concat $ - [p, "-", Text.intercalate "-" s] - -- | Parses, validates, and possibly constructs a "LangTag" object. -langTag :: Text.Text -> Maybe LangTag -langTag s = case AP.parseOnly langTagParser s of - Right tag -> Just tag - Left _ -> Nothing +langTagFromText :: Text.Text -> Maybe LangTag +langTagFromText s = case AP.parseOnly langTagParser s of + Right tag -> Just tag + Left _ -> Nothing + +langTagToText :: LangTag -> Text.Text +langTagToText (LangTag p []) = p +langTagToText (LangTag p s) = Text.concat $ [p, "-", Text.intercalate "-" s] -- Parses a language tag as defined by RFC 1766 and constructs a LangTag object. langTagParser :: AP.Parser LangTag From f7415bea47bb58bbce4e219017117c63bb2c993d Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Fri, 28 Jun 2013 20:22:39 +0200 Subject: [PATCH 4/7] Replace additional `xpPrim' calls Moved and started using `xpSaslError'. Added `xpShow' and `xpPriority'. --- source/Network/Xmpp/IM/Presence.hs | 34 ++++++++++++++------------ source/Network/Xmpp/IM/Roster.hs | 21 +++++++++++++++- source/Network/Xmpp/IM/Roster/Types.hs | 17 +------------ source/Network/Xmpp/Marshal.hs | 30 ----------------------- source/Network/Xmpp/Sasl/Common.hs | 32 +++++++++++++++++++++++- 5 files changed, 71 insertions(+), 63 deletions(-) diff --git a/source/Network/Xmpp/IM/Presence.hs b/source/Network/Xmpp/IM/Presence.hs index 0f0ba03..82077ac 100644 --- a/source/Network/Xmpp/IM/Presence.hs +++ b/source/Network/Xmpp/IM/Presence.hs @@ -13,20 +13,7 @@ import Network.Xmpp.Types data ShowStatus = StatusAway | StatusChat | StatusDnd - | StatusXa - -instance Show ShowStatus where - show StatusAway = "away" - show StatusChat = "chat" - show StatusDnd = "dnd" - show StatusXa = "xa" - -instance Read ShowStatus where - readsPrec _ "away" = [(StatusAway, "")] - readsPrec _ "chat" = [(StatusChat, "")] - readsPrec _ "dnd" = [(StatusDnd , "")] - readsPrec _ "xa" = [(StatusXa , "")] - readsPrec _ _ = [] + | StatusXa deriving (Read, Show) data IMPresence = IMP { showStatus :: Maybe ShowStatus , status :: Maybe Text @@ -65,8 +52,25 @@ xpIMPresence = xpUnliftElems . xpClean $ xp3Tuple (xpOption $ xpElemNodes "{jabber:client}show" - (xpContent xpPrim)) + (xpContent xpShow)) (xpOption $ xpElemNodes "{jabber:client}status" (xpContent xpText)) (xpOption $ xpElemNodes "{jabber:client}priority" (xpContent xpPrim)) + +xpShow :: PU Text ShowStatus +xpShow = ("xpShow", "") + xpPartial ( \input -> case showStatusFromText input of + Nothing -> Left "Could not parse show status." + Just j -> Right j) + showStatusToText + where + showStatusFromText "away" = Just StatusAway + showStatusFromText "chat" = Just StatusChat + showStatusFromText "dnd" = Just StatusDnd + showStatusFromText "xa" = Just StatusXa + showStatusFromText _ = Nothing + showStatusToText StatusAway = "away" + showStatusToText StatusChat = "chat" + showStatusToText StatusDnd = "dnd" + showStatusToText StatusXa = "xa" diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs index 6933543..771d69e 100644 --- a/source/Network/Xmpp/IM/Roster.hs +++ b/source/Network/Xmpp/IM/Roster.hs @@ -177,7 +177,7 @@ xpItems = xpWrap (map (\((app_, ask_, jid_, name_, sub_), groups_) -> xpOption $ xpAttribute_ "ask" "subscribe") (xpAttribute "jid" xpJid) (xpAttribute' "name" xpText) - (xpAttribute' "subscription" xpPrim) + (xpAttribute' "subscription" xpSubscription) ) (xpFindMatches $ xpElemText "{jabber:iq:roster}group") @@ -187,3 +187,22 @@ xpQuery = xpWrap (\(ver_, items_) -> Query ver_ items_ ) xpElem "{jabber:iq:roster}query" (xpAttribute' "ver" xpText) xpItems + +xpSubscription :: PU Text Subscription +xpSubscription = ("xpSubscription", "") + xpPartial ( \input -> case subscriptionFromText input of + Nothing -> Left "Could not parse subscription." + Just j -> Right j) + subscriptionToText + where + subscriptionFromText "none" = Just None + subscriptionFromText "to" = Just To + subscriptionFromText "from" = Just From + subscriptionFromText "both" = Just Both + subscriptionFromText "remove" = Just Remove + subscriptionFromText _ = Nothing + subscriptionToText None = "none" + subscriptionToText To = "to" + subscriptionToText From = "from" + subscriptionToText Both = "both" + subscriptionToText Remove = "remove" diff --git a/source/Network/Xmpp/IM/Roster/Types.hs b/source/Network/Xmpp/IM/Roster/Types.hs index b5de0ef..c3af358 100644 --- a/source/Network/Xmpp/IM/Roster/Types.hs +++ b/source/Network/Xmpp/IM/Roster/Types.hs @@ -4,22 +4,7 @@ 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 Subscription = None | To | From | Both | Remove deriving (Eq, Read, Show) data Roster = Roster { ver :: Maybe Text , items :: Map.Map Jid Item } deriving Show diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs index a7ff049..c21c975 100644 --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -427,36 +427,6 @@ xpStanzaErrorCondition = ("xpStanzaErrorCondition", "") stanzaErrorConditionFromText "unexpected-request" = Just UnexpectedRequest stanzaErrorConditionFromText _ = Nothing -xpSaslError :: PU Text SaslError -xpSaslError = ("xpSaslError", "") - xpPartial ( \input -> case saslErrorFromText input of - Nothing -> Left "Could not parse SASL error." - Just j -> Right j) - saslErrorToText - where - saslErrorToText SaslAborted = "aborted" - saslErrorToText SaslAccountDisabled = "account-disabled" - saslErrorToText SaslCredentialsExpired = "credentials-expired" - saslErrorToText SaslEncryptionRequired = "encryption-required" - saslErrorToText SaslIncorrectEncoding = "incorrect-encoding" - saslErrorToText SaslInvalidAuthzid = "invalid-authzid" - saslErrorToText SaslInvalidMechanism = "invalid-mechanism" - saslErrorToText SaslMalformedRequest = "malformed-request" - saslErrorToText SaslMechanismTooWeak = "mechanism-too-weak" - saslErrorToText SaslNotAuthorized = "not-authorized" - saslErrorToText SaslTemporaryAuthFailure = "temporary-auth-failure" - saslErrorFromText "aborted" = Just SaslAborted - saslErrorFromText "account-disabled" = Just SaslAccountDisabled - saslErrorFromText "credentials-expired" = Just SaslCredentialsExpired - saslErrorFromText "encryption-required" = Just SaslEncryptionRequired - saslErrorFromText "incorrect-encoding" = Just SaslIncorrectEncoding - saslErrorFromText "invalid-authzid" = Just SaslInvalidAuthzid - saslErrorFromText "invalid-mechanism" = Just SaslInvalidMechanism - saslErrorFromText "malformed-request" = Just SaslMalformedRequest - saslErrorFromText "mechanism-too-weak" = Just SaslMechanismTooWeak - saslErrorFromText "not-authorized" = Just SaslNotAuthorized - saslErrorFromText "temporary-auth-failure" = Just SaslTemporaryAuthFailure - xpStreamErrorCondition :: PU Text StreamErrorCondition xpStreamErrorCondition = ("xpStreamErrorCondition", "") xpPartial ( \input -> case streamErrorConditionFromText input of diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index fb15668..0687bd1 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -80,10 +80,40 @@ xpFailure = xpWrap (xpContent xpId)) (xpElemByNamespace "urn:ietf:params:xml:ns:xmpp-sasl" - xpPrim + xpSaslError (xpUnit) (xpUnit)))) +xpSaslError :: PU Text.Text SaslError +xpSaslError = ("xpSaslError", "") + xpPartial ( \input -> case saslErrorFromText input of + Nothing -> Left "Could not parse SASL error." + Just j -> Right j) + saslErrorToText + where + saslErrorToText SaslAborted = "aborted" + saslErrorToText SaslAccountDisabled = "account-disabled" + saslErrorToText SaslCredentialsExpired = "credentials-expired" + saslErrorToText SaslEncryptionRequired = "encryption-required" + saslErrorToText SaslIncorrectEncoding = "incorrect-encoding" + saslErrorToText SaslInvalidAuthzid = "invalid-authzid" + saslErrorToText SaslInvalidMechanism = "invalid-mechanism" + saslErrorToText SaslMalformedRequest = "malformed-request" + saslErrorToText SaslMechanismTooWeak = "mechanism-too-weak" + saslErrorToText SaslNotAuthorized = "not-authorized" + saslErrorToText SaslTemporaryAuthFailure = "temporary-auth-failure" + saslErrorFromText "aborted" = Just SaslAborted + saslErrorFromText "account-disabled" = Just SaslAccountDisabled + saslErrorFromText "credentials-expired" = Just SaslCredentialsExpired + saslErrorFromText "encryption-required" = Just SaslEncryptionRequired + saslErrorFromText "incorrect-encoding" = Just SaslIncorrectEncoding + saslErrorFromText "invalid-authzid" = Just SaslInvalidAuthzid + saslErrorFromText "invalid-mechanism" = Just SaslInvalidMechanism + saslErrorFromText "malformed-request" = Just SaslMalformedRequest + saslErrorFromText "mechanism-too-weak" = Just SaslMechanismTooWeak + saslErrorFromText "not-authorized" = Just SaslNotAuthorized + saslErrorFromText "temporary-auth-failure" = Just SaslTemporaryAuthFailure + -- Challenge element pickler. xpChallenge :: PU [Node] (Maybe Text.Text) xpChallenge = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" From ea567c78436a7d67179b074666b7edb8a09a7299 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Fri, 28 Jun 2013 22:47:37 +0200 Subject: [PATCH 5/7] Change LangTag Show/Read instances, add parseLangTag, fix __GLASGOW... --- source/Network/Xmpp.hs | 3 ++- source/Network/Xmpp/Types.hs | 33 ++++++++++++++++++++++++++++----- 2 files changed, 30 insertions(+), 6 deletions(-) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index f230e8f..25712ef 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -46,7 +46,7 @@ module Network.Xmpp -- for addressing entities in the network. It is somewhat similar to an e-mail -- address, but contains three parts instead of two. , Jid -#if __GLASGOW_HASKELL >= 706 +#if __GLASGOW_HASKELL__ >= 706 , jidQ #endif , isBare @@ -174,6 +174,7 @@ module Network.Xmpp , LangTag , langTagFromText , langTagToText + , parseLangTag , XmppFailure(..) , StreamErrorInfo(..) , StreamErrorCondition(..) diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 8181c34..0e66478 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL >= 706 +#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE TemplateHaskell #-} #endif @@ -22,6 +22,7 @@ module Network.Xmpp.Types , LangTag (..) , langTagFromText , langTagToText + , parseLangTag , Message(..) , message , MessageError(..) @@ -50,7 +51,7 @@ module Network.Xmpp.Types , ConnectionDetails(..) , StreamConfiguration(..) , Jid(..) -#if __GLASGOW_HASKELL >= 706 +#if __GLASGOW_HASKELL__ >= 706 , jidQ #endif , isBare @@ -86,7 +87,7 @@ import Data.Text (Text) import qualified Data.Text as Text import Data.Typeable(Typeable) import Data.XML.Types -#if __GLASGOW_HASKELL >= 706 +#if __GLASGOW_HASKELL__ >= 706 import Language.Haskell.TH import Language.Haskell.TH.Quote #endif @@ -598,7 +599,7 @@ versionParser = do -- has a primary tag and a number of subtags. Two language tags are considered -- equal if and only if they contain the same tags (case-insensitive). data LangTag = LangTag { primaryTag :: !Text - , subtags :: ![Text] } deriving (Read, Show) + , subtags :: ![Text] } -- Equals for language tags is not case-sensitive. instance Eq LangTag where @@ -774,7 +775,7 @@ instance Read Jid where [(parseJid (read s' :: String), r)] -- May fail with "Prelude.read: no parse" -- or the `parseJid' error message (see below) -#if __GLASGOW_HASKELL >= 706 +#if __GLASGOW_HASKELL__ >= 706 jidQ :: QuasiQuoter jidQ = QuasiQuoter { quoteExp = \s -> do when (head s == ' ') . fail $ "Leading whitespaces in JID" ++ show s @@ -796,6 +797,28 @@ jidQ = QuasiQuoter { quoteExp = \s -> do mbTextE (Just s) = [| Just $(textE s) |] #endif +-- Produces a LangTag value in the format "parseLangTag \"\"". +instance Show LangTag where + show l = "parseLangTag " ++ show (langTagToText l) + +-- The string must be in the format "parseLangTag \"\"". This is based +-- on parseJid, and suffers the same problems. +instance Read LangTag where + readsPrec _ s = do + let (s', r) = case lex s of + [] -> error "Expected `parseLangTag \"\"'" + [("parseLangTag", r')] -> case lex r' of + [] -> error "Expected `parseLangTag \"\"'" + [(s'', r'')] -> (s'', r'') + _ -> error "Expected `parseLangTag \"\"'" + _ -> error "Expected `parseLangTag \"\"'" + [(parseLangTag (read s' :: String), r)] + +parseLangTag :: String -> LangTag +parseLangTag s = case langTagFromText $ Text.pack s of + Just l -> l + Nothing -> error $ "Language tag value (" ++ s ++ ") did not validate" + -- | Parses a JID string. -- -- Note: This function is only meant to be used to reverse @Jid@ Show From 57bb2a1d21e5242d77e6cca5162ed084b2b6bb70 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Mon, 1 Jul 2013 18:28:58 +0200 Subject: [PATCH 6/7] Utilities.hs: Implemented `IO [Int]' function for reconnection waiting --- source/Network/Xmpp/Utilities.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/source/Network/Xmpp/Utilities.hs b/source/Network/Xmpp/Utilities.hs index 87d9a91..c383715 100644 --- a/source/Network/Xmpp/Utilities.hs +++ b/source/Network/Xmpp/Utilities.hs @@ -28,6 +28,7 @@ import Prelude import System.IO.Unsafe(unsafePerformIO) import qualified Text.XML.Stream.Render as TXSR import Text.XML.Unresolved as TXU +import System.Random -- | Apply f with the content of tv as state, restoring the original value when an -- exception occurs @@ -92,3 +93,13 @@ hostnameP = do if Text.length label + 1 + Text.length r > 255 then fail "Hostname too long." else return $ Text.concat [label, Text.pack ".", r] + +-- The number of seconds to wait before reconnection attempts in accordance with +-- the truncated binary exponential backoff algorithm. +waitingTimes :: IO [Int] +waitingTimes = do + wait <- randomRIO (1, 59) + waits <- Prelude.mapM (\n -> randomRIO (0, wait * n)) slotTimes + return (wait:waits) + where + slotTimes = [1, 3, 8, 15, 24, 35, 48, 63, 80, 99, 99, 99, 99, 99, 99] From 52961a70a460693a4693eda41701baf8244039cd Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Mon, 1 Jul 2013 18:34:19 +0200 Subject: [PATCH 7/7] IQ.hs: Set default time-out value to 30 instead of 3 --- source/Network/Xmpp/Concurrent/IQ.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/source/Network/Xmpp/Concurrent/IQ.hs b/source/Network/Xmpp/Concurrent/IQ.hs index 17d3298..2204493 100644 --- a/source/Network/Xmpp/Concurrent/IQ.hs +++ b/source/Network/Xmpp/Concurrent/IQ.hs @@ -54,7 +54,7 @@ sendIQ timeOut to tp lang body session = do -- TODO: Add timeout return () --- | Like 'sendIQ', but waits for the answer IQ. Times out after 3 seconds +-- | Like 'sendIQ', but waits for the answer IQ. Times out after 30 seconds sendIQ' :: Maybe Jid -> IQRequestType -> Maybe LangTag @@ -62,7 +62,7 @@ sendIQ' :: Maybe Jid -> Session -> IO (Maybe IQResponse) sendIQ' to tp lang body session = do - ref <- sendIQ (Just 3000000) to tp lang body session + ref <- sendIQ (Just 30000000) to tp lang body session maybe (return Nothing) (fmap Just . atomically . takeTMVar) ref