{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_HADDOCK hide #-}
module Network.Xmpp.Concurrent.IQ where
import Control.Applicative ((<$>))
import Control.Concurrent (forkIO)
import Control.Concurrent.STM
import Control.Concurrent.Thread.Delay (delay)
import Control.Monad
import Control.Monad.Except
import Control.Monad.Trans
import qualified Data.Map as Map
import qualified Data.Map.Strict as Map.Strict
import Data.Maybe
import Data.Text (Text)
import Data.XML.Pickle
import Data.XML.Types
import Lens.Family2 (toListOf, (&), (^.))
import Network.Xmpp.Concurrent.Basic
import Network.Xmpp.Concurrent.Types
import Network.Xmpp.Lens
import Network.Xmpp.Stanza
import Network.Xmpp.Types
import System.Log.Logger
sendIQ :: Maybe Integer
-> Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> [ExtendedAttribute]
-> Session
-> IO (Either XmppFailure (STM (Maybe (Annotated IQResponse))))
sendIQ :: Maybe Integer
-> Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> [ExtendedAttribute]
-> Session
-> IO (Either XmppFailure (STM (Maybe (Annotated IQResponse))))
sendIQ Maybe Integer
timeOut Maybe Jid
t IQRequestType
tp Maybe LangTag
lang Element
body [ExtendedAttribute]
attrs Session
session = do
Text
newId <- Session -> IO Text
idGenerator Session
session
Either (Maybe Jid) Jid
j <- case Maybe Jid
t of
Just Jid
t -> Either (Maybe Jid) Jid -> IO (Either (Maybe Jid) Jid)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Maybe Jid) Jid -> IO (Either (Maybe Jid) Jid))
-> Either (Maybe Jid) Jid -> IO (Either (Maybe Jid) Jid)
forall a b. (a -> b) -> a -> b
$ Jid -> Either (Maybe Jid) Jid
forall a b. b -> Either a b
Right Jid
t
Maybe Jid
Nothing -> Maybe Jid -> Either (Maybe Jid) Jid
forall a b. a -> Either a b
Left (Maybe Jid -> Either (Maybe Jid) Jid)
-> IO (Maybe Jid) -> IO (Either (Maybe Jid) Jid)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session -> IO (Maybe Jid)
getJid Session
session
TMVar (Maybe (Annotated IQResponse))
ref <- STM (TMVar (Maybe (Annotated IQResponse)))
-> IO (TMVar (Maybe (Annotated IQResponse)))
forall a. STM a -> IO a
atomically (STM (TMVar (Maybe (Annotated IQResponse)))
-> IO (TMVar (Maybe (Annotated IQResponse))))
-> STM (TMVar (Maybe (Annotated IQResponse)))
-> IO (TMVar (Maybe (Annotated IQResponse)))
forall a b. (a -> b) -> a -> b
$ do
TMVar (Maybe (Annotated IQResponse))
resRef <- STM (TMVar (Maybe (Annotated IQResponse)))
forall a. STM (TMVar a)
newEmptyTMVar
let value :: (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
value = (Either (Maybe Jid) Jid
j, TMVar (Maybe (Annotated IQResponse))
resRef)
(Map (IQRequestType, Text) (TChan IQRequestTicket)
byNS, Map
Text (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
byId) <- TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
-> STM
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
forall a. TVar a -> STM a
readTVar (Session
-> TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
iqHandlers Session
session)
TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
-> (Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
-> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Session
-> TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
iqHandlers Session
session) (Map (IQRequestType, Text) (TChan IQRequestTicket)
byNS, Text
-> (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
-> Map
Text (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
-> Map
Text (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
newId (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
value Map
Text (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
byId)
TMVar (Maybe (Annotated IQResponse))
-> STM (TMVar (Maybe (Annotated IQResponse)))
forall (m :: * -> *) a. Monad m => a -> m a
return TMVar (Maybe (Annotated IQResponse))
resRef
Either XmppFailure ()
res <- Stanza -> Session -> IO (Either XmppFailure ())
sendStanza (IQRequest -> Stanza
IQRequestS (IQRequest -> Stanza) -> IQRequest -> Stanza
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Jid
-> Maybe Jid
-> Maybe LangTag
-> IQRequestType
-> Element
-> [ExtendedAttribute]
-> IQRequest
IQRequest Text
newId Maybe Jid
forall a. Maybe a
Nothing Maybe Jid
t Maybe LangTag
lang IQRequestType
tp Element
body [ExtendedAttribute]
attrs)
Session
session
case Either XmppFailure ()
res of
Right () -> do
case Maybe Integer
timeOut of
Maybe Integer
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Integer
t -> IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Integer -> IO ()
delay Integer
t
TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
-> Text -> TMVar (Maybe (Annotated IQResponse)) -> IO ()
doTimeOut (Session
-> TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
iqHandlers Session
session) Text
newId TMVar (Maybe (Annotated IQResponse))
ref
Either XmppFailure (STM (Maybe (Annotated IQResponse)))
-> IO (Either XmppFailure (STM (Maybe (Annotated IQResponse))))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure (STM (Maybe (Annotated IQResponse)))
-> IO (Either XmppFailure (STM (Maybe (Annotated IQResponse)))))
-> (STM (Maybe (Annotated IQResponse))
-> Either XmppFailure (STM (Maybe (Annotated IQResponse))))
-> STM (Maybe (Annotated IQResponse))
-> IO (Either XmppFailure (STM (Maybe (Annotated IQResponse))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Maybe (Annotated IQResponse))
-> Either XmppFailure (STM (Maybe (Annotated IQResponse)))
forall a b. b -> Either a b
Right (STM (Maybe (Annotated IQResponse))
-> IO (Either XmppFailure (STM (Maybe (Annotated IQResponse)))))
-> STM (Maybe (Annotated IQResponse))
-> IO (Either XmppFailure (STM (Maybe (Annotated IQResponse))))
forall a b. (a -> b) -> a -> b
$ TMVar (Maybe (Annotated IQResponse))
-> STM (Maybe (Annotated IQResponse))
forall a. TMVar a -> STM a
readTMVar TMVar (Maybe (Annotated IQResponse))
ref
Left XmppFailure
e -> Either XmppFailure (STM (Maybe (Annotated IQResponse)))
-> IO (Either XmppFailure (STM (Maybe (Annotated IQResponse))))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure (STM (Maybe (Annotated IQResponse)))
-> IO (Either XmppFailure (STM (Maybe (Annotated IQResponse)))))
-> Either XmppFailure (STM (Maybe (Annotated IQResponse)))
-> IO (Either XmppFailure (STM (Maybe (Annotated IQResponse))))
forall a b. (a -> b) -> a -> b
$ XmppFailure
-> Either XmppFailure (STM (Maybe (Annotated IQResponse)))
forall a b. a -> Either a b
Left XmppFailure
e
where
doTimeOut :: TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
-> Text -> TMVar (Maybe (Annotated IQResponse)) -> IO ()
doTimeOut TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
handlers Text
iqid TMVar (Maybe (Annotated IQResponse))
var = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Bool
p <- TMVar (Maybe (Annotated IQResponse))
-> Maybe (Annotated IQResponse) -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar (Maybe (Annotated IQResponse))
var Maybe (Annotated IQResponse)
forall a. Maybe a
Nothing
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
p (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ do
(Map (IQRequestType, Text) (TChan IQRequestTicket)
byNS, Map
Text (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
byId) <- TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
-> STM
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
forall a. TVar a -> STM a
readTVar (Session
-> TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
iqHandlers Session
session)
TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
-> (Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
-> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
handlers (Map (IQRequestType, Text) (TChan IQRequestTicket)
byNS, Text
-> Map
Text (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
-> Map
Text (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
iqid Map
Text (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
byId)
() -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
sendIQA' :: Maybe Integer
-> Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> [ExtendedAttribute]
-> Session
-> IO (Either IQSendError (Annotated IQResponse))
sendIQA' :: Maybe Integer
-> Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> [ExtendedAttribute]
-> Session
-> IO (Either IQSendError (Annotated IQResponse))
sendIQA' Maybe Integer
timeout Maybe Jid
to IQRequestType
tp Maybe LangTag
lang Element
body [ExtendedAttribute]
attrs Session
session = do
Either XmppFailure (STM (Maybe (Annotated IQResponse)))
ref <- Maybe Integer
-> Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> [ExtendedAttribute]
-> Session
-> IO (Either XmppFailure (STM (Maybe (Annotated IQResponse))))
sendIQ Maybe Integer
timeout Maybe Jid
to IQRequestType
tp Maybe LangTag
lang Element
body [ExtendedAttribute]
attrs Session
session
(XmppFailure -> IO (Either IQSendError (Annotated IQResponse)))
-> (STM (Maybe (Annotated IQResponse))
-> IO (Either IQSendError (Annotated IQResponse)))
-> Either XmppFailure (STM (Maybe (Annotated IQResponse)))
-> IO (Either IQSendError (Annotated IQResponse))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either IQSendError (Annotated IQResponse)
-> IO (Either IQSendError (Annotated IQResponse))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either IQSendError (Annotated IQResponse)
-> IO (Either IQSendError (Annotated IQResponse)))
-> (XmppFailure -> Either IQSendError (Annotated IQResponse))
-> XmppFailure
-> IO (Either IQSendError (Annotated IQResponse))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IQSendError -> Either IQSendError (Annotated IQResponse)
forall a b. a -> Either a b
Left (IQSendError -> Either IQSendError (Annotated IQResponse))
-> (XmppFailure -> IQSendError)
-> XmppFailure
-> Either IQSendError (Annotated IQResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmppFailure -> IQSendError
IQSendError) ((Maybe (Annotated IQResponse)
-> Either IQSendError (Annotated IQResponse))
-> IO (Maybe (Annotated IQResponse))
-> IO (Either IQSendError (Annotated IQResponse))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Either IQSendError (Annotated IQResponse)
-> (Annotated IQResponse
-> Either IQSendError (Annotated IQResponse))
-> Maybe (Annotated IQResponse)
-> Either IQSendError (Annotated IQResponse)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IQSendError -> Either IQSendError (Annotated IQResponse)
forall a b. a -> Either a b
Left IQSendError
IQTimeOut) Annotated IQResponse -> Either IQSendError (Annotated IQResponse)
forall a b. b -> Either a b
Right)
(IO (Maybe (Annotated IQResponse))
-> IO (Either IQSendError (Annotated IQResponse)))
-> (STM (Maybe (Annotated IQResponse))
-> IO (Maybe (Annotated IQResponse)))
-> STM (Maybe (Annotated IQResponse))
-> IO (Either IQSendError (Annotated IQResponse))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Maybe (Annotated IQResponse))
-> IO (Maybe (Annotated IQResponse))
forall a. STM a -> IO a
atomically) Either XmppFailure (STM (Maybe (Annotated IQResponse)))
ref
sendIQ' :: Maybe Integer
-> Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> [ExtendedAttribute]
-> Session
-> IO (Either IQSendError IQResponse)
sendIQ' :: Maybe Integer
-> Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> [ExtendedAttribute]
-> Session
-> IO (Either IQSendError IQResponse)
sendIQ' Maybe Integer
timeout Maybe Jid
to IQRequestType
tp Maybe LangTag
lang Element
body [ExtendedAttribute]
attrs Session
session =
(Annotated IQResponse -> IQResponse)
-> Either IQSendError (Annotated IQResponse)
-> Either IQSendError IQResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Annotated IQResponse -> IQResponse
forall a b. (a, b) -> a
fst (Either IQSendError (Annotated IQResponse)
-> Either IQSendError IQResponse)
-> IO (Either IQSendError (Annotated IQResponse))
-> IO (Either IQSendError IQResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer
-> Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> [ExtendedAttribute]
-> Session
-> IO (Either IQSendError (Annotated IQResponse))
sendIQA' Maybe Integer
timeout Maybe Jid
to IQRequestType
tp Maybe LangTag
lang Element
body [ExtendedAttribute]
attrs Session
session
listenIQ :: IQRequestType
-> Text
-> Session
-> IO (Either (STM IQRequestTicket) (STM IQRequestTicket))
listenIQ :: IQRequestType
-> Text
-> Session
-> IO (Either (STM IQRequestTicket) (STM IQRequestTicket))
listenIQ IQRequestType
tp Text
ns Session
session = do
let handlers :: TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
handlers = (Session
-> TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
iqHandlers Session
session)
STM (Either (STM IQRequestTicket) (STM IQRequestTicket))
-> IO (Either (STM IQRequestTicket) (STM IQRequestTicket))
forall a. STM a -> IO a
atomically (STM (Either (STM IQRequestTicket) (STM IQRequestTicket))
-> IO (Either (STM IQRequestTicket) (STM IQRequestTicket)))
-> STM (Either (STM IQRequestTicket) (STM IQRequestTicket))
-> IO (Either (STM IQRequestTicket) (STM IQRequestTicket))
forall a b. (a -> b) -> a -> b
$ do
(Map (IQRequestType, Text) (TChan IQRequestTicket)
byNS, Map
Text (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
byID) <- TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
-> STM
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
forall a. TVar a -> STM a
readTVar TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
handlers
TChan IQRequestTicket
iqCh <- STM (TChan IQRequestTicket)
forall a. STM (TChan a)
newTChan
let (Maybe (TChan IQRequestTicket)
present, Map (IQRequestType, Text) (TChan IQRequestTicket)
byNS') = ((IQRequestType, Text)
-> TChan IQRequestTicket
-> TChan IQRequestTicket
-> TChan IQRequestTicket)
-> (IQRequestType, Text)
-> TChan IQRequestTicket
-> Map (IQRequestType, Text) (TChan IQRequestTicket)
-> (Maybe (TChan IQRequestTicket),
Map (IQRequestType, Text) (TChan IQRequestTicket))
forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)
Map.Strict.insertLookupWithKey
(\(IQRequestType, Text)
_ TChan IQRequestTicket
_ TChan IQRequestTicket
old -> TChan IQRequestTicket
old)
(IQRequestType
tp, Text
ns)
TChan IQRequestTicket
iqCh
Map (IQRequestType, Text) (TChan IQRequestTicket)
byNS
TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
-> (Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
-> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
handlers (Map (IQRequestType, Text) (TChan IQRequestTicket)
byNS', Map
Text (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
byID)
case Maybe (TChan IQRequestTicket)
present of
Maybe (TChan IQRequestTicket)
Nothing -> Either (STM IQRequestTicket) (STM IQRequestTicket)
-> STM (Either (STM IQRequestTicket) (STM IQRequestTicket))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (STM IQRequestTicket) (STM IQRequestTicket)
-> STM (Either (STM IQRequestTicket) (STM IQRequestTicket)))
-> (STM IQRequestTicket
-> Either (STM IQRequestTicket) (STM IQRequestTicket))
-> STM IQRequestTicket
-> STM (Either (STM IQRequestTicket) (STM IQRequestTicket))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM IQRequestTicket
-> Either (STM IQRequestTicket) (STM IQRequestTicket)
forall a b. b -> Either a b
Right (STM IQRequestTicket
-> STM (Either (STM IQRequestTicket) (STM IQRequestTicket)))
-> STM IQRequestTicket
-> STM (Either (STM IQRequestTicket) (STM IQRequestTicket))
forall a b. (a -> b) -> a -> b
$ TChan IQRequestTicket -> STM IQRequestTicket
forall a. TChan a -> STM a
readTChan TChan IQRequestTicket
iqCh
Just TChan IQRequestTicket
iqCh' -> do
TChan IQRequestTicket
clonedChan <- TChan IQRequestTicket -> STM (TChan IQRequestTicket)
forall a. TChan a -> STM (TChan a)
cloneTChan TChan IQRequestTicket
iqCh'
Either (STM IQRequestTicket) (STM IQRequestTicket)
-> STM (Either (STM IQRequestTicket) (STM IQRequestTicket))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (STM IQRequestTicket) (STM IQRequestTicket)
-> STM (Either (STM IQRequestTicket) (STM IQRequestTicket)))
-> (STM IQRequestTicket
-> Either (STM IQRequestTicket) (STM IQRequestTicket))
-> STM IQRequestTicket
-> STM (Either (STM IQRequestTicket) (STM IQRequestTicket))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM IQRequestTicket
-> Either (STM IQRequestTicket) (STM IQRequestTicket)
forall a b. a -> Either a b
Left (STM IQRequestTicket
-> STM (Either (STM IQRequestTicket) (STM IQRequestTicket)))
-> STM IQRequestTicket
-> STM (Either (STM IQRequestTicket) (STM IQRequestTicket))
forall a b. (a -> b) -> a -> b
$ TChan IQRequestTicket -> STM IQRequestTicket
forall a. TChan a -> STM a
readTChan TChan IQRequestTicket
clonedChan
unlistenIQ :: IQRequestType
-> Text
-> Session
-> IO ()
unlistenIQ :: IQRequestType -> Text -> Session -> IO ()
unlistenIQ IQRequestType
tp Text
ns Session
session = do
let handlers :: TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
handlers = (Session
-> TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
iqHandlers Session
session)
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
(Map (IQRequestType, Text) (TChan IQRequestTicket)
byNS, Map
Text (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
byID) <- TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
-> STM
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
forall a. TVar a -> STM a
readTVar TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
handlers
let byNS' :: Map (IQRequestType, Text) (TChan IQRequestTicket)
byNS' = (IQRequestType, Text)
-> Map (IQRequestType, Text) (TChan IQRequestTicket)
-> Map (IQRequestType, Text) (TChan IQRequestTicket)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (IQRequestType
tp, Text
ns) Map (IQRequestType, Text) (TChan IQRequestTicket)
byNS
TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
-> (Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
-> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar
(Map (IQRequestType, Text) (TChan IQRequestTicket),
Map
Text
(Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse))))
handlers (Map (IQRequestType, Text) (TChan IQRequestTicket)
byNS', Map
Text (Either (Maybe Jid) Jid, TMVar (Maybe (Annotated IQResponse)))
byID)
() -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
answerIQ :: IQRequestTicket
-> Either StanzaError (Maybe Element)
-> [ExtendedAttribute]
-> IO (Maybe (Either XmppFailure ()))
answerIQ :: IQRequestTicket
-> Either StanzaError (Maybe Element)
-> [ExtendedAttribute]
-> IO (Maybe (Either XmppFailure ()))
answerIQ = IQRequestTicket
-> Either StanzaError (Maybe Element)
-> [ExtendedAttribute]
-> IO (Maybe (Either XmppFailure ()))
answerTicket
class IQRequestClass a where
data IQResponseType a
pickleRequest :: PU Element a
pickleResponse :: PU [Element] (IQResponseType a)
requestType :: a -> IQRequestType
requestNamespace :: a -> Text
data IQRequestError = IQRequestSendError XmppFailure
| IQRequestTimeout
| IQRequestUnpickleError UnpickleError
deriving Int -> IQRequestError -> ShowS
[IQRequestError] -> ShowS
IQRequestError -> String
(Int -> IQRequestError -> ShowS)
-> (IQRequestError -> String)
-> ([IQRequestError] -> ShowS)
-> Show IQRequestError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IQRequestError] -> ShowS
$cshowList :: [IQRequestError] -> ShowS
show :: IQRequestError -> String
$cshow :: IQRequestError -> String
showsPrec :: Int -> IQRequestError -> ShowS
$cshowsPrec :: Int -> IQRequestError -> ShowS
Show
sendIQRequest :: (IQRequestClass a, MonadError IQRequestError m, MonadIO m) =>
Maybe Integer
-> Maybe Jid
-> a
-> Session
-> m (Either IQError (IQResponseType a))
sendIQRequest :: Maybe Integer
-> Maybe Jid
-> a
-> Session
-> m (Either IQError (IQResponseType a))
sendIQRequest Maybe Integer
timeout Maybe Jid
t a
req Session
con = do
Either IQSendError IQResponse
mbRes <- IO (Either IQSendError IQResponse)
-> m (Either IQSendError IQResponse)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IQSendError IQResponse)
-> m (Either IQSendError IQResponse))
-> IO (Either IQSendError IQResponse)
-> m (Either IQSendError IQResponse)
forall a b. (a -> b) -> a -> b
$ Maybe Integer
-> Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> [ExtendedAttribute]
-> Session
-> IO (Either IQSendError IQResponse)
sendIQ' Maybe Integer
timeout Maybe Jid
t (a -> IQRequestType
forall a. IQRequestClass a => a -> IQRequestType
requestType a
req) Maybe LangTag
forall a. Maybe a
Nothing
(PU Element a -> a -> Element
forall t a. PU t a -> a -> t
pickle PU Element a
forall a. IQRequestClass a => PU Element a
pickleRequest a
req) [] Session
con
case Either IQSendError IQResponse
mbRes of
Left (IQSendError
IQTimeOut) -> IQRequestError -> m (Either IQError (IQResponseType a))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError IQRequestError
IQRequestTimeout
Left (IQSendError XmppFailure
e) -> IQRequestError -> m (Either IQError (IQResponseType a))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (IQRequestError -> m (Either IQError (IQResponseType a)))
-> IQRequestError -> m (Either IQError (IQResponseType a))
forall a b. (a -> b) -> a -> b
$ XmppFailure -> IQRequestError
IQRequestSendError XmppFailure
e
Right (IQResponseError IQError
e) -> Either IQError (IQResponseType a)
-> m (Either IQError (IQResponseType a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either IQError (IQResponseType a)
-> m (Either IQError (IQResponseType a)))
-> Either IQError (IQResponseType a)
-> m (Either IQError (IQResponseType a))
forall a b. (a -> b) -> a -> b
$ IQError -> Either IQError (IQResponseType a)
forall a b. a -> Either a b
Left IQError
e
Right (IQResponseResult IQResult
res) ->
case PU [Element] (IQResponseType a)
-> [Element] -> Either UnpickleError (IQResponseType a)
forall t a. PU t a -> t -> Either UnpickleError a
unpickle PU [Element] (IQResponseType a)
forall a. IQRequestClass a => PU [Element] (IQResponseType a)
pickleResponse (IQResult
res IQResult -> (IQResult -> [Element]) -> [Element]
forall s t. s -> (s -> t) -> t
& Fold IQResult IQResult Element Element -> IQResult -> [Element]
forall s t a b. Fold s t a b -> s -> [a]
toListOf forall s. IsStanza s => Traversal s Element
Fold IQResult IQResult Element Element
payloadT) of
Left UnpickleError
e -> IQRequestError -> m (Either IQError (IQResponseType a))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (IQRequestError -> m (Either IQError (IQResponseType a)))
-> IQRequestError -> m (Either IQError (IQResponseType a))
forall a b. (a -> b) -> a -> b
$ UnpickleError -> IQRequestError
IQRequestUnpickleError UnpickleError
e
Right IQResponseType a
r -> Either IQError (IQResponseType a)
-> m (Either IQError (IQResponseType a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either IQError (IQResponseType a)
-> m (Either IQError (IQResponseType a)))
-> Either IQError (IQResponseType a)
-> m (Either IQError (IQResponseType a))
forall a b. (a -> b) -> a -> b
$ IQResponseType a -> Either IQError (IQResponseType a)
forall a b. b -> Either a b
Right IQResponseType a
r
type IQRequestHandler a = a -> IO (Either StanzaError (IQResponseType a))
runIQHandler :: IQRequestClass a =>
IQRequestHandler a
-> Session
-> IO ()
runIQHandler :: IQRequestHandler a -> Session -> IO ()
runIQHandler (IQRequestHandler a
handler :: a -> IO (Either StanzaError (IQResponseType a)))
Session
sess = do
let prx :: a
prx = a
forall a. HasCallStack => a
undefined :: a
ns :: Text
ns = (a -> Text
forall a. IQRequestClass a => a -> Text
requestNamespace a
prx)
Either (STM IQRequestTicket) (STM IQRequestTicket)
mbChan <- IQRequestType
-> Text
-> Session
-> IO (Either (STM IQRequestTicket) (STM IQRequestTicket))
listenIQ (a -> IQRequestType
forall a. IQRequestClass a => a -> IQRequestType
requestType a
prx) Text
ns Session
sess
case Either (STM IQRequestTicket) (STM IQRequestTicket)
mbChan of
Left STM IQRequestTicket
_ -> String -> String -> IO ()
warningM String
"Pontarius.Xmpp" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"IQ namespace " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
ns
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is already handled"
Right STM IQRequestTicket
getNext -> IO (Maybe (Either XmppFailure ())) -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO (Maybe (Either XmppFailure ())) -> IO ())
-> IO (Maybe (Either XmppFailure ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ do
IQRequestTicket
ticket <- STM IQRequestTicket -> IO IQRequestTicket
forall a. STM a -> IO a
atomically STM IQRequestTicket
getNext
case PU Element a -> Element -> Either UnpickleError a
forall t a. PU t a -> t -> Either UnpickleError a
unpickle PU Element a
forall a. IQRequestClass a => PU Element a
pickleRequest (IQRequestTicket -> IQRequest
iqRequestBody IQRequestTicket
ticket IQRequest
-> FoldLike Element IQRequest IQRequest Element Element -> Element
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike Element IQRequest IQRequest Element Element
forall s p. HasStanzaPayload s p => Lens s p
payload) of
Left UnpickleError
_ -> IQRequestTicket
-> Either StanzaError (Maybe Element)
-> [ExtendedAttribute]
-> IO (Maybe (Either XmppFailure ()))
answerIQ IQRequestTicket
ticket (StanzaError -> Either StanzaError (Maybe Element)
forall a b. a -> Either a b
Left (StanzaError -> Either StanzaError (Maybe Element))
-> StanzaError -> Either StanzaError (Maybe Element)
forall a b. (a -> b) -> a -> b
$ StanzaErrorCondition -> StanzaError
mkStanzaError StanzaErrorCondition
BadRequest) []
Right a
req -> do
Either StanzaError (IQResponseType a)
res <- IQRequestHandler a
handler a
req
case Either StanzaError (IQResponseType a)
res of
Left StanzaError
e -> IQRequestTicket
-> Either StanzaError (Maybe Element)
-> [ExtendedAttribute]
-> IO (Maybe (Either XmppFailure ()))
answerIQ IQRequestTicket
ticket (StanzaError -> Either StanzaError (Maybe Element)
forall a b. a -> Either a b
Left StanzaError
e) []
Right IQResponseType a
r -> do
let answer :: [Element]
answer = (PU [Element] (IQResponseType a) -> IQResponseType a -> [Element]
forall t a. PU t a -> a -> t
pickle PU [Element] (IQResponseType a)
forall a. IQRequestClass a => PU [Element] (IQResponseType a)
pickleResponse IQResponseType a
r)
IQRequestTicket
-> Either StanzaError (Maybe Element)
-> [ExtendedAttribute]
-> IO (Maybe (Either XmppFailure ()))
answerIQ IQRequestTicket
ticket (Maybe Element -> Either StanzaError (Maybe Element)
forall a b. b -> Either a b
Right (Maybe Element -> Either StanzaError (Maybe Element))
-> Maybe Element -> Either StanzaError (Maybe Element)
forall a b. (a -> b) -> a -> b
$ [Element] -> Maybe Element
forall a. [a] -> Maybe a
listToMaybe [Element]
answer ) []