Jon Kristensen
14 years ago
committed by
Philipp Balzarek
2 changed files with 0 additions and 905 deletions
@ -1,762 +0,0 @@ |
|||||||
-- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the |
|
||||||
-- Pontarius distribution for more details. |
|
||||||
|
|
||||||
-- I believe we need to use the MultiParamTypeClasses extension to be able to |
|
||||||
-- work with arbitrary client states (solving the problem that the ClientState |
|
||||||
-- type class is solving). However, I would be happy if someone proved me wrong. |
|
||||||
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-} |
|
||||||
|
|
||||||
{-# OPTIONS_HADDOCK hide #-} |
|
||||||
|
|
||||||
-- This module provides the functions used by XMPP clients to manage their XMPP |
|
||||||
-- sessions. |
|
||||||
-- |
|
||||||
-- Working with Pontarius is mostly done asynchronously with callbacks; |
|
||||||
-- Pontarius "owns" the XMPP thread and carries the client state with it. A |
|
||||||
-- client consists of a list of client handlers to handle XMPP events. This is |
|
||||||
-- all set up through a @Session@ object, which a client can create by calling |
|
||||||
-- the (blocking) function @createSession@. |
|
||||||
-- |
|
||||||
-- The Pontarius XMPP functions operate in an arbitrary MonadIO monad. |
|
||||||
-- Typically, clients will use the IO monad. |
|
||||||
-- |
|
||||||
-- For more information, see the Pontarius manual. |
|
||||||
|
|
||||||
-- TODO: Better functions and events for stanzas, IncomingIQ, OutgoingIQ, etc. (ClientSession, ClientStanza) |
|
||||||
|
|
||||||
-- TODO: IO function to do everything related to the handle, instead of just connecting. |
|
||||||
|
|
||||||
-- TODO: Enumerate in the same thread? Enumerate one element at the time, non-blocking? |
|
||||||
|
|
||||||
module Network.XMPP.Session ( ClientHandler (..) |
|
||||||
, ClientState (..) |
|
||||||
, ConnectResult (..) |
|
||||||
, Session |
|
||||||
, TerminationReason |
|
||||||
, OpenStreamResult (..) |
|
||||||
, SecureWithTLSResult (..) |
|
||||||
, AuthenticateResult (..) |
|
||||||
, sendPresence |
|
||||||
, sendIQ |
|
||||||
, sendMessage |
|
||||||
, connect |
|
||||||
, openStreams |
|
||||||
, tlsSecureStreams |
|
||||||
, authenticate |
|
||||||
, session |
|
||||||
, injectAction |
|
||||||
, getID ) where |
|
||||||
|
|
||||||
import Network.XMPP.Address |
|
||||||
import Network.XMPP.SASL |
|
||||||
import Network.XMPP.Stanza |
|
||||||
import Network.XMPP.Stream |
|
||||||
import Network.XMPP.TLS |
|
||||||
import Network.XMPP.Types |
|
||||||
import Network.XMPP.Utilities |
|
||||||
|
|
||||||
import qualified Control.Exception as CE |
|
||||||
import qualified Control.Exception.Base as CEB -- ? |
|
||||||
import qualified Control.Monad.Error as CME |
|
||||||
import qualified Control.Monad.State as CMS |
|
||||||
import qualified Network as N |
|
||||||
|
|
||||||
------------- |
|
||||||
|
|
||||||
import Crypto.Random (newGenIO, SystemRandom) |
|
||||||
|
|
||||||
import Control.Concurrent.MVar |
|
||||||
|
|
||||||
import Codec.Binary.UTF8.String |
|
||||||
import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) |
|
||||||
import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay) |
|
||||||
import Control.Monad.IO.Class (liftIO, MonadIO) |
|
||||||
import Control.Monad.State hiding (State) |
|
||||||
import Data.Enumerator (($$), Iteratee, continue, joinI, |
|
||||||
run, run_, yield) |
|
||||||
import Data.Enumerator.Binary (enumHandle, enumFile) |
|
||||||
import Data.Maybe |
|
||||||
import Data.String |
|
||||||
import Data.XML.Types |
|
||||||
import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput) |
|
||||||
import Network.TLS |
|
||||||
import Network.TLS.Cipher |
|
||||||
import System.IO (BufferMode, BufferMode(NoBuffering)) |
|
||||||
-- import Text.XML.Enumerator.Parse (parseBytes, decodeEntities) |
|
||||||
-- import Text.XML.Enumerator.Document (fromEvents) |
|
||||||
import qualified Codec.Binary.Base64.String as CBBS |
|
||||||
import qualified Data.ByteString as DB |
|
||||||
import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack, fromChunks, toChunks, null) |
|
||||||
import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack) |
|
||||||
import qualified Data.Enumerator as E |
|
||||||
import qualified Data.Enumerator.List as EL |
|
||||||
import qualified Data.List as DL |
|
||||||
import qualified Data.Text as DT |
|
||||||
import qualified Data.Text.Lazy as DTL |
|
||||||
|
|
||||||
import Data.Certificate.X509 (X509) |
|
||||||
|
|
||||||
import Data.UUID (UUID, toString) |
|
||||||
|
|
||||||
import System.Random (randomIO) |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- ============================================================================= |
|
||||||
-- EXPORTED TYPES AND FUNCTIONS |
|
||||||
-- ============================================================================= |
|
||||||
|
|
||||||
|
|
||||||
-- | The @Session@ object is used by clients when interacting with Pontarius. |
|
||||||
-- It holds information needed by Pontarius XMPP; its content is not |
|
||||||
-- accessible from the client. |
|
||||||
|
|
||||||
-- data Session s m = Session { sessionChannel :: Chan (InternalEvent s m) |
|
||||||
-- , sessionIDGenerator :: IDGenerator } |
|
||||||
|
|
||||||
|
|
||||||
-- | A client typically needs one or more @ClientHandler@ objects to interact |
|
||||||
-- with Pontarius. Each client handler may provide four callback |
|
||||||
-- functions; the first three callbacks deals with received stanzas, and the |
|
||||||
-- last one is used when the session is terminated. |
|
||||||
-- |
|
||||||
-- These stanza functions takes the current client state and an object |
|
||||||
-- containing the details of the stanza in question. The boolean returned |
|
||||||
-- along with the possibly updated state signals whether or not the message |
|
||||||
-- should be blocked to client handlerss further down the stack. For example, |
|
||||||
-- an XEP-0030: Service Discovery handler may choose to hide disco\#info |
|
||||||
-- requests to handlers above it in the stack. |
|
||||||
-- |
|
||||||
-- The 'sessionTerminated' callback function takes a 'TerminationReason' value |
|
||||||
-- along with the state and will be sent to all client handlers. |
|
||||||
|
|
||||||
-- data MonadIO m => ClientHandler s m = |
|
||||||
-- ClientHandler { messageReceived :: Maybe (Message -> StateT s m Bool) |
|
||||||
-- , presenceReceived :: Maybe (Presence -> StateT s m Bool) |
|
||||||
-- , iqReceived :: Maybe (IQ -> StateT s m Bool) |
|
||||||
-- , sessionTerminated :: Maybe (TerminationReason -> |
|
||||||
-- StateT s m ()) } |
|
||||||
|
|
||||||
|
|
||||||
-- | @TerminationReason@ contains information on why the XMPP session was |
|
||||||
-- terminated. |
|
||||||
|
|
||||||
-- data TerminationReason = WhateverReason -- TODO |
|
||||||
|
|
||||||
|
|
||||||
-- | Creates an XMPP session. Blocks the current thread. The first parameter, |
|
||||||
-- @s@, is an arbitrary state that is defined by the client. This is the |
|
||||||
-- initial state, and it will be passed to the client (handlers) as XMPP |
|
||||||
-- events are emitted. The second parameter is the list of @ClientHandler@s; |
|
||||||
-- this is a way to provide a "layered" system of XMPP event handlers. For |
|
||||||
-- example, a client may have a dedicated handler to manage messages, |
|
||||||
-- implement a spam protection system, etc. Messages are piped through these |
|
||||||
-- handlers one by one, and any handler may block the message from being sent |
|
||||||
-- to the next handler(s) above in the stack. The third argument is a callback |
|
||||||
-- function that will be called when the session has been initialized, and |
|
||||||
-- this function should be used by the client to store the Session object in |
|
||||||
-- its state. |
|
||||||
|
|
||||||
-- Creates the internal event channel, injects the Pontarius XMPP session object |
|
||||||
-- into the ClientState object, runs the "session created" client callback (in |
|
||||||
-- the new state context), and stores the updated client state in s''. Finally, |
|
||||||
-- we launch the (main) state loop of Pontarius XMPP. |
|
||||||
|
|
||||||
session :: (MonadIO m, ClientState s m) => s -> [ClientHandler s m] -> |
|
||||||
(CMS.StateT s m ()) -> m () |
|
||||||
|
|
||||||
session s h c = do |
|
||||||
threadID <- liftIO $ newEmptyMVar |
|
||||||
chan <- liftIO $ newChan |
|
||||||
idGenerator <- liftIO $ idGenerator "" -- TODO: Prefix |
|
||||||
((), clientState) <- runStateT c (putSession s $ session_ chan idGenerator) |
|
||||||
(result, _) <- runStateT (stateLoop chan) |
|
||||||
(defaultState chan threadID h clientState idGenerator) |
|
||||||
case result of |
|
||||||
Just (CE.SomeException e) -> do |
|
||||||
liftIO $ putStrLn "Got an exception!" |
|
||||||
threadID' <- liftIO $ tryTakeMVar threadID |
|
||||||
case threadID' of |
|
||||||
Nothing -> do |
|
||||||
liftIO $ putStrLn "No thread ID to kill" |
|
||||||
Just t -> do |
|
||||||
liftIO $ putStrLn "Killing thread" |
|
||||||
liftIO $ killThread t |
|
||||||
CE.throw e |
|
||||||
Nothing -> |
|
||||||
return () |
|
||||||
where |
|
||||||
-- session :: Chan (InternalEvent m s) -> Session m s -- TODO |
|
||||||
session_ c i = Session { sessionChannel = c, sessionIDGenerator = i } |
|
||||||
|
|
||||||
|
|
||||||
defaultState :: (MonadIO m, ClientState s m) => Chan (InternalEvent s m) -> MVar ThreadId -> |
|
||||||
[ClientHandler s m] -> s -> IDGenerator -> State s m |
|
||||||
|
|
||||||
defaultState c t h s i = State { stateClientHandlers = h |
|
||||||
, stateClientState = s |
|
||||||
, stateChannel = c |
|
||||||
, stateConnectionState = Disconnected |
|
||||||
, stateStreamState = PreStream |
|
||||||
, stateTLSState = NoTLS |
|
||||||
, stateOpenStreamsCallback = Nothing |
|
||||||
, stateTLSSecureStreamsCallback = Nothing |
|
||||||
, stateAuthenticateCallback = Nothing |
|
||||||
, stateAuthenticationState = NoAuthentication |
|
||||||
, stateResource = Nothing |
|
||||||
, stateShouldExit = False |
|
||||||
, stateThreadID = t |
|
||||||
, statePresenceCallbacks = [] |
|
||||||
, stateMessageCallbacks = [] |
|
||||||
, stateIQCallbacks = [] |
|
||||||
, stateTimeoutStanzaIDs = [] |
|
||||||
, stateIDGenerator = i |
|
||||||
, stateSASLRValue = Nothing } -- TODO: Prefix |
|
||||||
|
|
||||||
|
|
||||||
-- | |
|
||||||
-- Convenience function for calling "openStreams" and "tlsSecureStreams" and\/or |
|
||||||
-- "authenticate". See the documentation for the three separate functions for |
|
||||||
-- details on how they operate. |
|
||||||
|
|
||||||
connect :: MonadIO m => Session s m -> HostName -> PortNumber -> |
|
||||||
Maybe (Maybe [X509], ([X509] -> Bool)) -> |
|
||||||
Maybe (UserName, Password, Maybe Resource) -> |
|
||||||
(ConnectResult -> StateT s m ()) -> StateT s m () |
|
||||||
|
|
||||||
connect s h p t a c = openStreams s h p connect' |
|
||||||
where |
|
||||||
connect' r = case r of |
|
||||||
OpenStreamSuccess _ _ -> case t of -- TODO: Check for TLS support? |
|
||||||
Just (certificate, certificateValidator) -> |
|
||||||
tlsSecureStreams s certificate certificateValidator connect'' |
|
||||||
Nothing -> connect'' (SecureWithTLSSuccess 1.0 "") -- TODO |
|
||||||
OpenStreamFailure -> c ConnectOpenStreamFailure |
|
||||||
connect'' r = case r of |
|
||||||
SecureWithTLSSuccess _ _ -> case a of |
|
||||||
Just (userName, password, resource) -> |
|
||||||
authenticate s userName password resource connect''' |
|
||||||
Nothing -> connect''' (AuthenticateSuccess 1.0 "" "todo") -- TODO |
|
||||||
SecureWithTLSFailure -> c ConnectSecureWithTLSFailure |
|
||||||
connect''' r = case r of |
|
||||||
AuthenticateSuccess streamProperties streamFeatures resource -> |
|
||||||
c (ConnectSuccess streamProperties streamFeatures (Just resource)) |
|
||||||
AuthenticateFailure -> c ConnectAuthenticateFailure |
|
||||||
|
|
||||||
|
|
||||||
openStreams :: MonadIO m => Session s m -> HostName -> PortNumber -> |
|
||||||
(OpenStreamResult -> StateT s m ()) -> StateT s m () |
|
||||||
|
|
||||||
openStreams s h p c = CMS.get >>= |
|
||||||
(\ state -> lift $ liftIO $ writeChan (sessionChannel s) |
|
||||||
(IEC (CEOpenStream h p c))) |
|
||||||
|
|
||||||
|
|
||||||
-- | |
|
||||||
-- Tries to secure the connection with TLS. |
|
||||||
-- |
|
||||||
-- If the list of certificates is provided, they will be presented to the |
|
||||||
-- server. |
|
||||||
-- |
|
||||||
-- The third parameter is an optional custom validation function for the server |
|
||||||
-- certificates. Note that Pontarius will perform its own validation |
|
||||||
-- according to the RFC 6120, including comparing the domain name specified in |
|
||||||
-- the certificate against the connected server, as well as checking the |
|
||||||
-- integrity, and the certificate authorities. |
|
||||||
-- |
|
||||||
-- Note: The current implementation of `certificate' looks for trusted |
|
||||||
-- certificates in the /etc/ssl/certs directory. |
|
||||||
-- |
|
||||||
-- Note: The current implementation of `certificate' does not support parsing |
|
||||||
-- X509 extensions. Because of this, we will defer checking CRLs and/or OCSP |
|
||||||
-- services as well as checking for the basicConstraints cA boolean for the |
|
||||||
-- time-being. |
|
||||||
|
|
||||||
tlsSecureStreams :: MonadIO m => Session s m -> Maybe [X509] -> |
|
||||||
([X509] -> Bool) -> (SecureWithTLSResult -> StateT s m ()) -> StateT s m () |
|
||||||
|
|
||||||
tlsSecureStreams s c a c_ = CMS.get >>= |
|
||||||
(\ state -> lift $ liftIO $ |
|
||||||
writeChan (sessionChannel s) |
|
||||||
(IEC (CESecureWithTLS c a c_))) |
|
||||||
|
|
||||||
|
|
||||||
-- | |
|
||||||
|
|
||||||
authenticate :: MonadIO m => Session s m -> UserName -> Password -> |
|
||||||
Maybe Resource -> (AuthenticateResult -> StateT s m ()) -> |
|
||||||
StateT s m () |
|
||||||
|
|
||||||
authenticate s u p r c = CMS.get >>= |
|
||||||
(\ state -> lift $ liftIO $ |
|
||||||
writeChan (sessionChannel s) |
|
||||||
(IEC (CEAuthenticate u p r c))) |
|
||||||
|
|
||||||
|
|
||||||
sendMessage :: MonadIO m => Session s m -> Message -> Maybe (Message -> StateT s m Bool) -> Maybe (Timeout, StateT s m ()) -> Maybe (StreamError -> StateT s m ()) -> StateT s m () |
|
||||||
sendMessage se m c t st = CMS.get >>= |
|
||||||
(\ state -> lift $ liftIO $ |
|
||||||
writeChan (sessionChannel se) |
|
||||||
(IEC (CEMessage m c t st))) |
|
||||||
|
|
||||||
sendPresence :: MonadIO m => Session s m -> Presence -> Maybe (Presence -> StateT s m Bool) -> Maybe (Timeout, StateT s m ()) -> Maybe (StreamError -> StateT s m ()) -> StateT s m () |
|
||||||
sendPresence se p c t st = CMS.get >>= |
|
||||||
(\ state -> lift $ liftIO $ |
|
||||||
writeChan (sessionChannel se) |
|
||||||
(IEC (CEPresence p c t st))) |
|
||||||
|
|
||||||
sendIQ :: MonadIO m => Session s m -> IQ -> Maybe (IQ -> StateT s m Bool) -> Maybe (Timeout, StateT s m ()) -> Maybe (StreamError -> StateT s m ()) -> StateT s m () |
|
||||||
sendIQ se i c t st = CMS.get >>= |
|
||||||
(\ state -> lift $ liftIO $ |
|
||||||
writeChan (sessionChannel se) |
|
||||||
(IEC (CEIQ i c t st))) |
|
||||||
|
|
||||||
injectAction :: MonadIO m => Session s m -> Maybe (StateT s m Bool) -> StateT s m () -> StateT s m () |
|
||||||
injectAction s p a = CMS.get >>= |
|
||||||
(\ state -> lift $ liftIO $ |
|
||||||
writeChan (sessionChannel s) |
|
||||||
(IEC (CEAction p a))) |
|
||||||
|
|
||||||
getID :: MonadIO m => Session s m -> StateT s m String |
|
||||||
getID s = CMS.get >>= \ state -> lift $ liftIO $ nextID (sessionIDGenerator s) >>= \ id -> return id |
|
||||||
|
|
||||||
-- xmppDisconnect :: MonadIO m => Session s m -> Maybe (s -> (Bool, s)) -> m () |
|
||||||
-- xmppDisconnect s c = xmppDisconnect s c |
|
||||||
|
|
||||||
class ClientState s m where |
|
||||||
putSession :: s -> Session s m -> s |
|
||||||
|
|
||||||
|
|
||||||
-- ============================================================================= |
|
||||||
-- INTERNAL TYPES AND FUNCTIONS |
|
||||||
-- ============================================================================= |
|
||||||
|
|
||||||
|
|
||||||
type OpenStreamCallback s m = Maybe (OpenStreamResult -> CMS.StateT s m ()) |
|
||||||
|
|
||||||
type SecureWithTLSCallback s m = Maybe (SecureWithTLSResult -> CMS.StateT s m ()) |
|
||||||
|
|
||||||
type AuthenticateCallback s m = Maybe (AuthenticateResult -> CMS.StateT s m ()) |
|
||||||
|
|
||||||
|
|
||||||
isConnected :: ConnectionState -> Bool |
|
||||||
isConnected Disconnected = True |
|
||||||
isConnected (Connected _ _) = True |
|
||||||
|
|
||||||
data MonadIO m => State s m = |
|
||||||
State { stateClientHandlers :: [ClientHandler s m] |
|
||||||
, stateClientState :: s |
|
||||||
, stateChannel :: Chan (InternalEvent s m) |
|
||||||
, stateConnectionState :: ConnectionState -- s m |
|
||||||
, stateTLSState :: TLSState |
|
||||||
, stateStreamState :: StreamState |
|
||||||
, stateOpenStreamsCallback :: OpenStreamCallback s m |
|
||||||
, stateTLSSecureStreamsCallback :: SecureWithTLSCallback s m |
|
||||||
, stateAuthenticateCallback :: AuthenticateCallback s m |
|
||||||
, stateAuthenticationState :: AuthenticationState |
|
||||||
, stateResource :: Maybe Resource |
|
||||||
, stateShouldExit :: Bool |
|
||||||
, stateThreadID :: MVar ThreadId |
|
||||||
, statePresenceCallbacks :: [(StanzaID, (Presence -> StateT s m Bool))] |
|
||||||
, stateMessageCallbacks :: [(StanzaID, (Message -> StateT s m Bool))] |
|
||||||
, stateIQCallbacks :: [(StanzaID, (IQ -> StateT s m Bool))] |
|
||||||
, stateTimeoutStanzaIDs :: [StanzaID] |
|
||||||
, stateIDGenerator :: IDGenerator |
|
||||||
, stateSASLRValue :: Maybe String |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
-- Repeatedly reads internal events from the channel and processes them. This is |
|
||||||
-- the main loop of the XMPP session process. |
|
||||||
|
|
||||||
-- The main loop of the XMPP library runs in the following monads: |
|
||||||
-- |
|
||||||
-- m, m => MonadIO (from the client) |
|
||||||
-- StateT |
|
||||||
-- ErrorT |
|
||||||
|
|
||||||
-- TODO: Will >> carry the updated state? |
|
||||||
-- TODO: Should InternalState be in both places? |
|
||||||
|
|
||||||
stateLoop :: (MonadIO m, ClientState s m) => Chan (InternalEvent s m) -> |
|
||||||
StateT (State s m) m (Maybe CE.SomeException) |
|
||||||
|
|
||||||
stateLoop c = do |
|
||||||
event <- lift $ liftIO $ readChan c |
|
||||||
lift $ liftIO $ putStrLn $ "Processing event " ++ (show event) ++ "." |
|
||||||
result <- (processEvent event) |
|
||||||
state <- get |
|
||||||
case result of |
|
||||||
Nothing -> do |
|
||||||
case stateShouldExit state of |
|
||||||
True -> |
|
||||||
return $ Nothing |
|
||||||
False -> |
|
||||||
stateLoop c |
|
||||||
Just e -> |
|
||||||
return $ Just e |
|
||||||
|
|
||||||
|
|
||||||
-- Process an InternalEvent and performs the necessary IO and updates the state |
|
||||||
-- accordingly. |
|
||||||
|
|
||||||
processEvent :: (MonadIO m, ClientState s m) => (InternalEvent s m) -> |
|
||||||
(StateT (State s m) m) (Maybe CE.SomeException) |
|
||||||
|
|
||||||
processEvent e = get >>= \ state -> |
|
||||||
let handleOrTLSCtx = case stateTLSState state of |
|
||||||
PostHandshake tlsCtx -> |
|
||||||
Right tlsCtx |
|
||||||
_ -> |
|
||||||
let Connected _ handle = stateConnectionState state in Left handle |
|
||||||
in case e of |
|
||||||
|
|
||||||
-- --------------------------------------------------------------------------- |
|
||||||
-- CLIENT EVENTS |
|
||||||
-- --------------------------------------------------------------------------- |
|
||||||
-- |
|
||||||
IEC (CEOpenStream hostName portNumber callback) -> do |
|
||||||
|
|
||||||
-- CEB.assert (stateConnectionState state == Disconnected) (return ()) |
|
||||||
|
|
||||||
-- let portNumber' = fromIntegral portNumber |
|
||||||
|
|
||||||
-- connectResult <- liftIO $ CE.try $ N.connectTo hostName |
|
||||||
-- (N.PortNumber portNumber') |
|
||||||
|
|
||||||
-- case connectResult of |
|
||||||
-- Right handle -> do |
|
||||||
-- put $ state { stateConnectionState = Connected (ServerAddress hostName portNumber') handle |
|
||||||
-- , stateStreamState = PreStream |
|
||||||
-- , stateOpenStreamsCallback = Just callback } |
|
||||||
-- lift $ liftIO $ hSetBuffering handle NoBuffering |
|
||||||
-- lift $ liftIO $ send ("<?xml version='1.0'?><stream:stream to='" ++ hostName ++ |
|
||||||
-- "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.or" ++ |
|
||||||
-- "g/streams' version='1.0'>") (Left handle) |
|
||||||
-- threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Left handle) |
|
||||||
-- lift $ liftIO $ putMVar (stateThreadID state) threadID |
|
||||||
-- return Nothing |
|
||||||
Left e -> do |
|
||||||
let clientState = stateClientState state |
|
||||||
((), clientState') <- lift $ runStateT (callback OpenStreamFailure) clientState |
|
||||||
put $ state { stateShouldExit = True } |
|
||||||
return $ Just e |
|
||||||
|
|
||||||
IEC (CESecureWithTLS certificate verifyCertificate callback) -> do |
|
||||||
-- CEB.assert (not $ isTLSSecured (stateStreamState state)) (return ()) |
|
||||||
let Connected _ handle = stateConnectionState state |
|
||||||
lift $ liftIO $ send "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>" (Left handle) |
|
||||||
put $ state { stateStreamState = PreStream |
|
||||||
, stateTLSSecureStreamsCallback = Just callback } |
|
||||||
return Nothing |
|
||||||
|
|
||||||
-- TODO: Save callback in state. |
|
||||||
IEC (CEAuthenticate userName password resource callback) -> do |
|
||||||
-- CEB.assert (or [ stateConnectionState state == Connected |
|
||||||
-- , stateConnectionState state == TLSSecured ]) (return ()) |
|
||||||
-- CEB.assert (stateHandle state /= Nothing) (return ()) |
|
||||||
-- let Connected (ServerAddress hostName _) _ = stateConnectionState state |
|
||||||
rValue <- lift $ liftIO $ randomIO |
|
||||||
put $ state { stateAuthenticationState = AuthenticatingPreChallenge1 userName password resource |
|
||||||
, stateAuthenticateCallback = Just callback |
|
||||||
, stateSASLRValue = Just (toString rValue) } |
|
||||||
lift $ liftIO $ putStrLn $ "__________" ++ ("<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='SCRAM-SHA-1'>" ++ (CBBS.encode ("n,,n=" ++ userName ++ ",r=" ++ (toString rValue))) ++ "</auth>") |
|
||||||
lift $ liftIO $ send ("<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='SCRAM-SHA-1'>" ++ (CBBS.encode ("n,,n=" ++ userName ++ ",r=" ++ (toString rValue))) ++ "</auth>") handleOrTLSCtx |
|
||||||
return Nothing |
|
||||||
|
|
||||||
IEE (EnumeratorBeginStream from to id ver lang namespace) -> do |
|
||||||
put $ state { stateStreamState = PreFeatures (1.0) } |
|
||||||
return Nothing |
|
||||||
|
|
||||||
-- IEE (EnumeratorXML (XEFeatures features)) -> do |
|
||||||
-- let PreFeatures streamProperties = stateStreamState state |
|
||||||
-- case stateTLSState state of |
|
||||||
-- NoTLS -> let callback = fromJust $ stateOpenStreamsCallback state in do |
|
||||||
-- ((), clientState) <- lift $ runStateT (callback $ OpenStreamSuccess streamProperties "TODO") (stateClientState state) |
|
||||||
-- put $ state { stateClientState = clientState |
|
||||||
-- , stateStreamState = PostFeatures streamProperties "TODO" } |
|
||||||
-- return Nothing |
|
||||||
-- _ -> case stateAuthenticationState state of |
|
||||||
-- AuthenticatedUnbound _ resource -> do -- TODO: resource |
|
||||||
-- case resource of |
|
||||||
-- Nothing -> do |
|
||||||
-- lift $ liftIO $ send ("<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" ++ "s:xml:ns:xmpp-bind\"></bind></iq>") handleOrTLSCtx |
|
||||||
-- return () |
|
||||||
-- _ -> do |
|
||||||
-- lift $ liftIO $ send ("<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" ++ "s:xml:ns:xmpp-bind\"><resource>" ++ fromJust resource ++ "</resource></bind></iq>") handleOrTLSCtx |
|
||||||
-- return () |
|
||||||
-- id <- liftIO $ nextID $ stateIDGenerator state |
|
||||||
-- lift $ liftIO $ send ("<iq type=\"set\" id=\"" ++ id ++ "\"><session xmlns=\"urn:ietf:params:xml:ns:xmpp-session\"/>" ++ "</iq>") handleOrTLSCtx |
|
||||||
-- |
|
||||||
-- -- TODO: Execute callback on iq result |
|
||||||
-- |
|
||||||
-- let callback = fromJust $ stateAuthenticateCallback state in do -- TODO: streamProperties "TODO" after success |
|
||||||
-- ((), clientState) <- lift $ runStateT (callback $ AuthenticateSuccess streamProperties "TODO" "todo") (stateClientState state) -- get proper resource value when moving to iq result |
|
||||||
-- put $ state { stateClientState = clientState |
|
||||||
-- , stateStreamState = PostFeatures streamProperties "TODO" } |
|
||||||
-- state' <- get |
|
||||||
-- return Nothing |
|
||||||
-- _ -> do |
|
||||||
-- let callback = fromJust $ stateTLSSecureStreamsCallback state in do |
|
||||||
-- ((), clientState) <- lift $ runStateT (callback $ SecureWithTLSSuccess streamProperties "TODO") (stateClientState state) |
|
||||||
-- put $ state { stateClientState = clientState |
|
||||||
-- , stateStreamState = PostFeatures streamProperties "TODO" } |
|
||||||
-- return Nothing |
|
||||||
-- |
|
||||||
-- -- TODO: Can we assume that it's safe to start to enumerate on handle when it |
|
||||||
-- -- might not have exited? |
|
||||||
-- IEE (EnumeratorXML XEProceed) -> do |
|
||||||
-- let Connected (ServerAddress hostName _) handle = stateConnectionState state |
|
||||||
-- tlsCtx <- lift $ liftIO $ do |
|
||||||
-- gen <- newGenIO :: IO SystemRandom -- TODO: Investigate limitations |
|
||||||
-- clientContext <- client tlsParams gen handle |
|
||||||
-- handshake clientContext |
|
||||||
-- return clientContext |
|
||||||
-- put $ (defaultState (stateChannel state) (stateThreadID state) (stateClientHandlers state) (stateClientState state) (stateIDGenerator state)) { stateTLSState = PostHandshake tlsCtx, stateConnectionState = (stateConnectionState state), stateTLSSecureStreamsCallback = (stateTLSSecureStreamsCallback state) } |
|
||||||
-- threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Right tlsCtx) -- double code |
|
||||||
-- lift $ liftIO $ putStrLn "00000000000000000000000000000000" |
|
||||||
-- lift $ liftIO $ swapMVar (stateThreadID state) threadID -- return value not used |
|
||||||
-- lift $ liftIO $ putStrLn "00000000000000000000000000000000" |
|
||||||
-- lift $ liftIO $ threadDelay 1000000 |
|
||||||
-- lift $ liftIO $ putStrLn "00000000000000000000000000000000" |
|
||||||
-- lift $ liftIO $ send ("<?xml version='1.0'?><stream:stream to='" ++ |
|
||||||
-- hostName ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++ |
|
||||||
-- "streams' version='1.0'>") (Right tlsCtx) |
|
||||||
-- lift $ liftIO $ putStrLn "00000000000000000000000000000000" |
|
||||||
-- return Nothing |
|
||||||
-- |
|
||||||
-- IEE (EnumeratorXML (XEChallenge (Chal challenge))) -> do |
|
||||||
-- lift $ liftIO $ putStrLn challenge |
|
||||||
-- let Connected (ServerAddress hostName _) _ = stateConnectionState state |
|
||||||
-- let challenge' = CBBS.decode challenge |
|
||||||
-- case stateAuthenticationState state of |
|
||||||
-- AuthenticatingPreChallenge1 userName password resource -> do |
|
||||||
-- id <- liftIO $ nextID $ stateIDGenerator state |
|
||||||
-- -- TODO: replyToChallenge |
|
||||||
-- return () |
|
||||||
-- AuthenticatingPreChallenge2 userName password resource -> do |
|
||||||
-- -- This is not the first challenge; [...] |
|
||||||
-- -- TODO: Can we assume "rspauth"? |
|
||||||
-- lift $ liftIO $ send "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/>" handleOrTLSCtx |
|
||||||
-- put $ state { stateAuthenticationState = AuthenticatingPreSuccess userName password resource } |
|
||||||
-- return () |
|
||||||
-- return Nothing |
|
||||||
-- |
|
||||||
-- -- We have received a SASL "success" message over a secured connection |
|
||||||
-- -- TODO: Parse the success message? |
|
||||||
-- -- TODO: <?xml version='1.0'?>? |
|
||||||
-- IEE (EnumeratorXML (XESuccess (Succ _))) -> do |
|
||||||
-- let serverHost = "jonkristensen.com" |
|
||||||
-- let AuthenticatingPreSuccess userName _ resource = stateAuthenticationState state in do |
|
||||||
-- lift $ liftIO $ send ("<?xml version='1.0'?><stream:stream to='" ++ serverHost ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++ "streams' version='1.0'>") handleOrTLSCtx |
|
||||||
-- put $ state { stateAuthenticationState = AuthenticatedUnbound userName resource } |
|
||||||
-- return Nothing |
|
||||||
|
|
||||||
IEE EnumeratorDone -> |
|
||||||
-- TODO: Exit? |
|
||||||
return Nothing |
|
||||||
|
|
||||||
-- --------------------------------------------------------------------------- |
|
||||||
-- XML EVENTS |
|
||||||
-- --------------------------------------------------------------------------- |
|
||||||
|
|
||||||
-- -- Ignore id="bind_1" and session IQ result, otherwise create client event |
|
||||||
-- IEE (EnumeratorXML (XEIQ iqEvent)) -> |
|
||||||
-- case shouldIgnoreIQ iqEvent of |
|
||||||
-- True -> |
|
||||||
-- return Nothing |
|
||||||
-- False -> do |
|
||||||
-- let stanzaID' = iqID iqEvent |
|
||||||
-- let newTimeouts = case stanzaID' of |
|
||||||
-- Just stanzaID'' -> |
|
||||||
-- case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of |
|
||||||
-- True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state) |
|
||||||
-- False -> (stateTimeoutStanzaIDs state) |
|
||||||
-- Nothing -> (stateTimeoutStanzaIDs state) |
|
||||||
-- let iqReceivedFunctions = map (\ x -> iqReceived x) (stateClientHandlers state) |
|
||||||
-- let functions = map (\ x -> case x of |
|
||||||
-- Just f -> Just (f iqEvent) |
|
||||||
-- Nothing -> Nothing) iqReceivedFunctions |
|
||||||
-- let functions' = case lookup (fromJust $ iqID $ iqEvent) (stateIQCallbacks state) of |
|
||||||
-- Just f -> (Just (f $ iqEvent)):functions |
|
||||||
-- Nothing -> functions |
|
||||||
-- let clientState = stateClientState state |
|
||||||
-- clientState' <- sendToClient functions' clientState |
|
||||||
-- put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts } |
|
||||||
-- return Nothing |
|
||||||
-- |
|
||||||
-- -- TODO: Known bug - does not work with PresenceError |
|
||||||
-- |
|
||||||
-- IEE (EnumeratorXML (XEPresence (Right presenceEvent))) -> do |
|
||||||
-- let stanzaID' = presenceID $ presenceEvent |
|
||||||
-- let newTimeouts = case stanzaID' of |
|
||||||
-- Just stanzaID'' -> |
|
||||||
-- case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of |
|
||||||
-- True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state) |
|
||||||
-- False -> (stateTimeoutStanzaIDs state) |
|
||||||
-- Nothing -> (stateTimeoutStanzaIDs state) |
|
||||||
-- let presenceReceivedFunctions = map (\ x -> presenceReceived x) (stateClientHandlers state) |
|
||||||
-- let functions = map (\ x -> case x of |
|
||||||
-- Just f -> Just (f presenceEvent) |
|
||||||
-- Nothing -> Nothing) presenceReceivedFunctions |
|
||||||
-- let clientState = stateClientState state -- ClientState s m |
|
||||||
-- clientState' <- sendToClient functions clientState |
|
||||||
-- put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts } |
|
||||||
-- return Nothing |
|
||||||
-- |
|
||||||
-- -- TODO: Does not work with message errors |
|
||||||
-- IEE (EnumeratorXML (XEMessage (Right messageEvent))) -> do |
|
||||||
-- let stanzaID' = messageID $ messageEvent |
|
||||||
-- let newTimeouts = case stanzaID' of |
|
||||||
-- Just stanzaID'' -> |
|
||||||
-- case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of |
|
||||||
-- True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state) |
|
||||||
-- False -> (stateTimeoutStanzaIDs state) |
|
||||||
-- Nothing -> (stateTimeoutStanzaIDs state) |
|
||||||
-- let messageReceivedFunctions = map (\ x -> messageReceived x) (stateClientHandlers state) |
|
||||||
-- let functions = map (\ x -> case x of |
|
||||||
-- Just f -> Just (f messageEvent) |
|
||||||
-- Nothing -> Nothing) messageReceivedFunctions |
|
||||||
-- let clientState = stateClientState state -- ClientState s m |
|
||||||
-- clientState' <- sendToClient functions clientState |
|
||||||
-- put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts } |
|
||||||
-- return Nothing |
|
||||||
|
|
||||||
IEC (CEPresence presence stanzaCallback timeoutCallback streamErrorCallback) -> do |
|
||||||
presence' <- case presenceID $ presence of |
|
||||||
Nothing -> do |
|
||||||
id <- liftIO $ nextID $ stateIDGenerator state |
|
||||||
return $ presence { presenceID = Just (SID id) } |
|
||||||
_ -> return presence |
|
||||||
case timeoutCallback of |
|
||||||
Just (t, timeoutCallback') -> |
|
||||||
let stanzaID' = (fromJust $ presenceID $ presence') in do |
|
||||||
registerTimeout (stateChannel state) stanzaID' t timeoutCallback' |
|
||||||
put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) } |
|
||||||
Nothing -> |
|
||||||
return () |
|
||||||
let xml = presenceToXML (Right presence') (fromJust $ langTag "en") |
|
||||||
lift $ liftIO $ send (elementToString $ Just xml) handleOrTLSCtx |
|
||||||
return Nothing |
|
||||||
|
|
||||||
IEC (CEMessage message stanzaCallback timeoutCallback streamErrorCallback) -> do |
|
||||||
message' <- case messageID message of |
|
||||||
Nothing -> do |
|
||||||
id <- liftIO $ nextID $ stateIDGenerator state |
|
||||||
return $ message { messageID = Just (SID id) } |
|
||||||
_ -> return message |
|
||||||
case timeoutCallback of |
|
||||||
Just (t, timeoutCallback') -> |
|
||||||
let stanzaID' = (fromJust $ messageID message') in do |
|
||||||
registerTimeout (stateChannel state) stanzaID' t timeoutCallback' |
|
||||||
put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) } |
|
||||||
Nothing -> |
|
||||||
return () |
|
||||||
let xml = messageToXML (Right message') (fromJust $ langTag "en") |
|
||||||
lift $ liftIO $ send (elementToString $ Just xml) handleOrTLSCtx |
|
||||||
return Nothing |
|
||||||
|
|
||||||
-- TODO: Known bugs until Session rewritten - new ID everytime, callback not called |
|
||||||
|
|
||||||
IEC (CEIQ iq stanzaCallback timeoutCallback stanzaErrorCallback) -> do |
|
||||||
iq' <- do -- case iqID iq of |
|
||||||
-- Nothing -> do |
|
||||||
id <- liftIO $ nextID $ stateIDGenerator state |
|
||||||
return iq |
|
||||||
let callback' = fromJust stanzaCallback |
|
||||||
put $ state { stateIQCallbacks = (fromJust $ iqID iq, callback'):(stateIQCallbacks state) } |
|
||||||
case timeoutCallback of |
|
||||||
Just (t, timeoutCallback') -> |
|
||||||
let stanzaID' = (fromJust $ iqID iq') in do |
|
||||||
registerTimeout (stateChannel state) stanzaID' t timeoutCallback' |
|
||||||
put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) } |
|
||||||
Nothing -> |
|
||||||
return () |
|
||||||
-- TODO: Bind ID to callback |
|
||||||
let xml = iqToXML iq' (fromJust $ langTag "en") |
|
||||||
lift $ liftIO $ send (elementToString $ Just xml) handleOrTLSCtx |
|
||||||
return Nothing |
|
||||||
|
|
||||||
IEC (CEAction predicate callback) -> do |
|
||||||
case predicate of |
|
||||||
Just predicate' -> do |
|
||||||
result <- runBoolClientCallback predicate' |
|
||||||
case result of |
|
||||||
True -> do |
|
||||||
runUnitClientCallback callback |
|
||||||
return Nothing |
|
||||||
False -> return Nothing |
|
||||||
Nothing -> do |
|
||||||
runUnitClientCallback callback |
|
||||||
return Nothing |
|
||||||
|
|
||||||
-- XOEDisconnect -> do |
|
||||||
-- -- TODO: Close stream |
|
||||||
-- return () |
|
||||||
|
|
||||||
IET (TimeoutEvent i t c) -> |
|
||||||
case i `elem` (stateTimeoutStanzaIDs state) of |
|
||||||
True -> do |
|
||||||
runUnitClientCallback c |
|
||||||
return Nothing |
|
||||||
False -> return Nothing |
|
||||||
|
|
||||||
|
|
||||||
e -> do |
|
||||||
return Nothing |
|
||||||
-- lift $ liftIO $ putStrLn $ "UNCAUGHT EVENT: " ++ (show e) |
|
||||||
-- return $ Just (CE.SomeException $ CE.PatternMatchFail "processEvent") |
|
||||||
where |
|
||||||
-- Assumes handle is set |
|
||||||
send :: String -> Either Handle TLSCtx -> IO () |
|
||||||
send s o = case o of |
|
||||||
Left handle -> do |
|
||||||
-- liftIO $ hPutStr handle $ encodeString $ s |
|
||||||
-- liftIO $ hFlush handle |
|
||||||
return () |
|
||||||
Right tlsCtx -> do |
|
||||||
liftIO $ sendData tlsCtx $ DBLC.pack $ encodeString s |
|
||||||
return () |
|
||||||
shouldIgnoreIQ :: IQ -> Bool |
|
||||||
shouldIgnoreIQ i = case iqPayload i of |
|
||||||
Nothing -> False |
|
||||||
Just e -> case nameNamespace $ elementName e of |
|
||||||
Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-bind" -> True |
|
||||||
Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-session" -> True |
|
||||||
Just _ -> False |
|
||||||
Nothing -> False |
|
||||||
|
|
||||||
|
|
||||||
registerTimeout :: (ClientState s m, MonadIO m) => Chan (InternalEvent s m) -> StanzaID -> Timeout -> StateT s m () -> StateT (State s m) m () |
|
||||||
registerTimeout ch i t ca = do |
|
||||||
liftIO $ threadDelay $ t * 1000 |
|
||||||
liftIO $ forkIO $ writeChan ch $ IET (TimeoutEvent i t ca) |
|
||||||
return () |
|
||||||
|
|
||||||
|
|
||||||
runBoolClientCallback :: (ClientState s m, MonadIO m) => StateT s m Bool -> StateT (State s m) m Bool |
|
||||||
runBoolClientCallback c = do |
|
||||||
state <- get |
|
||||||
let clientState = stateClientState state |
|
||||||
(bool, clientState') <- lift $ runStateT c clientState |
|
||||||
put $ state { stateClientState = clientState' } |
|
||||||
return bool |
|
||||||
|
|
||||||
|
|
||||||
runUnitClientCallback :: (ClientState s m, MonadIO m) => StateT s m () -> StateT (State s m) m () |
|
||||||
runUnitClientCallback c = do |
|
||||||
state <- get |
|
||||||
let clientState = stateClientState state |
|
||||||
((), clientState') <- lift $ runStateT c clientState |
|
||||||
put $ state { stateClientState = clientState' } |
|
||||||
|
|
||||||
|
|
||||||
sendToClient :: (MonadIO m, ClientState s m) => [Maybe (StateT s m Bool)] -> s -> (StateT (State s m) m) s |
|
||||||
sendToClient [] s = return s |
|
||||||
sendToClient (Nothing:fs) s = sendToClient fs s |
|
||||||
sendToClient ((Just f):fs) s = do |
|
||||||
(b, s') <- lift $ runStateT f s |
|
||||||
case b of |
|
||||||
True -> return s' |
|
||||||
False -> sendToClient fs s' |
|
||||||
@ -1,143 +0,0 @@ |
|||||||
-- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the |
|
||||||
-- Pontarius distribution for more details. |
|
||||||
|
|
||||||
{-# OPTIONS_HADDOCK hide #-} |
|
||||||
|
|
||||||
-- The stanza record types are generally pretty convenient to work with. |
|
||||||
-- However, due to the fact that an "IQ" can be both an "IQRequest" and an |
|
||||||
-- "IQResponse" we provide some helper functions in this module that work on |
|
||||||
-- both types. |
|
||||||
-- |
|
||||||
-- We also provide functions to create a new stanza ID generator, and to |
|
||||||
-- generate new IDs. |
|
||||||
|
|
||||||
module Network.XMPP.Stanza ( |
|
||||||
iqID, |
|
||||||
iqFrom, |
|
||||||
iqTo, |
|
||||||
iqLangTag, |
|
||||||
iqPayload, |
|
||||||
iqPayloadNamespace, |
|
||||||
iqRequestPayloadNamespace, |
|
||||||
iqResponsePayloadNamespace |
|
||||||
) where |
|
||||||
|
|
||||||
import Network.XMPP.Address |
|
||||||
import Network.XMPP.Types |
|
||||||
|
|
||||||
import Data.XML.Types (Element, elementName, nameNamespace) |
|
||||||
import Data.Text (unpack) |
|
||||||
|
|
||||||
|
|
||||||
-- | |
|
||||||
-- Returns the @StanzaID@ value of the @IQ@, if any. |
|
||||||
|
|
||||||
iqID :: IQ -> Maybe StanzaID |
|
||||||
|
|
||||||
iqID (Left req) = iqRequestID req |
|
||||||
iqID (Right res) = iqResponseID res |
|
||||||
|
|
||||||
|
|
||||||
-- TODO: Maybe? |
|
||||||
|
|
||||||
iqResponseID :: IQResponse -> Maybe StanzaID |
|
||||||
|
|
||||||
iqResponseID (Left err) = iqErrorID err |
|
||||||
iqResponseID (Right res) = iqResultID res |
|
||||||
|
|
||||||
|
|
||||||
-- | |
|
||||||
-- Returns the @From@ @JID@ value of the @IQ@, if any. |
|
||||||
|
|
||||||
iqFrom :: IQ -> Maybe From |
|
||||||
|
|
||||||
iqFrom (Left req) = iqRequestFrom req |
|
||||||
iqFrom (Right res) = iqResponseFrom res |
|
||||||
|
|
||||||
|
|
||||||
-- | |
|
||||||
-- Returns the @To@ @JID@ value of the @IQ@, if any. |
|
||||||
|
|
||||||
iqTo :: IQ -> Maybe To |
|
||||||
|
|
||||||
iqTo (Left req) = iqRequestTo req |
|
||||||
iqTo (Right res) = iqResponseTo res |
|
||||||
|
|
||||||
|
|
||||||
-- | |
|
||||||
-- Returns the @XMLLang@ value of the @IQ@, if any. |
|
||||||
|
|
||||||
iqLangTag :: IQ -> LangTag |
|
||||||
|
|
||||||
iqLangTag (Left req) = iqRequestLangTag req |
|
||||||
iqLangTag (Right res) = iqResponseLangTag res |
|
||||||
|
|
||||||
|
|
||||||
iqResponseLangTag :: IQResponse -> LangTag |
|
||||||
|
|
||||||
iqResponseLangTag (Left err) = iqErrorLangTag err |
|
||||||
iqResponseLangTag (Right res) = iqResultLangTag res |
|
||||||
|
|
||||||
|
|
||||||
iqResponseFrom :: IQResponse -> Maybe From |
|
||||||
|
|
||||||
iqResponseFrom (Left err) = iqErrorFrom err |
|
||||||
iqResponseFrom (Right res) = iqResultFrom res |
|
||||||
|
|
||||||
|
|
||||||
iqResponseTo :: IQResponse -> Maybe To |
|
||||||
|
|
||||||
iqResponseTo (Left err) = iqErrorTo err |
|
||||||
iqResponseTo (Right res) = iqResultTo res |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- | |
|
||||||
-- Returns the @Element@ payload value of the @IQ@, if any. If the IQ in |
|
||||||
-- question is of the "request" type, use @iqRequestPayload@ instead. |
|
||||||
|
|
||||||
iqPayload :: IQ -> Maybe Element |
|
||||||
|
|
||||||
iqPayload (Left req) = Just (iqRequestPayload req) |
|
||||||
iqPayload (Right res) = iqResponsePayload res |
|
||||||
|
|
||||||
|
|
||||||
iqResponsePayload :: IQResponse -> Maybe Element |
|
||||||
|
|
||||||
iqResponsePayload (Left err) = iqErrorPayload err |
|
||||||
iqResponsePayload (Right res) = iqResultPayload res |
|
||||||
|
|
||||||
|
|
||||||
-- | |
|
||||||
-- Returns the namespace of the element of the @IQ@, if any. |
|
||||||
|
|
||||||
iqPayloadNamespace :: IQ -> Maybe String |
|
||||||
|
|
||||||
iqPayloadNamespace i = case iqPayload i of |
|
||||||
Nothing -> Nothing |
|
||||||
Just p -> case nameNamespace $ elementName p of |
|
||||||
Nothing -> Nothing |
|
||||||
Just n -> Just (unpack n) |
|
||||||
|
|
||||||
|
|
||||||
-- | |
|
||||||
-- Returns the namespace of the element of the @IQRequest@, if any. |
|
||||||
|
|
||||||
iqRequestPayloadNamespace :: IQRequest -> Maybe String |
|
||||||
|
|
||||||
iqRequestPayloadNamespace i = let p = iqRequestPayload i in |
|
||||||
case nameNamespace $ elementName p of |
|
||||||
Nothing -> Nothing |
|
||||||
Just n -> Just (unpack n) |
|
||||||
|
|
||||||
|
|
||||||
-- | |
|
||||||
-- Returns the namespace of the element of the @IQRequest@, if any. |
|
||||||
|
|
||||||
iqResponsePayloadNamespace :: IQResponse -> Maybe String |
|
||||||
|
|
||||||
iqResponsePayloadNamespace i = case iqResponsePayload i of |
|
||||||
Nothing -> Nothing |
|
||||||
Just p -> case nameNamespace $ elementName p of |
|
||||||
Nothing -> Nothing |
|
||||||
Just n -> Just (unpack n) |
|
||||||
Loading…
Reference in new issue