{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Network.XMPP.Stream
-- Copyright   :  (c) Dmitry Astapov, 2006 ; pierre, 2007
-- License     :  BSD-style (see the file LICENSE)
-- Copyright   :  (c) riskbook, 2020
-- SPDX-License-Identifier:  BSD3
-- 
-- Maintainer  :  Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- An XMPP stream: means to create and use one
--
-----------------------------------------------------------------------------
module Network.XMPP.Stream
  ( XmppSendable(..)
  , Plugin(..)
  , XmppError(..)
  , startM, nextM, withNextM, selectM, xtractM, textractM, withSelectM
  , resetStreamHandle, getText, getText_
  , loopWithPlugins
  , getNextId
  , parse, parseM, waitAndProcess
  , withUUID
  ) where

import           Control.Monad                (void)
import           Control.Monad.State          (MonadState(..), gets, modify)
import           Control.Monad.Except         (runExceptT, throwError, lift)
import           Control.Monad.IO.Class       (MonadIO(..))
import           Control.Applicative          (Alternative, empty)
import           System.IO                    (Handle, hGetContents)
import           Data.Text                    (Text, unpack, pack)
import qualified Data.UUID.V4                 as UUID
import qualified Data.UUID                    as UUID
import           Data.Functor                 (($>))

import           Text.XML                     (Node)
import           Text.XML.HaXml.Lex           (xmlLex)
import           Text.XML.HaXml.Parse
import           Text.XML.HaXml.Posn          (Posn, noPos)
import           Text.XML.HaXml.Types
import qualified Text.XML.HaXml.Pretty        as P (content)
import           Text.XML.HaXml.Xtract.Parse  (xtract)
import           Text.ParserCombinators.Poly.State (onFail)

import           Network.XMPP.Print           (hPutNode, hPutXmpp)
import           Network.XMPP.Utils
import           Network.XMPP.Types
import           Network.XMPP.UTF8
import           Network.XMPP.XML
import           Network.XMPP.Stanza

-- Main 'workhorses' for Stream are 'xmppSend', 'nextM', 'peekM' and 'selectM':
-- | Sends message into Stream
class XmppSendable t a where
  xmppSend :: Monad t => a -> t ()

instance MonadIO m => XmppSendable (XmppMonad m) Node where
  xmppSend :: Node -> XmppMonad m ()
xmppSend Node
node = do
    Handle
h <- (Stream -> Handle) -> XmppMonad m Handle
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Stream -> Handle
handle
    IO () -> XmppMonad m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> XmppMonad m ()) -> IO () -> XmppMonad m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Node -> IO ()
hPutNode Handle
h Node
node

instance MonadIO m => XmppSendable (XmppMonad m) (Content Posn) where
  xmppSend :: Content Posn -> XmppMonad m ()
xmppSend Content Posn
content = do
    Handle
h <- (Stream -> Handle) -> XmppMonad m Handle
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Stream -> Handle
handle
    IO () -> XmppMonad m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> XmppMonad m ()) -> IO () -> XmppMonad m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Content Posn -> IO ()
hPutXmpp Handle
h Content Posn
content

