{-# 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

-- | 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 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}

--
-- Picklers
--

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))
                  -- TODO: Multiple status elements with different lang tags
                  (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"