pontarius-mediaserver-0.0.1.0: Media/XPMN/PontariusMediaServer/XPMNDeviceServer.hs
-- | Module: $Header$
-- Description: An abstraction layer between Pontarius XMPP and the logic of
-- XPMN services
-- Copyright: Copyright © 2010-2011 Jon Kristensen
-- License: BSD-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; they all need to manage their
-- (XMPP) connection, manage subscription requests and deal with the XPMN
-- event system (such as executing commands and getting and setting
-- variables). This module serves as a helping abstraction layer for doing
-- these things, exposing as few underlying details as possible.
--
-- Interaction with this module is mostly event-based. The client works with
-- two channels, one dealing with DeviceInEvents (received events that are
-- either generated by an external source or by this module), and another
-- dealing with DeviceOutEvents (outgoing events, generated by the client).
-- The client acquires these channels by using the 'start' function.
-- Internally, this module also uses two channels in its interaction with
-- Pontarius XMPP. The principle there is the same.
-- Re-exports: JID
module Media.XPMN.PontariusMediaServer.XPMNDeviceServer ( ServiceEvent (..)
, DeviceInEvent (..)
, DeviceOutEvent (..)
, DeviceServer (..)
, action
, actionResponse
, simpleVariableGet
, simpleVariableGetResponse
, simpleVariableSet
, simpleVariableSetResponse
, complexVariableExtend
, complexVariableExtendResponse
, complexVariableRetract
, complexVariableRetractResponse
, start
-- Re-exported from
-- Pontarius XMPP:
, JID ) where
import Network.XMPP.PontariusXMPP
import Data.XML.Types
import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
import Control.Concurrent (forkIO)
import qualified Data.Map as DM
import qualified Data.Text as DT
import Data.Maybe
import Data.String
import Data.List (elem, delete)
data DeviceServer = DeviceServer { inEvents :: Chan DeviceInEvent
, outEvents :: Chan DeviceOutEvent
, modifySimpleVar :: SimpleVariable -> Element -> IO SimpleVariable }
data SimpleVariable = SimpleVariable String Element [JID]
simpleVariable :: String -> Element -> [JID] -> SimpleVariable
simpleVariable n e s = SimpleVariable n e s
modifySimpleVariable :: Chan ClientOutEvent -> SimpleVariable -> Element -> IO SimpleVariable
modifySimpleVariable c (SimpleVariable n _ s) e = do
notifySimple v
return v
where
v = SimpleVariable n e s
notifySimple :: SimpleVariable -> IO ()
notifySimple (SimpleVariable n e []) = return ()
notifySimple (SimpleVariable n e (s:ss)) = do
-- writeChan c [event notification]
notifySimple $ SimpleVariable n e ss
subscribeToSimpleVariable :: Chan ClientOutEvent -> SimpleVariable -> JID -> IO SimpleVariable
subscribeToSimpleVariable c (SimpleVariable n e s) s_
| s_ `elem` s = return (SimpleVariable n e s)
| otherwise = do
notifySimple (SimpleVariable n e [s_]) -- TODO
return $ SimpleVariable n e (s_:s)
unsubscribeToSimpleVariable :: Chan ClientOutEvent -> SimpleVariable -> JID -> IO SimpleVariable
unsubscribeToSimpleVariable c (SimpleVariable n e s) s_
| s_ `elem` s = do
let s' = delete s_ s
return (SimpleVariable n e s')
| otherwise = return $ SimpleVariable n e s
data Identity = Identity { identityCategory :: String
, identityType :: String
, identityName :: Maybe String }
-- TODO: Validate
identity c t n = Identity { identityCategory = c
, identityType = t
, identityName = n }
-- TODO: Validate feature string
-- [String] is the list of the features
start :: [String] -> String -> Integer -> JID -> String ->
IO DeviceServer
start f s po j pa =
do (pxo, pxi) <- connect s po j pa
writeChan pxo $ presenceEvent DoNotDisturb (presenceStatus "Pontarius Media Server 0.1 Alpha 1")
forkIO $ loop pxi pxo
die <- newChan
doe <- newChan
forkIO $ loop' doe
return DeviceServer { inEvents = die --
, outEvents = doe --
, modifySimpleVar = modifySimpleVariable pxo } --
where
loop :: Chan ClientInEvent -> Chan ClientOutEvent -> IO ()
loop c c_ = do e <- readChan c
processEvent e c_ f
loop c c_
loop' :: Chan DeviceOutEvent -> IO ()
loop' c = do e <- readChan c
putStrLn $ "XPMNDeviceServer: Got Device Out Event: " ++ (show e)
loop' c
processEvent :: ClientInEvent -> Chan ClientOutEvent -> [String] -> IO ()
processEvent (CIEPresence (_, Just jid, _, Just Subscribe, _)) c fea =
writeChan c $ createPresence (Just jid) (Just Subscribed) Nothing
processEvent (CIEIQGet (i, f, _, e)) c fea
| (nameNamespace $ elementName e) /= Nothing &&
(DT.unpack $ fromJust (nameNamespace $ elementName e)) ==
"http://jabber.org/protocol/disco#info" =
-- iqGetEvent :: Maybe StanzaID -> Maybe JID -> Element -> ClientOutEvent
writeChan c $ iqResultEvent (Just i) (fromJust f) (Just query)
| otherwise = putStrLn $ ">>>>>>>>>> " ++ (show e)
where
query :: Element
query = (Element { elementName = fromString "query"
, elementAttributes = DM.empty
, elementNodes = identities (snd $ features___ []) ++ features (fst $ features___ fea) })
where
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))
processEvent e c f = putStrLn $ show e
-- TODO: Later: Forward presence and node subscription requests to client.
-- TODO: Later: data NodeName = NN String
data Status = Status { statusValue :: String
, statusSubscribers :: [JID] }
type Statuses = DM.Map String Status -- TODO: Later: NodeName
type PubSubItems = DM.Map String Element
data PubSubNode = PubSubNode { pubSubNodeItems :: PubSubItems
, pubSubNodeSubscribers :: [JID] }
type PubSubNodes = DM.Map String PubSubNode -- TODO: Later: NodeName
-- 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)
action :: String -> JID -> Element -> ServiceEvent
action i j e = Action (i, j, e)
actionResponse :: String -> JID -> Element -> ServiceEvent
actionResponse i j e = ActionResponse (i, j, e)
simpleVariableGet :: String -> JID -> ServiceEvent
simpleVariableGet i j = SimpleVariableGet (i, j)
simpleVariableGetResponse :: String -> JID -> String -> ServiceEvent
simpleVariableGetResponse i j s = SimpleVariableGetResponse (i, j, s)
simpleVariableSet :: String -> JID -> String -> ServiceEvent
simpleVariableSet i j s = SimpleVariableSet (i, j, s)
simpleVariableSetResponse :: String -> JID -> Maybe String -> ServiceEvent
simpleVariableSetResponse i j s = SimpleVariableSetResponse (i, j, s)
complexVariableExtend :: String -> JID -> String -> Element -> ServiceEvent
complexVariableExtend i j s e = ComplexVariableExtend (i, j, s, e)
complexVariableExtendResponse :: String -> JID -> String -> Maybe Element -> ServiceEvent
complexVariableExtendResponse i j s e = ComplexVariableExtendResponse (i, j, s, e)
complexVariableRetract :: String -> JID -> String -> ServiceEvent
complexVariableRetract i j s = ComplexVariableRetract (i, j, s)
complexVariableRetractResponse :: String -> JID -> Maybe String -> ServiceEvent
complexVariableRetractResponse i j s = ComplexVariableRetractResponse (i, j, s)
data DeviceInEvent = DISE ServiceEvent deriving (Eq, Show)
data DeviceOutEvent = DOSE ServiceEvent deriving (Eq, Show)