{-# 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

-- | Sends an IQ, returns an STM action that returns the first inbound IQ with a
-- matching ID that has type @result@ or @error@ or Nothing if the timeout was
-- reached.
--
-- When sending the action fails, an XmppFailure is returned.
sendIQ :: Maybe Integer -- ^ Timeout . When the timeout is reached the response
                        -- TMVar will be filled with 'IQResponseTimeout' and the
                        -- id is removed from the list of IQ handlers. 'Nothing'
                        -- deactivates the timeout
       -> Maybe Jid -- ^ Recipient (to)
       -> IQRequestType  -- ^ IQ type (@Get@ or @Set@)
       -> Maybe LangTag  -- ^ Language tag of the payload (@Nothing@ for
                         -- default)
       -> Element -- ^ The IQ body (there has to be exactly one)
       -> [ExtendedAttribute] -- ^ Additional stanza attributes
       -> 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 ()

-- | Like 'sendIQ', but waits for the answer IQ.
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

-- | Like 'sendIQ', but waits for the answer IQ. Discards plugin Annotations
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

-- | Register your interest in inbound IQ stanzas of a specific type and
-- namespace. The returned STM action yields the received, matching IQ stanzas.
--
-- If a handler for IQ stanzas with the given type and namespace is already
-- registered, the producer will be wrapped in Left. In this case the returned
-- request tickets may already be processed elsewhere.
listenIQ :: IQRequestType  -- ^ Type of IQs to receive ('Get' or 'Set')
         -> Text -- ^ Namespace of the child element
         -> 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


-- | Unregister a previously registered IQ handler. No more IQ stanzas will be
-- delivered to any of the returned producers.
unlistenIQ :: IQRequestType  -- ^ Type of IQ ('Get' or 'Set')
           -> Text -- ^ Namespace of the child element
           -> 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 ()

-- | Answer an IQ request. Only the first answer ist sent and Just True is
-- returned when the answer is sucessfully sent. If an error occured during
-- sending Just False is returned (and another attempt can be
-- undertaken). Subsequent answers after the first sucessful one are dropped and
-- (False is returned in that case)
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

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

-- | Send an IQ request. May throw IQSendError, UnpickleError,

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 ) []