{-# 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 , pierre -- 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 from srv uuid = MkIQ { iqFrom = Just $ SomeJID from , iqTo = Just $ SomeJID $ DomainJID $ DomainID srv , iqId = UUID.toText uuid , iqType = Get , iqBody = [xml||] , iqPurpose = SOutgoing } queryForRoomInfoStanza :: UserJID -> RoomJID -> UUID.UUID -> Stanza 'IQ 'Outgoing () queryForRoomInfoStanza from room uuid = MkIQ { iqFrom = Just $ SomeJID from , iqTo = Just $ SomeJID room , iqId = UUID.toText uuid , iqType = Get , iqBody = [xml||] , iqPurpose = SOutgoing } createRoomStanza :: UserJID -> UserJID -> UUID.UUID -> Stanza 'Presence 'Outgoing () createRoomStanza who room uuid = MkPresence { pFrom = Just $ SomeJID who , pTo = Just $ SomeJID room , pId = UUID.toText uuid , pType = Default , pShowType = Available , pStatus = "" , pPriority = Nothing , pExt = [xml||] , pPurpose = SOutgoing } leaveRoomStanza :: UserJID -> RoomMemberJID -> UUID.UUID -> Stanza 'Presence 'Outgoing () leaveRoomStanza user member uuid = MkPresence { pFrom = Just $ SomeJID user , pTo = Just $ SomeJID member , pId = UUID.toText uuid , pType = Unavailable , pShowType = Available , pStatus = "" , pPriority = Nothing , pExt = [] , pPurpose = SOutgoing } destroyRoomStanza :: UserJID -> RoomJID -> T.Text -> UUID.UUID -> Stanza 'IQ 'Outgoing () destroyRoomStanza owner room reason uuid = MkIQ { iqFrom = Just $ SomeJID owner , iqTo = Just $ SomeJID room , iqId = UUID.toText uuid , iqType = Set , iqBody = [xml| #{reason} |] , iqPurpose = SOutgoing } privateMessageStanza :: UserJID -> RoomMemberJID -> T.Text -> UUID.UUID -> Stanza 'Message 'Outgoing () privateMessageStanza from to msg uuid = MkMessage { mFrom = Just $ SomeJID from , mTo = Just $ SomeJID to , mId = UUID.toText uuid , mType = Chat , mSubject = "" , mBody = msg , mThread = "" , mExt = [] , mPurpose = SOutgoing } roomMessageStanza :: UserJID -> RoomJID -> T.Text -> UUID.UUID -> Stanza 'Message 'Outgoing () roomMessageStanza from to msg uuid = MkMessage { mFrom = Just $ SomeJID from , mTo = Just $ SomeJID to , mId = UUID.toText uuid , mType = GroupChat , mSubject = "" , mBody = msg , mThread = "" , mExt = [] , mPurpose = SOutgoing } queryInstantRoomConfigStanza :: UserJID -> RoomJID -> UUID.UUID -> Stanza 'IQ 'Outgoing () queryInstantRoomConfigStanza owner room uuid = MkIQ { iqFrom = Just $ SomeJID owner , iqTo = Just $ SomeJID room , iqId = UUID.toText uuid , iqType = Get , iqBody = [xml| |] , iqPurpose = SOutgoing } submitInstantRoomConfigStanza :: UserJID -> RoomJID -> XmppForm -> UUID.UUID -> Stanza 'IQ 'Outgoing () submitInstantRoomConfigStanza owner room form uuid = MkIQ { iqFrom = Just $ SomeJID owner , iqTo = Just $ SomeJID room , iqId = UUID.toText uuid , iqType = Set , iqBody = [xml|^{encodeXml form}|] , iqPurpose = SOutgoing } setRoomMembersListStanza :: RoomJID -> UserJID -> RoomMembersList -> UUID.UUID -> Stanza 'IQ 'Outgoing () setRoomMembersListStanza room admin members uuid = MkIQ { iqFrom = Just $ SomeJID admin , iqTo = Just $ SomeJID room , iqId = UUID.toText uuid , iqType = Set , iqBody = [xml| ^{encodeXml members} |] , iqPurpose = SOutgoing } data Affiliation = OwnerAffiliation | AdminAffiliation | MemberAffiliation | OutcastAffiliation | NoneAffiliation deriving (Eq, Show) data Role = ModeratorRole | NoneRole | ParticipantRole | VisitorRole deriving (Eq, Show) data MUCPayload = MUCRoomCreated Affiliation Role | MUCRoomQuery XmppForm | MUCRoomConfigRejected | MUCNotFound T.Text | MUCMembersPresences Affiliation Role | MUCMessageId T.Text | MUCArchivedMessage { mamMessage :: Stanza 'Message 'Incoming () , mamFrom :: JID 'Domain , mamWhen :: UTCTime , mamStoredId :: T.Text } deriving instance Show MUCPayload newtype RoomMembersList = RoomMembersList [(UserJID, Affiliation)] deriving (Eq, Show) instance ToXML RoomMembersList where encodeXml (RoomMembersList members) = [xml| $forall (jid, affiliation) <- members |] instance FromXML MUCPayload where decodeXml m | matchPatterns m ["/x/item/@jid", "/x/item/@role", "/x/item/@affiliation"] = MUCRoomCreated <$> parseAffiliation (txtpat "/x/item/@affiliation" m) <*> parseRole (txtpat "/x/item/@role" m) | matchPatterns m ["/query/x"] = MUCRoomQuery <$> (listToMaybe (xtract id "/query/x" m) >>= decodeXml) | matchPatterns m ["/error[@code='404']", "/error[@type='cancel']", "/error/item-not-found"] = Just $ MUCNotFound $ txtpat "/error/text/-" m | matchPatterns m [ "/query[@type='cancel]" , "/query[@xmlns='http://jabber.org/protocol/muc#owner']" ] = Just MUCRoomConfigRejected | matchPatterns m ["/x/item/@affiliation", "/x/item/@role"] = MUCMembersPresences <$> parseAffiliation (txtpat "/x/item/@affiliation" m) <*> parseRole (txtpat "/x/item/@role" m) | matchPatterns m ["/result", "/result/forwarded/message"] = let mMsg = listToMaybe (xtract id "/result/forwarded/message" m) >>= decodeStanza mFrom = mread $ txtpat "/result/forwarded/delay/@from" m mTime = mread $ T.replace "T" " " $ txtpat "/result/forwarded/delay/@stamp" m storedId = txtpat "/result/forwarded/message/stanza-id/@id" m in MUCArchivedMessage <$> mMsg <*> mFrom <*> mTime <*> Just storedId | matchPatterns m ["/stanza-id/@id"] = Just $ MUCMessageId $ txtpat "/stanza-id/@id" m | otherwise = Nothing encodeAffiliation :: Affiliation -> T.Text encodeAffiliation OwnerAffiliation = "owner" encodeAffiliation AdminAffiliation = "admin" encodeAffiliation MemberAffiliation = "member" encodeAffiliation OutcastAffiliation = "outcast" encodeAffiliation NoneAffiliation = "none" parseAffiliation :: T.Text -> Maybe Affiliation parseAffiliation v = case v of "owner" -> Just OwnerAffiliation "admin" -> Just AdminAffiliation "member" -> Just MemberAffiliation "outcast" -> Just OutcastAffiliation _ -> Nothing parseRole :: T.Text -> Maybe Role parseRole v = case v of "moderator" -> Just ModeratorRole "participant" -> Just ParticipantRole "visitor" -> Just VisitorRole _ -> Nothing