{-# 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 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
data Stream
= Stream
{ Stream -> Handle
handle::Handle
, Stream -> Int
idx :: !Int
, Stream -> [Token]
lexemes :: [Token]
}
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
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
, JID 'NodeResource -> DomainID
jnrDomain :: DomainID
, JID 'NodeResource -> ResourceID
jnrResource :: ResourceID
} -> 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
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
data StreamType = Client
| ComponentAccept
| ComponentConnect
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"
data RosterItem = RosterItem { RosterItem -> JID 'NodeResource
jid :: JID 'NodeResource
, RosterItem -> SubscribtionType
subscribtion :: SubscribtionType
, RosterItem -> Maybe String
nickname :: Maybe String
, RosterItem -> [String]
groups :: [String]
}
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"
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
, Stanza 'Message p ext -> MessageType
mType :: MessageType
, Stanza 'Message p ext -> Text
mSubject :: T.Text
, Stanza 'Message p ext -> Text
mBody :: T.Text
, Stanza 'Message p ext -> Text
mThread :: T.Text
, Stanza 'Message p ext -> DataByPurpose p ext
mExt :: DataByPurpose p ext
, 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
, Stanza 'Presence p ext -> PresenceType
pType :: PresenceType
, Stanza 'Presence p ext -> ShowType
pShowType :: ShowType
, Stanza 'Presence p ext -> Text
pStatus :: T.Text
, Stanza 'Presence p ext -> Maybe Integer
pPriority :: Maybe Integer
, Stanza 'Presence p ext -> DataByPurpose p ext
pExt :: DataByPurpose p ext
, 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
, Stanza 'IQ p ext -> IQType
iqType :: IQType
, Stanza 'IQ p ext -> DataByPurpose p ext
iqBody :: DataByPurpose p ext
, 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)