{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
module Network.XMPP.XEP.MUC
( createRoomStanza, leaveRoomStanza, destroyRoomStanza
, roomMessageStanza, privateMessageStanza, queryInstantRoomConfigStanza
, queryForAssociatedServicesStanza, submitInstantRoomConfigStanza
, setRoomMembersListStanza, queryForRoomInfoStanza
, UserJID, RoomJID, RoomMemberJID, FromXML(..), MUCPayload(..), RoomMembersList(..)
, Affiliation(..), Role(..)
)
where
import qualified Data.UUID as UUID
import qualified Data.Text as T
import Data.Maybe (listToMaybe)
import Data.Time (UTCTime)
import Text.Hamlet.XML (xml)
import Text.XML.HaXml.Xtract.Parse (xtract)
import Network.XMPP.Types
import Network.XMPP.XML
import Network.XMPP.Stanza
import Network.XMPP.XEP.Form
type UserJID = JID 'NodeResource
type RoomJID = JID 'Node
type RoomMemberJID = JID 'NodeResource
queryForAssociatedServicesStanza :: JID 'NodeResource -> Server -> UUID.UUID -> Stanza 'IQ 'Outgoing MUCPayload
queryForAssociatedServicesStanza :: JID 'NodeResource
-> Server -> UUID -> Stanza 'IQ 'Outgoing MUCPayload
queryForAssociatedServicesStanza JID 'NodeResource
from Server
srv UUID
uuid =
MkIQ :: forall (p :: StanzaPurpose) ext.
Maybe SomeJID
-> Maybe SomeJID
-> Server
-> IQType
-> DataByPurpose p ext
-> Sing p
-> Stanza 'IQ p ext
MkIQ
{ iqFrom :: Maybe SomeJID
iqFrom = SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ JID 'NodeResource -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID JID 'NodeResource
from
, iqTo :: Maybe SomeJID
iqTo = SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ JID 'Domain -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID (JID 'Domain -> SomeJID) -> JID 'Domain -> SomeJID
forall a b. (a -> b) -> a -> b
$ DomainID -> JID 'Domain
DomainJID (DomainID -> JID 'Domain) -> DomainID -> JID 'Domain
forall a b. (a -> b) -> a -> b
$ Server -> DomainID
DomainID Server
srv
, iqId :: Server
iqId = UUID -> Server
UUID.toText UUID
uuid
, iqType :: IQType
iqType = IQType
Get
, iqBody :: DataByPurpose 'Outgoing MUCPayload
iqBody = [xml|<query xmlns='http://jabber.org/protocol/disco#items'/>|]
, iqPurpose :: Sing 'Outgoing
iqPurpose = Sing 'Outgoing
SOutgoing
}
queryForRoomInfoStanza :: UserJID -> RoomJID -> UUID.UUID -> Stanza 'IQ 'Outgoing ()
queryForRoomInfoStanza :: JID 'NodeResource -> RoomJID -> UUID -> Stanza 'IQ 'Outgoing ()
queryForRoomInfoStanza JID 'NodeResource
from RoomJID
room UUID
uuid =
MkIQ :: forall (p :: StanzaPurpose) ext.
Maybe SomeJID
-> Maybe SomeJID
-> Server
-> IQType
-> DataByPurpose p ext
-> Sing p
-> Stanza 'IQ p ext
MkIQ
{ iqFrom :: Maybe SomeJID
iqFrom = SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ JID 'NodeResource -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID JID 'NodeResource
from
, iqTo :: Maybe SomeJID
iqTo = SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ RoomJID -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID RoomJID
room
, iqId :: Server
iqId = UUID -> Server
UUID.toText UUID
uuid
, iqType :: IQType
iqType = IQType
Get
, iqBody :: DataByPurpose 'Outgoing ()
iqBody = [xml|<query xmlns="http://jabber.org/protocol/disco#info">|]
, iqPurpose :: Sing 'Outgoing
iqPurpose = Sing 'Outgoing
SOutgoing
}
createRoomStanza :: UserJID -> UserJID -> UUID.UUID -> Stanza 'Presence 'Outgoing ()
createRoomStanza :: JID 'NodeResource
-> JID 'NodeResource -> UUID -> Stanza 'Presence 'Outgoing ()
createRoomStanza JID 'NodeResource
who JID 'NodeResource
room UUID
uuid =
MkPresence :: forall (p :: StanzaPurpose) ext.
Maybe SomeJID
-> Maybe SomeJID
-> Server
-> PresenceType
-> ShowType
-> Server
-> Maybe Integer
-> DataByPurpose p ext
-> Sing p
-> Stanza 'Presence p ext
MkPresence
{ pFrom :: Maybe SomeJID
pFrom = SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ JID 'NodeResource -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID JID 'NodeResource
who
, pTo :: Maybe SomeJID
pTo = SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ JID 'NodeResource -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID JID 'NodeResource
room
, pId :: Server
pId = UUID -> Server
UUID.toText UUID
uuid
, pType :: PresenceType
pType = PresenceType
Default
, pShowType :: ShowType
pShowType = ShowType
Available
, pStatus :: Server
pStatus = Server
""
, pPriority :: Maybe Integer
pPriority = Maybe Integer
forall a. Maybe a
Nothing
, pExt :: DataByPurpose 'Outgoing ()
pExt = [xml|<x xmlns="http://jabber.org/protocol/muc">|]
, pPurpose :: Sing 'Outgoing
pPurpose = Sing 'Outgoing
SOutgoing
}
leaveRoomStanza :: UserJID -> RoomMemberJID -> UUID.UUID -> Stanza 'Presence 'Outgoing ()
leaveRoomStanza :: JID 'NodeResource
-> JID 'NodeResource -> UUID -> Stanza 'Presence 'Outgoing ()
leaveRoomStanza JID 'NodeResource
user JID 'NodeResource
member UUID
uuid =
MkPresence :: forall (p :: StanzaPurpose) ext.
Maybe SomeJID
-> Maybe SomeJID
-> Server
-> PresenceType
-> ShowType
-> Server
-> Maybe Integer
-> DataByPurpose p ext
-> Sing p
-> Stanza 'Presence p ext
MkPresence
{ pFrom :: Maybe SomeJID
pFrom = SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ JID 'NodeResource -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID JID 'NodeResource
user
, pTo :: Maybe SomeJID
pTo = SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ JID 'NodeResource -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID JID 'NodeResource
member
, pId :: Server
pId = UUID -> Server
UUID.toText UUID
uuid
, pType :: PresenceType
pType = PresenceType
Unavailable
, pShowType :: ShowType
pShowType = ShowType
Available
, pStatus :: Server
pStatus = Server
""
, pPriority :: Maybe Integer
pPriority = Maybe Integer
forall a. Maybe a
Nothing
, pExt :: DataByPurpose 'Outgoing ()
pExt = []
, pPurpose :: Sing 'Outgoing
pPurpose = Sing 'Outgoing
SOutgoing
}
destroyRoomStanza :: UserJID -> RoomJID -> T.Text -> UUID.UUID -> Stanza 'IQ 'Outgoing ()
destroyRoomStanza :: JID 'NodeResource
-> RoomJID -> Server -> UUID -> Stanza 'IQ 'Outgoing ()
destroyRoomStanza JID 'NodeResource
owner RoomJID
room Server
reason UUID
uuid =
MkIQ :: forall (p :: StanzaPurpose) ext.
Maybe SomeJID
-> Maybe SomeJID
-> Server
-> IQType
-> DataByPurpose p ext
-> Sing p
-> Stanza 'IQ p ext
MkIQ
{ iqFrom :: Maybe SomeJID
iqFrom = SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ JID 'NodeResource -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID JID 'NodeResource
owner
, iqTo :: Maybe SomeJID
iqTo = SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ RoomJID -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID RoomJID
room
, iqId :: Server
iqId = UUID -> Server
UUID.toText UUID
uuid
, iqType :: IQType
iqType = IQType
Set
, iqBody :: DataByPurpose 'Outgoing ()
iqBody = [xml|
<query xmlns="http://jabber.org/protocol/muc#owner">
<destroy jid="#{T.pack (show room)}">
<reason>#{reason}</reason>
|]
, iqPurpose :: Sing 'Outgoing
iqPurpose = Sing 'Outgoing
SOutgoing
}
privateMessageStanza
:: UserJID
-> RoomMemberJID
-> T.Text
-> UUID.UUID
-> Stanza 'Message 'Outgoing ()
privateMessageStanza :: JID 'NodeResource
-> JID 'NodeResource
-> Server
-> UUID
-> Stanza 'Message 'Outgoing ()
privateMessageStanza JID 'NodeResource
from JID 'NodeResource
to Server
msg UUID
uuid =
MkMessage :: forall (p :: StanzaPurpose) ext.
Maybe SomeJID
-> Maybe SomeJID
-> Server
-> MessageType
-> Server
-> Server
-> Server
-> DataByPurpose p ext
-> Sing p
-> Stanza 'Message p ext
MkMessage
{ mFrom :: Maybe SomeJID
mFrom = SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ JID 'NodeResource -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID JID 'NodeResource
from
, mTo :: Maybe SomeJID
mTo = SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ JID 'NodeResource -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID JID 'NodeResource
to
, mId :: Server
mId = UUID -> Server
UUID.toText UUID
uuid
, mType :: MessageType
mType = MessageType
Chat
, mSubject :: Server
mSubject = Server
""
, mBody :: Server
mBody = Server
msg
, mThread :: Server
mThread = Server
""
, mExt :: DataByPurpose 'Outgoing ()
mExt = []
, mPurpose :: Sing 'Outgoing
mPurpose = Sing 'Outgoing
SOutgoing
}
roomMessageStanza
:: UserJID
-> RoomJID
-> T.Text
-> UUID.UUID
-> Stanza 'Message 'Outgoing ()
roomMessageStanza :: JID 'NodeResource
-> RoomJID -> Server -> UUID -> Stanza 'Message 'Outgoing ()
roomMessageStanza JID 'NodeResource
from RoomJID
to Server
msg UUID
uuid =
MkMessage :: forall (p :: StanzaPurpose) ext.
Maybe SomeJID
-> Maybe SomeJID
-> Server
-> MessageType
-> Server
-> Server
-> Server
-> DataByPurpose p ext
-> Sing p
-> Stanza 'Message p ext
MkMessage
{ mFrom :: Maybe SomeJID
mFrom = SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ JID 'NodeResource -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID JID 'NodeResource
from
, mTo :: Maybe SomeJID
mTo = SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ RoomJID -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID RoomJID
to
, mId :: Server
mId = UUID -> Server
UUID.toText UUID
uuid
, mType :: MessageType
mType = MessageType
GroupChat
, mSubject :: Server
mSubject = Server
""
, mBody :: Server
mBody = Server
msg
, mThread :: Server
mThread = Server
""
, mExt :: DataByPurpose 'Outgoing ()
mExt = []
, mPurpose :: Sing 'Outgoing
mPurpose = Sing 'Outgoing
SOutgoing
}
queryInstantRoomConfigStanza :: UserJID -> RoomJID -> UUID.UUID -> Stanza 'IQ 'Outgoing ()
queryInstantRoomConfigStanza :: JID 'NodeResource -> RoomJID -> UUID -> Stanza 'IQ 'Outgoing ()
queryInstantRoomConfigStanza JID 'NodeResource
owner RoomJID
room UUID
uuid =
MkIQ :: forall (p :: StanzaPurpose) ext.
Maybe SomeJID
-> Maybe SomeJID
-> Server
-> IQType
-> DataByPurpose p ext
-> Sing p
-> Stanza 'IQ p ext
MkIQ
{ iqFrom :: Maybe SomeJID
iqFrom = SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ JID 'NodeResource -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID JID 'NodeResource
owner
, iqTo :: Maybe SomeJID
iqTo = SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ RoomJID -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID RoomJID
room
, iqId :: Server
iqId = UUID -> Server
UUID.toText UUID
uuid
, iqType :: IQType
iqType = IQType
Get
, iqBody :: DataByPurpose 'Outgoing ()
iqBody = [xml| <query xmlns="http://jabber.org/protocol/muc#owner"> |]
, iqPurpose :: Sing 'Outgoing
iqPurpose = Sing 'Outgoing
SOutgoing
}
submitInstantRoomConfigStanza :: UserJID -> RoomJID -> XmppForm -> UUID.UUID -> Stanza 'IQ 'Outgoing ()
submitInstantRoomConfigStanza :: JID 'NodeResource
-> RoomJID -> XmppForm -> UUID -> Stanza 'IQ 'Outgoing ()
submitInstantRoomConfigStanza JID 'NodeResource
owner RoomJID
room XmppForm
form UUID
uuid =
MkIQ :: forall (p :: StanzaPurpose) ext.
Maybe SomeJID
-> Maybe SomeJID
-> Server
-> IQType
-> DataByPurpose p ext
-> Sing p
-> Stanza 'IQ p ext
MkIQ
{ iqFrom :: Maybe SomeJID
iqFrom = SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ JID 'NodeResource -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID JID 'NodeResource
owner
, iqTo :: Maybe SomeJID
iqTo = SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ RoomJID -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID RoomJID
room
, iqId :: Server
iqId = UUID -> Server
UUID.toText UUID
uuid
, iqType :: IQType
iqType = IQType
Set
, iqBody :: DataByPurpose 'Outgoing ()
iqBody = [xml|<query xmlns="http://jabber.org/protocol/muc#owner">^{encodeXml form}|]
, iqPurpose :: Sing 'Outgoing
iqPurpose = Sing 'Outgoing
SOutgoing
}
setRoomMembersListStanza :: RoomJID -> UserJID -> RoomMembersList -> UUID.UUID -> Stanza 'IQ 'Outgoing ()
setRoomMembersListStanza :: RoomJID
-> JID 'NodeResource
-> RoomMembersList
-> UUID
-> Stanza 'IQ 'Outgoing ()
setRoomMembersListStanza RoomJID
room JID 'NodeResource
admin RoomMembersList
members UUID
uuid =
MkIQ :: forall (p :: StanzaPurpose) ext.
Maybe SomeJID
-> Maybe SomeJID
-> Server
-> IQType
-> DataByPurpose p ext
-> Sing p
-> Stanza 'IQ p ext
MkIQ
{ iqFrom :: Maybe SomeJID
iqFrom = SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ JID 'NodeResource -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID JID 'NodeResource
admin
, iqTo :: Maybe SomeJID
iqTo = SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ RoomJID -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID RoomJID
room
, iqId :: Server
iqId = UUID -> Server
UUID.toText UUID
uuid
, iqType :: IQType
iqType = IQType
Set
, iqBody :: DataByPurpose 'Outgoing ()
iqBody = [xml|
<query xmlns="http://jabber.org/protocol/muc#admin">
^{encodeXml members}
|]
, iqPurpose :: Sing 'Outgoing
iqPurpose = Sing 'Outgoing
SOutgoing
}
data Affiliation =
OwnerAffiliation
| AdminAffiliation
| MemberAffiliation
| OutcastAffiliation
| NoneAffiliation
deriving (Affiliation -> Affiliation -> Bool
(Affiliation -> Affiliation -> Bool)
-> (Affiliation -> Affiliation -> Bool) -> Eq Affiliation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Affiliation -> Affiliation -> Bool
$c/= :: Affiliation -> Affiliation -> Bool
== :: Affiliation -> Affiliation -> Bool
$c== :: Affiliation -> Affiliation -> Bool
Eq, Int -> Affiliation -> ShowS
[Affiliation] -> ShowS
Affiliation -> String
(Int -> Affiliation -> ShowS)
-> (Affiliation -> String)
-> ([Affiliation] -> ShowS)
-> Show Affiliation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Affiliation] -> ShowS
$cshowList :: [Affiliation] -> ShowS
show :: Affiliation -> String
$cshow :: Affiliation -> String
showsPrec :: Int -> Affiliation -> ShowS
$cshowsPrec :: Int -> Affiliation -> ShowS
Show)
data Role =
ModeratorRole
| NoneRole
| ParticipantRole
| VisitorRole
deriving (Role -> Role -> Bool
(Role -> Role -> Bool) -> (Role -> Role -> Bool) -> Eq Role
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Role -> Role -> Bool
$c/= :: Role -> Role -> Bool
== :: Role -> Role -> Bool
$c== :: Role -> Role -> Bool
Eq, Int -> Role -> ShowS
[Role] -> ShowS
Role -> String
(Int -> Role -> ShowS)
-> (Role -> String) -> ([Role] -> ShowS) -> Show Role
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Role] -> ShowS
$cshowList :: [Role] -> ShowS
show :: Role -> String
$cshow :: Role -> String
showsPrec :: Int -> Role -> ShowS
$cshowsPrec :: Int -> Role -> ShowS
Show)
data MUCPayload =
MUCRoomCreated Affiliation Role
| MUCRoomQuery XmppForm
| MUCRoomConfigRejected
| MUCNotFound T.Text
| MUCMembersPresences Affiliation Role
| MUCMessageId T.Text
| MUCArchivedMessage
{ MUCPayload -> Stanza 'Message 'Incoming ()
mamMessage :: Stanza 'Message 'Incoming ()
, MUCPayload -> JID 'Domain
mamFrom :: JID 'Domain
, MUCPayload -> UTCTime
mamWhen :: UTCTime
, MUCPayload -> Server
mamStoredId :: T.Text
}
deriving instance Show MUCPayload
newtype RoomMembersList = RoomMembersList [(UserJID, Affiliation)]
deriving (RoomMembersList -> RoomMembersList -> Bool
(RoomMembersList -> RoomMembersList -> Bool)
-> (RoomMembersList -> RoomMembersList -> Bool)
-> Eq RoomMembersList
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RoomMembersList -> RoomMembersList -> Bool
$c/= :: RoomMembersList -> RoomMembersList -> Bool
== :: RoomMembersList -> RoomMembersList -> Bool
$c== :: RoomMembersList -> RoomMembersList -> Bool
Eq, Int -> RoomMembersList -> ShowS
[RoomMembersList] -> ShowS
RoomMembersList -> String
(Int -> RoomMembersList -> ShowS)
-> (RoomMembersList -> String)
-> ([RoomMembersList] -> ShowS)
-> Show RoomMembersList
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RoomMembersList] -> ShowS
$cshowList :: [RoomMembersList] -> ShowS
show :: RoomMembersList -> String
$cshow :: RoomMembersList -> String
showsPrec :: Int -> RoomMembersList -> ShowS
$cshowsPrec :: Int -> RoomMembersList -> ShowS
Show)
instance ToXML RoomMembersList where
encodeXml :: RoomMembersList -> [Node]
encodeXml (RoomMembersList [(JID 'NodeResource, Affiliation)]
members) =
[xml|
$forall (jid, affiliation) <- members
<item affiliation="#{encodeAffiliation affiliation}"
jid="#{T.pack $ show $ toBareJID jid}">
|]
instance FromXML MUCPayload where
decodeXml :: Content Posn -> Maybe MUCPayload
decodeXml Content Posn
m
| Content Posn -> [Server] -> Bool
forall i. Content i -> [Server] -> Bool
matchPatterns Content Posn
m [Server
"/x/item/@jid", Server
"/x/item/@role", Server
"/x/item/@affiliation"]
= Affiliation -> Role -> MUCPayload
MUCRoomCreated
(Affiliation -> Role -> MUCPayload)
-> Maybe Affiliation -> Maybe (Role -> MUCPayload)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Server -> Maybe Affiliation
parseAffiliation (Server -> Content Posn -> Server
txtpat Server
"/x/item/@affiliation" Content Posn
m)
Maybe (Role -> MUCPayload) -> Maybe Role -> Maybe MUCPayload
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Server -> Maybe Role
parseRole (Server -> Content Posn -> Server
txtpat Server
"/x/item/@role" Content Posn
m)
| Content Posn -> [Server] -> Bool
forall i. Content i -> [Server] -> Bool
matchPatterns Content Posn
m [Server
"/query/x"]
= XmppForm -> MUCPayload
MUCRoomQuery (XmppForm -> MUCPayload) -> Maybe XmppForm -> Maybe MUCPayload
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Content Posn] -> Maybe (Content Posn)
forall a. [a] -> Maybe a
listToMaybe (ShowS -> String -> CFilter Posn
forall i. ShowS -> String -> CFilter i
xtract ShowS
forall a. a -> a
id String
"/query/x" Content Posn
m) Maybe (Content Posn)
-> (Content Posn -> Maybe XmppForm) -> Maybe XmppForm
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Content Posn -> Maybe XmppForm
forall a. FromXML a => Content Posn -> Maybe a
decodeXml)
| Content Posn -> [Server] -> Bool
forall i. Content i -> [Server] -> Bool
matchPatterns
Content Posn
m
[Server
"/error[@code='404']", Server
"/error[@type='cancel']", Server
"/error/item-not-found"]
= MUCPayload -> Maybe MUCPayload
forall a. a -> Maybe a
Just (MUCPayload -> Maybe MUCPayload) -> MUCPayload -> Maybe MUCPayload
forall a b. (a -> b) -> a -> b
$ Server -> MUCPayload
MUCNotFound (Server -> MUCPayload) -> Server -> MUCPayload
forall a b. (a -> b) -> a -> b
$ Server -> Content Posn -> Server
txtpat Server
"/error/text/-" Content Posn
m
| Content Posn -> [Server] -> Bool
forall i. Content i -> [Server] -> Bool
matchPatterns
Content Posn
m
[ Server
"/query[@type='cancel]"
, Server
"/query[@xmlns='http://jabber.org/protocol/muc#owner']"
]
= MUCPayload -> Maybe MUCPayload
forall a. a -> Maybe a
Just MUCPayload
MUCRoomConfigRejected
| Content Posn -> [Server] -> Bool
forall i. Content i -> [Server] -> Bool
matchPatterns Content Posn
m [Server
"/x/item/@affiliation", Server
"/x/item/@role"]
= Affiliation -> Role -> MUCPayload
MUCMembersPresences
(Affiliation -> Role -> MUCPayload)
-> Maybe Affiliation -> Maybe (Role -> MUCPayload)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Server -> Maybe Affiliation
parseAffiliation (Server -> Content Posn -> Server
txtpat Server
"/x/item/@affiliation" Content Posn
m)
Maybe (Role -> MUCPayload) -> Maybe Role -> Maybe MUCPayload
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Server -> Maybe Role
parseRole (Server -> Content Posn -> Server
txtpat Server
"/x/item/@role" Content Posn
m)
| Content Posn -> [Server] -> Bool
forall i. Content i -> [Server] -> Bool
matchPatterns Content Posn
m [Server
"/result", Server
"/result/forwarded/message"]
= let
mMsg :: Maybe (Stanza 'Message 'Incoming ())
mMsg =
[Content Posn] -> Maybe (Content Posn)
forall a. [a] -> Maybe a
listToMaybe (ShowS -> String -> CFilter Posn
forall i. ShowS -> String -> CFilter i
xtract ShowS
forall a. a -> a
id String
"/result/forwarded/message" Content Posn
m) Maybe (Content Posn)
-> (Content Posn -> Maybe (Stanza 'Message 'Incoming ()))
-> Maybe (Stanza 'Message 'Incoming ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Content Posn -> Maybe (Stanza 'Message 'Incoming ())
forall (t :: StanzaType) (p :: StanzaPurpose) e a.
StanzaDecoder t p e a =>
a -> Maybe (Stanza t p e)
decodeStanza
mFrom :: Maybe (JID 'Domain)
mFrom = Server -> Maybe (JID 'Domain)
forall a. Read a => Server -> Maybe a
mread (Server -> Maybe (JID 'Domain)) -> Server -> Maybe (JID 'Domain)
forall a b. (a -> b) -> a -> b
$ Server -> Content Posn -> Server
txtpat Server
"/result/forwarded/delay/@from" Content Posn
m
mTime :: Maybe UTCTime
mTime =
Server -> Maybe UTCTime
forall a. Read a => Server -> Maybe a
mread (Server -> Maybe UTCTime) -> Server -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ Server -> Server -> Server -> Server
T.replace Server
"T" Server
" " (Server -> Server) -> Server -> Server
forall a b. (a -> b) -> a -> b
$ Server -> Content Posn -> Server
txtpat Server
"/result/forwarded/delay/@stamp" Content Posn
m
storedId :: Server
storedId = Server -> Content Posn -> Server
txtpat Server
"/result/forwarded/message/stanza-id/@id" Content Posn
m
in
Stanza 'Message 'Incoming ()
-> JID 'Domain -> UTCTime -> Server -> MUCPayload
MUCArchivedMessage (Stanza 'Message 'Incoming ()
-> JID 'Domain -> UTCTime -> Server -> MUCPayload)
-> Maybe (Stanza 'Message 'Incoming ())
-> Maybe (JID 'Domain -> UTCTime -> Server -> MUCPayload)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Stanza 'Message 'Incoming ())
mMsg Maybe (JID 'Domain -> UTCTime -> Server -> MUCPayload)
-> Maybe (JID 'Domain) -> Maybe (UTCTime -> Server -> MUCPayload)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (JID 'Domain)
mFrom Maybe (UTCTime -> Server -> MUCPayload)
-> Maybe UTCTime -> Maybe (Server -> MUCPayload)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe UTCTime
mTime Maybe (Server -> MUCPayload) -> Maybe Server -> Maybe MUCPayload
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Server -> Maybe Server
forall a. a -> Maybe a
Just Server
storedId
| Content Posn -> [Server] -> Bool
forall i. Content i -> [Server] -> Bool
matchPatterns Content Posn
m [Server
"/stanza-id/@id"]
= MUCPayload -> Maybe MUCPayload
forall a. a -> Maybe a
Just (MUCPayload -> Maybe MUCPayload) -> MUCPayload -> Maybe MUCPayload
forall a b. (a -> b) -> a -> b
$ Server -> MUCPayload
MUCMessageId (Server -> MUCPayload) -> Server -> MUCPayload
forall a b. (a -> b) -> a -> b
$ Server -> Content Posn -> Server
txtpat Server
"/stanza-id/@id" Content Posn
m
| Bool
otherwise
= Maybe MUCPayload
forall a. Maybe a
Nothing
encodeAffiliation :: Affiliation -> T.Text
encodeAffiliation :: Affiliation -> Server
encodeAffiliation Affiliation
OwnerAffiliation = Server
"owner"
encodeAffiliation Affiliation
AdminAffiliation = Server
"admin"
encodeAffiliation Affiliation
MemberAffiliation = Server
"member"
encodeAffiliation Affiliation
OutcastAffiliation = Server
"outcast"
encodeAffiliation Affiliation
NoneAffiliation = Server
"none"
parseAffiliation :: T.Text -> Maybe Affiliation
parseAffiliation :: Server -> Maybe Affiliation
parseAffiliation Server
v = case Server
v of
Server
"owner" -> Affiliation -> Maybe Affiliation
forall a. a -> Maybe a
Just Affiliation
OwnerAffiliation
Server
"admin" -> Affiliation -> Maybe Affiliation
forall a. a -> Maybe a
Just Affiliation
AdminAffiliation
Server
"member" -> Affiliation -> Maybe Affiliation
forall a. a -> Maybe a
Just Affiliation
MemberAffiliation
Server
"outcast" -> Affiliation -> Maybe Affiliation
forall a. a -> Maybe a
Just Affiliation
OutcastAffiliation
Server
_ -> Maybe Affiliation
forall a. Maybe a
Nothing
parseRole :: T.Text -> Maybe Role
parseRole :: Server -> Maybe Role
parseRole Server
v = case Server
v of
Server
"moderator" -> Role -> Maybe Role
forall a. a -> Maybe a
Just Role
ModeratorRole
Server
"participant" -> Role -> Maybe Role
forall a. a -> Maybe a
Just Role
ParticipantRole
Server
"visitor" -> Role -> Maybe Role
forall a. a -> Maybe a
Just Role
VisitorRole
Server
_ -> Maybe Role
forall a. Maybe a
Nothing