Browse Source
Move the functionality from Network.Xmpp.IM.Message and *.Presence to Network.Xmpp.Stanza since it is not specific to RFC 6121. Implement presence functionality of RFC 6121 Fix hslint errors and warningmaster
Philipp Balzarek
13 years ago
8 changed files with 268 additions and 240 deletions
@ -1,75 +1,66 @@ |
|||||||
{-# OPTIONS_HADDOCK hide #-} |
{-# OPTIONS_HADDOCK hide #-} |
||||||
|
{-# LANGUAGE OverloadedStrings #-} |
||||||
|
{-# LANGUAGE NoMonomorphismRestriction #-} |
||||||
|
|
||||||
module Network.Xmpp.IM.Presence where |
module Network.Xmpp.IM.Presence where |
||||||
|
|
||||||
|
import Data.Text (Text) |
||||||
|
import Data.XML.Pickle |
||||||
|
import Data.XML.Types |
||||||
import Network.Xmpp.Types |
import Network.Xmpp.Types |
||||||
|
|
||||||
-- | An empty presence. |
data ShowStatus = StatusAway |
||||||
presence :: Presence |
| StatusChat |
||||||
presence = Presence { presenceID = Nothing |
| StatusDnd |
||||||
, presenceFrom = Nothing |
| StatusXa |
||||||
, presenceTo = Nothing |
|
||||||
, presenceLangTag = Nothing |
|
||||||
, presenceType = Nothing |
|
||||||
, presencePayload = [] |
|
||||||
} |
|
||||||
|
|
||||||
-- | Request subscription with an entity. |
instance Show ShowStatus where |
||||||
presenceSubscribe :: Jid -> Presence |
show StatusAway = "away" |
||||||
presenceSubscribe to = presence { presenceTo = Just to |
show StatusChat = "chat" |
||||||
, presenceType = Just Subscribe |
show StatusDnd = "dnd" |
||||||
} |
show StatusXa = "xa" |
||||||
|
|
||||||
-- | Is presence a subscription request? |
instance Read ShowStatus where |
||||||
isPresenceSubscribe :: Presence -> Bool |
readsPrec _ "away" = [(StatusAway, "")] |
||||||
isPresenceSubscribe pres = presenceType pres == (Just Subscribe) |
readsPrec _ "chat" = [(StatusChat, "")] |
||||||
|
readsPrec _ "dnd" = [(StatusDnd , "")] |
||||||
|
readsPrec _ "xa" = [(StatusXa , "")] |
||||||
|
readsPrec _ _ = [] |
||||||
|
|
||||||
-- | Approve a subscripton of an entity. |
data IMPresence = IMP { showStatus :: Maybe ShowStatus |
||||||
presenceSubscribed :: Jid -> Presence |
, status :: Maybe Text |
||||||
presenceSubscribed to = presence { presenceTo = Just to |
, priority :: Maybe Int |
||||||
, presenceType = Just Subscribed |
|
||||||
} |
} |
||||||
|
|
||||||
-- | Is presence a subscription approval? |
imPresence :: IMPresence |
||||||
isPresenceSubscribed :: Presence -> Bool |
imPresence = IMP { showStatus = Nothing |
||||||
isPresenceSubscribed pres = presenceType pres == (Just Subscribed) |
, status = Nothing |
||||||
|
, priority = Nothing |
||||||
-- | End a subscription with an entity. |
|
||||||
presenceUnsubscribe :: Jid -> Presence |
|
||||||
presenceUnsubscribe to = presence { presenceTo = Just to |
|
||||||
, presenceType = Just Unsubscribed |
|
||||||
} |
} |
||||||
|
|
||||||
-- | Is presence an unsubscription request? |
|
||||||
isPresenceUnsubscribe :: Presence -> Bool |
|
||||||
isPresenceUnsubscribe pres = presenceType pres == (Just Unsubscribe) |
|
||||||
|
|
||||||
-- | Signal to the server that the client is available for communication. |
|
||||||
presenceOnline :: Presence |
|
||||||
presenceOnline = presence |
|
||||||
|
|
||||||
-- | Signal to the server that the client is no longer available for |
getIMPresence :: Presence -> Maybe IMPresence |
||||||
-- communication. |
getIMPresence pres = case unpickle xpIMPresence (presencePayload pres) of |
||||||
presenceOffline :: Presence |
Left _ -> Nothing |
||||||
presenceOffline = presence {presenceType = Just Unavailable} |
Right r -> Just r |
||||||
|
|
||||||
---- Change your status |
withIMPresence :: IMPresence -> Presence -> Presence |
||||||
--status |
withIMPresence imPres pres = pres{presencePayload = presencePayload pres |
||||||
-- :: Maybe Text -- ^ Status message |
++ pickleTree xpIMPresence |
||||||
-- -> Maybe ShowType -- ^ Status Type |
imPres} |
||||||
-- -> Maybe Int -- ^ Priority |
|
||||||
-- -> Presence |
|
||||||
--status txt showType prio = presence { presenceShowType = showType |
|
||||||
-- , presencePriority = prio |
|
||||||
-- , presenceStatus = txt |
|
||||||
-- } |
|
||||||
|
|
||||||
-- | Set the current availability status. This implicitly sets the client's |
-- |
||||||
-- status online. |
-- Picklers |
||||||
--presenceAvail :: ShowType -> Presence |
-- |
||||||
--presenceAvail showType = status Nothing (Just showType) Nothing |
|
||||||
|
|
||||||
-- | Set the current status message. This implicitly sets the client's status |
xpIMPresence :: PU [Element] IMPresence |
||||||
-- online. |
xpIMPresence = xpUnliftElems $ |
||||||
--presenceMessage :: Text -> Presence |
xpWrap (\(s, st, p) -> IMP s st p) |
||||||
--presenceMessage txt = status (Just txt) Nothing Nothing |
(\(IMP s st p) -> (s, st, p)) $ |
||||||
|
xp3Tuple |
||||||
|
(xpOption $ xpElemNodes "{jabber:client}show" |
||||||
|
(xpContent xpPrim)) |
||||||
|
(xpOption $ xpElemNodes "{jabber:client}status" |
||||||
|
(xpContent xpText)) |
||||||
|
(xpOption $ xpElemNodes "{jabber:client}priority" |
||||||
|
(xpContent xpPrim)) |
||||||
|
|||||||
@ -0,0 +1,76 @@ |
|||||||
|
{-# LANGUAGE RecordWildCards #-} |
||||||
|
|
||||||
|
{-# OPTIONS_HADDOCK hide #-} |
||||||
|
|
||||||
|
-- | Stanza related functions and constants |
||||||
|
-- |
||||||
|
|
||||||
|
module Network.Xmpp.Stanza where |
||||||
|
|
||||||
|
import Data.XML.Types |
||||||
|
import Network.Xmpp.Types |
||||||
|
|
||||||
|
|
||||||
|
-- | An empty message |
||||||
|
message :: Message |
||||||
|
message = Message { messageID = Nothing |
||||||
|
, messageFrom = Nothing |
||||||
|
, messageTo = Nothing |
||||||
|
, messageLangTag = Nothing |
||||||
|
, messageType = Normal |
||||||
|
, messagePayload = [] |
||||||
|
} |
||||||
|
|
||||||
|
-- | An empty presence. |
||||||
|
presence :: Presence |
||||||
|
presence = Presence { presenceID = Nothing |
||||||
|
, presenceFrom = Nothing |
||||||
|
, presenceTo = Nothing |
||||||
|
, presenceLangTag = Nothing |
||||||
|
, presenceType = Nothing |
||||||
|
, presencePayload = [] |
||||||
|
} |
||||||
|
|
||||||
|
-- | Request subscription with an entity. |
||||||
|
presenceSubscribe :: Jid -> Presence |
||||||
|
presenceSubscribe to = presence { presenceTo = Just to |
||||||
|
, presenceType = Just Subscribe |
||||||
|
} |
||||||
|
|
||||||
|
-- | Approve a subscripton of an entity. |
||||||
|
presenceSubscribed :: Jid -> Presence |
||||||
|
presenceSubscribed to = presence { presenceTo = Just to |
||||||
|
, presenceType = Just Subscribed |
||||||
|
} |
||||||
|
|
||||||
|
-- | End a subscription with an entity. |
||||||
|
presenceUnsubscribe :: Jid -> Presence |
||||||
|
presenceUnsubscribe to = presence { presenceTo = Just to |
||||||
|
, presenceType = Just Unsubscribed |
||||||
|
} |
||||||
|
|
||||||
|
-- | Signal to the server that the client is available for communication. |
||||||
|
presenceOnline :: Presence |
||||||
|
presenceOnline = presence |
||||||
|
|
||||||
|
-- | Signal to the server that the client is no longer available for |
||||||
|
-- communication. |
||||||
|
presenceOffline :: Presence |
||||||
|
presenceOffline = presence {presenceType = Just Unavailable} |
||||||
|
|
||||||
|
-- | Produce an answer message with the given payload, switching the "from" and |
||||||
|
-- "to" attributes in the original message. Produces a 'Nothing' value of the |
||||||
|
-- provided message message has no from attribute. |
||||||
|
answerMessage :: Message -> [Element] -> Maybe Message |
||||||
|
answerMessage Message{messageFrom = Just frm, ..} payload = |
||||||
|
Just Message{ messageFrom = messageTo |
||||||
|
, messageID = Nothing |
||||||
|
, messageTo = Just frm |
||||||
|
, messagePayload = payload |
||||||
|
, .. |
||||||
|
} |
||||||
|
answerMessage _ _ = Nothing |
||||||
|
|
||||||
|
-- | Add a recipient to a presence notification. |
||||||
|
presTo :: Presence -> Jid -> Presence |
||||||
|
presTo pres to = pres{presenceTo = Just to} |
||||||
Loading…
Reference in new issue