{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module Network.Xmpp.IM.Presence where
import Data.Default
import Data.Text (Text)
import Data.XML.Pickle
import Data.XML.Types
import Network.Xmpp.Types
data ShowStatus = StatusAway
| StatusChat
| StatusDnd
| StatusXa deriving (ReadPrec [ShowStatus]
ReadPrec ShowStatus
Int -> ReadS ShowStatus
ReadS [ShowStatus]
(Int -> ReadS ShowStatus)
-> ReadS [ShowStatus]
-> ReadPrec ShowStatus
-> ReadPrec [ShowStatus]
-> Read ShowStatus
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ShowStatus]
$creadListPrec :: ReadPrec [ShowStatus]
readPrec :: ReadPrec ShowStatus
$creadPrec :: ReadPrec ShowStatus
readList :: ReadS [ShowStatus]
$creadList :: ReadS [ShowStatus]
readsPrec :: Int -> ReadS ShowStatus
$creadsPrec :: Int -> ReadS ShowStatus
Read, Int -> ShowStatus -> ShowS
[ShowStatus] -> ShowS
ShowStatus -> String
(Int -> ShowStatus -> ShowS)
-> (ShowStatus -> String)
-> ([ShowStatus] -> ShowS)
-> Show ShowStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShowStatus] -> ShowS
$cshowList :: [ShowStatus] -> ShowS
show :: ShowStatus -> String
$cshow :: ShowStatus -> String
showsPrec :: Int -> ShowStatus -> ShowS
$cshowsPrec :: Int -> ShowStatus -> ShowS
Show, ShowStatus -> ShowStatus -> Bool
(ShowStatus -> ShowStatus -> Bool)
-> (ShowStatus -> ShowStatus -> Bool) -> Eq ShowStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShowStatus -> ShowStatus -> Bool
$c/= :: ShowStatus -> ShowStatus -> Bool
== :: ShowStatus -> ShowStatus -> Bool
$c== :: ShowStatus -> ShowStatus -> Bool
Eq)
data IMPresence = IMP { IMPresence -> Maybe ShowStatus
showStatus :: Maybe ShowStatus
, IMPresence -> Maybe Text
status :: Maybe Text
, IMPresence -> Maybe Int
priority :: Maybe Int
} deriving (Int -> IMPresence -> ShowS
[IMPresence] -> ShowS
IMPresence -> String
(Int -> IMPresence -> ShowS)
-> (IMPresence -> String)
-> ([IMPresence] -> ShowS)
-> Show IMPresence
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IMPresence] -> ShowS
$cshowList :: [IMPresence] -> ShowS
show :: IMPresence -> String
$cshow :: IMPresence -> String
showsPrec :: Int -> IMPresence -> ShowS
$cshowsPrec :: Int -> IMPresence -> ShowS
Show, IMPresence -> IMPresence -> Bool
(IMPresence -> IMPresence -> Bool)
-> (IMPresence -> IMPresence -> Bool) -> Eq IMPresence
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IMPresence -> IMPresence -> Bool
$c/= :: IMPresence -> IMPresence -> Bool
== :: IMPresence -> IMPresence -> Bool
$c== :: IMPresence -> IMPresence -> Bool
Eq)
imPresence :: IMPresence
imPresence :: IMPresence
imPresence = IMP :: Maybe ShowStatus -> Maybe Text -> Maybe Int -> IMPresence
IMP { showStatus :: Maybe ShowStatus
showStatus = Maybe ShowStatus
forall a. Maybe a
Nothing
, status :: Maybe Text
status = Maybe Text
forall a. Maybe a
Nothing
, priority :: Maybe Int
priority = Maybe Int
forall a. Maybe a
Nothing
}
instance Default IMPresence where
def :: IMPresence
def = IMPresence
imPresence
getIMPresence :: Presence -> Maybe IMPresence
getIMPresence :: Presence -> Maybe IMPresence
getIMPresence Presence
pres = case PU [Element] IMPresence
-> [Element] -> Either UnpickleError IMPresence
forall t a. PU t a -> t -> Either UnpickleError a
unpickle PU [Element] IMPresence
xpIMPresence (Presence -> [Element]
presencePayload Presence
pres) of
Left UnpickleError
_ -> Maybe IMPresence
forall a. Maybe a
Nothing
Right IMPresence
r -> IMPresence -> Maybe IMPresence
forall a. a -> Maybe a
Just IMPresence
r
withIMPresence :: IMPresence -> Presence -> Presence
withIMPresence :: IMPresence -> Presence -> Presence
withIMPresence IMPresence
imPres Presence
pres = Presence
pres{presencePayload :: [Element]
presencePayload = Presence -> [Element]
presencePayload Presence
pres
[Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ PU [Element] IMPresence -> IMPresence -> [Element]
forall t a. PU t a -> a -> t
pickleTree PU [Element] IMPresence
xpIMPresence
IMPresence
imPres}
xpIMPresence :: PU [Element] IMPresence
xpIMPresence :: PU [Element] IMPresence
xpIMPresence = PU [Node] IMPresence -> PU [Element] IMPresence
forall a. PU [Node] a -> PU [Element] a
xpUnliftElems (PU [Node] IMPresence -> PU [Element] IMPresence)
-> (PU [Node] (Maybe ShowStatus, Maybe Text, Maybe Int)
-> PU [Node] IMPresence)
-> PU [Node] (Maybe ShowStatus, Maybe Text, Maybe Int)
-> PU [Element] IMPresence
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
((Maybe ShowStatus, Maybe Text, Maybe Int) -> IMPresence)
-> (IMPresence -> (Maybe ShowStatus, Maybe Text, Maybe Int))
-> PU [Node] (Maybe ShowStatus, Maybe Text, Maybe Int)
-> PU [Node] IMPresence
forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap (\(Maybe ShowStatus
s, Maybe Text
st, Maybe Int
p) -> Maybe ShowStatus -> Maybe Text -> Maybe Int -> IMPresence
IMP Maybe ShowStatus
s Maybe Text
st Maybe Int
p)
(\(IMP Maybe ShowStatus
s Maybe Text
st Maybe Int
p) -> (Maybe ShowStatus
s, Maybe Text
st, Maybe Int
p)) (PU [Node] (Maybe ShowStatus, Maybe Text, Maybe Int)
-> PU [Node] IMPresence)
-> (PU [Node] (Maybe ShowStatus, Maybe Text, Maybe Int)
-> PU [Node] (Maybe ShowStatus, Maybe Text, Maybe Int))
-> PU [Node] (Maybe ShowStatus, Maybe Text, Maybe Int)
-> PU [Node] IMPresence
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
PU [Node] (Maybe ShowStatus, Maybe Text, Maybe Int)
-> PU [Node] (Maybe ShowStatus, Maybe Text, Maybe Int)
forall t a. PU t a -> PU t a
xpClean (PU [Node] (Maybe ShowStatus, Maybe Text, Maybe Int)
-> PU [Element] IMPresence)
-> PU [Node] (Maybe ShowStatus, Maybe Text, Maybe Int)
-> PU [Element] IMPresence
forall a b. (a -> b) -> a -> b
$
PU [Node] (Maybe ShowStatus)
-> PU [Node] (Maybe Text)
-> PU [Node] (Maybe Int)
-> PU [Node] (Maybe ShowStatus, Maybe Text, Maybe Int)
forall a a1 a2 a3.
PU [a] a1 -> PU [a] a2 -> PU [a] a3 -> PU [a] (a1, a2, a3)
xp3Tuple
(PU [Node] ShowStatus -> PU [Node] (Maybe ShowStatus)
forall t a. PU [t] a -> PU [t] (Maybe a)
xpOption (PU [Node] ShowStatus -> PU [Node] (Maybe ShowStatus))
-> PU [Node] ShowStatus -> PU [Node] (Maybe ShowStatus)
forall a b. (a -> b) -> a -> b
$ Name -> PU [Node] ShowStatus -> PU [Node] ShowStatus
forall b. Name -> PU [Node] b -> PU [Node] b
xpElemNodes Name
"{jabber:client}show"
(PU Text ShowStatus -> PU [Node] ShowStatus
forall a. PU Text a -> PU [Node] a
xpContent PU Text ShowStatus
xpShow))
(PU [Node] Text -> PU [Node] (Maybe Text)
forall t a. PU [t] a -> PU [t] (Maybe a)
xpOption (PU [Node] Text -> PU [Node] (Maybe Text))
-> PU [Node] Text -> PU [Node] (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Name -> PU [Node] Text -> PU [Node] Text
forall b. Name -> PU [Node] b -> PU [Node] b
xpElemNodes Name
"{jabber:client}status"
(PU Text Text -> PU [Node] Text
forall a. PU Text a -> PU [Node] a
xpContent PU Text Text
xpText))
(PU [Node] Int -> PU [Node] (Maybe Int)
forall t a. PU [t] a -> PU [t] (Maybe a)
xpOption (PU [Node] Int -> PU [Node] (Maybe Int))
-> PU [Node] Int -> PU [Node] (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Name -> PU [Node] Int -> PU [Node] Int
forall b. Name -> PU [Node] b -> PU [Node] b
xpElemNodes Name
"{jabber:client}priority"
(PU Text Int -> PU [Node] Int
forall a. PU Text a -> PU [Node] a
xpContent PU Text Int
forall a. (Show a, Read a) => PU Text a
xpPrim))
xpShow :: PU Text ShowStatus
xpShow :: PU Text ShowStatus
xpShow = (Text
"xpShow", Text
"") (Text, Text) -> PU Text ShowStatus -> PU Text ShowStatus
forall t a. (Text, Text) -> PU t a -> PU t a
<?>
(Text -> Either Text ShowStatus)
-> (ShowStatus -> Text) -> PU Text ShowStatus
forall a b. (a -> Either Text b) -> (b -> a) -> PU a b
xpPartial ( \Text
input -> case Text -> Maybe ShowStatus
forall a. (Eq a, IsString a) => a -> Maybe ShowStatus
showStatusFromText Text
input of
Maybe ShowStatus
Nothing -> Text -> Either Text ShowStatus
forall a b. a -> Either a b
Left Text
"Could not parse show status."
Just ShowStatus
j -> ShowStatus -> Either Text ShowStatus
forall a b. b -> Either a b
Right ShowStatus
j)
ShowStatus -> Text
forall p. IsString p => ShowStatus -> p
showStatusToText
where
showStatusFromText :: a -> Maybe ShowStatus
showStatusFromText a
"away" = ShowStatus -> Maybe ShowStatus
forall a. a -> Maybe a
Just ShowStatus
StatusAway
showStatusFromText a
"chat" = ShowStatus -> Maybe ShowStatus
forall a. a -> Maybe a
Just ShowStatus
StatusChat
showStatusFromText a
"dnd" = ShowStatus -> Maybe ShowStatus
forall a. a -> Maybe a
Just ShowStatus
StatusDnd
showStatusFromText a
"xa" = ShowStatus -> Maybe ShowStatus
forall a. a -> Maybe a
Just ShowStatus
StatusXa
showStatusFromText a
_ = Maybe ShowStatus
forall a. Maybe a
Nothing
showStatusToText :: ShowStatus -> p
showStatusToText ShowStatus
StatusAway = p
"away"
showStatusToText ShowStatus
StatusChat = p
"chat"
showStatusToText ShowStatus
StatusDnd = p
"dnd"
showStatusToText ShowStatus
StatusXa = p
"xa"