{-# 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Jid
t
Maybe Jid
Nothing -> forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session -> IO (Maybe Jid)
getJid Session
session
TMVar (Maybe (Annotated IQResponse))
ref <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
TMVar (Maybe (Annotated IQResponse))
resRef <- 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) <- 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)
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, 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)
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 forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Jid
-> Maybe Jid
-> Maybe LangTag
-> IQRequestType
-> Element
-> [ExtendedAttribute]
-> IQRequest
IQRequest Text
newId 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Integer
t -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> STM a
readTMVar TMVar (Maybe (Annotated IQResponse))
ref
Left XmppFailure
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
Bool
p <- forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar (Maybe (Annotated IQResponse))
var forall a. Maybe a
Nothing
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
p 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) <- 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)
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, 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)
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
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmppFailure -> IQSendError
IQSendError) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left IQSendError
IQTimeOut) forall a b. b -> Either a b
Right)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst 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)
forall a. STM a -> IO a
atomically 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) <- 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 <- forall a. STM (TChan a)
newTChan
let (Maybe (TChan IQRequestTicket)
present, Map (IQRequestType, Text) (TChan IQRequestTicket)
byNS') = 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
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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> STM a
readTChan TChan IQRequestTicket
iqCh
Just TChan IQRequestTicket
iqCh' -> do
TChan IQRequestTicket
clonedChan <- forall a. TChan a -> STM (TChan a)
cloneTChan TChan IQRequestTicket
iqCh'
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ 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)
forall a. STM a -> IO a
atomically 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) <- 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' = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (IQRequestType
tp, Text
ns) Map (IQRequestType, Text) (TChan IQRequestTicket)
byNS
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)
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
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 :: forall a (m :: * -> *).
(IQRequestClass a, MonadError IQRequestError m, MonadIO m) =>
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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 (forall a. IQRequestClass a => a -> IQRequestType
requestType a
req) forall a. Maybe a
Nothing
(forall t a. PU t a -> a -> t
pickle forall a. IQRequestClass a => PU Element a
pickleRequest a
req) [] Session
con
case Either IQSendError IQResponse
mbRes of
Left (IQSendError
IQTimeOut) -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError IQRequestError
IQRequestTimeout
Left (IQSendError XmppFailure
e) -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ XmppFailure -> IQRequestError
IQRequestSendError XmppFailure
e
Right (IQResponseError IQError
e) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left IQError
e
Right (IQResponseResult IQResult
res) ->
case forall t a. PU t a -> t -> Either UnpickleError a
unpickle forall a. IQRequestClass a => PU [Element] (IQResponseType a)
pickleResponse (IQResult
res forall s t. s -> (s -> t) -> t
& forall s t a b. Fold s t a b -> s -> [a]
toListOf forall s. IsStanza s => Traversal s Element
payloadT) of
Left UnpickleError
e -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ UnpickleError -> IQRequestError
IQRequestUnpickleError UnpickleError
e
Right IQResponseType a
r -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 :: forall a.
IQRequestClass a =>
IQRequestHandler a -> Session -> IO ()
runIQHandler (a -> IO (Either StanzaError (IQResponseType a))
handler :: a -> IO (Either StanzaError (IQResponseType a)))
Session
sess = do
let prx :: a
prx = forall a. HasCallStack => a
undefined :: a
ns :: Text
ns = (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 (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" forall a b. (a -> b) -> a -> b
$ String
"IQ namespace " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
ns
forall a. [a] -> [a] -> [a]
++ String
" is already handled"
Right STM IQRequestTicket
getNext -> forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
IQRequestTicket
ticket <- forall a. STM a -> IO a
atomically STM IQRequestTicket
getNext
case forall t a. PU t a -> t -> Either UnpickleError a
unpickle forall a. IQRequestClass a => PU Element a
pickleRequest (IQRequestTicket -> IQRequest
iqRequestBody IQRequestTicket
ticket forall s a t b. s -> FoldLike a s t a b -> a
^. 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 (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ StanzaErrorCondition -> StanzaError
mkStanzaError StanzaErrorCondition
BadRequest) []
Right a
req -> do
Either StanzaError (IQResponseType a)
res <- a -> IO (Either StanzaError (IQResponseType 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 (forall a b. a -> Either a b
Left StanzaError
e) []
Right IQResponseType a
r -> do
let answer :: [Element]
answer = (forall t a. PU t a -> a -> t
pickle 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 (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
listToMaybe [Element]
answer ) []