{-# LANGUAGE CPP #-}

#if WITH_TEMPLATE_HASKELL
{-# LANGUAGE TemplateHaskell #-}
#endif

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK hide #-}

module Network.Xmpp.Types
    ( NonemptyText(..)
    , nonEmpty
    , text
    , IQError(..)
    , IQRequest(..)
    , IQRequestType(..)
    , IQResponse(..)
    , IQResult(..)
    , LangTag (..)
#if WITH_TEMPLATE_HASKELL
    , langTagQ
#endif
    , langTagFromText
    , langTagToText
    , parseLangTag
    , ExtendedAttribute
    , Message(..)
    , message
    , MessageError(..)
    , messageError
    , MessageType(..)
    , Presence(..)
    , presence
    , PresenceError(..)
    , PresenceType(..)
    , SaslError(..)
    , SaslFailure(..)
    , StreamFeatures(..)
    , Stanza(..)
    , XmppElement(..)
    , messageS
    , messageErrorS
    , presenceS
    , StanzaError(..)
    , StanzaErrorCondition(..)
    , StanzaErrorType(..)
    , XmppFailure(..)
    , XmppTlsError(..)
    , StreamErrorCondition(..)
    , Version(..)
    , versionFromText
    , StreamHandle(..)
    , Stream(..)
    , StreamState(..)
    , ConnectionState(..)
    , StreamErrorInfo(..)
    , ConnectionDetails(..)
    , StreamConfiguration(..)
    , xmppDefaultParams
    , xmppDefaultParamsStrong
    , Jid(..)
#if WITH_TEMPLATE_HASKELL
    , jidQ
    , jid
#endif
    , isBare
    , isFull
    , jidFromText
    , jidFromTexts
    , (<~)
    , nodeprepProfile
    , resourceprepProfile
    , jidToText
    , jidToTexts
    , toBare
    , localpart
    , domainpart
    , resourcepart
    , parseJid
    , TlsBehaviour(..)
    , AuthFailure(..)
    ) where

import           Control.Applicative ((<$>), (<|>), many)
import           Control.Concurrent.STM
import           Control.Exception
import           Control.Monad.Except
import qualified Data.Attoparsec.Text as AP
import qualified Data.ByteString as BS
import           Data.Char (isSpace)
import           Data.Conduit
import           Data.Default
import           Data.Semigroup as Sem
import qualified Data.Set as Set
import           Data.String (IsString, fromString)
import           Data.Text (Text)
import qualified Data.Text as Text
import           Data.Typeable(Typeable)
import           Data.XML.Types as XML
import qualified Data.Text.Encoding as Text
import           GHC.Generics
#if WITH_TEMPLATE_HASKELL
import           Language.Haskell.TH
import           Language.Haskell.TH.Quote
import qualified Language.Haskell.TH.Syntax as TH
#endif
import           Network.Socket
import           Network.DNS
import           Network.TLS hiding (Version, HostName)
import           Network.TLS.Extra
import qualified Text.StringPrep as SP
import qualified Text.StringPrep.Profiles as SP


-- $setup
-- :set -itests
-- >>> :add tests/Tests/Arbitrary.hs
-- >>> import Network.Xmpp.Types
-- >>> import Control.Applicative((<$>))

-- | Type of Texts that contain at least on non-space character
newtype NonemptyText = Nonempty {NonemptyText -> Text
fromNonempty :: Text}
                       deriving (Int -> NonemptyText -> ShowS
[NonemptyText] -> ShowS
NonemptyText -> String
(Int -> NonemptyText -> ShowS)
-> (NonemptyText -> String)
-> ([NonemptyText] -> ShowS)
-> Show NonemptyText
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NonemptyText] -> ShowS
$cshowList :: [NonemptyText] -> ShowS
show :: NonemptyText -> String
$cshow :: NonemptyText -> String
showsPrec :: Int -> NonemptyText -> ShowS
$cshowsPrec :: Int -> NonemptyText -> ShowS
Show, ReadPrec [NonemptyText]
ReadPrec NonemptyText
Int -> ReadS NonemptyText
ReadS [NonemptyText]
(Int -> ReadS NonemptyText)
-> ReadS [NonemptyText]
-> ReadPrec NonemptyText
-> ReadPrec [NonemptyText]
-> Read NonemptyText
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [NonemptyText]
$creadListPrec :: ReadPrec [NonemptyText]
readPrec :: ReadPrec NonemptyText
$creadPrec :: ReadPrec NonemptyText
readList :: ReadS [NonemptyText]
$creadList :: ReadS [NonemptyText]
readsPrec :: Int -> ReadS NonemptyText
$creadsPrec :: Int -> ReadS NonemptyText
Read, NonemptyText -> NonemptyText -> Bool
(NonemptyText -> NonemptyText -> Bool)
-> (NonemptyText -> NonemptyText -> Bool) -> Eq NonemptyText
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NonemptyText -> NonemptyText -> Bool
$c/= :: NonemptyText -> NonemptyText -> Bool
== :: NonemptyText -> NonemptyText -> Bool
$c== :: NonemptyText -> NonemptyText -> Bool
Eq, Eq NonemptyText
Eq NonemptyText
-> (NonemptyText -> NonemptyText -> Ordering)
-> (NonemptyText -> NonemptyText -> Bool)
-> (NonemptyText -> NonemptyText -> Bool)
-> (NonemptyText -> NonemptyText -> Bool)
-> (NonemptyText -> NonemptyText -> Bool)
-> (NonemptyText -> NonemptyText -> NonemptyText)
-> (NonemptyText -> NonemptyText -> NonemptyText)
-> Ord NonemptyText
NonemptyText -> NonemptyText -> Bool
NonemptyText -> NonemptyText -> Ordering
NonemptyText -> NonemptyText -> NonemptyText
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NonemptyText -> NonemptyText -> NonemptyText
$cmin :: NonemptyText -> NonemptyText -> NonemptyText
max :: NonemptyText -> NonemptyText -> NonemptyText
$cmax :: NonemptyText -> NonemptyText -> NonemptyText
>= :: NonemptyText -> NonemptyText -> Bool
$c>= :: NonemptyText -> NonemptyText -> Bool
> :: NonemptyText -> NonemptyText -> Bool
$c> :: NonemptyText -> NonemptyText -> Bool
<= :: NonemptyText -> NonemptyText -> Bool
$c<= :: NonemptyText -> NonemptyText -> Bool
< :: NonemptyText -> NonemptyText -> Bool
$c< :: NonemptyText -> NonemptyText -> Bool
compare :: NonemptyText -> NonemptyText -> Ordering
$ccompare :: NonemptyText -> NonemptyText -> Ordering
$cp1Ord :: Eq NonemptyText
Ord)

instance IsString NonemptyText where
    fromString :: String -> NonemptyText
fromString String
str = case Text -> Maybe NonemptyText
nonEmpty (String -> Text
Text.pack String
str) of
        Maybe NonemptyText
Nothing -> String -> NonemptyText
forall a. HasCallStack => String -> a
error (String -> NonemptyText) -> String -> NonemptyText
forall a b. (a -> b) -> a -> b
$ String
"NonemptyText fromString called on empty or " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                            String
"all-whitespace string"
        Just NonemptyText
r -> NonemptyText
r

-- | Check that Text contains at least one non-space character and wrap it
nonEmpty :: Text -> Maybe NonemptyText
nonEmpty :: Text -> Maybe NonemptyText
nonEmpty Text
txt = if (Char -> Bool) -> Text -> Bool
Text.all Char -> Bool
isSpace Text
txt then Maybe NonemptyText
forall a. Maybe a
Nothing else NonemptyText -> Maybe NonemptyText
forall a. a -> Maybe a
Just (Text -> NonemptyText
Nonempty Text
txt)

-- | Same as 'fromNonempty'
text :: NonemptyText -> Text
text :: NonemptyText -> Text
text (Nonempty Text
txt) = Text
txt

data XmppElement = XmppStanza !Stanza
                 | XmppNonza  !Element
                   deriving (XmppElement -> XmppElement -> Bool
(XmppElement -> XmppElement -> Bool)
-> (XmppElement -> XmppElement -> Bool) -> Eq XmppElement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: XmppElement -> XmppElement -> Bool
$c/= :: XmppElement -> XmppElement -> Bool
== :: XmppElement -> XmppElement -> Bool
$c== :: XmppElement -> XmppElement -> Bool
Eq, Int -> XmppElement -> ShowS
[XmppElement] -> ShowS
XmppElement -> String
(Int -> XmppElement -> ShowS)
-> (XmppElement -> String)
-> ([XmppElement] -> ShowS)
-> Show XmppElement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [XmppElement] -> ShowS
$cshowList :: [XmppElement] -> ShowS
show :: XmppElement -> String
$cshow :: XmppElement -> String
showsPrec :: Int -> XmppElement -> ShowS
$cshowsPrec :: Int -> XmppElement -> ShowS
Show)

-- | The Xmpp communication primitives (Message, Presence and Info/Query) are
-- called stanzas.
data Stanza = IQRequestS     !IQRequest
            | IQResultS      !IQResult
            | IQErrorS       !IQError
            | MessageS       !Message
            | MessageErrorS  !MessageError
            | PresenceS      !Presence
            | PresenceErrorS !PresenceError
              deriving (Stanza -> Stanza -> Bool
(Stanza -> Stanza -> Bool)
-> (Stanza -> Stanza -> Bool) -> Eq Stanza
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Stanza -> Stanza -> Bool
$c/= :: Stanza -> Stanza -> Bool
== :: Stanza -> Stanza -> Bool
$c== :: Stanza -> Stanza -> Bool
Eq, Int -> Stanza -> ShowS
[Stanza] -> ShowS
Stanza -> String
(Int -> Stanza -> ShowS)
-> (Stanza -> String) -> ([Stanza] -> ShowS) -> Show Stanza
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Stanza] -> ShowS
$cshowList :: [Stanza] -> ShowS
show :: Stanza -> String
$cshow :: Stanza -> String
showsPrec :: Int -> Stanza -> ShowS
$cshowsPrec :: Int -> Stanza -> ShowS
Show, (forall x. Stanza -> Rep Stanza x)
-> (forall x. Rep Stanza x -> Stanza) -> Generic Stanza
forall x. Rep Stanza x -> Stanza
forall x. Stanza -> Rep Stanza x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Stanza x -> Stanza
$cfrom :: forall x. Stanza -> Rep Stanza x
Generic)

type ExtendedAttribute = (XML.Name, Text)

-- | A "request" Info/Query (IQ) stanza is one with either "get" or "set" as
-- type. It always contains an xml payload.
data IQRequest = IQRequest { IQRequest -> Text
iqRequestID      :: !Text
                           , IQRequest -> Maybe Jid
iqRequestFrom    :: !(Maybe Jid)
                           , IQRequest -> Maybe Jid
iqRequestTo      :: !(Maybe Jid)
                           , IQRequest -> Maybe LangTag
iqRequestLangTag :: !(Maybe LangTag)
                           , IQRequest -> IQRequestType
iqRequestType    :: !IQRequestType
                           , IQRequest -> Element
iqRequestPayload :: !Element
                           , IQRequest -> [ExtendedAttribute]
iqRequestAttributes :: ![ExtendedAttribute]
                           } deriving (IQRequest -> IQRequest -> Bool
(IQRequest -> IQRequest -> Bool)
-> (IQRequest -> IQRequest -> Bool) -> Eq IQRequest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IQRequest -> IQRequest -> Bool
$c/= :: IQRequest -> IQRequest -> Bool
== :: IQRequest -> IQRequest -> Bool
$c== :: IQRequest -> IQRequest -> Bool
Eq, Int -> IQRequest -> ShowS
[IQRequest] -> ShowS
IQRequest -> String
(Int -> IQRequest -> ShowS)
-> (IQRequest -> String)
-> ([IQRequest] -> ShowS)
-> Show IQRequest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IQRequest] -> ShowS
$cshowList :: [IQRequest] -> ShowS
show :: IQRequest -> String
$cshow :: IQRequest -> String
showsPrec :: Int -> IQRequest -> ShowS
$cshowsPrec :: Int -> IQRequest -> ShowS
Show, (forall x. IQRequest -> Rep IQRequest x)
-> (forall x. Rep IQRequest x -> IQRequest) -> Generic IQRequest
forall x. Rep IQRequest x -> IQRequest
forall x. IQRequest -> Rep IQRequest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep IQRequest x -> IQRequest
$cfrom :: forall x. IQRequest -> Rep IQRequest x
Generic)

-- | The type of IQ request that is made.
data IQRequestType = Get | Set deriving (IQRequestType -> IQRequestType -> Bool
(IQRequestType -> IQRequestType -> Bool)
-> (IQRequestType -> IQRequestType -> Bool) -> Eq IQRequestType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IQRequestType -> IQRequestType -> Bool
$c/= :: IQRequestType -> IQRequestType -> Bool
== :: IQRequestType -> IQRequestType -> Bool
$c== :: IQRequestType -> IQRequestType -> Bool
Eq, Eq IQRequestType
Eq IQRequestType
-> (IQRequestType -> IQRequestType -> Ordering)
-> (IQRequestType -> IQRequestType -> Bool)
-> (IQRequestType -> IQRequestType -> Bool)
-> (IQRequestType -> IQRequestType -> Bool)
-> (IQRequestType -> IQRequestType -> Bool)
-> (IQRequestType -> IQRequestType -> IQRequestType)
-> (IQRequestType -> IQRequestType -> IQRequestType)
-> Ord IQRequestType
IQRequestType -> IQRequestType -> Bool
IQRequestType -> IQRequestType -> Ordering
IQRequestType -> IQRequestType -> IQRequestType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: IQRequestType -> IQRequestType -> IQRequestType
$cmin :: IQRequestType -> IQRequestType -> IQRequestType
max :: IQRequestType -> IQRequestType -> IQRequestType
$cmax :: IQRequestType -> IQRequestType -> IQRequestType
>= :: IQRequestType -> IQRequestType -> Bool
$c>= :: IQRequestType -> IQRequestType -> Bool
> :: IQRequestType -> IQRequestType -> Bool
$c> :: IQRequestType -> IQRequestType -> Bool
<= :: IQRequestType -> IQRequestType -> Bool
$c<= :: IQRequestType -> IQRequestType -> Bool
< :: IQRequestType -> IQRequestType -> Bool
$c< :: IQRequestType -> IQRequestType -> Bool
compare :: IQRequestType -> IQRequestType -> Ordering
$ccompare :: IQRequestType -> IQRequestType -> Ordering
$cp1Ord :: Eq IQRequestType
Ord, ReadPrec [IQRequestType]
ReadPrec IQRequestType
Int -> ReadS IQRequestType
ReadS [IQRequestType]
(Int -> ReadS IQRequestType)
-> ReadS [IQRequestType]
-> ReadPrec IQRequestType
-> ReadPrec [IQRequestType]
-> Read IQRequestType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [IQRequestType]
$creadListPrec :: ReadPrec [IQRequestType]
readPrec :: ReadPrec IQRequestType
$creadPrec :: ReadPrec IQRequestType
readList :: ReadS [IQRequestType]
$creadList :: ReadS [IQRequestType]
readsPrec :: Int -> ReadS IQRequestType
$creadsPrec :: Int -> ReadS IQRequestType
Read, Int -> IQRequestType -> ShowS
[IQRequestType] -> ShowS
IQRequestType -> String
(Int -> IQRequestType -> ShowS)
-> (IQRequestType -> String)
-> ([IQRequestType] -> ShowS)
-> Show IQRequestType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IQRequestType] -> ShowS
$cshowList :: [IQRequestType] -> ShowS
show :: IQRequestType -> String
$cshow :: IQRequestType -> String
showsPrec :: Int -> IQRequestType -> ShowS
$cshowsPrec :: Int -> IQRequestType -> ShowS
Show, (forall x. IQRequestType -> Rep IQRequestType x)
-> (forall x. Rep IQRequestType x -> IQRequestType)
-> Generic IQRequestType
forall x. Rep IQRequestType x -> IQRequestType
forall x. IQRequestType -> Rep IQRequestType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep IQRequestType x -> IQRequestType
$cfrom :: forall x. IQRequestType -> Rep IQRequestType x
Generic)

