diff --git a/DeviceTest.hs b/DeviceTest.hs
deleted file mode 100644
--- a/DeviceTest.hs
+++ /dev/null
@@ -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 = []
diff --git a/Directory.db b/Directory.db
new file mode 100644
Binary files /dev/null and b/Directory.db differ
diff --git a/Main.hs b/Main.hs
--- a/Main.hs
+++ b/Main.hs
@@ -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 .
+
+-}
+
+
+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 ()
diff --git a/Media/XPMN/PontariusMediaServer/Object.hs b/Media/XPMN/PontariusMediaServer/Object.hs
deleted file mode 100644
--- a/Media/XPMN/PontariusMediaServer/Object.hs
+++ /dev/null
@@ -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)
diff --git a/Media/XPMN/PontariusMediaServer/XPMNDeviceServer.hs b/Media/XPMN/PontariusMediaServer/XPMNDeviceServer.hs
deleted file mode 100644
--- a/Media/XPMN/PontariusMediaServer/XPMNDeviceServer.hs
+++ /dev/null
@@ -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)
diff --git a/Media/XPMN/PontariusMediaServer/XPMNDeviceServer.hs-darcs-backup0 b/Media/XPMN/PontariusMediaServer/XPMNDeviceServer.hs-darcs-backup0
deleted file mode 100644
--- a/Media/XPMN/PontariusMediaServer/XPMNDeviceServer.hs-darcs-backup0
+++ /dev/null
@@ -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)
diff --git a/Media/XPMN/Server/DirectoryDevice.hs b/Media/XPMN/Server/DirectoryDevice.hs
new file mode 100644
--- /dev/null
+++ b/Media/XPMN/Server/DirectoryDevice.hs
@@ -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 .
+
+-}
+
+
+-- | 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'
diff --git a/Media/XPMN/Server/Object.hs b/Media/XPMN/Server/Object.hs
new file mode 100644
--- /dev/null
+++ b/Media/XPMN/Server/Object.hs
@@ -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 .
+
+-}
+
+
+-- | 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
diff --git a/Media/XPMN/Server/ObjectServer.hs b/Media/XPMN/Server/ObjectServer.hs
new file mode 100644
--- /dev/null
+++ b/Media/XPMN/Server/ObjectServer.hs
@@ -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 .
+
+-}
+
+
+-- | 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 ()
diff --git a/README b/README
--- a/README
+++ b/README
@@ -4,6 +4,4 @@
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.
diff --git a/install.sh b/install.sh
new file mode 100644
--- /dev/null
+++ b/install.sh
@@ -0,0 +1,5 @@
+#!/bin/sh
+runhaskell Setup.hs configure --user
+runhaskell Setup.hs build
+runhaskell Setup.hs install
+
diff --git a/pontarius-mediaserver.cabal b/pontarius-mediaserver.cabal
--- a/pontarius-mediaserver.cabal
+++ b/pontarius-mediaserver.cabal
@@ -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: