Browse Source
Conflicts: source/Network/Xmpp/Concurrent.hs source/Network/Xmpp/IM/Roster.hs source/Network/Xmpp/Types.hsmaster
Jon Kristensen
13 years ago
28 changed files with 925 additions and 914 deletions
@ -1,15 +1,28 @@
@@ -1,15 +1,28 @@
|
||||
-- | RFC 6121: Instant Messaging and Presence |
||||
-- |
||||
module Network.Xmpp.IM |
||||
( -- * Instant Messages |
||||
subject |
||||
, thread |
||||
, body |
||||
, bodies |
||||
, newIM |
||||
, simpleIM |
||||
, answerIM |
||||
MessageBody(..) |
||||
, MessageThread(..) |
||||
, MessageSubject(..) |
||||
, instantMessage |
||||
, getIM |
||||
, withIM |
||||
-- * Presence |
||||
, module Network.Xmpp.IM.Presence |
||||
, ShowStatus(..) |
||||
, IMPresence(..) |
||||
, imPresence |
||||
, getIMPresence |
||||
, withIMPresence |
||||
-- * Roster |
||||
, Roster(..) |
||||
, Item(..) |
||||
, getRoster |
||||
, rosterAdd |
||||
, rosterRemove |
||||
) where |
||||
|
||||
import Network.Xmpp.IM.Message |
||||
import Network.Xmpp.IM.Presence |
||||
import Network.Xmpp.IM.Roster |
||||
import Network.Xmpp.IM.Roster.Types |
||||
|
||||
@ -1,76 +1,67 @@
@@ -1,76 +1,67 @@
|
||||
{-# OPTIONS_HADDOCK hide #-} |
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
{-# LANGUAGE NoMonomorphismRestriction #-} |
||||
|
||||
module Network.Xmpp.IM.Presence where |
||||
|
||||
import Data.Text(Text) |
||||
import Data.Text (Text) |
||||
import Data.XML.Pickle |
||||
import Data.XML.Types |
||||
import Network.Xmpp.Types |
||||
|
||||
-- | An empty presence. |
||||
presence :: Presence |
||||
presence = Presence { presenceID = Nothing |
||||
, presenceFrom = Nothing |
||||
, presenceTo = Nothing |
||||
, presenceLangTag = Nothing |
||||
, presenceType = Nothing |
||||
, presencePayload = [] |
||||
} |
||||
data ShowStatus = StatusAway |
||||
| StatusChat |
||||
| StatusDnd |
||||
| StatusXa |
||||
|
||||
-- | Request subscription with an entity. |
||||
presenceSubscribe :: Jid -> Presence |
||||
presenceSubscribe to = presence { presenceTo = Just to |
||||
, presenceType = Just Subscribe |
||||
} |
||||
instance Show ShowStatus where |
||||
show StatusAway = "away" |
||||
show StatusChat = "chat" |
||||
show StatusDnd = "dnd" |
||||
show StatusXa = "xa" |
||||
|
||||
-- | Is presence a subscription request? |
||||
isPresenceSubscribe :: Presence -> Bool |
||||
isPresenceSubscribe pres = presenceType pres == (Just Subscribe) |
||||
instance Read ShowStatus where |
||||
readsPrec _ "away" = [(StatusAway, "")] |
||||
readsPrec _ "chat" = [(StatusChat, "")] |
||||
readsPrec _ "dnd" = [(StatusDnd , "")] |
||||
readsPrec _ "xa" = [(StatusXa , "")] |
||||
readsPrec _ _ = [] |
||||
|
||||
-- | Approve a subscripton of an entity. |
||||
presenceSubscribed :: Jid -> Presence |
||||
presenceSubscribed to = presence { presenceTo = Just to |
||||
, presenceType = Just Subscribed |
||||
data IMPresence = IMP { showStatus :: Maybe ShowStatus |
||||
, status :: Maybe Text |
||||
, priority :: Maybe Int |
||||
} |
||||
|
||||
-- | Is presence a subscription approval? |
||||
isPresenceSubscribed :: Presence -> Bool |
||||
isPresenceSubscribed pres = presenceType pres == (Just Subscribed) |
||||
|
||||
-- | End a subscription with an entity. |
||||
presenceUnsubscribe :: Jid -> Presence |
||||
presenceUnsubscribe to = presence { presenceTo = Just to |
||||
, presenceType = Just Unsubscribed |
||||
imPresence :: IMPresence |
||||
imPresence = IMP { showStatus = Nothing |
||||
, status = Nothing |
||||
, priority = Nothing |
||||
} |
||||
|
||||
-- | 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 |
||||
-- communication. |
||||
presenceOffline :: Presence |
||||
presenceOffline = presence {presenceType = Just Unavailable} |
||||
getIMPresence :: Presence -> Maybe IMPresence |
||||
getIMPresence pres = case unpickle xpIMPresence (presencePayload pres) of |
||||
Left _ -> Nothing |
||||
Right r -> Just r |
||||
|
||||
---- Change your status |
||||
--status |
||||
-- :: Maybe Text -- ^ Status message |
||||
-- -> Maybe ShowType -- ^ Status Type |
||||
-- -> Maybe Int -- ^ Priority |
||||
-- -> Presence |
||||
--status txt showType prio = presence { presenceShowType = showType |
||||
-- , presencePriority = prio |
||||
-- , presenceStatus = txt |
||||
-- } |
||||
withIMPresence :: IMPresence -> Presence -> Presence |
||||
withIMPresence imPres pres = pres{presencePayload = presencePayload pres |
||||
++ pickleTree xpIMPresence |
||||
imPres} |
||||
|
||||
-- | Set the current availability status. This implicitly sets the client's |
||||
-- status online. |
||||
--presenceAvail :: ShowType -> Presence |
||||
--presenceAvail showType = status Nothing (Just showType) Nothing |
||||
-- |
||||
-- Picklers |
||||
-- |
||||
|
||||
-- | Set the current status message. This implicitly sets the client's status |
||||
-- online. |
||||
--presenceMessage :: Text -> Presence |
||||
--presenceMessage txt = status (Just txt) Nothing Nothing |
||||
xpIMPresence :: PU [Element] IMPresence |
||||
xpIMPresence = xpUnliftElems . |
||||
xpWrap (\(s, st, p) -> IMP s st p) |
||||
(\(IMP s st p) -> (s, st, p)) . |
||||
xpClean $ |
||||
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,47 @@
@@ -0,0 +1,47 @@
|
||||
module Network.Xmpp.IM.Roster.Types where |
||||
|
||||
import qualified Data.Map as Map |
||||
import Data.Text (Text) |
||||
import Network.Xmpp.Types |
||||
|
||||
data Subscription = None | To | From | Both | Remove deriving Eq |
||||
|
||||
instance Show Subscription where |
||||
show None = "none" |
||||
show To = "to" |
||||
show From = "from" |
||||
show Both = "both" |
||||
show Remove = "remove" |
||||
|
||||
instance Read Subscription where |
||||
readsPrec _ "none" = [(None ,"")] |
||||
readsPrec _ "to" = [(To ,"")] |
||||
readsPrec _ "from" = [(From ,"")] |
||||
readsPrec _ "both" = [(Both ,"")] |
||||
readsPrec _ "remove" = [(Remove ,"")] |
||||
readsPrec _ _ = [] |
||||
|
||||
data Roster = Roster { ver :: Maybe Text |
||||
, items :: Map.Map Jid Item } deriving Show |
||||
|
||||
|
||||
|
||||
data Item = Item { approved :: Bool |
||||
, ask :: Bool |
||||
, jid :: Jid |
||||
, name :: Maybe Text |
||||
, subscription :: Subscription |
||||
, groups :: [Text] |
||||
} deriving Show |
||||
|
||||
data QueryItem = QueryItem { qiApproved :: Maybe Bool |
||||
, qiAsk :: Bool |
||||
, qiJid :: Jid |
||||
, qiName :: Maybe Text |
||||
, qiSubscription :: Maybe Subscription |
||||
, qiGroups :: [Text] |
||||
} deriving Show |
||||
|
||||
data Query = Query { queryVer :: Maybe Text |
||||
, queryItems :: [QueryItem] |
||||
} deriving Show |
||||
@ -0,0 +1,76 @@
@@ -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