asakul
/
pontarius-xmpp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

Merge branch 'master' of https://github.com/nejla/pontarius

master
Philipp Balzarek 14 years ago
parent
0f43a5f63c e4a27def01
commit
b816466662
6 changed files with 532 additions and 549 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 19
      src/Network/XMPP/Concurrent/IQ.hs
  2. 289
      src/Network/XMPP/Concurrent/Monad.hs
  3. 175
      src/Network/XMPP/Concurrent/Threads.hs
  4. 70
      src/Network/XMPP/Concurrent/Types.hs
  5. 2
      src/Network/XMPP/Message.hs
  6. 524
      src/Network/XMPP/Types.hs

19
src/Network/XMPP/Concurrent/IQ.hs
Unescape View File

@ -12,13 +12,14 @@ import Network.XMPP.Concurrent.Monad @@ -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 @@ -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)

289
src/Network/XMPP/Concurrent/Monad.hs
Unescape View File

@ -17,217 +17,238 @@ import Network.XMPP.Concurrent.Types @@ -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

175
src/Network/XMPP/Concurrent/Threads.hs
Unescape View File

@ -29,6 +29,8 @@ import Text.XML.Stream.Elements @@ -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 = @@ -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 @@ -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 @@ -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

70
src/Network/XMPP/Concurrent/Types.hs
Unescape View File

@ -14,52 +14,56 @@ import qualified Data.Map as Map @@ -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 _ = "<Interrupt>"
instance Ex.Exception Interrupt
data IQRequestTicket = IQRequestTicket

2
src/Network/XMPP/Message.hs
Unescape View File

@ -23,7 +23,7 @@ message = Message { messageID = Nothing @@ -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

524
src/Network/XMPP/Types.hs
Unescape View File

@ -1,15 +1,10 @@ @@ -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 @@ -27,7 +22,6 @@ module Network.XMPP.Types
, PresenceType(..)
, SaslError(..)
, SaslFailure(..)
, ServerAddress(..)
, ServerFeatures(..)
, Stanza(..)
, StanzaError(..)
@ -46,8 +40,6 @@ module Network.XMPP.Types @@ -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 @@ -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 @@ -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 @@ -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 @@ -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
-- (<http://xmpp.org/rfcs/rfc6121.html#message-syntax-type>)
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 @@ -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 @@ -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 @@ -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 @@ -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 <stanza-kind to='sender' type='error'>. 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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -641,39 +574,33 @@ instance Error StreamError where noMsg = StreamConnectionError
newtype IdGenerator = IdGenerator (IO Text)
--- other stuff
-- Version numbers are displayed as "<major>.<minor>".
data Version = Version { majorVersion :: Integer
, minorVersion :: Integer } deriving (Eq)
-- Version numbers are displayed as "<major>.<minor>".
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 @@ -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 @@ -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 @@ -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)

Write Preview
Loading…
Cancel
Save