{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}


-----------------------------------------------------------------------------
-- |
-- Module      :  Network.XMPP.Types
-- Copyright   :  (c) Dmitry Astapov, 2006 ; pierre, 2007
-- License     :  BSD-style (see the file LICENSE)
-- Copyright   :  (c) riskbook, 2020
-- SPDX-License-Identifier:  BSD3
--
-- Maintainer  :  Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-----------------------------------------------------------------------------
module Network.XMPP.Types where

import System.IO              (Handle, stdin)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans    (MonadTrans)
import Control.Monad.State    (MonadState, StateT, runStateT)
import Data.Maybe             (maybeToList)
import qualified Data.Text as T

import Text.Blaze             (ToMarkup (toMarkup))
import Text.Regex
import Text.XML.HaXml.Types   (Content)
import Text.XML.HaXml.Posn    (Posn)
import Text.XML.HaXml.Lex     (Token)
import Text.XML               (Node)
import Singlethongs
--------------------------------------------------------------------------------

type Server   = T.Text
type Username = T.Text
type Password = T.Text
type Resource = T.Text

--------------------------------------------------------------------------------

-- | XMPP stream, used as a state in XmppMonad state transformer
data Stream
    = Stream
    { Stream -> Handle
handle::Handle     -- ^ IO handle to the underlying file or socket
    , Stream -> Int
idx :: !Int        -- ^ id of the next message (if needed)
    , Stream -> [Token]
lexemes :: [Token] -- ^ Stream of the lexemes coming from server
    }

newtype XmppMonad m a
    = XmppMonad { XmppMonad m a -> StateT Stream m a
unXmppMonad :: StateT Stream m a }
    deriving (a -> XmppMonad m b -> XmppMonad m a
(a -> b) -> XmppMonad m a -> XmppMonad m b
(forall a b. (a -> b) -> XmppMonad m a -> XmppMonad m b)
-> (forall a b. a -> XmppMonad m b -> XmppMonad m a)
-> Functor (XmppMonad m)
forall a b. a -> XmppMonad m b -> XmppMonad m a
forall a b. (a -> b) -> XmppMonad m a -> XmppMonad m b
forall (m :: * -> *) a b.
Functor m =>
a -> XmppMonad m b -> XmppMonad m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> XmppMonad m a -> XmppMonad m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> XmppMonad m b -> XmppMonad m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> XmppMonad m b -> XmppMonad m a
fmap :: (a -> b) -> XmppMonad m a -> XmppMonad m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> XmppMonad m a -> XmppMonad m b
Functor, Functor (XmppMonad m)
a -> XmppMonad m a
Functor (XmppMonad m)
-> (forall a. a -> XmppMonad m a)
-> (forall a b.
    XmppMonad m (a -> b) -> XmppMonad m a -> XmppMonad m b)
-> (forall a b c.
    (a -> b -> c) -> XmppMonad m a -> XmppMonad m b -> XmppMonad m c)
-> (forall a b. XmppMonad m a -> XmppMonad m b -> XmppMonad m b)
-> (forall a b. XmppMonad m a -> XmppMonad m b -> XmppMonad m a)
-> Applicative (XmppMonad m)
XmppMonad m a -> XmppMonad m b -> XmppMonad m b
XmppMonad m a -> XmppMonad m b -> XmppMonad m a
XmppMonad m (a -> b) -> XmppMonad m a -> XmppMonad m b
(a -> b -> c) -> XmppMonad m a -> XmppMonad m b -> XmppMonad m c
forall a. a -> XmppMonad m a
forall a b. XmppMonad m a -> XmppMonad m b -> XmppMonad m a
forall a b. XmppMonad m a -> XmppMonad m b -> XmppMonad m b
forall a b. XmppMonad m (a -> b) -> XmppMonad m a -> XmppMonad m b
forall a b c.
(a -> b -> c) -> XmppMonad m a -> XmppMonad m b -> XmppMonad m c
forall (m :: * -> *). Monad m => Functor (XmppMonad m)
forall (m :: * -> *) a. Monad m => a -> XmppMonad m a
forall (m :: * -> *) a b.
Monad m =>
XmppMonad m a -> XmppMonad m b -> XmppMonad m a
forall (m :: * -> *) a b.
Monad m =>
XmppMonad m a -> XmppMonad m b -> XmppMonad m b
forall (m :: * -> *) a b.
Monad m =>
XmppMonad m (a -> b) -> XmppMonad m a -> XmppMonad m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> XmppMonad m a -> XmppMonad m b -> XmppMonad m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: XmppMonad m a -> XmppMonad m b -> XmppMonad m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
XmppMonad m a -> XmppMonad m b -> XmppMonad m a
*> :: XmppMonad m a -> XmppMonad m b -> XmppMonad m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
XmppMonad m a -> XmppMonad m b -> XmppMonad m b
liftA2 :: (a -> b -> c) -> XmppMonad m a -> XmppMonad m b -> XmppMonad m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> XmppMonad m a -> XmppMonad m b -> XmppMonad m c
<*> :: XmppMonad m (a -> b) -> XmppMonad m a -> XmppMonad m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
XmppMonad m (a -> b) -> XmppMonad m a -> XmppMonad m b
pure :: a -> XmppMonad m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> XmppMonad m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (XmppMonad m)
Applicative, Applicative (XmppMonad m)
a -> XmppMonad m a
Applicative (XmppMonad m)
-> (forall a b.
    XmppMonad m a -> (a -> XmppMonad m b) -> XmppMonad m b)
-> (forall a b. XmppMonad m a -> XmppMonad m b -> XmppMonad m b)
-> (forall a. a -> XmppMonad m a)
-> Monad (XmppMonad m)
XmppMonad m a -> (a -> XmppMonad m b) -> XmppMonad m b
XmppMonad m a -> XmppMonad m b -> XmppMonad m b
forall a. a -> XmppMonad m a
forall a b. XmppMonad m a -> XmppMonad m b -> XmppMonad m b
forall a b. XmppMonad m a -> (a -> XmppMonad m b) -> XmppMonad m b
forall (m :: * -> *). Monad m => Applicative (XmppMonad m)
forall (m :: * -> *) a. Monad m => a -> XmppMonad m a
forall (m :: * -> *) a b.
Monad m =>
XmppMonad m a -> XmppMonad m b -> XmppMonad m b
forall (m :: * -> *) a b.
Monad m =>
XmppMonad m a -> (a -> XmppMonad m b) -> XmppMonad m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> XmppMonad m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> XmppMonad m a
>> :: XmppMonad m a -> XmppMonad m b -> XmppMonad m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
XmppMonad m a -> XmppMonad m b -> XmppMonad m b
>>= :: XmppMonad m a -> (a -> XmppMonad m b) -> XmppMonad m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
XmppMonad m a -> (a -> XmppMonad m b) -> XmppMonad m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (XmppMonad m)
Monad, Monad (XmppMonad m)
Monad (XmppMonad m)
-> (forall a. IO a -> XmppMonad m a) -> MonadIO (XmppMonad m)
IO a -> XmppMonad m a
forall a. IO a -> XmppMonad m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (XmppMonad m)
forall (m :: * -> *) a. MonadIO m => IO a -> XmppMonad m a
liftIO :: IO a -> XmppMonad m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> XmppMonad m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (XmppMonad m)
MonadIO, MonadState Stream, m a -> XmppMonad m a
(forall (m :: * -> *) a. Monad m => m a -> XmppMonad m a)
-> MonadTrans XmppMonad
forall (m :: * -> *) a. Monad m => m a -> XmppMonad m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> XmppMonad m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> XmppMonad m a
MonadTrans)

