pontarius-mediaserver 0.0.1.0 → 0.0.2.0
raw patch · 12 files changed
+654/−785 lines, 12 filesdep +hloggerdep +pontarius-xpmndep −HLoggerdep ~pontarius-xmppbinary-added
Dependencies added: hlogger, pontarius-xpmn
Dependencies removed: HLogger
Dependency ranges changed: pontarius-xmpp
Files
- DeviceTest.hs +0/−38
- Directory.db binary
- Main.hs +48/−1
- Media/XPMN/PontariusMediaServer/Object.hs +0/−241
- Media/XPMN/PontariusMediaServer/XPMNDeviceServer.hs +0/−253
- Media/XPMN/PontariusMediaServer/XPMNDeviceServer.hs-darcs-backup0 +0/−245
- Media/XPMN/Server/DirectoryDevice.hs +146/−0
- Media/XPMN/Server/Object.hs +343/−0
- Media/XPMN/Server/ObjectServer.hs +107/−0
- README +1/−3
- install.sh +5/−0
- pontarius-mediaserver.cabal +4/−4
− DeviceTest.hs
@@ -1,38 +0,0 @@-import Network.XMPP.PontariusXMPP-import Media.XPMN.PontariusMediaServer.XPMNDeviceServer-import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)-import Data.XML.Types-import Data.String-import qualified Data.Map as DM-import Control.Concurrent (forkIO)--host = "test.pontarius.org"-user = "sprint1"-server = "test.pontarius.org"-port = 5222-resource = "pontarius"-password = ""--main :: IO ()-main =- do -- Connect the XMPP account- deviceServer <- start getFeatures host port- (jid (Just user) server (Just resource)) password- - -- writeChan co $ action "id0123456789" (jid (Just "admin")- -- "test.pontarius.org"- -- (Just "resource"))- -- Element { elementName = fromString "test"- -- , elementAttributes = DM.empty- -- , elementNodes = [] }- forkIO $ loop $ inEvents deviceServer- return ()- where- loop :: Chan DeviceInEvent -> IO ()- loop c =- do e <- readChan c- putStrLn $ "DeviceTest: Got DeviceInEvent." ++ (show e)- loop c--getFeatures :: [String]-getFeatures = []
+ Directory.db view
binary file changed (absent → 4096 bytes)
Main.hs view
@@ -1,2 +1,49 @@+{-++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/>.++-}+++import Media.XPMN.Server.DirectoryDevice+import qualified Media.XPMN.Server.ObjectServer as MSXO+import qualified Media.XPMN.Server.Object as MSXO_+++host = "test.pontarius.org"+user = "sprint1"+server = "test.pontarius.org"+port = 5222+resource = "pontarius"+password = ""++ main :: IO ()-main = putStrLn "Pontarius Media Server"+main = do+ (osw, osr) <- MSXO.start "Directory"+ start host user server port resource password osw osr+ -- osw $ MSXO.OSIEPersistObject (MSXO_.container Nothing Nothing)+ -- osw $ MSXO.OSIEPersistObject (MSXO_.item Nothing Nothing Nothing Nothing)+ -- osw $ MSXO.OSIEUpdateObject "82c2cae1-b7b4-248e-ede6-9792419a1576" (MSXO_.item Nothing Nothing Nothing Nothing)+ -- osw $ MSXO.OSIEGetObject "82c2cae1-b7b4-248e-ede6-9792419a1576"+ -- osw $ MSXO.OSIEGetRoot+ -- osw $ MSXO.OSIEGetChildren "82c2cae1-b7b4-248e-ede6-9792419a1576"+ + -- TODO: Allow the user to press Enter to exit.+ + return ()
− Media/XPMN/PontariusMediaServer/Object.hs
@@ -1,241 +0,0 @@--- | Module: $Header$--- Description: Utilities for managing media objects--- Copyright: Copyright © 2010-2011 Jon Kristensen--- License: BSD-3--- --- Maintainer: info@pontarius.org--- Stability: unstable--- Portability: portable--- --- An 'Object' is either an 'Item' or a 'Container'. 'Item's and 'Container's--- both have 'ObjectAttributes'. 'Additionally, Item's have 'ItemAttributes'.--- --- A 'PersistedObject' represents an 'Object' which has been stored in the--- database (thus having an identifier and perhaps also a parent). This--- identifier cannot be changed.---- Parts of this module are not very thoroughly done as we are considering--- moving to HaskellDB.---- Example for specific meta-data (log table not tested):------ run c "CREATE TABLE metadata_1 (id INTEGER PRIMARY KEY NOT NULL, object_i" ++--- "d INTEGER NOT NULL, dummy_value INTEGER, FOREIGN KEY(object_id) RE" ++--- "FERENCES objects(id))" [] -- x in metadata_x is the types value--- run c "CREATE TABLE metadata_1_log (id INTEGER PRIMARY KEY NOT NULL, meta" ++--- "data_id INTEGER NOT NULL, object_id TEXT NOT NULL, dummy_value INT" ++--- "EGER, FOREIGN KEY(object_id) REFERENCES objects(id), FOREIGN KEY(m" ++--- "etadata_id) REFERENCES metadata_1(id))" []--module Media.XPMN.PonariusMediaServer.Object ( connectToDatabase- , initializeDatabase- , objectID- , parentID- , object- , container- , item- , persist- , update- , getRoot- , getChildren- , getObject- , insertDummyData -- TODO: Remove- ) where--import Database.HDBC-import Database.HDBC.Sqlite3--import Data.XML.Types----- An object cannot have its objectID modified.--- TODO: Add date and time information?--type ObjectID = String -- TODO: Use UUID--data Object = Item { itemObjectAttributes :: ObjectAttributes- , itemAttributes :: ItemAttributes } |- Container ObjectAttributes--data ObjectAttributes = ObjectAttributes { objectType :: Maybe Integer- , objectExtraMetadata :: Maybe Element }--data ItemAttributes = ItemAttributes { objectHash :: Maybe String -- TODO- , objectSize :: Maybe Integer }--data PersistedObject = PO (ObjectID, Maybe ObjectID, Object)----- | Connects to the local database (the provided string appended by ".db).--connectToDatabase :: String -> IO Connection-connectToDatabase s = connectSqlite3 (s ++ ".db")---disconnectFromDatabase :: IConnection c => c -> IO ()-disconnectFromDatabase l = disconnect l----- | Creates the necessary tables.---- TODO: Use withTransaction?--initializeDatabase :: IConnection conn => conn -> IO ()--initializeDatabase c = do- -- Create the object data and log table- run c "CREATE TABLE objects (id TEXT PRIMARY KEY NOT NULL, parent_id TEXT, type INTEGER, extra_metadata TEXT, is_container INTEGER NOT NULL, hash TEXT, size INTEGER, CHECK ((is_container = 0 and hash = NULL and size = NULL) or (is_container != 0 and hash != NULL and size != NULL)))" []- run c "CREATE TABLE objects_log (id INTEGER PRIMARY KEY NOT NULL, object_id TEXT NOT NULL, parent_id TEXT, type INTEGER, extra_metadata TEXT, is_container INTEGER NOT NULL, hash TEXT, size INTEGER, FOREIGN KEY(object_id) REFERENCES objects(id), CHECK ((is_container = 0 and hash = NULL and size = NULL) or (is_container != 0 and hash != NULL and size != NULL)))" []- - commit c- - return ()----- | Returns the 'ObjectID' of a 'PersistedObject'.--objectID :: PersistedObject -> ObjectID-objectID (PO (i, _, _)) = i----- | Returns the potential 'ObjectID' of the parent of a 'PersistedObject'.--parentID :: PersistedObject -> Maybe ObjectID-parentID (PO (_, p, _)) = p----- | Returns the 'Object' of a 'PersistedObject'.--object :: PersistedObject -> Object-object (PO (_, _, o)) = o----- | Creates a 'Container' 'Object'.--container :: Maybe Integer -> Maybe Element -> Object-container t m = Container $ ObjectAttributes { objectType = t- , objectExtraMetadata = m }----- | Creates a 'Item' 'Object'.--item :: Maybe Integer -> Maybe Element -> Maybe String -> Maybe Integer -> Object-item t m h s = Item { itemObjectAttributes = ObjectAttributes { objectType = t- , objectExtraMetadata = m }- , itemAttributes = ItemAttributes { objectHash = h- , objectSize = s } }----- | Persists an object (with or without a parent) in the database.--persist :: (IConnection c) => c -> Object -> Maybe ObjectID -> IO PersistedObject--persist c (Item { itemObjectAttributes = oa, itemAttributes = ia }) i =- do let hash' = case objectHash ia of -- TODO: itemHash in record...- Just x -> toSql x- Nothing -> SqlNull- size' = case objectSize ia of- Just x -> toSql x- Nothing -> SqlNull- run c "INSERT INTO objects (id, parent_id, type, extra_metadata, is_container, hash, size) VALUES (?, ?, ?, ?, ?, ?, ?)" [toSql id, parent_id', type', extra', toSql "0", hash', size']- run c "INSERT INTO objects_log (object_id, parent_id, type, extra_metadata, is_container, hash, size) VALUES (?, ?, ?, ?, ?, ?, ?)" [toSql id, parent_id', type', extra', toSql "0", hash', size']- commit c- return $ PO (id, i, Item { itemObjectAttributes = oa, itemAttributes = ia } )- where- id = "fa768fa6-2121-f90a-3902-307297203971"- parent_id' :: SqlValue- parent_id' = case i of- Just x -> toSql (show x)- Nothing -> SqlNull- type' :: SqlValue- type' = case objectType oa of- Just x -> toSql (show x)- Nothing -> SqlNull- extra' :: SqlValue- extra' = case objectExtraMetadata oa of- Just x -> toSql (show x)- Nothing -> SqlNull--persist c (Container oa) i =- do run c "INSERT INTO objects (id, parent_id, type, extra_metadata, is_container, hash, size) VALUES (?, ?, ?, ?, ?, ?, ?)" [toSql id, parent_id', type', extra', toSql "1", SqlNull, SqlNull]- run c "INSERT INTO objects_log (object_id, parent_id, type, extra_metadata, is_container, hash, size) VALUES (?, ?, ?, ?, ?, ?, ?)" [toSql id, parent_id', type', extra', toSql "1", SqlNull, SqlNull]- commit c- return $ PO (id, i, Container oa)- where -- TODO: Duplicate- id = "fa768fa6-2121-f90a-3902-307297203972"- parent_id' :: SqlValue- parent_id' = case i of- Just x -> toSql (show x)- Nothing -> SqlNull- type' :: SqlValue- type' = case objectType oa of- Just x -> toSql (show x)- Nothing -> SqlNull- extra' :: SqlValue- extra' = case objectExtraMetadata oa of- Just x -> toSql (show x)- Nothing -> SqlNull----- | Update the properties and/or change the parent of a 'PersistedObject'.--update :: ObjectID -> Object -> Maybe ObjectID -> PersistedObject-update i o p = update i o p----- | Get the elements that are in the root (does not have a parent).--getRoot :: IConnection c => c -> IO [PersistedObject]-getRoot c =- do result <- quickQuery' c "SELECT * FROM objects WHERE parent = NULL" []- return $ map resultToObject result----- | Get the elements with the given parent.--getChildren :: IConnection c => c -> ObjectID -> IO [PersistedObject]-getChildren c o =- do result <- quickQuery' c ("SELECT * FROM objects WHERE parent = '" ++ o ++- "'") []- return $ map resultToObject result----- | Get the object with the given 'ObjectID'.--getObject :: IConnection c => c -> ObjectID -> IO PersistedObject-getObject c o =- do result <- quickQuery' c ("SELECT * FROM objects WHERE id = '" ++ o ++ "'")- []- return $ resultToObject $ head result----- Inserts two "empty" objects, one container and one item, in the database.--insertDummyData :: IConnection conn => conn -> IO ()--insertDummyData c =- do let o0 = container Nothing Nothing- let o1 = item Nothing Nothing Nothing Nothing- - p0 <- persist c o0 Nothing- p1 <- persist c o1 Nothing- - return ()----- Function to convert a query result to a PersistedObject.---- resultToObject :: [SqlValue, SqlValue, SqlValue, SqlValue, SqlValue, SqlValue, SqlValue] -> PersistedObject--resultToObject [i, p, t, e, c, h, s]- | isContainer = persistedObject (Container objectAttributes)- | otherwise = persistedObject (Item { itemObjectAttributes = objectAttributes, itemAttributes = ItemAttributes { objectHash = Nothing, objectSize = Nothing } }) -- TODO- where- id = let SqlString i' = i in i'- isContainer = c == SqlString "1"- objectAttributes = ObjectAttributes { objectType = Nothing- , objectExtraMetadata = Nothing}- parent = case p of- SqlNull -> Nothing- SqlString s -> Just s- persistedObject o = PO (id, parent, o)
− Media/XPMN/PontariusMediaServer/XPMNDeviceServer.hs
@@ -1,253 +0,0 @@--- | 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)
− Media/XPMN/PontariusMediaServer/XPMNDeviceServer.hs-darcs-backup0
@@ -1,245 +0,0 @@--- | 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)
+ Media/XPMN/Server/DirectoryDevice.hs view
@@ -0,0 +1,146 @@+{-++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: 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'
+ Media/XPMN/Server/Object.hs view
@@ -0,0 +1,343 @@+{-++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: Utilities for managing media objects+-- Copyright: Copyright © 2010-2011 Jon Kristensen+-- License: AGPL-3+-- +-- Maintainer: info@pontarius.org+-- Stability: unstable+-- Portability: portable++-- | An 'Object' is either an 'Item' or a 'Container'. 'Item's and 'Container's+-- both have 'ObjectAttributes'. 'Additionally, Item's have 'ItemAttributes'.+-- +-- A 'PersistedObject' represents an 'Object' which has been stored in the+-- database (thus having an identifier and perhaps also a parent). This+-- identifier cannot be changed.++-- Parts of this module are not very thoroughly done as we are considering+-- moving to HaskellDB.++-- Example for specific meta-data (log table not tested):+--+-- run c "CREATE TABLE metadata_1 (id INTEGER PRIMARY KEY NOT NULL, object_i" +++-- "d INTEGER NOT NULL, dummy_value INTEGER, FOREIGN KEY(object_id) RE" +++-- "FERENCES objects(id))" [] -- x in metadata_x is the types value+-- run c "CREATE TABLE metadata_1_log (id INTEGER PRIMARY KEY NOT NULL, meta" +++-- "data_id INTEGER NOT NULL, object_id TEXT NOT NULL, dummy_value INT" +++-- "EGER, FOREIGN KEY(object_id) REFERENCES objects(id), FOREIGN KEY(m" +++-- "etadata_id) REFERENCES metadata_1(id))" []++module Media.XPMN.Server.Object ( Object+ , ObjectID+ , PersistedObject+ , connectToDatabase+ , initializeDatabase+ , objectID+ , parentID+ , object+ , container+ , item+ , persist+ , update+ , getRoot+ , getChildren+ , getObject+ , insertDummyData -- TODO: Remove+ ) where++import Database.HDBC+import Database.HDBC.Sqlite3++import Data.XML.Types++import Network.XMPP++import qualified Data.ByteString.Char8 as DB++data ObjectEvent = OEObjectPersisted++-- An object cannot have its objectID modified.+-- TODO: Add date and time information?++type ObjectID = String -- TODO: Use UUID++data Object = Item { itemObjectAttributes :: ObjectAttributes+ , itemAttributes :: ItemAttributes } |+ Container ObjectAttributes deriving (Show)++data ObjectAttributes = ObjectAttributes { objectName :: Maybe String+ , objectType :: Maybe Integer+ , objectExtraMetadata :: Maybe Element } deriving (Show)++data ItemAttributes = ItemAttributes { objectHash :: Maybe String -- TODO+ , objectSize :: Maybe Integer } deriving (Show)++data PersistedObject = PO (ObjectID, Maybe ObjectID, Object) deriving (Show)+++-- | Connects to the local database (the provided string appended by ".db).++connectToDatabase :: String -> IO Connection+connectToDatabase s = connectSqlite3 (s ++ ".db")+++disconnectFromDatabase :: IConnection c => c -> IO ()+disconnectFromDatabase l = disconnect l+++objectAttributes :: Object -> ObjectAttributes+objectAttributes (Item { itemObjectAttributes = oa }) = oa+objectAttributes (Container oa) = oa+++-- | Creates the necessary tables.++-- TODO: Use withTransaction?++initializeDatabase :: IConnection conn => conn -> IO ()++initializeDatabase c = do+ -- Create the object data and log table+ run c "CREATE TABLE objects (id TEXT PRIMARY KEY NOT NULL, parent_id TEXT, name TEXT, type INTEGER, extra_metadata TEXT, is_container INTEGER NOT NULL, hash TEXT, size INTEGER)" [] -- , CHECK ((is_container = 0 and (hash isnull) and (size isnull)) or (is_container != 0 and (not (hash isnull)) and (not (size isnull)))))+ run c "CREATE TABLE objects_log (id INTEGER PRIMARY KEY NOT NULL, object_id TEXT NOT NULL, parent_id TEXT, name TEXT, type INTEGER, extra_metadata TEXT, is_container INTEGER NOT NULL, hash TEXT, size INTEGER, FOREIGN KEY(object_id) REFERENCES objects(id))" [] -- , CHECK ((is_container = 0 and (hash isnull) and (size isnull)) or (is_container != 0 and (not (hash isnull)) and (not (size isnull))))+ + commit c+ + return ()+++-- | Returns the 'ObjectID' of a 'PersistedObject'.++objectID :: PersistedObject -> ObjectID+objectID (PO (i, _, _)) = i+++-- | Returns the potential 'ObjectID' of the parent of a 'PersistedObject'.++parentID :: PersistedObject -> Maybe ObjectID+parentID (PO (_, p, _)) = p+++-- | Returns the 'Object' of a 'PersistedObject'.++object :: PersistedObject -> Object+object (PO (_, _, o)) = o+++-- | Creates a 'Container' 'Object'.++container :: Maybe Integer -> Maybe Element -> Object+container t m = Container $ ObjectAttributes { objectName = Nothing+ , objectType = t+ , objectExtraMetadata = m }+++-- | Creates a 'Item' 'Object'.++item :: Maybe Integer -> Maybe Element -> Maybe String -> Maybe Integer -> Object+item t m h s = Item { itemObjectAttributes = ObjectAttributes { objectName = Nothing+ , objectType = t+ , objectExtraMetadata = m }+ , itemAttributes = ItemAttributes { objectHash = h+ , objectSize = s } }+++-- | Persists an object (with or without a parent) in the database.++persist :: (IConnection c) => c -> Object -> Maybe ObjectID -> IO PersistedObject++persist c (Item { itemObjectAttributes = oa, itemAttributes = ia }) i =+ do let hash' = case objectHash ia of -- TODO: itemHash in record...+ Just x -> toSql x+ Nothing -> SqlNull+ size' = case objectSize ia of+ Just x -> toSql x+ Nothing -> SqlNull+ id <- randomUUID+ run c "INSERT INTO objects (id, parent_id, name, type, extra_metadata, is_container, hash, size) VALUES (?, ?, ?, ?, ?, ?, ?, ?)" [toSql id, parent_id', name', type', extra', toSql "0", hash', size']+ commit c+ run c "INSERT INTO objects_log (object_id, parent_id, name, type, extra_metadata, is_container, hash, size) VALUES (?, ?, ?, ?, ?, ?, ?, ?)" [toSql id, parent_id', name', type', extra', toSql "0", hash', size']+ commit c+ return $ PO (id, i, Item { itemObjectAttributes = oa, itemAttributes = ia } )+ where+ parent_id' :: SqlValue+ parent_id' = case i of+ Just x -> toSql (show x)+ Nothing -> SqlNull+ name' :: SqlValue+ name' = case objectName oa of+ Just x -> toSql (show x)+ Nothing -> SqlNull+ type' :: SqlValue+ type' = case objectType oa of+ Just x -> toSql (show x)+ Nothing -> SqlNull+ extra' :: SqlValue+ extra' = case objectExtraMetadata oa of+ Just x -> toSql (show x)+ Nothing -> SqlNull++persist c (Container oa) i =+ do id <- randomUUID+ run c "INSERT INTO objects (id, parent_id, name, type, extra_metadata, is_container, hash, size) VALUES (?, ?, ?, ?, ?, ?, ?, ?)" [toSql id, parent_id', name', type', extra', toSql "1", SqlNull, SqlNull]+ commit c+ run c "INSERT INTO objects_log (object_id, parent_id, name, type, extra_metadata, is_container, hash, size) VALUES (?, ?, ?, ?, ?, ?, ?, ?)" [toSql id, parent_id', name', type', extra', toSql "1", SqlNull, SqlNull]+ commit c+ return $ PO (id, i, Container oa)+ where -- TODO: Duplicate+ parent_id' :: SqlValue+ parent_id' = case i of+ Just x -> toSql (show x)+ Nothing -> SqlNull+ name' :: SqlValue+ name' = case objectName oa of+ Just x -> toSql (show x)+ Nothing -> SqlNull+ type' :: SqlValue+ type' = case objectType oa of+ Just x -> toSql (show x)+ Nothing -> SqlNull+ extra' :: SqlValue+ extra' = case objectExtraMetadata oa of+ Just x -> toSql (show x)+ Nothing -> SqlNull+++-- | Update the properties and/or change the parent of a 'PersistedObject'.++update :: (IConnection c) => c -> ObjectID -> Maybe ObjectID -> Object -> IO PersistedObject+update c i p o = -- TODO: hash and size+ do run c ("UPDATE objects SET parent_id=" ++ parent_id'' ++ ", name=" ++ name'' ++ ", type=" ++ type'' ++ ", extra_metadata=" ++ extra'' ++ ", is_container='" ++ (container' o) ++ "' WHERE id='" ++ i ++ "'") [] -- TODO: Secure it+ commit c+ run c "INSERT INTO objects_log (object_id, parent_id, name, type, extra_metadata, is_container, hash, size) VALUES (?, ?, ?, ?, ?, ?, ?, ?)" [toSql i, parent_id', name', type', extra', toSql "1", SqlNull, SqlNull]+ commit c+ return $ PO (i, p, o)+ where -- TODO: Duplicate+ oa = objectAttributes o+ parent_id'' :: String+ parent_id'' = case p of+ Nothing -> "NULL"+ Just x -> "'" ++ x ++ "'"+ parent_id' :: SqlValue+ parent_id' = case p of+ Just x -> toSql (show x)+ Nothing -> SqlNull+ name' :: SqlValue+ name' = case objectName oa of+ Just x -> toSql (show x)+ Nothing -> SqlNull+ name'' :: String+ name'' = case objectName oa of+ Just x -> "'" ++ show x ++ "'"+ Nothing -> "NULL"+ type' :: SqlValue+ type' = case objectType oa of+ Just x -> toSql (show x)+ Nothing -> SqlNull+ type'' :: String+ type'' = case objectType oa of+ Just x -> "'" ++ (show x) ++ "'"+ Nothing -> "NULL"+ extra' :: SqlValue+ extra' = case objectExtraMetadata oa of+ Just x -> toSql (show x)+ Nothing -> SqlNull+ extra'' :: String+ extra'' = case objectExtraMetadata oa of+ Just x -> "'" ++ (show x) ++ "'"+ Nothing -> "NULL"+ container' :: Object -> String+ container' (Container _) = "1"+ container' (Item _ _) = "0"+++-- | Get the elements that are in the root (does not have a parent).++getRoot :: IConnection c => c -> IO [PersistedObject]+getRoot c =+ do result <- quickQuery' c "SELECT * FROM objects WHERE parent_id isnull" []+ return $ map resultToObject result+++-- | Get the elements with the given parent.++getChildren :: IConnection c => c -> ObjectID -> IO [PersistedObject]+getChildren c o =+ do result <- quickQuery' c ("SELECT * FROM objects WHERE parent_id='" ++ o +++ "'") []+ return $ map resultToObject result+++-- | Get the object with the given 'ObjectID'.++getObject :: IConnection c => c -> ObjectID -> IO (Maybe PersistedObject)+getObject c o =+ do result <- quickQuery' c ("SELECT * FROM objects WHERE id = '" ++ o ++ "'")+ []+ case length result of+ 0 -> return Nothing+ 1 -> return $ Just (resultToObject $ head result)+++-- Inserts two "empty" objects, one container and one item, in the database.++insertDummyData :: IConnection conn => conn -> IO ()++insertDummyData c =+ do let o0 = container Nothing Nothing+ let o1 = item Nothing Nothing Nothing Nothing+ + p0 <- persist c o0 Nothing+ p1 <- persist c o1 Nothing+ + return ()+++-- Function to convert a query result to a PersistedObject.++-- resultToObject :: [SqlValue, SqlValue, SqlValue, SqlValue, SqlValue, SqlValue, SqlValue] -> PersistedObject++resultToObject [i, p, n, t, e, c, h, s]+ | isContainer = persistedObject (Container objectAttributes)+ | otherwise = persistedObject (Item { itemObjectAttributes = objectAttributes, itemAttributes = ItemAttributes { objectHash = Nothing, objectSize = Nothing } }) -- TODO+ where+ id = let SqlByteString i' = i in DB.unpack i'+ isContainer = c == SqlString "1"+ objectAttributes = ObjectAttributes { objectName = Nothing+ , objectType = Nothing+ , objectExtraMetadata = Nothing}+ parent = case p of+ SqlNull -> Nothing+ SqlString s -> Just s+ persistedObject o = PO (id, parent, o)++randomUUID :: IO String+randomUUID = do+ f0 <- getID_ 8+ f1 <- getID_ 4+ f2 <- getID_ 4+ f3 <- getID_ 4+ f4 <- getID_ 12+ return $ f0 ++ "-" ++ f1 ++ "-" ++ f2 ++ "-" ++ f3 ++ "-" ++ f4
+ Media/XPMN/Server/ObjectServer.hs view
@@ -0,0 +1,107 @@+{-++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: Event-based module for managing media database objects+-- Copyright: Copyright © 2010-2011 Jon Kristensen+-- License: AGPL-3+-- +-- Maintainer: info@pontarius.org+-- Stability: unstable+-- Portability: portable++module Media.XPMN.Server.ObjectServer (ObjectServerOutEvent (..), ObjectServerInEvent (..), start) where++import Media.XPMN.Server.Object++import Database.HDBC+import Database.HDBC.Sqlite3++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)+import Data.Maybe++data State = State { stateConnection :: Connection }++data ObjectServerInEvent = OSIEPersistObject Object |+ OSIEUpdateObject ObjectID Object |+ OSIEGetObject ObjectID |+ OSIEGetRoot |+ OSIEGetChildren ObjectID deriving (Show)++data ObjectServerOutEvent = OSOEObjectPersisted PersistedObject |+ OSOEObjectUpdated PersistedObject |+ OSOEObject (Maybe PersistedObject) |+ OSOEGetRoot [PersistedObject] |+ OSOEGetChildren [PersistedObject] deriving (Show)++start :: String -> IO ((ObjectServerInEvent -> IO ()), IO ObjectServerOutEvent)+start s = do+ c <- newChan+ c_ <- newChan+ connection <- connectToDatabase s+ -- initializeDatabase connection+ forkIO $ eventLoop c c_ (State { stateConnection = connection })+ return (writeChan c, readChan c_)++eventLoop :: Chan ObjectServerInEvent -> Chan ObjectServerOutEvent -> State -> IO ()+eventLoop c c_ s = do+ e <- readChan c+ s' <- processEvent e c_ s+ eventLoop c c_ s++processEvent :: ObjectServerInEvent -> Chan ObjectServerOutEvent -> State -> IO State+processEvent (OSIEPersistObject o) c s = do+ persistedObject <- persist (stateConnection s) o Nothing+ writeChan c $ OSOEObjectPersisted persistedObject+ putStrLn (show $ objectID persistedObject)+ return s+processEvent (OSIEUpdateObject i o) c s = do+ persistedObject <- update (stateConnection s) i Nothing o+ writeChan c $ OSOEObjectUpdated persistedObject+ putStrLn (show $ objectID persistedObject)+ return s+processEvent (OSIEGetObject i) c s = do+ persistedObject <- getObject (stateConnection s) i+ writeChan c $ OSOEObject persistedObject+ putStrLn $ "Got object: " ++ (show $ objectID $ fromJust persistedObject)+ return s+processEvent OSIEGetRoot c s = do+ persistedObjects <- getRoot (stateConnection s)+ writeChan c $ OSOEGetRoot persistedObjects+ putStrLn $ "Got " ++ (show $ length persistedObjects) ++ " objects."+ return s+processEvent (OSIEGetChildren i) c s = do+ persistedObjects <- getChildren (stateConnection s) i+ writeChan c $ OSOEGetChildren persistedObjects+ putStrLn $ "Got " ++ (show $ length persistedObjects) ++ " objects."+ return s++main = do+ (write, read) <- start "Test"+ write $ OSIEPersistObject (container Nothing Nothing)+ write $ OSIEPersistObject (item Nothing Nothing Nothing Nothing)+ write $ OSIEUpdateObject "82c2cae1-b7b4-248e-ede6-9792419a1576" (item Nothing Nothing Nothing Nothing)+ write $ OSIEGetObject "82c2cae1-b7b4-248e-ede6-9792419a1576"+ write $ OSIEGetRoot+ write $ OSIEGetChildren "82c2cae1-b7b4-248e-ede6-9792419a1576"+ return ()
README view
@@ -4,6 +4,4 @@ <http://hackage.haskell.org/package/pontarius-mediaserver/> for more information. -We have just made an initial alpha release with a prototyped directory service.-We will release a working directory service by the next sprint as well as-prototype transfer service code.+This software is not really usable yet.
+ install.sh view
@@ -0,0 +1,5 @@+#!/bin/sh+runhaskell Setup.hs configure --user+runhaskell Setup.hs build+runhaskell Setup.hs install+
pontarius-mediaserver.cabal view
@@ -2,7 +2,7 @@ -- TODO: Highlighting bug: The last line of the description. Name: pontarius-mediaserver-Version: 0.0.1.0+Version: 0.0.2.0 Cabal-Version: >= 1.6 Build-Type: Simple License: OtherLicense@@ -13,7 +13,7 @@ Stability: alpha Homepage: http://www.pontarius.org/projects/pontarius-mediaserver/ Bug-Reports: mailto:info@pontarius.org-Package-URL: http://www.pontarius.org/releases/pontarius-mediaserver-0.0.1.0.tar.gz+Package-URL: http://www.pontarius.org/releases/pontarius-mediaserver-0.0.2.0.tar.gz Synopsis: Extended Personal Media Network (XPMN) media server Description: Pontarius Media Server will be a free and privacy-aware Extended Personal Media Network (XPMN) media server.@@ -27,7 +27,7 @@ -- uuid Executable pontarius-mediaserver-test Main-Is: Main.hs- Build-Depends: HLogger ==0.0.2.0, pontarius-xmpp ==0.0.2.0, base >= 2 && < 5, xml-types, HDBC, HDBC-sqlite3+ Build-Depends: hlogger ==0.0.2.0, pontarius-xmpp ==0.0.3.0, pontarius-xpmn ==0.0.1.0, base >= 2 && < 5, xml-types, HDBC, HDBC-sqlite3 -- Other-Modules: -- HS-Source-Dirs: -- Extensions:@@ -58,5 +58,5 @@ Type: darcs -- Module: Location: https://patch-tag.com/r/jonkri/pontarius-mediaserver- Tag: 0.0.1.0+ Tag: 0.0.2.0 -- Subdir: