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
Unified 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
import Network.XMPP.Types import Network.XMPP.Types
-- | Sends an IQ, returns a 'TMVar' that will be filled with the first inbound -- | 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) sendIQ :: Maybe JID -- ^ Recipient (to)
-> IQRequestType -- ^ IQ type (Get or Set) -> IQRequestType -- ^ IQ type (@Get@ or @Set@)
-> Maybe LangTag -- ^ Language tag of the payload (Nothing for default) -> Maybe LangTag -- ^ Language tag of the payload (@Nothing@ for
-> Element -- ^ The iq body (there has to be exactly one) -- default)
-> XMPP (TMVar IQResponse) -> Element -- ^ The IQ body (there has to be exactly one)
sendIQ to tp lang body = do -- TODO: add timeout -> XMPP (TMVar IQResponse)
sendIQ to tp lang body = do -- TODO: Add timeout
newId <- liftIO =<< asks idGenerator newId <- liftIO =<< asks idGenerator
handlers <- asks iqHandlers handlers <- asks iqHandlers
ref <- liftIO . atomically $ do 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 sendStanza . IQRequestS $ IQRequest newId Nothing to lang tp body
return ref return ref
-- | like 'sendIQ', but waits for the answer IQ -- | Like 'sendIQ', but waits for the answer IQ.
sendIQ' :: Maybe JID sendIQ' :: Maybe JID
-> IQRequestType -> IQRequestType
-> Maybe LangTag -> Maybe LangTag
-> Element -> Element
-> XMPP IQResponse -> XMPP IQResponse
sendIQ' to tp lang body = do sendIQ' to tp lang body = do
ref <- sendIQ to tp lang body ref <- sendIQ to tp lang body
liftIO . atomically $ takeTMVar ref liftIO . atomically $ takeTMVar ref
answerIQ :: IQRequestTicket answerIQ :: IQRequestTicket
-> Either StanzaError (Maybe Element) -> Either StanzaError (Maybe Element)

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

