{- 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 . -} -- | Module: $Header$ -- Description: XPMN device implementing the Pontarius Directory profile -- Copyright: Copyright © 2010-2011 Jon Kristensen -- License: AGPL-3 -- -- Maintainer: info@pontarius.org -- Stability: unstable -- Portability: portable module Media.XPMN.Server.DirectoryDevice (start) where import Network.XMPP import Network.XMPP.Utilities -- TODO import qualified Media.XPMN.DeviceServer as MXD import Media.XPMN.Server.Object import qualified Media.XPMN.Server.ObjectServer as MXSO import qualified Media.XPMN.Server.Object as MXSO_ import Media.XPMN.Server.ObjectServer hiding (start) import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) import Data.Maybe import Data.XML.Types import qualified Data.Text as DT import System.Random import qualified Data.Map as DM data State = State { deviceServer :: MXD.DeviceServer , objectServerWrite :: (ObjectServerInEvent -> IO ()) , stateQueries :: [MXD.Query ObjectServerOutEvent] } data InternalEvent = IED MXD.DeviceInEvent | IEO ObjectServerOutEvent deriving (Show) -- instance XMLable ObjectServerOutEvent where -- toXML Ping = [NodeElement (Element (Name (DT.pack "ping") Nothing Nothing) (DM.fromList []) [])] -- fromXML [NodeElement (Element { elementName = n })] | nameLocalName n == DT.pack "ping" = Ping start h u s po r pa osw osr = do deviceServer <- MXD.start s po u pa r [] ["..."] -- TODO c <- newChan putStrLn $ "?????????????????" forkIO $ readObjectStuff osr c forkIO $ readXMPPStuff (MXD.inEvents deviceServer) c forkIO $ loop (State { deviceServer = deviceServer , objectServerWrite = osw , stateQueries = [] }) c return () where loop :: State -> Chan InternalEvent -> IO () loop s c = do putStrLn $ "!!!!!!!!!!!!!!!!!" e <- readChan c putStrLn $ "DirectoryDevice: Got Event: " ++ (show e) s' <- processEvent s e loop s' c processEvent :: State -> InternalEvent -> IO State processEvent s (IED MXD.DIEOnline) = do putStrLn "We are online!" return s -- TODO: There is an architectural problem with Pontarius XMPP, Pontarius -- XPMN and the ObjectServer that prohibits us to have a proper system for -- message passing, replying to messages and ID's. We need to look this -- over soon. -- TODO: -- processEvent s (IED (MXD.DIEQuery j "even-numbers" _)) = do -- let que = query j even :: Query Integer -- return s { stateQueries = que:(stateQueries s) } -- TODO: Add (optional) metadata processEvent s (IED (MXD.DIEIQ (IQSet { iqSetPayload = p }))) | (nameLocalName $ elementName p) == DT.pack "add-container" = do putStrLn $ "Got request to add a container." objectServerWrite s $ MXSO.OSIEPersistObject (MXSO_.container Nothing Nothing) return s -- TODO: Add size, hash and (optional) metadata processEvent s (IED (MXD.DIEIQ (IQSet { iqSetPayload = p }))) | (nameLocalName $ elementName p) == DT.pack "add-item" = do putStrLn $ "Got request to add an item." objectServerWrite s $ MXSO.OSIEPersistObject (MXSO_.item Nothing Nothing Nothing Nothing) return s -- TODO: Add object ID and (optional) metadata processEvent s (IED (MXD.DIEIQ (IQSet { iqSetPayload = p }))) | (nameLocalName $ elementName p) == DT.pack "modify-object" = do putStrLn $ "Got request to modify an object." objectServerWrite s $ MXSO.OSIEUpdateObject (MXSO_.item Nothing Nothing Nothing Nothing) return s -- TODO: Add object ID processEvent s (IED (MXD.DIEIQ (IQSet { iqSetPayload = p }))) | (nameLocalName $ elementName p) == DT.pack "delete-object" = do putStrLn $ "Got request to delete an object." -- TODO: Delete using the object server return s processEvent s (IED (MXD.DIEIQ i)) = do putStrLn $ "Got an IQ that was not processed by DeviceServer or us: " ++ (show i) return s processEvent s (IEO x) = do putStrLn $ show x return s -- q' <- mapM (\ q -> (queryRetract (deviceServer s)) q idToRemove) (stateQueries s) -- q'' <- mapM (\ q -> (queryPublish (deviceServer s)) q idToAdd number) (stateQueries s) -- return s { pingpongVar = s', stateStd = stdGen', stateQueries = q'' } -- IO ObjectServerOutEvent readObjectStuff c c' = do e <- c writeChan c' (IEO e) readObjectStuff c c' readXMPPStuff c c' = do e <- readChan c writeChan c' (IED e) readXMPPStuff c c'