-- | A "response" Info/Query (IQ) stanza is either an 'IQError', an IQ stanza
-- of  type "result" ('IQResult')
data IQResponse = IQResponseError IQError
                | IQResponseResult IQResult
                deriving (IQResponse -> IQResponse -> Bool
(IQResponse -> IQResponse -> Bool)
-> (IQResponse -> IQResponse -> Bool) -> Eq IQResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IQResponse -> IQResponse -> Bool
$c/= :: IQResponse -> IQResponse -> Bool
== :: IQResponse -> IQResponse -> Bool
$c== :: IQResponse -> IQResponse -> Bool
Eq, Int -> IQResponse -> ShowS
[IQResponse] -> ShowS
IQResponse -> String
(Int -> IQResponse -> ShowS)
-> (IQResponse -> String)
-> ([IQResponse] -> ShowS)
-> Show IQResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IQResponse] -> ShowS
$cshowList :: [IQResponse] -> ShowS
show :: IQResponse -> String
$cshow :: IQResponse -> String
showsPrec :: Int -> IQResponse -> ShowS
$cshowsPrec :: Int -> IQResponse -> ShowS
Show)

-- | The (non-error) answer to an IQ request.
data IQResult = IQResult { IQResult -> Text
iqResultID      :: !Text
                         , IQResult -> Maybe Jid
iqResultFrom    :: !(Maybe Jid)
                         , IQResult -> Maybe Jid
iqResultTo      :: !(Maybe Jid)
                         , IQResult -> Maybe LangTag
iqResultLangTag :: !(Maybe LangTag)
                         , IQResult -> Maybe Element
iqResultPayload :: !(Maybe Element)
                         , IQResult -> [ExtendedAttribute]
iqResultAttributes :: ![ExtendedAttribute]
                         } deriving (IQResult -> IQResult -> Bool
(IQResult -> IQResult -> Bool)
-> (IQResult -> IQResult -> Bool) -> Eq IQResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IQResult -> IQResult -> Bool
$c/= :: IQResult -> IQResult -> Bool
== :: IQResult -> IQResult -> Bool
$c== :: IQResult -> IQResult -> Bool
Eq, Int -> IQResult -> ShowS
[IQResult] -> ShowS
IQResult -> String
(Int -> IQResult -> ShowS)
-> (IQResult -> String) -> ([IQResult] -> ShowS) -> Show IQResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IQResult] -> ShowS
$cshowList :: [IQResult] -> ShowS
show :: IQResult -> String
$cshow :: IQResult -> String
showsPrec :: Int -> IQResult -> ShowS
$cshowsPrec :: Int -> IQResult -> ShowS
Show, (forall x. IQResult -> Rep IQResult x)
-> (forall x. Rep IQResult x -> IQResult) -> Generic IQResult
forall x. Rep IQResult x -> IQResult
forall x. IQResult -> Rep IQResult x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep IQResult x -> IQResult
$cfrom :: forall x. IQResult -> Rep IQResult x
Generic)

-- | The answer to an IQ request that generated an error.
data IQError = IQError { IQError -> Text
iqErrorID          :: !Text
                       , IQError -> Maybe Jid
iqErrorFrom        :: !(Maybe Jid)
                       , IQError -> Maybe Jid
iqErrorTo          :: !(Maybe Jid)
                       , IQError -> Maybe LangTag
iqErrorLangTag     :: !(Maybe LangTag)
                       , IQError -> StanzaError
iqErrorStanzaError :: !StanzaError
                       , IQError -> Maybe Element
iqErrorPayload     :: !(Maybe Element) -- should this be []?
                       , IQError -> [ExtendedAttribute]
iqErrorAttributes  :: ![ExtendedAttribute]
                       } deriving (IQError -> IQError -> Bool
(IQError -> IQError -> Bool)
-> (IQError -> IQError -> Bool) -> Eq IQError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IQError -> IQError -> Bool
$c/= :: IQError -> IQError -> Bool
== :: IQError -> IQError -> Bool
$c== :: IQError -> IQError -> Bool
Eq, Int -> IQError -> ShowS
[IQError] -> ShowS
IQError -> String
(Int -> IQError -> ShowS)
-> (IQError -> String) -> ([IQError] -> ShowS) -> Show IQError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IQError] -> ShowS
$cshowList :: [IQError] -> ShowS
show :: IQError -> String
$cshow :: IQError -> String
showsPrec :: Int -> IQError -> ShowS
$cshowsPrec :: Int -> IQError -> ShowS
Show, (forall x. IQError -> Rep IQError x)
-> (forall x. Rep IQError x -> IQError) -> Generic IQError
forall x. Rep IQError x -> IQError
forall x. IQError -> Rep IQError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep IQError x -> IQError
$cfrom :: forall x. IQError -> Rep IQError x
Generic)

-- | The message stanza. Used for /push/ type communication.
data Message = Message { Message -> Maybe Text
messageID      :: !(Maybe Text)
                       , Message -> Maybe Jid
messageFrom    :: !(Maybe Jid)
                       , Message -> Maybe Jid
messageTo      :: !(Maybe Jid)
                       , Message -> Maybe LangTag
messageLangTag :: !(Maybe LangTag)
                       , Message -> MessageType
messageType    :: !MessageType
                       , Message -> [Element]
messagePayload :: ![Element]
                       , Message -> [ExtendedAttribute]
messageAttributes :: ![ExtendedAttribute]
                       } deriving (Message -> Message -> Bool
(Message -> Message -> Bool)
-> (Message -> Message -> Bool) -> Eq Message
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Message -> Message -> Bool
$c/= :: Message -> Message -> Bool
== :: Message -> Message -> Bool
$c== :: Message -> Message -> Bool
Eq, Int -> Message -> ShowS
[Message] -> ShowS
Message -> String
(Int -> Message -> ShowS)
-> (Message -> String) -> ([Message] -> ShowS) -> Show Message
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Message] -> ShowS
$cshowList :: [Message] -> ShowS
show :: Message -> String
$cshow :: Message -> String
showsPrec :: Int -> Message -> ShowS
$cshowsPrec :: Int -> Message -> ShowS
Show, (forall x. Message -> Rep Message x)
-> (forall x. Rep Message x -> Message) -> Generic Message
forall x. Rep Message x -> Message
forall x. Message -> Rep Message x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Message x -> Message
$cfrom :: forall x. Message -> Rep Message x
Generic)

-- | An empty message
--
-- @
-- message = Message { messageID      = Nothing
--                   , messageFrom    = Nothing
--                   , messageTo      = Nothing
--                   , messageLangTag = Nothing
--                   , messageType    = Normal
--                   , messagePayload = []
--                   }
-- @
message :: Message
message :: Message
message = Message :: Maybe Text
-> Maybe Jid
-> Maybe Jid
-> Maybe LangTag
-> MessageType
-> [Element]
-> [ExtendedAttribute]
-> Message
Message { messageID :: Maybe Text
messageID      = Maybe Text
forall a. Maybe a
Nothing
                  , messageFrom :: Maybe Jid
messageFrom    = Maybe Jid
forall a. Maybe a
Nothing
                  , messageTo :: Maybe Jid
messageTo      = Maybe Jid
forall a. Maybe a
Nothing
                  , messageLangTag :: Maybe LangTag
messageLangTag = Maybe LangTag
forall a. Maybe a
Nothing
                  , messageType :: MessageType
messageType    = MessageType
Normal
                  , messagePayload :: [Element]
messagePayload = []
                  , messageAttributes :: [ExtendedAttribute]
messageAttributes = []
                  }

-- | Empty message stanza
--
-- @messageS = 'MessageS' 'message'@
messageS :: Stanza
messageS :: Stanza
messageS = Message -> Stanza
MessageS Message
message

instance Default Message where
    def :: Message
def = Message
message

-- | An error stanza generated in response to a 'Message'.
data MessageError = MessageError { MessageError -> Maybe Text
messageErrorID          :: !(Maybe Text)
                                 , MessageError -> Maybe Jid
messageErrorFrom        :: !(Maybe Jid)
                                 , MessageError -> Maybe Jid
messageErrorTo          :: !(Maybe Jid)
                                 , MessageError -> Maybe LangTag
messageErrorLangTag     :: !(Maybe LangTag)
                                 , MessageError -> StanzaError
messageErrorStanzaError :: !StanzaError
                                 , MessageError -> [Element]
messageErrorPayload     :: ![Element]
                                 , MessageError -> [ExtendedAttribute]
messageErrorAttributes  :: ![ExtendedAttribute]
                                 } deriving (MessageError -> MessageError -> Bool
(MessageError -> MessageError -> Bool)
-> (MessageError -> MessageError -> Bool) -> Eq MessageError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MessageError -> MessageError -> Bool
$c/= :: MessageError -> MessageError -> Bool
== :: MessageError -> MessageError -> Bool
$c== :: MessageError -> MessageError -> Bool
Eq, Int -> MessageError -> ShowS
[MessageError] -> ShowS
MessageError -> String
(Int -> MessageError -> ShowS)
-> (MessageError -> String)
-> ([MessageError] -> ShowS)
-> Show MessageError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MessageError] -> ShowS
$cshowList :: [MessageError] -> ShowS
show :: MessageError -> String
$cshow :: MessageError -> String
showsPrec :: Int -> MessageError -> ShowS
$cshowsPrec :: Int -> MessageError -> ShowS
Show, (forall x. MessageError -> Rep MessageError x)
-> (forall x. Rep MessageError x -> MessageError)
-> Generic MessageError
forall x. Rep MessageError x -> MessageError
forall x. MessageError -> Rep MessageError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MessageError x -> MessageError
$cfrom :: forall x. MessageError -> Rep MessageError x
Generic)

messageError :: MessageError
messageError :: MessageError
messageError = MessageError :: Maybe Text
-> Maybe Jid
-> Maybe Jid
-> Maybe LangTag
-> StanzaError
-> [Element]
-> [ExtendedAttribute]
-> MessageError
MessageError { messageErrorID :: Maybe Text
messageErrorID          = Maybe Text
forall a. Maybe a
Nothing
                            , messageErrorFrom :: Maybe Jid
messageErrorFrom        = Maybe Jid
forall a. Maybe a
Nothing
                            , messageErrorTo :: Maybe Jid
messageErrorTo          = Maybe Jid
forall a. Maybe a
Nothing
                            , messageErrorLangTag :: Maybe LangTag
messageErrorLangTag     = Maybe LangTag
forall a. Maybe a
Nothing
                            , messageErrorStanzaError :: StanzaError
messageErrorStanzaError =
                                StanzaError :: StanzaErrorType
-> StanzaErrorCondition
-> Maybe (Maybe LangTag, NonemptyText)
-> Maybe Element
-> StanzaError
StanzaError { stanzaErrorType :: StanzaErrorType
stanzaErrorType = StanzaErrorType
Cancel
                                            , stanzaErrorCondition :: StanzaErrorCondition
stanzaErrorCondition =
                                                  StanzaErrorCondition
ServiceUnavailable
                                            , stanzaErrorText :: Maybe (Maybe LangTag, NonemptyText)
stanzaErrorText = Maybe (Maybe LangTag, NonemptyText)
forall a. Maybe a
Nothing
                                            , stanzaErrorApplicationSpecificCondition :: Maybe Element
stanzaErrorApplicationSpecificCondition = Maybe Element
forall a. Maybe a
Nothing
                                            }
                            , messageErrorPayload :: [Element]
messageErrorPayload     = []
                            , messageErrorAttributes :: [ExtendedAttribute]
messageErrorAttributes  = []
                            }

instance Default MessageError where
    def :: MessageError
def = MessageError
messageError

messageErrorS :: Stanza
messageErrorS :: Stanza
messageErrorS = MessageError -> Stanza
MessageErrorS MessageError
forall a. Default a => a
def

-- | The type of a Message being sent
-- (<http://xmpp.org/rfcs/rfc6121.html#message-syntax-type>)
data MessageType = -- | 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.
                   Chat
                   -- | 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.
                 | GroupChat
                   -- | 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).
                 | Headline
                   -- | 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.
                   --
                   -- This is the /default/ value.
                 | Normal
                 deriving (MessageType -> MessageType -> Bool
(MessageType -> MessageType -> Bool)
-> (MessageType -> MessageType -> Bool) -> Eq MessageType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MessageType -> MessageType -> Bool
$c/= :: MessageType -> MessageType -> Bool
== :: MessageType -> MessageType -> Bool
$c== :: MessageType -> MessageType -> Bool
Eq, ReadPrec [MessageType]
ReadPrec MessageType
Int -> ReadS MessageType
ReadS [MessageType]
(Int -> ReadS MessageType)
-> ReadS [MessageType]
-> ReadPrec MessageType
-> ReadPrec [MessageType]
-> Read MessageType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [MessageType]
$creadListPrec :: ReadPrec [MessageType]
readPrec :: ReadPrec MessageType
$creadPrec :: ReadPrec MessageType
readList :: ReadS [MessageType]
$creadList :: ReadS [MessageType]
readsPrec :: Int -> ReadS MessageType
$creadsPrec :: Int -> ReadS MessageType
Read, Int -> MessageType -> ShowS
[MessageType] -> ShowS
MessageType -> String
(Int -> MessageType -> ShowS)
-> (MessageType -> String)
-> ([MessageType] -> ShowS)
-> Show MessageType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MessageType] -> ShowS
$cshowList :: [MessageType] -> ShowS
show :: MessageType -> String
$cshow :: MessageType -> String
showsPrec :: Int -> MessageType -> ShowS
$cshowsPrec :: Int -> MessageType -> ShowS
Show, (forall x. MessageType -> Rep MessageType x)
-> (forall x. Rep MessageType x -> MessageType)
-> Generic MessageType
forall x. Rep MessageType x -> MessageType
forall x. MessageType -> Rep MessageType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MessageType x -> MessageType
$cfrom :: forall x. MessageType -> Rep MessageType x
Generic)

