-- | 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 (..) , 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 (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 start :: String -> Integer -> JID -> String -> -- IO (Chan DeviceInEvent, Chan DeviceOutEvent) IO DeviceServer -- start 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 (die, 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_ 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 -> IO () processEvent (CIEPresence (_, Just jid, _, Just Subscribe, _)) c = writeChan c $ createPresence (Just jid) (Just Subscribed) Nothing processEvent (CIEIQGet (i, f, _, e)) c | (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___) }) 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], [Identity]) features___ = (["http://jabber.org/protocol/disco#info"], [Identity { identityCategory = "xpmn" , identityType = "service" , identityName = Nothing }]) processEvent e c = 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 = 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)