Browse Source

added SessionSettings record, made the stanza types internal (forced StanzaId), StanzaId show instance, Session.hs is broken

master
Jon Kristensen 14 years ago
parent
commit
5cda361ba0
  1. 1
      Network/XMPP/Session.hs
  2. 246
      Network/XMPP/Types.hs

1
Network/XMPP/Session.hs

@ -132,7 +132,6 @@ processEvent (OpenStreamsEvent h p) = openStreamAction h p @@ -132,7 +132,6 @@ processEvent (OpenStreamsEvent h p) = openStreamAction h p
result <- liftIO $ CE.try (computation $ evtChan rs)
case result of
Right () -> do
fireStreamsOpenedEvent Nothing
return ()
-- -- lift $ liftIO $ putMVar (stateThreadID state) threadID
Left (CE.SomeException e) -> do -- TODO: Safe to do this?

246
Network/XMPP/Types.hs

@ -9,7 +9,7 @@ @@ -9,7 +9,7 @@
module Network.XMPP.Types (
StanzaID (..),
StanzaId (..),
From,
To,
IQ,
@ -64,9 +64,12 @@ MessageError (..), @@ -64,9 +64,12 @@ MessageError (..),
HookId (..),
Hook (..),
HookPayload (..),
State (..)
State (..),
SessionSettings (..)
) where
-- import Network.XMPP.Utilities (idGenerator)
import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput)
import qualified Network as N
@ -93,6 +96,17 @@ import Control.Exception.Base (SomeException) @@ -93,6 +96,17 @@ import Control.Exception.Base (SomeException)
import Control.Concurrent
import Data.Maybe (fromJust)
-- | The string prefix MUST be
data SessionSettings =
SessionSettings { ssIdPrefix :: String
, ssIdGenerator :: IdGenerator
, ssStreamLang :: LangTag }
-- =============================================================================
-- STANZA TYPES
-- =============================================================================
@ -108,12 +122,14 @@ import Control.Concurrent @@ -108,12 +122,14 @@ import Control.Concurrent
-- |
-- The StanzaID type wraps a string of random characters that in Pontarius XMPP
-- is guaranteed to be unique for the XMPP session. Clients can add a string
-- prefix for the IDs to guarantee that they are unique in a larger context by
-- specifying the stanzaIDPrefix setting. TODO
-- Wraps a string of random characters that, when using an appropriate
-- @IDGenerator@, is guaranteed to be unique for the XMPP session.
-- Stanza identifiers are generated by Pontarius.
data StanzaId = SI String deriving (Eq)
data StanzaID = SID String deriving (Eq, Show)
instance Show StanzaId where
show (SI s) = s
-- |
@ -128,18 +144,24 @@ type From = Address @@ -128,18 +144,24 @@ type From = Address
type To = Address
-- |
-- 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.
-- 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.
--
-- Objects of this type cannot be generated by Pontarius applications,
-- but are only created internally.
type IQ = Either IQRequest IQResponse
-- |
-- A "request" Info/Query (IQ) stanza is one with either "get" or "set" as type.
-- They are guaranteed to always contain a payload.
-- 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 :: Maybe StanzaID
data IQRequest = IQRequest { iqRequestID :: StanzaId
, iqRequestFrom :: Maybe From
, iqRequestTo :: Maybe To
, iqRequestLangTag :: LangTag
@ -148,63 +170,24 @@ data IQRequest = IQRequest { iqRequestID :: Maybe StanzaID @@ -148,63 +170,24 @@ data IQRequest = IQRequest { iqRequestID :: Maybe StanzaID
deriving (Show)
data InternalEvent m
= OpenStreamsEvent HostName PortNumber
-- | DisconnectEvent
| RegisterStreamsOpenedHook (Maybe (Maybe OpenStreamsFailureReason -> XMPPT m Bool)) (Maybe OpenStreamsFailureReason -> XMPPT m Bool)
| EnumeratorFirstLevelElement Element
-- | IEEE EnumeratorEvent
| EnumeratorDone
| EnumeratorBeginStream (Maybe String) (Maybe String) (Maybe String) (Maybe String) (Maybe String) (Maybe String)
| EnumeratorEndStream
| EnumeratorException CE.SomeException
-- |
-- The XMPP monad transformer. Contains internal state in order to
-- work with Pontarius. Pontarius clients needs to operate in this
-- context.
newtype XMPPT m a = XMPPT { runXMPPT :: StateT (State m) m a } deriving (Monad, MonadIO)
-- Make XMPPT derive the Monad and MonadIO instances.
deriving instance (Monad m, MonadIO m) => MonadState (State m) (XMPPT m)
-- We need a channel because multiple threads needs to append events,
-- and we need to wait for events when there are none.
data State m = State { evtChan :: Chan (InternalEvent m)
, hookIdGenerator :: IdGenerator
, hooks :: [Hook m] }
data HookId = HookId String deriving (Eq)
data HookPayload m = StreamsOpenedHook (Maybe (Maybe OpenStreamsFailureReason -> XMPPT m Bool)) (Maybe OpenStreamsFailureReason -> XMPPT m Bool)
type Hook m = (HookId, HookPayload m)
-- TODO: Possible ways opening a stream can fail.
data OpenStreamsFailureReason = OpenStreamsFailureReason deriving (Show)
-- data TLSSecureFailureReason = TLSSecureFailureReason
-- data AuthenticateFailureReason = AuthenticateFailureReason
data DisconnectReason = DisconnectReason deriving (Show)
data IQRequestType = Get | Set deriving (Show)
-- |
-- 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
data IQResult = IQResult { iqResultID :: Maybe StanzaID
-- |
-- Objects of this type cannot be generated by Pontarius applications,
-- but are only created internally.
data IQResult = IQResult { iqResultID :: StanzaId
, iqResultFrom :: Maybe From
, iqResultTo :: Maybe To
, iqResultLangTag :: LangTag
@ -212,7 +195,11 @@ data IQResult = IQResult { iqResultID :: Maybe StanzaID @@ -212,7 +195,11 @@ data IQResult = IQResult { iqResultID :: Maybe StanzaID
deriving (Show)
data IQError = IQError { iqErrorID :: Maybe StanzaID
-- |
-- Objects of this type cannot be generated by Pontarius applications,
-- but are only created internally.
data IQError = IQError { iqErrorID :: StanzaId
, iqErrorFrom :: Maybe From
, iqErrorTo :: Maybe To
, iqErrorLangTag :: LangTag
@ -222,9 +209,12 @@ data IQError = IQError { iqErrorID :: Maybe StanzaID @@ -222,9 +209,12 @@ data IQError = IQError { iqErrorID :: Maybe StanzaID
-- |
-- The message stanza - either a message or a message error.
-- 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 From
, messageTo :: Maybe To
, messageLangTag :: LangTag
@ -233,7 +223,13 @@ data Message = Message { messageID :: Maybe StanzaID @@ -233,7 +223,13 @@ data Message = Message { messageID :: Maybe StanzaID
deriving (Show)
data MessageError = MessageError { messageErrorID :: Maybe StanzaID
-- |
-- 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
, messageErrorFrom :: Maybe From
, messageErrorTo :: Maybe To
, messageErrorLangTag :: LangTag
@ -242,18 +238,22 @@ data MessageError = MessageError { messageErrorID :: Maybe StanzaID @@ -242,18 +238,22 @@ data MessageError = MessageError { messageErrorID :: Maybe StanzaID
deriving (Show)
-- Objects of this type cannot be generated by Pontarius applications,
-- but are only created internally.
type InternalMessage = Either MessageError Message
-- |
-- @MessageType@ holds XMPP message types as defined in XMPP-IM. @Normal@ is the
-- default message type. The "error" message type is left out as errors are
-- using @MessageError@.
data MessageType = Chat |
Groupchat |
Headline |
Normal deriving (Eq)
-- @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
deriving (Eq)
instance Show MessageType where
@ -264,10 +264,10 @@ instance Show MessageType where @@ -264,10 +264,10 @@ instance Show MessageType where
-- |
-- The presence stanza. It is used for both originating messages and replies.
-- For presence errors, see "PresenceError".
-- Objects of this type cannot be generated by Pontarius applications,
-- but are only created internally.
data Presence = Presence { presenceID :: Maybe StanzaID
data Presence = Presence { presenceID :: StanzaId
, presenceFrom :: Maybe From
, presenceTo :: Maybe To
, presenceLangTag :: LangTag
@ -276,7 +276,11 @@ data Presence = Presence { presenceID :: Maybe StanzaID @@ -276,7 +276,11 @@ data Presence = Presence { presenceID :: Maybe StanzaID
deriving (Show)
data PresenceError = PresenceError { presenceErrorID :: Maybe StanzaID
-- |
-- Objects of this type cannot be generated by Pontarius applications,
-- but are only created internally.
data PresenceError = PresenceError { presenceErrorID :: Maybe StanzaId
, presenceErrorFrom :: Maybe From
, presenceErrorTo :: Maybe To
, presenceErrorLangTag :: LangTag
@ -285,12 +289,15 @@ data PresenceError = PresenceError { presenceErrorID :: Maybe StanzaID @@ -285,12 +289,15 @@ data PresenceError = PresenceError { presenceErrorID :: Maybe StanzaID
deriving (Show)
-- Objects of this type cannot be generated by Pontarius applications,
-- but are only created internally.
type InternalPresence = Either PresenceError Presence
-- |
-- @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
Subscribed | -- ^ Sender has approved the subscription
@ -316,7 +323,7 @@ instance Show PresenceType where @@ -316,7 +323,7 @@ instance Show PresenceType where
-- stream looks like <stanza-kind to='sender' type='error'>. These errors are
-- wrapped in the @StanzaError@ type.
-- Sender XML is optional and is not included.
-- TODO: Sender XML is (optional and is) not included.
data StanzaError = StanzaError { stanzaErrorType :: StanzaErrorType
, stanzaErrorCondition :: StanzaErrorCondition
@ -490,10 +497,10 @@ type Password = String @@ -490,10 +497,10 @@ type Password = String
type Resource = String
data TimeoutEvent s m = TimeoutEvent StanzaID Timeout (StateT s m ())
data TimeoutEvent s m = TimeoutEvent StanzaId Timeout (StateT s m ())
instance Show (TimeoutEvent s m) where
show (TimeoutEvent (SID i) t _) = "TimeoutEvent (ID: " ++ (show i) ++ ", timeout: " ++ (show t) ++ ")"
show (TimeoutEvent (SI i) t _) = "TimeoutEvent (ID: " ++ (show i) ++ ", timeout: " ++ (show t) ++ ")"
data StreamState = PreStream |
@ -593,6 +600,10 @@ data StreamError = StreamError @@ -593,6 +600,10 @@ data StreamError = StreamError
-- =============================================================================
-- | Wraps a function that MUST generate a stream of unique Ids. The
-- strings MUST be appropriate for use in the stanza id attirubte.
-- For a default implementation, see @idGenerator@.
newtype IdGenerator = IdGenerator (IORef [String])
@ -634,5 +645,68 @@ instance Show LangTag where @@ -634,5 +645,68 @@ instance Show LangTag where
instance Eq LangTag where
(LangTag ap as) == (LangTag bp bs)
| length as == length bs && map toLower ap == map toLower bp = all (\ (a, b) -> map toLower a == map toLower b) $ zip as bs
| length as == length bs && map toLower ap == map toLower bp =
all (\ (a, b) -> map toLower a == map toLower b) $ zip as bs
| otherwise = False
data InternalEvent m
= OpenStreamsEvent HostName PortNumber
-- | DisconnectEvent
| RegisterStreamsOpenedHook (Maybe (Maybe OpenStreamsFailureReason -> XMPPT m Bool)) (Maybe OpenStreamsFailureReason -> XMPPT m Bool)
| EnumeratorFirstLevelElement Element
-- | IEEE EnumeratorEvent
| EnumeratorDone
| EnumeratorBeginStream (Maybe String) (Maybe String) (Maybe String) (Maybe String) (Maybe String) (Maybe String)
| EnumeratorEndStream
| EnumeratorException CE.SomeException
-- |
-- The XMPP monad transformer. Contains internal state in order to
-- work with Pontarius. Pontarius clients needs to operate in this
-- context.
newtype XMPPT m a = XMPPT { runXMPPT :: StateT (State m) m a } deriving (Monad, MonadIO)
-- Make XMPPT derive the Monad and MonadIO instances.
deriving instance (Monad m, MonadIO m) => MonadState (State m) (XMPPT m)
-- We need a channel because multiple threads needs to append events,
-- and we need to wait for events when there are none.
data State m = State { evtChan :: Chan (InternalEvent m)
, hookIdGenerator :: IdGenerator
, hooks :: [Hook m] }
data HookId = HookId String deriving (Eq)
data HookPayload m = StreamsOpenedHook (Maybe (Maybe OpenStreamsFailureReason -> XMPPT m Bool)) (Maybe OpenStreamsFailureReason -> XMPPT m Bool)
type Hook m = (HookId, HookPayload m)
-- TODO: Possible ways opening a stream can fail.
data OpenStreamsFailureReason = OpenStreamsFailureReason deriving (Show)
-- data TLSSecureFailureReason = TLSSecureFailureReason
-- data AuthenticateFailureReason = AuthenticateFailureReason
data DisconnectReason = DisconnectReason deriving (Show)
Loading…
Cancel
Save