-- | The presence stanza. Used for communicating status updates.
data Presence = Presence { Presence -> Maybe Text
presenceID      :: !(Maybe Text)
                         , Presence -> Maybe Jid
presenceFrom    :: !(Maybe Jid)
                         , Presence -> Maybe Jid
presenceTo      :: !(Maybe Jid)
                         , Presence -> Maybe LangTag
presenceLangTag :: !(Maybe LangTag)
                         , Presence -> PresenceType
presenceType    :: !PresenceType
                         , Presence -> [Element]
presencePayload :: ![Element]
                         , Presence -> [ExtendedAttribute]
presenceAttributes :: ![ExtendedAttribute]
                         } deriving (Presence -> Presence -> Bool
(Presence -> Presence -> Bool)
-> (Presence -> Presence -> Bool) -> Eq Presence
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Presence -> Presence -> Bool
$c/= :: Presence -> Presence -> Bool
== :: Presence -> Presence -> Bool
$c== :: Presence -> Presence -> Bool
Eq, Int -> Presence -> ShowS
[Presence] -> ShowS
Presence -> String
(Int -> Presence -> ShowS)
-> (Presence -> String) -> ([Presence] -> ShowS) -> Show Presence
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Presence] -> ShowS
$cshowList :: [Presence] -> ShowS
show :: Presence -> String
$cshow :: Presence -> String
showsPrec :: Int -> Presence -> ShowS
$cshowsPrec :: Int -> Presence -> ShowS
Show, (forall x. Presence -> Rep Presence x)
-> (forall x. Rep Presence x -> Presence) -> Generic Presence
forall x. Rep Presence x -> Presence
forall x. Presence -> Rep Presence x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Presence x -> Presence
$cfrom :: forall x. Presence -> Rep Presence x
Generic)

-- | An empty presence.
presence :: Presence
presence :: Presence
presence = Presence :: Maybe Text
-> Maybe Jid
-> Maybe Jid
-> Maybe LangTag
-> PresenceType
-> [Element]
-> [ExtendedAttribute]
-> Presence
Presence { presenceID :: Maybe Text
presenceID       = Maybe Text
forall a. Maybe a
Nothing
                    , presenceFrom :: Maybe Jid
presenceFrom     = Maybe Jid
forall a. Maybe a
Nothing
                    , presenceTo :: Maybe Jid
presenceTo       = Maybe Jid
forall a. Maybe a
Nothing
                    , presenceLangTag :: Maybe LangTag
presenceLangTag  = Maybe LangTag
forall a. Maybe a
Nothing
                    , presenceType :: PresenceType
presenceType     = PresenceType
Available
                    , presencePayload :: [Element]
presencePayload  = []
                    , presenceAttributes :: [ExtendedAttribute]
presenceAttributes = []
                    }

-- | Empty presence stanza
presenceS :: Stanza
presenceS :: Stanza
presenceS = Presence -> Stanza
PresenceS Presence
presence

instance Default Presence where
    def :: Presence
def = Presence
presence

-- | An error stanza generated in response to a 'Presence'.
data PresenceError = PresenceError { PresenceError -> Maybe Text
presenceErrorID          :: !(Maybe Text)
                                   , PresenceError -> Maybe Jid
presenceErrorFrom        :: !(Maybe Jid)
                                   , PresenceError -> Maybe Jid
presenceErrorTo          :: !(Maybe Jid)
                                   , PresenceError -> Maybe LangTag
presenceErrorLangTag     :: !(Maybe LangTag)
                                   , PresenceError -> StanzaError
presenceErrorStanzaError :: !StanzaError
                                   , PresenceError -> [Element]
presenceErrorPayload     :: ![Element]
                                   , PresenceError -> [ExtendedAttribute]
presenceErrorAttributes  :: ![ExtendedAttribute]
                                   } deriving (PresenceError -> PresenceError -> Bool
(PresenceError -> PresenceError -> Bool)
-> (PresenceError -> PresenceError -> Bool) -> Eq PresenceError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PresenceError -> PresenceError -> Bool
$c/= :: PresenceError -> PresenceError -> Bool
== :: PresenceError -> PresenceError -> Bool
$c== :: PresenceError -> PresenceError -> Bool
Eq, Int -> PresenceError -> ShowS
[PresenceError] -> ShowS
PresenceError -> String
(Int -> PresenceError -> ShowS)
-> (PresenceError -> String)
-> ([PresenceError] -> ShowS)
-> Show PresenceError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PresenceError] -> ShowS
$cshowList :: [PresenceError] -> ShowS
show :: PresenceError -> String
$cshow :: PresenceError -> String
showsPrec :: Int -> PresenceError -> ShowS
$cshowsPrec :: Int -> PresenceError -> ShowS
Show, (forall x. PresenceError -> Rep PresenceError x)
-> (forall x. Rep PresenceError x -> PresenceError)
-> Generic PresenceError
forall x. Rep PresenceError x -> PresenceError
forall x. PresenceError -> Rep PresenceError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PresenceError x -> PresenceError
$cfrom :: forall x. PresenceError -> Rep PresenceError x
Generic)

-- | @PresenceType@ holds Xmpp presence types. The "error" message type is left
-- out as errors are using @PresenceError@.
data PresenceType = Subscribe    | -- ^ Sender wants to subscribe to presence
                    Subscribed   | -- ^ Sender has approved the subscription
                    Unsubscribe  | -- ^ Sender is unsubscribing from presence
                    Unsubscribed | -- ^ Sender has denied or cancelled a
                                   --   subscription
                    Probe        | -- ^ Sender requests current presence;
                                   --   should only be used by servers
                    Available    | -- ^ Sender wants to express availability
                                   --   (no type attribute is defined)
                    Unavailable deriving (PresenceType -> PresenceType -> Bool
(PresenceType -> PresenceType -> Bool)
-> (PresenceType -> PresenceType -> Bool) -> Eq PresenceType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PresenceType -> PresenceType -> Bool
$c/= :: PresenceType -> PresenceType -> Bool
== :: PresenceType -> PresenceType -> Bool
$c== :: PresenceType -> PresenceType -> Bool
Eq, ReadPrec [PresenceType]
ReadPrec PresenceType
Int -> ReadS PresenceType
ReadS [PresenceType]
(Int -> ReadS PresenceType)
-> ReadS [PresenceType]
-> ReadPrec PresenceType
-> ReadPrec [PresenceType]
-> Read PresenceType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PresenceType]
$creadListPrec :: ReadPrec [PresenceType]
readPrec :: ReadPrec PresenceType
$creadPrec :: ReadPrec PresenceType
readList :: ReadS [PresenceType]
$creadList :: ReadS [PresenceType]
readsPrec :: Int -> ReadS PresenceType
$creadsPrec :: Int -> ReadS PresenceType
Read, Int -> PresenceType -> ShowS
[PresenceType] -> ShowS
PresenceType -> String
(Int -> PresenceType -> ShowS)
-> (PresenceType -> String)
-> ([PresenceType] -> ShowS)
-> Show PresenceType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PresenceType] -> ShowS
$cshowList :: [PresenceType] -> ShowS
show :: PresenceType -> String
$cshow :: PresenceType -> String
showsPrec :: Int -> PresenceType -> ShowS
$cshowsPrec :: Int -> PresenceType -> ShowS
Show, (forall x. PresenceType -> Rep PresenceType x)
-> (forall x. Rep PresenceType x -> PresenceType)
-> Generic PresenceType
forall x. Rep PresenceType x -> PresenceType
forall x. PresenceType -> Rep PresenceType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PresenceType x -> PresenceType
$cfrom :: forall x. PresenceType -> Rep PresenceType x
Generic)

-- | All stanzas (IQ, message, presence) can cause errors, which in the Xmpp
-- stream looks like @\<stanza-kind to=\'sender\' type=\'error\'\>@ . These
-- errors are wrapped in the @StanzaError@ type.  TODO: Sender XML is (optional
-- and is) not yet included.
data StanzaError = StanzaError
    { StanzaError -> StanzaErrorType
stanzaErrorType                         :: StanzaErrorType
    , StanzaError -> StanzaErrorCondition
stanzaErrorCondition                    :: StanzaErrorCondition
    , StanzaError -> Maybe (Maybe LangTag, NonemptyText)
stanzaErrorText                         :: Maybe (Maybe LangTag, NonemptyText)
    , StanzaError -> Maybe Element
stanzaErrorApplicationSpecificCondition :: Maybe Element
    } deriving (StanzaError -> StanzaError -> Bool
(StanzaError -> StanzaError -> Bool)
-> (StanzaError -> StanzaError -> Bool) -> Eq StanzaError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StanzaError -> StanzaError -> Bool
$c/= :: StanzaError -> StanzaError -> Bool
== :: StanzaError -> StanzaError -> Bool
$c== :: StanzaError -> StanzaError -> Bool
Eq, Int -> StanzaError -> ShowS
[StanzaError] -> ShowS
StanzaError -> String
(Int -> StanzaError -> ShowS)
-> (StanzaError -> String)
-> ([StanzaError] -> ShowS)
-> Show StanzaError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StanzaError] -> ShowS
$cshowList :: [StanzaError] -> ShowS
show :: StanzaError -> String
$cshow :: StanzaError -> String
showsPrec :: Int -> StanzaError -> ShowS
$cshowsPrec :: Int -> StanzaError -> ShowS
Show, (forall x. StanzaError -> Rep StanzaError x)
-> (forall x. Rep StanzaError x -> StanzaError)
-> Generic StanzaError
forall x. Rep StanzaError x -> StanzaError
forall x. StanzaError -> Rep StanzaError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep StanzaError x -> StanzaError
$cfrom :: forall x. StanzaError -> Rep StanzaError x
Generic)

-- | @StanzaError@s always have one of these types.
data StanzaErrorType = Cancel   | -- ^ Error is unrecoverable - do not retry
                       Continue | -- ^ Conditition was a warning - proceed
                       Modify   | -- ^ Change the data and retry
                       Auth     | -- ^ Provide credentials and retry
                       Wait       -- ^ Error is temporary - wait and retry
                       deriving (StanzaErrorType -> StanzaErrorType -> Bool
(StanzaErrorType -> StanzaErrorType -> Bool)
-> (StanzaErrorType -> StanzaErrorType -> Bool)
-> Eq StanzaErrorType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StanzaErrorType -> StanzaErrorType -> Bool
$c/= :: StanzaErrorType -> StanzaErrorType -> Bool
== :: StanzaErrorType -> StanzaErrorType -> Bool
$c== :: StanzaErrorType -> StanzaErrorType -> Bool
Eq, ReadPrec [StanzaErrorType]
ReadPrec StanzaErrorType
Int -> ReadS StanzaErrorType
ReadS [StanzaErrorType]
(Int -> ReadS StanzaErrorType)
-> ReadS [StanzaErrorType]
-> ReadPrec StanzaErrorType
-> ReadPrec [StanzaErrorType]
-> Read StanzaErrorType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [StanzaErrorType]
$creadListPrec :: ReadPrec [StanzaErrorType]
readPrec :: ReadPrec StanzaErrorType
$creadPrec :: ReadPrec StanzaErrorType
readList :: ReadS [StanzaErrorType]
$creadList :: ReadS [StanzaErrorType]
readsPrec :: Int -> ReadS StanzaErrorType
$creadsPrec :: Int -> ReadS StanzaErrorType
Read, Int -> StanzaErrorType -> ShowS
[StanzaErrorType] -> ShowS
StanzaErrorType -> String
(Int -> StanzaErrorType -> ShowS)
-> (StanzaErrorType -> String)
-> ([StanzaErrorType] -> ShowS)
-> Show StanzaErrorType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StanzaErrorType] -> ShowS
$cshowList :: [StanzaErrorType] -> ShowS
show :: StanzaErrorType -> String
$cshow :: StanzaErrorType -> String
showsPrec :: Int -> StanzaErrorType -> ShowS
$cshowsPrec :: Int -> StanzaErrorType -> ShowS
Show, (forall x. StanzaErrorType -> Rep StanzaErrorType x)
-> (forall x. Rep StanzaErrorType x -> StanzaErrorType)
-> Generic StanzaErrorType
forall x. Rep StanzaErrorType x -> StanzaErrorType
forall x. StanzaErrorType -> Rep StanzaErrorType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep StanzaErrorType x -> StanzaErrorType
$cfrom :: forall x. StanzaErrorType -> Rep StanzaErrorType x
Generic)

-- | Stanza errors are accommodated with one of the error conditions listed
-- below.
data StanzaErrorCondition = BadRequest            -- ^ Malformed XML.
                          | Conflict              -- ^ Resource or session with
                                                  --   name already exists.
                          | FeatureNotImplemented
                          | Forbidden             -- ^ Insufficient permissions.
                          | Gone (Maybe NonemptyText) -- ^ Entity can no longer
                                                      -- be contacted at this
                                                      -- address.
                          | InternalServerError
                          | ItemNotFound
                          | JidMalformed
                          | NotAcceptable         -- ^ Does not meet policy
                                                  --   criteria.
                          | NotAllowed            -- ^ No entity may perform
                                                  --   this action.
                          | NotAuthorized         -- ^ Must provide proper
                                                  --   credentials.
                          | PolicyViolation       -- ^ The entity has violated
                                                  -- some local service policy
                                                  -- (e.g., a message contains
                                                  -- words that are prohibited
                                                  -- by the service)
                          | RecipientUnavailable  -- ^ Temporarily unavailable.
                          | Redirect (Maybe NonemptyText) -- ^ Redirecting to
                                                          -- other entity,
                                                          -- usually
                                                          -- temporarily.
                          | RegistrationRequired
                          | RemoteServerNotFound
                          | RemoteServerTimeout
                          | ResourceConstraint    -- ^ Entity lacks the
                                                  --   necessary system
                                                  --   resources.
                          | ServiceUnavailable
                          | SubscriptionRequired
                          | UndefinedCondition    -- ^ Application-specific
                                                  --   condition.
                          | UnexpectedRequest     -- ^ Badly timed request.
                            deriving (StanzaErrorCondition -> StanzaErrorCondition -> Bool
(StanzaErrorCondition -> StanzaErrorCondition -> Bool)
-> (StanzaErrorCondition -> StanzaErrorCondition -> Bool)
-> Eq StanzaErrorCondition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StanzaErrorCondition -> StanzaErrorCondition -> Bool
$c/= :: StanzaErrorCondition -> StanzaErrorCondition -> Bool
== :: StanzaErrorCondition -> StanzaErrorCondition -> Bool
$c== :: StanzaErrorCondition -> StanzaErrorCondition -> Bool
Eq, ReadPrec [StanzaErrorCondition]
ReadPrec StanzaErrorCondition
Int -> ReadS StanzaErrorCondition
ReadS [StanzaErrorCondition]
(Int -> ReadS StanzaErrorCondition)
-> ReadS [StanzaErrorCondition]
-> ReadPrec StanzaErrorCondition
-> ReadPrec [StanzaErrorCondition]
-> Read StanzaErrorCondition
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [StanzaErrorCondition]
$creadListPrec :: ReadPrec [StanzaErrorCondition]
readPrec :: ReadPrec StanzaErrorCondition
$creadPrec :: ReadPrec StanzaErrorCondition
readList :: ReadS [StanzaErrorCondition]
$creadList :: ReadS [StanzaErrorCondition]
readsPrec :: Int -> ReadS StanzaErrorCondition
$creadsPrec :: Int -> ReadS StanzaErrorCondition
Read, Int -> StanzaErrorCondition -> ShowS
[StanzaErrorCondition] -> ShowS
StanzaErrorCondition -> String
(Int -> StanzaErrorCondition -> ShowS)
-> (StanzaErrorCondition -> String)
-> ([StanzaErrorCondition] -> ShowS)
-> Show StanzaErrorCondition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StanzaErrorCondition] -> ShowS
$cshowList :: [StanzaErrorCondition] -> ShowS
show :: StanzaErrorCondition -> String
$cshow :: StanzaErrorCondition -> String
showsPrec :: Int -> StanzaErrorCondition -> ShowS
$cshowsPrec :: Int -> StanzaErrorCondition -> ShowS
Show, (forall x. StanzaErrorCondition -> Rep StanzaErrorCondition x)
-> (forall x. Rep StanzaErrorCondition x -> StanzaErrorCondition)
-> Generic StanzaErrorCondition
forall x. Rep StanzaErrorCondition x -> StanzaErrorCondition
forall x. StanzaErrorCondition -> Rep StanzaErrorCondition x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep StanzaErrorCondition x -> StanzaErrorCondition
$cfrom :: forall x. StanzaErrorCondition -> Rep StanzaErrorCondition x
Generic)

