@ -11,7 +11,42 @@
@@ -11,7 +11,42 @@
{- # 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)
@ -24,7 +59,6 @@ import Control.Monad.Error
@@ -24,7 +59,6 @@ import Control.Monad.Error
import qualified Data.ByteString as BS
import Data.Conduit
import Data.List.Split as L
import Data.String ( IsString ( .. ) )
import Data.Text ( Text )
import qualified Data.Text as Text
@ -33,16 +67,9 @@ import Data.XML.Types
@@ -33,16 +67,9 @@ import Data.XML.Types
import qualified Network as N
import System.IO
-- | The string prefix MUST be
data SessionSettings =
SessionSettings { ssIdPrefix :: String
, ssIdGenerator :: IdGenerator
, ssStreamLang :: LangTag }
import Network.XMPP.JID
import System.IO
-- =============================================================================
-- STANZA TYPES
@ -74,38 +101,6 @@ instance Read StanzaId where
@@ -74,38 +101,6 @@ instance Read StanzaId where
instance IsString StanzaId where
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
-- "set") or "response" ("result" or "error"). The @IQ@ type wraps
-- these two sub-types.
@ -120,14 +115,11 @@ data Stanza = IQRequestS IQRequest
@@ -120,14 +115,11 @@ data Stanza = IQRequestS IQRequest
| MessageErrorS MessageError
| PresenceS Presence
| PresenceErrorS PresenceError
deriving Show
-- |
-- A "request" Info/Query (IQ) stanza is one with either "get" or
-- "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
, iqRequestFrom :: Maybe JID
, iqRequestTo :: Maybe JID
@ -137,7 +129,7 @@ data IQRequest = IQRequest { iqRequestID :: StanzaId
@@ -137,7 +129,7 @@ data IQRequest = IQRequest { iqRequestID :: StanzaId
}
deriving ( Show )
-- | The type of request that is made
data IQRequestType = Get | Set deriving ( Eq , Ord )
instance Show IQRequestType where
@ -149,21 +141,12 @@ instance Read IQRequestType where
@@ -149,21 +141,12 @@ instance Read IQRequestType where
readsPrec _ " set " = [ ( Set , " " ) ]
readsPrec _ _ = []
-- |
-- 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.
-- | A "response" Info/Query (IQ) stanza is eitheran 'IQError' or an IQ stanza
-- with the type "result" ('IQResult')
type IQResponse = Either IQError IQResult
-- |
-- Objects of this type cannot be generated by Pontarius applications,
-- but are only created internally.
-- | The answer to an IQ request
data IQResult = IQResult { iqResultID :: StanzaId
, iqResultFrom :: Maybe JID
, iqResultTo :: Maybe JID
@ -171,11 +154,7 @@ data IQResult = IQResult { iqResultID :: StanzaId
@@ -171,11 +154,7 @@ data IQResult = IQResult { iqResultID :: StanzaId
, iqResultPayload :: Maybe Element }
deriving ( Show )
-- |
-- Objects of this type cannot be generated by Pontarius applications,
-- but are only created internally.
-- | The answer to an IQ request that generated an error
data IQError = IQError { iqErrorID :: StanzaId
, iqErrorFrom :: Maybe JID
, iqErrorTo :: Maybe JID
@ -185,12 +164,7 @@ data IQError = IQError { iqErrorID :: StanzaId
@@ -185,12 +164,7 @@ data IQError = IQError { iqErrorID :: StanzaId
}
deriving ( Show )
-- |
-- A non-error message stanza.
--
-- Objects of this type cannot be generated by Pontarius applications,
-- but are only created internally.
-- | The message stanza. Used for /push/ type communication
data Message = Message { messageID :: Maybe StanzaId
, messageFrom :: Maybe JID
, messageTo :: Maybe JID
@ -203,13 +177,7 @@ data Message = Message { messageID :: Maybe StanzaId
@@ -203,13 +177,7 @@ data Message = Message { messageID :: Maybe StanzaId
}
deriving ( Show )
-- |
-- An error message stanza.
--
-- Objects of this type cannot be generated by Pontarius applications,
-- but are only created internally.
-- | An error stanza generated in response to a 'Message'
data MessageError = MessageError { messageErrorID :: Maybe StanzaId
, messageErrorFrom :: Maybe JID
, messageErrorTo :: Maybe JID
@ -220,15 +188,47 @@ data MessageError = MessageError { messageErrorID :: Maybe StanzaId
@@ -220,15 +188,47 @@ data MessageError = MessageError { messageErrorID :: Maybe StanzaId
deriving ( Show )
-- |
-- @MessageType@ holds XMPP message types as defined in XMPP-IM. The
-- "error" message type is left out as errors are wrapped in
-- @MessageError@.
data MessageType = Chat | -- ^
GroupChat | -- ^
Headline | -- ^
Normal -- ^ The default message type
-- | The type of a Message being sent
-- (<http://xmpp.org/rfcs/rfc6121.html#message-syntax-type>)
data MessageType = -- | The message is sent in the context of a one-to-one chat
-- session. Typically an interactive client will present a
-- message of type /chat/ in an interface that enables
-- one-to-one chat between the two parties, including an
-- appropriate conversation history.
Chat
-- | 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 )
@ -341,7 +341,6 @@ instance Read ShowType where
@@ -341,7 +341,6 @@ instance Read ShowType where
-- wrapped in the @StanzaError@ type.
-- TODO: Sender XML is (optional and is) not included.
data StanzaError = StanzaError { stanzaErrorType :: StanzaErrorType
, stanzaErrorCondition :: StanzaErrorCondition
, stanzaErrorText :: Maybe ( Maybe LangTag , Text )
@ -471,81 +470,172 @@ instance Read StanzaErrorCondition where
@@ -471,81 +470,172 @@ instance Read StanzaErrorCondition where
-- OTHER STUFF
-- =============================================================================
data SASLFailure = SASLFailure { saslFailureCondition :: SASLError
, saslFailureText :: Maybe Text } -- TODO: XMLLang
data SaslFailure = SaslFailure { saslFailureCondition :: SaslError
, saslFailureText :: Maybe ( Maybe LangTag
, Text
)
} deriving Show
data SASLError = -- SASLAborted | -- Client aborted - should not happen
SASLAccountDisabled | -- ^ The account has been temporarily
-- disabled
SASLCredentialsExpired | -- ^ The authentication failed because
data SaslError = SaslAborted -- ^ Client aborted
| SaslAccountDisabled -- ^ The account has been temporarily
-- disabled
| SaslCredentialsExpired -- ^ The authentication failed because
-- the credentials have expired
SASLEncryptionRequired | -- ^ The mechanism requested cannot be
| SaslEncryptionRequired -- ^ The mechanism requested cannot be
-- used the confidentiality and
-- integrity of the underlying
-- stream is protected (typically
-- with TLS)
-- SASLIncorrectEncoding | -- The base64 encoding is incorrect
-- - should not happen
-- SASLInvalidAuthzid | -- The authzid has an incorrect format,
-- or the initiating entity does not
-- have the appropriate permissions to
-- authorize that ID
SASLInvalidMechanism | -- ^ The mechanism is not supported by
-- the receiving entity
-- SASLMalformedRequest | -- Invalid syntax - should not happen
SASLMechanismTooWeak | -- ^ The receiving entity policy
-- requires a stronger mechanism
SASLNotAuthorized ( Maybe Text ) | -- ^ Invalid credentials
-- provided, or some
-- generic authentication
-- failure has occurred
SASLTemporaryAuthFailure -- ^ There receiving entity reported a
| SaslIncorrectEncoding -- ^ The base64 encoding is incorrect
| SaslInvalidAuthzid -- ^ The authzid has an incorrect
-- format or the initiating entity does
-- not have the appropriate permissions
-- to authorize that ID
| SaslInvalidMechanism -- ^ The mechanism is not supported by
-- the receiving entity
| SaslMalformedRequest -- ^ Invalid syntax
| SaslMechanismTooWeak -- ^ The receiving entity policy
-- requires a stronger mechanism
| SaslNotAuthorized -- ^ Invalid credentials
-- provided, or some
-- generic authentication
-- failure has occurred
| SaslTemporaryAuthFailure -- ^ There receiving entity reported a
-- temporary error condition; the
-- initiating entity is recommended
-- 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.
-- 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 )
type Timeout = Int
data StreamError = StreamError String
-- 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
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
| StreamXMLError
| StreamUnpickleError String
| StreamXMLError String
| StreamConnectionError
deriving ( Show , Eq , Typeable )
instance Exception StreamError
instance Error StreamError where strMsg = StreamError
instance Error StreamError where no Msg= StreamConnection Error
-- =============================================================================
-- XML TYPES
@ -610,24 +700,32 @@ instance Read LangTag where
@@ -610,24 +700,32 @@ instance Read LangTag where
-- all (\ (a, b) -> map toLower a == map toLower b) $ zip as bs
-- | otherwise = False
data ServerFeatures = SF
{ stls :: Maybe Bool
, saslMechanisms :: [ Text . Text ]
, other :: [ Element ]
} deriving Show
data XMPPConState = XMPPConState
{ sConSrc :: Source IO Event
, sRawSrc :: Source IO BS . ByteString
, sConPushBS :: BS . ByteString -> IO ()
, sConHandle :: Maybe Handle
, sFeatures :: ServerFeatures
, sHaveTLS :: Bool
, sHostname :: Maybe Text
, sUsername :: Maybe Text
, sResource :: Maybe Text
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
, sRawSrc :: Source IO BS . ByteString
, sConPushBS :: BS . ByteString -> IO ()
, sConHandle :: Maybe Handle
, sFeatures :: ServerFeatures
, sConnectionState :: XmppConnectionState
, sHostname :: Maybe Text
, sUsername :: Maybe Text
, sResource :: Maybe Text
, sCloseConnection :: IO ()
-- TODO: add default Language
}
-- |
@ -635,14 +733,14 @@ data XMPPConState = XMPPConState
@@ -635,14 +733,14 @@ data XMPPConState = XMPPConState
-- work with Pontarius. Pontarius clients needs to operate in this
-- 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.
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