{-# 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]
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
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
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
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
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 { showStatus :: Maybe ShowStatus
showStatus = forall a. Maybe a
Nothing
                 , status :: Maybe Text
status     = forall a. Maybe a
Nothing
                 , priority :: Maybe Int
priority   = forall a. Maybe a
Nothing
                 }

instance Default IMPresence where
    def :: IMPresence
def = IMPresence
imPresence

-- | Try to extract RFC6121 IM presence information from presence stanza.
-- Returns Nothing when the data is malformed, (Just IMPresence) otherwise.
getIMPresence :: Presence -> Maybe IMPresence
getIMPresence :: Presence -> Maybe IMPresence
getIMPresence Presence
pres = case forall t a. PU t a -> t -> Either UnpickleError a
unpickle PU [Element] IMPresence
xpIMPresence (Presence -> [Element]
presencePayload Presence
pres) of
    Left UnpickleError
_ -> forall a. Maybe a
Nothing
    Right IMPresence
r -> 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
                                                   forall a. [a] -> [a] -> [a]
++ forall t a. PU t a -> a -> t
pickleTree PU [Element] IMPresence
xpIMPresence
                                                                 IMPresence
imPres}

--
-- Picklers
--

xpIMPresence :: PU [Element] IMPresence
xpIMPresence :: PU [Element] IMPresence
xpIMPresence = forall a. PU [Node] a -> PU [Element] a
xpUnliftElems forall b c a. (b -> c) -> (a -> b) -> a -> c
.
               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)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
               forall t a. PU t a -> PU t a
xpClean forall a b. (a -> b) -> a -> b
$
               forall a a1 a2 a3.
PU [a] a1 -> PU [a] a2 -> PU [a] a3 -> PU [a] (a1, a2, a3)
xp3Tuple
                  (forall t a. PU [t] a -> PU [t] (Maybe a)
xpOption forall a b. (a -> b) -> a -> b
$ forall b. Name -> PU [Node] b -> PU [Node] b
xpElemNodes Name
"{jabber:client}show"
                     (forall a. PU Text a -> PU [Node] a
xpContent PU Text ShowStatus
xpShow))
                  -- TODO: Multiple status elements with different lang tags
                  (forall t a. PU [t] a -> PU [t] (Maybe a)
xpOption forall a b. (a -> b) -> a -> b
$ forall b. Name -> PU [Node] b -> PU [Node] b
xpElemNodes Name
"{jabber:client}status"
                     (forall a. PU Text a -> PU [Node] a
xpContent PU Text Text
xpText))
                  (forall t a. PU [t] a -> PU [t] (Maybe a)
xpOption forall a b. (a -> b) -> a -> b
$ forall b. Name -> PU [Node] b -> PU [Node] b
xpElemNodes Name
"{jabber:client}priority"
                     (forall a. PU Text a -> PU [Node] a
xpContent forall a. (Show a, Read a) => PU Text a
xpPrim))

xpShow :: PU Text ShowStatus
xpShow :: PU Text ShowStatus
xpShow = (Text
"xpShow", Text
"") forall t a. (Text, Text) -> PU t a -> PU t a
<?>
        forall a b. (a -> Either Text b) -> (b -> a) -> PU a b
xpPartial ( \Text
input -> case forall {a}. (Eq a, IsString a) => a -> Maybe ShowStatus
showStatusFromText Text
input of
                                   Maybe ShowStatus
Nothing -> forall a b. a -> Either a b
Left Text
"Could not parse show status."
                                   Just ShowStatus
j -> forall a b. b -> Either a b
Right ShowStatus
j)
                  forall {a}. IsString a => ShowStatus -> a
showStatusToText
  where
    showStatusFromText :: a -> Maybe ShowStatus
showStatusFromText a
"away" = forall a. a -> Maybe a
Just ShowStatus
StatusAway
    showStatusFromText a
"chat" = forall a. a -> Maybe a
Just ShowStatus
StatusChat
    showStatusFromText a
"dnd" = forall a. a -> Maybe a
Just ShowStatus
StatusDnd
    showStatusFromText a
"xa" = forall a. a -> Maybe a
Just ShowStatus
StatusXa
    showStatusFromText a
_ = forall a. Maybe a
Nothing
    showStatusToText :: ShowStatus -> a
showStatusToText ShowStatus
StatusAway = a
"away"
    showStatusToText ShowStatus
StatusChat = a
"chat"
    showStatusToText ShowStatus
StatusDnd = a
"dnd"
    showStatusToText ShowStatus
StatusXa = a
"xa"