-- =============================================================================
--  OTHER STUFF
-- =============================================================================

data SaslFailure = SaslFailure { SaslFailure -> SaslError
saslFailureCondition :: SaslError
                               , SaslFailure -> Maybe (Maybe LangTag, Text)
saslFailureText :: Maybe ( Maybe LangTag
                                                          , Text
                                                          )
                               } deriving (SaslFailure -> SaslFailure -> Bool
(SaslFailure -> SaslFailure -> Bool)
-> (SaslFailure -> SaslFailure -> Bool) -> Eq SaslFailure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SaslFailure -> SaslFailure -> Bool
$c/= :: SaslFailure -> SaslFailure -> Bool
== :: SaslFailure -> SaslFailure -> Bool
$c== :: SaslFailure -> SaslFailure -> Bool
Eq, Int -> SaslFailure -> ShowS
[SaslFailure] -> ShowS
SaslFailure -> String
(Int -> SaslFailure -> ShowS)
-> (SaslFailure -> String)
-> ([SaslFailure] -> ShowS)
-> Show SaslFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SaslFailure] -> ShowS
$cshowList :: [SaslFailure] -> ShowS
show :: SaslFailure -> String
$cshow :: SaslFailure -> String
showsPrec :: Int -> SaslFailure -> ShowS
$cshowsPrec :: Int -> SaslFailure -> ShowS
Show, (forall x. SaslFailure -> Rep SaslFailure x)
-> (forall x. Rep SaslFailure x -> SaslFailure)
-> Generic SaslFailure
forall x. Rep SaslFailure x -> SaslFailure
forall x. SaslFailure -> Rep SaslFailure x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SaslFailure x -> SaslFailure
$cfrom :: forall x. SaslFailure -> Rep SaslFailure x
Generic)

data SaslError = SaslAborted              -- ^ Client aborted.
               | SaslAccountDisabled      -- ^ The account has been temporarily
                                          --   disabled.
               | SaslCredentialsExpired   -- ^ The authentication failed because
                                          --   the credentials have expired.
               | SaslEncryptionRequired   -- ^ The mechanism requested cannot be
                                          --   used the confidentiality and
                                          --   integrity of the underlying
                                          --   stream is protected (typically
                                          --   with TLS).
               | SaslIncorrectEncoding    -- ^ The base64 encoding is incorrect.
               | SaslInvalidAuthzid       -- ^ The authzid has an incorrect
                                          --   format or the initiating entity
                                          --   does not have the appropriate
                                          --   permissions to authorize that ID.
               | SaslInvalidMechanism     -- ^ The mechanism is not supported by
                                          --   the receiving entity.
               | SaslMalformedRequest     -- ^ Invalid syntax.
               | SaslMechanismTooWeak     -- ^ The receiving entity policy
                                          --   requires a stronger mechanism.
               | SaslNotAuthorized        -- ^ Invalid credentials provided, or
                                          --   some generic authentication
                                          --   failure has occurred.
               | SaslTemporaryAuthFailure -- ^ There receiving entity reported a
                                          --   temporary error condition; the
                                          --   initiating entity is recommended
                                          --   to try again later.
               deriving (SaslError -> SaslError -> Bool
(SaslError -> SaslError -> Bool)
-> (SaslError -> SaslError -> Bool) -> Eq SaslError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SaslError -> SaslError -> Bool
$c/= :: SaslError -> SaslError -> Bool
== :: SaslError -> SaslError -> Bool
$c== :: SaslError -> SaslError -> Bool
Eq, ReadPrec [SaslError]
ReadPrec SaslError
Int -> ReadS SaslError
ReadS [SaslError]
(Int -> ReadS SaslError)
-> ReadS [SaslError]
-> ReadPrec SaslError
-> ReadPrec [SaslError]
-> Read SaslError
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SaslError]
$creadListPrec :: ReadPrec [SaslError]
readPrec :: ReadPrec SaslError
$creadPrec :: ReadPrec SaslError
readList :: ReadS [SaslError]
$creadList :: ReadS [SaslError]
readsPrec :: Int -> ReadS SaslError
$creadsPrec :: Int -> ReadS SaslError
Read, Int -> SaslError -> ShowS
[SaslError] -> ShowS
SaslError -> String
(Int -> SaslError -> ShowS)
-> (SaslError -> String)
-> ([SaslError] -> ShowS)
-> Show SaslError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SaslError] -> ShowS
$cshowList :: [SaslError] -> ShowS
show :: SaslError -> String
$cshow :: SaslError -> String
showsPrec :: Int -> SaslError -> ShowS
$cshowsPrec :: Int -> SaslError -> ShowS
Show, (forall x. SaslError -> Rep SaslError x)
-> (forall x. Rep SaslError x -> SaslError) -> Generic SaslError
forall x. Rep SaslError x -> SaslError
forall x. SaslError -> Rep SaslError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SaslError x -> SaslError
$cfrom :: forall x. SaslError -> Rep SaslError x
Generic)

-- The documentation of StreamErrorConditions is copied from
-- http://xmpp.org/rfcs/rfc6120.html#streams-error-conditions
data StreamErrorCondition
    = StreamBadFormat -- ^ The entity has sent XML that cannot be processed.
    | StreamBadNamespacePrefix -- ^ The entity has sent a namespace prefix that
                               -- is unsupported, or has sent no namespace
                               -- prefix on an element that needs such a prefix
    | StreamConflict -- ^ The server either (1) is closing the existing stream
                     -- for this entity because a new stream has been initiated
                     -- that conflicts with the existing stream, or (2) is
                     -- refusing a new stream for this entity because allowing
                     -- the new stream would conflict with an existing stream
                     -- (e.g., because the server allows only a certain number
                     -- of connections from the same IP address or allows only
                     -- one server-to-server stream for a given domain pair as a
                     -- way of helping to ensure in-order processing
    | StreamConnectionTimeout -- ^ One party is closing the stream because it
                              -- has reason to believe that the other party has
                              -- permanently lost the ability to communicate
                              -- over the stream.
    | StreamHostGone -- ^ The value of the 'to' attribute provided in the
                     -- initial stream header corresponds to an FQDN that is no
                     -- longer serviced by the receiving entity
    | StreamHostUnknown -- ^ The value of the 'to' attribute provided in the
                        -- initial stream header does not correspond to an FQDN
                        -- that is serviced by the receiving entity.
    | StreamImproperAddressing -- ^ A stanza sent between two servers lacks a
                               -- 'to' or 'from' attribute, the 'from' or 'to'
                               -- attribute has no value, or the value violates
                               -- the rules for XMPP addresses
    | StreamInternalServerError -- ^ The server has experienced a
                                -- misconfiguration or other internal error that
                                -- prevents it from servicing the stream.
    | StreamInvalidFrom -- ^ The data provided in a 'from' attribute does not
                        -- match an authorized JID or validated domain as
                        -- negotiated (1) between two servers using SASL or
                        -- Server Dialback, or (2) between a client and a server
                        -- via SASL authentication and resource binding.
    | StreamInvalidNamespace -- ^ The stream namespace name is something other
                             -- than \"http://etherx.jabber.org/streams\" (see
                             -- Section 11.2) or the content namespace declared
                             -- as the default namespace is not supported (e.g.,
                             -- something other than \"jabber:client\" or
                             -- \"jabber:server\").
    | StreamInvalidXml -- ^ The entity has sent invalid XML over the stream to a
                       -- server that performs validation
    | StreamNotAuthorized -- ^ The entity has attempted to send XML stanzas or
                          -- other outbound data before the stream has been
                          -- authenticated, or otherwise is not authorized to
                          -- perform an action related to stream negotiation;
                          -- the receiving entity MUST NOT process the offending
                          -- data before sending the stream error.
    | StreamNotWellFormed -- ^ The initiating entity has sent XML that violates
                          -- the well-formedness rules of [XML] or [XML‑NAMES].
    | StreamPolicyViolation -- ^ The entity has violated some local service
                            -- policy (e.g., a stanza exceeds a configured size
                            -- limit); the server MAY choose to specify the
                            -- policy in the \<text/\> element or in an
                            -- application-specific condition element.
    | StreamRemoteConnectionFailed -- ^ The server is unable to properly connect
                                   -- to a remote entity that is needed for
                                   -- authentication or authorization (e.g., in
                                   -- certain scenarios related to Server
                                   -- Dialback [XEP‑0220]); this condition is
                                   -- not to be used when the cause of the error
                                   -- is within the administrative domain of the
                                   -- XMPP service provider, in which case the
                                   -- \<internal-server-error /\> condition is
                                   -- more appropriate.
    | StreamReset -- ^ The server is closing the stream because it has new
                  -- (typically security-critical) features to offer, because
                  -- the keys or certificates used to establish a secure context
                  -- for the stream have expired or have been revoked during the
                  -- life of the stream , because the TLS sequence number has
                  -- wrapped, etc. The reset applies to the stream and to any
                  -- security context established for that stream (e.g., via TLS
                  -- and SASL), which means that encryption and authentication
                  -- need to be negotiated again for the new stream (e.g., TLS
                  -- session resumption cannot be used)
    | StreamResourceConstraint -- ^ The server lacks the system resources
                               -- necessary to service the stream.
    | StreamRestrictedXml -- ^ he entity has attempted to send restricted XML
                          -- features such as a comment, processing instruction,
                          -- DTD subset, or XML entity reference
    | StreamSeeOtherHost -- ^ The server will not provide service to the
                         -- initiating entity but is redirecting traffic to
                         -- another host under the administrative control of the
                         -- same service provider.
    | StreamSystemShutdown -- ^ The server is being shut down and all active
                           -- streams are being closed.
    | StreamUndefinedCondition -- ^ The error condition is not one of those
                               -- defined by the other conditions in this list
    | StreamUnsupportedEncoding -- ^ The initiating entity has encoded the
                                -- stream in an encoding that is not supported
                                -- by the server or has otherwise improperly
                                -- encoded the stream (e.g., by violating the
                                -- rules of the [UTF‑8] encoding).
    | StreamUnsupportedFeature -- ^ The receiving entity has advertised a
                               -- mandatory-to-negotiate stream feature that the
                               -- initiating entity does not support, and has
                               -- offered no other mandatory-to-negotiate
                               -- feature alongside the unsupported feature.
    | StreamUnsupportedStanzaType -- ^ The initiating entity has sent a
                                  -- first-level child of the stream that is not
                                  -- supported by the server, either because the
                                  -- receiving entity does not understand the
                                  -- namespace or because the receiving entity
                                  -- does not understand the element name for
                                  -- the applicable namespace (which might be
                                  -- the content namespace declared as the
                                  -- default namespace)
    | StreamUnsupportedVersion -- ^ The 'version' attribute provided by the
                               -- initiating entity in the stream header
                               -- specifies a version of XMPP that is not
                               -- supported by the server.
      deriving (StreamErrorCondition -> StreamErrorCondition -> Bool
(StreamErrorCondition -> StreamErrorCondition -> Bool)
-> (StreamErrorCondition -> StreamErrorCondition -> Bool)
-> Eq StreamErrorCondition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StreamErrorCondition -> StreamErrorCondition -> Bool
$c/= :: StreamErrorCondition -> StreamErrorCondition -> Bool
== :: StreamErrorCondition -> StreamErrorCondition -> Bool
$c== :: StreamErrorCondition -> StreamErrorCondition -> Bool
Eq, ReadPrec [StreamErrorCondition]
ReadPrec StreamErrorCondition
Int -> ReadS StreamErrorCondition
ReadS [StreamErrorCondition]
(Int -> ReadS StreamErrorCondition)
-> ReadS [StreamErrorCondition]
-> ReadPrec StreamErrorCondition
-> ReadPrec [StreamErrorCondition]
-> Read StreamErrorCondition
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [StreamErrorCondition]
$creadListPrec :: ReadPrec [StreamErrorCondition]
readPrec :: ReadPrec StreamErrorCondition
$creadPrec :: ReadPrec StreamErrorCondition
readList :: ReadS [StreamErrorCondition]
$creadList :: ReadS [StreamErrorCondition]
readsPrec :: Int -> ReadS StreamErrorCondition
$creadsPrec :: Int -> ReadS StreamErrorCondition
Read, Int -> StreamErrorCondition -> ShowS
[StreamErrorCondition] -> ShowS
StreamErrorCondition -> String
(Int -> StreamErrorCondition -> ShowS)
-> (StreamErrorCondition -> String)
-> ([StreamErrorCondition] -> ShowS)
-> Show StreamErrorCondition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StreamErrorCondition] -> ShowS
$cshowList :: [StreamErrorCondition] -> ShowS
show :: StreamErrorCondition -> String
$cshow :: StreamErrorCondition -> String
showsPrec :: Int -> StreamErrorCondition -> ShowS
$cshowsPrec :: Int -> StreamErrorCondition -> ShowS
Show, (forall x. StreamErrorCondition -> Rep StreamErrorCondition x)
-> (forall x. Rep StreamErrorCondition x -> StreamErrorCondition)
-> Generic StreamErrorCondition
forall x. Rep StreamErrorCondition x -> StreamErrorCondition
forall x. StreamErrorCondition -> Rep StreamErrorCondition x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep StreamErrorCondition x -> StreamErrorCondition
$cfrom :: forall x. StreamErrorCondition -> Rep StreamErrorCondition x
Generic)

-- | Encapsulates information about an XMPP stream error.
data StreamErrorInfo = StreamErrorInfo
    { StreamErrorInfo -> StreamErrorCondition
errorCondition :: !StreamErrorCondition
    , StreamErrorInfo -> Maybe (Maybe LangTag, NonemptyText)
errorText      :: !(Maybe (Maybe LangTag, NonemptyText))
    , StreamErrorInfo -> Maybe Element
errorXml       :: !(Maybe Element)
    } deriving (Int -> StreamErrorInfo -> ShowS
[StreamErrorInfo] -> ShowS
StreamErrorInfo -> String
(Int -> StreamErrorInfo -> ShowS)
-> (StreamErrorInfo -> String)
-> ([StreamErrorInfo] -> ShowS)
-> Show StreamErrorInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StreamErrorInfo] -> ShowS
$cshowList :: [StreamErrorInfo] -> ShowS
show :: StreamErrorInfo -> String
$cshow :: StreamErrorInfo -> String
showsPrec :: Int -> StreamErrorInfo -> ShowS
$cshowsPrec :: Int -> StreamErrorInfo -> ShowS
Show, StreamErrorInfo -> StreamErrorInfo -> Bool
(StreamErrorInfo -> StreamErrorInfo -> Bool)
-> (StreamErrorInfo -> StreamErrorInfo -> Bool)
-> Eq StreamErrorInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StreamErrorInfo -> StreamErrorInfo -> Bool
$c/= :: StreamErrorInfo -> StreamErrorInfo -> Bool
== :: StreamErrorInfo -> StreamErrorInfo -> Bool
$c== :: StreamErrorInfo -> StreamErrorInfo -> Bool
Eq, (forall x. StreamErrorInfo -> Rep StreamErrorInfo x)
-> (forall x. Rep StreamErrorInfo x -> StreamErrorInfo)
-> Generic StreamErrorInfo
forall x. Rep StreamErrorInfo x -> StreamErrorInfo
forall x. StreamErrorInfo -> Rep StreamErrorInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep StreamErrorInfo x -> StreamErrorInfo
$cfrom :: forall x. StreamErrorInfo -> Rep StreamErrorInfo x
Generic)

data XmppTlsError = XmppTlsError TLSError
                  | XmppTlsException TLSException
                    deriving (Int -> XmppTlsError -> ShowS
[XmppTlsError] -> ShowS
XmppTlsError -> String
(Int -> XmppTlsError -> ShowS)
-> (XmppTlsError -> String)
-> ([XmppTlsError] -> ShowS)
-> Show XmppTlsError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [XmppTlsError] -> ShowS
$cshowList :: [XmppTlsError] -> ShowS
show :: XmppTlsError -> String
$cshow :: XmppTlsError -> String
showsPrec :: Int -> XmppTlsError -> ShowS
$cshowsPrec :: Int -> XmppTlsError -> ShowS
Show, XmppTlsError -> XmppTlsError -> Bool
(XmppTlsError -> XmppTlsError -> Bool)
-> (XmppTlsError -> XmppTlsError -> Bool) -> Eq XmppTlsError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: XmppTlsError -> XmppTlsError -> Bool
$c/= :: XmppTlsError -> XmppTlsError -> Bool
== :: XmppTlsError -> XmppTlsError -> Bool
$c== :: XmppTlsError -> XmppTlsError -> Bool
Eq, Typeable, (forall x. XmppTlsError -> Rep XmppTlsError x)
-> (forall x. Rep XmppTlsError x -> XmppTlsError)
-> Generic XmppTlsError
forall x. Rep XmppTlsError x -> XmppTlsError
forall x. XmppTlsError -> Rep XmppTlsError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep XmppTlsError x -> XmppTlsError
$cfrom :: forall x. XmppTlsError -> Rep XmppTlsError x
Generic)

-- | Signals an XMPP stream error or another unpredicted stream-related
-- situation. This error is fatal, and closes the XMPP stream.
data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream
                                                        -- element has been
                                                        -- encountered.
                 | StreamEndFailure -- ^ The stream has been closed.
                                    -- This exception is caught by the
                                    -- concurrent implementation, and
                                    -- will thus not be visible
                                    -- through use of 'Session'.
                 | StreamCloseError ([Element], XmppFailure) -- ^ When an XmppFailure
                                              -- is encountered in
                                              -- closeStreams, this
                                              -- constructor wraps the
                                              -- elements collected so
                                              -- far.
                 | TcpConnectionFailure -- ^ All attempts to TCP
                                        -- connect to the server
                                        -- failed.
                 | XmppIllegalTcpDetails -- ^ The TCP details provided did not
                                         -- validate.
                 | TlsError XmppTlsError -- ^ An error occurred in the
                                     -- TLS layer
                 | TlsNoServerSupport -- ^ The server does not support
                                      -- the use of TLS
                 | XmppNoStream -- ^ An action that required an active
                                -- stream were performed when the
                                -- 'StreamState' was 'Closed'
                 | XmppAuthFailure AuthFailure -- ^ Authentication with the
                                               -- server failed (unrecoverably)
                 | TlsStreamSecured -- ^ Connection already secured
                 | XmppOtherFailure -- ^ Undefined condition. More
                                    -- information should be available in
                                    -- the log.
                 | XmppIOException IOException -- ^ An 'IOException'
                                               -- occurred
                 | XmppInvalidXml String -- ^ Received data is not valid XML
                 deriving (Int -> XmppFailure -> ShowS
[XmppFailure] -> ShowS
XmppFailure -> String
(Int -> XmppFailure -> ShowS)
-> (XmppFailure -> String)
-> ([XmppFailure] -> ShowS)
-> Show XmppFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [XmppFailure] -> ShowS
$cshowList :: [XmppFailure] -> ShowS
show :: XmppFailure -> String
$cshow :: XmppFailure -> String
showsPrec :: Int -> XmppFailure -> ShowS
$cshowsPrec :: Int -> XmppFailure -> ShowS
Show, XmppFailure -> XmppFailure -> Bool
(XmppFailure -> XmppFailure -> Bool)
-> (XmppFailure -> XmppFailure -> Bool) -> Eq XmppFailure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: XmppFailure -> XmppFailure -> Bool
$c/= :: XmppFailure -> XmppFailure -> Bool
== :: XmppFailure -> XmppFailure -> Bool
$c== :: XmppFailure -> XmppFailure -> Bool
Eq, Typeable, (forall x. XmppFailure -> Rep XmppFailure x)
-> (forall x. Rep XmppFailure x -> XmppFailure)
-> Generic XmppFailure
forall x. Rep XmppFailure x -> XmppFailure
forall x. XmppFailure -> Rep XmppFailure x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep XmppFailure x -> XmppFailure
$cfrom :: forall x. XmppFailure -> Rep XmppFailure x
Generic)

instance Exception XmppFailure

-- | Signals a SASL authentication error condition.
data AuthFailure = -- | No mechanism offered by the server was matched
                   -- by the provided acceptable mechanisms; wraps the
                   -- mechanisms offered by the server
                   AuthNoAcceptableMechanism [Text.Text]
                 | AuthStreamFailure XmppFailure -- TODO: Remove
                   -- | A SASL failure element was encountered
                 | AuthSaslFailure SaslFailure
                   -- | The credentials provided did not conform to
                   -- the SASLprep Stringprep profile
                 | AuthIllegalCredentials
                   -- | Other failure; more information is available
                   -- in the log
                 | AuthOtherFailure
                 deriving (AuthFailure -> AuthFailure -> Bool
(AuthFailure -> AuthFailure -> Bool)
-> (AuthFailure -> AuthFailure -> Bool) -> Eq AuthFailure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuthFailure -> AuthFailure -> Bool
$c/= :: AuthFailure -> AuthFailure -> Bool
== :: AuthFailure -> AuthFailure -> Bool
$c== :: AuthFailure -> AuthFailure -> Bool
Eq, Int -> AuthFailure -> ShowS
[AuthFailure] -> ShowS
AuthFailure -> String
(Int -> AuthFailure -> ShowS)
-> (AuthFailure -> String)
-> ([AuthFailure] -> ShowS)
-> Show AuthFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuthFailure] -> ShowS
$cshowList :: [AuthFailure] -> ShowS
show :: AuthFailure -> String
$cshow :: AuthFailure -> String
showsPrec :: Int -> AuthFailure -> ShowS
$cshowsPrec :: Int -> AuthFailure -> ShowS
Show, (forall x. AuthFailure -> Rep AuthFailure x)
-> (forall x. Rep AuthFailure x -> AuthFailure)
-> Generic AuthFailure
forall x. Rep AuthFailure x -> AuthFailure
forall x. AuthFailure -> Rep AuthFailure x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AuthFailure x -> AuthFailure
$cfrom :: forall x. AuthFailure -> Rep AuthFailure x
Generic)

-- =============================================================================
--  XML TYPES
-- =============================================================================

-- | XMPP version number. Displayed as "\<major\>.\<minor\>". 2.4 is lesser than
-- 2.13, which in turn is lesser than 12.3.

data Version = Version { Version -> Integer
majorVersion :: !Integer
                       , Version -> Integer
minorVersion :: !Integer } deriving (Version -> Version -> Bool
(Version -> Version -> Bool)
-> (Version -> Version -> Bool) -> Eq Version
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Version -> Version -> Bool
$c/= :: Version -> Version -> Bool
== :: Version -> Version -> Bool
$c== :: Version -> Version -> Bool
Eq, ReadPrec [Version]
ReadPrec Version
Int -> ReadS Version
ReadS [Version]
(Int -> ReadS Version)
-> ReadS [Version]
-> ReadPrec Version
-> ReadPrec [Version]
-> Read Version
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Version]
$creadListPrec :: ReadPrec [Version]
readPrec :: ReadPrec Version
$creadPrec :: ReadPrec Version
readList :: ReadS [Version]
$creadList :: ReadS [Version]
readsPrec :: Int -> ReadS Version
$creadsPrec :: Int -> ReadS Version
Read, Int -> Version -> ShowS
[Version] -> ShowS
Version -> String
(Int -> Version -> ShowS)
-> (Version -> String) -> ([Version] -> ShowS) -> Show Version
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Version] -> ShowS
$cshowList :: [Version] -> ShowS
show :: Version -> String
$cshow :: Version -> String
showsPrec :: Int -> Version -> ShowS
$cshowsPrec :: Int -> Version -> ShowS
Show, (forall x. Version -> Rep Version x)
-> (forall x. Rep Version x -> Version) -> Generic Version
forall x. Rep Version x -> Version
forall x. Version -> Rep Version x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Version x -> Version
$cfrom :: forall x. Version -> Rep Version x
Generic)

-- If the major version numbers are not equal, compare them. Otherwise, compare
-- the minor version numbers.
instance Ord Version where
    compare :: Version -> Version -> Ordering
compare (Version Integer
amajor Integer
aminor) (Version Integer
bmajor Integer
bminor)
        | Integer
amajor Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
bmajor = Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Integer
amajor Integer
bmajor
        | Bool
otherwise = Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Integer
aminor Integer
bminor

-- instance Read Version where
--     readsPrec _ txt = (,"") <$> maybeToList (versionFromText $ Text.pack txt)

-- instance Show Version where
--     show (Version major minor) = (show major) ++ "." ++ (show minor)

-- Converts a "<major>.<minor>" numeric version number to a @Version@ object.
versionFromText :: Text.Text -> Maybe Version
versionFromText :: Text -> Maybe Version
versionFromText Text
s = case Parser Version -> Text -> Either String Version
forall a. Parser a -> Text -> Either String a
AP.parseOnly Parser Version
versionParser Text
s of
    Right Version
version -> Version -> Maybe Version
forall a. a -> Maybe a
Just Version
version
    Left String
_ -> Maybe Version
forall a. Maybe a
Nothing

-- Read numbers, a dot, more numbers, and end-of-file.
versionParser :: AP.Parser Version
versionParser :: Parser Version
versionParser = do
    String
major <- Parser Text Char -> Parser Text String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
AP.many1 Parser Text Char
AP.digit
    (Char -> Bool) -> Parser ()
AP.skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.')
    String
minor <- Parser Text Char -> Parser Text String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
AP.many1 Parser Text Char
AP.digit
    Parser ()
forall t. Chunk t => Parser t ()
AP.endOfInput
    Version -> Parser Version
forall (m :: * -> *) a. Monad m => a -> m a
return (Version -> Parser Version) -> Version -> Parser Version
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Version
Version (String -> Integer
forall a. Read a => String -> a
read String
major) (String -> Integer
forall a. Read a => String -> a
read String
minor)

-- | The language tag in accordance with RFC 5646 (in the form of "en-US"). It
-- has a primary tag and a number of subtags. Two language tags are considered
-- equal if and only if they contain the same tags (case-insensitive).
data LangTag = LangTag { LangTag -> Text
primaryTag :: !Text
                       , LangTag -> [Text]
subtags    :: ![Text] }

-- Equals for language tags is not case-sensitive.
instance Eq LangTag where
    LangTag Text