runXmppMonad :: MonadIO m => XmppMonad m a -> m (a, Stream)
runXmppMonad :: XmppMonad m a -> m (a, Stream)
runXmppMonad = (StateT Stream m a -> Stream -> m (a, Stream))
-> Stream -> StateT Stream m a -> m (a, Stream)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Stream m a -> Stream -> m (a, Stream)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Stream
newStream (StateT Stream m a -> m (a, Stream))
-> (XmppMonad m a -> StateT Stream m a)
-> XmppMonad m a
-> m (a, Stream)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmppMonad m a -> StateT Stream m a
forall (m :: * -> *) a. XmppMonad m a -> StateT Stream m a
unXmppMonad
  where newStream :: Stream
newStream = Stream :: Handle -> Int -> [Token] -> Stream
Stream { handle :: Handle
handle = Handle
stdin, idx :: Int
idx = Int
0, lexemes :: [Token]
lexemes = [] }

runXmppMonad' :: MonadIO m => Stream -> XmppMonad m a -> m (a, Stream)
runXmppMonad' :: Stream -> XmppMonad m a -> m (a, Stream)
runXmppMonad' Stream
s = (StateT Stream m a -> Stream -> m (a, Stream))
-> Stream -> StateT Stream m a -> m (a, Stream)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Stream m a -> Stream -> m (a, Stream)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Stream
s (StateT Stream m a -> m (a, Stream))
-> (XmppMonad m a -> StateT Stream m a)
-> XmppMonad m a
-> m (a, Stream)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmppMonad m a -> StateT Stream m a
forall (m :: * -> *) a. XmppMonad m a -> StateT Stream m a
unXmppMonad

