pontarius-xpmn-0.0.1.0: Media/XPMN/DeviceServer.hs
{-
Copyright © Jon Kristensen, 2010-2011.
This file is part of Pontarius Media Server.
Pontarius Media Server is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as published by the
Free Software Foundation, either version 3 of the License, or (at your option)
any later version.
Pontarius Media Server is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License along
with Pontarius Media Server. If not, see <http://www.gnu.org/licenses/>.
-}
-- | Module: $Header$
-- Description: An abstraction layer between Pontarius XMPP and the logic of
-- XPMN devices (controllers and/or services)
-- Copyright: Copyright © 2010-2011 Jon Kristensen
-- License: AGPL-3
--
-- Maintainer: info@pontarius.org
-- Stability: unstable
-- Portability: portable
-- | A logical entity (application) in an extended personal media network is
-- called an XPMN device. Such devices are service providers, controllers, or
-- both. These devices have a lot in common, such as the need for managing
-- their (XMPP) connections, variables, events, and queries. This module
-- serves as a helping abstraction layer for doing this, exposing as few
-- underlying (XMPP) details as possible.
--
-- Interaction with this module is mostly event-based. The client works with
-- two functions, one dealing with acquiring DeviceInEvents (received events
-- that are either generated by an (to the client/device) external source
-- (such as another client, the XMPP library or this module)), and another
-- dealing with the transmission of DeviceOutEvents (outgoing events,
-- generated by the client). An example of a DeviceInEvent would be a
-- notification that the device is on-line. A DeviceOutEvent could be a
-- request to set a simple variable in a foreign device. The client acquires
-- these two functions by using the 'start' function, which is the only
-- function that this module exports.
--
-- More documentation on how to use this module will be available by the time
-- Pontarius XPMN enters beta.
-- Internally, this module uses two channels in its interaction with Pontarius
-- XMPP. The principle here is the same; XMPPInEvents are events generated by
-- Pontarius XMPP and sent to the XMPP client (this module) and XMPPOutEvents
-- are events sent from this XMPP client to Pontarius XMPP.
{-# LANGUAGE PolymorphicComponents #-}
module Media.XPMN.DeviceServer ( ServiceEvent (..)
, ComplexVariable
, DeviceInEvent (..)
, DeviceOutEvent (..)
, DeviceServer (..)
, start
, SimpleVariable
-- , simpleVariable
, simpleVariableName
, simpleVariableValue
, complexVariable
, complexVariableValue
, query
, XMLable (toXML, fromXML)
, Query ) where
import Network.XMPP
import Network.XMPP.JID -- TODO
import Control.Concurrent (forkIO)
import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
import Data.List (elem, delete)
import Data.Maybe
import Data.String
import Data.XML.Types
import qualified Data.List as DL
import qualified Data.Map as DM
import qualified Data.Text as DT
-- | All XPMN variables deals with XML in terms of a list of XML nodes.
type VariableValue = [Node]
-- Undocumented types:
type VariableName = String -- TODO: Document rules, create protected variable.
-- type NodeName = String
type ItemID = String -- TODO: Document rules, create protected variable.
type Subscriber = JID
-- | An 'XMLable' is a type which can be converted from/to XML.
class XMLable a where
fromXML :: [Node] -> a
toXML :: a -> [Node]
-- | Example instance of the XMLable for an integer.
instance XMLable Integer where
toXML i = [NodeContent (ContentText (DT.pack (show i)))]
fromXML [NodeContent (ContentText t)] = read $ DT.unpack t
-- A pubsub node is basically just an ordered list of ItemIDs and arbitrary
-- objects, and a list of subscribers.
data PubsubNode a = PubsubNode VariableName [(ItemID, a)] [Subscriber]
deriving (Show)
-- | A simple XPMN variable is a variable which has only one value. Changing a
-- simple variable overrides its current value.
type SimpleVariable = PubsubNode
-- | A complex XPMN variable is a variable which has a list of values. You can
-- retract from and publish to a complex variable.
type ComplexVariable = PubsubNode
data Query a = Query (PubsubNode a) (a -> Bool)
data DeviceServer = DeviceServer { inEvents :: Chan DeviceInEvent
, outEvents :: Chan DeviceOutEvent
, createSimpleVar :: XMLable a =>
VariableName -> a ->
[Subscriber] -> IO (SimpleVariable a)
, modifySimpleVar :: XMLable a =>
SimpleVariable a -> a ->
IO (SimpleVariable a)
, subscribeSimpleVar :: XMLable a =>
SimpleVariable a ->
Subscriber ->
IO (SimpleVariable a)
, unsubscribeSimpleVar :: XMLable a =>
SimpleVariable a ->
Subscriber ->
SimpleVariable a
, publish :: XMLable a =>
ComplexVariable a ->
ItemID ->
a ->
IO (ComplexVariable a)
, retract :: XMLable a => ComplexVariable a ->
ItemID -> IO (ComplexVariable a)
, subscribeComplexVar :: XMLable a =>
ComplexVariable a ->
Subscriber ->
ComplexVariable a
, unsubscribeComplexVar :: XMLable a =>
ComplexVariable a ->
Subscriber ->
ComplexVariable a
, queryPublish :: XMLable a => Query a ->
ItemID -> a -> IO (Query a)
, queryRetract :: XMLable a => Query a -> ItemID ->
IO (Query a) }
data Identity = Identity { identityCategory :: String
, identityType :: String
, identityName :: Maybe String }
-- TODO: Validate feature string
data InternalEvent = IEX XMPPInEvent | IED DeviceOutEvent deriving (Eq, Show)
data State = State { stateServer :: String
, statePort :: Integer
, stateUserName :: String
, statePassword :: String
, stateResource :: String
, stateOurJID :: JID
, stateVariableNames :: [String]
, stateQueryNames :: [String] }
-- TODO: Later: Forward presence and node subscription requests to client.
data DeviceInEvent = DIEIncomingSimpleVariableGet From String |
DIEIncomingSimpleVariableSet To String [Node] |
DIEOnline |
DIEIQ IQ |
DIEPresence Presence |
DIESubscribe JID String |
DIEUnsubscribe JID String |
DIEQuery JID String [Node] |
DIEItems Subscriber String
deriving (Eq, Show)
data DeviceOutEvent = DOEOutgoingSimpleVariableGet From String |
DOEOutgoingSimpleVariableSet To String [Node] |
DOEOutgoingSimpleVariableResult To String [Node] |
DOEIQ IQ |
DOEPresence Presence |
DOEMessage Message |
DOESubscribed JID String
deriving (Eq, Show)
-- TODO: Later: First String should be something like StanzaID.
data ServiceEvent = AutoSubscriptionRequest (String, JID) | -- TODO: Only in
ManualSubscriptionRequest (String, JID) | -- TODO: Only in
Action (String, JID, Element) |
ActionResponse (String, JID, Element) |
SimpleVariableGet (String, JID) |
SimpleVariableGetResponse (String, JID, String) |
SimpleVariableSet (String, JID, String) |
SimpleVariableSetResponse (String, JID, Maybe String) |
-- IQ ID, _, Item ID, _
ComplexVariableExtend (String, JID, String, Element) |
ComplexVariableExtendResponse (String, JID, String, Maybe Element) |
ComplexVariableRetract (String, JID, String) |
ComplexVariableRetractResponse (String, JID, Maybe String) deriving (Eq, Show)
pubsubNodeName :: XMLable a => PubsubNode a -> VariableName
pubsubNodeName (PubsubNode n _ _) = n
pubsubNodeValue :: XMLable a => PubsubNode a -> [(ItemID, a)]
pubsubNodeValue (PubsubNode _ v _) = v
pubsubNodeSubscribers :: XMLable a => PubsubNode a -> [JID]
pubsubNodeSubscribers (PubsubNode _ _ s) = s
-- Unsubscribes a JID from a simple variable and notifies the subscriber.
unsubscribeFromPubsubNode :: XMLable a => PubsubNode a -> Subscriber -> PubsubNode a
unsubscribeFromPubsubNode p s
-- JID not subscribed
| not $ s `elem` subscribers = p
| otherwise = setPubsubNodeSubscribers p (delete s subscribers)
where
subscribers = pubsubNodeSubscribers p
-- | Create a simple variable with an initial set of subscribers and notify the
-- subscribers of the new value.
simpleVariable :: XMLable a => Chan XMPPOutEvent -> VariableName -> a ->
[Subscriber] -> IO (SimpleVariable a)
simpleVariable c n v s = do
let var = PubsubNode n [(n, v)] s
mapM_ (\ x -> writeChan c (XOEMessage (getSimpleMessage n (toXML v) x))) s
return var
simpleVariableName :: XMLable a => SimpleVariable a -> VariableName
simpleVariableName (PubsubNode n _ _) = n
simpleVariableValue :: XMLable a => SimpleVariable a -> a
simpleVariableValue (PubsubNode _ v _) = snd $ head v
simpleVariableSubscribers :: XMLable a => SimpleVariable a -> [Subscriber]
simpleVariableSubscribers (PubsubNode _ _ s) = s
-- | Modifies a simple variable and notifies the subscribers.
modifySimpleVariable :: XMLable a => Chan XMPPOutEvent -> SimpleVariable a -> a ->
IO (SimpleVariable a)
modifySimpleVariable c s v = do
mapM_ (\ x -> writeChan c (XOEMessage (getSimpleMessage name (toXML v) x))) subscribers
return $ PubsubNode name [(name, v)] subscribers
where
name = simpleVariableName s
subscribers = simpleVariableSubscribers s
-- No notifications.
setPubsubNodeSubscribers :: XMLable a => PubsubNode a -> [Subscriber] -> PubsubNode a
setPubsubNodeSubscribers (PubsubNode n v _) s = PubsubNode n v s
-- Subscribes a JID to a simple variable and notifies the subscriber.
subscribeToSimpleVariable :: XMLable a => Chan XMPPOutEvent ->
SimpleVariable a -> Subscriber ->
IO (SimpleVariable a)
subscribeToSimpleVariable c si su
-- JID already subscribed
| su `elem` simpleVariableSubscribers si = return si
| otherwise = do
writeChan c (XOEMessage (getSimpleMessage name (toXML value) su))
return $ setPubsubNodeSubscribers si (su:subscribers)
where
name = simpleVariableName si
value = simpleVariableValue si
subscribers = simpleVariableSubscribers si
-- Unsubscribes a JID from a simple variable and notifies the subscriber.
unsubscribeFromSimpleVariable :: XMLable a => SimpleVariable a -> Subscriber ->
SimpleVariable a
unsubscribeFromSimpleVariable si su
-- JID not subscribed
| not $ su `elem` simpleVariableSubscribers si = si
| otherwise = setPubsubNodeSubscribers si (delete su subscribers)
where
subscribers = simpleVariableSubscribers si
-- | A complex variable is a pubsub node which can only be published to
-- internally.
complexVariable :: XMLable a => VariableName -> [(ItemID, a)] -> [Subscriber] ->
ComplexVariable a
complexVariable n v s = PubsubNode n v s
complexVariableName :: XMLable a => ComplexVariable a -> VariableName
complexVariableName (PubsubNode n _ _) = n
complexVariableValue ::XMLable a => ComplexVariable a -> [(ItemID, a)]
complexVariableValue (PubsubNode _ v _) = v
complexVariableSubscribers :: XMLable a => ComplexVariable a -> [JID]
complexVariableSubscribers (PubsubNode _ _ s) = s
-- | Modifies a simple variable and notifies the subscribers.
-- TODO: Check if element of list.
publish_ :: XMLable a => Chan XMPPOutEvent -> ComplexVariable a -> ItemID -> a ->
IO (ComplexVariable a)
publish_ c (PubsubNode n v s) i v_ = do
mapM_ (\ x ->
writeChan c (XOEMessage (getComplexPublishMessage n i (toXML v_) x)))
s
return newvar
where
newvar = PubsubNode n ((i, v_):v) s
-- | Modifies a simple variable and notifies the subscribers.
retract_ :: XMLable a => Chan XMPPOutEvent -> ComplexVariable a -> ItemID -> IO (ComplexVariable a)
retract_ c (PubsubNode n v s) i = do
mapM_ (\ x -> writeChan c (XOEMessage (getComplexRetractMessage n i x))) s
return newvar
where
newvar = PubsubNode n v' s
-- v' is v without the retracted element
v' = DL.filter (\ x -> fst x /= i) v
-- Subscribes a JID to a complex variable.
subscribeToComplexVariable :: XMLable a => ComplexVariable a ->
Subscriber -> ComplexVariable a
subscribeToComplexVariable (PubsubNode n v s) s_
| s_ `elem` s = PubsubNode n v s
| otherwise = do
PubsubNode n v (s_:s)
-- Unsubscribes a JID from a complex variable.
unsubscribeFromComplexVariable :: XMLable a => ComplexVariable a ->
Subscriber -> ComplexVariable a
unsubscribeFromComplexVariable (PubsubNode n v s) s_
| s_ `elem` s = do
let s' = delete s_ s
PubsubNode n v s'
| otherwise = PubsubNode n v s
query :: XMLable a => Subscriber -> (a -> Bool) -> Query a
query s f = Query (PubsubNode "" [] [s]) f
queryPublish_ :: XMLable a => Chan XMPPOutEvent -> Query a -> ItemID -> a -> IO (Query a)
queryPublish_ c q i v = do
case (queryFilter q) v of
True -> do
pubsubNode <- publish_ c (queryPubsubNode q) i v
return $ Query pubsubNode (queryFilter q)
False ->
return q
queryRetract_ :: XMLable a => Chan XMPPOutEvent -> Query a -> ItemID -> IO (Query a)
queryRetract_ c q i = do
case DL.lookup i (pubsubNodeValue $ queryPubsubNode q) of
Just _ -> do
pubsubNode <- retract_ c (queryPubsubNode q) i
return $ Query pubsubNode (queryFilter q)
Nothing -> do
return q
queryPubsubNode (Query p _) = p
queryFilter (Query _ f) = f
-- TODO: Validate
identity c t n = Identity { identityCategory = c
, identityType = t
, identityName = n }
start :: String -> Integer -> String -> String -> String -> [String] ->
[String] -> IO DeviceServer
start s po u pa r v q = do
-- Create an XMPP session and request to connect
(xmppIn, xmppOut) <- createSession
writeChan xmppOut $ XOEConnect s po
-- Create the three additional channels that are needed; one internal for the
-- state loop of this module, and two dealing with the message passing between
-- this module and the device
internalChan <- newChan
deviceIn <- newChan
deviceOut <- newChan
-- Start three threads - one to listen for events from Pontarius XMPP, one for
-- events from the device and one for the state loop
forkIO $ xmppListener xmppIn internalChan
forkIO $ deviceListener deviceOut internalChan
forkIO $ stateLoop (State { stateServer = s
, statePort = po
, stateUserName = u
, statePassword = pa
, stateResource = r
, stateOurJID = jid (Just u) s (Just r)
, stateVariableNames = v
, stateQueryNames = q })
internalChan xmppOut deviceIn
return DeviceServer { inEvents = deviceIn
, outEvents = deviceOut
, createSimpleVar = simpleVariable xmppOut
, modifySimpleVar = modifySimpleVariable xmppOut
, subscribeSimpleVar = subscribeToSimpleVariable xmppOut
, unsubscribeSimpleVar = unsubscribeFromSimpleVariable
, publish = publish_ xmppOut
, retract = retract_ xmppOut
, subscribeComplexVar = subscribeToComplexVariable
, unsubscribeComplexVar = unsubscribeFromComplexVariable
, queryPublish = queryPublish_ xmppOut
, queryRetract = queryRetract_ xmppOut }
where
xmppListener :: Chan XMPPInEvent -> Chan InternalEvent -> IO ()
xmppListener c c_ = do e <- readChan c
writeChan c_ $ IEX e
xmppListener c c_
deviceListener :: Chan DeviceOutEvent -> Chan InternalEvent -> IO ()
deviceListener c c_ = do e <- readChan c
writeChan c_ $ IED e
deviceListener c c_
stateLoop :: State -> Chan InternalEvent -> Chan XMPPOutEvent ->
Chan DeviceInEvent -> IO ()
stateLoop s c c_ c__ = do
e <- readChan c
-- putStrLn $ "InternalEvent: " ++ (show e)
s' <- processEvent s e c_ c__
stateLoop s c c_ c__
-- Processes XMPP events from Pontarius XMPP
processEvent :: State -> InternalEvent -> Chan XMPPOutEvent ->
Chan DeviceInEvent -> IO State
processEvent s (IEX XIEConnectionSucceeded) c c_ = do
writeChan c $ XOEAuthenticate (stateUserName s) (statePassword s)
(stateResource s)
return s
processEvent s (IEX XIEAuthenticationSucceeded) c c_ = do
writeChan c_ DIEOnline
writeChan c $ XOEPresence $
presence Nothing Nothing Nothing Nothing Available []
return s
-- Query for service discovery when someone comes on-line
processEvent s (IEX (XIEPresence (Presence { presenceStanza = stanza
, presenceType = Available }))) c c_
| fromJust (stanzaFrom stanza) /= stateOurJID s = do
let jid = stanzaFrom stanza
writeChan c $ XOEIQ $ iqGet Nothing Nothing (stanzaFrom stanza) Nothing
(Element { elementName = Name { nameLocalName = DT.pack "query"
, nameNamespace = Just (DT.pack "http://jabber.org/protocol/disco#info")
, namePrefix = Nothing }
, elementAttributes = DM.fromList []
, elementNodes = [] })
return s
-- Auto-accept subscriptions when asked and ask for subscription
processEvent s (IEX (XIEPresence (Presence { presenceStanza = stanza
, presenceType = Subscribe }))) c c_ = do
let jid = stanzaFrom stanza
writeChan c $ XOEPresence $ presence Nothing Nothing jid Nothing
Subscribe []
writeChan c $ XOEPresence $ presence Nothing Nothing jid Nothing
Subscribed []
return s
-- Reply when service discovery is requested from us
processEvent s (IEX (XIEIQ (IQGet { iqGetStanza = stanza
, iqGetPayload = p }))) c c_
| (nameNamespace $ elementName p) ==
Just (DT.pack "http://jabber.org/protocol/disco#info") = do
let jid = stanzaFrom stanza
writeChan c $ XOEIQ $ iqResult Nothing Nothing jid Nothing
(Just discoInfoElement)
return s
-- Complex "items" query
processEvent s (IEX (XIEIQ (IQGet { iqGetStanza = stanza
, iqGetPayload = p }))) c c_
| (nameNamespace $ elementName p) == Just (DT.pack "http://jabber.org/protocol/pubsub") &&
(nameLocalName $ elementName p) == DT.pack "pubsub" &&
length (elementChildren p) > 0 &&
(nameLocalName $ elementName $ head (elementChildren p)) == DT.pack "items" = do
let fromJID = fromJust $ stanzaFrom stanza
let nodeName = DT.unpack $ fromJust $ attributeText
(fromString "node") (head (elementChildren p))
case nodeName `elem` stateVariableNames s of
True -> do
writeChan c_ $ DIEItems fromJID nodeName
return s
False -> do
putStrLn "Variable not offered by device (items)!"
return s
-- Simple variable get
processEvent s (IEX (XIEIQ (IQGet { iqGetStanza = stanza
, iqGetPayload = p }))) c c_
| (nameNamespace $ elementName p) == Just (DT.pack "urn:xmpp:xpmn:0") &&
(nameLocalName $ elementName p) == DT.pack "simple-variable" = do
let jid = fromJust $ stanzaFrom stanza
let name = DT.unpack $ fromJust $ attributeText (fromString "name") p
case name `elem` stateVariableNames s of
True -> do
putStrLn "Hmm..."
writeChan c_ $ DIEIncomingSimpleVariableGet jid name
return s
False -> do
putStrLn "Variable not offered by device (set)!"
return s
-- Simple variable set
processEvent s (IEX (XIEIQ (IQSet { iqSetStanza = stanza
, iqSetPayload = p }))) c c_
| (nameNamespace $ elementName p) == Just (DT.pack "urn:xmpp:xpmn:0") &&
(nameLocalName $ elementName p) == DT.pack "simple-variable" = do
let jid = fromJust $ stanzaFrom stanza
let name = DT.unpack $ fromJust $ attributeText (fromString "name") p
case name `elem` stateVariableNames s of
True -> do
putStrLn "Hmm2..."
writeChan c_ $ DIEIncomingSimpleVariableSet jid name (elementNodes p)
return s
False -> do
putStrLn "Variable not offered by device (set)!"
return s
-- Variable subscription - simple and complex
processEvent s (IEX (XIEIQ (IQSet { iqSetStanza = stanza
, iqSetPayload = p }))) c c_
| (nameNamespace $ elementName p) == Just (DT.pack "http://jabber.org/protocol/pubsub") &&
(nameLocalName $ elementName p) == DT.pack "pubsub" &&
length (elementChildren p) > 0 &&
(nameLocalName $ elementName $ head (elementChildren p)) == DT.pack "subscribe" = do
let fromJID = fromJust $ stanzaFrom stanza
let nodeName = DT.unpack $ fromJust $ attributeText
(fromString "node") (head (elementChildren p))
let subscribeJID = fromJust $ stringToJID $ DT.unpack $ fromJust $
attributeText (fromString "jid") (head (elementChildren p))
case nodeName `elem` stateVariableNames s of
True -> do
writeChan c_ $ DIESubscribe subscribeJID nodeName
return s
False -> do
putStrLn "Variable not offered by device (subscr)!"
return s
-- Variable unsubscription
processEvent s (IEX (XIEIQ (IQSet { iqSetStanza = stanza
, iqSetPayload = p }))) c c_
| (nameNamespace $ elementName p) == Just (DT.pack "http://jabber.org/protocol/pubsub") &&
(nameLocalName $ elementName p) == DT.pack "pubsub" &&
length (elementChildren p) > 0 &&
(nameLocalName $ elementName $ head (elementChildren p)) == DT.pack "unsubscribe" = do
let fromJID = fromJust $ stanzaFrom stanza
let nodeName = DT.unpack $ fromJust $ attributeText
(fromString "node") (head (elementChildren p))
let subscribeJID = fromJust $ stringToJID $ DT.unpack $ fromJust $
attributeText (fromString "jid") (head (elementChildren p))
case nodeName `elem` stateVariableNames s of
True -> do
writeChan c_ $ DIEUnsubscribe subscribeJID nodeName
return s
False -> do
putStrLn "Variable not offered by device (unsubscr)!"
return s
-- Query
processEvent s (IEX (XIEIQ (IQSet { iqSetStanza = stanza
, iqSetPayload = p }))) c c_
| (nameLocalName $ elementName p) == DT.pack "query" &&
(nameNamespace $ elementName p) /= Nothing &&
DT.unpack (fromJust (nameNamespace $ elementName p)) `elem` stateQueryNames s = do
let fromJID = fromJust $ stanzaFrom stanza
let nodeName = DT.unpack (fromJust $ nameNamespace $ elementName p)
let nodes = elementNodes p
writeChan c_ $ DIEQuery fromJID nodeName nodes
return s
-- Service discovery result, auto-subscribe user to relevant variables
-- TODO: Verify that auto-subscription is detected
processEvent s (IEX (XIEIQ (IQResult { iqResultStanza = stanza
, iqResultPayload = p }))) c c_
| p /= Nothing &&
(nameNamespace $ elementName $ fromJust p) ==
Just (DT.pack "http://jabber.org/protocol/disco#info") = do
let jid = fromJust $ stanzaFrom stanza
-- Get all features elements
let features = filter (\ x -> not $ null (isNamed (Name { nameLocalName = DT.pack "feature"
, nameNamespace = Just (DT.pack "http://jabber.org/protocol/disco#info")
, namePrefix = Nothing }) x)) (elementChildren $ fromJust p)
-- Features to strings
let features_ = map (\ x -> DT.unpack $ fromJust $ attributeText (fromString "var") x) features
-- For each string in variables, check if "[string]+notify" is part of features_
let autovars = filter (\ x -> x ++ "+notify" `elem` features_) (stateVariableNames s)
mapM_ (\ x -> writeChan c_ $ DIESubscribe jid x) autovars
return s
-- Other IQ, send it to device
processEvent s (IEX (XIEIQ iq)) c c_ = do
putStrLn "This is happening"
writeChan c_ $ DIEIQ iq
return s
-- Get an external simple variable
processEvent s (IED (DOEOutgoingSimpleVariableGet j n)) c c_ = do
writeChan c $ XOEIQ $ iqGet Nothing Nothing (Just j) Nothing
(Element { elementName = Name { nameLocalName = DT.pack "simple-variable"
, namePrefix = Nothing
, nameNamespace = Just (DT.pack "urn:xmpp:xpmn:0") }
, elementAttributes = DM.fromList [( Name { nameLocalName = DT.pack "variable"
, namePrefix = Nothing
, nameNamespace = Nothing }
, [ContentText (DT.pack n)])]
, elementNodes = [] })
return s
-- Set an external simple variable
processEvent s (IED (DOEOutgoingSimpleVariableSet j n v)) c c_ = do
writeChan c $ XOEIQ $ iqSet Nothing Nothing (Just j) Nothing
(Element { elementName = Name { nameLocalName = DT.pack "simple-variable"
, namePrefix = Nothing
, nameNamespace = Just (DT.pack "urn:xmpp:xpmn:0") }
, elementAttributes = DM.fromList [( Name { nameLocalName = DT.pack "variable"
, namePrefix = Nothing
, nameNamespace = Nothing }
, [ContentText (DT.pack n)])]
, elementNodes = v }) -- Only difference from above
return s
-- -- Set an external simple variable
-- processEvent s (IED (DOEOutgoingSimpleVariableResult j n v)) c c_ = do
-- writeChan c $ XOEIQ $ iqResult Nothing Nothing (Just j) Nothing
-- (Just (Element { elementName = Name { nameLocalName = DT.pack "simple-variable"
-- , namePrefix = Nothing
-- , nameNamespace = Just (DT.pack "urn:xmpp:xpmn:0") }
-- , elementAttributes = DM.fromList [( Name { nameLocalName = DT.pack "variable"
-- , namePrefix = Nothing
-- , nameNamespace = Nothing }
-- , [ContentText (DT.pack n)])]
-- , elementNodes = v })) -- Only difference from above
-- return s
-- Send a device-specific IQ
processEvent s (IED (DOEIQ i)) c c_ = do
writeChan c $ XOEIQ i
return s
processEvent s (IEX xmppEvent) c c_ = do
putStrLn $ "Uncaught XMPP Event: " ++ (show xmppEvent)
return s
processEvent s (IED deviceEvent) c c_ = do
putStrLn $ "Uncaught Device Event: " ++ (show deviceEvent)
return s
discoInfoElement :: Element
discoInfoElement = (Element { elementName = fromString "query"
, elementAttributes = DM.empty
, elementNodes = identities (snd $
features___ []) ++
features (fst $
features___ fea) })
identities :: [Identity] -> [Node]
identities [] = []
identities (i':is) = (NodeElement (Element { elementName = fromString "identity"
, elementAttributes = DM.fromList $ attrList i'
, elementNodes = [] })):(identities is)
attrList :: Identity -> [(Name, [Content])]
attrList i' = case identityName i' of
Just name -> [(fromString "category", [ContentText $ DT.pack $ identityCategory i']),
(fromString "type", [ContentText $ DT.pack $ identityType i']),
(fromString "name", [ContentText $ DT.pack $ name])]
Nothing -> [(fromString "category", [ContentText $ DT.pack $ identityCategory i']),
(fromString "type", [ContentText $ DT.pack $ identityType i'])]
features :: [String] -> [Node]
features [] = []
features (f:fs) = (NodeElement (Element { elementName = fromString "feature"
, elementAttributes = DM.fromList [(fromString "var", [ContentText $ DT.pack f])]
, elementNodes = [] })):(features fs)
-- TODO: Should be configured by the device client later
features___ :: [String] -> ([String], [Identity])
features___ f = case elem "http://jabber.org/protocol/disco#info" f of
False -> (("http://jabber.org/protocol/disco#info":features'___ f),
[Identity { identityCategory = "xpmn"
, identityType = "service"
, identityName = Nothing }]) -- TODO
True -> (features'___ f , [Identity { identityCategory = "xpmn"
, identityType = "service"
, identityName = Nothing }]) -- TODO
features'___ [] = []
features'___ (f:fs) = (f:(features'___ fs))
fea :: [String]
fea = ["pingpong+notify"]
getSimpleMessage :: VariableName -> VariableValue -> JID -> Message
getSimpleMessage n v s = message Nothing Nothing (Just s) Nothing Normal [event]
where
event :: Element
event = Element { elementName = Name { nameLocalName = DT.pack "event"
, nameNamespace = Just (DT.pack "http://jabber.org/protocol/pubsub#event")
, namePrefix = Nothing }
, elementAttributes = DM.fromList []
, elementNodes = [NodeElement items] }
items :: Element
items = Element { elementName = fromString "items"
, elementAttributes = DM.fromList [(fromString "node", [ContentText (DT.pack n)])]
, elementNodes = [NodeElement item] }
item :: Element
item = Element { elementName = fromString "item"
, elementAttributes = DM.fromList [(fromString "id", [ContentText (DT.pack n)])]
, elementNodes = v }
getComplexPublishMessage :: VariableName -> ItemID -> VariableValue ->
Subscriber -> Message
getComplexPublishMessage n i v s = message Nothing Nothing (Just s) Nothing
Normal [event]
where
event :: Element
event = Element { elementName = Name { nameLocalName = DT.pack "event"
, nameNamespace = Just (DT.pack "http://jabber.org/protocol/pubsub#event")
, namePrefix = Nothing }
, elementAttributes = DM.fromList []
, elementNodes = [NodeElement items] }
items :: Element
items = Element { elementName = fromString "items"
, elementAttributes = DM.fromList [(fromString "node", [ContentText (DT.pack n)])]
, elementNodes = [NodeElement item] }
item :: Element
item = Element { elementName = fromString "item"
, elementAttributes = DM.fromList [(fromString "id", [ContentText (DT.pack i)])]
, elementNodes = v }
getComplexRetractMessage :: VariableName -> ItemID -> Subscriber -> Message
getComplexRetractMessage n i s = message Nothing Nothing (Just s) Nothing Normal
[event]
where
event :: Element
event = Element { elementName = Name { nameLocalName = DT.pack "event"
, nameNamespace = Just (DT.pack "http://jabber.org/protocol/pubsub#event")
, namePrefix = Nothing }
, elementAttributes = DM.fromList []
, elementNodes = [NodeElement items] }
items :: Element
items = Element { elementName = fromString "items"
, elementAttributes = DM.fromList [(fromString "node", [ContentText (DT.pack n)])]
, elementNodes = [NodeElement retract] }
retract :: Element
retract = Element { elementName = fromString "retract"
, elementAttributes = DM.fromList [(fromString "id", [ContentText (DT.pack i)])]
, elementNodes = [] }