p [Text]
s == :: LangTag -> LangTag -> Bool
== LangTag Text
q [Text]
t = Text -> Text
Text.toLower Text
p Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Text
Text.toLower Text
q Bool -> Bool -> Bool
&&
        (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
Text.toLower [Text]
s [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
Text.toLower [Text]
t

-- | Parses, validates, and possibly constructs a "LangTag" object.
langTagFromText :: Text.Text -> Maybe LangTag
langTagFromText :: Text -> Maybe LangTag
langTagFromText Text
s = case Parser LangTag -> Text -> Either String LangTag
forall a. Parser a -> Text -> Either String a
AP.parseOnly Parser LangTag
langTagParser Text
s of
                        Right LangTag
tag -> LangTag -> Maybe LangTag
forall a. a -> Maybe a
Just LangTag
tag
                        Left String
_ -> Maybe LangTag
forall a. Maybe a
Nothing

langTagToText :: LangTag -> Text.Text
langTagToText :: LangTag -> Text
langTagToText (LangTag Text
p []) = Text
p
langTagToText (LangTag Text
p [Text]
s) = [Text] -> Text
Text.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text
p, Text
"-", Text -> [Text] -> Text
Text.intercalate Text
"-" [Text]
s]

-- Parses a language tag as defined by RFC 1766 and constructs a LangTag object.
langTagParser :: AP.Parser LangTag
langTagParser :: Parser LangTag
langTagParser = do
    -- Read until we reach a '-' character, or EOF. This is the `primary tag'.
    Text
primTag <- Parser Text
tag
    -- Read zero or more subtags.
    [Text]
subTags <- Parser Text -> Parser Text [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Text
subtag
    Parser ()
forall t. Chunk t => Parser t ()
AP.endOfInput
    LangTag -> Parser LangTag
forall (m :: * -> *) a. Monad m => a -> m a
return (LangTag -> Parser LangTag) -> LangTag -> Parser LangTag
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> LangTag
LangTag Text
primTag [Text]
subTags
  where
    tag :: AP.Parser Text.Text
    tag :: Parser Text
tag = do
        Text
t <- (Char -> Bool) -> Parser Text
AP.takeWhile1 ((Char -> Bool) -> Parser Text) -> (Char -> Bool) -> Parser Text
forall a b. (a -> b) -> a -> b
$ String -> Char -> Bool
AP.inClass String
tagChars
        Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
    subtag :: AP.Parser Text.Text
    subtag :: Parser Text
subtag = do
        (Char -> Bool) -> Parser ()
AP.skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-')
        Parser Text
tag
    tagChars :: [Char]
    tagChars :: String
tagChars = [Char
'a'..Char
'z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'A'..Char
'Z']

data StreamFeatures = StreamFeatures
    { StreamFeatures -> Maybe Bool
streamFeaturesTls         :: !(Maybe Bool)
    , StreamFeatures -> [Text]
streamFeaturesMechanisms  :: ![Text.Text]
    , StreamFeatures -> Maybe Bool
streamFeaturesRosterVer   :: !(Maybe Bool)
      -- ^ @Nothing@ for no roster versioning, @Just False@ for roster
      -- versioning and @Just True@ when the server sends the non-standard
      -- "optional" element (observed with prosody).
    , StreamFeatures -> Bool
streamFeaturesPreApproval :: !Bool -- ^ Does the server support pre-approval
    , StreamFeatures -> Maybe Bool
streamFeaturesSession     :: !(Maybe Bool)
       -- ^ Does this server allow the stream elelemt? (See
       -- https://tools.ietf.org/html/draft-cridland-xmpp-session-01)
    , StreamFeatures -> [Element]
streamFeaturesOther       :: ![Element]
      -- TODO: All feature elements instead?
    } deriving (StreamFeatures -> StreamFeatures -> Bool
(StreamFeatures -> StreamFeatures -> Bool)
-> (StreamFeatures -> StreamFeatures -> Bool) -> Eq StreamFeatures
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StreamFeatures -> StreamFeatures -> Bool
$c/= :: StreamFeatures -> StreamFeatures -> Bool
== :: StreamFeatures -> StreamFeatures -> Bool
$c== :: StreamFeatures -> StreamFeatures -> Bool
Eq, Int -> StreamFeatures -> ShowS
[StreamFeatures] -> ShowS
StreamFeatures -> String
(Int -> StreamFeatures -> ShowS)
-> (StreamFeatures -> String)
-> ([StreamFeatures] -> ShowS)
-> Show StreamFeatures
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StreamFeatures] -> ShowS
$cshowList :: [StreamFeatures] -> ShowS
show :: StreamFeatures -> String
$cshow :: StreamFeatures -> String
showsPrec :: Int -> StreamFeatures -> ShowS
$cshowsPrec :: Int -> StreamFeatures -> ShowS
Show)

instance Sem.Semigroup StreamFeatures where
    StreamFeatures
sf1 <> :: StreamFeatures -> StreamFeatures -> StreamFeatures
<> StreamFeatures
sf2 =
        StreamFeatures :: Maybe Bool
-> [Text]
-> Maybe Bool
-> Bool
-> Maybe Bool
-> [Element]
-> StreamFeatures
StreamFeatures
               { streamFeaturesTls :: Maybe Bool
streamFeaturesTls = (StreamFeatures -> Maybe Bool) -> Maybe Bool
forall (m :: * -> *) a.
MonadPlus m =>
(StreamFeatures -> m a) -> m a
mplusOn StreamFeatures -> Maybe Bool
streamFeaturesTls
               , streamFeaturesMechanisms :: [Text]
streamFeaturesMechanisms  = (StreamFeatures -> [Text]) -> [Text]
forall (m :: * -> *) a.
MonadPlus m =>
(StreamFeatures -> m a) -> m a
mplusOn StreamFeatures -> [Text]
streamFeaturesMechanisms
               , streamFeaturesRosterVer :: Maybe Bool
streamFeaturesRosterVer   = (StreamFeatures -> Maybe Bool) -> Maybe Bool
forall (m :: * -> *) a.
MonadPlus m =>
(StreamFeatures -> m a) -> m a
mplusOn StreamFeatures -> Maybe Bool
streamFeaturesRosterVer
               , streamFeaturesPreApproval :: Bool
streamFeaturesPreApproval =
                 StreamFeatures -> Bool
streamFeaturesPreApproval StreamFeatures
sf1
                 Bool -> Bool -> Bool
|| StreamFeatures -> Bool
streamFeaturesPreApproval StreamFeatures
sf2
               , streamFeaturesSession :: Maybe Bool
streamFeaturesSession   = (StreamFeatures -> Maybe Bool) -> Maybe Bool
forall (m :: * -> *) a.
MonadPlus m =>
(StreamFeatures -> m a) -> m a
mplusOn StreamFeatures -> Maybe Bool
streamFeaturesSession
               , streamFeaturesOther :: [Element]
streamFeaturesOther       = (StreamFeatures -> [Element]) -> [Element]
forall (m :: * -> *) a.
MonadPlus m =>
(StreamFeatures -> m a) -> m a
mplusOn StreamFeatures -> [Element]
streamFeaturesOther

               }
      where
        mplusOn :: (StreamFeatures -> m a) -> m a
mplusOn StreamFeatures -> m a
f = StreamFeatures -> m a
f StreamFeatures
sf1 m a -> m a -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` StreamFeatures -> m a
f StreamFeatures
sf2

instance Monoid StreamFeatures where
    mempty :: StreamFeatures
mempty = StreamFeatures :: Maybe Bool
-> [Text]
-> Maybe Bool
-> Bool
-> Maybe Bool
-> [Element]
-> StreamFeatures
StreamFeatures
               { streamFeaturesTls :: Maybe Bool
streamFeaturesTls         = Maybe Bool
forall a. Maybe a
Nothing
               , streamFeaturesMechanisms :: [Text]
streamFeaturesMechanisms  = []
               , streamFeaturesRosterVer :: Maybe Bool
streamFeaturesRosterVer   = Maybe Bool
forall a. Maybe a
Nothing
               , streamFeaturesPreApproval :: Bool
streamFeaturesPreApproval = Bool
False
               , streamFeaturesSession :: Maybe Bool
streamFeaturesSession     = Maybe Bool
forall a. Maybe a
Nothing
               , streamFeaturesOther :: [Element]
streamFeaturesOther       = []
               }
    mappend :: StreamFeatures -> StreamFeatures -> StreamFeatures
mappend = StreamFeatures -> StreamFeatures -> StreamFeatures
forall a. Semigroup a => a -> a -> a
(<>)

-- | Signals the state of the stream connection.
data ConnectionState
    = Closed  -- ^ Stream has not been established yet
    | Plain   -- ^ Stream established, but not secured via TLS
    | Secured -- ^ Stream established and secured via TLS
    | Finished -- ^ Stream was closed
      deriving (Int -> ConnectionState -> ShowS
[ConnectionState] -> ShowS
ConnectionState -> String
(Int -> ConnectionState -> ShowS)
-> (ConnectionState -> String)
-> ([ConnectionState] -> ShowS)
-> Show ConnectionState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConnectionState] -> ShowS
$cshowList :: [ConnectionState] -> ShowS
show :: ConnectionState -> String
$cshow :: ConnectionState -> String
showsPrec :: Int -> ConnectionState -> ShowS
$cshowsPrec :: Int -> ConnectionState -> ShowS
Show, ConnectionState -> ConnectionState -> Bool
(ConnectionState -> ConnectionState -> Bool)
-> (ConnectionState -> ConnectionState -> Bool)
-> Eq ConnectionState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConnectionState -> ConnectionState -> Bool
$c/= :: ConnectionState -> ConnectionState -> Bool
== :: ConnectionState -> ConnectionState -> Bool
$c== :: ConnectionState -> ConnectionState -> Bool
Eq, Typeable, (forall x. ConnectionState -> Rep ConnectionState x)
-> (forall x. Rep ConnectionState x -> ConnectionState)
-> Generic ConnectionState
forall x. Rep ConnectionState x -> ConnectionState
forall x. ConnectionState -> Rep ConnectionState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ConnectionState x -> ConnectionState
$cfrom :: forall x. ConnectionState -> Rep ConnectionState x
Generic)

-- | Defines operations for sending, receiving, flushing, and closing on a
-- stream.
data StreamHandle =
    StreamHandle { StreamHandle -> ByteString -> IO (Either XmppFailure ())
streamSend :: BS.ByteString
                                 -> IO (Either XmppFailure ()) -- ^ Sends may not
                                                          -- interleave
                 , StreamHandle -> Int -> IO (Either XmppFailure ByteString)
streamReceive :: Int -> IO (Either XmppFailure BS.ByteString)
                   -- This is to hold the state of the XML parser (otherwise we
                   -- will receive EventBeginDocument events and forget about
                   -- name prefixes). (TODO: Clarify)
                 , StreamHandle -> IO ()
streamFlush :: IO ()
                 , StreamHandle -> IO ()
streamClose :: IO ()
                 }