instance MonadIO m => XmppSendable (XmppMonad m) (Stanza t 'Outgoing e) where
  xmppSend :: Stanza t 'Outgoing e -> XmppMonad m ()
xmppSend Stanza t 'Outgoing e
s = Node -> XmppMonad m ()
forall (t :: * -> *) a. (XmppSendable t a, Monad t) => a -> t ()
xmppSend (Stanza t 'Outgoing e -> Node
forall (t :: StanzaType) (p :: StanzaPurpose) e a.
StanzaEncoder t p e a =>
Stanza t p e -> a
encodeStanza Stanza t 'Outgoing e
s :: Node)

data XmppError =
    StreamClosedError
  | MessageParseError Text Text
  | NonSupportedAuthMechanisms [Text] Text
  | AuthError Text
  | RanOutOfInput
  | UnknownVersion Text
  | UnknownError Text
  deriving (XmppError -> XmppError -> Bool
(XmppError -> XmppError -> Bool)
-> (XmppError -> XmppError -> Bool) -> Eq XmppError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: XmppError -> XmppError -> Bool
$c/= :: XmppError -> XmppError -> Bool
== :: XmppError -> XmppError -> Bool
$c== :: XmppError -> XmppError -> Bool
Eq, Int -> XmppError -> ShowS
[XmppError] -> ShowS
XmppError -> String
(Int -> XmppError -> ShowS)
-> (XmppError -> String)
-> ([XmppError] -> ShowS)
-> Show XmppError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [XmppError] -> ShowS
$cshowList :: [XmppError] -> ShowS
show :: XmppError -> String
$cshow :: XmppError -> String
showsPrec :: Int -> XmppError -> ShowS
$cshowsPrec :: Int -> XmppError -> ShowS
Show)

-- | Parses XML element producing Stanza
parse :: forall l e. (Alternative l, FromXML e) => Content Posn -> l (SomeStanza e)
parse :: Content Posn -> l (SomeStanza e)
parse Content Posn
m | ShowS -> String -> Content Posn -> Bool
forall i. ShowS -> String -> Content i -> Bool
xtractp ShowS
forall a. a -> a
id String
"/message" Content Posn
m  = Maybe (Stanza 'Message 'Incoming e) -> l (SomeStanza e)
forall (t :: StanzaType) (p :: StanzaPurpose).
(Alternative l, FromXML e) =>
Maybe (Stanza t p e) -> l (SomeStanza e)
mSucceed (Content Posn -> Maybe (Stanza 'Message 'Incoming e)
forall (t :: StanzaType) (p :: StanzaPurpose) e a.
StanzaDecoder t p e a =>
a -> Maybe (Stanza t p e)
decodeStanza Content Posn
m :: Maybe (Stanza 'Message 'Incoming e))
        | ShowS -> String -> Content Posn -> Bool
forall i. ShowS -> String -> Content i -> Bool
xtractp ShowS
forall a. a -> a
id String
"/presence" Content Posn
m = Maybe (Stanza 'Presence 'Incoming e) -> l (SomeStanza e)
forall (t :: StanzaType) (p :: StanzaPurpose).
(Alternative l, FromXML e) =>
Maybe (Stanza t p e) -> l (SomeStanza e)
mSucceed (Content Posn -> Maybe (Stanza 'Presence 'Incoming e)
forall (t :: StanzaType) (p :: StanzaPurpose) e a.
StanzaDecoder t p e a =>
a -> Maybe (Stanza t p e)
decodeStanza Content Posn
m :: Maybe (Stanza 'Presence 'Incoming e))
        | ShowS -> String -> Content Posn -> Bool
forall i. ShowS -> String -> Content i -> Bool
xtractp ShowS
forall a. a -> a
id String
"/iq" Content Posn
m       = Maybe (Stanza 'IQ 'Incoming e) -> l (SomeStanza e)
forall (t :: StanzaType) (p :: StanzaPurpose).
(Alternative l, FromXML e) =>
Maybe (Stanza t p e) -> l (SomeStanza e)
mSucceed (Content Posn -> Maybe (Stanza 'IQ 'Incoming e)
forall (t :: StanzaType) (p :: StanzaPurpose) e a.
StanzaDecoder t p e a =>
a -> Maybe (Stanza t p e)
decodeStanza Content Posn
m :: Maybe (Stanza 'IQ 'Incoming e))
        | Bool
otherwise                = l (SomeStanza e)
forall (f :: * -> *) a. Alternative f => f a
empty
  where xtractp :: ShowS -> String -> Content i -> Bool
xtractp ShowS
f String
p Content i
m = Bool -> Bool
not (Bool -> Bool) -> ([Content i] -> Bool) -> [Content i] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Content i] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Content i] -> Bool) -> [Content i] -> Bool
forall a b. (a -> b) -> a -> b
$ ShowS -> String -> CFilter i
forall i. ShowS -> String -> CFilter i
xtract ShowS
f String
p Content i
m
        mSucceed :: (Alternative l, FromXML e) => Maybe (Stanza t p e) -> l (SomeStanza e)
        mSucceed :: Maybe (Stanza t p e) -> l (SomeStanza e)
