path: root/dht/Presence/Stanza/Types.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StrictData        #-}
module Stanza.Types where

import Control.Concurrent.STM
import Data.Int
import Data.Text
import Data.XML.Types as XML

import Connection (PeerAddress(..))
import ConnectionKey (ClientAddress(..))
import LockedChan
import Nesting (Lang)

type Stanza = StanzaWrap (LockedChan XML.Event)

data StanzaWrap a = Stanza
    { stanzaType :: StanzaType
    , stanzaId :: Maybe Text
    , stanzaTo :: Maybe Text
    , stanzaFrom :: Maybe Text
    , stanzaChan :: a
    , stanzaClosers ::  TVar (Maybe [XML.Event])
    , stanzaInterrupt :: TMVar ()
    , stanzaOrigin :: StanzaOrigin
    }

data StanzaOrigin = LocalPeer
                  | PeerOrigin PeerAddress (TChan Stanza)
                  | ClientOrigin ClientAddress (TChan Stanza)

data StanzaType
    = Unrecognized
    | Ping
    | Pong
    | RequestResource (Maybe Text) (Maybe Text) -- ^ Client's name for this host followed by client's requested resource id.
    | SetResource
    | RequestItems (Maybe Text)
    | Items
    | RequestInfo (Maybe Text)
    | Info
    | SessionRequest
    | UnrecognizedQuery Name
    | RequestRoster
    | Roster
    | RosterEvent { rosterEventType :: RosterEventType
                  , rosterUser :: Text
                  , rosterContact :: Text }
    | Error StanzaError XML.Event
    | PresenceStatus { presenceShow :: JabberShow
                     , presencePriority :: Maybe Int8
                     , presenceStatus :: [(Lang,Text)]
                     , presenceWhiteList :: [Text]
                        -- ^ A custom extension extension we are using.  When a
                        -- peer answers a presence probe, it also communicates
                        -- to the remote peer which remote users it believes
                        -- are subscribed to that presence.
                        --
                        -- This is communicated via a space-delimited list in
                        -- the nonstandard "whitelist" attribute for a
                        -- <{jabber:server}presence> tag.
                        --
                        -- TODO: Use this to update the buddies file so that a
                        -- client is made aware when a subscription was
                        -- canceled.
                     }

    | PresenceInformError
    | PresenceInformSubscription Bool
    | PresenceRequestStatus
    | PresenceRequestSubscription Bool
    | Message { msgThread :: Maybe MessageThread
              , msgLangMap :: [(Lang,LangSpecificMessage)]
              , msgType :: MessageType
              }
    | NotifyClientVersion { versionName :: Text
                          , versionVersion :: Text }
    | InternalEnableHack ClientHack
    | InternalCacheId Text
 deriving (Show,Eq)

data MessageType
    = NormalMsg  -- ^ The message is a standalone message that is sent outside
                 -- the context of a one-to-one conversation or groupchat, and
                 -- to which it is expected that the recipient will reply.
                 -- Typically a receiving client will present a message of type
                 -- "normal" in an interface that enables the recipient to
                 -- reply, but without a conversation history. The default
                 -- value of the 'type' attribute is "normal".

    | ChatMsg -- ^ The message is sent in the context of a one-to-one chat
              -- session. Typically an interactive client will present a
              -- message of type "chat" in an interface that enables one-to-one
              -- chat between the two parties, including an appropriate
              -- conversation history. Detailed recommendations regarding
              -- one-to-one chat sessions are provided under Section 5.1.

    | GroupChatMsg -- ^ The message is sent in the context of a multi-user chat
                   -- environment (similar to that of [IRC]). Typically a
                   -- receiving client will present a message of type
                   -- "groupchat" in an interface that enables many-to-many
                   -- chat between the parties, including a roster of parties
                   -- in the chatroom and an appropriate conversation history.
                   -- For detailed information about XMPP-based groupchat,
                   -- refer to [XEP‑0045].

    | HeadlineMsg -- ^ The message provides an alert, a notification, or other
                  -- transient information to which no reply is expected (e.g.,
                  -- news headlines, sports updates, near-real-time market
                  -- data, or syndicated content). Because no reply to the
                  -- message is expected, typically a receiving client will
                  -- present a message of type "headline" in an interface that
                  -- appropriately differentiates the message from standalone
                  -- messages, chat messages, and groupchat messages (e.g., by
                  -- not providing the recipient with the ability to reply). If
                  -- the 'to' address is the bare JID, the receiving server
                  -- SHOULD deliver the message to all of the recipient's
                  -- available resources with non-negative presence priority
                  -- and MUST deliver the message to at least one of those
                  -- resources; if the 'to' address is a full JID and there is
                  -- a matching resource, the server MUST deliver the message
                  -- to that resource; otherwise the server MUST either
                  -- silently ignore the message or return an error (see
                  -- Section 8).
    --
    -- | ErrorMsg -- The message is generated by an entity that experiences an
    -- error when processing a message received from another entity (for
    -- details regarding stanza error syntax, refer to [XMPP‑CORE]). A client
    -- that receives a message of type "error" SHOULD present an appropriate
    -- interface informing the original sender regarding the nature of the
    -- error.
    --
 deriving (Show,Read,Ord,Eq,Enum)


