{-
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