haskell-xmpp-2.0.0: src/Network/XMPP/Types.hs
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module : Network.XMPP.Types
-- Copyright : (c) Dmitry Astapov, 2006 ; pierre, 2007
-- License : BSD-style (see the file 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
--
-----------------------------------------------------------------------------
module Network.XMPP.Types where
import System.IO (Handle, stdin)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans (MonadTrans)
import Control.Monad.State (MonadState, StateT, runStateT)
import Data.Maybe (maybeToList)
import qualified Data.Text as T
import Text.Blaze (ToMarkup (toMarkup))
import Text.Regex
import Text.XML.HaXml.Types (Content)
import Text.XML.HaXml.Posn (Posn)
import Text.XML.HaXml.Lex (Token)
import Text.XML (Node)
import Singlethongs
--------------------------------------------------------------------------------
type Server = T.Text
type Username = T.Text
type Password = T.Text
type Resource = T.Text
--------------------------------------------------------------------------------
-- | XMPP stream, used as a state in XmppMonad state transformer
data Stream
= Stream
{ handle::Handle -- ^ IO handle to the underlying file or socket
, idx :: !Int -- ^ id of the next message (if needed)
, lexemes :: [Token] -- ^ Stream of the lexemes coming from server
}
newtype XmppMonad m a
= XmppMonad { unXmppMonad :: StateT Stream m a }
deriving (Functor, Applicative, Monad, MonadIO, MonadState Stream, MonadTrans)
runXmppMonad :: MonadIO m => XmppMonad m a -> m (a, Stream)
runXmppMonad = flip runStateT newStream . unXmppMonad
where newStream = Stream { handle = stdin, idx = 0, lexemes = [] }
runXmppMonad' :: MonadIO m => Stream -> XmppMonad m a -> m (a, Stream)
runXmppMonad' s = flip runStateT s . unXmppMonad
--------------------------------------------------------------------------------
-- | Jabber ID (JID) datatype
--
-- https://xmpp.org/extensions/xep-0029.html#sect-idm45723967532368
-- <JID> - [<node>"@"]<domain>["/"<resource>]
-- <node> - <conforming-char>[<conforming-char>]* - The node identifier (optional)
-- <domain> - <hname>["."<hname>]* - The domain identifier (required)
-- <resource> - <any-char>[<any-char>]* - The resource identifier (optional)
newtype DomainID = DomainID { unDomainID :: T.Text } deriving (Eq, Show)
newtype NodeID = NodeID { unNodeID :: T.Text } deriving (Eq, Show)
newtype ResourceID = ResourceID { unResourceID :: T.Text } deriving (Eq, Show)
data JIDQualification
= Resource
| NodeResource
| Node
| Domain
data SomeJID = forall (a :: JIDQualification). SomeJID (JID a)
data JID :: JIDQualification -> * where
ResourceJID :: { jrDomain :: DomainID
, jrResource :: ResourceID
} -> JID 'Resource
NodeResourceJID :: { jnrNode :: NodeID -- ^ Account name
, jnrDomain :: DomainID -- ^ Server adress
, jnrResource :: ResourceID -- ^ Resource name
} -> JID 'NodeResource
NodeJID :: { nNode :: NodeID
, nDomain :: DomainID
} -> JID 'Node
DomainJID :: { jdDomain :: DomainID } -> JID 'Domain
toBareJID :: JID 'NodeResource -> JID 'Node
toBareJID (NodeResourceJID node domain _) = NodeJID node domain
instance Read (JID 'NodeResource) where
readsPrec prev str =
case readsPrec prev str of
[(SomeJID j@NodeResourceJID{}, after)] -> [(j, after)]
_ -> []
instance Read (JID 'Resource) where
readsPrec prev str =
case readsPrec prev str of
[(SomeJID j@ResourceJID{}, after)] -> [(j, after)]
_ -> []
instance Read (JID 'Domain) where
readsPrec prev str =
case readsPrec prev str of
[(SomeJID j@DomainJID{}, after)] -> [(j, after)]
_ -> []
instance Read (JID 'Node) where
readsPrec prev str =
case readsPrec prev str of
[(SomeJID j@NodeJID{}, after)] -> [(j, after)]
_ -> []
instance Read SomeJID where
-- Reads JID from string (name@server\/resource)
readsPrec _ str = case matchRegexAll regex str of
Just (_, _, after, [_, name, _, server, _, _, resource, _]) ->
fmap (, after) . maybeToList $ case (toMaybe name, server, toMaybe resource) of
(Just node, domain, Just resource) ->
let nodeId = NodeID $ T.pack node
domainId = DomainID $ T.pack domain
resourceId = ResourceID $ T.pack resource
in Just $ SomeJID $ NodeResourceJID nodeId domainId resourceId
(Just node, domain, Nothing) ->
let nodeId = NodeID $ T.pack node
domainId = DomainID $ T.pack domain
in Just $ SomeJID $ NodeJID nodeId domainId
(Nothing, domain, Nothing) ->
Just $ SomeJID $ DomainJID $ DomainID $ T.pack domain
(Nothing, domain, Just resource) ->
let domainId = DomainID $ T.pack domain
resourceId = ResourceID $ T.pack resource
in Just $ SomeJID $ ResourceJID domainId resourceId
_ -> []
where
toMaybe "" = Nothing
toMaybe s = Just s
regex = mkRegex $ "((([^@])+)@)?" ++ "(([^/])+)" ++ "(/((.)+))?"
instance Show SomeJID where
show (SomeJID j) = show j
instance Show (JID a) where
show (NodeResourceJID (NodeID node) (DomainID domain) (ResourceID resource)) =
T.unpack $ node <> "@" <> domain <> "/" <> resource
show (ResourceJID (DomainID domain) (ResourceID resource)) =
T.unpack $ domain <> "/" <> resource
show (DomainJID (DomainID domain)) = T.unpack domain
show (NodeJID (NodeID node) (DomainID domain)) =
T.unpack $ node <> "@" <> domain
deriving instance Eq (JID a)
instance ToMarkup (JID a) where
toMarkup = toMarkup . show
--------------------------------------------------------------------------------
-- | XMPP Stream type, used in 'stream' pretty-printing combinator and the likes
data StreamType = Client -- ^ Client-to-server
| ComponentAccept -- ^ FIXME
| ComponentConnect -- ^ FIXME
instance Show StreamType where
show Client = "jabber:client"
show ComponentAccept = "jabber:component:accept"
show ComponentConnect = "jabber:component:connect"
-- | Roster item type (7.1)
data RosterItem = RosterItem { jid :: JID 'NodeResource
-- ^ Entry's JID
, subscribtion :: SubscribtionType
-- ^ Subscribtion type
, nickname :: Maybe String
-- ^ Entry's nickname
, groups :: [String]
-- ^ <group> elements
}
data SubscribtionType = None | To | From | Both deriving Eq
instance Show SubscribtionType where
show None = "none"
show To = "to"
show From = "from"
show Both = "both"
instance Read SubscribtionType where
readsPrec _ "none" = [(None, "")]
readsPrec _ "to" = [(To, "")]
readsPrec _ "from" = [(From, "")]
readsPrec _ "both" = [(Both, "")]
readsPrec _ "" = [(None, "")]
readsPrec _ _ = error "incorrect subscribtion type"
--------------------------------------------------------------------------------
data MessageType
= Chat
| GroupChat
| Headline
| Normal
| MessageError
deriving (Eq)
instance Show MessageType where
show Chat = "chat"
show GroupChat = "groupchat"
show Headline = "headline"
show Normal = "normal"
show MessageError = "error"
instance Read MessageType where
readsPrec _ "chat" = [(Chat, "")]
readsPrec _ "groupchat" = [(GroupChat, "")]
readsPrec _ "headline" = [(Headline, "")]
readsPrec _ "normal" = [(Normal, "")]
readsPrec _ "error" = [(MessageError, "")]
readsPrec _ "" = [(Chat, "")]
readsPrec _ _ = error "incorrect message type"
data PresenceType
= Default
| Unavailable
| Subscribe
| Subscribed
| Unsubscribe
| Unsubscribed
| Probe
| PresenceError
deriving (Eq)
instance Show PresenceType where
show Default = ""
show Unavailable = "unavailable"
show Subscribe = "subscribe"
show Subscribed = "subscribed"
show Unsubscribe = "unsubscribe"
show Unsubscribed = "unsubscribed"
show Probe = "probe"
show PresenceError = "error"
instance Read PresenceType where
readsPrec _ "" = [(Default, "")]
readsPrec _ "available" = [(Default, "")]
readsPrec _ "unavailable" = [(Unavailable, "")]
readsPrec _ "subscribe" = [(Subscribe, "")]
readsPrec _ "subscribed" = [(Subscribed, "")]
readsPrec _ "unsubscribe" = [(Unsubscribe, "")]
readsPrec _ "unsubscribed" = [(Unsubscribed, "")]
readsPrec _ "probe" = [(Probe, "")]
readsPrec _ "error" = [(PresenceError, "")]
readsPrec _ _ = error "incorrect presence type"
data IQType
= Get
| Result
| Set
| IQError
deriving (Eq)
instance Show IQType where
show Get = "get"
show Result = "result"
show Set = "set"
show IQError = "error"
instance Read IQType where
readsPrec _ "get" = [(Get, "")]
readsPrec _ "result" = [(Result, "")]
readsPrec _ "set" = [(Set, "")]
readsPrec _ "error" = [(IQError, "")]
readsPrec _ "" = [(Get, "")]
readsPrec _ _ = error "incorrect iq type"
data ShowType = Available
| Away
| FreeChat
| DND
| XAway
deriving (Eq)
instance Show ShowType where
show Available = ""
show Away = "away"
show FreeChat = "chat"
show DND = "dnd"
show XAway = "xa"
instance Read ShowType where
readsPrec _ "" = [(Available, "")]
readsPrec _ "available" = [(Available, "")]
readsPrec _ "away" = [(Away, "")]
readsPrec _ "chat" = [(FreeChat, "")]
readsPrec _ "dnd" = [(DND, "")]
readsPrec _ "xa" = [(XAway, "")]
readsPrec _ "invisible" = [(Available, "")]
readsPrec _ _ = error "incorrect <show> value"
--------------------------------------------------------------------------------
-- | Generic XMPP stream atom
data StanzaPurpose = Incoming | Outgoing
deriving (Eq, Show)
singlethongs ''StanzaPurpose
data SomeStanza e
= forall (a :: StanzaType) (p :: StanzaPurpose)
. SomeStanza (Stanza a p e)
instance Show e => Show (SomeStanza e) where
show (SomeStanza (s@MkMessage {mPurpose = SIncoming})) = "(SomeStanza $ " <> show s <> ")"
show (SomeStanza (s@MkMessage {mPurpose = SOutgoing})) = "(SomeStanza $ " <> show s <> ")"
show (SomeStanza (s@MkPresence {pPurpose = SIncoming})) = "(SomeStanza $ " <> show s <> ")"
show (SomeStanza (s@MkPresence {pPurpose = SOutgoing})) = "(SomeStanza $ " <> show s <> ")"
show (SomeStanza (s@MkIQ {iqPurpose = SIncoming})) = "(SomeStanza $ " <> show s <> ")"
show (SomeStanza (s@MkIQ {iqPurpose = SOutgoing})) = "(SomeStanza $ " <> show s <> ")"
data StanzaType
= Message
| Presence
| IQ
type family DataByPurpose (p :: StanzaPurpose) body where
DataByPurpose 'Incoming body = Either [Content Posn] body
DataByPurpose 'Outgoing body = [Node]
data Stanza :: StanzaType -> StanzaPurpose -> * -> * where
MkMessage ::
{ mFrom :: Maybe SomeJID
, mTo :: Maybe SomeJID
, mId :: T.Text -- ^ Message 'from', 'to', 'id' attributes
, mType :: MessageType -- ^ Message type (2.1.1)
, mSubject :: T.Text -- ^ Subject element (2.1.2.1)
, mBody :: T.Text -- ^ Body element (2.1.2.2)
, mThread :: T.Text -- ^ Thread element (2.1.2.3)
, mExt :: DataByPurpose p ext -- ^ Additional contents, used for extensions
, mPurpose :: Sing p
}
-> Stanza 'Message p ext
MkPresence ::
{ pFrom :: Maybe SomeJID
, pTo :: Maybe SomeJID
, pId :: T.Text -- ^ Presence 'from', 'to', 'id' attributes
, pType :: PresenceType -- ^ Presence type (2.2.1)
, pShowType :: ShowType -- ^ Show element (2.2.2.1)
, pStatus :: T.Text -- ^ Status element (2.2.2.2)
, pPriority :: Maybe Integer -- ^ Presence priority (2.2.2.3)
, pExt :: DataByPurpose p ext -- ^ Additional contents, used for extensions
, pPurpose :: Sing p
}
-> Stanza 'Presence p ext
MkIQ ::
{ iqFrom :: Maybe SomeJID
, iqTo :: Maybe SomeJID
, iqId :: T.Text -- ^ IQ id (Core-9.2.3)
, iqType :: IQType -- ^ IQ type (Core-9.2.3)
, iqBody :: DataByPurpose p ext -- ^ Child element (Core-9.2.3)
, iqPurpose :: Sing p
}
-> Stanza 'IQ p ext
instance Show (Sing 'Incoming) where
show _ = "incoming"
instance Show (Sing 'Outgoing) where
show _ = "outgoing"
deriving instance Show (Sing (dir :: StanzaPurpose)) => Show (DataByPurpose dir ext) => Show ext => Show (Stanza t dir ext)