asakul
/
pontarius-xmpp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

minor formatting and (partial) documentation additions

master
Jon Kristensen 14 years ago
parent
abb264a311
commit
e4a27def01
1 changed files with 224 additions and 302 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 526
      src/Network/XMPP/Types.hs

526
src/Network/XMPP/Types.hs
Unescape View File

@ -1,15 +1,10 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
-- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the
-- Pontarius distribution for more details.
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK hide #-}
module Network.XMPP.Types module Network.XMPP.Types
( IQError(..) ( IQError(..)
@ -27,7 +22,6 @@ module Network.XMPP.Types
, PresenceType(..) , PresenceType(..)
, SaslError(..) , SaslError(..)
, SaslFailure(..) , SaslFailure(..)
, ServerAddress(..)
, ServerFeatures(..) , ServerFeatures(..)
, Stanza(..) , Stanza(..)
, StanzaError(..) , StanzaError(..)
@ -46,8 +40,6 @@ module Network.XMPP.Types
) )
where where
-- import Network.XMPP.Utilities (idGenerator)
import Control.Applicative((<$>)) import Control.Applicative((<$>))
import Control.Exception import Control.Exception
import Control.Monad.IO.Class import Control.Monad.IO.Class
@ -69,24 +61,9 @@ import Network.XMPP.JID
import System.IO import System.IO
-- =============================================================================
-- STANZA TYPES
-- =============================================================================
-- TODO: Would a Stanza class such as the one below be useful sometimes?
--
-- class Stanza a where
-- stanzaID :: a -> Maybe StanzaID
-- stanzaFrom :: a -> Maybe From
-- stanzaTo :: a -> Maybe To
-- stanzaXMLLang :: a -> Maybe XMLLang
-- | -- |
-- Wraps a string of random characters that, when using an appropriate -- Wraps a string of random characters that, when using an appropriate
-- @IDGenerator@, is guaranteed to be unique for the XMPP session. -- @IDGenerator@, is guaranteed to be unique for the XMPP session.
-- Stanza identifiers are generated by Pontarius.
data StanzaId = SI !Text deriving (Eq, Ord) data StanzaId = SI !Text deriving (Eq, Ord)
@ -99,13 +76,8 @@ instance Read StanzaId where
instance IsString StanzaId where instance IsString StanzaId where
fromString = SI . Text.pack fromString = SI . Text.pack
-- An Info/Query (IQ) stanza is either of the type "request" ("get" or -- | The XMPP communication primities (Message, Presence and Info/Query) are
-- "set") or "response" ("result" or "error"). The @IQ@ type wraps -- called stanzas.
-- these two sub-types.
--
-- Objects of this type cannot be generated by Pontarius applications,
-- but are only created internally.
data Stanza = IQRequestS IQRequest data Stanza = IQRequestS IQRequest
| IQResultS IQResult | IQResultS IQResult
| IQErrorS IQError | IQErrorS IQError
@ -115,19 +87,17 @@ data Stanza = IQRequestS IQRequest
| PresenceErrorS PresenceError | PresenceErrorS PresenceError
deriving Show deriving Show
-- | -- | A "request" Info/Query (IQ) stanza is one with either "get" or "set" as
-- A "request" Info/Query (IQ) stanza is one with either "get" or -- type. They are guaranteed to always contain a payload.
-- "set" as type. They are guaranteed to always contain a payload.
data IQRequest = IQRequest { iqRequestID :: StanzaId data IQRequest = IQRequest { iqRequestID :: StanzaId
, iqRequestFrom :: Maybe JID , iqRequestFrom :: Maybe JID
, iqRequestTo :: Maybe JID , iqRequestTo :: Maybe JID
, iqRequestLangTag :: Maybe LangTag , iqRequestLangTag :: Maybe LangTag
, iqRequestType :: IQRequestType , iqRequestType :: IQRequestType
, iqRequestPayload :: Element , iqRequestPayload :: Element
} } deriving Show
deriving (Show)
-- | The type of request that is made -- | The type of IQ 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
@ -139,93 +109,82 @@ 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 -- | A "response" Info/Query (IQ) stanza is either an 'IQError' or an IQ stanza
-- with the type "result" ('IQResult') -- with the type "result" ('IQResult').
type IQResponse = Either IQError IQResult type IQResponse = Either IQError IQResult
-- | The answer to an IQ request -- | The (non-error) answer to an IQ request.
data IQResult = IQResult { iqResultID :: StanzaId data IQResult = IQResult { iqResultID :: StanzaId
, iqResultFrom :: Maybe JID , iqResultFrom :: Maybe JID
, iqResultTo :: Maybe JID , iqResultTo :: Maybe JID
, iqResultLangTag :: Maybe LangTag , iqResultLangTag :: Maybe LangTag
, iqResultPayload :: Maybe Element } , iqResultPayload :: Maybe Element
deriving (Show) } deriving Show
-- | The answer to an IQ request that generated an error -- | The answer to an IQ request that generated an error.
data IQError = IQError { iqErrorID :: StanzaId data IQError = IQError { iqErrorID :: StanzaId
, iqErrorFrom :: Maybe JID , iqErrorFrom :: Maybe JID
, iqErrorTo :: Maybe JID , iqErrorTo :: Maybe JID
, iqErrorLangTag :: Maybe LangTag , iqErrorLangTag :: Maybe LangTag
, iqErrorStanzaError :: StanzaError , iqErrorStanzaError :: StanzaError
, iqErrorPayload :: Maybe Element -- should this be []? , iqErrorPayload :: Maybe Element -- should this be []?
} } deriving Show
deriving (Show)
-- | The message stanza. Used for /push/ type communication -- | The message stanza. Used for /push/ type communication.
data Message = Message { messageID :: Maybe StanzaId data Message = Message { messageID :: Maybe StanzaId
, messageFrom :: Maybe JID , messageFrom :: Maybe JID
, messageTo :: Maybe JID , messageTo :: Maybe JID
, messageLangTag :: Maybe LangTag , messageLangTag :: Maybe LangTag
, messageType :: MessageType , messageType :: MessageType
, messagePayload :: [Element] , messagePayload :: [Element]
} } deriving Show
deriving (Show)
-- | An error stanza generated in response to a 'Message' -- | An error stanza generated in response to a 'Message'.
data MessageError = MessageError { messageErrorID :: Maybe StanzaId data MessageError = MessageError { messageErrorID :: Maybe StanzaId
, messageErrorFrom :: Maybe JID , messageErrorFrom :: Maybe JID
, messageErrorTo :: Maybe JID , messageErrorTo :: Maybe JID
, messageErrorLangTag :: Maybe LangTag , messageErrorLangTag :: Maybe LangTag
, messageErrorStanzaError :: StanzaError , messageErrorStanzaError :: StanzaError
, messageErrorPayload :: [Element] , messageErrorPayload :: [Element]
} } deriving (Show)
deriving (Show)
-- | The type of a Message being sent -- | The type of a Message being sent
-- (<http://xmpp.org/rfcs/rfc6121.html#message-syntax-type>) -- (<http://xmpp.org/rfcs/rfc6121.html#message-syntax-type>)
data MessageType = -- | The message is sent in the context of a one-to-one chat data MessageType = -- | The message is sent in the context of a one-to-one chat
-- session. Typically an interactive client will present a -- session. Typically an interactive client will present a
-- message of type /chat/ in an interface that enables -- message of type /chat/ in an interface that enables
-- one-to-one chat between the two parties, including an -- one-to-one chat between the two parties, including an
-- appropriate conversation history. -- appropriate conversation history.
Chat Chat
-- | The message is sent in the context of a -- | The message is sent in the context of a multi-user chat
-- multi-user chat environment (similar to that of -- environment (similar to that of @IRC@). Typically a
-- @IRC@). Typically a receiving client will -- receiving client will present a message of type
-- present a message of type /groupchat/ in an -- /groupchat/ in an interface that enables many-to-many
-- interface that enables many-to-many chat -- chat between the parties, including a roster of parties
-- between the parties, including a roster of -- in the chatroom and an appropriate conversation history.
-- parties in the chatroom and an appropriate
-- conversation history.
| GroupChat | GroupChat
-- | The message provides an alert, a -- | The message provides an alert, a notification, or other
-- notification, or other transient information to -- transient information to which no reply is expected
-- which no reply is expected (e.g., news -- (e.g., news headlines, sports updates, near-real-time
-- headlines, sports updates, near-real-time -- market data, or syndicated content). Because no reply to
-- market data, or syndicated content). Because no -- the message is expected, typically a receiving client
-- reply to the message is expected, typically a -- will present a message of type /headline/ in an interface
-- receiving client will present a message of type -- that appropriately differentiates the message from
-- /headline/ in an interface that appropriately -- standalone messages, chat messages, and groupchat
-- differentiates the message from standalone -- messages (e.g., by not providing the recipient with the
-- messages, chat messages, and groupchat messages -- ability to reply).
-- (e.g., by not providing the recipient with the
-- ability to reply).
| Headline | Headline
-- | The message is a standalone message that is -- | The message is a standalone message that is sent outside
-- sent outside the context of a one-to-one -- the context of a one-to-one conversation or groupchat, and
-- conversation or groupchat, and to which it is -- to which it is expected that the recipient will reply.
-- expected that the recipient will -- Typically a receiving client will present a message of
-- reply. Typically a receiving client will -- type /normal/ in an interface that enables the recipient
-- present a message of type /normal/ in an -- to reply, but without a conversation history.
-- interface that enables the recipient to reply, --
-- but without a conversation history. -- This is the /default/ value.
--
-- This is the /default/ value
| Normal | Normal
deriving (Eq) deriving (Eq)
instance Show MessageType where instance Show MessageType where
show Chat = "chat" show Chat = "chat"
@ -234,43 +193,33 @@ instance Show MessageType where
show Normal = "normal" show Normal = "normal"
instance Read MessageType where instance Read MessageType where
readsPrec _ "chat" = [( Chat ,"")] readsPrec _ "chat" = [(Chat, "")]
readsPrec _ "groupchat" = [( GroupChat ,"")] readsPrec _ "groupchat" = [(GroupChat, "")]
readsPrec _ "headline" = [( Headline ,"")] readsPrec _ "headline" = [(Headline, "")]
readsPrec _ "normal" = [( Normal ,"")] readsPrec _ "normal" = [(Normal, "")]
readsPrec _ _ = [( Normal ,"")] readsPrec _ _ = [(Normal, "")]
-- | -- | The presence stanza. Used for communicating status updates.
-- Objects of this type cannot be generated by Pontarius applications, data Presence = Presence { presenceID :: Maybe StanzaId
-- but are only created internally. , presenceFrom :: Maybe JID
, presenceTo :: Maybe JID
data Presence = Presence { presenceID :: Maybe StanzaId , presenceLangTag :: Maybe LangTag
, presenceFrom :: Maybe JID , presenceType :: Maybe PresenceType
, presenceTo :: Maybe JID , presencePayload :: [Element]
, presenceLangTag :: Maybe LangTag } deriving Show
, presenceType :: Maybe PresenceType
, presencePayload :: [Element]
} -- | An error stanza generated in response to a 'Presence'.
deriving (Show) data PresenceError = PresenceError { presenceErrorID :: Maybe StanzaId
, presenceErrorFrom :: Maybe JID
, presenceErrorTo :: Maybe JID
-- | , presenceErrorLangTag :: Maybe LangTag
-- Objects of this type cannot be generated by Pontarius applications,
-- but are only created internally.
data PresenceError = PresenceError { presenceErrorID :: Maybe StanzaId
, presenceErrorFrom :: Maybe JID
, presenceErrorTo :: Maybe JID
, presenceErrorLangTag :: Maybe LangTag
, presenceErrorStanzaError :: StanzaError , presenceErrorStanzaError :: StanzaError
, presenceErrorPayload :: [Element] , presenceErrorPayload :: [Element]
} } deriving Show
deriving (Show)
-- |
-- @PresenceType@ holds XMPP presence types. The "error" message type
-- is left out as errors are using @PresenceError@.
-- | @PresenceType@ holds XMPP presence types. The "error" message type is left
-- out as errors are using @PresenceError@.
data PresenceType = Subscribe | -- ^ Sender wants to subscribe to presence data PresenceType = Subscribe | -- ^ Sender wants to subscribe to presence
Subscribed | -- ^ Sender has approved the subscription Subscribed | -- ^ Sender has approved the subscription
Unsubscribe | -- ^ Sender is unsubscribing from presence Unsubscribe | -- ^ Sender is unsubscribing from presence
@ -281,7 +230,6 @@ data PresenceType = Subscribe | -- ^ Sender wants to subscribe to presence
Default | Default |
Unavailable deriving (Eq) Unavailable deriving (Eq)
instance Show PresenceType where instance Show PresenceType where
show Subscribe = "subscribe" show Subscribe = "subscribe"
show Subscribed = "subscribed" show Subscribed = "subscribed"
@ -292,15 +240,15 @@ instance Show PresenceType where
show Unavailable = "unavailable" show Unavailable = "unavailable"
instance Read PresenceType where instance Read PresenceType where
readsPrec _ "" = [( Default ,"")] readsPrec _ "" = [(Default, "")]
readsPrec _ "available" = [( Default ,"")] readsPrec _ "available" = [(Default, "")]
readsPrec _ "unavailable" = [( Unavailable ,"")] readsPrec _ "unavailable" = [(Unavailable, "")]
readsPrec _ "subscribe" = [( Subscribe ,"")] readsPrec _ "subscribe" = [(Subscribe, "")]
readsPrec _ "subscribed" = [( Subscribed ,"")] readsPrec _ "subscribed" = [(Subscribed, "")]
readsPrec _ "unsubscribe" = [( Unsubscribe ,"")] readsPrec _ "unsubscribe" = [(Unsubscribe, "")]
readsPrec _ "unsubscribed" = [( Unsubscribed ,"")] readsPrec _ "unsubscribed" = [(Unsubscribed, "")]
readsPrec _ "probe" = [( Probe ,"")] readsPrec _ "probe" = [(Probe, "")]
readsPrec _ _ = [] readsPrec _ _ = []
--data ShowType = Available --data ShowType = Available
-- | Away -- | Away
@ -327,22 +275,18 @@ instance Read PresenceType where
-- readsPrec _ _ = [] -- readsPrec _ _ = []
-- | -- | All stanzas (IQ, message, presence) can cause errors, which in the XMPP
-- All stanzas (IQ, message, presence) can cause errors, which in the XMPP
-- stream looks like <stanza-kind to='sender' type='error'>. These errors are -- stream looks like <stanza-kind to='sender' type='error'>. These errors are
-- wrapped in the @StanzaError@ type. -- wrapped in the @StanzaError@ type.
-- TODO: Sender XML is (optional and is) not yet included.
-- TODO: Sender XML is (optional and is) not included. data StanzaError = StanzaError
data StanzaError = StanzaError { stanzaErrorType :: StanzaErrorType { stanzaErrorType :: StanzaErrorType
, stanzaErrorCondition :: StanzaErrorCondition , stanzaErrorCondition :: StanzaErrorCondition
, stanzaErrorText :: Maybe (Maybe LangTag, Text) , stanzaErrorText :: Maybe (Maybe LangTag, Text)
, stanzaErrorApplicationSpecificCondition :: , stanzaErrorApplicationSpecificCondition :: Maybe Element
Maybe Element } deriving (Eq, Show) } deriving (Eq, Show)
-- | @StanzaError@s always have one of these types.
-- |
-- @StanzaError@s always have one of these types.
data StanzaErrorType = Cancel | -- ^ Error is unrecoverable - do not retry data StanzaErrorType = Cancel | -- ^ Error is unrecoverable - do not retry
Continue | -- ^ Conditition was a warning - proceed Continue | -- ^ Conditition was a warning - proceed
Modify | -- ^ Change the data and retry Modify | -- ^ Change the data and retry
@ -350,7 +294,6 @@ data StanzaErrorType = Cancel | -- ^ Error is unrecoverable - do not retry
Wait -- ^ Error is temporary - wait and retry Wait -- ^ Error is temporary - wait and retry
deriving (Eq) deriving (Eq)
instance Show StanzaErrorType where instance Show StanzaErrorType where
show Cancel = "cancel" show Cancel = "cancel"
show Continue = "continue" show Continue = "continue"
@ -366,48 +309,42 @@ instance Read StanzaErrorType where
readsPrec _ "wait" = [( Wait , "")] readsPrec _ "wait" = [( Wait , "")]
readsPrec _ _ = [] readsPrec _ _ = []
-- | Stanza errors are accommodated with one of the error conditions listed
-- | -- below.
-- Stanza errors are accommodated with one of the error conditions listed below. data StanzaErrorCondition = BadRequest -- ^ Malformed XML.
| Conflict -- ^ Resource or session with
data StanzaErrorCondition = BadRequest | -- ^ Malformed XML -- name already exists.
Conflict | -- ^ Resource or session | FeatureNotImplemented
-- with name already | Forbidden -- ^ Insufficient permissions.
-- exists | Gone -- ^ Entity can no longer be
FeatureNotImplemented | -- contacted at this
Forbidden | -- ^ Insufficient -- address.
-- permissions | InternalServerError
Gone | -- ^ Entity can no longer | ItemNotFound
-- be contacted at this | JIDMalformed
-- address | NotAcceptable -- ^ Does not meet policy
InternalServerError | -- criteria.
ItemNotFound | | NotAllowed -- ^ No entity may perform
JIDMalformed | -- this action.
NotAcceptable | -- ^ Does not meet policy | NotAuthorized -- ^ Must provide proper
-- criteria -- credentials.
NotAllowed | -- ^ No entity may perform | PaymentRequired
-- this action | RecipientUnavailable -- ^ Temporarily unavailable.
NotAuthorized | -- ^ Must provide proper | Redirect -- ^ Redirecting to other
-- credentials -- entity, usually
PaymentRequired | -- temporarily.
RecipientUnavailable | -- ^ Temporarily | RegistrationRequired
-- unavailable | RemoteServerNotFound
Redirect | -- ^ Redirecting to other | RemoteServerTimeout
-- entity, usually | ResourceConstraint -- ^ Entity lacks the
-- temporarily -- necessary system
RegistrationRequired | -- resources.
RemoteServerNotFound | | ServiceUnavailable
RemoteServerTimeout | | SubscriptionRequired
ResourceConstraint | -- ^ Entity lacks the | UndefinedCondition -- ^ Application-specific
-- necessary system -- condition.
-- resources | UnexpectedRequest -- ^ Badly timed request.
ServiceUnavailable | deriving Eq
SubscriptionRequired |
UndefinedCondition | -- ^ Application-specific
-- condition
UnexpectedRequest -- ^ Badly timed request
deriving (Eq)
instance Show StanzaErrorCondition where instance Show StanzaErrorCondition where
show BadRequest = "bad-request" show BadRequest = "bad-request"
@ -468,35 +405,33 @@ data SaslFailure = SaslFailure { saslFailureCondition :: SaslError
) )
} deriving Show } deriving Show
data SaslError = SaslAborted -- ^ Client aborted.
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.
| SaslInvalidAuthzid -- ^ The authzid has an incorrect | SaslInvalidAuthzid -- ^ The authzid has an incorrect
-- format or the initiating entity does -- format or the initiating entity
-- not have the appropriate permissions -- does not have the appropriate
-- to authorize that ID -- permissions to 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 | SaslMalformedRequest -- ^ Invalid syntax.
| SaslMechanismTooWeak -- ^ The receiving entity policy | SaslMechanismTooWeak -- ^ The receiving entity policy
-- requires a stronger mechanism -- requires a stronger mechanism.
| SaslNotAuthorized -- ^ Invalid credentials | SaslNotAuthorized -- ^ Invalid credentials provided, or
-- provided, or some -- 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 instance Show SaslError where
show SaslAborted = "aborted" show SaslAborted = "aborted"
@ -525,39 +460,36 @@ instance Read SaslError where
readsPrec _ "temporary-auth-failure" = [(SaslTemporaryAuthFailure , "")] readsPrec _ "temporary-auth-failure" = [(SaslTemporaryAuthFailure , "")]
readsPrec _ _ = [] readsPrec _ _ = []
-- | Readability type for host name Texts. -- data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq)
-- type HostName = Text -- This is defined in Network as well
data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq)
-- TODO: document the error cases -- TODO: document the error cases
data StreamErrorCondition = StreamBadFormat data StreamErrorCondition
| StreamBadNamespacePrefix = StreamBadFormat
| StreamConflict | StreamBadNamespacePrefix
| StreamConnectionTimeout | StreamConflict
| StreamHostGone | StreamConnectionTimeout
| StreamHostUnknown | StreamHostGone
| StreamImproperAddressing | StreamHostUnknown
| StreamInternalServerError | StreamImproperAddressing
| StreamInvalidFrom | StreamInternalServerError
| StreamInvalidNamespace | StreamInvalidFrom
| StreamInvalidXml | StreamInvalidNamespace
| StreamNotAuthorized | StreamInvalidXml
| StreamNotWellFormed | StreamNotAuthorized
| StreamPolicyViolation | StreamNotWellFormed
| StreamRemoteConnectionFailed | StreamPolicyViolation
| StreamReset | StreamRemoteConnectionFailed
| StreamResourceConstraint | StreamReset
| StreamRestrictedXml | StreamResourceConstraint
| StreamSeeOtherHost | StreamRestrictedXml
| StreamSystemShutdown | StreamSeeOtherHost
| StreamUndefinedCondition | StreamSystemShutdown
| StreamUnsupportedEncoding | StreamUndefinedCondition
| StreamUnsupportedFeature | StreamUnsupportedEncoding
| StreamUnsupportedStanzaType | StreamUnsupportedFeature
| StreamUnsupportedVersion | StreamUnsupportedStanzaType
deriving Eq | StreamUnsupportedVersion
deriving Eq
instance Show StreamErrorCondition where instance Show StreamErrorCondition where
show StreamBadFormat = "bad-format" show StreamBadFormat = "bad-format"
@ -587,45 +519,46 @@ instance Show StreamErrorCondition where
show StreamUnsupportedVersion = "unsupported-version" show StreamUnsupportedVersion = "unsupported-version"
instance Read StreamErrorCondition where instance Read StreamErrorCondition where
readsPrec _ "bad-format" = [(StreamBadFormat , "")] readsPrec _ "bad-format" = [(StreamBadFormat , "")]
readsPrec _ "bad-namespace-prefix" = [(StreamBadNamespacePrefix , "")] readsPrec _ "bad-namespace-prefix" = [(StreamBadNamespacePrefix , "")]
readsPrec _ "conflict" = [(StreamConflict , "")] readsPrec _ "conflict" = [(StreamConflict , "")]
readsPrec _ "connection-timeout" = [(StreamConnectionTimeout , "")] readsPrec _ "connection-timeout" = [(StreamConnectionTimeout , "")]
readsPrec _ "host-gone" = [(StreamHostGone , "")] readsPrec _ "host-gone" = [(StreamHostGone , "")]
readsPrec _ "host-unknown" = [(StreamHostUnknown , "")] readsPrec _ "host-unknown" = [(StreamHostUnknown , "")]
readsPrec _ "improper-addressing" = [(StreamImproperAddressing , "")] readsPrec _ "improper-addressing" = [(StreamImproperAddressing , "")]
readsPrec _ "internal-server-error" = [(StreamInternalServerError , "")] readsPrec _ "internal-server-error" = [(StreamInternalServerError , "")]
readsPrec _ "invalid-from" = [(StreamInvalidFrom , "")] readsPrec _ "invalid-from" = [(StreamInvalidFrom , "")]
readsPrec _ "invalid-namespace" = [(StreamInvalidNamespace , "")] readsPrec _ "invalid-namespace" = [(StreamInvalidNamespace , "")]
readsPrec _ "invalid-xml" = [(StreamInvalidXml , "")] readsPrec _ "invalid-xml" = [(StreamInvalidXml , "")]
readsPrec _ "not-authorized" = [(StreamNotAuthorized , "")] readsPrec _ "not-authorized" = [(StreamNotAuthorized , "")]
readsPrec _ "not-well-formed" = [(StreamNotWellFormed , "")] readsPrec _ "not-well-formed" = [(StreamNotWellFormed , "")]
readsPrec _ "policy-violation" = [(StreamPolicyViolation , "")] readsPrec _ "policy-violation" = [(StreamPolicyViolation , "")]
readsPrec _ "remote-connection-failed" = [(StreamRemoteConnectionFailed , "")] readsPrec _ "remote-connection-failed" =
readsPrec _ "reset" = [(StreamReset , "")] [(StreamRemoteConnectionFailed, "")]
readsPrec _ "resource-constraint" = [(StreamResourceConstraint , "")] readsPrec _ "reset" = [(StreamReset , "")]
readsPrec _ "restricted-xml" = [(StreamRestrictedXml , "")] readsPrec _ "resource-constraint" = [(StreamResourceConstraint , "")]
readsPrec _ "see-other-host" = [(StreamSeeOtherHost , "")] readsPrec _ "restricted-xml" = [(StreamRestrictedXml , "")]
readsPrec _ "system-shutdown" = [(StreamSystemShutdown , "")] readsPrec _ "see-other-host" = [(StreamSeeOtherHost , "")]
readsPrec _ "undefined-condition" = [(StreamUndefinedCondition , "")] readsPrec _ "system-shutdown" = [(StreamSystemShutdown , "")]
readsPrec _ "unsupported-encoding" = [(StreamUnsupportedEncoding , "")] readsPrec _ "undefined-condition" = [(StreamUndefinedCondition , "")]
readsPrec _ "unsupported-feature" = [(StreamUnsupportedFeature , "")] readsPrec _ "unsupported-encoding" = [(StreamUnsupportedEncoding , "")]
readsPrec _ "unsupported-stanza-type" = [(StreamUnsupportedStanzaType , "")] readsPrec _ "unsupported-feature" = [(StreamUnsupportedFeature , "")]
readsPrec _ "unsupported-version" = [(StreamUnsupportedVersion , "")] readsPrec _ "unsupported-stanza-type" = [(StreamUnsupportedStanzaType, "")]
readsPrec _ _ = [(StreamUndefinedCondition , "")] readsPrec _ "unsupported-version" = [(StreamUnsupportedVersion , "")]
readsPrec _ _ = [(StreamUndefinedCondition , "")]
data XmppStreamError = XmppStreamError data XmppStreamError = XmppStreamError
{ errorCondition :: StreamErrorCondition { errorCondition :: StreamErrorCondition
, errorText :: Maybe (Maybe LangTag, Text) , errorText :: Maybe (Maybe LangTag, Text)
, errorXML :: Maybe Element , errorXML :: Maybe Element
} deriving (Show, Eq) } deriving (Show, Eq)
data StreamError = StreamError XmppStreamError data StreamError = StreamError XmppStreamError
| StreamWrongVersion Text | StreamWrongVersion Text
| StreamXMLError String | StreamXMLError String -- If stream pickling goes wrong.
| StreamConnectionError | StreamConnectionError
deriving (Show, Eq, Typeable) deriving (Show, Eq, Typeable)
instance Exception StreamError instance Exception StreamError
instance Error StreamError where noMsg = StreamConnectionError instance Error StreamError where noMsg = StreamConnectionError
@ -641,39 +574,33 @@ instance Error StreamError where noMsg = StreamConnectionError
newtype IdGenerator = IdGenerator (IO Text) newtype IdGenerator = IdGenerator (IO Text)
--- other stuff -- Version numbers are displayed as "<major>.<minor>".
data Version = Version { majorVersion :: Integer data Version = Version { majorVersion :: Integer
, minorVersion :: Integer } deriving (Eq) , minorVersion :: Integer } deriving (Eq)
-- Version numbers are displayed as "<major>.<minor>".
instance Show Version where instance Show Version where
show (Version major minor) = (show major) ++ "." ++ (show minor) show (Version major minor) = (show major) ++ "." ++ (show minor)
-- If the major version numbers are not equal, compare them. Otherwise, compare -- If the major version numbers are not equal, compare them. Otherwise, compare
-- the minor version numbers. -- the minor version numbers.
instance Ord Version where instance Ord Version where
compare (Version amajor aminor) (Version bmajor bminor) compare (Version amajor aminor) (Version bmajor bminor)
| amajor /= bmajor = compare amajor bmajor | amajor /= bmajor = compare amajor bmajor
| otherwise = compare aminor bminor | otherwise = compare aminor bminor
-- The language tag in the form of "en-US". It has a primary tag, followed by a
-- number of subtags.
data LangTag = LangTag { primaryTag :: Text data LangTag = LangTag { primaryTag :: Text
, subtags :: [Text] } , subtags :: [Text] }
deriving (Eq) -- TODO: remove deriving (Eq) -- TODO: remove
-- Displays the language tag in the form of "en-US".
instance Show LangTag where instance Show LangTag where
show (LangTag p []) = Text.unpack p show (LangTag p []) = Text.unpack p
show (LangTag p s) = Text.unpack . Text.concat show (LangTag p s) = Text.unpack . Text.concat
$ [p, "-", Text.intercalate "-" s] -- TODO: clean up $ [p, "-", Text.intercalate "-" s] -- TODO: clean up
-- Parses a Text string to a list of LangTag objects. TODO: Why?
parseLangTag :: Text -> [LangTag] parseLangTag :: Text -> [LangTag]
parseLangTag txt = case Text.splitOn "-" txt of parseLangTag txt = case Text.splitOn "-" txt of
[] -> [] [] -> []
@ -682,9 +609,8 @@ parseLangTag txt = case Text.splitOn "-" txt of
instance Read LangTag where instance Read LangTag where
readsPrec _ txt = (,"") <$> (parseLangTag $ Text.pack txt) readsPrec _ txt = (,"") <$> (parseLangTag $ Text.pack txt)
-- Two language tags are considered equal of they contain the same tags (case-insensitive). -- Two language tags are considered equal of they contain the same tags
-- (case-insensitive).
-- TODO: port
-- instance Eq LangTag where -- instance Eq LangTag where
-- (LangTag ap as) == (LangTag bp bs) -- (LangTag ap as) == (LangTag bp bs)
@ -693,20 +619,17 @@ instance Read LangTag where
-- | 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 XmppConnectionState = XmppConnectionClosed -- ^ No connection at data XmppConnectionState
-- this point = XmppConnectionClosed -- ^ No connection at this point.
| XmppConnectionPlain -- ^ Connection | XmppConnectionPlain -- ^ Connection established, but not secured.
-- established, but | XmppConnectionSecured -- ^ Connection established and secured via TLS.
-- not secured deriving (Show, Eq, Typeable)
| XmppConnectionSecured -- ^ Connection
-- established and
-- secured via TLS
deriving (Show, Eq, Typeable)
data XmppConnection = XmppConnection data XmppConnection = XmppConnection
{ sConSrc :: Source IO Event { sConSrc :: Source IO Event
, sRawSrc :: Source IO BS.ByteString , sRawSrc :: Source IO BS.ByteString
@ -725,12 +648,11 @@ data XmppConnection = XmppConnection
-- The XMPP monad transformer. Contains internal state in order to -- The XMPP monad transformer. Contains internal state in order to
-- 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 XmppConnection m a } deriving (Monad, MonadIO) newtype XMPPT m a = XMPPT { runXMPPT :: StateT XmppConnection m a } deriving (Monad, MonadIO)
-- | Low-level and single-threaded XMPP monad. See @XMPP@ for a concurrent
-- implementation.
type XMPPConMonad a = StateT XmppConnection 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 (XmppConnection) (XMPPT m)
deriving instance (Monad m, MonadIO m) => MonadState (XmppConnection) (XMPPT m)
Write Preview
Loading…
Cancel
Save