module Network.Xmpp.Types
( IQError(..)
, IQRequest(..)
, IQRequestType(..)
, IQResponse(..)
, IQResult(..)
, IdGenerator(..)
, LangTag (..)
, Message(..)
, MessageError(..)
, MessageType(..)
, Presence(..)
, PresenceError(..)
, PresenceType(..)
, SaslError(..)
, SaslFailure(..)
, ServerFeatures(..)
, Stanza(..)
, StanzaError(..)
, StanzaErrorCondition(..)
, StanzaErrorType(..)
, StanzaId(..)
, StreamError(..)
, StreamErrorCondition(..)
, Version(..)
, XmppConMonad
, XmppConnection(..)
, XmppConnectionState(..)
, XmppT(..)
, XmppStreamError(..)
, langTag
, module Network.Xmpp.Jid
)
where
import Control.Applicative ((<$>), many)
import Control.Exception
import Control.Monad.IO.Class
import Control.Monad.State.Strict
import Control.Monad.Error
import qualified Data.Attoparsec.Text as AP
import qualified Data.ByteString as BS
import Data.Conduit
import Data.String(IsString(..))
import Data.Maybe (fromJust, fromMaybe, maybeToList)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable(Typeable)
import Data.XML.Types
import qualified Network as N
import Network.Xmpp.Jid
import System.IO
data StanzaId = SI !Text deriving (Eq, Ord)
instance Show StanzaId where
show (SI s) = Text.unpack s
instance Read StanzaId where
readsPrec _ x = [(SI $ Text.pack x, "")]
instance IsString StanzaId where
fromString = SI . Text.pack
data Stanza = IQRequestS !IQRequest
| IQResultS !IQResult
| IQErrorS !IQError
| MessageS !Message
| MessageErrorS !MessageError
| PresenceS !Presence
| PresenceErrorS !PresenceError
deriving Show
data IQRequest = IQRequest { iqRequestID :: !StanzaId
, iqRequestFrom :: !(Maybe Jid)
, iqRequestTo :: !(Maybe Jid)
, iqRequestLangTag :: !(Maybe LangTag)
, iqRequestType :: !IQRequestType
, iqRequestPayload :: !Element
} deriving Show
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 IQResponse = IQResponseError IQError
| IQResponseResult IQResult
| IQResponseTimeout
deriving Show
data IQResult = IQResult { iqResultID :: !StanzaId
, iqResultFrom :: !(Maybe Jid)
, iqResultTo :: !(Maybe Jid)
, iqResultLangTag :: !(Maybe LangTag)
, iqResultPayload :: !(Maybe Element)
} deriving Show
data IQError = IQError { iqErrorID :: !StanzaId
, iqErrorFrom :: !(Maybe Jid)
, iqErrorTo :: !(Maybe Jid)
, iqErrorLangTag :: !(Maybe LangTag)
, iqErrorStanzaError :: !StanzaError
, iqErrorPayload :: !(Maybe Element)
} deriving Show
data Message = Message { messageID :: !(Maybe StanzaId)
, messageFrom :: !(Maybe Jid)
, messageTo :: !(Maybe Jid)
, messageLangTag :: !(Maybe LangTag)
, messageType :: !MessageType
, messagePayload :: ![Element]
} deriving Show
data MessageError = MessageError { messageErrorID :: !(Maybe StanzaId)
, messageErrorFrom :: !(Maybe Jid)
, messageErrorTo :: !(Maybe Jid)
, messageErrorLangTag :: !(Maybe LangTag)
, messageErrorStanzaError :: !StanzaError
, messageErrorPayload :: ![Element]
} deriving (Show)
data MessageType =
Chat
| GroupChat
| Headline
| 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, "")]
data Presence = Presence { presenceID :: !(Maybe StanzaId)
, presenceFrom :: !(Maybe Jid)
, presenceTo :: !(Maybe Jid)
, presenceLangTag :: !(Maybe LangTag)
, presenceType :: !(Maybe PresenceType)
, presencePayload :: ![Element]
} deriving Show
data PresenceError = PresenceError { presenceErrorID :: !(Maybe StanzaId)
, presenceErrorFrom :: !(Maybe Jid)
, presenceErrorTo :: !(Maybe Jid)
, presenceErrorLangTag :: !(Maybe LangTag)
, presenceErrorStanzaError :: !StanzaError
, presenceErrorPayload :: ![Element]
} deriving Show
data PresenceType = Subscribe |
Subscribed |
Unsubscribe |
Unsubscribed |
Probe |
Default |
Unavailable deriving (Eq)
instance Show PresenceType where
show Subscribe = "subscribe"
show Subscribed = "subscribed"
show Unsubscribe = "unsubscribe"
show Unsubscribed = "unsubscribed"
show Probe = "probe"
show Default = ""
show Unavailable = "unavailable"
instance Read PresenceType where
readsPrec _ "" = [(Default, "")]
readsPrec _ "available" = [(Default, "")]
readsPrec _ "unavailable" = [(Unavailable, "")]
readsPrec _ "subscribe" = [(Subscribe, "")]
readsPrec _ "subscribed" = [(Subscribed, "")]
readsPrec _ "unsubscribe" = [(Unsubscribe, "")]
readsPrec _ "unsubscribed" = [(Unsubscribed, "")]
readsPrec _ "probe" = [(Probe, "")]
readsPrec _ _ = []
data StanzaError = StanzaError
{ stanzaErrorType :: StanzaErrorType
, stanzaErrorCondition :: StanzaErrorCondition
, stanzaErrorText :: Maybe (Maybe LangTag, Text)
, stanzaErrorApplicationSpecificCondition :: Maybe Element
} deriving (Eq, Show)
data StanzaErrorType = Cancel |
Continue |
Modify |
Auth |
Wait
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 _ _ = []
data StanzaErrorCondition = BadRequest
| Conflict
| FeatureNotImplemented
| Forbidden
| Gone
| InternalServerError
| ItemNotFound
| JidMalformed
| NotAcceptable
| NotAllowed
| NotAuthorized
| PaymentRequired
| RecipientUnavailable
| Redirect
| RegistrationRequired
| RemoteServerNotFound
| RemoteServerTimeout
| ResourceConstraint
| ServiceUnavailable
| SubscriptionRequired
| UndefinedCondition
| UnexpectedRequest
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 , "")]
data SaslFailure = SaslFailure { saslFailureCondition :: SaslError
, saslFailureText :: Maybe ( Maybe LangTag
, Text
)
} deriving Show
data SaslError = SaslAborted
| SaslAccountDisabled
| SaslCredentialsExpired
| SaslEncryptionRequired
| SaslIncorrectEncoding
| SaslInvalidAuthzid
| SaslInvalidMechanism
| SaslMalformedRequest
| SaslMechanismTooWeak
| SaslNotAuthorized
| SaslTemporaryAuthFailure
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 _ _ = []
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
| StreamUnknownError
| StreamNotStreamElement Text
| StreamInvalidStreamNamespace (Maybe Text)
| StreamInvalidStreamPrefix (Maybe Text)
| StreamWrongTo (Maybe Text)
| StreamWrongVersion (Maybe Text)
| StreamWrongLangTag (Maybe Text)
| StreamXMLError String
| StreamStreamEnd
| StreamConnectionError
deriving (Show, Eq, Typeable)
instance Exception StreamError
instance Error StreamError where noMsg = StreamConnectionError
newtype IdGenerator = IdGenerator (IO Text)
data Version = Version { majorVersion :: !Integer
, minorVersion :: !Integer } deriving (Eq)
instance Ord Version where
compare (Version amajor aminor) (Version bmajor bminor)
| amajor /= bmajor = compare amajor bmajor
| otherwise = compare aminor bminor
instance Read Version where
readsPrec _ txt = (,"") <$> maybeToList (versionFromText $ Text.pack txt)
instance Show Version where
show (Version major minor) = (show major) ++ "." ++ (show minor)
versionFromText :: Text.Text -> Maybe Version
versionFromText s = case AP.parseOnly versionParser s of
Right version -> Just version
Left _ -> Nothing
versionParser :: AP.Parser Version
versionParser = do
major <- AP.many1 AP.digit
AP.skip (== '.')
minor <- AP.many1 AP.digit
AP.endOfInput
return $ Version (read major) (read minor)
data LangTag = LangTag { primaryTag :: !Text
, subtags :: ![Text] }
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]
langTag :: Text.Text -> Maybe LangTag
langTag s = case AP.parseOnly langTagParser s of
Right tag -> Just tag
Left _ -> Nothing
langTagParser :: AP.Parser LangTag
langTagParser = do
primTag <- tag
subTags <- many subtag
AP.endOfInput
return $ LangTag primTag subTags
where
tag :: AP.Parser Text.Text
tag = do
t <- AP.takeWhile1 $ AP.inClass tagChars
return t
subtag :: AP.Parser Text.Text
subtag = do
AP.skip (== '-')
subtag <- tag
return subtag
tagChars :: [Char]
tagChars = ['a'..'z'] ++ ['A'..'Z']
data ServerFeatures = SF
{ stls :: !(Maybe Bool)
, saslMechanisms :: ![Text.Text]
, other :: ![Element]
} deriving Show
data XmppConnectionState
= XmppConnectionClosed
| XmppConnectionPlain
| XmppConnectionSecured
deriving (Show, Eq, Typeable)
data XmppConnection = XmppConnection
{ sConSrc :: !(Source IO Event)
, sRawSrc :: !(Source IO BS.ByteString)
, sConPushBS :: !(BS.ByteString -> IO Bool)
, sConHandle :: !(Maybe Handle)
, sFeatures :: !ServerFeatures
, sConnectionState :: !XmppConnectionState
, sHostname :: !(Maybe Text)
, sJid :: !(Maybe Jid)
, sCloseConnection :: !(IO ())
, sPreferredLang :: !(Maybe LangTag)
, sStreamLang :: !(Maybe LangTag)
, sStreamId :: !(Maybe Text)
, sToJid :: !(Maybe Jid)
, sJidWhenPlain :: !Bool
, sFrom :: !(Maybe Jid)
}
newtype XmppT m a = XmppT { runXmppT :: StateT XmppConnection m a } deriving (Monad, MonadIO)
type XmppConMonad a = StateT XmppConnection IO a
deriving instance (Monad m, MonadIO m) => MonadState (XmppConnection) (XmppT m)