{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE StandaloneDeriving #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Network.XMPP.XEP.MUC
-- Copyright   :  (c) pierre, 2007
-- License     :  BSD-style (see the file libraries/base/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
--
-- XEP-0045, join\/kick\/ban\/leave functionality
--
-----------------------------------------------------------------------------
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       -- fully qualified user JID in Jabber: for example - JohnWick@localhost/riskbook-web
type RoomJID = JID 'Node               -- for example - programmers@localhost
type RoomMemberJID = JID 'NodeResource -- for example - programmers@localhost/NikitaRzm

-- | https://xmpp.org/extensions/xep-0045.html#disco-service
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