mSucceed = l (SomeStanza e)
-> (Stanza t p e -> l (SomeStanza e))
-> Maybe (Stanza t p e)
-> l (SomeStanza e)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe l (SomeStanza e)
forall (f :: * -> *) a. Alternative f => f a
empty (SomeStanza e -> l (SomeStanza e)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeStanza e -> l (SomeStanza e))
-> (Stanza t p e -> SomeStanza e)
-> Stanza t p e
-> l (SomeStanza e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stanza t p e -> SomeStanza e
forall e (a :: StanzaType) (p :: StanzaPurpose).
Stanza a p e -> SomeStanza e
SomeStanza)

-- | Gets next message from stream and parses it
-- | We shall skip over unknown messages, rather than crashing
parseM :: (FromXML e, MonadIO m) => XmppMonad m (Either XmppError (SomeStanza e))
parseM :: XmppMonad m (Either XmppError (SomeStanza e))
parseM = ((Content Posn -> Maybe (SomeStanza e))
-> Either XmppError (Content Posn)
-> Either XmppError (Maybe (SomeStanza e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Content Posn -> Maybe (SomeStanza e)
forall (l :: * -> *) e.
(Alternative l, FromXML e) =>
Content Posn -> l (SomeStanza e)
parse (Either XmppError (Content Posn)
 -> Either XmppError (Maybe (SomeStanza e)))
-> XmppMonad m (Either XmppError (Content Posn))
-> XmppMonad m (Either XmppError (Maybe (SomeStanza e)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XmppMonad m (Either XmppError (Content Posn))
forall (m :: * -> *).
MonadIO m =>
XmppMonad m (Either XmppError (Content Posn))
nextM) XmppMonad m (Either XmppError (Maybe (SomeStanza e)))
-> (Either XmppError (Maybe (SomeStanza e))
    -> XmppMonad m (Either XmppError (SomeStanza e)))
-> XmppMonad m (Either XmppError (SomeStanza e))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Right Maybe (SomeStanza e)
m -> XmppMonad m (Either XmppError (SomeStanza e))
-> (SomeStanza e -> XmppMonad m (Either XmppError (SomeStanza e)))
-> Maybe (SomeStanza e)
-> XmppMonad m (Either XmppError (SomeStanza e))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe XmppMonad m (Either XmppError (SomeStanza e))
forall e (m :: * -> *).
(FromXML e, MonadIO m) =>
XmppMonad m (Either XmppError (SomeStanza e))
parseM (Either XmppError (SomeStanza e)
-> XmppMonad m (Either XmppError (SomeStanza e))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XmppError (SomeStanza e)
 -> XmppMonad m (Either XmppError (SomeStanza e)))
-> (SomeStanza e -> Either XmppError (SomeStanza e))
-> SomeStanza e
-> XmppMonad m (Either XmppError (SomeStanza e))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeStanza e -> Either XmppError (SomeStanza e)
forall a b. b -> Either a b
Right) Maybe (SomeStanza e)
m
  Left  XmppError
e -> Either XmppError (SomeStanza e)
-> XmppMonad m (Either XmppError (SomeStanza e))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XmppError (SomeStanza e)
 -> XmppMonad m (Either XmppError (SomeStanza e)))
-> Either XmppError (SomeStanza e)
-> XmppMonad m (Either XmppError (SomeStanza e))
forall a b. (a -> b) -> a -> b
$ XmppError -> Either XmppError (SomeStanza e)
forall a b. a -> Either a b
Left XmppError
e

-- | Skips all messages, that will return result `Nothing` from computation
-- | In other words - waits for appropriate message, defined by predicate
waitAndProcess
  :: (FromXML e, MonadIO m)
  => (SomeStanza e -> Maybe a)
  -> XmppMonad m (Either XmppError a)
waitAndProcess :: (SomeStanza e -> Maybe a) -> XmppMonad m (Either XmppError a)
waitAndProcess SomeStanza e -> Maybe a
compute = XmppMonad m (Either XmppError (SomeStanza e))
forall e (m :: * -> *).
(FromXML e, MonadIO m) =>
XmppMonad m (Either XmppError (SomeStanza e))
parseM XmppMonad m (Either XmppError (SomeStanza e))
-> (Either XmppError (SomeStanza e)
    -> XmppMonad m (Either XmppError a))
-> XmppMonad m (Either XmppError a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Right SomeStanza e
m   -> XmppMonad m (Either XmppError a)
-> (a -> XmppMonad m (Either XmppError a))
-> Maybe a
-> XmppMonad m (Either XmppError a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((SomeStanza e -> Maybe a) -> XmppMonad m (Either XmppError a)
forall e (m :: * -> *) a.
(FromXML e, MonadIO m) =>
(SomeStanza e -> Maybe a) -> XmppMonad m (Either XmppError a)
waitAndProcess SomeStanza e -> Maybe a
compute) (Either XmppError a -> XmppMonad m (Either XmppError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XmppError a -> XmppMonad m (Either XmppError a))
-> (a -> Either XmppError a)
-> a
-> XmppMonad m (Either XmppError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either XmppError a
forall a b. b -> Either a b
Right) (Maybe a -> XmppMonad m (Either XmppError a))
-> Maybe a -> XmppMonad m (Either XmppError a)
forall a b. (a -> b) -> a -> b
$ SomeStanza e -> Maybe a
compute SomeStanza e
m
  Left  XmppError
err -> Either XmppError a -> XmppMonad m (Either XmppError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XmppError a -> XmppMonad m (Either XmppError a))
-> Either XmppError a -> XmppMonad m (Either XmppError a)
forall a b. (a -> b) -> a -> b
$ XmppError -> Either XmppError a
forall a b. a -> Either a b
Left XmppError
err

withUUID :: MonadIO m => (UUID.UUID -> Stanza t p e) -> m (Stanza t p e)
withUUID :: (UUID -> Stanza t p e) -> m (Stanza t p e)
withUUID UUID -> Stanza t p e
setUUID = UUID -> Stanza t p e
setUUID (UUID -> Stanza t p e) -> m UUID -> m (Stanza t p e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID -> m UUID
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UUID
UUID.nextRandom

-- | Selects next messages from stream
nextM :: MonadIO m => XmppMonad m (Either XmppError (Content Posn))
nextM :: XmppMonad m (Either XmppError (Content Posn))
nextM = ExceptT XmppError (XmppMonad m) (Content Posn)
-> XmppMonad m (Either XmppError (Content Posn))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XmppError (XmppMonad m) (Content Posn)
 -> XmppMonad m (Either XmppError (Content Posn)))
-> ExceptT XmppError (XmppMonad m) (Content Posn)
-> XmppMonad m (Either XmppError (Content Posn))
forall a b. (a -> b) -> a -> b
$ do
  [Token]
ls <- XmppMonad m [Token] -> ExceptT XmppError (XmppMonad m) [Token]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (XmppMonad m [Token] -> ExceptT XmppError (XmppMonad m) [Token])
-> XmppMonad m [Token] -> ExceptT XmppError (XmppMonad m) [Token]
forall a b. (a -> b) -> a -> b
$ (Stream -> [Token]) -> XmppMonad m [Token]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Stream -> [Token]
lexemes

  if [Token] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Token]
ls then XmppError -> ExceptT XmppError (XmppMonad m) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppError
RanOutOfInput else () -> ExceptT XmppError (XmppMonad m) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  case XParser () -> [Token] -> (Either String (), [Token])
forall a. XParser a -> [Token] -> (Either String a, [Token])
xmlParseWith (QName -> XParser ()
elemCloseTag (QName -> XParser ()) -> QName -> XParser ()
forall a b. (a -> b) -> a -> b
$ String -> QName
N String
"stream:stream") [Token]
ls of
    (Right (), [Token]
rest) -> do
      (Stream -> Stream) -> ExceptT XmppError (XmppMonad m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\Stream
stream -> Stream
stream { lexemes :: [Token]
lexemes = [Token]
rest })
      XmppError -> ExceptT XmppError (XmppMonad m) (Content Posn)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppError
StreamClosedError -- all subsequent queries will end by EOF exception
    (Either String (), [Token])
_ -> case XParser (Element Posn)
-> [Token] -> (Either String (Element Posn), [Token])
forall a. XParser a -> [Token] -> (Either String a, [Token])
xmlParseWith XParser (Element Posn)
element [Token]
ls of
      (Right Element Posn
e, [Token]
rest) -> do
        let msg :: Content Posn
msg = Element Posn -> Posn -> Content Posn
forall i. Element i -> i -> Content i
CElem Element Posn
e Posn
noPos
        XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (XmppMonad m () -> ExceptT XmppError (XmppMonad m) ())
-> XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall a b. (a -> b) -> a -> b
$ String -> XmppMonad m ()
forall (m :: * -> *). MonadIO m => String -> XmppMonad m ()
debug (String -> XmppMonad m ()) -> String -> XmppMonad m ()
forall a b. (a -> b) -> a -> b
$ String
"nextM: Got element: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (Content Posn -> Doc
forall i. Content i -> Doc
P.content Content Posn
msg)
        (Stream -> Stream) -> ExceptT XmppError (XmppMonad m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\Stream
stream -> Stream
stream { lexemes :: [Token]
lexemes = [Token]
rest }) ExceptT XmppError (XmppMonad m) ()
-> Content Posn -> ExceptT XmppError (XmppMonad m) (Content Posn)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Content Posn
msg
      (Left String
err, [Token]
_) ->
        XmppError -> ExceptT XmppError (XmppMonad m) (Content Posn)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (XmppError -> ExceptT XmppError (XmppMonad m) (Content Posn))
-> XmppError -> ExceptT XmppError (XmppMonad m) (Content Posn)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> XmppError
MessageParseError (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [Token] -> String
forall a. Show a => a -> String
show [Token]
ls) (Text -> XmppError) -> Text -> XmppError
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. Show a => a -> String
show String
err

-- | Selects next message matching predicate
selectM
  :: MonadIO m
  => (Content Posn -> Bool)
  -> XmppMonad m (Either XmppError (Content Posn))
selectM :: (Content Posn -> Bool)
-> XmppMonad m (Either XmppError (Content Posn))
selectM Content Posn -> Bool
p = ExceptT XmppError (XmppMonad m) (Content Posn)
-> XmppMonad m (Either XmppError (Content Posn))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XmppError (XmppMonad m) (Content Posn)
 -> XmppMonad m (Either XmppError (Content Posn)))
-> ExceptT XmppError (XmppMonad m) (Content Posn)
-> XmppMonad m (Either XmppError (Content Posn))
forall a b. (a -> b) -> a -> b
$ do
  Content Posn
m <- XmppMonad m (Either XmppError (Content Posn))
-> ExceptT
     XmppError (XmppMonad m) (Either XmppError (Content Posn))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift XmppMonad m (Either XmppError (Content Posn))
forall (m :: * -> *).
MonadIO m =>
XmppMonad m (Either XmppError (Content Posn))
nextM ExceptT XmppError (XmppMonad m) (Either XmppError (Content Posn))
-> (Either XmppError (Content Posn)
    -> ExceptT XmppError (XmppMonad m) (Content Posn))
-> ExceptT XmppError (XmppMonad m) (Content Posn)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (XmppError -> ExceptT XmppError (XmppMonad m) (Content Posn))
-> (Content Posn -> ExceptT XmppError (XmppMonad m) (Content Posn))
-> Either XmppError (Content Posn)
-> ExceptT XmppError (XmppMonad m) (Content Posn)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either XmppError -> ExceptT XmppError (XmppMonad m) (Content Posn)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Content Posn -> ExceptT XmppError (XmppMonad m) (Content Posn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  if Content Posn -> Bool
p Content Posn
m then Content Posn -> ExceptT XmppError (XmppMonad m) (Content Posn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Content Posn
m else XmppError -> ExceptT XmppError (XmppMonad m) (Content Posn)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (XmppError -> ExceptT XmppError (XmppMonad m) (Content Posn))
-> XmppError -> ExceptT XmppError (XmppMonad m) (Content Posn)
forall a b. (a -> b) -> a -> b
$ Text -> XmppError
UnknownError Text
"Failed to select message"

-- | Pass in xtract query, return query result from the first message where it returns non-empty results
xtractM :: MonadIO m => Text -> XmppMonad m [Content Posn]
xtractM :: Text -> XmppMonad m [Content Posn]
xtractM Text
q =do
  Either XmppError (Content Posn)
eim <- (Content Posn -> Bool)
-> XmppMonad m (Either XmppError (Content Posn))
forall (m :: * -> *).
MonadIO m =>
(Content Posn -> Bool)
-> XmppMonad m (Either XmppError (Content Posn))
selectM (Bool -> Bool
not (Bool -> Bool) -> (Content Posn -> Bool) -> Content Posn -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Content Posn] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Content Posn] -> Bool)
-> (Content Posn -> [Content Posn]) -> Content Posn -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> String -> Content Posn -> [Content Posn]
forall i. ShowS -> String -> CFilter i
xtract ShowS
forall a. a -> a
id (Text -> String
unpack Text
q))
  case Either XmppError (Content Posn)
eim of
    Right Content Posn
m -> [Content Posn] -> XmppMonad m [Content Posn]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Content Posn] -> XmppMonad m [Content Posn])
-> [Content Posn] -> XmppMonad m [Content Posn]
forall a b. (a -> b) -> a -> b
$ ShowS -> String -> Content Posn -> [Content Posn]
forall i. ShowS -> String -> CFilter i
xtract ShowS
forall a. a -> a
id (Text -> String
unpack Text
q) Content Posn
m
    Left XmppError
