{-# OPTIONS_HADDOCK hide #-}
module Network.Xmpp.Concurrent.Basic where

import           Control.Applicative
import           Control.Concurrent.STM
import qualified Control.Exception as Ex
import           Control.Monad.State.Strict
import qualified Data.ByteString as BS
import           Network.Xmpp.Concurrent.Types
import           Network.Xmpp.Marshal
import           Network.Xmpp.Stream
import           Network.Xmpp.Types
import           Network.Xmpp.Utilities

semWrite :: WriteSemaphore -> BS.ByteString -> IO (Either XmppFailure ())
semWrite :: WriteSemaphore -> ByteString -> IO (Either XmppFailure ())
semWrite WriteSemaphore
sem ByteString
bs = IO (ByteString -> IO (Either XmppFailure ()))
-> ((ByteString -> IO (Either XmppFailure ())) -> IO ())
-> ((ByteString -> IO (Either XmppFailure ()))
    -> IO (Either XmppFailure ()))
-> IO (Either XmppFailure ())
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Ex.bracket (STM (ByteString -> IO (Either XmppFailure ()))
-> IO (ByteString -> IO (Either XmppFailure ()))
forall a. STM a -> IO a
atomically (STM (ByteString -> IO (Either XmppFailure ()))
 -> IO (ByteString -> IO (Either XmppFailure ())))
-> STM (ByteString -> IO (Either XmppFailure ()))
-> IO (ByteString -> IO (Either XmppFailure ()))
forall a b. (a -> b) -> a -> b
$ WriteSemaphore -> STM (ByteString -> IO (Either XmppFailure ()))
forall a. TMVar a -> STM a
takeTMVar WriteSemaphore
sem)
                          (STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> ((ByteString -> IO (Either XmppFailure ())) -> STM ())
-> (ByteString -> IO (Either XmppFailure ()))
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriteSemaphore
-> (ByteString -> IO (Either XmppFailure ())) -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar WriteSemaphore
sem)
                          ((ByteString -> IO (Either XmppFailure ()))
-> ByteString -> IO (Either XmppFailure ())
forall a b. (a -> b) -> a -> b
$ ByteString
bs)

writeXmppElem :: WriteSemaphore -> XmppElement -> IO (Either XmppFailure ())
writeXmppElem :: WriteSemaphore -> XmppElement -> IO (Either XmppFailure ())
writeXmppElem WriteSemaphore
sem XmppElement
a = do
    let el :: Element
el = case XmppElement
a of
                 XmppStanza Stanza
s -> PU [Node] Stanza -> Stanza -> Element
forall a. PU [Node] a -> a -> Element
pickleElem PU [Node] Stanza
xpStanza Stanza
s
                 XmppNonza Element
n -> Element
n
        outData :: ByteString
outData = Element -> ByteString
renderElement (Element -> ByteString) -> Element -> ByteString
forall a b. (a -> b) -> a -> b
$ Element -> Element
nsHack Element
el
    ByteString -> IO ()
forall (m :: * -> *). MonadIO m => ByteString -> m ()
debugOut ByteString
outData
    WriteSemaphore -> ByteString -> IO (Either XmppFailure ())
semWrite WriteSemaphore
sem ByteString
outData

writeStanza :: WriteSemaphore -> Stanza -> IO (Either XmppFailure ())
writeStanza :: WriteSemaphore -> Stanza -> IO (Either XmppFailure ())
writeStanza WriteSemaphore
sem Stanza
a = do
    let outData :: ByteString
outData = Element -> ByteString
renderElement (Element -> ByteString) -> Element -> ByteString
forall a b. (a -> b) -> a -> b
$ Element -> Element
nsHack (PU [Node] Stanza -> Stanza -> Element
forall a. PU [Node] a -> a -> Element
pickleElem PU [Node] Stanza
xpStanza Stanza
a)
    ByteString -> IO ()
forall (m :: * -> *). MonadIO m => ByteString -> m ()
debugOut ByteString
outData
    WriteSemaphore -> ByteString -> IO (Either XmppFailure ())
semWrite WriteSemaphore
sem ByteString
outData


-- | Send a stanza to the server without running plugins. (The stanza is sent as
-- is)
sendRawStanza :: Stanza -> Session -> IO (Either XmppFailure ())
sendRawStanza :: Stanza -> Session -> IO (Either XmppFailure ())
sendRawStanza Stanza
a Session
session = WriteSemaphore -> Stanza -> IO (Either XmppFailure ())
writeStanza (Session -> WriteSemaphore
writeSemaphore Session
session) Stanza
a

-- | Send a stanza to the server, managed by plugins
sendStanza :: Stanza -> Session -> IO (Either XmppFailure ())
sendStanza :: Stanza -> Session -> IO (Either XmppFailure ())
sendStanza = (Session -> Stanza -> IO (Either XmppFailure ()))
-> Stanza -> Session -> IO (Either XmppFailure ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip Session -> Stanza -> IO (Either XmppFailure ())
sendStanza'

-- | Get the channel of incoming stanzas.
getStanzaChan :: Session -> TChan (Stanza, [Annotation])
getStanzaChan :: Session -> TChan (Stanza, [Annotation])
getStanzaChan Session
session = Session -> TChan (Stanza, [Annotation])
stanzaCh Session
session

-- | Get the next incoming stanza
getStanza :: Session -> IO (Stanza, [Annotation])
getStanza :: Session -> IO (Stanza, [Annotation])
getStanza Session
session = STM (Stanza, [Annotation]) -> IO (Stanza, [Annotation])
forall a. STM a -> IO a
atomically (STM (Stanza, [Annotation]) -> IO (Stanza, [Annotation]))
-> (TChan (Stanza, [Annotation]) -> STM (Stanza, [Annotation]))
-> TChan (Stanza, [Annotation])
-> IO (Stanza, [Annotation])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan (Stanza, [Annotation]) -> STM (Stanza, [Annotation])
forall a. TChan a -> STM a
readTChan (TChan (Stanza, [Annotation]) -> IO (Stanza, [Annotation]))
-> TChan (Stanza, [Annotation]) -> IO (Stanza, [Annotation])
forall a b. (a -> b) -> a -> b
$ Session -> TChan (Stanza, [Annotation])
stanzaCh Session
session

-- | Duplicate the inbound channel of the session object. Most receiving
-- functions discard stanzas they are not interested in from the inbound
-- channel. Duplicating the channel ensures that those stanzas can aren't lost
-- and can still be handled somewhere else.
dupSession :: Session -> IO Session
dupSession :: Session -> IO Session
dupSession Session
session = do
    TChan (Stanza, [Annotation])
stanzaCh' <- STM (TChan (Stanza, [Annotation]))
-> IO (TChan (Stanza, [Annotation]))
forall a. STM a -> IO a
atomically (STM (TChan (Stanza, [Annotation]))
 -> IO (TChan (Stanza, [Annotation])))
-> STM (TChan (Stanza, [Annotation]))
-> IO (TChan (Stanza, [Annotation]))
forall a b. (a -> b) -> a -> b
$ TChan (Stanza, [Annotation]) -> STM (TChan (Stanza, [Annotation]))
forall a. TChan a -> STM (TChan a)
cloneTChan (Session -> TChan (Stanza, [Annotation])
stanzaCh Session
session)
    Session -> IO Session
forall (m :: * -> *) a. Monad m => a -> m a
return (Session -> IO Session) -> Session -> IO Session
forall a b. (a -> b) -> a -> b
$ Session
session {stanzaCh :: TChan (Stanza, [Annotation])
stanzaCh = TChan (Stanza, [Annotation])
stanzaCh'}

-- | Return the JID assigned to us by the server
getJid :: Session -> IO (Maybe Jid)
getJid :: Session -> IO (Maybe Jid)
getJid Session{streamRef :: Session -> TMVar Stream
streamRef = TMVar Stream
st} = do
    Stream
s <- STM Stream -> IO Stream
forall a. STM a -> IO a
atomically (STM Stream -> IO Stream) -> STM Stream -> IO Stream
forall a b. (a -> b) -> a -> b
$ TMVar Stream -> STM Stream
forall a. TMVar a -> STM a
readTMVar TMVar Stream
st
    StateT StreamState IO (Maybe Jid) -> Stream -> IO (Maybe Jid)
forall a. StateT StreamState IO a -> Stream -> IO a
withStream' ((StreamState -> Maybe Jid) -> StateT StreamState IO (Maybe Jid)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StreamState -> Maybe Jid
streamJid) Stream
s

-- | Return the stream features the server announced
getFeatures :: Session -> IO StreamFeatures
getFeatures :: Session -> IO StreamFeatures
getFeatures Session{streamRef :: Session -> TMVar Stream
streamRef = TMVar Stream
st} = do
    Stream
s <- STM Stream -> IO Stream
forall a. STM a -> IO a
atomically (STM Stream -> IO Stream) -> STM Stream -> IO Stream
forall a b. (a -> b) -> a -> b
$ TMVar Stream -> STM Stream
forall a. TMVar a -> STM a
readTMVar TMVar Stream
st
    StateT StreamState IO StreamFeatures -> Stream -> IO StreamFeatures
forall a. StateT StreamState IO a -> Stream -> IO a
withStream' ((StreamState -> StreamFeatures)
-> StateT StreamState IO StreamFeatures
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StreamState -> StreamFeatures
streamFeatures) Stream
s

-- | Wait until the connection of the stream is re-established
waitForStream :: Session -> IO ()
waitForStream :: Session -> IO ()
waitForStream Session{streamRef :: Session -> TMVar Stream
streamRef = TMVar Stream
sr} = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Stream
s <- TMVar Stream -> STM Stream
forall a. TMVar a -> STM a
readTMVar TMVar Stream
sr
    StreamState
ss <- TMVar StreamState -> STM StreamState
forall a. TMVar a -> STM a
readTMVar (TMVar StreamState -> STM StreamState)
-> TMVar StreamState -> STM StreamState
forall a b. (a -> b) -> a -> b
$ Stream -> TMVar StreamState
unStream Stream
s
    case StreamState -> ConnectionState
streamConnectionState StreamState
ss of
        ConnectionState
Plain -> () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        ConnectionState
Secured -> () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        ConnectionState
_ -> STM ()
forall a. STM a
retry

streamState :: Session -> STM ConnectionState
streamState :: Session -> STM ConnectionState
streamState Session{streamRef :: Session -> TMVar Stream
streamRef = TMVar Stream
sr}  = do
    Stream
s <- TMVar Stream -> STM Stream
forall a. TMVar a -> STM a
readTMVar TMVar Stream
sr
    StreamState -> ConnectionState
streamConnectionState (StreamState -> ConnectionState)
-> STM StreamState -> STM ConnectionState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TMVar StreamState -> STM StreamState
forall a. TMVar a -> STM a
readTMVar (TMVar StreamState -> STM StreamState)
-> TMVar StreamState -> STM StreamState
forall a b. (a -> b) -> a -> b
$ Stream -> TMVar StreamState
unStream Stream
s)