--------------------------------------------------------------------------------
-- | Jabber ID (JID) datatype
--
-- https://xmpp.org/extensions/xep-0029.html#sect-idm45723967532368
-- <JID>      - [<node>"@"]<domain>["/"<resource>]
-- <node>     - <conforming-char>[<conforming-char>]* - The node identifier (optional)
-- <domain>   - <hname>["."<hname>]*                  - The domain identifier (required)
-- <resource> - <any-char>[<any-char>]*               - The resource identifier (optional)

newtype DomainID = DomainID { DomainID -> Text
unDomainID :: T.Text } deriving (DomainID -> DomainID -> Bool
(DomainID -> DomainID -> Bool)
-> (DomainID -> DomainID -> Bool) -> Eq DomainID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DomainID -> DomainID -> Bool
$c/= :: DomainID -> DomainID -> Bool
== :: DomainID -> DomainID -> Bool
$c== :: DomainID -> DomainID -> Bool
Eq, Int -> DomainID -> ShowS
[DomainID] -> ShowS
DomainID -> String
(Int -> DomainID -> ShowS)
-> (DomainID -> String) -> ([DomainID] -> ShowS) -> Show DomainID
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DomainID] -> ShowS
$cshowList :: [DomainID] -> ShowS
show :: DomainID -> String
$cshow :: DomainID -> String
showsPrec :: Int -> DomainID -> ShowS
$cshowsPrec :: Int -> DomainID -> ShowS
Show)

newtype NodeID = NodeID { NodeID -> Text
unNodeID :: T.Text } deriving (NodeID -> NodeID -> Bool
(NodeID -> NodeID -> Bool)
-> (NodeID -> NodeID -> Bool) -> Eq NodeID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeID -> NodeID -> Bool
$c/= :: NodeID -> NodeID -> Bool
== :: NodeID -> NodeID -> Bool
$c== :: NodeID -> NodeID -> Bool
Eq, Int -> NodeID -> ShowS
[NodeID] -> ShowS
NodeID -> String
(Int -> NodeID -> ShowS)
-> (NodeID -> String) -> ([NodeID] -> ShowS) -> Show NodeID
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeID] -> ShowS
$cshowList :: [NodeID] -> ShowS
show :: NodeID -> String
$cshow :: NodeID -> String
showsPrec :: Int -> NodeID -> ShowS
$cshowsPrec :: Int -> NodeID -> ShowS
Show)

newtype ResourceID = ResourceID { ResourceID -> Text
unResourceID :: T.Text } deriving (ResourceID -> ResourceID -> Bool
(ResourceID -> ResourceID -> Bool)
-> (ResourceID -> ResourceID -> Bool) -> Eq ResourceID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResourceID -> ResourceID -> Bool
$c/= :: ResourceID -> ResourceID -> Bool
== :: ResourceID -> ResourceID -> Bool
$c== :: ResourceID -> ResourceID -> Bool
Eq, Int -> ResourceID -> ShowS
[ResourceID] -> ShowS
ResourceID -> String
(Int -> ResourceID -> ShowS)
-> (ResourceID -> String)
-> ([ResourceID] -> ShowS)
-> Show ResourceID
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ResourceID] -> ShowS
$cshowList :: [ResourceID] -> ShowS
show :: ResourceID -> String
$cshow :: ResourceID -> String
showsPrec :: Int -> ResourceID -> ShowS
$cshowsPrec :: Int -> ResourceID -> ShowS
Show)

data JIDQualification
  = Resource
  | NodeResource
  | Node
  | Domain

data SomeJID = forall (a :: JIDQualification). SomeJID (JID a)

data JID :: JIDQualification -> * where
  ResourceJID     :: { JID 'Resource -> DomainID
jrDomain :: DomainID
                     , JID 'Resource -> ResourceID
jrResource :: ResourceID
                     } -> JID 'Resource

  NodeResourceJID :: { JID 'NodeResource -> NodeID
jnrNode :: NodeID           -- ^ Account name
                     , JID 'NodeResource -> DomainID
jnrDomain :: DomainID       -- ^ Server adress
                     , JID 'NodeResource -> ResourceID
jnrResource :: ResourceID   -- ^ Resource name
                     } -> JID 'NodeResource
  NodeJID         :: { JID 'Node -> NodeID
nNode :: NodeID
                     , JID 'Node -> DomainID
nDomain :: DomainID
                     } -> JID 'Node
  DomainJID       :: { JID 'Domain -> DomainID
jdDomain :: DomainID } -> JID 'Domain