_e -> [Content Posn] -> XmppMonad m [Content Posn]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] -- TODO

textractM :: MonadIO m => Text -> XmppMonad m Text
textractM :: Text -> XmppMonad m Text
textractM Text
q = do
  [Content Posn]
res <- Text -> XmppMonad m [Content Posn]
forall (m :: * -> *).
MonadIO m =>
Text -> XmppMonad m [Content Posn]
xtractM Text
q
  Text -> XmppMonad m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> XmppMonad m Text) -> Text -> XmppMonad m Text
forall a b. (a -> b) -> a -> b
$ case [Content Posn]
res of
    [] -> Text
""
    [Content Posn]
x  -> [Content Posn] -> Text
forall i. [Content i] -> Text
getText_ [Content Posn]
x

withNextM :: MonadIO m => (Content Posn -> b) -> XmppMonad m (Either XmppError b)
withNextM :: (Content Posn -> b) -> XmppMonad m (Either XmppError b)
withNextM Content Posn -> b
compute = (Content Posn -> b)
-> Either XmppError (Content Posn) -> Either XmppError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Content Posn -> b
compute (Either XmppError (Content Posn) -> Either XmppError b)
-> XmppMonad m (Either XmppError (Content Posn))
-> XmppMonad m (Either XmppError b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XmppMonad m (Either XmppError (Content Posn))
forall (m :: * -> *).
MonadIO m =>
XmppMonad m (Either XmppError (Content Posn))
nextM

withSelectM
  :: MonadIO m
  => (Content Posn -> Bool)
  -> (Content Posn -> b)
  -> XmppMonad m (Either XmppError b)
withSelectM :: (Content Posn -> Bool)
-> (Content Posn -> b) -> XmppMonad m (Either XmppError b)
withSelectM Content Posn -> Bool
predicate Content Posn -> b
compute =
  (Content Posn -> Bool)
-> XmppMonad m (Either XmppError (Content Posn))
forall (m :: * -> *).
MonadIO m =>
(Content Posn -> Bool)
-> XmppMonad m (Either XmppError (Content Posn))
selectM Content Posn -> Bool
predicate XmppMonad m (Either XmppError (Content Posn))
-> (Either XmppError (Content Posn)
    -> XmppMonad m (Either XmppError b))
-> XmppMonad m (Either XmppError b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (XmppError -> XmppMonad m (Either XmppError b))
-> (Content Posn -> XmppMonad m (Either XmppError b))
-> Either XmppError (Content Posn)
-> XmppMonad m (Either XmppError b)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either XmppError b -> XmppMonad m (Either XmppError b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XmppError b -> XmppMonad m (Either XmppError b))
-> (XmppError -> Either XmppError b)
-> XmppError
-> XmppMonad m (Either XmppError b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmppError -> Either XmppError b
forall a b. a -> Either a b
Left) (Either XmppError b -> XmppMonad m (Either XmppError b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XmppError b -> XmppMonad m (Either XmppError b))
-> (Content Posn -> Either XmppError b)
-> Content Posn
-> XmppMonad m (Either XmppError b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either XmppError b
forall a b. b -> Either a b
Right (b -> Either XmppError b)
-> (Content Posn -> b) -> Content Posn -> Either XmppError b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Content Posn -> b
compute)


-- | startM is a special accessor case, since it has to retrieve only opening tag of the '<stream>' message,
-- which encloses the whole XMPP stream. That's why it does it's own parsing, and does not rely on 'nextM'
startM :: MonadIO m => XmppMonad m (Either XmppError [Attribute])
startM :: XmppMonad m (Either XmppError [Attribute])
startM = do
  (Either String ElemTag
starter, [Token]
rest) <- XParser ElemTag -> [Token] -> (Either String ElemTag, [Token])
forall a. XParser a -> [Token] -> (Either String a, [Token])
xmlParseWith XParser ElemTag
streamStart ([Token] -> (Either String ElemTag, [Token]))
-> XmppMonad m [Token]
-> XmppMonad m (Either String ElemTag, [Token])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Stream -> [Token]) -> XmppMonad m [Token]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Stream -> [Token]
lexemes
  case Either String ElemTag
starter of
    Left String
e -> Either XmppError [Attribute]
-> XmppMonad m (Either XmppError [Attribute])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XmppError [Attribute]
 -> XmppMonad m (Either XmppError [Attribute]))
-> Either XmppError [Attribute]
-> XmppMonad m (Either XmppError [Attribute])
forall a b. (a -> b) -> a -> b
$ XmppError -> Either XmppError [Attribute]
forall a b. a -> Either a b
Left (XmppError -> Either XmppError [Attribute])
-> XmppError -> Either XmppError [Attribute]
forall a b. (a -> b) -> a -> b
$ Text -> XmppError
UnknownError (Text -> XmppError) -> Text -> XmppError
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
e
    Right (ElemTag (N String
"stream:stream") [Attribute]
attrs) ->
      (Stream -> Stream) -> XmppMonad m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\Stream
stream -> Stream
stream { lexemes :: [Token]
lexemes = [Token]
rest }) XmppMonad m ()
-> Either XmppError [Attribute]
-> XmppMonad m (Either XmppError [Attribute])
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [Attribute] -> Either XmppError [Attribute]
forall a b. b -> Either a b
Right [Attribute]
attrs
    Right ElemTag
