From 5cda361ba0331727a3dd5637452853ee34daf97a Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Sun, 8 Apr 2012 15:13:41 +0200 Subject: [PATCH] added SessionSettings record, made the stanza types internal (forced StanzaId), StanzaId show instance, Session.hs is broken --- Network/XMPP/Session.hs | 1 - Network/XMPP/Types.hs | 246 ++++++++++++++++++++++++++-------------- 2 files changed, 160 insertions(+), 87 deletions(-) diff --git a/Network/XMPP/Session.hs b/Network/XMPP/Session.hs index 77e8c67..a05b517 100644 --- a/Network/XMPP/Session.hs +++ b/Network/XMPP/Session.hs @@ -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? diff --git a/Network/XMPP/Types.hs b/Network/XMPP/Types.hs index 0a90287..728d7fa 100644 --- a/Network/XMPP/Types.hs +++ b/Network/XMPP/Types.hs @@ -9,7 +9,7 @@ module Network.XMPP.Types ( -StanzaID (..), +StanzaId (..), From, To, IQ, @@ -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) 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 -- | --- 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 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 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 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 -- | --- 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 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 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@. +-- @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 deriving (Eq) +data MessageType = Chat | -- ^ + Groupchat | -- ^ + Headline | -- ^ + Normal -- ^ The default message type + deriving (Eq) 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 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 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 -- stream looks like . 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 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 -- ============================================================================= +-- | 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]) @@ -633,6 +644,69 @@ instance Show LangTag where -- Two language tags are considered equal of they contain the same tags (case-insensitive). 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 + (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 | 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) \ No newline at end of file