data RosterEventType
    = RequestedSubscription
    | NewBuddy -- preceded by PresenceInformSubscription True
    | RemovedBuddy -- preceded by PresenceInformSubscription False
    | PendingSubscriber -- same as PresenceRequestSubscription
    | NewSubscriber
    | RejectSubscriber
 deriving (Show,Read,Ord,Eq,Enum)

data ClientHack = SimulatedChatErrors
 deriving (Show,Read,Ord,Eq,Enum)


data LangSpecificMessage =
    LangSpecificMessage { msgBody :: Maybe Text
                        , msgSubject :: Maybe Text
                        }
  deriving (Show,Eq)

data MessageThread = MessageThread {
        msgThreadParent  :: Maybe Text,
        msgThreadContent :: Text
    }
  deriving (Show,Eq)


data JabberShow = Offline
                | ExtendedAway
                | Away
                | DoNotDisturb
                | Available
                | Chatty
 deriving (Show,Enum,Ord,Eq,Read)

class StanzaFirstTag a where
    -- Peek at the stanza open tag.
    stanzaFirstTag :: StanzaWrap a -> IO XML.Event
instance StanzaFirstTag (TChan XML.Event) where
    stanzaFirstTag stanza = do
        e <-atomically $ peekTChan (stanzaChan stanza)
        return e
instance StanzaFirstTag (LockedChan XML.Event) where
    stanzaFirstTag stanza = do
        e <-atomically $ peekLChan (stanzaChan stanza)
        return e
instance StanzaFirstTag XML.Event where
    stanzaFirstTag stanza = return (stanzaChan stanza)

data StanzaError
    = BadRequest
    | Conflict
    | FeatureNotImplemented
    | Forbidden
    | Gone
    | InternalServerError
    | ItemNotFound
    | JidMalformed
    | NotAcceptable
    | NotAllowed
    | NotAuthorized
    | PaymentRequired
    | RecipientUnavailable
    | Redirect
    | RegistrationRequired
    | RemoteServerNotFound
    | RemoteServerTimeout
    | ResourceConstraint
    | ServiceUnavailable
    | SubscriptionRequired
    | UndefinedCondition
    | UnexpectedRequest
 deriving (Show,Enum,Ord,Eq)

xep0086 :: StanzaError -> (Text, Int)
xep0086 e = case e of
    BadRequest            -> ("modify", 400)
    Conflict              -> ("cancel", 409)
    FeatureNotImplemented -> ("cancel", 501)
    Forbidden             -> ("auth", 403)
    Gone                  -> ("modify", 302)
    InternalServerError   -> ("wait", 500)
    ItemNotFound          -> ("cancel", 404)
    JidMalformed          -> ("modify", 400)
    NotAcceptable         -> ("modify", 406)
    NotAllowed            -> ("cancel", 405)
    NotAuthorized         -> ("auth", 401)
    PaymentRequired       -> ("auth", 402)
    RecipientUnavailable  -> ("wait", 404)
    Redirect              -> ("modify", 302)
    RegistrationRequired  -> ("auth", 407)
    RemoteServerNotFound  -> ("cancel", 404)
    RemoteServerTimeout   -> ("wait", 504)
    ResourceConstraint    -> ("wait", 500)
    ServiceUnavailable    -> ("cancel", 503)
    SubscriptionRequired  -> ("auth", 407)
    UndefinedCondition    -> ("", 500)
    UnexpectedRequest     -> ("wait", 400)

errorText :: StanzaError -> Text
errorText e = case e of
    BadRequest            -> "Bad request"
    Conflict              -> "Conflict"
    FeatureNotImplemented -> "This feature is not implemented"
    Forbidden             -> "Forbidden"
    Gone                  -> "Recipient can no longer be contacted"
    InternalServerError   -> "Internal server error"
    ItemNotFound          -> "Item not found"
    JidMalformed          -> "JID Malformed"
    NotAcceptable         -> "Message was rejected"
    NotAllowed            -> "Not allowed"
    NotAuthorized         -> "Not authorized"
    PaymentRequired       -> "Payment is required"
    RecipientUnavailable  -> "Recipient is unavailable"
    Redirect              -> "Redirect"
    RegistrationRequired  -> "Registration required"
    RemoteServerNotFound  -> "Recipient's server not found"
    RemoteServerTimeout   -> "Remote server timeout"
    ResourceConstraint    -> "The server is low on resources"
    ServiceUnavailable    -> "The service is unavailable"
    SubscriptionRequired  -> "A subscription is required"
    UndefinedCondition    -> "Undefined condition"
    UnexpectedRequest     -> "Unexpected request"