{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
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
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)
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)
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
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
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
(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
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"
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 []
textractM :: MonadIO m => Text -> XmppMonad m Text
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 :: 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
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) })
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