@ -17,217 +17,238 @@ import Network.XMPP.Concurrent.Types
import Network.XMPP.Monad import Network.XMPP.Monad
-- | Register a new IQ listener. IQ requests matching the type and namespace will -- | Register a new IQ listener. IQ requests matching the type and namespace
-- be put in the channel. -- will be put in the channel.
-- --
-- Return the new channel or Nothing if this namespace/'IQRequestType' -- Return the new channel or Nothing if this namespace/'IQRequestType'
-- combination was alread handled -- combination was alread handled.
listenIQChan :: IQRequestType -- ^ type of IQs to receive (Get / Set) listenIQChan :: IQRequestType -- ^ Type of IQs to receive (@Get@ or @Set@)
-> Text -- ^ namespace of the child element -> Text -- ^ Namespace of the child element
-> XMPP (Maybe ( TChan IQRequestTicket)) -> XMPP (Maybe (TChan IQRequestTicket))
listenIQChan tp ns = do listenIQChan tp ns = do
handlers <- asks iqHandlers handlers <- asks iqHandlers
liftIO . atomically $ do liftIO . atomically $ do
(byNS, byID) <- readTVar handlers (byNS, byID) <- readTVar handlers
iqCh <- newTChan iqCh <- newTChan
let (present, byNS') = Map.insertLookupWithKey' (\_ _ old -> old) let (present, byNS') = Map.insertLookupWithKey'
(tp,ns) iqCh byNS (\_ _ old -> old)
writeTVar handlers (byNS', byID) (tp, ns)
return $ case present of iqCh
Nothing -> Just iqCh byNS
Just _iqCh' -> Nothing writeTVar handlers (byNS', byID)
return $ case present of
-- | get the inbound message channel, duplicates from master if necessary Nothing -> Just iqCh
-- please note that once duplicated it will keep filling up, call Just _iqCh' -> Nothing
-- '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'
-- | Get a duplicate of the stanza channel -- | Get a duplicate of the stanza channel
getStanzaChan :: XMPP (TChan Stanza) getStanzaChan :: XMPP (TChan Stanza)
getStanzaChan = do getStanzaChan = do
shadow <- asks sShadow shadow <- asks sShadow
liftIO $ atomically $ dupTChan shadow 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 :: XMPP (TChan (Either PresenceError Presence))
getPresenceChan = do getPresenceChan = do
pChR <- asks presenceRef pChR <- asks presenceRef
pCh <- liftIO $ readIORef pChR pCh <- liftIO $ readIORef pChR
case pCh of case pCh of
Nothing -> do Nothing -> do
shadow <- asks pShadow shadow <- asks pShadow
pCh' <- liftIO $ atomically $ dupTChan shadow pCh' <- liftIO $ atomically $ dupTChan shadow
liftIO $ writeIORef pChR (Just pCh') liftIO $ writeIORef pChR (Just pCh')
return pCh' return pCh'
Just pCh' -> return pCh' Just pCh' -> return pCh'
-- | Drop the local end of the inbound stanza channel -- | Drop the local end of the inbound stanza channel from our context so it can
-- from our context so it can be GC-ed -- be GC-ed.
dropMessageChan :: XMPP () dropMessageChan :: XMPP ()
dropMessageChan = do dropMessageChan = do
r <- asks messagesRef r <- asks messagesRef
liftIO $ writeIORef r Nothing liftIO $ writeIORef r Nothing
-- | see 'dropMessageChan' -- | Analogous to 'dropMessageChan'.
dropPresenceChan :: XMPP () dropPresenceChan :: XMPP ()
dropPresenceChan = do dropPresenceChan = do
r <- asks presenceRef r <- asks presenceRef
liftIO $ writeIORef r Nothing liftIO $ writeIORef r Nothing
-- | Read an element from the inbound stanza channel, acquiring a copy -- | Read an element from the inbound stanza channel, acquiring a copy of the
-- of the channel as necessary -- channel as necessary.
pullMessage :: XMPP (Either MessageError Message) pullMessage :: XMPP (Either MessageError Message)
pullMessage = do pullMessage = do
c <- getMessageChan c <- getMessageChan
liftIO $ atomically $ readTChan c liftIO $ atomically $ readTChan c
-- | Read an element from the inbound stanza channel, acquiring a copy -- | Read an element from the inbound stanza channel, acquiring a copy of the
-- of the channel as necessary -- channel as necessary.
pullPresence :: XMPP (Either PresenceError Presence) pullPresence :: XMPP (Either PresenceError Presence)
pullPresence = do pullPresence = do
c <- getPresenceChan c <- getPresenceChan
liftIO $ atomically $ readTChan c liftIO $ atomically $ readTChan c
-- | Send a stanza to the server -- | Send a stanza to the server.
sendStanza :: Stanza -> XMPP () sendStanza :: Stanza -> XMPP ()
sendStanza a = do sendStanza a = do
out <- asks outCh out <- asks outCh
liftIO . atomically $ writeTChan out a liftIO . atomically $ writeTChan out a
return () return ()
-- | Create a forked session object without forking a thread -- | Create a forked session object without forking a thread.
forkSession :: Session -> IO Session forkSession :: Session -> IO Session
forkSession sess = do forkSession sess = do
mCH' <- newIORef Nothing mCH' <- newIORef Nothing
pCH' <- 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 :: XMPP () -> XMPP ThreadId
fork a = do fork a = do
sess <- ask sess <- ask
sess' <- liftIO $ forkSession sess sess' <- liftIO $ forkSession sess
liftIO $ forkIO $ runReaderT a sess' liftIO $ forkIO $ runReaderT a sess'
-- | Pulls a message and returns it if the given predicate returns @True@.
filterMessages :: (MessageError -> Bool) filterMessages :: (MessageError -> Bool)
-> (Message -> Bool) -> (Message -> Bool)
-> XMPP (Either MessageError Message) -> XMPP (Either MessageError Message)
filterMessages f g = do filterMessages f g = do
s <- pullMessage s <- pullMessage
case s of case s of
Left e | f e -> return $ Left e Left e | f e -> return $ Left e
| otherwise -> filterMessages f g | otherwise -> filterMessages f g
Right m | g m -> return $ Right m Right m | g m -> return $ Right m
| otherwise -> filterMessages f g | otherwise -> filterMessages f g
-- | Pulls a (non-error) message and returns it if the given predicate returns
-- @True@.
waitForMessage :: (Message -> Bool) -> XMPP Message waitForMessage :: (Message -> Bool) -> XMPP Message
waitForMessage f = do waitForMessage f = do
s <- pullMessage s <- pullMessage
case s of case s of
Left _ -> waitForMessage f Left _ -> waitForMessage f
Right m | f m -> return m Right m | f m -> return m
| otherwise -> waitForMessage f | otherwise -> waitForMessage f
-- | Pulls an error message and returns it if the given predicate returns @True@.
waitForMessageError :: (MessageError -> Bool) -> XMPP MessageError waitForMessageError :: (MessageError -> Bool) -> XMPP MessageError
waitForMessageError f = do waitForMessageError f = do
s <- pullMessage s <- pullMessage
case s of case s of
Right _ -> waitForMessageError f Right _ -> waitForMessageError f
Left m | f m -> return m Left m | f m -> return m
| otherwise -> waitForMessageError f | otherwise -> waitForMessageError f
-- | Pulls a (non-error) presence and returns it if the given predicate returns
-- @True@.
waitForPresence :: (Presence -> Bool) -> XMPP Presence waitForPresence :: (Presence -> Bool) -> XMPP Presence
waitForPresence f = do waitForPresence f = do
s <- pullPresence s <- pullPresence
case s of case s of
Left _ -> waitForPresence f Left _ -> waitForPresence f
Right m | f m -> return m Right m | f m -> return m
| otherwise -> waitForPresence f | otherwise -> waitForPresence f
-- | Run an XMPPMonad action in isolation. -- TODO: Wait for presence error?
-- Reader and writer workers will be temporarily stopped
-- and resumed with the new session details once the action returns. -- | Run an XMPPMonad action in isolation. Reader and writer workers will be
-- The Action will run in the calling thread/ -- temporarily stopped and resumed with the new session details once the action
-- Any uncaught exceptions will be interpreted as connection failure -- 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 :: XMPPConMonad a -> XMPP (Either StreamError a)
withConnection a = do withConnection a = do
readerId <- asks readerThread readerId <- asks readerThread
stateRef <- asks conStateRef stateRef <- asks conStateRef
write <- asks writeRef write <- asks writeRef
wait <- liftIO $ newEmptyTMVarIO wait <- liftIO $ newEmptyTMVarIO
liftIO . Ex.mask_ $ do liftIO . Ex.mask_ $ do
throwTo readerId $ Interrupt wait -- Suspends the reader until the lock (wait) is released (set to `()').
s <- Ex.catch ( atomically $ do throwTo readerId $ Interrupt wait
_ <- takeTMVar write -- We acquire the write and stateRef locks, to make sure that this is
s <- takeTMVar stateRef -- the only thread that can write to the stream and to perform a
putTMVar wait () -- withConnection calculation. Afterwards, we release the lock and
return s -- fetches an updated state.
) s <- Ex.catch
(\e -> atomically (putTMVar wait ()) (atomically $ do
>> Ex.throwIO (e :: Ex.SomeException) _ <- takeTMVar write
-- No MVar taken s <- takeTMVar stateRef
) putTMVar wait ()
Ex.catches ( do return s
(res, s') <- runStateT a s )
atomically $ do -- If we catch an exception, we have failed to take the MVars above.
putTMVar write (sConPushBS s') (\e -> atomically (putTMVar wait ()) >>
putTMVar stateRef s' Ex.throwIO (e :: Ex.SomeException)
return $ Right res )
) -- Run the XMPPMonad action, save the (possibly updated) states, release
-- we treat all Exceptions as fatal -- the locks, and return the result.
[ Ex.Handler $ \e -> return $ Left (e :: StreamError) Ex.catches
, Ex.Handler $ \e -> runStateT xmppKillConnection s (do
>> Ex.throwIO (e :: Ex.SomeException) (res, s') <- runStateT a s
] atomically $ do
putTMVar write (sConPushBS s')
-- | Send a presence Stanza 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 :: Presence -> XMPP ()
sendPresence = sendStanza . PresenceS sendPresence = sendStanza . PresenceS
-- | Send a Message Stanza -- | Send a message stanza.
sendMessage :: Message -> XMPP () sendMessage :: Message -> XMPP ()
sendMessage = sendStanza . MessageS sendMessage = sendStanza . MessageS
-- | Executes a function to update the event handlers.
modifyHandlers :: (EventHandlers -> EventHandlers) -> XMPP () modifyHandlers :: (EventHandlers -> EventHandlers) -> XMPP ()
modifyHandlers f = do modifyHandlers f = do
eh <- asks eventHandlers eh <- asks eventHandlers
liftIO . atomically $ writeTVar eh . f =<< readTVar eh liftIO . atomically $ writeTVar eh . f =<< readTVar eh
-- | Sets the handler to be executed when the session ends.
setSessionEndHandler :: XMPP () -> XMPP () setSessionEndHandler :: XMPP () -> XMPP ()
setSessionEndHandler eh = do setSessionEndHandler eh = do
r <- ask r <- ask
modifyHandlers (\s -> s{sessionEndHandler = runReaderT eh r}) modifyHandlers (\s -> s{sessionEndHandler = runReaderT eh r})
-- | Sets the handler to be executed when the server connection is closed.
setConnectionClosedHandler :: (StreamError -> XMPP ()) -> XMPP () setConnectionClosedHandler :: (StreamError -> XMPP ()) -> XMPP ()
setConnectionClosedHandler eh = do setConnectionClosedHandler eh = do
r <- ask r <- ask
modifyHandlers (\s -> s{connectionClosedHandler = \e -> runReaderT (eh e) r}) modifyHandlers (\s -> s{connectionClosedHandler = \e -> runReaderT (eh e) r})
-- | run an event handler -- | Run an event handler.
runHandler :: (EventHandlers -> IO a) -> XMPP a runHandler :: (EventHandlers -> IO a) -> XMPP a
runHandler h = do runHandler h = do
eh <- liftIO . atomically . readTVar =<< asks eventHandlers eh <- liftIO . atomically . readTVar =<< asks eventHandlers
liftIO $ h eh liftIO $ h eh
-- | End the current xmpp session -- | End the current XMPP session.
endSession :: XMPP () endSession :: XMPP ()
endSession = do -- TODO: This has to be idempotent (is it?) endSession = do -- TODO: This has to be idempotent (is it?)
void $ withConnection xmppKillConnection void $ withConnection xmppKillConnection
liftIO =<< asks stopThreads liftIO =<< asks stopThreads
runHandler sessionEndHandler runHandler sessionEndHandler
-- | Close the connection to the server -- | Close the connection to the server.
closeConnection :: XMPP () closeConnection :: XMPP ()
closeConnection = void $ withConnection xmppKillConnection closeConnection = void $ withConnection xmppKillConnection

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

@ -29,6 +29,8 @@ import Text.XML.Stream.Elements
import GHC.IO (unsafeUnmask) import GHC.IO (unsafeUnmask)
-- Worker to read stanzas from the stream and concurrently distribute them to
-- all listener threads.
readWorker :: TChan (Either MessageError Message) readWorker :: TChan (Either MessageError Message)
-> TChan (Either PresenceError Presence) -> TChan (Either PresenceError Presence)
-> TChan Stanza -> TChan Stanza
@ -84,24 +86,30 @@ readWorker messageC presenceC stanzaC iqHands handlers stateRef =
IQRequestS i -> handleIQRequest iqHands i IQRequestS i -> handleIQRequest iqHands i
IQResultS i -> handleIQResponse iqHands (Right i) IQResultS i -> handleIQResponse iqHands (Right i)
IQErrorS i -> handleIQResponse iqHands (Left i) IQErrorS i -> handleIQResponse iqHands (Left i)
where where
-- Defining an Control.Exception.allowInterrupt equivalent for -- Defining an Control.Exception.allowInterrupt equivalent for GHC 7
-- GHC 7 compatibility. -- compatibility.
allowInterrupt :: IO () allowInterrupt :: IO ()
allowInterrupt = unsafeUnmask $ return () allowInterrupt = unsafeUnmask $ return ()
-- Call the connection closed handlers.
noCon :: TVar EventHandlers -> StreamError -> IO (Maybe a) noCon :: TVar EventHandlers -> StreamError -> IO (Maybe a)
noCon h e = do noCon h e = do
hands <- atomically $ readTVar h hands <- atomically $ readTVar h
_ <- forkIO $ connectionClosedHandler hands e _ <- forkIO $ connectionClosedHandler hands e
return Nothing return Nothing
-- While waiting for the first semaphore(s) to flip we might receive -- While waiting for the first semaphore(s) to flip we might receive another
-- another interrupt. When that happens we add it's semaphore to the -- interrupt. When that happens we add it's semaphore to the list and retry
-- list and retry waiting -- 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 :: [TMVar ()] -> IO [()]
handleInterrupts ts = handleInterrupts ts =
Ex.catch (atomically $ forM ts takeTMVar) 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 :: TVar IQHandlers -> IQRequest -> STM ()
handleIQRequest handlers iq = do handleIQRequest handlers iq = do
(byNS, _) <- readTVar handlers (byNS, _) <- readTVar handlers
@ -111,67 +119,79 @@ handleIQRequest handlers iq = do
Just ch -> do Just ch -> do
sent <- newTVar False sent <- newTVar False
writeTChan ch $ IQRequestTicket sent iq writeTChan ch $ IQRequestTicket sent iq
handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> STM () handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> STM ()
handleIQResponse handlers iq = do handleIQResponse handlers iq = do
(byNS, byID) <- readTVar handlers (byNS, byID) <- readTVar handlers
case Map.updateLookupWithKey (\_ _ -> Nothing) (iqID iq) byID of case Map.updateLookupWithKey (\_ _ -> Nothing) (iqID iq) byID of
(Nothing, _) -> return () -- we are not supposed (Nothing, _) -> return () -- We are not supposed to send an error.
-- to send an error (Just tmvar, byID') -> do
(Just tmvar, byID') -> do _ <- tryPutTMVar tmvar iq -- Don't block.
_ <- tryPutTMVar tmvar iq -- don't block writeTVar handlers (byNS, byID')
writeTVar handlers (byNS, byID') where
where iqID (Left err) = iqErrorID err
iqID (Left err) = iqErrorID err iqID (Right iq') = iqResultID iq'
iqID (Right iq') = iqResultID iq'
-- Worker to write stanzas to the stream concurrently.
writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO Bool) -> IO () writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO Bool) -> IO ()
writeWorker stCh writeR = forever $ do writeWorker stCh writeR = forever $ do
(write, next) <- atomically $ (,) <$> (write, next) <- atomically $ (,) <$>
takeTMVar writeR <*> takeTMVar writeR <*>
readTChan stCh readTChan stCh
r <- write $ renderElement (pickleElem xpStanza next) r <- write $ renderElement (pickleElem xpStanza next)
unless r $ do unless r $ do -- If the writing failed, the connection is dead.
atomically $ unGetTChan stCh next -- connection is dead atomically $ unGetTChan stCh next
threadDelay 250000 -- avoid free spinning threadDelay 250000 -- Avoid free spinning.
atomically $ putTMVar writeR write atomically $ putTMVar writeR write -- Put it back.
-- Two streams: input and output. Threads read from input stream and write to output stream. -- Two streams: input and output. Threads read from input stream and write to
-- | Runs thread in XmppState monad -- output stream.
-- returns channel of incoming and outgoing stances, respectively -- | Runs thread in XmppState monad. Returns channel of incoming and outgoing
-- and an Action to stop the Threads and close the connection -- stances, respectively, and an Action to stop the Threads and close the
startThreads -- connection.
:: IO ( TChan (Either MessageError Message) startThreads :: IO ( TChan (Either MessageError Message)
, TChan (Either PresenceError Presence) , TChan (Either PresenceError Presence)
, TChan Stanza , TChan Stanza
, TVar IQHandlers , TVar IQHandlers
, TChan Stanza , TChan Stanza
, IO () , IO ()
, TMVar (BS.ByteString -> IO Bool) , TMVar (BS.ByteString -> IO Bool)
, TMVar XmppConnection , TMVar XmppConnection
, ThreadId , ThreadId
, TVar EventHandlers , TVar EventHandlers
) )
startThreads = do startThreads = do
writeLock <- newTMVarIO (\_ -> return False) writeLock <- newTMVarIO (\_ -> return False)
messageC <- newTChanIO messageC <- newTChanIO
presenceC <- newTChanIO presenceC <- newTChanIO
outC <- newTChanIO outC <- newTChanIO
stanzaC <- newTChanIO stanzaC <- newTChanIO
handlers <- newTVarIO ( Map.empty, Map.empty) handlers <- newTVarIO (Map.empty, Map.empty)
eh <- newTVarIO zeroEventHandlers eh <- newTVarIO zeroEventHandlers
conS <- newTMVarIO xmppNoConnection conS <- newTMVarIO xmppNoConnection
lw <- forkIO $ writeWorker outC writeLock lw <- forkIO $ writeWorker outC writeLock
cp <- forkIO $ connPersist writeLock cp <- forkIO $ connPersist writeLock
rd <- forkIO $ readWorker messageC presenceC stanzaC handlers eh conS rd <- forkIO $ readWorker messageC presenceC stanzaC handlers eh conS
return (messageC, presenceC, stanzaC, handlers, outC return ( messageC
, killConnection writeLock [lw, rd, cp] , presenceC
, writeLock, conS ,rd, eh) , stanzaC
, handlers
, outC
, killConnection writeLock [lw, rd, cp]
, writeLock
, conS
, rd
, eh)
where where
killConnection writeLock threads = liftIO $ do killConnection writeLock threads = liftIO $ do
_ <- atomically $ takeTMVar writeLock -- Should we put it back? _ <- atomically $ takeTMVar writeLock -- Should we put it back?
_ <- forM threads killThread _ <- forM threads killThread
return() return ()
zeroEventHandlers :: EventHandlers
zeroEventHandlers = EventHandlers
{ sessionEndHandler = return ()
, connectionClosedHandler = \_ -> return ()
}
-- | Creates and initializes a new XMPP session. -- | Creates and initializes a new XMPP session.
newSession :: IO Session newSession :: IO Session
@ -184,22 +204,37 @@ newSession = do
curId <- readTVar idRef curId <- readTVar idRef
writeTVar idRef (curId + 1 :: Integer) writeTVar idRef (curId + 1 :: Integer)
return . read. show $ curId return . read. show $ curId
return (Session workermCh workerpCh mC pC sC outC hand writeR rdr getId return $ Session
conS eh stopThreads') 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 :: XMPP b -> IO (Session, b)
withNewSession a = do withNewSession a = do
sess <- newSession sess <- newSession
ret <- runReaderT a sess ret <- runReaderT a sess
return (sess, ret) return (sess, ret)
-- | Runs the given XMPP computation in the given session.
withSession :: Session -> XMPP a -> IO a withSession :: Session -> XMPP a -> IO a
withSession = flip runReaderT withSession = flip runReaderT
-- | Sends a blank space every 30 seconds to keep the connection alive -- Acquires the write lock, pushes a space, and releases the lock.
connPersist :: TMVar (BS.ByteString -> IO Bool) -> IO () -- | Sends a blank space every 30 seconds to keep the connection alive.
connPersist :: TMVar (BS.ByteString -> IO Bool) -> IO ()
connPersist lock = forever $ do connPersist lock = forever $ do
pushBS <- atomically $ takeTMVar lock pushBS <- atomically $ takeTMVar lock
_ <- pushBS " " _ <- pushBS " "
atomically $ putTMVar lock pushBS atomically $ putTMVar lock pushBS
threadDelay 30000000 threadDelay 30000000

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

@ -14,52 +14,56 @@ import qualified Data.Map as Map
import Data.Text(Text) import Data.Text(Text)
import Data.Typeable import Data.Typeable
import Network.XMPP.Types 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) type IQHandlers = (Map.Map (IQRequestType, Text) (TChan IQRequestTicket)
, Map.Map StanzaId (TMVar IQResponse) , Map.Map StanzaId (TMVar IQResponse)
) )
-- Handlers to be run when the XMPP session ends and when the XMPP connection is
-- closed.
data EventHandlers = EventHandlers data EventHandlers = EventHandlers
{ sessionEndHandler :: IO () { sessionEndHandler :: IO ()
, connectionClosedHandler :: StreamError -> IO () , connectionClosedHandler :: StreamError -> IO ()
} }
zeroEventHandlers :: EventHandlers -- The Session object is the XMPP (ReaderT) state.
zeroEventHandlers = EventHandlers data Session = Session
{ sessionEndHandler = return () { -- The original master channels that the reader puts stanzas
, connectionClosedHandler = \_ -> return () -- 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.
data Session = Session { messagesRef :: IORef (Maybe ( TChan (Either mShadow :: TChan (Either MessageError Message)
MessageError , pShadow :: TChan (Either PresenceError Presence)
Message , sShadow :: TChan Stanza -- All stanzas
))) -- The cloned copies of the original/shadow channels. They are
, presenceRef :: IORef (Maybe (TChan (Either -- thread-local (as opposed to the shadow channels) and contains all
PresenceError Presence ))) -- stanzas received after the cloning of the shadow channels.
, mShadow :: TChan (Either MessageError , messagesRef :: IORef (Maybe (TChan (Either MessageError Message)))
Message) , presenceRef :: IORef (Maybe (TChan (Either PresenceError Presence)))
-- the original chan , outCh :: TChan Stanza
, pShadow :: TChan (Either PresenceError , iqHandlers :: TVar IQHandlers
Presence) -- Writing lock, so that only one thread could write to the stream at any
-- the original chan -- given time.
, sShadow :: TChan Stanza -- All stanzas , writeRef :: TMVar (BS.ByteString -> IO Bool)
, outCh :: TChan Stanza , readerThread :: ThreadId
, iqHandlers :: TVar IQHandlers , idGenerator :: IO StanzaId
, writeRef :: TMVar (BS.ByteString -> IO Bool ) -- Lock (used by withConnection) to make sure that a maximum of one
, readerThread :: ThreadId -- XMPPConMonad calculation is executed at any given time.
, idGenerator :: IO StanzaId , conStateRef :: TMVar XmppConnection
, conStateRef :: TMVar XmppConnection , eventHandlers :: TVar EventHandlers
, eventHandlers :: TVar EventHandlers , stopThreads :: IO ()
, stopThreads :: IO () }
}
-- XMPP is a monad for concurrent XMPP usage.
type XMPP a = ReaderT Session IO a 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 data Interrupt = Interrupt (TMVar ()) deriving Typeable
instance Show Interrupt where show _ = "<Interrupt>" instance Show Interrupt where show _ = "<Interrupt>"
instance Ex.Exception Interrupt instance Ex.Exception Interrupt
data IQRequestTicket = IQRequestTicket data IQRequestTicket = IQRequestTicket

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

@ -23,7 +23,7 @@ message = Message { messageID = Nothing
-- Produce an answer message with the given payload, switching the "from" and -- Produce an answer message with the given payload, switching the "from" and
-- "to" attributes in the original message. -- "to" attributes in the original message.
answerMessage :: Message -> [Node] -> Maybe Message answerMessage :: Message -> [Element] -> Maybe Message
answerMessage Message{messageFrom = Just frm, ..} payload = answerMessage Message{messageFrom = Just frm, ..} payload =
Just Message{ messageFrom = messageTo Just Message{ messageFrom = messageTo
, messageID = Nothing , messageID = Nothing

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

@ -1,15 +1,10 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
-- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the
-- Pontarius distribution for more details.
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK hide #-}
module Network.XMPP.Types module Network.XMPP.Types
( IQError(..) ( IQError(..)
@ -27,7 +22,6 @@ module Network.XMPP.Types
, PresenceType(..) , PresenceType(..)
, SaslError(..) , SaslError(..)
, SaslFailure(..) , SaslFailure(..)
, ServerAddress(..)
, ServerFeatures(..) , ServerFeatures(..)
, Stanza(..) , Stanza(..)
, StanzaError(..) , StanzaError(..)
@ -46,8 +40,6 @@ module Network.XMPP.Types
) )
where where
-- import Network.XMPP.Utilities (idGenerator)
import Control.Applicative((<$>)) import Control.Applicative((<$>))
import Control.Exception import Control.Exception
import Control.Monad.IO.Class import Control.Monad.IO.Class
@ -69,24 +61,9 @@ import Network.XMPP.JID
import System.IO 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 -- Wraps a string of random characters that, when using an appropriate
-- @IDGenerator@, is guaranteed to be unique for the XMPP session. -- @IDGenerator@, is guaranteed to be unique for the XMPP session.
-- Stanza identifiers are generated by Pontarius.
data StanzaId = SI !Text deriving (Eq, Ord) data StanzaId = SI !Text deriving (Eq, Ord)
@ -99,13 +76,8 @@ instance Read StanzaId where
instance IsString StanzaId where instance IsString StanzaId where
fromString = SI . Text.pack fromString = SI . Text.pack
-- An Info/Query (IQ) stanza is either of the type "request" ("get" or -- | The XMPP communication primities (Message, Presence and Info/Query) are
-- "set") or "response" ("result" or "error"). The @IQ@ type wraps -- called stanzas.
-- these two sub-types.
--
-- Objects of this type cannot be generated by Pontarius applications,
-- but are only created internally.
data Stanza = IQRequestS IQRequest data Stanza = IQRequestS IQRequest
| IQResultS IQResult | IQResultS IQResult
| IQErrorS IQError | IQErrorS IQError
@ -115,19 +87,17 @@ data Stanza = IQRequestS IQRequest
| PresenceErrorS PresenceError | PresenceErrorS PresenceError
deriving Show deriving Show
-- | -- | A "request" Info/Query (IQ) stanza is one with either "get" or "set" as
-- A "request" Info/Query (IQ) stanza is one with either "get" or -- type. They are guaranteed to always contain a payload.
-- "set" as type. They are guaranteed to always contain a payload.
data IQRequest = IQRequest { iqRequestID :: StanzaId data IQRequest = IQRequest { iqRequestID :: StanzaId
, iqRequestFrom :: Maybe JID , iqRequestFrom :: Maybe JID
, iqRequestTo :: Maybe JID , iqRequestTo :: Maybe JID
, iqRequestLangTag :: Maybe LangTag , iqRequestLangTag :: Maybe LangTag
, iqRequestType :: IQRequestType , iqRequestType :: IQRequestType
, iqRequestPayload :: Element , 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) data IQRequestType = Get | Set deriving (Eq, Ord)
instance Show IQRequestType where instance Show IQRequestType where
@ -139,93 +109,82 @@ instance Read IQRequestType where
readsPrec _ "set" = [(Set, "")] readsPrec _ "set" = [(Set, "")]
readsPrec _ _ = [] readsPrec _ _ = []
-- | A "response" Info/Query (IQ) stanza is eitheran 'IQError' or an IQ stanza -- | A "response" Info/Query (IQ) stanza is either an 'IQError' or an IQ stanza
-- with the type "result" ('IQResult') -- with the type "result" ('IQResult').
type IQResponse = Either IQError 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 data IQResult = IQResult { iqResultID :: StanzaId
, iqResultFrom :: Maybe JID , iqResultFrom :: Maybe JID
, iqResultTo :: Maybe JID , iqResultTo :: Maybe JID
, iqResultLangTag :: Maybe LangTag , iqResultLangTag :: Maybe LangTag
, iqResultPayload :: Maybe Element } , iqResultPayload :: Maybe Element
deriving (Show) } 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 data IQError = IQError { iqErrorID :: StanzaId
, iqErrorFrom :: Maybe JID , iqErrorFrom :: Maybe JID
, iqErrorTo :: Maybe JID , iqErrorTo :: Maybe JID
, iqErrorLangTag :: Maybe LangTag , iqErrorLangTag :: Maybe LangTag
, iqErrorStanzaError :: StanzaError , iqErrorStanzaError :: StanzaError
, iqErrorPayload :: Maybe Element -- should this be []? , 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 data Message = Message { messageID :: Maybe StanzaId
, messageFrom :: Maybe JID , messageFrom :: Maybe JID
, messageTo :: Maybe JID , messageTo :: Maybe JID
, messageLangTag :: Maybe LangTag , messageLangTag :: Maybe LangTag
, messageType :: MessageType , messageType :: MessageType
, messagePayload :: [Element] , 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 data MessageError = MessageError { messageErrorID :: Maybe StanzaId
, messageErrorFrom :: Maybe JID , messageErrorFrom :: Maybe JID
, messageErrorTo :: Maybe JID , messageErrorTo :: Maybe JID
, messageErrorLangTag :: Maybe LangTag , messageErrorLangTag :: Maybe LangTag
, messageErrorStanzaError :: StanzaError , messageErrorStanzaError :: StanzaError
, messageErrorPayload :: [Element] , messageErrorPayload :: [Element]
} } deriving (Show)
deriving (Show)
-- | The type of a Message being sent -- | The type of a Message being sent
-- (<http://xmpp.org/rfcs/rfc6121.html#message-syntax-type>) -- (<http://xmpp.org/rfcs/rfc6121.html#message-syntax-type>)
data MessageType = -- | The message is sent in the context of a one-to-one chat data MessageType = -- | The message is sent in the context of a one-to-one chat
-- session. Typically an interactive client will present a -- session. Typically an interactive client will present a
-- message of type /chat/ in an interface that enables -- message of type /chat/ in an interface that enables
-- one-to-one chat between the two parties, including an -- one-to-one chat between the two parties, including an
-- appropriate conversation history. -- appropriate conversation history.
Chat Chat
-- | The message is sent in the context of a -- | The message is sent in the context of a multi-user chat
-- multi-user chat environment (similar to that of -- environment (similar to that of @IRC@). Typically a
-- @IRC@). Typically a receiving client will -- receiving client will present a message of type
-- present a message of type /groupchat/ in an -- /groupchat/ in an interface that enables many-to-many
-- interface that enables many-to-many chat -- chat between the parties, including a roster of parties
-- between the parties, including a roster of -- in the chatroom and an appropriate conversation history.
-- parties in the chatroom and an appropriate
-- conversation history.
| GroupChat | GroupChat
-- | The message provides an alert, a -- | The message provides an alert, a notification, or other
-- notification, or other transient information to -- transient information to which no reply is expected
-- which no reply is expected (e.g., news -- (e.g., news headlines, sports updates, near-real-time
-- headlines, sports updates, near-real-time -- market data, or syndicated content). Because no reply to
-- market data, or syndicated content). Because no -- the message is expected, typically a receiving client
-- reply to the message is expected, typically a -- will present a message of type /headline/ in an interface
-- receiving client will present a message of type -- that appropriately differentiates the message from
-- /headline/ in an interface that appropriately -- standalone messages, chat messages, and groupchat
-- differentiates the message from standalone -- messages (e.g., by not providing the recipient with the
-- messages, chat messages, and groupchat messages -- ability to reply).
-- (e.g., by not providing the recipient with the
-- ability to reply).
| Headline | Headline
-- | The message is a standalone message that is -- | The message is a standalone message that is sent outside
-- sent outside the context of a one-to-one -- the context of a one-to-one conversation or groupchat, and
-- conversation or groupchat, and to which it is -- to which it is expected that the recipient will reply.
-- expected that the recipient will -- Typically a receiving client will present a message of
-- reply. Typically a receiving client will -- type /normal/ in an interface that enables the recipient
-- present a message of type /normal/ in an -- to reply, but without a conversation history.
-- interface that enables the recipient to reply, --
-- but without a conversation history. -- This is the /default/ value.
--
-- This is the /default/ value
| Normal | Normal
deriving (Eq) deriving (Eq)
instance Show MessageType where instance Show MessageType where
show Chat = "chat" show Chat = "chat"
@ -234,43 +193,33 @@ instance Show MessageType where
show Normal = "normal" show Normal = "normal"
instance Read MessageType where instance Read MessageType where
readsPrec _ "chat" = [( Chat ,"")] readsPrec _ "chat" = [(Chat, "")]
readsPrec _ "groupchat" = [( GroupChat ,"")] readsPrec _ "groupchat" = [(GroupChat, "")]
readsPrec _ "headline" = [( Headline ,"")] readsPrec _ "headline" = [(Headline, "")]
readsPrec _ "normal" = [( Normal ,"")] readsPrec _ "normal" = [(Normal, "")]
readsPrec _ _ = [( Normal ,"")] readsPrec _ _ = [(Normal, "")]
-- | -- | The presence stanza. Used for communicating status updates.
-- Objects of this type cannot be generated by Pontarius applications, data Presence = Presence { presenceID :: Maybe StanzaId
-- but are only created internally. , presenceFrom :: Maybe JID
, presenceTo :: Maybe JID
data Presence = Presence { presenceID :: Maybe StanzaId , presenceLangTag :: Maybe LangTag
, presenceFrom :: Maybe JID , presenceType :: Maybe PresenceType
, presenceTo :: Maybe JID , presencePayload :: [Element]
, presenceLangTag :: Maybe LangTag } deriving Show
, presenceType :: Maybe PresenceType
, presencePayload :: [Element]
} -- | An error stanza generated in response to a 'Presence'.
deriving (Show) data PresenceError = PresenceError { presenceErrorID :: Maybe StanzaId
, presenceErrorFrom :: Maybe JID
, presenceErrorTo :: Maybe JID
-- | , presenceErrorLangTag :: Maybe LangTag
-- 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
, presenceErrorStanzaError :: StanzaError , presenceErrorStanzaError :: StanzaError
, presenceErrorPayload :: [Element] , presenceErrorPayload :: [Element]
} } deriving Show
deriving (Show)
-- |
-- @PresenceType@ holds XMPP presence types. The "error" message type
-- is left out as errors are using @PresenceError@.
-- | @PresenceType@ holds XMPP presence types. The "error" message type is left
-- out as errors are using @PresenceError@.
data PresenceType = Subscribe | -- ^ Sender wants to subscribe to presence data PresenceType = Subscribe | -- ^ Sender wants to subscribe to presence
Subscribed | -- ^ Sender has approved the subscription Subscribed | -- ^ Sender has approved the subscription
Unsubscribe | -- ^ Sender is unsubscribing from presence Unsubscribe | -- ^ Sender is unsubscribing from presence
@ -281,7 +230,6 @@ data PresenceType = Subscribe | -- ^ Sender wants to subscribe to presence
Default | Default |
Unavailable deriving (Eq) Unavailable deriving (Eq)
instance Show PresenceType where instance Show PresenceType where
show Subscribe = "subscribe" show Subscribe = "subscribe"
show Subscribed = "subscribed" show Subscribed = "subscribed"
@ -292,15 +240,15 @@ instance Show PresenceType where
show Unavailable = "unavailable" show Unavailable = "unavailable"
instance Read PresenceType where instance Read PresenceType where
readsPrec _ "" = [( Default ,"")] readsPrec _ "" = [(Default, "")]
readsPrec _ "available" = [( Default ,"")] readsPrec _ "available" = [(Default, "")]
readsPrec _ "unavailable" = [( Unavailable ,"")] readsPrec _ "unavailable" = [(Unavailable, "")]
readsPrec _ "subscribe" = [( Subscribe ,"")] readsPrec _ "subscribe" = [(Subscribe, "")]
readsPrec _ "subscribed" = [( Subscribed ,"")] readsPrec _ "subscribed" = [(Subscribed, "")]
readsPrec _ "unsubscribe" = [( Unsubscribe ,"")] readsPrec _ "unsubscribe" = [(Unsubscribe, "")]
readsPrec _ "unsubscribed" = [( Unsubscribed ,"")] readsPrec _ "unsubscribed" = [(Unsubscribed, "")]
readsPrec _ "probe" = [( Probe ,"")] readsPrec _ "probe" = [(Probe, "")]
readsPrec _ _ = [] readsPrec _ _ = []
--data ShowType = Available --data ShowType = Available
-- | Away -- | Away
@ -327,22 +275,18 @@ instance Read PresenceType where
-- readsPrec _ _ = [] -- 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 -- stream looks like <stanza-kind to='sender' type='error'>. These errors are
-- wrapped in the @StanzaError@ type. -- wrapped in the @StanzaError@ type.
-- TODO: Sender XML is (optional and is) not yet included.
-- TODO: Sender XML is (optional and is) not included. data StanzaError = StanzaError
data StanzaError = StanzaError { stanzaErrorType :: StanzaErrorType { stanzaErrorType :: StanzaErrorType
, stanzaErrorCondition :: StanzaErrorCondition , stanzaErrorCondition :: StanzaErrorCondition
, stanzaErrorText :: Maybe (Maybe LangTag, Text) , stanzaErrorText :: Maybe (Maybe LangTag, Text)
, stanzaErrorApplicationSpecificCondition :: , stanzaErrorApplicationSpecificCondition :: Maybe Element
Maybe Element } deriving (Eq, Show) } deriving (Eq, Show)
-- | @StanzaError@s always have one of these types.
-- |
-- @StanzaError@s always have one of these types.
data StanzaErrorType = Cancel | -- ^ Error is unrecoverable - do not retry data StanzaErrorType = Cancel | -- ^ Error is unrecoverable - do not retry
Continue | -- ^ Conditition was a warning - proceed Continue | -- ^ Conditition was a warning - proceed
Modify | -- ^ Change the data and retry 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 Wait -- ^ Error is temporary - wait and retry
deriving (Eq) deriving (Eq)
instance Show StanzaErrorType where instance Show StanzaErrorType where
show Cancel = "cancel" show Cancel = "cancel"
show Continue = "continue" show Continue = "continue"
@ -366,48 +309,42 @@ instance Read StanzaErrorType where
readsPrec _ "wait" = [( Wait , "")] readsPrec _ "wait" = [( Wait , "")]
readsPrec _ _ = [] readsPrec _ _ = []
-- | Stanza errors are accommodated with one of the error conditions listed
-- | -- below.
-- Stanza errors are accommodated with one of the error conditions listed below. data StanzaErrorCondition = BadRequest -- ^ Malformed XML.
| Conflict -- ^ Resource or session with
data StanzaErrorCondition = BadRequest | -- ^ Malformed XML -- name already exists.
Conflict | -- ^ Resource or session | FeatureNotImplemented
-- with name already | Forbidden -- ^ Insufficient permissions.
-- exists | Gone -- ^ Entity can no longer be
FeatureNotImplemented | -- contacted at this
Forbidden | -- ^ Insufficient -- address.
-- permissions | InternalServerError
Gone | -- ^ Entity can no longer | ItemNotFound
-- be contacted at this | JIDMalformed
-- address | NotAcceptable -- ^ Does not meet policy
InternalServerError | -- criteria.
ItemNotFound | | NotAllowed -- ^ No entity may perform
JIDMalformed | -- this action.
NotAcceptable | -- ^ Does not meet policy | NotAuthorized -- ^ Must provide proper
-- criteria -- credentials.
NotAllowed | -- ^ No entity may perform | PaymentRequired
-- this action | RecipientUnavailable -- ^ Temporarily unavailable.
NotAuthorized | -- ^ Must provide proper | Redirect -- ^ Redirecting to other
-- credentials -- entity, usually
PaymentRequired | -- temporarily.
RecipientUnavailable | -- ^ Temporarily | RegistrationRequired
-- unavailable | RemoteServerNotFound
Redirect | -- ^ Redirecting to other | RemoteServerTimeout
-- entity, usually | ResourceConstraint -- ^ Entity lacks the
-- temporarily -- necessary system
RegistrationRequired | -- resources.
RemoteServerNotFound | | ServiceUnavailable
RemoteServerTimeout | | SubscriptionRequired
ResourceConstraint | -- ^ Entity lacks the | UndefinedCondition -- ^ Application-specific
-- necessary system -- condition.
-- resources | UnexpectedRequest -- ^ Badly timed request.
ServiceUnavailable | deriving Eq
SubscriptionRequired |
UndefinedCondition | -- ^ Application-specific
-- condition
UnexpectedRequest -- ^ Badly timed request
deriving (Eq)
instance Show StanzaErrorCondition where instance Show StanzaErrorCondition where
show BadRequest = "bad-request" show BadRequest = "bad-request"
@ -468,35 +405,33 @@ data SaslFailure = SaslFailure { saslFailureCondition :: SaslError
) )
} deriving Show } deriving Show
data SaslError = SaslAborted -- ^ Client aborted.
data SaslError = SaslAborted -- ^ Client aborted
| SaslAccountDisabled -- ^ The account has been temporarily | SaslAccountDisabled -- ^ The account has been temporarily
-- disabled -- disabled.
| SaslCredentialsExpired -- ^ The authentication failed because | SaslCredentialsExpired -- ^ The authentication failed because
-- the credentials have expired -- the credentials have expired.
| SaslEncryptionRequired -- ^ The mechanism requested cannot be | SaslEncryptionRequired -- ^ The mechanism requested cannot be
-- used the confidentiality and -- used the confidentiality and
-- integrity of the underlying -- integrity of the underlying
-- stream is protected (typically -- stream is protected (typically
-- with TLS) -- with TLS).
| SaslIncorrectEncoding -- ^ The base64 encoding is incorrect | SaslIncorrectEncoding -- ^ The base64 encoding is incorrect.
| SaslInvalidAuthzid -- ^ The authzid has an incorrect | SaslInvalidAuthzid -- ^ The authzid has an incorrect
-- format or the initiating entity does -- format or the initiating entity
-- not have the appropriate permissions -- does not have the appropriate
-- to authorize that ID -- permissions to authorize that ID.
| SaslInvalidMechanism -- ^ The mechanism is not supported by | SaslInvalidMechanism -- ^ The mechanism is not supported by
-- the receiving entity -- the receiving entity.
| SaslMalformedRequest -- ^ Invalid syntax | SaslMalformedRequest -- ^ Invalid syntax.
| SaslMechanismTooWeak -- ^ The receiving entity policy | SaslMechanismTooWeak -- ^ The receiving entity policy
-- requires a stronger mechanism -- requires a stronger mechanism.
| SaslNotAuthorized -- ^ Invalid credentials | SaslNotAuthorized -- ^ Invalid credentials provided, or
-- provided, or some -- some generic authentication
-- generic authentication -- failure has occurred.
-- failure has occurred
| SaslTemporaryAuthFailure -- ^ There receiving entity reported a | SaslTemporaryAuthFailure -- ^ There receiving entity reported a
-- temporary error condition; the -- temporary error condition; the
-- initiating entity is recommended -- initiating entity is recommended
-- to try again later -- to try again later.
instance Show SaslError where instance Show SaslError where
show SaslAborted = "aborted" show SaslAborted = "aborted"
@ -525,39 +460,36 @@ instance Read SaslError where
readsPrec _ "temporary-auth-failure" = [(SaslTemporaryAuthFailure , "")] readsPrec _ "temporary-auth-failure" = [(SaslTemporaryAuthFailure , "")]
readsPrec _ _ = [] readsPrec _ _ = []
-- | Readability type for host name Texts. -- data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq)
-- type HostName = Text -- This is defined in Network as well
data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq)
-- TODO: document the error cases -- TODO: document the error cases
data StreamErrorCondition = StreamBadFormat data StreamErrorCondition
| StreamBadNamespacePrefix = StreamBadFormat
| StreamConflict | StreamBadNamespacePrefix
| StreamConnectionTimeout | StreamConflict
| StreamHostGone | StreamConnectionTimeout
| StreamHostUnknown | StreamHostGone
| StreamImproperAddressing | StreamHostUnknown
| StreamInternalServerError | StreamImproperAddressing
| StreamInvalidFrom | StreamInternalServerError
| StreamInvalidNamespace | StreamInvalidFrom
| StreamInvalidXml | StreamInvalidNamespace
| StreamNotAuthorized | StreamInvalidXml
| StreamNotWellFormed | StreamNotAuthorized
| StreamPolicyViolation | StreamNotWellFormed
| StreamRemoteConnectionFailed | StreamPolicyViolation
| StreamReset | StreamRemoteConnectionFailed
| StreamResourceConstraint | StreamReset
| StreamRestrictedXml | StreamResourceConstraint
| StreamSeeOtherHost | StreamRestrictedXml
| StreamSystemShutdown | StreamSeeOtherHost
| StreamUndefinedCondition | StreamSystemShutdown
| StreamUnsupportedEncoding | StreamUndefinedCondition
| StreamUnsupportedFeature | StreamUnsupportedEncoding
| StreamUnsupportedStanzaType | StreamUnsupportedFeature
| StreamUnsupportedVersion | StreamUnsupportedStanzaType
deriving Eq | StreamUnsupportedVersion
deriving Eq
instance Show StreamErrorCondition where instance Show StreamErrorCondition where
show StreamBadFormat = "bad-format" show StreamBadFormat = "bad-format"
@ -587,45 +519,46 @@ instance Show StreamErrorCondition where
show StreamUnsupportedVersion = "unsupported-version" show StreamUnsupportedVersion = "unsupported-version"
instance Read StreamErrorCondition where instance Read StreamErrorCondition where
readsPrec _ "bad-format" = [(StreamBadFormat , "")] readsPrec _ "bad-format" = [(StreamBadFormat , "")]
readsPrec _ "bad-namespace-prefix" = [(StreamBadNamespacePrefix , "")] readsPrec _ "bad-namespace-prefix" = [(StreamBadNamespacePrefix , "")]
readsPrec _ "conflict" = [(StreamConflict , "")] readsPrec _ "conflict" = [(StreamConflict , "")]
readsPrec _ "connection-timeout" = [(StreamConnectionTimeout , "")] readsPrec _ "connection-timeout" = [(StreamConnectionTimeout , "")]
readsPrec _ "host-gone" = [(StreamHostGone , "")] readsPrec _ "host-gone" = [(StreamHostGone , "")]
readsPrec _ "host-unknown" = [(StreamHostUnknown , "")] readsPrec _ "host-unknown" = [(StreamHostUnknown , "")]
readsPrec _ "improper-addressing" = [(StreamImproperAddressing , "")] readsPrec _ "improper-addressing" = [(StreamImproperAddressing , "")]
readsPrec _ "internal-server-error" = [(StreamInternalServerError , "")] readsPrec _ "internal-server-error" = [(StreamInternalServerError , "")]
readsPrec _ "invalid-from" = [(StreamInvalidFrom , "")] readsPrec _ "invalid-from" = [(StreamInvalidFrom , "")]
readsPrec _ "invalid-namespace" = [(StreamInvalidNamespace , "")] readsPrec _ "invalid-namespace" = [(StreamInvalidNamespace , "")]
readsPrec _ "invalid-xml" = [(StreamInvalidXml , "")] readsPrec _ "invalid-xml" = [(StreamInvalidXml , "")]
readsPrec _ "not-authorized" = [(StreamNotAuthorized , "")] readsPrec _ "not-authorized" = [(StreamNotAuthorized , "")]
readsPrec _ "not-well-formed" = [(StreamNotWellFormed , "")] readsPrec _ "not-well-formed" = [(StreamNotWellFormed , "")]
readsPrec _ "policy-violation" = [(StreamPolicyViolation , "")] readsPrec _ "policy-violation" = [(StreamPolicyViolation , "")]
readsPrec _ "remote-connection-failed" = [(StreamRemoteConnectionFailed , "")] readsPrec _ "remote-connection-failed" =
readsPrec _ "reset" = [(StreamReset , "")] [(StreamRemoteConnectionFailed, "")]
readsPrec _ "resource-constraint" = [(StreamResourceConstraint , "")] readsPrec _ "reset" = [(StreamReset , "")]
readsPrec _ "restricted-xml" = [(StreamRestrictedXml , "")] readsPrec _ "resource-constraint" = [(StreamResourceConstraint , "")]
readsPrec _ "see-other-host" = [(StreamSeeOtherHost , "")] readsPrec _ "restricted-xml" = [(StreamRestrictedXml , "")]
readsPrec _ "system-shutdown" = [(StreamSystemShutdown , "")] readsPrec _ "see-other-host" = [(StreamSeeOtherHost , "")]
readsPrec _ "undefined-condition" = [(StreamUndefinedCondition , "")] readsPrec _ "system-shutdown" = [(StreamSystemShutdown , "")]
readsPrec _ "unsupported-encoding" = [(StreamUnsupportedEncoding , "")] readsPrec _ "undefined-condition" = [(StreamUndefinedCondition , "")]
readsPrec _ "unsupported-feature" = [(StreamUnsupportedFeature , "")] readsPrec _ "unsupported-encoding" = [(StreamUnsupportedEncoding , "")]
readsPrec _ "unsupported-stanza-type" = [(StreamUnsupportedStanzaType , "")] readsPrec _ "unsupported-feature" = [(StreamUnsupportedFeature , "")]
readsPrec _ "unsupported-version" = [(StreamUnsupportedVersion , "")] readsPrec _ "unsupported-stanza-type" = [(StreamUnsupportedStanzaType, "")]
readsPrec _ _ = [(StreamUndefinedCondition , "")] readsPrec _ "unsupported-version" = [(StreamUnsupportedVersion , "")]
readsPrec _ _ = [(StreamUndefinedCondition , "")]
data XmppStreamError = XmppStreamError data XmppStreamError = XmppStreamError
{ errorCondition :: StreamErrorCondition { errorCondition :: StreamErrorCondition
, errorText :: Maybe (Maybe LangTag, Text) , errorText :: Maybe (Maybe LangTag, Text)
, errorXML :: Maybe Element , errorXML :: Maybe Element
} deriving (Show, Eq) } deriving (Show, Eq)
data StreamError = StreamError XmppStreamError data StreamError = StreamError XmppStreamError
| StreamWrongVersion Text | StreamWrongVersion Text
| StreamXMLError String | StreamXMLError String -- If stream pickling goes wrong.
| StreamConnectionError | StreamConnectionError
deriving (Show, Eq, Typeable) deriving (Show, Eq, Typeable)
instance Exception StreamError instance Exception StreamError
instance Error StreamError where noMsg = StreamConnectionError instance Error StreamError where noMsg = StreamConnectionError
@ -641,39 +574,33 @@ instance Error StreamError where noMsg = StreamConnectionError
newtype IdGenerator = IdGenerator (IO Text) newtype IdGenerator = IdGenerator (IO Text)
--- other stuff -- Version numbers are displayed as "<major>.<minor>".
data Version = Version { majorVersion :: Integer data Version = Version { majorVersion :: Integer
, minorVersion :: Integer } deriving (Eq) , minorVersion :: Integer } deriving (Eq)
-- Version numbers are displayed as "<major>.<minor>".
instance Show Version where instance Show Version where
show (Version major minor) = (show major) ++ "." ++ (show minor) show (Version major minor) = (show major) ++ "." ++ (show minor)
-- If the major version numbers are not equal, compare them. Otherwise, compare -- If the major version numbers are not equal, compare them. Otherwise, compare
-- the minor version numbers. -- the minor version numbers.
instance Ord Version where instance Ord Version where
compare (Version amajor aminor) (Version bmajor bminor) compare (Version amajor aminor) (Version bmajor bminor)
| amajor /= bmajor = compare amajor bmajor | amajor /= bmajor = compare amajor bmajor
| otherwise = compare aminor bminor | 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 data LangTag = LangTag { primaryTag :: Text
, subtags :: [Text] } , subtags :: [Text] }
deriving (Eq) -- TODO: remove deriving (Eq) -- TODO: remove
-- Displays the language tag in the form of "en-US".
instance Show LangTag where instance Show LangTag where
show (LangTag p []) = Text.unpack p show (LangTag p []) = Text.unpack p
show (LangTag p s) = Text.unpack . Text.concat show (LangTag p s) = Text.unpack . Text.concat
$ [p, "-", Text.intercalate "-" s] -- TODO: clean up $ [p, "-", Text.intercalate "-" s] -- TODO: clean up
-- Parses a Text string to a list of LangTag objects. TODO: Why?
parseLangTag :: Text -> [LangTag] parseLangTag :: Text -> [LangTag]
parseLangTag txt = case Text.splitOn "-" txt of parseLangTag txt = case Text.splitOn "-" txt of
[] -> [] [] -> []
@ -682,9 +609,8 @@ parseLangTag txt = case Text.splitOn "-" txt of
instance Read LangTag where instance Read LangTag where
readsPrec _ txt = (,"") <$> (parseLangTag $ Text.pack txt) readsPrec _ txt = (,"") <$> (parseLangTag $ Text.pack txt)
-- Two language tags are considered equal of they contain the same tags (case-insensitive). -- Two language tags are considered equal of they contain the same tags
-- (case-insensitive).
-- TODO: port
-- instance Eq LangTag where -- instance Eq LangTag where
-- (LangTag ap as) == (LangTag bp bs) -- (LangTag ap as) == (LangTag bp bs)
@ -693,20 +619,17 @@ instance Read LangTag where
-- | otherwise = False -- | otherwise = False
data ServerFeatures = SF data ServerFeatures = SF
{ stls :: Maybe Bool { stls :: Maybe Bool
, saslMechanisms :: [Text.Text] , saslMechanisms :: [Text.Text]
, other :: [Element] , other :: [Element]
} deriving Show } deriving Show
data XmppConnectionState = XmppConnectionClosed -- ^ No connection at data XmppConnectionState
-- this point = XmppConnectionClosed -- ^ No connection at this point.
| XmppConnectionPlain -- ^ Connection | XmppConnectionPlain -- ^ Connection established, but not secured.
-- established, but | XmppConnectionSecured -- ^ Connection established and secured via TLS.
-- not secured deriving (Show, Eq, Typeable)
| XmppConnectionSecured -- ^ Connection
-- established and
-- secured via TLS
deriving (Show, Eq, Typeable)
data XmppConnection = XmppConnection data XmppConnection = XmppConnection
{ sConSrc :: Source IO Event { sConSrc :: Source IO Event
, sRawSrc :: Source IO BS.ByteString , sRawSrc :: Source IO BS.ByteString
@ -725,12 +648,11 @@ data XmppConnection = XmppConnection
-- The XMPP monad transformer. Contains internal state in order to -- The XMPP monad transformer. Contains internal state in order to
-- work with Pontarius. Pontarius clients needs to operate in this -- work with Pontarius. Pontarius clients needs to operate in this
-- context. -- context.
newtype XMPPT m a = XMPPT { runXMPPT :: StateT XmppConnection m a } deriving (Monad, MonadIO) 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 type XMPPConMonad a = StateT XmppConnection IO a
-- Make XMPPT derive the Monad and MonadIO instances. -- 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)

Write Preview
Loading…
Cancel
Save