|
|
|
@ -11,7 +11,42 @@ |
|
|
|
{-# LANGUAGE OverloadedStrings #-} |
|
|
|
{-# LANGUAGE OverloadedStrings #-} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
module Network.XMPP.Types where |
|
|
|
module Network.XMPP.Types |
|
|
|
|
|
|
|
( IQError(..) |
|
|
|
|
|
|
|
, IQRequest(..) |
|
|
|
|
|
|
|
, IQRequestType(..) |
|
|
|
|
|
|
|
, IQResponse |
|
|
|
|
|
|
|
, IQResult(..) |
|
|
|
|
|
|
|
, IdGenerator(..) |
|
|
|
|
|
|
|
, LangTag (..) |
|
|
|
|
|
|
|
, Message(..) |
|
|
|
|
|
|
|
, MessageError(..) |
|
|
|
|
|
|
|
, MessageType(..) |
|
|
|
|
|
|
|
, Presence(..) |
|
|
|
|
|
|
|
, PresenceError(..) |
|
|
|
|
|
|
|
, PresenceType(..) |
|
|
|
|
|
|
|
, SaslError(..) |
|
|
|
|
|
|
|
, SaslFailure(..) |
|
|
|
|
|
|
|
, ServerAddress(..) |
|
|
|
|
|
|
|
, ServerFeatures(..) |
|
|
|
|
|
|
|
, ShowType(..) |
|
|
|
|
|
|
|
, Stanza(..) |
|
|
|
|
|
|
|
, StanzaError(..) |
|
|
|
|
|
|
|
, StanzaErrorCondition(..) |
|
|
|
|
|
|
|
, StanzaErrorType(..) |
|
|
|
|
|
|
|
, StanzaId(..) |
|
|
|
|
|
|
|
, StreamError(..) |
|
|
|
|
|
|
|
, Version(..) |
|
|
|
|
|
|
|
, XMPPConMonad |
|
|
|
|
|
|
|
, XmppConnection(..) |
|
|
|
|
|
|
|
, XmppConnectionState(..) |
|
|
|
|
|
|
|
, XmppNoConnection(..) |
|
|
|
|
|
|
|
, XMPPT(..) |
|
|
|
|
|
|
|
, XmppStreamError(..) |
|
|
|
|
|
|
|
, parseLangTag |
|
|
|
|
|
|
|
, module Network.XMPP.JID |
|
|
|
|
|
|
|
) |
|
|
|
|
|
|
|
where |
|
|
|
|
|
|
|
|
|
|
|
-- import Network.XMPP.Utilities (idGenerator) |
|
|
|
-- import Network.XMPP.Utilities (idGenerator) |
|
|
|
|
|
|
|
|
|
|
|
@ -24,7 +59,6 @@ import Control.Monad.Error |
|
|
|
|
|
|
|
|
|
|
|
import qualified Data.ByteString as BS |
|
|
|
import qualified Data.ByteString as BS |
|
|
|
import Data.Conduit |
|
|
|
import Data.Conduit |
|
|
|
import Data.List.Split as L |
|
|
|
|
|
|
|
import Data.String(IsString(..)) |
|
|
|
import Data.String(IsString(..)) |
|
|
|
import Data.Text (Text) |
|
|
|
import Data.Text (Text) |
|
|
|
import qualified Data.Text as Text |
|
|
|
import qualified Data.Text as Text |
|
|
|
@ -33,16 +67,9 @@ import Data.XML.Types |
|
|
|
|
|
|
|
|
|
|
|
import qualified Network as N |
|
|
|
import qualified Network as N |
|
|
|
|
|
|
|
|
|
|
|
import System.IO |
|
|
|
import Network.XMPP.JID |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- | The string prefix MUST be |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
data SessionSettings = |
|
|
|
|
|
|
|
SessionSettings { ssIdPrefix :: String |
|
|
|
|
|
|
|
, ssIdGenerator :: IdGenerator |
|
|
|
|
|
|
|
, ssStreamLang :: LangTag } |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
import System.IO |
|
|
|
|
|
|
|
|
|
|
|
-- ============================================================================= |
|
|
|
-- ============================================================================= |
|
|
|
-- STANZA TYPES |
|
|
|
-- STANZA TYPES |
|
|
|
@ -74,38 +101,6 @@ instance Read StanzaId where |
|
|
|
instance IsString StanzaId where |
|
|
|
instance IsString StanzaId where |
|
|
|
fromString = SI . Text.pack |
|
|
|
fromString = SI . Text.pack |
|
|
|
|
|
|
|
|
|
|
|
-- | |
|
|
|
|
|
|
|
-- @From@ is a readability type synonym for @Address@. |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- | Jabber ID (JID) datatype |
|
|
|
|
|
|
|
data JID = JID { localpart :: !(Maybe Text) |
|
|
|
|
|
|
|
-- ^ Account name |
|
|
|
|
|
|
|
, domainpart :: !Text |
|
|
|
|
|
|
|
-- ^ Server adress |
|
|
|
|
|
|
|
, resourcepart :: !(Maybe Text) |
|
|
|
|
|
|
|
-- ^ Resource name |
|
|
|
|
|
|
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
instance Show JID where |
|
|
|
|
|
|
|
show (JID nd dmn res) = |
|
|
|
|
|
|
|
maybe "" ((++ "@") . Text.unpack) nd ++ |
|
|
|
|
|
|
|
(Text.unpack dmn) ++ |
|
|
|
|
|
|
|
maybe "" (('/' :) . Text.unpack) res |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
parseJID :: [Char] -> [JID] |
|
|
|
|
|
|
|
parseJID jid = do |
|
|
|
|
|
|
|
(jid', rst) <- case L.splitOn "@" jid of |
|
|
|
|
|
|
|
[rest] -> [(JID Nothing, rest)] |
|
|
|
|
|
|
|
[nd,rest] -> [(JID (Just (Text.pack nd)), rest)] |
|
|
|
|
|
|
|
_ -> [] |
|
|
|
|
|
|
|
case L.splitOn "/" rst of |
|
|
|
|
|
|
|
[dmn] -> [jid' (Text.pack dmn) Nothing] |
|
|
|
|
|
|
|
[dmn, rsrc] -> [jid' (Text.pack dmn) (Just (Text.pack rsrc))] |
|
|
|
|
|
|
|
_ -> [] |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
instance Read JID where |
|
|
|
|
|
|
|
readsPrec _ x = (,"") <$> parseJID x |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- An Info/Query (IQ) stanza is either of the type "request" ("get" or |
|
|
|
-- An Info/Query (IQ) stanza is either of the type "request" ("get" or |
|
|
|
-- "set") or "response" ("result" or "error"). The @IQ@ type wraps |
|
|
|
-- "set") or "response" ("result" or "error"). The @IQ@ type wraps |
|
|
|
-- these two sub-types. |
|
|
|
-- these two sub-types. |
|
|
|
@ -120,14 +115,11 @@ data Stanza = IQRequestS IQRequest |
|
|
|
| MessageErrorS MessageError |
|
|
|
| MessageErrorS MessageError |
|
|
|
| PresenceS Presence |
|
|
|
| PresenceS Presence |
|
|
|
| PresenceErrorS PresenceError |
|
|
|
| PresenceErrorS PresenceError |
|
|
|
|
|
|
|
deriving Show |
|
|
|
|
|
|
|
|
|
|
|
-- | |
|
|
|
-- | |
|
|
|
-- A "request" Info/Query (IQ) stanza is one with either "get" or |
|
|
|
-- A "request" Info/Query (IQ) stanza is one with either "get" or |
|
|
|
-- "set" as type. They are guaranteed to always contain a payload. |
|
|
|
-- "set" as type. They are guaranteed to always contain a payload. |
|
|
|
-- |
|
|
|
|
|
|
|
-- Objects of this type cannot be generated by Pontarius applications, |
|
|
|
|
|
|
|
-- but are only created internally. |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
data IQRequest = IQRequest { iqRequestID :: StanzaId |
|
|
|
data IQRequest = IQRequest { iqRequestID :: StanzaId |
|
|
|
, iqRequestFrom :: Maybe JID |
|
|
|
, iqRequestFrom :: Maybe JID |
|
|
|
, iqRequestTo :: Maybe JID |
|
|
|
, iqRequestTo :: Maybe JID |
|
|
|
@ -137,7 +129,7 @@ data IQRequest = IQRequest { iqRequestID :: StanzaId |
|
|
|
} |
|
|
|
} |
|
|
|
deriving (Show) |
|
|
|
deriving (Show) |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- | The type of request that is made |
|
|
|
data IQRequestType = Get | Set deriving (Eq, Ord) |
|
|
|
data IQRequestType = Get | Set deriving (Eq, Ord) |
|
|
|
|
|
|
|
|
|
|
|
instance Show IQRequestType where |
|
|
|
instance Show IQRequestType where |
|
|
|
@ -149,21 +141,12 @@ instance Read IQRequestType where |
|
|
|
readsPrec _ "set" = [(Set, "")] |
|
|
|
readsPrec _ "set" = [(Set, "")] |
|
|
|
readsPrec _ _ = [] |
|
|
|
readsPrec _ _ = [] |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- | A "response" Info/Query (IQ) stanza is eitheran 'IQError' or an IQ stanza |
|
|
|
-- | |
|
|
|
-- with the type "result" ('IQResult') |
|
|
|
-- A "response" Info/Query (IQ) stanza is one with either "result" or |
|
|
|
|
|
|
|
-- "error" as type. We have devided IQ responses into two types. |
|
|
|
|
|
|
|
-- |
|
|
|
|
|
|
|
-- Objects of this type cannot be generated by Pontarius applications, |
|
|
|
|
|
|
|
-- but are only created internally. |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
type IQResponse = Either IQError IQResult |
|
|
|
type IQResponse = Either IQError IQResult |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- | The answer to an IQ request |
|
|
|
-- | |
|
|
|
|
|
|
|
-- Objects of this type cannot be generated by Pontarius applications, |
|
|
|
|
|
|
|
-- but are only created internally. |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
data IQResult = IQResult { iqResultID :: StanzaId |
|
|
|
data IQResult = IQResult { iqResultID :: StanzaId |
|
|
|
, iqResultFrom :: Maybe JID |
|
|
|
, iqResultFrom :: Maybe JID |
|
|
|
, iqResultTo :: Maybe JID |
|
|
|
, iqResultTo :: Maybe JID |
|
|
|
@ -171,11 +154,7 @@ data IQResult = IQResult { iqResultID :: StanzaId |
|
|
|
, iqResultPayload :: Maybe Element } |
|
|
|
, iqResultPayload :: Maybe Element } |
|
|
|
deriving (Show) |
|
|
|
deriving (Show) |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- | The answer to an IQ request that generated an error |
|
|
|
-- | |
|
|
|
|
|
|
|
-- Objects of this type cannot be generated by Pontarius applications, |
|
|
|
|
|
|
|
-- but are only created internally. |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
data IQError = IQError { iqErrorID :: StanzaId |
|
|
|
data IQError = IQError { iqErrorID :: StanzaId |
|
|
|
, iqErrorFrom :: Maybe JID |
|
|
|
, iqErrorFrom :: Maybe JID |
|
|
|
, iqErrorTo :: Maybe JID |
|
|
|
, iqErrorTo :: Maybe JID |
|
|
|
@ -185,12 +164,7 @@ data IQError = IQError { iqErrorID :: StanzaId |
|
|
|
} |
|
|
|
} |
|
|
|
deriving (Show) |
|
|
|
deriving (Show) |
|
|
|
|
|
|
|
|
|
|
|
-- | |
|
|
|
-- | The message stanza. Used for /push/ type communication |
|
|
|
-- A non-error message stanza. |
|
|
|
|
|
|
|
-- |
|
|
|
|
|
|
|
-- Objects of this type cannot be generated by Pontarius applications, |
|
|
|
|
|
|
|
-- but are only created internally. |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
data Message = Message { messageID :: Maybe StanzaId |
|
|
|
data Message = Message { messageID :: Maybe StanzaId |
|
|
|
, messageFrom :: Maybe JID |
|
|
|
, messageFrom :: Maybe JID |
|
|
|
, messageTo :: Maybe JID |
|
|
|
, messageTo :: Maybe JID |
|
|
|
@ -203,13 +177,7 @@ data Message = Message { messageID :: Maybe StanzaId |
|
|
|
} |
|
|
|
} |
|
|
|
deriving (Show) |
|
|
|
deriving (Show) |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- | An error stanza generated in response to a 'Message' |
|
|
|
-- | |
|
|
|
|
|
|
|
-- An error message stanza. |
|
|
|
|
|
|
|
-- |
|
|
|
|
|
|
|
-- Objects of this type cannot be generated by Pontarius applications, |
|
|
|
|
|
|
|
-- but are only created internally. |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
data MessageError = MessageError { messageErrorID :: Maybe StanzaId |
|
|
|
data MessageError = MessageError { messageErrorID :: Maybe StanzaId |
|
|
|
, messageErrorFrom :: Maybe JID |
|
|
|
, messageErrorFrom :: Maybe JID |
|
|
|
, messageErrorTo :: Maybe JID |
|
|
|
, messageErrorTo :: Maybe JID |
|
|
|
@ -220,15 +188,47 @@ data MessageError = MessageError { messageErrorID :: Maybe StanzaId |
|
|
|
deriving (Show) |
|
|
|
deriving (Show) |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- | |
|
|
|
-- | The type of a Message being sent |
|
|
|
-- @MessageType@ holds XMPP message types as defined in XMPP-IM. The |
|
|
|
-- (<http://xmpp.org/rfcs/rfc6121.html#message-syntax-type>) |
|
|
|
-- "error" message type is left out as errors are wrapped in |
|
|
|
data MessageType = -- | The message is sent in the context of a one-to-one chat |
|
|
|
-- @MessageError@. |
|
|
|
-- session. Typically an interactive client will present a |
|
|
|
|
|
|
|
-- message of type /chat/ in an interface that enables |
|
|
|
data MessageType = Chat | -- ^ |
|
|
|
-- one-to-one chat between the two parties, including an |
|
|
|
GroupChat | -- ^ |
|
|
|
-- appropriate conversation history. |
|
|
|
Headline | -- ^ |
|
|
|
Chat |
|
|
|
Normal -- ^ The default message type |
|
|
|
-- | The message is sent in the context of a |
|
|
|
|
|
|
|
-- multi-user chat environment (similar to that of |
|
|
|
|
|
|
|
-- @IRC@). Typically a receiving client will |
|
|
|
|
|
|
|
-- present a message of type /groupchat/ in an |
|
|
|
|
|
|
|
-- interface that enables many-to-many chat |
|
|
|
|
|
|
|
-- between the parties, including a roster of |
|
|
|
|
|
|
|
-- parties in the chatroom and an appropriate |
|
|
|
|
|
|
|
-- conversation history. |
|
|
|
|
|
|
|
| GroupChat |
|
|
|
|
|
|
|
-- | The message provides an alert, a |
|
|
|
|
|
|
|
-- notification, or other transient information to |
|
|
|
|
|
|
|
-- which no reply is expected (e.g., news |
|
|
|
|
|
|
|
-- headlines, sports updates, near-real-time |
|
|
|
|
|
|
|
-- market data, or syndicated content). Because no |
|
|
|
|
|
|
|
-- reply to the message is expected, typically a |
|
|
|
|
|
|
|
-- receiving client will present a message of type |
|
|
|
|
|
|
|
-- /headline/ in an interface that appropriately |
|
|
|
|
|
|
|
-- differentiates the message from standalone |
|
|
|
|
|
|
|
-- messages, chat messages, and groupchat messages |
|
|
|
|
|
|
|
-- (e.g., by not providing the recipient with the |
|
|
|
|
|
|
|
-- ability to reply). |
|
|
|
|
|
|
|
| Headline |
|
|
|
|
|
|
|
-- | The message is a standalone message that is |
|
|
|
|
|
|
|
-- sent outside the context of a one-to-one |
|
|
|
|
|
|
|
-- conversation or groupchat, and to which it is |
|
|
|
|
|
|
|
-- expected that the recipient will |
|
|
|
|
|
|
|
-- reply. Typically a receiving client will |
|
|
|
|
|
|
|
-- present a message of type /normal/ in an |
|
|
|
|
|
|
|
-- interface that enables the recipient to reply, |
|
|
|
|
|
|
|
-- but without a conversation history. |
|
|
|
|
|
|
|
-- |
|
|
|
|
|
|
|
-- This is the /default/ value |
|
|
|
|
|
|
|
| Normal |
|
|
|
deriving (Eq) |
|
|
|
deriving (Eq) |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
@ -341,7 +341,6 @@ instance Read ShowType where |
|
|
|
-- wrapped in the @StanzaError@ type. |
|
|
|
-- wrapped in the @StanzaError@ type. |
|
|
|
|
|
|
|
|
|
|
|
-- TODO: Sender XML is (optional and is) not included. |
|
|
|
-- TODO: Sender XML is (optional and is) not included. |
|
|
|
|
|
|
|
|
|
|
|
data StanzaError = StanzaError { stanzaErrorType :: StanzaErrorType |
|
|
|
data StanzaError = StanzaError { stanzaErrorType :: StanzaErrorType |
|
|
|
, stanzaErrorCondition :: StanzaErrorCondition |
|
|
|
, stanzaErrorCondition :: StanzaErrorCondition |
|
|
|
, stanzaErrorText :: Maybe (Maybe LangTag, Text) |
|
|
|
, stanzaErrorText :: Maybe (Maybe LangTag, Text) |
|
|
|
@ -471,81 +470,172 @@ instance Read StanzaErrorCondition where |
|
|
|
-- OTHER STUFF |
|
|
|
-- OTHER STUFF |
|
|
|
-- ============================================================================= |
|
|
|
-- ============================================================================= |
|
|
|
|
|
|
|
|
|
|
|
data SASLFailure = SASLFailure { saslFailureCondition :: SASLError |
|
|
|
data SaslFailure = SaslFailure { saslFailureCondition :: SaslError |
|
|
|
, saslFailureText :: Maybe Text } -- TODO: XMLLang |
|
|
|
, saslFailureText :: Maybe ( Maybe LangTag |
|
|
|
|
|
|
|
, Text |
|
|
|
|
|
|
|
) |
|
|
|
|
|
|
|
} deriving Show |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
data SASLError = -- SASLAborted | -- Client aborted - should not happen |
|
|
|
data SaslError = SaslAborted -- ^ Client aborted |
|
|
|
SASLAccountDisabled | -- ^ The account has been temporarily |
|
|
|
| SaslAccountDisabled -- ^ The account has been temporarily |
|
|
|
-- disabled |
|
|
|
-- disabled |
|
|
|
SASLCredentialsExpired | -- ^ The authentication failed because |
|
|
|
| SaslCredentialsExpired -- ^ The authentication failed because |
|
|
|
-- the credentials have expired |
|
|
|
-- the credentials have expired |
|
|
|
SASLEncryptionRequired | -- ^ The mechanism requested cannot be |
|
|
|
| SaslEncryptionRequired -- ^ The mechanism requested cannot be |
|
|
|
-- used the confidentiality and |
|
|
|
-- used the confidentiality and |
|
|
|
-- integrity of the underlying |
|
|
|
-- integrity of the underlying |
|
|
|
-- stream is protected (typically |
|
|
|
-- stream is protected (typically |
|
|
|
-- with TLS) |
|
|
|
-- with TLS) |
|
|
|
-- SASLIncorrectEncoding | -- The base64 encoding is incorrect |
|
|
|
| SaslIncorrectEncoding -- ^ The base64 encoding is incorrect |
|
|
|
-- - should not happen |
|
|
|
| SaslInvalidAuthzid -- ^ The authzid has an incorrect |
|
|
|
-- SASLInvalidAuthzid | -- The authzid has an incorrect format, |
|
|
|
-- format or the initiating entity does |
|
|
|
-- or the initiating entity does not |
|
|
|
-- not have the appropriate permissions |
|
|
|
-- have the appropriate permissions to |
|
|
|
-- to authorize that ID |
|
|
|
-- authorize that ID |
|
|
|
| SaslInvalidMechanism -- ^ The mechanism is not supported by |
|
|
|
SASLInvalidMechanism | -- ^ The mechanism is not supported by |
|
|
|
|
|
|
|
-- the receiving entity |
|
|
|
-- the receiving entity |
|
|
|
-- SASLMalformedRequest | -- Invalid syntax - should not happen |
|
|
|
| SaslMalformedRequest -- ^ Invalid syntax |
|
|
|
SASLMechanismTooWeak | -- ^ The receiving entity policy |
|
|
|
| SaslMechanismTooWeak -- ^ The receiving entity policy |
|
|
|
-- requires a stronger mechanism |
|
|
|
-- requires a stronger mechanism |
|
|
|
SASLNotAuthorized (Maybe Text) | -- ^ Invalid credentials |
|
|
|
| SaslNotAuthorized -- ^ Invalid credentials |
|
|
|
-- provided, or some |
|
|
|
-- provided, or some |
|
|
|
-- generic authentication |
|
|
|
-- generic authentication |
|
|
|
-- failure has occurred |
|
|
|
-- failure has occurred |
|
|
|
SASLTemporaryAuthFailure -- ^ There receiving entity reported a |
|
|
|
| SaslTemporaryAuthFailure -- ^ There receiving entity reported a |
|
|
|
-- temporary error condition; the |
|
|
|
-- temporary error condition; the |
|
|
|
-- initiating entity is recommended |
|
|
|
-- initiating entity is recommended |
|
|
|
-- to try again later |
|
|
|
-- to try again later |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
instance Show SaslError where |
|
|
|
|
|
|
|
show SaslAborted = "aborted" |
|
|
|
|
|
|
|
show SaslAccountDisabled = "account-disabled" |
|
|
|
|
|
|
|
show SaslCredentialsExpired = "credentials-expired" |
|
|
|
|
|
|
|
show SaslEncryptionRequired = "encryption-required" |
|
|
|
|
|
|
|
show SaslIncorrectEncoding = "incorrect-encoding" |
|
|
|
|
|
|
|
show SaslInvalidAuthzid = "invalid-authzid" |
|
|
|
|
|
|
|
show SaslInvalidMechanism = "invalid-mechanism" |
|
|
|
|
|
|
|
show SaslMalformedRequest = "malformed-request" |
|
|
|
|
|
|
|
show SaslMechanismTooWeak = "mechanism-too-weak" |
|
|
|
|
|
|
|
show SaslNotAuthorized = "not-authorized" |
|
|
|
|
|
|
|
show SaslTemporaryAuthFailure = "temporary-auth-failure" |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
instance Read SaslError where |
|
|
|
|
|
|
|
readsPrec _ "aborted" = [(SaslAborted , "")] |
|
|
|
|
|
|
|
readsPrec _ "account-disabled" = [(SaslAccountDisabled , "")] |
|
|
|
|
|
|
|
readsPrec _ "credentials-expired" = [(SaslCredentialsExpired , "")] |
|
|
|
|
|
|
|
readsPrec _ "encryption-required" = [(SaslEncryptionRequired , "")] |
|
|
|
|
|
|
|
readsPrec _ "incorrect-encoding" = [(SaslIncorrectEncoding , "")] |
|
|
|
|
|
|
|
readsPrec _ "invalid-authzid" = [(SaslInvalidAuthzid , "")] |
|
|
|
|
|
|
|
readsPrec _ "invalid-mechanism" = [(SaslInvalidMechanism , "")] |
|
|
|
|
|
|
|
readsPrec _ "malformed-request" = [(SaslMalformedRequest , "")] |
|
|
|
|
|
|
|
readsPrec _ "mechanism-too-weak" = [(SaslMechanismTooWeak , "")] |
|
|
|
|
|
|
|
readsPrec _ "not-authorized" = [(SaslNotAuthorized , "")] |
|
|
|
|
|
|
|
readsPrec _ "temporary-auth-failure" = [(SaslTemporaryAuthFailure , "")] |
|
|
|
|
|
|
|
readsPrec _ _ = [] |
|
|
|
|
|
|
|
|
|
|
|
-- | Readability type for host name Texts. |
|
|
|
-- | Readability type for host name Texts. |
|
|
|
|
|
|
|
|
|
|
|
-- type HostName = Text -- This is defined in Network as well |
|
|
|
-- type HostName = Text -- This is defined in Network as well |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- | Readability type for port number Integers. |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
type PortNumber = Integer -- We use N(etwork).PortID (PortNumber) internally |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- | Readability type for user name Texts. |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
type UserName = Text |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- | Readability type for password Texts. |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
type Password = Text |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- | Readability type for (Address) resource identifier Texts. |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
type Resource = Text |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
type StreamID = Text |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq) |
|
|
|
data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq) |
|
|
|
|
|
|
|
|
|
|
|
type Timeout = Int |
|
|
|
-- TODO: document the error cases |
|
|
|
|
|
|
|
data StreamErrorCondition = StreamBadFormat |
|
|
|
|
|
|
|
| StreamBadNamespacePrefix |
|
|
|
|
|
|
|
| StreamConflict |
|
|
|
|
|
|
|
| StreamConnectionTimeout |
|
|
|
|
|
|
|
| StreamHostGone |
|
|
|
|
|
|
|
| StreamHostUnknown |
|
|
|
|
|
|
|
| StreamImproperAddressing |
|
|
|
|
|
|
|
| StreamInternalServerError |
|
|
|
|
|
|
|
| StreamInvalidFrom |
|
|
|
|
|
|
|
| StreamInvalidNamespace |
|
|
|
|
|
|
|
| StreamInvalidXml |
|
|
|
|
|
|
|
| StreamNotAuthorized |
|
|
|
|
|
|
|
| StreamNotWellFormed |
|
|
|
|
|
|
|
| StreamPolicyViolation |
|
|
|
|
|
|
|
| StreamRemoteConnectionFailed |
|
|
|
|
|
|
|
| StreamReset |
|
|
|
|
|
|
|
| StreamResourceConstraint |
|
|
|
|
|
|
|
| StreamRestrictedXml |
|
|
|
|
|
|
|
| StreamSeeOtherHost |
|
|
|
|
|
|
|
| StreamSystemShutdown |
|
|
|
|
|
|
|
| StreamUndefinedCondition |
|
|
|
|
|
|
|
| StreamUnsupportedEncoding |
|
|
|
|
|
|
|
| StreamUnsupportedFeature |
|
|
|
|
|
|
|
| StreamUnsupportedStanzaType |
|
|
|
|
|
|
|
| StreamUnsupportedVersion |
|
|
|
|
|
|
|
deriving Eq |
|
|
|
|
|
|
|
|
|
|
|
data StreamError = StreamError String |
|
|
|
instance Show StreamErrorCondition where |
|
|
|
|
|
|
|
show StreamBadFormat = "bad-format" |
|
|
|
|
|
|
|
show StreamBadNamespacePrefix = "bad-namespace-prefix" |
|
|
|
|
|
|
|
show StreamConflict = "conflict" |
|
|
|
|
|
|
|
show StreamConnectionTimeout = "connection-timeout" |
|
|
|
|
|
|
|
show StreamHostGone = "host-gone" |
|
|
|
|
|
|
|
show StreamHostUnknown = "host-unknown" |
|
|
|
|
|
|
|
show StreamImproperAddressing = "improper-addressing" |
|
|
|
|
|
|
|
show StreamInternalServerError = "internal-server-error" |
|
|
|
|
|
|
|
show StreamInvalidFrom = "invalid-from" |
|
|
|
|
|
|
|
show StreamInvalidNamespace = "invalid-namespace" |
|
|
|
|
|
|
|
show StreamInvalidXml = "invalid-xml" |
|
|
|
|
|
|
|
show StreamNotAuthorized = "not-authorized" |
|
|
|
|
|
|
|
show StreamNotWellFormed = "not-well-formed" |
|
|
|
|
|
|
|
show StreamPolicyViolation = "policy-violation" |
|
|
|
|
|
|
|
show StreamRemoteConnectionFailed = "remote-connection-failed" |
|
|
|
|
|
|
|
show StreamReset = "reset" |
|
|
|
|
|
|
|
show StreamResourceConstraint = "resource-constraint" |
|
|
|
|
|
|
|
show StreamRestrictedXml = "restricted-xml" |
|
|
|
|
|
|
|
show StreamSeeOtherHost = "see-other-host" |
|
|
|
|
|
|
|
show StreamSystemShutdown = "system-shutdown" |
|
|
|
|
|
|
|
show StreamUndefinedCondition = "undefined-condition" |
|
|
|
|
|
|
|
show StreamUnsupportedEncoding = "unsupported-encoding" |
|
|
|
|
|
|
|
show StreamUnsupportedFeature = "unsupported-feature" |
|
|
|
|
|
|
|
show StreamUnsupportedStanzaType = "unsupported-stanza-type" |
|
|
|
|
|
|
|
show StreamUnsupportedVersion = "unsupported-version" |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
instance Read StreamErrorCondition where |
|
|
|
|
|
|
|
readsPrec _ "bad-format" = [(StreamBadFormat , "")] |
|
|
|
|
|
|
|
readsPrec _ "bad-namespace-prefix" = [(StreamBadNamespacePrefix , "")] |
|
|
|
|
|
|
|
readsPrec _ "conflict" = [(StreamConflict , "")] |
|
|
|
|
|
|
|
readsPrec _ "connection-timeout" = [(StreamConnectionTimeout , "")] |
|
|
|
|
|
|
|
readsPrec _ "host-gone" = [(StreamHostGone , "")] |
|
|
|
|
|
|
|
readsPrec _ "host-unknown" = [(StreamHostUnknown , "")] |
|
|
|
|
|
|
|
readsPrec _ "improper-addressing" = [(StreamImproperAddressing , "")] |
|
|
|
|
|
|
|
readsPrec _ "internal-server-error" = [(StreamInternalServerError , "")] |
|
|
|
|
|
|
|
readsPrec _ "invalid-from" = [(StreamInvalidFrom , "")] |
|
|
|
|
|
|
|
readsPrec _ "invalid-namespace" = [(StreamInvalidNamespace , "")] |
|
|
|
|
|
|
|
readsPrec _ "invalid-xml" = [(StreamInvalidXml , "")] |
|
|
|
|
|
|
|
readsPrec _ "not-authorized" = [(StreamNotAuthorized , "")] |
|
|
|
|
|
|
|
readsPrec _ "not-well-formed" = [(StreamNotWellFormed , "")] |
|
|
|
|
|
|
|
readsPrec _ "policy-violation" = [(StreamPolicyViolation , "")] |
|
|
|
|
|
|
|
readsPrec _ "remote-connection-failed" = [(StreamRemoteConnectionFailed , "")] |
|
|
|
|
|
|
|
readsPrec _ "reset" = [(StreamReset , "")] |
|
|
|
|
|
|
|
readsPrec _ "resource-constraint" = [(StreamResourceConstraint , "")] |
|
|
|
|
|
|
|
readsPrec _ "restricted-xml" = [(StreamRestrictedXml , "")] |
|
|
|
|
|
|
|
readsPrec _ "see-other-host" = [(StreamSeeOtherHost , "")] |
|
|
|
|
|
|
|
readsPrec _ "system-shutdown" = [(StreamSystemShutdown , "")] |
|
|
|
|
|
|
|
readsPrec _ "undefined-condition" = [(StreamUndefinedCondition , "")] |
|
|
|
|
|
|
|
readsPrec _ "unsupported-encoding" = [(StreamUnsupportedEncoding , "")] |
|
|
|
|
|
|
|
readsPrec _ "unsupported-feature" = [(StreamUnsupportedFeature , "")] |
|
|
|
|
|
|
|
readsPrec _ "unsupported-stanza-type" = [(StreamUnsupportedStanzaType , "")] |
|
|
|
|
|
|
|
readsPrec _ "unsupported-version" = [(StreamUnsupportedVersion , "")] |
|
|
|
|
|
|
|
readsPrec _ _ = [(StreamUndefinedCondition , "")] |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
data XmppStreamError = XmppStreamError |
|
|
|
|
|
|
|
{ errorCondition :: StreamErrorCondition |
|
|
|
|
|
|
|
, errorText :: Maybe (Maybe LangTag, Text) |
|
|
|
|
|
|
|
, errorXML :: Maybe Element |
|
|
|
|
|
|
|
} deriving (Show, Eq) |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
data StreamError = StreamError XmppStreamError |
|
|
|
| StreamWrongVersion Text |
|
|
|
| StreamWrongVersion Text |
|
|
|
| StreamXMLError |
|
|
|
| StreamXMLError String |
|
|
|
| StreamUnpickleError String |
|
|
|
|
|
|
|
| StreamConnectionError |
|
|
|
| StreamConnectionError |
|
|
|
deriving (Show, Eq, Typeable) |
|
|
|
deriving (Show, Eq, Typeable) |
|
|
|
instance Exception StreamError |
|
|
|
instance Exception StreamError |
|
|
|
instance Error StreamError where strMsg = StreamError |
|
|
|
instance Error StreamError where noMsg = StreamConnectionError |
|
|
|
|
|
|
|
|
|
|
|
-- ============================================================================= |
|
|
|
-- ============================================================================= |
|
|
|
-- XML TYPES |
|
|
|
-- XML TYPES |
|
|
|
@ -610,24 +700,32 @@ instance Read LangTag where |
|
|
|
-- all (\ (a, b) -> map toLower a == map toLower b) $ zip as bs |
|
|
|
-- all (\ (a, b) -> map toLower a == map toLower b) $ zip as bs |
|
|
|
-- | otherwise = False |
|
|
|
-- | otherwise = False |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
data ServerFeatures = SF |
|
|
|
data ServerFeatures = SF |
|
|
|
{ stls :: Maybe Bool |
|
|
|
{ stls :: Maybe Bool |
|
|
|
, saslMechanisms :: [Text.Text] |
|
|
|
, saslMechanisms :: [Text.Text] |
|
|
|
, other :: [Element] |
|
|
|
, other :: [Element] |
|
|
|
} deriving Show |
|
|
|
} deriving Show |
|
|
|
|
|
|
|
|
|
|
|
data XMPPConState = XMPPConState |
|
|
|
data XmppConnectionState = XmppConnectionClosed -- ^ No connection at |
|
|
|
|
|
|
|
-- this point |
|
|
|
|
|
|
|
| XmppConnectionPlain -- ^ Connection |
|
|
|
|
|
|
|
-- established, but |
|
|
|
|
|
|
|
-- not secured |
|
|
|
|
|
|
|
| XmppConnectionSecured -- ^ Connection |
|
|
|
|
|
|
|
-- established and |
|
|
|
|
|
|
|
-- secured via TLS |
|
|
|
|
|
|
|
data XmppConnection = XmppConnection |
|
|
|
{ sConSrc :: Source IO Event |
|
|
|
{ sConSrc :: Source IO Event |
|
|
|
, sRawSrc :: Source IO BS.ByteString |
|
|
|
, sRawSrc :: Source IO BS.ByteString |
|
|
|
, sConPushBS :: BS.ByteString -> IO () |
|
|
|
, sConPushBS :: BS.ByteString -> IO () |
|
|
|
, sConHandle :: Maybe Handle |
|
|
|
, sConHandle :: Maybe Handle |
|
|
|
, sFeatures :: ServerFeatures |
|
|
|
, sFeatures :: ServerFeatures |
|
|
|
, sHaveTLS :: Bool |
|
|
|
, sConnectionState :: XmppConnectionState |
|
|
|
, sHostname :: Maybe Text |
|
|
|
, sHostname :: Maybe Text |
|
|
|
, sUsername :: Maybe Text |
|
|
|
, sUsername :: Maybe Text |
|
|
|
, sResource :: Maybe Text |
|
|
|
, sResource :: Maybe Text |
|
|
|
|
|
|
|
, sCloseConnection :: IO () |
|
|
|
|
|
|
|
-- TODO: add default Language |
|
|
|
} |
|
|
|
} |
|
|
|
|
|
|
|
|
|
|
|
-- | |
|
|
|
-- | |
|
|
|
@ -635,14 +733,14 @@ data XMPPConState = XMPPConState |
|
|
|
-- work with Pontarius. Pontarius clients needs to operate in this |
|
|
|
-- work with Pontarius. Pontarius clients needs to operate in this |
|
|
|
-- context. |
|
|
|
-- context. |
|
|
|
|
|
|
|
|
|
|
|
newtype XMPPT m a = XMPPT { runXMPPT :: StateT XMPPConState m a } deriving (Monad, MonadIO) |
|
|
|
newtype XMPPT m a = XMPPT { runXMPPT :: StateT XmppConnection m a } deriving (Monad, MonadIO) |
|
|
|
|
|
|
|
|
|
|
|
type XMPPConMonad a = StateT XMPPConState IO a |
|
|
|
type XMPPConMonad a = StateT XmppConnection IO a |
|
|
|
|
|
|
|
|
|
|
|
-- Make XMPPT derive the Monad and MonadIO instances. |
|
|
|
-- Make XMPPT derive the Monad and MonadIO instances. |
|
|
|
|
|
|
|
|
|
|
|
deriving instance (Monad m, MonadIO m) => MonadState (XMPPConState) (XMPPT m) |
|
|
|
deriving instance (Monad m, MonadIO m) => MonadState (XmppConnection) (XMPPT m) |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
data XmppNoConnection = XmppNoConnection deriving (Show, Typeable) |
|
|
|
|
|
|
|
instance Exception XmppNoConnection |
|
|
|
|
|
|
|
|
|
|
|
-- We need a channel because multiple threads needs to append events, |
|
|
|
|
|
|
|
-- and we need to wait for events when there are none. |
|
|
|
|
|
|
|
|
Jon Kristensen
14 years ago