data StreamState = StreamState
    { -- | State of the stream - 'Closed', 'Plain', or 'Secured'
      StreamState -> ConnectionState
streamConnectionState :: !ConnectionState
      -- | Functions to send, receive, flush, and close the stream
    , StreamState -> StreamHandle
streamHandle :: StreamHandle
      -- | Event conduit source, and its associated finalizer
    , StreamState -> ConduitT () Event (ExceptT XmppFailure IO) ()
streamEventSource :: ConduitT () Event (ExceptT XmppFailure IO) ()
      -- | Stream features advertised by the server
    , StreamState -> StreamFeatures
streamFeatures :: !StreamFeatures -- TODO: Maybe?
      -- | The hostname or IP specified for the connection
    , StreamState -> Maybe Text
streamAddress :: !(Maybe Text)
      -- | The hostname specified in the server's stream element's
      -- `from' attribute
    , StreamState -> Maybe Jid
streamFrom :: !(Maybe Jid)
      -- | The identifier specified in the server's stream element's
      -- `id' attribute
    , StreamState -> Maybe Text
streamId :: !(Maybe Text)
      -- | The language tag value specified in the server's stream
      -- element's `langtag' attribute; will be a `Just' value once
      -- connected to the server
      -- TODO: Verify
    , StreamState -> Maybe LangTag
streamLang :: !(Maybe LangTag)
      -- | Our JID as assigned by the server
    , StreamState -> Maybe Jid
streamJid :: !(Maybe Jid)
      -- | Configuration settings for the stream
    , StreamState -> StreamConfiguration
streamConfiguration :: StreamConfiguration
    }

newtype Stream = Stream { Stream -> TMVar StreamState
unStream :: TMVar StreamState }

---------------
-- JID
---------------

-- | A JID is XMPP\'s native format for addressing entities in the network. It
-- is somewhat similar to an e-mail address but contains three parts instead of
-- two: localpart, domainpart, and resourcepart.
--
-- The @localpart@ of a JID is an optional identifier placed
-- before the domainpart and separated from the latter by a
-- \'\@\' character. Typically a localpart uniquely identifies
-- the entity requesting and using network access provided by a
-- server (i.e., a local account), although it can also
-- represent other kinds of entities (e.g., a chat room
-- associated with a multi-user chat service). The entity
-- represented by an XMPP localpart is addressed within the
-- context of a specific domain (i.e.,
-- @localpart\@domainpart@).
--
-- The domainpart typically identifies the /home/ server to
-- which clients connect for XML routing and data management
-- functionality. However, it is not necessary for an XMPP
-- domainpart to identify an entity that provides core XMPP
-- server functionality (e.g., a domainpart can identify an
-- entity such as a multi-user chat service, a
-- publish-subscribe service, or a user directory).
--
-- The resourcepart of a JID is an optional identifier placed
-- after the domainpart and separated from the latter by the
-- \'\/\' character. A resourcepart can modify either a
-- @localpart\@domainpart@ address or a mere @domainpart@
-- address. Typically a resourcepart uniquely identifies a
-- specific connection (e.g., a device or location) or object
-- (e.g., an occupant in a multi-user chat room) belonging to
-- the entity associated with an XMPP localpart at a domain
-- (i.e., @localpart\@domainpart/resourcepart@).
--
-- For more details see RFC 6122 <http://xmpp.org/rfcs/rfc6122.html>

data Jid = Jid { Jid -> Maybe NonemptyText
localpart_    :: !(Maybe NonemptyText)
               , Jid -> NonemptyText
domainpart_   :: !NonemptyText
               , Jid -> Maybe NonemptyText
resourcepart_ :: !(Maybe NonemptyText)
               } deriving (Jid -> Jid -> Bool
(Jid -> Jid -> Bool) -> (Jid -> Jid -> Bool) -> Eq Jid
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Jid -> Jid -> Bool
$c/= :: Jid -> Jid -> Bool
== :: Jid -> Jid -> Bool
$c== :: Jid -> Jid -> Bool
Eq, Eq Jid
Eq Jid
-> (Jid -> Jid -> Ordering)
-> (Jid -> Jid -> Bool)
-> (Jid -> Jid -> Bool)
-> (Jid -> Jid -> Bool)
-> (Jid -> Jid -> Bool)
-> (Jid -> Jid -> Jid)
-> (Jid -> Jid -> Jid)
-> Ord Jid
Jid -> Jid -> Bool
Jid -> Jid -> Ordering
Jid -> Jid -> Jid
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Jid -> Jid -> Jid
$cmin :: Jid -> Jid -> Jid
max :: Jid -> Jid -> Jid
$cmax :: Jid -> Jid -> Jid
>= :: Jid -> Jid -> Bool
$c>= :: Jid -> Jid -> Bool
> :: Jid -> Jid -> Bool
$c> :: Jid -> Jid -> Bool
<= :: Jid -> Jid -> Bool
$c<= :: Jid -> Jid -> Bool
< :: Jid -> Jid -> Bool
$c< :: Jid -> Jid -> Bool
compare :: Jid -> Jid -> Ordering
$ccompare :: Jid -> Jid -> Ordering
$cp1Ord :: Eq Jid
Ord)

-- | Converts a JID to a Text.
jidToText :: Jid -> Text
jidToText :: Jid -> Text
jidToText (Jid Maybe NonemptyText
nd NonemptyText
dmn Maybe NonemptyText
res) = [Text] -> Text
Text.concat ([Text] -> Text) -> ([[Text]] -> [Text]) -> [[Text]] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> Text) -> [[Text]] -> Text
forall a b. (a -> b) -> a -> b
$
                             [ [Text] -> (Text -> [Text]) -> Maybe Text -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text
"@"]) (NonemptyText -> Text
text (NonemptyText -> Text) -> Maybe NonemptyText -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe NonemptyText
nd)
                             , [NonemptyText -> Text
text NonemptyText
dmn]
                             , [Text] -> (Text -> [Text]) -> Maybe Text -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
r -> [Text
"/",Text
r]) (NonemptyText -> Text
text (NonemptyText -> Text) -> Maybe NonemptyText -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe NonemptyText
res)
                             ]

-- | Converts a JID to up to three Text values: (the optional) localpart, the
-- domainpart, and (the optional) resourcepart.
--
-- >>> jidToTexts [jid|foo@bar/quux|]
-- (Just "foo","bar",Just "quux")
--
-- >>> jidToTexts [jid|bar/quux|]
-- (Nothing,"bar",Just "quux")
--
-- >>> jidToTexts [jid|foo@bar|]
-- (Just "foo","bar",Nothing)
--
-- prop> jidToTexts j == (localpart j, domainpart j, resourcepart j)
jidToTexts :: Jid -> (Maybe Text, Text, Maybe Text)
jidToTexts :: Jid -> (Maybe Text, Text, Maybe Text)
jidToTexts (Jid Maybe NonemptyText
nd NonemptyText
dmn Maybe NonemptyText
res) = (NonemptyText -> Text
text (NonemptyText -> Text) -> Maybe NonemptyText -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe NonemptyText
nd, NonemptyText -> Text
text NonemptyText
dmn, NonemptyText -> Text
text (NonemptyText -> Text) -> Maybe NonemptyText -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe NonemptyText
res)

-- Produces a Jid value in the format "parseJid \"<jid>\"".
instance Show Jid where
  show :: Jid -> String
show Jid
j = String
"parseJid " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show (Jid -> Text
jidToText Jid
j)

-- The string must be in the format "parseJid \"<jid>\"".
-- TODO: This function should produce its error values in a uniform way.
-- TODO: Do we need to care about precedence here?
instance Read Jid where
    readsPrec :: Int -> ReadS Jid
readsPrec Int
_ String
s = do
        -- Verifies that the first word is "parseJid", parses the second word and
        -- the remainder, if any, and produces these two values or fails.
      case ReadS String
lex String
s of
        [(String
"parseJid", String
r')] ->
          case ReadS String
lex String
r' of
            [(String
s', String
r'')] ->
              case (ReadS String
forall a. Read a => ReadS a
reads String
s') of
                ((String
jidTxt,String
_):[(String, String)]
_) ->
                  case Text -> Maybe Jid
jidFromText (String -> Text
Text.pack String
jidTxt) of
                       Maybe Jid
Nothing -> []
                       Just Jid
jid' -> [(Jid
jid', String
r'')]
                [(String, String)]
_ -> []
            [(String, String)]
_ -> []
        [(String, String)]
_ -> []


#if WITH_TEMPLATE_HASKELL

instance TH.Lift Jid where
    lift :: Jid -> Q Exp
lift (Jid Maybe NonemptyText
lp NonemptyText
dp Maybe NonemptyText
rp) = [| Jid $(mbTextE $ text <$> lp)
                                 $(textE   $ text dp)
                                 $(mbTextE $ text <$> rp)
                           |]
     where
        textE :: Text -> Q Exp
textE Text
t = [| Nonempty $ Text.pack $(stringE $ Text.unpack t) |]
        mbTextE :: Maybe Text -> Q Exp
mbTextE Maybe Text
Nothing = [| Nothing |]
        mbTextE (Just Text
s) = [| Just $(textE s) |]

-- | Constructs and validates a @Jid@ at compile time.
--
-- Syntax:
-- @
--     [jid|localpart\@domainpart/resourcepart|]
-- @
--
-- >>> [jid|foo@bar/quux|]
-- parseJid "foo@bar/quux"
--
-- >>> Just [jid|foo@bar/quux|] == jidFromTexts (Just "foo") "bar" (Just "quux")
-- True
--
-- >>> Just [jid|foo@bar/quux|] == jidFromText "foo@bar/quux"
-- True
--
-- See also 'jidFromText'
jid :: QuasiQuoter
jid :: QuasiQuoter
jid = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter { quoteExp :: String -> Q Exp
quoteExp = \String
s -> do
                          Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Char
forall a. [a] -> a
head String
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') (Q () -> Q ()) -> (String -> Q ()) -> String -> Q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Leading whitespaces in JID" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
s
                          let t :: Text
t = String -> Text
Text.pack String
s
                          Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Char
Text.last Text
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') (Q () -> Q ()) -> (String -> Q ()) -> String -> Q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q ()
reportWarning (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Trailing whitespace in JID " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
s
                          case Text -> Maybe Jid
jidFromText Text
t of
                              Maybe Jid
Nothing -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Could not parse JID " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
                              Just Jid
j -> Jid -> Q Exp
forall t. Lift t => t -> Q Exp
TH.lift Jid
j
                  , quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"Jid patterns aren't implemented"
                  , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"jid QQ can't be used in type context"
                  , quoteDec :: String -> Q [Dec]
quoteDec  = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"jid QQ can't be used in declaration context"
                  }

-- | Synonym for 'jid'
jidQ :: QuasiQuoter
jidQ :: QuasiQuoter
jidQ = QuasiQuoter
jidQ
#endif

-- | The partial order of "definiteness". JID1 is less than or equal JID2 iff
-- the domain parts are equal and JID1's local part and resource part each are
-- either Nothing or equal to Jid2's
(<~) :: Jid -> Jid -> Bool
(Jid Maybe NonemptyText
lp1 NonemptyText
dp1 Maybe NonemptyText
rp1) <~ :: Jid -> Jid -> Bool
<~ (Jid Maybe NonemptyText
lp2 NonemptyText
dp2 Maybe NonemptyText
rp2) =
    NonemptyText
dp1 NonemptyText -> NonemptyText -> Bool
forall a. Eq a => a -> a -> Bool
==  NonemptyText
dp2 Bool -> Bool -> Bool
&&
    Maybe NonemptyText
lp1 Maybe NonemptyText -> Maybe NonemptyText -> Bool
forall a. Eq a => Maybe a -> Maybe a -> Bool
~<~ Maybe NonemptyText
lp2 Bool -> Bool -> Bool
&&
    Maybe NonemptyText
rp1 Maybe NonemptyText -> Maybe NonemptyText -> Bool
forall a. Eq a => Maybe a -> Maybe a -> Bool
~<~ Maybe NonemptyText
rp2
  where
   Maybe a
Nothing  ~<~ :: Maybe a -> Maybe a -> Bool
~<~ Maybe a
_ = Bool
True
   Just a
x  ~<~ Just a
y = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y
   Maybe a
_  ~<~ Maybe a
_ = Bool
False

-- Produces a LangTag value in the format "parseLangTag \"<jid>\"".
instance Show LangTag where
  show :: LangTag -> String
show LangTag
l = String
"parseLangTag " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show (LangTag -> Text
langTagToText LangTag
l)

-- The string must be in the format "parseLangTag \"<LangTag>\"". This is based
-- on parseJid, and suffers the same problems.
instance Read LangTag where
    readsPrec :: Int -> ReadS LangTag
readsPrec Int
_ String
s = do
        let (String
s', String
r) = case ReadS String
lex String
s of
                          [] -> String -> (String, String)
forall a. HasCallStack => String -> a
error String
"Expected `parseLangTag \"<LangTag>\"'"
                          [(String
"parseLangTag", String
r')] -> case ReadS String
lex String
r' of
                                              [] -> String -> (String, String)
forall a. HasCallStack => String -> a
error String
"Expected `parseLangTag \"<LangTag>\"'"
                                              [(String
s'', String
r'')] -> (String
s'', String
r'')
                                              [(String, String)]
_ -> String -> (String, String)
forall a. HasCallStack => String -> a
error String
"Expected `parseLangTag \"<LangTag>\"'"
                          [(String, String)]
_ -> String -> (String, String)
forall a. HasCallStack => String -> a
error String
"Expected `parseLangTag \"<LangTag>\"'"
        [(String -> LangTag
parseLangTag (ShowS
forall a. Read a => String -> a
read String
s' :: String), String
r)]

parseLangTag :: String -> LangTag
parseLangTag :: String -> LangTag
parseLangTag String
s = case Text -> Maybe LangTag
langTagFromText (Text -> Maybe LangTag) -> Text -> Maybe LangTag
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
s of
                     Just LangTag
l -> LangTag
l
                     Maybe LangTag
Nothing -> String -> LangTag
forall a. HasCallStack => String -> a
error (String -> LangTag) -> String -> LangTag
forall a b. (a -> b) -> a -> b
$ String
"Language tag value (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") did not validate"

#if WITH_TEMPLATE_HASKELL
langTagQ :: QuasiQuoter
langTagQ :: QuasiQuoter
langTagQ = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter {quoteExp :: String -> Q Exp
quoteExp = \String
s -> case Text -> Maybe LangTag
langTagFromText (Text -> Maybe LangTag) -> Text -> Maybe LangTag
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack  String
s of
                             Maybe LangTag
Nothing -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Not a valid language tag: "
                                               String -> ShowS
forall a. [a] -> [a] -> [a]
++  String
s
                             Just LangTag
lt -> [|LangTag $(textE $ primaryTag lt)
                                                  $(listE $
                                                      map textE (subtags lt))
                                        |]

                       , quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error (String -> String -> Q Pat) -> String -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ String
"LanguageTag patterns aren't"
                                         String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" implemented"
                       , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error (String -> String -> Q Type) -> String -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String
"LanguageTag QQ can't be used"
                                           String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in type context"
                       , quoteDec :: String -> Q [Dec]
quoteDec  = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error (String -> String -> Q [Dec]) -> String -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String
"LanguageTag QQ can't be used"
                                           String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in declaration context"

                       }
  where
    textE :: Text -> Q Exp
textE Text
t = [| Text.pack $(stringE $ Text.unpack t) |]
#endif
-- | Parses a JID string.
--
-- Note: This function is only meant to be used to reverse @Jid@ Show
-- operations; it will produce an 'undefined' value if the JID does not
-- validate; please refer to @jidFromText@ for a safe equivalent.
parseJid :: String -> Jid
parseJid :: String -> Jid
parseJid String
s = case Text -> Maybe Jid
jidFromText (Text -> Maybe Jid) -> Text -> Maybe Jid
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
s of
                 Just Jid
j -> Jid
j
                 Maybe Jid
Nothing -> String -> Jid
forall a. HasCallStack => String -> a
error (String -> Jid) -> String -> Jid
forall a b. (a -> b) -> a -> b
$ String
"Jid value (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") did not validate"

-- | Parse a JID
--
-- >>> localpart <$> jidFromText "foo@bar/quux"
-- Just (Just "foo")
--
-- >>> domainpart <$> jidFromText "foo@bar/quux"
-- Just "bar"
--
-- >>> resourcepart <$> jidFromText "foo@bar/quux"
-- Just (Just "quux")
--
-- @ and / can occur in the domain part
--
-- >>> jidFromText "foo/bar@quux/foo"
-- Just parseJid "foo/bar@quux/foo"
--
-- * Counterexamples
--
-- A JID must only have one \'\@\':
--
-- >>> jidFromText "foo@bar@quux"
-- Nothing
--
-- The domain part can\'t be empty:
--
-- >>> jidFromText "foo@/quux"
-- Nothing
--
-- Both the local part and the resource part can be omitted (but the
-- \'\@\' and \'\/\', must also be removed):
--
-- >>> jidToTexts <$> jidFromText "bar"
-- Just (Nothing,"bar",Nothing)
--
-- >>> jidToTexts <$> jidFromText "@bar"
-- Nothing
--
-- >>> jidToTexts <$> jidFromText "bar/"
-- Nothing
--
jidFromText :: Text -> Maybe Jid
jidFromText :: Text -> Maybe Jid
jidFromText Text
t = do
    (Maybe Text
l, Text
d, Maybe Text
r) <- Either String (Maybe Text, Text, Maybe Text)
-> Maybe (Maybe Text, Text, Maybe Text)
forall b a. Either b a -> Maybe a
eitherToMaybe (Either String (Maybe Text, Text, Maybe Text)
 -> Maybe (Maybe Text, Text, Maybe Text))
-> Either String (Maybe Text, Text, Maybe Text)
-> Maybe (Maybe Text, Text, Maybe Text)
forall a b. (a -> b) -> a -> b
$ Parser (Maybe Text, Text, Maybe Text)
-> Text -> Either String (Maybe Text, Text, Maybe Text)
forall a. Parser a -> Text -> Either String a
AP.parseOnly Parser (Maybe Text, Text, Maybe Text)
jidParts Text
t
    Maybe Text -> Text -> Maybe Text -> Maybe Jid
jidFromTexts Maybe Text
l Text
d Maybe Text
r
  where
    eitherToMaybe :: Either b a -> Maybe a
eitherToMaybe = (b -> Maybe a) -> (a -> Maybe a) -> Either b a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> b -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just

-- | Convert localpart, domainpart, and resourcepart to a JID. Runs the
-- appropriate stringprep profiles and validates the parts.
--
-- >>> jidFromTexts (Just "foo") "bar" (Just "baz") == jidFromText "foo@bar/baz"
-- True
--
-- prop> \j -> jidFromTexts (localpart j) (domainpart j) (resourcepart j) == Just j
jidFromTexts :: Maybe Text -> Text -> Maybe Text -> Maybe Jid
jidFromTexts :: Maybe Text -> Text -> Maybe Text -> Maybe Jid
jidFromTexts Maybe Text
l Text
d Maybe Text
r = do
    Maybe NonemptyText
localPart <- case Maybe Text
l of
        Maybe Text
Nothing -> Maybe NonemptyText -> Maybe (Maybe NonemptyText)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe NonemptyText
forall a. Maybe a
Nothing
        Just Text
l'-> do
            Text
l'' <- StringPrepProfile -> Text -> Maybe Text
SP.runStringPrep StringPrepProfile
nodeprepProfile Text
l'
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Text -> Bool
validPartLength Text
l''
            let prohibMap :: Set Char
prohibMap = String -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList String
nodeprepExtraProhibitedCharacters
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Bool
Text.all (Char -> Set Char -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Char
prohibMap) Text
l''
            NonemptyText
l''' <- Text -> Maybe NonemptyText
nonEmpty Text
l''
            Maybe NonemptyText -> Maybe (Maybe NonemptyText)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe NonemptyText -> Maybe (Maybe NonemptyText))
-> Maybe NonemptyText -> Maybe (Maybe NonemptyText)
forall a b. (a -> b) -> a -> b
$ NonemptyText -> Maybe NonemptyText
forall a. a -> Maybe a
Just NonemptyText
l'''
    -- strip dots again to handle stuff like "⒐" until we are rfc7622
    Text
domainPart' <- Text -> Maybe Text
forbidSeparators (Text -> Maybe Text) -> (Text -> Text) -> Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
stripSuffix (Text -> Maybe Text) -> Maybe Text -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StringPrepProfile -> Text -> Maybe Text
SP.runStringPrep (Bool -> StringPrepProfile
SP.namePrepProfile Bool
False) (Text -> Text
stripSuffix Text
d)
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Text -> Bool
validDomainPart Text
domainPart'
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Text -> Bool
validPartLength Text
domainPart'
    NonemptyText
domainPart <- Text -> Maybe NonemptyText
nonEmpty Text
domainPart'
    Maybe NonemptyText
resourcePart <- case Maybe Text
r of
        Maybe Text
Nothing -> Maybe NonemptyText -> Maybe (Maybe NonemptyText)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe NonemptyText
forall a. Maybe a
Nothing
        Just Text
r' -> do
            Text
r'' <- StringPrepProfile -> Text -> Maybe Text
SP.runStringPrep StringPrepProfile
resourceprepProfile Text
r'
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Text -> Bool
validPartLength Text
r''
            NonemptyText
r''' <- Text -> Maybe NonemptyText
nonEmpty Text
r''
            Maybe NonemptyText -> Maybe (Maybe NonemptyText)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe NonemptyText -> Maybe (Maybe NonemptyText))
-> Maybe NonemptyText -> Maybe (Maybe NonemptyText)
forall a b. (a -> b) -> a -> b
$ NonemptyText -> Maybe NonemptyText
forall a. a -> Maybe a
Just NonemptyText
r'''
    Jid -> Maybe Jid
forall (m :: * -> *) a. Monad m => a -> m a
return (Jid -> Maybe Jid) -> Jid -> Maybe Jid
forall a b. (a -> b) -> a -> b
$ Maybe NonemptyText -> NonemptyText -> Maybe NonemptyText -> Jid
Jid Maybe NonemptyText
localPart NonemptyText
domainPart Maybe NonemptyText
resourcePart
  where
    validDomainPart :: Text -> Bool
    validDomainPart :: Text -> Bool
validDomainPart Text
s = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
Text.null Text
s -- TODO: implement more stringent
                                          -- checks

    validPartLength :: Text -> Bool
    validPartLength :: Text -> Bool
validPartLength Text
p = Text -> Int
Text.length Text
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                        Bool -> Bool -> Bool
&& ByteString -> Int
BS.length (Text -> ByteString
Text.encodeUtf8 Text
p) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1024
    -- RFC6122 §2.2; we strip ALL the dots to avoid looking for a fixed point and bailing out early
    stripSuffix :: Text -> Text
stripSuffix = (Char -> Bool) -> Text -> Text
Text.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.')
    -- "／" might be a valid JID, but stringprep messes it up, so we use
    forbidSeparators :: Text -> Maybe Text
forbidSeparators Text
t = if Maybe Char
forall a. Maybe a
Nothing Maybe Char -> Maybe Char -> Bool
forall a. Eq a => a -> a -> Bool
== (Char -> Bool) -> Text -> Maybe Char
Text.find ((Char -> String -> Bool) -> String -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char
'/', Char
'@']) Text
t then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t else Maybe Text
forall a. Maybe a
Nothing

-- | Returns 'True' if the JID is /bare/, that is, it doesn't have a resource
-- part, and 'False' otherwise.
--
-- >>> isBare [jid|foo@bar|]
-- True
--
-- >>> isBare [jid|foo@bar/quux|]
-- False
isBare :: Jid -> Bool
isBare :: Jid -> Bool
isBare Jid
j | Jid -> Maybe Text
resourcepart Jid
j Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
forall a. Maybe a
Nothing = Bool
True
         | Bool
otherwise                 = Bool
False

-- | Returns 'True' if the JID is /full/, and 'False' otherwise.
--
-- @isFull = not . isBare@
--
-- >>> isBare [jid|foo@bar|]
-- True
--
-- >>> isBare [jid|foo@bar/quux|]
-- False
isFull :: Jid -> Bool
isFull :: Jid -> Bool
isFull = Bool -> Bool
not (Bool -> Bool) -> (Jid -> Bool) -> Jid -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Jid -> Bool
isBare

-- | Returns the @Jid@ without the resourcepart (if any).
--
-- >>> toBare [jid|foo@bar/quux|] == [jid|foo@bar|]
-- True
toBare :: Jid -> Jid
toBare :: Jid -> Jid
toBare Jid
j  = Jid
j{resourcepart_ :: Maybe NonemptyText
resourcepart_ = Maybe NonemptyText
forall a. Maybe a
Nothing}

-- | Returns the localpart of the @Jid@ (if any).
--
-- >>> localpart [jid|foo@bar/quux|]
-- Just "foo"
localpart :: Jid -> Maybe Text
localpart :: Jid -> Maybe Text
localpart = (NonemptyText -> Text) -> Maybe NonemptyText -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonemptyText -> Text
text (Maybe NonemptyText -> Maybe Text)
-> (Jid -> Maybe NonemptyText) -> Jid -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Jid -> Maybe NonemptyText
localpart_

-- | Returns the domainpart of the @Jid@.
--
-- >>> domainpart [jid|foo@bar/quux|]
-- "bar"
domainpart :: Jid -> Text
domainpart :: Jid -> Text
domainpart = NonemptyText -> Text
text (NonemptyText -> Text) -> (Jid -> NonemptyText) -> Jid -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Jid -> NonemptyText
domainpart_

-- | Returns the resourcepart of the @Jid@ (if any).
--
-- >>> resourcepart [jid|foo@bar/quux|]
-- Just "quux"
resourcepart :: Jid -> Maybe Text
resourcepart :: Jid -> Maybe Text
resourcepart = (NonemptyText -> Text) -> Maybe NonemptyText -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonemptyText -> Text
text (Maybe NonemptyText -> Maybe Text)
-> (Jid -> Maybe NonemptyText) -> Jid -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Jid -> Maybe NonemptyText
resourcepart_

-- | Parse the parts of a JID. The parts need to be validated with stringprep
-- before the JID can be constructed
jidParts :: AP.Parser (Maybe Text, Text, Maybe Text)
jidParts :: Parser (Maybe Text, Text, Maybe Text)
jidParts = do
    Maybe Text
maybeLocalPart <- Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Parser Text -> Parser Text (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
localPart Parser Text (Maybe Text)
-> Parser Text (Maybe Text) -> Parser Text (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Text -> Parser Text (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
    Text
domainPart <- (Char -> Bool) -> Parser Text
AP.takeWhile1 (String -> Char -> Bool
AP.notInClass [Char
'@', Char
'/'])
    Maybe Text
maybeResourcePart <- Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Parser Text -> Parser Text (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
resourcePart Parser Text (Maybe Text)
-> Parser Text (Maybe Text) -> Parser Text (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Text -> Parser Text (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
    Parser ()
forall t. Chunk t => Parser t ()
AP.endOfInput
    (Maybe Text, Text, Maybe Text)
-> Parser (Maybe Text, Text, Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
maybeLocalPart, Text
domainPart, Maybe Text
maybeResourcePart)
  where
    localPart :: Parser Text
localPart = do
        Text
bytes <- (Char -> Bool) -> Parser Text
AP.takeWhile1 (String -> Char -> Bool
AP.notInClass [Char
'@', Char
'/'])
        Char
_ <- Char -> Parser Text Char
AP.char Char
'@'
        Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
bytes
    resourcePart :: Parser Text
resourcePart = do
        Char
_ <- Char -> Parser Text Char
AP.char Char
'/'
        Parser Text
AP.takeText



-- | The `nodeprep' StringPrep profile.
nodeprepProfile :: SP.StringPrepProfile
nodeprepProfile :: StringPrepProfile
nodeprepProfile = Profile :: [Map] -> Bool -> [Prohibited] -> Bool -> StringPrepProfile
SP.Profile { maps :: [Map]
SP.maps = [Map
SP.b1, Map
SP.b2]
                             , shouldNormalize :: Bool
SP.shouldNormalize = Bool
True
                             , prohibited :: [Prohibited]
SP.prohibited = [ Prohibited
SP.a1
                                               , Prohibited
SP.c11
                                               , Prohibited
SP.c12
                                               , Prohibited
SP.c21
                                               , Prohibited
SP.c22
                                               , Prohibited
SP.c3
                                               , Prohibited
SP.c4
                                               , Prohibited
SP.c5
                                               , Prohibited
SP.c6
                                               , Prohibited
SP.c7
                                               , Prohibited
SP.c8
                                               , Prohibited
SP.c9
                                               ]
                             , shouldCheckBidi :: Bool
SP.shouldCheckBidi = Bool
True
                             }

-- | These characters needs to be checked for after normalization.
nodeprepExtraProhibitedCharacters :: [Char]
nodeprepExtraProhibitedCharacters :: String
nodeprepExtraProhibitedCharacters = [Char
'\x22', Char
'\x26', Char
'\x27', Char
'\x2F', Char
'\x3A',
                                     Char
'\x3C', Char
'\x3E', Char
'\x40']

-- | The `resourceprep' StringPrep profile.
resourceprepProfile :: SP.StringPrepProfile
resourceprepProfile :: StringPrepProfile
resourceprepProfile = Profile :: [Map] -> Bool -> [Prohibited] -> Bool -> StringPrepProfile
SP.Profile { maps :: [Map]
SP.maps = [Map
SP.b1]
                                 , shouldNormalize :: Bool
SP.shouldNormalize = Bool
True
                                 , prohibited :: [Prohibited]
SP.prohibited = [ Prohibited
SP.a1
                                                   , Prohibited
SP.c12
                                                   , Prohibited
SP.c21
                                                   , Prohibited
SP.c22
                                                   , Prohibited
SP.c3
                                                   , Prohibited
SP.c4
                                                   , Prohibited
SP.c5
                                                   , Prohibited
SP.c6
                                                   , Prohibited
SP.c7
                                                   , Prohibited
SP.c8
                                                   , Prohibited
SP.c9
                                                   ]
                                 , shouldCheckBidi :: Bool
SP.shouldCheckBidi = Bool
True
                                 }
-- | Specify the method with which the connection is (re-)established
data ConnectionDetails = UseRealm -- ^ Use realm to resolv host. This is the
                                  -- default.
                       | UseSrv HostName -- ^ Use this hostname for a SRV lookup
                       | UseHost HostName PortNumber -- ^ Use specified host
                       | UseConnection (ExceptT XmppFailure IO StreamHandle)
                         -- ^ Use a custom method to create a StreamHandle. This
                         -- will also be used by reconnect. For example, to
                         -- establish TLS before starting the stream as done by
                         -- GCM, see 'connectTls'. You can also return an
                         -- already established connection. This method should
                         -- also return a hostname that is used for TLS
                         -- signature verification. If startTLS is not used it
                         -- can be left empty

-- | Configuration settings related to the stream.
data StreamConfiguration =
    StreamConfiguration { -- | Default language when no language tag is set
                          StreamConfiguration -> Maybe LangTag
preferredLang :: !(Maybe LangTag)
                          -- | JID to include in the stream element's `to'
                          -- attribute when the connection is secured; if the
                          -- boolean is set to 'True', then the JID is also
                          -- included when the 'ConnectionState' is 'Plain'
                        , StreamConfiguration -> Maybe (Jid, Bool)
toJid :: !(Maybe (Jid, Bool))
                          -- | By settings this field, clients can specify the
                          -- network interface to use, override the SRV lookup
                          -- of the realm, as well as specify the use of a
                          -- non-standard port when connecting by IP or
                          -- connecting to a domain without SRV records.
                        , StreamConfiguration -> ConnectionDetails
connectionDetails :: ConnectionDetails
                          -- | DNS resolver configuration
                        , StreamConfiguration -> ResolvConf
resolvConf :: ResolvConf
                          -- | Whether or not to perform the legacy
                          -- session bind as defined in the (outdated)
                          -- RFC 3921 specification
                        , StreamConfiguration -> TlsBehaviour
tlsBehaviour :: TlsBehaviour
                          -- | Settings to be used for TLS negotitation
                        , StreamConfiguration -> ClientParams
tlsParams :: ClientParams
                        }

-- | Default parameters for TLS restricted to strong ciphers
xmppDefaultParamsStrong :: ClientParams
xmppDefaultParamsStrong :: ClientParams
xmppDefaultParamsStrong = (String -> ByteString -> ClientParams
defaultParamsClient String
"" ByteString
BS.empty)
                        { clientSupported :: Supported
clientSupported = Supported
forall a. Default a => a
def
                            { supportedCiphers :: [Cipher]
supportedCiphers = [Cipher]
ciphersuite_strong
                                                 [Cipher] -> [Cipher] -> [Cipher]
forall a. [a] -> [a] -> [a]
++ [ Cipher
cipher_AES256_SHA1
                                                    , Cipher
cipher_AES128_SHA1
                                                    ]
                            }
                        }

-- | Default parameters for TLS
-- @ciphersuite_all@ can be used to allow insecure ciphers
xmppDefaultParams :: ClientParams
xmppDefaultParams :: ClientParams
xmppDefaultParams = (String -> ByteString -> ClientParams
defaultParamsClient String
"" ByteString
BS.empty)
                        { clientSupported :: Supported
clientSupported = Supported
forall a. Default a => a
def
                            { supportedCiphers :: [Cipher]
supportedCiphers = [Cipher]
ciphersuite_default
                            }
                        }

instance Default StreamConfiguration where
    def :: StreamConfiguration
def = StreamConfiguration :: Maybe LangTag
-> Maybe (Jid, Bool)
-> ConnectionDetails
-> ResolvConf
-> TlsBehaviour
-> ClientParams
-> StreamConfiguration
StreamConfiguration { preferredLang :: Maybe LangTag
preferredLang     = Maybe LangTag
forall a. Maybe a
Nothing
                              , toJid :: Maybe (Jid, Bool)
toJid             = Maybe (Jid, Bool)
forall a. Maybe a
Nothing
                              , connectionDetails :: ConnectionDetails
connectionDetails = ConnectionDetails
UseRealm
                              , resolvConf :: ResolvConf
resolvConf        = ResolvConf
defaultResolvConf
                              , tlsBehaviour :: TlsBehaviour
tlsBehaviour      = TlsBehaviour
PreferTls
                              , tlsParams :: ClientParams
tlsParams         = ClientParams
xmppDefaultParams
                              }

-- | How the client should behave in regards to TLS.
data TlsBehaviour = RequireTls -- ^ Require the use of TLS; disconnect if it's
                               -- not offered.
                  | PreferTls  -- ^ Negotitate TLS if it's available.
                  | PreferPlain  -- ^ Negotitate TLS only if the server requires
                                 -- it
                  | RefuseTls  -- ^ Never secure the stream with TLS.
                    deriving (TlsBehaviour -> TlsBehaviour -> Bool
(TlsBehaviour -> TlsBehaviour -> Bool)
-> (TlsBehaviour -> TlsBehaviour -> Bool) -> Eq TlsBehaviour
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TlsBehaviour -> TlsBehaviour -> Bool
$c/= :: TlsBehaviour -> TlsBehaviour -> Bool
== :: TlsBehaviour -> TlsBehaviour -> Bool
$c== :: TlsBehaviour -> TlsBehaviour -> Bool
Eq, Int -> TlsBehaviour -> ShowS
[TlsBehaviour] -> ShowS
TlsBehaviour -> String
(Int -> TlsBehaviour -> ShowS)
-> (TlsBehaviour -> String)
-> ([TlsBehaviour] -> ShowS)
-> Show TlsBehaviour
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TlsBehaviour] -> ShowS
$cshowList :: [TlsBehaviour] -> ShowS
show :: TlsBehaviour -> String
$cshow :: TlsBehaviour -> String
showsPrec :: Int -> TlsBehaviour -> ShowS
$cshowsPrec :: Int -> TlsBehaviour -> ShowS
Show, (forall x. TlsBehaviour -> Rep TlsBehaviour x)
-> (forall x. Rep TlsBehaviour x -> TlsBehaviour)
-> Generic TlsBehaviour
forall x. Rep TlsBehaviour x -> TlsBehaviour
forall x. TlsBehaviour -> Rep TlsBehaviour x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TlsBehaviour x -> TlsBehaviour
$cfrom :: forall x. TlsBehaviour -> Rep TlsBehaviour x
Generic)