_ ->
      Either XmppError [Attribute]
-> XmppMonad m (Either XmppError [Attribute])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XmppError [Attribute]
 -> XmppMonad m (Either XmppError [Attribute]))
-> Either XmppError [Attribute]
-> XmppMonad m (Either XmppError [Attribute])
forall a b. (a -> b) -> a -> b
$ XmppError -> Either XmppError [Attribute]
forall a b. a -> Either a b
Left (XmppError -> Either XmppError [Attribute])
-> XmppError -> Either XmppError [Attribute]
forall a b. (a -> b) -> a -> b
$ Text -> XmppError
UnknownError Text
"Unexpected element at the beginning of XMPP stream!"
 where
  streamStart :: XParser ElemTag
streamStart = Parser SymTabs Token ProcessingInstruction -> XParser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser SymTabs Token ProcessingInstruction
processinginstruction XParser () -> XParser () -> XParser ()
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail` () -> XParser ()
forall (m :: * -> *) a. Monad m => a -> m a
return () XParser () -> XParser ElemTag -> XParser ElemTag
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XParser ElemTag
elemOpenTag

-- | Replaces contents of the Stream with the contents coming from given handle.
resetStreamHandle :: (MonadIO m, MonadState Stream m) => Handle -> m ()
resetStreamHandle :: Handle -> m ()
resetStreamHandle Handle
h =
  do String
c <- IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ Handle -> IO String
hGetContents Handle
h
     (Stream -> Stream) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\Stream
stream -> Stream
stream { handle :: Handle
handle=Handle
h , lexemes :: [Token]
lexemes = String -> String -> [Token]
xmlLex String
"stream" (ShowS
fromUTF8 String
c) })

-------------------------------
-- Basic plugin support
data Plugin
    = Plugin
    { Plugin -> String
trigger :: String
    , Plugin -> Content Posn -> XmppMonad IO ()
body    :: Content Posn -> XmppMonad IO ()
    }

loopWithPlugins :: [Plugin] -> XmppMonad IO (Either Text ())
loopWithPlugins :: [Plugin] -> XmppMonad IO (Either Text ())
loopWithPlugins [Plugin]
ps =
  let loop :: XmppMonad IO b
loop = XmppMonad IO (Either XmppError (Content Posn))
forall (m :: * -> *).
MonadIO m =>
XmppMonad m (Either XmppError (Content Posn))
nextM XmppMonad IO (Either XmppError (Content Posn))
-> (Either XmppError (Content Posn) -> XmppMonad IO b)
-> XmppMonad IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right Content Posn
m -> do
          let notEmpty :: Plugin -> Bool
notEmpty Plugin
p = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Content Posn] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Content Posn] -> Bool) -> [Content Posn] -> Bool
forall a b. (a -> b) -> a -> b
$ ShowS -> String -> Content Posn -> [Content Posn]
forall i. ShowS -> String -> CFilter i
xtract ShowS
forall a. a -> a
id (Plugin -> String
trigger Plugin
p) Content Posn
m
          [XmppMonad IO ()] -> XmppMonad IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ Plugin -> Content Posn -> XmppMonad IO ()
body Plugin
p Content Posn
m | Plugin
p <- [Plugin]
ps, Plugin -> Bool
notEmpty Plugin
p ] XmppMonad IO () -> XmppMonad IO b -> XmppMonad IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XmppMonad IO b
loop
        Left XmppError
_e -> XmppMonad IO b
loop
  in  XmppMonad IO (Either Text ())
forall b. XmppMonad IO b
loop

getNextId :: MonadIO m => XmppMonad m Int
getNextId :: XmppMonad m Int
getNextId = do
  Int
i <- (Stream -> Int) -> XmppMonad m Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Stream -> Int
idx
  (Stream -> Stream) -> XmppMonad m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\Stream
stream -> Stream
stream { idx :: Int
idx = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 })
  Int -> XmppMonad m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i