diff --git a/src/Network/XMPP/Concurrent/IQ.hs b/src/Network/XMPP/Concurrent/IQ.hs index ba5bd72..e8a3cab 100644 --- a/src/Network/XMPP/Concurrent/IQ.hs +++ b/src/Network/XMPP/Concurrent/IQ.hs @@ -12,13 +12,14 @@ import Network.XMPP.Concurrent.Monad import Network.XMPP.Types -- | Sends an IQ, returns a 'TMVar' that will be filled with the first inbound --- IQ with a matching ID that has type @result@ or @error@ +-- IQ with a matching ID that has type @result@ or @error@. sendIQ :: Maybe JID -- ^ Recipient (to) - -> IQRequestType -- ^ IQ type (Get or Set) - -> Maybe LangTag -- ^ Language tag of the payload (Nothing for default) - -> Element -- ^ The iq body (there has to be exactly one) - -> XMPP (TMVar IQResponse) -sendIQ to tp lang body = do -- TODO: add timeout + -> IQRequestType -- ^ IQ type (@Get@ or @Set@) + -> Maybe LangTag -- ^ Language tag of the payload (@Nothing@ for + -- default) + -> Element -- ^ The IQ body (there has to be exactly one) + -> XMPP (TMVar IQResponse) +sendIQ to tp lang body = do -- TODO: Add timeout newId <- liftIO =<< asks idGenerator handlers <- asks iqHandlers ref <- liftIO . atomically $ do @@ -30,15 +31,15 @@ sendIQ to tp lang body = do -- TODO: add timeout sendStanza . IQRequestS $ IQRequest newId Nothing to lang tp body return ref --- | like 'sendIQ', but waits for the answer IQ +-- | Like 'sendIQ', but waits for the answer IQ. sendIQ' :: Maybe JID -> IQRequestType -> Maybe LangTag -> Element -> XMPP IQResponse sendIQ' to tp lang body = do - ref <- sendIQ to tp lang body - liftIO . atomically $ takeTMVar ref + ref <- sendIQ to tp lang body + liftIO . atomically $ takeTMVar ref answerIQ :: IQRequestTicket -> Either StanzaError (Maybe Element) diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index 4a5f51d..9113de0 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -17,217 +17,238 @@ import Network.XMPP.Concurrent.Types import Network.XMPP.Monad --- | Register a new IQ listener. IQ requests matching the type and namespace will --- be put in the channel. +-- | Register a new IQ listener. IQ requests matching the type and namespace +-- will be put in the channel. -- -- Return the new channel or Nothing if this namespace/'IQRequestType' --- combination was alread handled -listenIQChan :: IQRequestType -- ^ type of IQs to receive (Get / Set) - -> Text -- ^ namespace of the child element - -> XMPP (Maybe ( TChan IQRequestTicket)) +-- combination was alread handled. +listenIQChan :: IQRequestType -- ^ Type of IQs to receive (@Get@ or @Set@) + -> Text -- ^ Namespace of the child element + -> XMPP (Maybe (TChan IQRequestTicket)) listenIQChan tp ns = do - handlers <- asks iqHandlers - liftIO . atomically $ do - (byNS, byID) <- readTVar handlers - iqCh <- newTChan - let (present, byNS') = Map.insertLookupWithKey' (\_ _ old -> old) - (tp,ns) iqCh byNS - writeTVar handlers (byNS', byID) - return $ case present of - Nothing -> Just iqCh - Just _iqCh' -> Nothing - --- | get the inbound message channel, duplicates from master if necessary --- please note that once duplicated it will keep filling up, call --- 'dropMessageChan' to allow it to be garbage collected -getMessageChan :: XMPP (TChan (Either MessageError Message)) -getMessageChan = do - mChR <- asks messagesRef - mCh <- liftIO $ readIORef mChR - case mCh of - Nothing -> do - shadow <- asks mShadow - mCh' <- liftIO $ atomically $ dupTChan shadow - liftIO $ writeIORef mChR (Just mCh') - return mCh' - Just mCh' -> return mCh' + handlers <- asks iqHandlers + liftIO . atomically $ do + (byNS, byID) <- readTVar handlers + iqCh <- newTChan + let (present, byNS') = Map.insertLookupWithKey' + (\_ _ old -> old) + (tp, ns) + iqCh + byNS + writeTVar handlers (byNS', byID) + return $ case present of + Nothing -> Just iqCh + Just _iqCh' -> Nothing -- | Get a duplicate of the stanza channel getStanzaChan :: XMPP (TChan Stanza) getStanzaChan = do - shadow <- asks sShadow - liftIO $ atomically $ dupTChan shadow + shadow <- asks sShadow + liftIO $ atomically $ dupTChan shadow --- | see 'getMessageChan' +-- | Get the inbound stanza channel, duplicates from master if necessary. Please +-- note that once duplicated it will keep filling up, call 'dropMessageChan' to +-- allow it to be garbage collected. +getMessageChan :: XMPP (TChan (Either MessageError Message)) +getMessageChan = do + mChR <- asks messagesRef + mCh <- liftIO $ readIORef mChR + case mCh of + Nothing -> do + shadow <- asks mShadow + mCh' <- liftIO $ atomically $ dupTChan shadow + liftIO $ writeIORef mChR (Just mCh') + return mCh' + Just mCh' -> return mCh' + +-- | Analogous to 'getMessageChan'. getPresenceChan :: XMPP (TChan (Either PresenceError Presence)) getPresenceChan = do - pChR <- asks presenceRef - pCh <- liftIO $ readIORef pChR - case pCh of - Nothing -> do - shadow <- asks pShadow - pCh' <- liftIO $ atomically $ dupTChan shadow - liftIO $ writeIORef pChR (Just pCh') - return pCh' - Just pCh' -> return pCh' - --- | Drop the local end of the inbound stanza channel --- from our context so it can be GC-ed + pChR <- asks presenceRef + pCh <- liftIO $ readIORef pChR + case pCh of + Nothing -> do + shadow <- asks pShadow + pCh' <- liftIO $ atomically $ dupTChan shadow + liftIO $ writeIORef pChR (Just pCh') + return pCh' + Just pCh' -> return pCh' + +-- | Drop the local end of the inbound stanza channel from our context so it can +-- be GC-ed. dropMessageChan :: XMPP () dropMessageChan = do - r <- asks messagesRef - liftIO $ writeIORef r Nothing + r <- asks messagesRef + liftIO $ writeIORef r Nothing --- | see 'dropMessageChan' +-- | Analogous to 'dropMessageChan'. dropPresenceChan :: XMPP () dropPresenceChan = do - r <- asks presenceRef - liftIO $ writeIORef r Nothing + r <- asks presenceRef + liftIO $ writeIORef r Nothing --- | Read an element from the inbound stanza channel, acquiring a copy --- of the channel as necessary +-- | Read an element from the inbound stanza channel, acquiring a copy of the +-- channel as necessary. pullMessage :: XMPP (Either MessageError Message) pullMessage = do - c <- getMessageChan - liftIO $ atomically $ readTChan c + c <- getMessageChan + liftIO $ atomically $ readTChan c --- | Read an element from the inbound stanza channel, acquiring a copy --- of the channel as necessary +-- | Read an element from the inbound stanza channel, acquiring a copy of the +-- channel as necessary. pullPresence :: XMPP (Either PresenceError Presence) pullPresence = do - c <- getPresenceChan - liftIO $ atomically $ readTChan c + c <- getPresenceChan + liftIO $ atomically $ readTChan c --- | Send a stanza to the server +-- | Send a stanza to the server. sendStanza :: Stanza -> XMPP () sendStanza a = do - out <- asks outCh - liftIO . atomically $ writeTChan out a - return () + out <- asks outCh + liftIO . atomically $ writeTChan out a + return () --- | Create a forked session object without forking a thread +-- | Create a forked session object without forking a thread. forkSession :: Session -> IO Session forkSession sess = do mCH' <- newIORef Nothing pCH' <- newIORef Nothing - return $ sess {messagesRef = mCH' ,presenceRef = pCH'} + return $ sess {messagesRef = mCH', presenceRef = pCH'} --- | Fork a new thread +-- | Fork a new thread. fork :: XMPP () -> XMPP ThreadId fork a = do - sess <- ask - sess' <- liftIO $ forkSession sess - liftIO $ forkIO $ runReaderT a sess' + sess <- ask + sess' <- liftIO $ forkSession sess + liftIO $ forkIO $ runReaderT a sess' +-- | Pulls a message and returns it if the given predicate returns @True@. filterMessages :: (MessageError -> Bool) -> (Message -> Bool) -> XMPP (Either MessageError Message) filterMessages f g = do - s <- pullMessage - case s of - Left e | f e -> return $ Left e - | otherwise -> filterMessages f g - Right m | g m -> return $ Right m - | otherwise -> filterMessages f g - + s <- pullMessage + case s of + Left e | f e -> return $ Left e + | otherwise -> filterMessages f g + Right m | g m -> return $ Right m + | otherwise -> filterMessages f g + +-- | Pulls a (non-error) message and returns it if the given predicate returns +-- @True@. waitForMessage :: (Message -> Bool) -> XMPP Message waitForMessage f = do - s <- pullMessage - case s of - Left _ -> waitForMessage f - Right m | f m -> return m - | otherwise -> waitForMessage f + s <- pullMessage + case s of + Left _ -> waitForMessage f + Right m | f m -> return m + | otherwise -> waitForMessage f +-- | Pulls an error message and returns it if the given predicate returns @True@. waitForMessageError :: (MessageError -> Bool) -> XMPP MessageError waitForMessageError f = do - s <- pullMessage - case s of - Right _ -> waitForMessageError f - Left m | f m -> return m - | otherwise -> waitForMessageError f - + s <- pullMessage + case s of + Right _ -> waitForMessageError f + Left m | f m -> return m + | otherwise -> waitForMessageError f + +-- | Pulls a (non-error) presence and returns it if the given predicate returns +-- @True@. waitForPresence :: (Presence -> Bool) -> XMPP Presence waitForPresence f = do - s <- pullPresence - case s of - Left _ -> waitForPresence f - Right m | f m -> return m - | otherwise -> waitForPresence f - --- | Run an XMPPMonad action in isolation. --- Reader and writer workers will be temporarily stopped --- and resumed with the new session details once the action returns. --- The Action will run in the calling thread/ --- Any uncaught exceptions will be interpreted as connection failure + s <- pullPresence + case s of + Left _ -> waitForPresence f + Right m | f m -> return m + | otherwise -> waitForPresence f + +-- TODO: Wait for presence error? + +-- | Run an XMPPMonad action in isolation. Reader and writer workers will be +-- temporarily stopped and resumed with the new session details once the action +-- returns. The action will run in the calling thread. Any uncaught exceptions +-- will be interpreted as connection failure. withConnection :: XMPPConMonad a -> XMPP (Either StreamError a) withConnection a = do - readerId <- asks readerThread - stateRef <- asks conStateRef - write <- asks writeRef - wait <- liftIO $ newEmptyTMVarIO - liftIO . Ex.mask_ $ do - throwTo readerId $ Interrupt wait - s <- Ex.catch ( atomically $ do - _ <- takeTMVar write - s <- takeTMVar stateRef - putTMVar wait () - return s - ) - (\e -> atomically (putTMVar wait ()) - >> Ex.throwIO (e :: Ex.SomeException) - -- No MVar taken - ) - Ex.catches ( do - (res, s') <- runStateT a s - atomically $ do - putTMVar write (sConPushBS s') - putTMVar stateRef s' - return $ Right res - ) - -- we treat all Exceptions as fatal - [ Ex.Handler $ \e -> return $ Left (e :: StreamError) - , Ex.Handler $ \e -> runStateT xmppKillConnection s - >> Ex.throwIO (e :: Ex.SomeException) - ] - --- | Send a presence Stanza + readerId <- asks readerThread + stateRef <- asks conStateRef + write <- asks writeRef + wait <- liftIO $ newEmptyTMVarIO + liftIO . Ex.mask_ $ do + -- Suspends the reader until the lock (wait) is released (set to `()'). + throwTo readerId $ Interrupt wait + -- We acquire the write and stateRef locks, to make sure that this is + -- the only thread that can write to the stream and to perform a + -- withConnection calculation. Afterwards, we release the lock and + -- fetches an updated state. + s <- Ex.catch + (atomically $ do + _ <- takeTMVar write + s <- takeTMVar stateRef + putTMVar wait () + return s + ) + -- If we catch an exception, we have failed to take the MVars above. + (\e -> atomically (putTMVar wait ()) >> + Ex.throwIO (e :: Ex.SomeException) + ) + -- Run the XMPPMonad action, save the (possibly updated) states, release + -- the locks, and return the result. + Ex.catches + (do + (res, s') <- runStateT a s + atomically $ do + putTMVar write (sConPushBS s') + putTMVar stateRef s' + return $ Right res + ) + -- We treat all Exceptions as fatal. If we catch a StreamError, we + -- return it. Otherwise, we throw an exception. + [ Ex.Handler $ \e -> return $ Left (e :: StreamError) + , Ex.Handler $ \e -> runStateT xmppKillConnection s + >> Ex.throwIO (e :: Ex.SomeException) + ] + +-- | Send a presence stanza. sendPresence :: Presence -> XMPP () sendPresence = sendStanza . PresenceS --- | Send a Message Stanza +-- | Send a message stanza. sendMessage :: Message -> XMPP () sendMessage = sendStanza . MessageS - +-- | Executes a function to update the event handlers. modifyHandlers :: (EventHandlers -> EventHandlers) -> XMPP () modifyHandlers f = do eh <- asks eventHandlers liftIO . atomically $ writeTVar eh . f =<< readTVar eh +-- | Sets the handler to be executed when the session ends. setSessionEndHandler :: XMPP () -> XMPP () setSessionEndHandler eh = do r <- ask modifyHandlers (\s -> s{sessionEndHandler = runReaderT eh r}) +-- | Sets the handler to be executed when the server connection is closed. setConnectionClosedHandler :: (StreamError -> XMPP ()) -> XMPP () setConnectionClosedHandler eh = do r <- ask modifyHandlers (\s -> s{connectionClosedHandler = \e -> runReaderT (eh e) r}) --- | run an event handler +-- | Run an event handler. runHandler :: (EventHandlers -> IO a) -> XMPP a runHandler h = do eh <- liftIO . atomically . readTVar =<< asks eventHandlers liftIO $ h eh --- | End the current xmpp session +-- | End the current XMPP session. endSession :: XMPP () endSession = do -- TODO: This has to be idempotent (is it?) void $ withConnection xmppKillConnection liftIO =<< asks stopThreads runHandler sessionEndHandler --- | Close the connection to the server +-- | Close the connection to the server. closeConnection :: XMPP () closeConnection = void $ withConnection xmppKillConnection - diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index 43717ae..102849a 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -29,6 +29,8 @@ import Text.XML.Stream.Elements import GHC.IO (unsafeUnmask) +-- Worker to read stanzas from the stream and concurrently distribute them to +-- all listener threads. readWorker :: TChan (Either MessageError Message) -> TChan (Either PresenceError Presence) -> TChan Stanza @@ -84,24 +86,30 @@ readWorker messageC presenceC stanzaC iqHands handlers stateRef = IQRequestS i -> handleIQRequest iqHands i IQResultS i -> handleIQResponse iqHands (Right i) IQErrorS i -> handleIQResponse iqHands (Left i) + where - -- Defining an Control.Exception.allowInterrupt equivalent for - -- GHC 7 compatibility. + -- Defining an Control.Exception.allowInterrupt equivalent for GHC 7 + -- compatibility. allowInterrupt :: IO () allowInterrupt = unsafeUnmask $ return () + -- Call the connection closed handlers. noCon :: TVar EventHandlers -> StreamError -> IO (Maybe a) noCon h e = do hands <- atomically $ readTVar h _ <- forkIO $ connectionClosedHandler hands e return Nothing - -- While waiting for the first semaphore(s) to flip we might receive - -- another interrupt. When that happens we add it's semaphore to the - -- list and retry waiting + -- While waiting for the first semaphore(s) to flip we might receive another + -- interrupt. When that happens we add it's semaphore to the list and retry + -- waiting. We do this because we might receive another interrupt while + -- recovering from the last one. We do this because we might receive another + -- interrupt while we're waiting for a mutex to unlock; if that happens, the + -- new interrupt is added to the list and is waited for as well. handleInterrupts :: [TMVar ()] -> IO [()] handleInterrupts ts = Ex.catch (atomically $ forM ts takeTMVar) - ( \(Interrupt t) -> handleInterrupts (t:ts)) + (\(Interrupt t) -> handleInterrupts (t:ts)) +-- If the IQ request has a namespace, sent it through the appropriate channel. handleIQRequest :: TVar IQHandlers -> IQRequest -> STM () handleIQRequest handlers iq = do (byNS, _) <- readTVar handlers @@ -111,67 +119,79 @@ handleIQRequest handlers iq = do Just ch -> do sent <- newTVar False writeTChan ch $ IQRequestTicket sent iq + handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> STM () handleIQResponse handlers iq = do - (byNS, byID) <- readTVar handlers - case Map.updateLookupWithKey (\_ _ -> Nothing) (iqID iq) byID of - (Nothing, _) -> return () -- we are not supposed - -- to send an error - (Just tmvar, byID') -> do - _ <- tryPutTMVar tmvar iq -- don't block - writeTVar handlers (byNS, byID') - where - iqID (Left err) = iqErrorID err - iqID (Right iq') = iqResultID iq' + (byNS, byID) <- readTVar handlers + case Map.updateLookupWithKey (\_ _ -> Nothing) (iqID iq) byID of + (Nothing, _) -> return () -- We are not supposed to send an error. + (Just tmvar, byID') -> do + _ <- tryPutTMVar tmvar iq -- Don't block. + writeTVar handlers (byNS, byID') + where + iqID (Left err) = iqErrorID err + iqID (Right iq') = iqResultID iq' +-- Worker to write stanzas to the stream concurrently. writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO Bool) -> IO () writeWorker stCh writeR = forever $ do - (write, next) <- atomically $ (,) <$> - takeTMVar writeR <*> - readTChan stCh - r <- write $ renderElement (pickleElem xpStanza next) - unless r $ do - atomically $ unGetTChan stCh next -- connection is dead - threadDelay 250000 -- avoid free spinning - atomically $ putTMVar writeR write - --- Two streams: input and output. Threads read from input stream and write to output stream. --- | Runs thread in XmppState monad --- returns channel of incoming and outgoing stances, respectively --- and an Action to stop the Threads and close the connection -startThreads - :: IO ( TChan (Either MessageError Message) - , TChan (Either PresenceError Presence) - , TChan Stanza - , TVar IQHandlers - , TChan Stanza - , IO () - , TMVar (BS.ByteString -> IO Bool) - , TMVar XmppConnection - , ThreadId - , TVar EventHandlers - ) - + (write, next) <- atomically $ (,) <$> + takeTMVar writeR <*> + readTChan stCh + r <- write $ renderElement (pickleElem xpStanza next) + unless r $ do -- If the writing failed, the connection is dead. + atomically $ unGetTChan stCh next + threadDelay 250000 -- Avoid free spinning. + atomically $ putTMVar writeR write -- Put it back. + +-- Two streams: input and output. Threads read from input stream and write to +-- output stream. +-- | Runs thread in XmppState monad. Returns channel of incoming and outgoing +-- stances, respectively, and an Action to stop the Threads and close the +-- connection. +startThreads :: IO ( TChan (Either MessageError Message) + , TChan (Either PresenceError Presence) + , TChan Stanza + , TVar IQHandlers + , TChan Stanza + , IO () + , TMVar (BS.ByteString -> IO Bool) + , TMVar XmppConnection + , ThreadId + , TVar EventHandlers + ) startThreads = do - writeLock <- newTMVarIO (\_ -> return False) - messageC <- newTChanIO - presenceC <- newTChanIO - outC <- newTChanIO - stanzaC <- newTChanIO - handlers <- newTVarIO ( Map.empty, Map.empty) - eh <- newTVarIO zeroEventHandlers - conS <- newTMVarIO xmppNoConnection - lw <- forkIO $ writeWorker outC writeLock - cp <- forkIO $ connPersist writeLock - rd <- forkIO $ readWorker messageC presenceC stanzaC handlers eh conS - return (messageC, presenceC, stanzaC, handlers, outC - , killConnection writeLock [lw, rd, cp] - , writeLock, conS ,rd, eh) + writeLock <- newTMVarIO (\_ -> return False) + messageC <- newTChanIO + presenceC <- newTChanIO + outC <- newTChanIO + stanzaC <- newTChanIO + handlers <- newTVarIO (Map.empty, Map.empty) + eh <- newTVarIO zeroEventHandlers + conS <- newTMVarIO xmppNoConnection + lw <- forkIO $ writeWorker outC writeLock + cp <- forkIO $ connPersist writeLock + rd <- forkIO $ readWorker messageC presenceC stanzaC handlers eh conS + return ( messageC + , presenceC + , stanzaC + , handlers + , outC + , killConnection writeLock [lw, rd, cp] + , writeLock + , conS + , rd + , eh) where - killConnection writeLock threads = liftIO $ do + killConnection writeLock threads = liftIO $ do _ <- atomically $ takeTMVar writeLock -- Should we put it back? _ <- forM threads killThread - return() + return () + zeroEventHandlers :: EventHandlers + zeroEventHandlers = EventHandlers + { sessionEndHandler = return () + , connectionClosedHandler = \_ -> return () + } -- | Creates and initializes a new XMPP session. newSession :: IO Session @@ -184,22 +204,37 @@ newSession = do curId <- readTVar idRef writeTVar idRef (curId + 1 :: Integer) return . read. show $ curId - return (Session workermCh workerpCh mC pC sC outC hand writeR rdr getId - conS eh stopThreads') - + return $ Session + mC + pC + sC + workermCh + workerpCh + outC + hand + writeR + rdr + getId + conS + eh + stopThreads' + +-- | Creates a new session and runs the given XMPP computation. withNewSession :: XMPP b -> IO (Session, b) withNewSession a = do - sess <- newSession - ret <- runReaderT a sess - return (sess, ret) + sess <- newSession + ret <- runReaderT a sess + return (sess, ret) +-- | Runs the given XMPP computation in the given session. withSession :: Session -> XMPP a -> IO a withSession = flip runReaderT --- | Sends a blank space every 30 seconds to keep the connection alive -connPersist :: TMVar (BS.ByteString -> IO Bool) -> IO () +-- Acquires the write lock, pushes a space, and releases the lock. +-- | Sends a blank space every 30 seconds to keep the connection alive. +connPersist :: TMVar (BS.ByteString -> IO Bool) -> IO () connPersist lock = forever $ do - pushBS <- atomically $ takeTMVar lock - _ <- pushBS " " - atomically $ putTMVar lock pushBS - threadDelay 30000000 + pushBS <- atomically $ takeTMVar lock + _ <- pushBS " " + atomically $ putTMVar lock pushBS + threadDelay 30000000 diff --git a/src/Network/XMPP/Concurrent/Types.hs b/src/Network/XMPP/Concurrent/Types.hs index b8f3e0c..c93920c 100644 --- a/src/Network/XMPP/Concurrent/Types.hs +++ b/src/Network/XMPP/Concurrent/Types.hs @@ -14,52 +14,56 @@ import qualified Data.Map as Map import Data.Text(Text) import Data.Typeable - import Network.XMPP.Types - +-- Map between the IQ request type and the "query" namespace pair, and the TChan +-- for the IQ request and "sent" boolean pair. type IQHandlers = (Map.Map (IQRequestType, Text) (TChan IQRequestTicket) , Map.Map StanzaId (TMVar IQResponse) ) +-- Handlers to be run when the XMPP session ends and when the XMPP connection is +-- closed. data EventHandlers = EventHandlers - { sessionEndHandler :: IO () - , connectionClosedHandler :: StreamError -> IO () - } + { sessionEndHandler :: IO () + , connectionClosedHandler :: StreamError -> IO () + } -zeroEventHandlers :: EventHandlers -zeroEventHandlers = EventHandlers - { sessionEndHandler = return () - , connectionClosedHandler = \_ -> return () - } - -data Session = Session { messagesRef :: IORef (Maybe ( TChan (Either - MessageError - Message - ))) - , presenceRef :: IORef (Maybe (TChan (Either - PresenceError Presence ))) - , mShadow :: TChan (Either MessageError - Message) - -- the original chan - , pShadow :: TChan (Either PresenceError - Presence) - -- the original chan - , sShadow :: TChan Stanza -- All stanzas - , outCh :: TChan Stanza - , iqHandlers :: TVar IQHandlers - , writeRef :: TMVar (BS.ByteString -> IO Bool ) - , readerThread :: ThreadId - , idGenerator :: IO StanzaId - , conStateRef :: TMVar XmppConnection - , eventHandlers :: TVar EventHandlers - , stopThreads :: IO () - } +-- The Session object is the XMPP (ReaderT) state. +data Session = Session + { -- The original master channels that the reader puts stanzas + -- into. These are cloned by @get{STanza,Message,Presence}Chan + -- on demand when first used by the thread and are stored in the + -- {message,presence}Ref fields below. + mShadow :: TChan (Either MessageError Message) + , pShadow :: TChan (Either PresenceError Presence) + , sShadow :: TChan Stanza -- All stanzas + -- The cloned copies of the original/shadow channels. They are + -- thread-local (as opposed to the shadow channels) and contains all + -- stanzas received after the cloning of the shadow channels. + , messagesRef :: IORef (Maybe (TChan (Either MessageError Message))) + , presenceRef :: IORef (Maybe (TChan (Either PresenceError Presence))) + , outCh :: TChan Stanza + , iqHandlers :: TVar IQHandlers + -- Writing lock, so that only one thread could write to the stream at any + -- given time. + , writeRef :: TMVar (BS.ByteString -> IO Bool) + , readerThread :: ThreadId + , idGenerator :: IO StanzaId + -- Lock (used by withConnection) to make sure that a maximum of one + -- XMPPConMonad calculation is executed at any given time. + , conStateRef :: TMVar XmppConnection + , eventHandlers :: TVar EventHandlers + , stopThreads :: IO () + } +-- XMPP is a monad for concurrent XMPP usage. type XMPP a = ReaderT Session IO a +-- Interrupt is used to signal to the reader thread that it should stop. data Interrupt = Interrupt (TMVar ()) deriving Typeable instance Show Interrupt where show _ = "" + instance Ex.Exception Interrupt data IQRequestTicket = IQRequestTicket diff --git a/src/Network/XMPP/Message.hs b/src/Network/XMPP/Message.hs index 7e10634..15ce0e3 100644 --- a/src/Network/XMPP/Message.hs +++ b/src/Network/XMPP/Message.hs @@ -23,7 +23,7 @@ message = Message { messageID = Nothing -- Produce an answer message with the given payload, switching the "from" and -- "to" attributes in the original message. -answerMessage :: Message -> [Node] -> Maybe Message +answerMessage :: Message -> [Element] -> Maybe Message answerMessage Message{messageFrom = Just frm, ..} payload = Just Message{ messageFrom = messageTo , messageID = Nothing diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index b77fd99..7706f0d 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -1,15 +1,10 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-} --- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the --- Pontarius distribution for more details. - -{-# OPTIONS_HADDOCK hide #-} - {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE OverloadedStrings #-} - +{-# OPTIONS_HADDOCK hide #-} module Network.XMPP.Types ( IQError(..) @@ -27,7 +22,6 @@ module Network.XMPP.Types , PresenceType(..) , SaslError(..) , SaslFailure(..) - , ServerAddress(..) , ServerFeatures(..) , Stanza(..) , StanzaError(..) @@ -46,8 +40,6 @@ module Network.XMPP.Types ) where --- import Network.XMPP.Utilities (idGenerator) - import Control.Applicative((<$>)) import Control.Exception import Control.Monad.IO.Class @@ -69,24 +61,9 @@ import Network.XMPP.JID import System.IO --- ============================================================================= --- STANZA TYPES --- ============================================================================= - - --- TODO: Would a Stanza class such as the one below be useful sometimes? --- --- class Stanza a where --- stanzaID :: a -> Maybe StanzaID --- stanzaFrom :: a -> Maybe From --- stanzaTo :: a -> Maybe To --- stanzaXMLLang :: a -> Maybe XMLLang - - -- | -- 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 !Text deriving (Eq, Ord) @@ -99,13 +76,8 @@ instance Read StanzaId where instance IsString StanzaId where fromString = SI . Text.pack --- 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. - +-- | The XMPP communication primities (Message, Presence and Info/Query) are +-- called stanzas. data Stanza = IQRequestS IQRequest | IQResultS IQResult | IQErrorS IQError @@ -115,19 +87,17 @@ data Stanza = IQRequestS IQRequest | 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. +-- | A "request" Info/Query (IQ) stanza is one with either "get" or "set" as +-- type. They are guaranteed to always contain a payload. data IQRequest = IQRequest { iqRequestID :: StanzaId , iqRequestFrom :: Maybe JID , iqRequestTo :: Maybe JID , iqRequestLangTag :: Maybe LangTag , iqRequestType :: IQRequestType , iqRequestPayload :: Element - } - deriving (Show) + } deriving Show --- | The type of request that is made +-- | The type of IQ request that is made. data IQRequestType = Get | Set deriving (Eq, Ord) instance Show IQRequestType where @@ -139,93 +109,82 @@ instance Read IQRequestType where readsPrec _ "set" = [(Set, "")] readsPrec _ _ = [] --- | A "response" Info/Query (IQ) stanza is eitheran 'IQError' or an IQ stanza --- with the type "result" ('IQResult') - +-- | A "response" Info/Query (IQ) stanza is either an 'IQError' or an IQ stanza +-- with the type "result" ('IQResult'). type IQResponse = Either IQError IQResult --- | The answer to an IQ request +-- | The (non-error) answer to an IQ request. data IQResult = IQResult { iqResultID :: StanzaId , iqResultFrom :: Maybe JID , iqResultTo :: Maybe JID , iqResultLangTag :: Maybe LangTag - , iqResultPayload :: Maybe Element } - deriving (Show) + , iqResultPayload :: Maybe Element + } deriving Show --- | The answer to an IQ request that generated an error +-- | The answer to an IQ request that generated an error. data IQError = IQError { iqErrorID :: StanzaId , iqErrorFrom :: Maybe JID , iqErrorTo :: Maybe JID , iqErrorLangTag :: Maybe LangTag , iqErrorStanzaError :: StanzaError , iqErrorPayload :: Maybe Element -- should this be []? - } - deriving (Show) + } deriving Show --- | The message stanza. Used for /push/ type communication +-- | The message stanza. Used for /push/ type communication. data Message = Message { messageID :: Maybe StanzaId , messageFrom :: Maybe JID , messageTo :: Maybe JID , messageLangTag :: Maybe LangTag , messageType :: MessageType , messagePayload :: [Element] - } - deriving (Show) + } deriving Show --- | An error stanza generated in response to a 'Message' +-- | An error stanza generated in response to a 'Message'. data MessageError = MessageError { messageErrorID :: Maybe StanzaId , messageErrorFrom :: Maybe JID , messageErrorTo :: Maybe JID , messageErrorLangTag :: Maybe LangTag , messageErrorStanzaError :: StanzaError , messageErrorPayload :: [Element] - } - deriving (Show) + } deriving (Show) -- | The type of a Message being sent -- () -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. +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. + -- | 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). + -- | 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 + -- | 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) - + deriving (Eq) instance Show MessageType where show Chat = "chat" @@ -234,43 +193,33 @@ instance Show MessageType where show Normal = "normal" instance Read MessageType where - readsPrec _ "chat" = [( Chat ,"")] - readsPrec _ "groupchat" = [( GroupChat ,"")] - readsPrec _ "headline" = [( Headline ,"")] - readsPrec _ "normal" = [( Normal ,"")] - readsPrec _ _ = [( Normal ,"")] - --- | --- Objects of this type cannot be generated by Pontarius applications, --- but are only created internally. - -data Presence = Presence { presenceID :: Maybe StanzaId - , presenceFrom :: Maybe JID - , presenceTo :: Maybe JID - , presenceLangTag :: Maybe LangTag - , presenceType :: Maybe PresenceType - , presencePayload :: [Element] - } - deriving (Show) - - --- | --- Objects of this type cannot be generated by Pontarius applications, --- but are only created internally. - -data PresenceError = PresenceError { presenceErrorID :: Maybe StanzaId - , presenceErrorFrom :: Maybe JID - , presenceErrorTo :: Maybe JID - , presenceErrorLangTag :: Maybe LangTag + readsPrec _ "chat" = [(Chat, "")] + readsPrec _ "groupchat" = [(GroupChat, "")] + readsPrec _ "headline" = [(Headline, "")] + readsPrec _ "normal" = [(Normal, "")] + readsPrec _ _ = [(Normal, "")] + +-- | The presence stanza. Used for communicating status updates. +data Presence = Presence { presenceID :: Maybe StanzaId + , presenceFrom :: Maybe JID + , presenceTo :: Maybe JID + , presenceLangTag :: Maybe LangTag + , presenceType :: Maybe PresenceType + , presencePayload :: [Element] + } deriving Show + + +-- | An error stanza generated in response to a 'Presence'. +data PresenceError = PresenceError { presenceErrorID :: Maybe StanzaId + , presenceErrorFrom :: Maybe JID + , presenceErrorTo :: Maybe JID + , presenceErrorLangTag :: Maybe LangTag , presenceErrorStanzaError :: StanzaError - , presenceErrorPayload :: [Element] - } - deriving (Show) - --- | --- @PresenceType@ holds XMPP presence types. The "error" message type --- is left out as errors are using @PresenceError@. + , presenceErrorPayload :: [Element] + } deriving Show +-- | @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 Unsubscribe | -- ^ Sender is unsubscribing from presence @@ -281,7 +230,6 @@ data PresenceType = Subscribe | -- ^ Sender wants to subscribe to presence Default | Unavailable deriving (Eq) - instance Show PresenceType where show Subscribe = "subscribe" show Subscribed = "subscribed" @@ -292,15 +240,15 @@ instance Show PresenceType where 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 _ _ = [] + 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 ShowType = Available -- | Away @@ -327,22 +275,18 @@ instance Read PresenceType where -- readsPrec _ _ = [] --- | --- All stanzas (IQ, message, presence) can cause errors, which in the XMPP +-- | All stanzas (IQ, message, presence) can cause errors, which in the XMPP -- stream looks like . These errors are -- 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) - , stanzaErrorApplicationSpecificCondition :: - Maybe Element } deriving (Eq, Show) - - --- | --- @StanzaError@s always have one of these types. - +-- TODO: Sender XML is (optional and is) not yet included. +data StanzaError = StanzaError + { stanzaErrorType :: StanzaErrorType + , stanzaErrorCondition :: StanzaErrorCondition + , stanzaErrorText :: Maybe (Maybe LangTag, Text) + , stanzaErrorApplicationSpecificCondition :: Maybe Element + } deriving (Eq, Show) + +-- | @StanzaError@s always have one of these types. data StanzaErrorType = Cancel | -- ^ Error is unrecoverable - do not retry Continue | -- ^ Conditition was a warning - proceed Modify | -- ^ Change the data and retry @@ -350,7 +294,6 @@ data StanzaErrorType = Cancel | -- ^ Error is unrecoverable - do not retry Wait -- ^ Error is temporary - wait and retry deriving (Eq) - instance Show StanzaErrorType where show Cancel = "cancel" show Continue = "continue" @@ -366,48 +309,42 @@ instance Read StanzaErrorType where readsPrec _ "wait" = [( Wait , "")] readsPrec _ _ = [] - --- | --- Stanza errors are accommodated with one of the error conditions listed below. - -data StanzaErrorCondition = BadRequest | -- ^ Malformed XML - Conflict | -- ^ Resource or session - -- with name already - -- exists - FeatureNotImplemented | - Forbidden | -- ^ Insufficient - -- permissions - Gone | -- ^ Entity can no longer - -- be contacted at this - -- address - InternalServerError | - ItemNotFound | - JIDMalformed | - NotAcceptable | -- ^ Does not meet policy - -- criteria - NotAllowed | -- ^ No entity may perform - -- this action - NotAuthorized | -- ^ Must provide proper - -- credentials - PaymentRequired | - RecipientUnavailable | -- ^ Temporarily - -- unavailable - Redirect | -- ^ Redirecting to other - -- entity, usually - -- temporarily - RegistrationRequired | - RemoteServerNotFound | - RemoteServerTimeout | - ResourceConstraint | -- ^ Entity lacks the - -- necessary system - -- resources - ServiceUnavailable | - SubscriptionRequired | - UndefinedCondition | -- ^ Application-specific - -- condition - UnexpectedRequest -- ^ Badly timed request - deriving (Eq) - +-- | Stanza errors are accommodated with one of the error conditions listed +-- below. +data StanzaErrorCondition = BadRequest -- ^ Malformed XML. + | Conflict -- ^ Resource or session with + -- name already exists. + | FeatureNotImplemented + | Forbidden -- ^ Insufficient permissions. + | Gone -- ^ Entity can no longer be + -- contacted at this + -- address. + | InternalServerError + | ItemNotFound + | JIDMalformed + | NotAcceptable -- ^ Does not meet policy + -- criteria. + | NotAllowed -- ^ No entity may perform + -- this action. + | NotAuthorized -- ^ Must provide proper + -- credentials. + | PaymentRequired + | RecipientUnavailable -- ^ Temporarily unavailable. + | Redirect -- ^ Redirecting to other + -- entity, usually + -- temporarily. + | RegistrationRequired + | RemoteServerNotFound + | RemoteServerTimeout + | ResourceConstraint -- ^ Entity lacks the + -- necessary system + -- resources. + | ServiceUnavailable + | SubscriptionRequired + | UndefinedCondition -- ^ Application-specific + -- condition. + | UnexpectedRequest -- ^ Badly timed request. + deriving Eq instance Show StanzaErrorCondition where show BadRequest = "bad-request" @@ -468,35 +405,33 @@ data SaslFailure = SaslFailure { saslFailureCondition :: SaslError ) } deriving Show - -data SaslError = SaslAborted -- ^ Client aborted +data SaslError = SaslAborted -- ^ Client aborted. | SaslAccountDisabled -- ^ The account has been temporarily - -- disabled + -- disabled. | SaslCredentialsExpired -- ^ The authentication failed because - -- the credentials have expired + -- the credentials have expired. | 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 + -- with TLS). + | 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 + -- 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 + -- 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 + -- 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 + -- to try again later. instance Show SaslError where show SaslAborted = "aborted" @@ -525,39 +460,36 @@ instance Read SaslError where readsPrec _ "temporary-auth-failure" = [(SaslTemporaryAuthFailure , "")] readsPrec _ _ = [] --- | Readability type for host name Texts. - --- type HostName = Text -- This is defined in Network as well - -data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq) +-- data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq) -- 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 +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" @@ -587,45 +519,46 @@ instance Show StreamErrorCondition where 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 , "")] + 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) - + { errorCondition :: StreamErrorCondition + , errorText :: Maybe (Maybe LangTag, Text) + , errorXML :: Maybe Element + } deriving (Show, Eq) data StreamError = StreamError XmppStreamError | StreamWrongVersion Text - | StreamXMLError String + | StreamXMLError String -- If stream pickling goes wrong. | StreamConnectionError deriving (Show, Eq, Typeable) + instance Exception StreamError instance Error StreamError where noMsg = StreamConnectionError @@ -641,39 +574,33 @@ instance Error StreamError where noMsg = StreamConnectionError newtype IdGenerator = IdGenerator (IO Text) ---- other stuff +-- Version numbers are displayed as ".". data Version = Version { majorVersion :: Integer , minorVersion :: Integer } deriving (Eq) - --- Version numbers are displayed as ".". - instance Show Version where show (Version major minor) = (show major) ++ "." ++ (show minor) - -- If the major version numbers are not equal, compare them. Otherwise, compare -- the minor version numbers. - instance Ord Version where compare (Version amajor aminor) (Version bmajor bminor) | amajor /= bmajor = compare amajor bmajor | otherwise = compare aminor bminor - +-- The language tag in the form of "en-US". It has a primary tag, followed by a +-- number of subtags. data LangTag = LangTag { primaryTag :: Text , subtags :: [Text] } deriving (Eq) -- TODO: remove - --- Displays the language tag in the form of "en-US". - instance Show LangTag where show (LangTag p []) = Text.unpack p show (LangTag p s) = Text.unpack . Text.concat $ [p, "-", Text.intercalate "-" s] -- TODO: clean up +-- Parses a Text string to a list of LangTag objects. TODO: Why? parseLangTag :: Text -> [LangTag] parseLangTag txt = case Text.splitOn "-" txt of [] -> [] @@ -682,9 +609,8 @@ parseLangTag txt = case Text.splitOn "-" txt of instance Read LangTag where readsPrec _ txt = (,"") <$> (parseLangTag $ Text.pack txt) --- Two language tags are considered equal of they contain the same tags (case-insensitive). - --- TODO: port +-- Two language tags are considered equal of they contain the same tags +-- (case-insensitive). -- instance Eq LangTag where -- (LangTag ap as) == (LangTag bp bs) @@ -693,20 +619,17 @@ instance Read LangTag where -- | otherwise = False data ServerFeatures = SF - { stls :: Maybe Bool - , saslMechanisms :: [Text.Text] - , other :: [Element] - } deriving Show - -data XmppConnectionState = XmppConnectionClosed -- ^ No connection at - -- this point - | XmppConnectionPlain -- ^ Connection - -- established, but - -- not secured - | XmppConnectionSecured -- ^ Connection - -- established and - -- secured via TLS - deriving (Show, Eq, Typeable) + { stls :: Maybe Bool + , saslMechanisms :: [Text.Text] + , other :: [Element] + } deriving Show + +data XmppConnectionState + = XmppConnectionClosed -- ^ No connection at this point. + | XmppConnectionPlain -- ^ Connection established, but not secured. + | XmppConnectionSecured -- ^ Connection established and secured via TLS. + deriving (Show, Eq, Typeable) + data XmppConnection = XmppConnection { sConSrc :: Source IO Event , sRawSrc :: Source IO BS.ByteString @@ -725,12 +648,11 @@ data XmppConnection = XmppConnection -- 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 XmppConnection m a } deriving (Monad, MonadIO) +-- | Low-level and single-threaded XMPP monad. See @XMPP@ for a concurrent +-- implementation. type XMPPConMonad a = StateT XmppConnection IO a -- Make XMPPT derive the Monad and MonadIO instances. - -deriving instance (Monad m, MonadIO m) => MonadState (XmppConnection) (XMPPT m) - +deriving instance (Monad m, MonadIO m) => MonadState (XmppConnection) (XMPPT m) \ No newline at end of file