toBareJID :: JID 'NodeResource -> JID 'Node
toBareJID :: JID 'NodeResource -> JID 'Node
toBareJID (NodeResourceJID NodeID
node DomainID
domain ResourceID
_) = NodeID -> DomainID -> JID 'Node
NodeJID NodeID
node DomainID
domain

instance Read (JID 'NodeResource) where
  readsPrec :: Int -> ReadS (JID 'NodeResource)
readsPrec Int
prev String
str =
    case Int -> ReadS SomeJID
forall a. Read a => Int -> ReadS a
readsPrec Int
prev String
str of
      [(SomeJID j :: JID a
j@NodeResourceJID{}, String
after)] -> [(JID a
JID 'NodeResource
j, String
after)]
      [(SomeJID, String)]
_ -> []

instance Read (JID 'Resource) where
  readsPrec :: Int -> ReadS (JID 'Resource)
readsPrec Int
prev String
str =
    case Int -> ReadS SomeJID
forall a. Read a => Int -> ReadS a
readsPrec Int
prev String
str of
      [(SomeJID j :: JID a
j@ResourceJID{}, String
after)] -> [(JID a
JID 'Resource
j, String
after)]
      [(SomeJID, String)]
_ -> []

instance Read (JID 'Domain) where
  readsPrec :: Int -> ReadS (JID 'Domain)
readsPrec Int
prev String
str =
    case Int -> ReadS SomeJID
forall a. Read a => Int -> ReadS a
readsPrec Int
prev String
str of
      [(SomeJID j :: JID a
j@DomainJID{}, String
after)] -> [(JID a
JID 'Domain
j, String
after)]
      [(SomeJID, String)]
_ -> []

instance Read (JID 'Node) where
  readsPrec :: Int -> ReadS (JID 'Node)
readsPrec Int
prev String
str =
    case Int -> ReadS SomeJID
forall a. Read a => Int -> ReadS a
readsPrec Int
prev String
str of
      [(SomeJID j :: JID a
j@NodeJID{}, String
after)] -> [(JID a
JID 'Node
j, String
after)]
      [(SomeJID, String)]
_ -> []

instance Read SomeJID where
  -- Reads JID from string (name@server\/resource)
  readsPrec :: Int -> ReadS SomeJID
readsPrec Int
_ String
str = case Regex -> String -> Maybe (String, String, String, [String])
matchRegexAll Regex
regex String
str of
    Just (String
_, String
_, String
after, [String
_, String
name, String
_, String
server, String
_, String
_, String
resource, String
_]) ->
      (SomeJID -> (SomeJID, String)) -> [SomeJID] -> [(SomeJID, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, String
after) ([SomeJID] -> [(SomeJID, String)])
-> (Maybe SomeJID -> [SomeJID])
-> Maybe SomeJID
-> [(SomeJID, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SomeJID -> [SomeJID]
forall a. Maybe a -> [a]
maybeToList (Maybe SomeJID -> [(SomeJID, String)])
-> Maybe SomeJID -> [(SomeJID, String)]
forall a b. (a -> b) -> a -> b
$ case (String -> Maybe String
forall a. (Eq a, IsString a) => a -> Maybe a
toMaybe String
name, String
server, String -> Maybe String
forall a. (Eq a, IsString a) => a -> Maybe a
toMaybe String
resource) of
        (Just String
node, String
domain, Just String
resource) ->
          let nodeId :: NodeID
nodeId     = Text -> NodeID
NodeID (Text -> NodeID) -> Text -> NodeID
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
node
              domainId :: DomainID
domainId   = Text -> DomainID
DomainID (Text -> DomainID) -> Text -> DomainID
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
domain
              resourceId :: ResourceID
resourceId = Text -> ResourceID
ResourceID (Text -> ResourceID) -> Text -> ResourceID
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
resource
          in  SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ JID 'NodeResource -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID (JID 'NodeResource -> SomeJID) -> JID 'NodeResource -> SomeJID
forall a b. (a -> b) -> a -> b
$ NodeID -> DomainID -> ResourceID -> JID 'NodeResource
NodeResourceJID NodeID
nodeId DomainID
domainId ResourceID
resourceId
        (Just String
node, String
domain, Maybe String
Nothing) ->
          let nodeId :: NodeID
nodeId     = Text -> NodeID
NodeID (Text -> NodeID) -> Text -> NodeID
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
node
              domainId :: DomainID
domainId   = Text -> DomainID
DomainID (Text -> DomainID) -> Text -> DomainID
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
domain
          in SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ JID 'Node -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID (JID 'Node -> SomeJID) -> JID 'Node -> SomeJID
forall a b. (a -> b) -> a -> b
$ NodeID -> DomainID -> JID 'Node
NodeJID NodeID
nodeId DomainID
domainId
        (Maybe String
Nothing, String
domain, Maybe String
Nothing) ->
          SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ JID 'Domain -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID (JID 'Domain -> SomeJID) -> JID 'Domain -> SomeJID
forall a b. (a -> b) -> a -> b
$ DomainID -> JID 'Domain
DomainJID (DomainID -> JID 'Domain) -> DomainID -> JID 'Domain
forall a b. (a -> b) -> a -> b
$ Text -> DomainID
DomainID (Text -> DomainID) -> Text -> DomainID
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
domain
        (Maybe String
Nothing, String
domain, Just String
resource) ->
          let domainId :: DomainID
domainId   = Text -> DomainID
DomainID (Text -> DomainID) -> Text -> DomainID
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
domain
              resourceId :: ResourceID
resourceId = Text -> ResourceID
ResourceID (Text -> ResourceID) -> Text -> ResourceID
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
resource
          in  SomeJID -> Maybe SomeJID
forall a. a -> Maybe a
Just (SomeJID -> Maybe SomeJID) -> SomeJID -> Maybe SomeJID
forall a b. (a -> b) -> a -> b
$ JID 'Resource -> SomeJID
forall (a :: JIDQualification). JID a -> SomeJID
SomeJID (JID 'Resource -> SomeJID) -> JID 'Resource -> SomeJID
forall a b. (a -> b) -> a -> b
$ DomainID -> ResourceID -> JID 'Resource
ResourceJID DomainID
domainId ResourceID
resourceId
    Maybe (String, String, String, [String])
_  -> []
    where
      toMaybe :: a -> Maybe a
toMaybe a
"" = Maybe a
forall a. Maybe a
Nothing
      toMaybe a
s  = a -> Maybe a
forall a. a -> Maybe a
Just a
s
      regex :: Regex
regex = String -> Regex
mkRegex (String -> Regex) -> String -> Regex
forall a b. (a -> b) -> a -> b
$ String
"((([^@])+)@)?" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(([^/])+)" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(/((.)+))?"

instance Show SomeJID where
  show :: SomeJID -> String
show (SomeJID JID a
j) = JID a -> String
forall a. Show a => a -> String
show JID a
j

instance Show (JID a) where
  show :: JID a -> String
show (NodeResourceJID (NodeID Text
node) (DomainID Text
domain) (ResourceID Text
resource)) =
    Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
node Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
domain Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
resource
  show (ResourceJID (DomainID Text
domain) (ResourceID Text
resource)) =
    Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
domain Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
resource
  show (DomainJID (DomainID Text
domain)) = Text -> String
T.unpack Text
domain
  show (NodeJID (NodeID Text
node) (DomainID Text
domain)) =
    Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
node Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
domain

deriving instance Eq (JID a)

instance ToMarkup (JID a) where
    toMarkup :: JID a -> Markup
toMarkup = String -> Markup
forall a. ToMarkup a => a -> Markup
toMarkup (String -> Markup) -> (JID a -> String) -> JID a -> Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JID a -> String
forall a. Show a => a -> String
show

--------------------------------------------------------------------------------

-- | XMPP Stream type, used in 'stream' pretty-printing combinator and the likes
data StreamType = Client -- ^ Client-to-server
                | ComponentAccept -- ^ FIXME
                | ComponentConnect -- ^ FIXME

instance Show StreamType where
  show :: StreamType -> String
show StreamType
Client = String
"jabber:client"
  show StreamType
ComponentAccept = String
"jabber:component:accept"
  show StreamType
ComponentConnect = String
"jabber:component:connect"

-- | Roster item type (7.1)
data RosterItem = RosterItem { RosterItem -> JID 'NodeResource
jid :: JID 'NodeResource
                             -- ^ Entry's JID
                             , RosterItem -> SubscribtionType
subscribtion :: SubscribtionType
                             -- ^ Subscribtion type
                             , RosterItem -> Maybe String
nickname :: Maybe String
                             -- ^ Entry's nickname
                             , RosterItem -> [String]
groups :: [String]
                             -- ^ <group> elements
                             }

data SubscribtionType = None | To | From | Both deriving SubscribtionType -> SubscribtionType -> Bool
(SubscribtionType -> SubscribtionType -> Bool)
-> (SubscribtionType -> SubscribtionType -> Bool)
-> Eq SubscribtionType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SubscribtionType -> SubscribtionType -> Bool
$c/= :: SubscribtionType -> SubscribtionType -> Bool
== :: SubscribtionType -> SubscribtionType -> Bool
$c== :: SubscribtionType -> SubscribtionType -> Bool
Eq

instance Show SubscribtionType where
  show :: SubscribtionType -> String
show SubscribtionType
None = String
"none"
  show SubscribtionType
To = String
"to"
  show SubscribtionType
From = String
"from"
  show SubscribtionType
Both = String
"both"

instance Read SubscribtionType where
  readsPrec :: Int -> ReadS SubscribtionType
readsPrec Int
_ String
"none" = [(SubscribtionType
None, String
"")]
  readsPrec Int
_ String
"to" = [(SubscribtionType
To, String
"")]
  readsPrec Int
_ String
"from" = [(SubscribtionType
From, String
"")]
  readsPrec Int
_ String
"both" = [(SubscribtionType
Both, String
"")]
  readsPrec Int
_ String
"" = [(SubscribtionType
None, String
"")]
  readsPrec Int
_ String
_ = ReadS SubscribtionType
forall a. HasCallStack => String -> a
error String
"incorrect subscribtion type"


--------------------------------------------------------------------------------

data MessageType
    = Chat
    | GroupChat
    | Headline
    | Normal
    | MessageError
    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)

instance Show MessageType where
  show :: MessageType -> String
show MessageType
Chat = String
"chat"
  show MessageType
GroupChat = String
"groupchat"
  show MessageType
Headline = String
"headline"
  show MessageType
Normal = String
"normal"
  show MessageType
MessageError = String
"error"
instance Read MessageType where
  readsPrec :: Int -> ReadS MessageType
readsPrec Int
_ String
"chat" = [(MessageType
Chat, String
"")]
  readsPrec Int
_ String
"groupchat" = [(MessageType
GroupChat, String
"")]
  readsPrec Int
_ String
"headline" = [(MessageType
Headline, String
"")]
  readsPrec Int
_ String
"normal" = [(MessageType
Normal, String
"")]
  readsPrec Int
_ String
"error" = [(MessageType
MessageError, String
"")]
  readsPrec Int
_ String
"" = [(MessageType
Chat, String
"")]
  readsPrec Int
_ String
_ = ReadS MessageType
forall a. HasCallStack => String -> a
error String
"incorrect message type"

data PresenceType
    = Default
    | Unavailable
    | Subscribe
    | Subscribed
    | Unsubscribe
    | Unsubscribed
    | Probe
    | PresenceError
    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)

instance Show PresenceType where
  show :: PresenceType -> String
show PresenceType
Default = String
""
  show PresenceType
Unavailable = String
"unavailable"
  show PresenceType
Subscribe = String
"subscribe"
  show PresenceType
Subscribed = String
"subscribed"
  show PresenceType
Unsubscribe = String
"unsubscribe"
  show PresenceType
Unsubscribed = String
"unsubscribed"
  show PresenceType
Probe = String
"probe"
  show PresenceType
PresenceError = String
"error"
instance Read PresenceType where
  readsPrec :: Int -> ReadS PresenceType
readsPrec Int
_ String
"" = [(PresenceType
Default, String
"")]
  readsPrec Int
_ String
"available" = [(PresenceType
Default, String
"")]
  readsPrec Int
_ String
"unavailable" = [(PresenceType
Unavailable, String
"")]
  readsPrec Int
_ String
"subscribe" = [(PresenceType
Subscribe, String
"")]
  readsPrec Int
_ String
"subscribed" = [(PresenceType
Subscribed, String
"")]
  readsPrec Int
_ String
"unsubscribe" = [(PresenceType
Unsubscribe, String
"")]
  readsPrec Int
_ String
"unsubscribed" = [(PresenceType
Unsubscribed, String
"")]
  readsPrec Int
_ String
"probe" = [(PresenceType
Probe, String
"")]
  readsPrec Int
_ String
"error" = [(PresenceType
PresenceError, String
"")]
  readsPrec Int
_ String
_ = ReadS PresenceType
forall a. HasCallStack => String -> a
error String
"incorrect presence type"

data IQType
    = Get
    | Result
    | Set
    | IQError
    deriving (IQType -> IQType -> Bool
(IQType -> IQType -> Bool)
-> (IQType -> IQType -> Bool) -> Eq IQType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IQType -> IQType -> Bool
$c/= :: IQType -> IQType -> Bool
== :: IQType -> IQType -> Bool
$c== :: IQType -> IQType -> Bool
Eq)

instance Show IQType where
  show :: IQType -> String
show IQType
Get = String
"get"
  show IQType
Result = String
"result"
  show IQType
Set = String
"set"
  show IQType
IQError = String
"error"
instance Read IQType where
  readsPrec :: Int -> ReadS IQType
readsPrec Int
_ String
"get" = [(IQType
Get, String
"")]
  readsPrec Int
_ String
"result" = [(IQType
Result, String
"")]
  readsPrec Int
_ String
"set" = [(IQType
Set, String
"")]
  readsPrec Int
_ String
"error" = [(IQType
IQError, String
"")]
  readsPrec Int
_ String
"" = [(IQType
Get, String
"")]
  readsPrec Int
_ String
_ = ReadS IQType
forall a. HasCallStack => String -> a
error String
"incorrect iq type"

data ShowType = Available
  | Away
  | FreeChat
  | DND
  | XAway
  deriving (ShowType -> ShowType -> Bool
(ShowType -> ShowType -> Bool)
-> (ShowType -> ShowType -> Bool) -> Eq ShowType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShowType -> ShowType -> Bool
$c/= :: ShowType -> ShowType -> Bool
== :: ShowType -> ShowType -> Bool
$c== :: ShowType -> ShowType -> Bool
Eq)

instance Show ShowType where
  show :: ShowType -> String
show ShowType
Available = String
""
  show ShowType
Away = String
"away"
  show ShowType
FreeChat = String
"chat"
  show ShowType
DND = String
"dnd"
  show ShowType
XAway = String
"xa"
instance Read ShowType where
  readsPrec :: Int -> ReadS ShowType
readsPrec Int
_ String
"" = [(ShowType
Available, String
"")]
  readsPrec Int
_ String
"available" = [(ShowType
Available, String
"")]
  readsPrec Int
_ String
"away" = [(ShowType
Away, String
"")]
  readsPrec Int
_ String
"chat" = [(ShowType
FreeChat, String
"")]
  readsPrec Int
_ String
"dnd" = [(ShowType
DND, String
"")]
  readsPrec Int
_ String
"xa" = [(ShowType
XAway, String
"")]
  readsPrec Int
_ String
"invisible" = [(ShowType
Available, String
"")]
  readsPrec Int
_ String
_ = ReadS ShowType
forall a. HasCallStack => String -> a
error String
"incorrect <show> value"

--------------------------------------------------------------------------------
-- | Generic XMPP stream atom

data StanzaPurpose = Incoming | Outgoing
  deriving (StanzaPurpose -> StanzaPurpose -> Bool
(StanzaPurpose -> StanzaPurpose -> Bool)
-> (StanzaPurpose -> StanzaPurpose -> Bool) -> Eq StanzaPurpose
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StanzaPurpose -> StanzaPurpose -> Bool
$c/= :: StanzaPurpose -> StanzaPurpose -> Bool
== :: StanzaPurpose -> StanzaPurpose -> Bool
$c== :: StanzaPurpose -> StanzaPurpose -> Bool
Eq, Int -> StanzaPurpose -> ShowS
[StanzaPurpose] -> ShowS
StanzaPurpose -> String
(Int -> StanzaPurpose -> ShowS)
-> (StanzaPurpose -> String)
-> ([StanzaPurpose] -> ShowS)
-> Show StanzaPurpose
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StanzaPurpose] -> ShowS
$cshowList :: [StanzaPurpose] -> ShowS
show :: StanzaPurpose -> String
$cshow :: StanzaPurpose -> String
showsPrec :: Int -> StanzaPurpose -> ShowS
$cshowsPrec :: Int -> StanzaPurpose -> ShowS
Show)

singlethongs ''StanzaPurpose

data SomeStanza e
  = forall (a :: StanzaType) (p :: StanzaPurpose)
  . SomeStanza (Stanza a p e)

instance Show e => Show (SomeStanza e) where
  show :: SomeStanza e -> String
show (SomeStanza (s :: Stanza a p e
s@MkMessage {mPurpose :: forall (p :: StanzaPurpose) ext. Stanza 'Message p ext -> Sing p
mPurpose = Sing p
SIncoming})) = String
"(SomeStanza $ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Stanza a p e -> String
forall a. Show a => a -> String
show Stanza a p e
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
  show (SomeStanza (s :: Stanza a p e
s@MkMessage {mPurpose :: forall (p :: StanzaPurpose) ext. Stanza 'Message p ext -> Sing p
mPurpose = Sing p
SOutgoing})) = String
"(SomeStanza $ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Stanza a p e -> String
forall a. Show a => a -> String
show Stanza a p e
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
  show (SomeStanza (s :: Stanza a p e
s@MkPresence {pPurpose :: forall (p :: StanzaPurpose) ext. Stanza 'Presence p ext -> Sing p
pPurpose = Sing p
SIncoming})) = String
"(SomeStanza $ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Stanza a p e -> String
forall a. Show a => a -> String
show Stanza a p e
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
  show (SomeStanza (s :: Stanza a p e
s@MkPresence {pPurpose :: forall (p :: StanzaPurpose) ext. Stanza 'Presence p ext -> Sing p
pPurpose = Sing p
SOutgoing})) = String
"(SomeStanza $ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Stanza a p e -> String
forall a. Show a => a -> String
show Stanza a p e
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
  show (SomeStanza (s :: Stanza a p e
s@MkIQ {iqPurpose :: forall (p :: StanzaPurpose) ext. Stanza 'IQ p ext -> Sing p
iqPurpose = Sing p
SIncoming})) = String
"(SomeStanza $ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Stanza a p e -> String
forall a. Show a => a -> String
show Stanza a p e
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
  show (SomeStanza (s :: Stanza a p e
s@MkIQ {iqPurpose :: forall (p :: StanzaPurpose) ext. Stanza 'IQ p ext -> Sing p
iqPurpose = Sing p
SOutgoing})) = String
"(SomeStanza $ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Stanza a p e -> String
forall a. Show a => a -> String
show Stanza a p e
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"

data StanzaType
    = Message
    | Presence
    | IQ

type family DataByPurpose (p :: StanzaPurpose) body where
  DataByPurpose 'Incoming body = Either [Content Posn] body
  DataByPurpose 'Outgoing body = [Node]

data Stanza :: StanzaType -> StanzaPurpose -> * -> * where
    MkMessage ::
        { Stanza 'Message p ext -> Maybe SomeJID
mFrom    :: Maybe SomeJID
        , Stanza 'Message p ext -> Maybe SomeJID
mTo      :: Maybe SomeJID
        , Stanza 'Message p ext -> Text
mId      :: T.Text          -- ^ Message 'from', 'to', 'id' attributes
        , Stanza 'Message p ext -> MessageType
mType    :: MessageType     -- ^ Message type (2.1.1)
        , Stanza 'Message p ext -> Text
mSubject :: T.Text          -- ^ Subject element (2.1.2.1)
        , Stanza 'Message p ext -> Text
mBody    :: T.Text          -- ^ Body element (2.1.2.2)
        , Stanza 'Message p ext -> Text
mThread  :: T.Text          -- ^ Thread element (2.1.2.3)
        , Stanza 'Message p ext -> DataByPurpose p ext
mExt     :: DataByPurpose p ext -- ^ Additional contents, used for extensions
        , Stanza 'Message p ext -> Sing p
mPurpose :: Sing p
        }
        -> Stanza 'Message p ext
    MkPresence ::
        { Stanza 'Presence p ext -> Maybe SomeJID
pFrom     :: Maybe SomeJID
        , Stanza 'Presence p ext -> Maybe SomeJID
pTo       :: Maybe SomeJID
        , Stanza 'Presence p ext -> Text
pId       :: T.Text          -- ^ Presence 'from', 'to', 'id' attributes
        , Stanza 'Presence p ext -> PresenceType
pType     :: PresenceType    -- ^ Presence type (2.2.1)
        , Stanza 'Presence p ext -> ShowType
pShowType :: ShowType        -- ^ Show element (2.2.2.1)
        , Stanza 'Presence p ext -> Text
pStatus   :: T.Text          -- ^ Status element (2.2.2.2)
        , Stanza 'Presence p ext -> Maybe Integer
pPriority :: Maybe Integer   -- ^ Presence priority (2.2.2.3)
        , Stanza 'Presence p ext -> DataByPurpose p ext
pExt      :: DataByPurpose p ext -- ^ Additional contents, used for extensions
        , Stanza 'Presence p ext -> Sing p
pPurpose :: Sing p
        }
        -> Stanza 'Presence p ext
    MkIQ ::
        { Stanza 'IQ p ext -> Maybe SomeJID
iqFrom  :: Maybe SomeJID
        , Stanza 'IQ p ext -> Maybe SomeJID
iqTo    :: Maybe SomeJID
        , Stanza 'IQ p ext -> Text
iqId    :: T.Text          -- ^ IQ id (Core-9.2.3)
        , Stanza 'IQ p ext -> IQType
iqType  :: IQType          -- ^ IQ type (Core-9.2.3)
        , Stanza 'IQ p ext -> DataByPurpose p ext
iqBody  :: DataByPurpose p ext -- ^ Child element (Core-9.2.3)
        , Stanza 'IQ p ext -> Sing p
iqPurpose :: Sing p
        }
        -> Stanza 'IQ p ext

instance Show (Sing 'Incoming) where
  show :: Sing 'Incoming -> String
show Sing 'Incoming
_ = String
"incoming"
instance Show (Sing 'Outgoing) where
  show :: Sing 'Outgoing -> String
show Sing 'Outgoing
_ = String
"outgoing"

deriving instance (Show (Sing (dir :: StanzaPurpose)), Show (DataByPurpose dir ext), Show ext) => Show (Stanza t dir ext)