{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
module Network.Xmpp.Extras.MUC
( MUCHistoryReq(..)
, joinMUC
, joinMUCResult
, sendMUC
) where
import Data.Default
import Data.Maybe
import Data.Text as T
import Data.Time
import Data.XML.Types
import Network.Xmpp.Extras.DateTime
import Network.Xmpp.Internal hiding (priority, status)
data MUCHistoryReq = MUCHistoryReq
{ MUCHistoryReq -> Maybe Integer
mhrMaxChars :: Maybe Integer
, MUCHistoryReq -> Maybe Integer
mhrMaxStanzas :: Maybe Integer
, MUCHistoryReq -> Maybe Integer
mhrSeconds :: Maybe Integer
, MUCHistoryReq -> Maybe UTCTime
mhrSince :: Maybe UTCTime
}
instance Default MUCHistoryReq where
def :: MUCHistoryReq
def = Maybe Integer
-> Maybe Integer -> Maybe Integer -> Maybe UTCTime -> MUCHistoryReq
MUCHistoryReq Maybe Integer
forall a. Maybe a
Nothing Maybe Integer
forall a. Maybe a
Nothing Maybe Integer
forall a. Maybe a
Nothing Maybe UTCTime
forall a. Maybe a
Nothing
joinMUC :: Jid -> Maybe MUCHistoryReq -> Session -> IO (Either XmppFailure ())
joinMUC :: Jid -> Maybe MUCHistoryReq -> Session -> IO (Either XmppFailure ())
joinMUC Jid
jid Maybe MUCHistoryReq
mhr = Presence -> Session -> IO (Either XmppFailure ())
sendPresence ((Presence -> Jid -> Presence
presTo Presence
presence Jid
jid) { presencePayload :: [Element]
presencePayload = [Name -> [(Name, [Content])] -> [Node] -> Element
Element Name
"x" [(Name
"xmlns", [Text -> Content
ContentText Text
"http://jabber.org/protocol/muc"])] ([Node] -> Element) -> [Node] -> Element
forall a b. (a -> b) -> a -> b
$ [Node]
-> (MUCHistoryReq -> [Node]) -> Maybe MUCHistoryReq -> [Node]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\MUCHistoryReq
hr -> [
Element -> Node
NodeElement (Element -> Node) -> Element -> Node
forall a b. (a -> b) -> a -> b
$ Name -> [(Name, [Content])] -> [Node] -> Element
Element Name
"history" (
([Char]
-> (Integer -> [Char]) -> Maybe Integer -> [(Name, [Content])]
forall a p t.
IsString a =>
p -> (t -> [Char]) -> Maybe t -> [(a, [Content])]
elementify [Char]
"maxchars" Integer -> [Char]
forall a. Show a => a -> [Char]
show (Maybe Integer -> [(Name, [Content])])
-> Maybe Integer -> [(Name, [Content])]
forall a b. (a -> b) -> a -> b
$ MUCHistoryReq -> Maybe Integer
mhrMaxChars MUCHistoryReq
hr) [(Name, [Content])] -> [(Name, [Content])] -> [(Name, [Content])]
forall a. [a] -> [a] -> [a]
++
([Char]
-> (Integer -> [Char]) -> Maybe Integer -> [(Name, [Content])]
forall a p t.
IsString a =>
p -> (t -> [Char]) -> Maybe t -> [(a, [Content])]
elementify [Char]
"maxstanzas" Integer -> [Char]
forall a. Show a => a -> [Char]
show (Maybe Integer -> [(Name, [Content])])
-> Maybe Integer -> [(Name, [Content])]
forall a b. (a -> b) -> a -> b
$ MUCHistoryReq -> Maybe Integer
mhrMaxStanzas MUCHistoryReq
hr) [(Name, [Content])] -> [(Name, [Content])] -> [(Name, [Content])]
forall a. [a] -> [a] -> [a]
++
([Char]
-> (Integer -> [Char]) -> Maybe Integer -> [(Name, [Content])]
forall a p t.
IsString a =>
p -> (t -> [Char]) -> Maybe t -> [(a, [Content])]
elementify [Char]
"seconds" Integer -> [Char]
forall a. Show a => a -> [Char]
show (Maybe Integer -> [(Name, [Content])])
-> Maybe Integer -> [(Name, [Content])]
forall a b. (a -> b) -> a -> b
$ MUCHistoryReq -> Maybe Integer
mhrSeconds MUCHistoryReq
hr) [(Name, [Content])] -> [(Name, [Content])] -> [(Name, [Content])]
forall a. [a] -> [a] -> [a]
++
([Char]
-> (UTCTime -> [Char]) -> Maybe UTCTime -> [(Name, [Content])]
forall a p t.
IsString a =>
p -> (t -> [Char]) -> Maybe t -> [(a, [Content])]
elementify [Char]
"since" UTCTime -> [Char]
toDateTime (Maybe UTCTime -> [(Name, [Content])])
-> Maybe UTCTime -> [(Name, [Content])]
forall a b. (a -> b) -> a -> b
$ MUCHistoryReq -> Maybe UTCTime
mhrSince MUCHistoryReq
hr)
) []]) Maybe MUCHistoryReq
mhr
] } )
where elementify :: p -> (t -> [Char]) -> Maybe t -> [(a, [Content])]
elementify p
name t -> [Char]
show Maybe t
content = (t -> (a, [Content])) -> [t] -> [(a, [Content])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\t
s -> (a
"seconds", [Text -> Content
ContentText (Text -> Content) -> Text -> Content
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ t -> [Char]
show t
s])) ([t] -> [(a, [Content])]) -> [t] -> [(a, [Content])]
forall a b. (a -> b) -> a -> b
$ Maybe t -> [t]
forall a. Maybe a -> [a]
maybeToList Maybe t
content
joinMUCResult :: Jid -> Maybe MUCHistoryReq -> Session -> IO (Either StanzaError PresenceType)
joinMUCResult :: Jid
-> Maybe MUCHistoryReq
-> Session
-> IO (Either StanzaError PresenceType)
joinMUCResult Jid
jid Maybe MUCHistoryReq
mhr Session
sess = do
Jid -> Maybe MUCHistoryReq -> Session -> IO (Either XmppFailure ())
joinMUC Jid
jid Maybe MUCHistoryReq
mhr Session
sess
Jid -> Session -> IO (Either StanzaError PresenceType)
waitForResult Jid
jid Session
sess
waitForResult :: Jid -> Session -> IO (Either StanzaError PresenceType)
waitForResult :: Jid -> Session -> IO (Either StanzaError PresenceType)
waitForResult Jid
jid Session
sess = do
Either PresenceError Presence
pres <- Session -> IO (Either PresenceError Presence)
pullPresence Session
sess
case Either PresenceError Presence
pres of
Left p :: PresenceError
p@(PresenceError {[ExtendedAttribute]
[Element]
Maybe Text
Maybe LangTag
Maybe Jid
StanzaError
presenceErrorID :: PresenceError -> Maybe Text
presenceErrorFrom :: PresenceError -> Maybe Jid
presenceErrorTo :: PresenceError -> Maybe Jid
presenceErrorLangTag :: PresenceError -> Maybe LangTag
presenceErrorStanzaError :: PresenceError -> StanzaError
presenceErrorPayload :: PresenceError -> [Element]
presenceErrorAttributes :: PresenceError -> [ExtendedAttribute]
presenceErrorAttributes :: [ExtendedAttribute]
presenceErrorPayload :: [Element]
presenceErrorStanzaError :: StanzaError
presenceErrorLangTag :: Maybe LangTag
presenceErrorTo :: Maybe Jid
presenceErrorFrom :: Maybe Jid
presenceErrorID :: Maybe Text
..}) | Maybe Jid
presenceErrorFrom Maybe Jid -> Maybe Jid -> Bool
forall a. Eq a => a -> a -> Bool
== Jid -> Maybe Jid
forall a. a -> Maybe a
Just Jid
jid -> Either StanzaError PresenceType
-> IO (Either StanzaError PresenceType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StanzaError PresenceType
-> IO (Either StanzaError PresenceType))
-> Either StanzaError PresenceType
-> IO (Either StanzaError PresenceType)
forall a b. (a -> b) -> a -> b
$ StanzaError -> Either StanzaError PresenceType
forall a b. a -> Either a b
Left StanzaError
presenceErrorStanzaError
| Bool
otherwise -> Jid -> Session -> IO (Either StanzaError PresenceType)
waitForResult Jid
jid Session
sess
Right p :: Presence
p@(Presence{[ExtendedAttribute]
[Element]
Maybe Text
Maybe LangTag
Maybe Jid
PresenceType
presenceID :: Presence -> Maybe Text
presenceFrom :: Presence -> Maybe Jid
presenceTo :: Presence -> Maybe Jid
presenceLangTag :: Presence -> Maybe LangTag
presenceType :: Presence -> PresenceType
presenceAttributes :: Presence -> [ExtendedAttribute]
presenceAttributes :: [ExtendedAttribute]
presencePayload :: [Element]
presenceType :: PresenceType
presenceLangTag :: Maybe LangTag
presenceTo :: Maybe Jid
presenceFrom :: Maybe Jid
presenceID :: Maybe Text
presencePayload :: Presence -> [Element]
..}) | Maybe Jid
presenceFrom Maybe Jid -> Maybe Jid -> Bool
forall a. Eq a => a -> a -> Bool
== Jid -> Maybe Jid
forall a. a -> Maybe a
Just Jid
jid -> Either StanzaError PresenceType
-> IO (Either StanzaError PresenceType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StanzaError PresenceType
-> IO (Either StanzaError PresenceType))
-> Either StanzaError PresenceType
-> IO (Either StanzaError PresenceType)
forall a b. (a -> b) -> a -> b
$ PresenceType -> Either StanzaError PresenceType
forall a b. b -> Either a b
Right PresenceType
presenceType
| Bool
otherwise -> Jid -> Session -> IO (Either StanzaError PresenceType)
waitForResult Jid
jid Session
sess
sendMUC :: Jid -> Text -> Session -> IO (Either XmppFailure ())
sendMUC :: Jid -> Text -> Session -> IO (Either XmppFailure ())
sendMUC Jid
jid Text
text = Message -> Session -> IO (Either XmppFailure ())
sendMessage ((Jid -> Text -> Message
simpleIM Jid
jid Text
text) { messageType :: MessageType
messageType = MessageType
GroupChat })