Holumbus-Storage-0.1.0: source/Holumbus/FileSystem/Node/NodeData.hs
-- ----------------------------------------------------------------------------
{- |
Module : Holumbus.FileSystem.Node.NodeData
Copyright : Copyright (C) 2008 Stefan Schmidt
License : MIT
Maintainer : Stefan Schmidt (stefanschmidt@web.de)
Stability : experimental
Portability: portable
Version : 0.1
-}
-- ----------------------------------------------------------------------------
module Holumbus.FileSystem.Node.NodeData
(
-- * data types
NodeData
-- * creation and destruction
, newNode
)
where
import Prelude hiding (appendFile)
import Control.Concurrent
import Control.Monad
import Data.Maybe
import System.Log.Logger
import Holumbus.Common.Debug
import Holumbus.Common.Utils
import Holumbus.FileSystem.Node
import Holumbus.FileSystem.Node.NodePort
import qualified Holumbus.FileSystem.Controller as C
import qualified Holumbus.FileSystem.Controller.ControllerPort as CP
import qualified Holumbus.FileSystem.Messages as M
import qualified Holumbus.FileSystem.Storage as S
import qualified Holumbus.FileSystem.Storage.FileStorage as FS
import Holumbus.Network.Communication
localLogger :: String
localLogger = "Holumbus.FileSystem.Node.NodeData"
-- ----------------------------------------------------------------------------
--
-- ----------------------------------------------------------------------------
-- | Node datatype.
data NodeData = NodeData {
nd_Client :: Client
, nd_Storage :: FS.FileStorage
}
data Node = Node (MVar NodeData)
-- ----------------------------------------------------------------------------
--
-- ----------------------------------------------------------------------------
newNode :: StreamName -> Maybe SocketId -> FS.FileStorage -> IO Node
newNode sn soid stor
= do
-- initialise the client
nodedata <- newEmptyMVar
client <- newClient sn soid (dispatch (Node nodedata))
-- open storage
stor' <- S.openStorage stor
putMVar nodedata (NodeData client stor')
return (Node nodedata)
dispatch
:: Node
-> M.NodeRequestMessage
-> IO (Maybe M.NodeResponseMessage)
dispatch nd msg
= do
case msg of
(M.NReqCreate i c) ->
do
createFile i c nd
return $ Just M.NRspSuccess
(M.NReqCreateS l) ->
do
createFiles l nd
return $ Just M.NRspSuccess
(M.NReqAppend i c) ->
do
appendFile i c nd
return $ Just M.NRspSuccess
(M.NReqDelete i b) ->
do
deleteFile i b nd
return $ Just M.NRspSuccess
(M.NReqCopy i cp) ->
do
copyFile i cp nd
return $ Just M.NRspSuccess
(M.NReqContains i)->
do
b <- containsFile i nd
return $ Just $ M.NRspContains b
(M.NReqGetFileContent i) ->
do
c <- getFileContent i nd
return $ Just $ M.NRspGetFileContent c
(M.NReqGetMultiFileContent l) ->
do
-- mvar <- newEmptyMVar
-- _ <- forkIO $ multiThread l nd mvar
-- lc <- takeMVar mvar
lc <- getMultiFileContent l nd
return $ Just $ M.NRspGetMultiFileContent lc
(M.NReqGetFileData i) ->
do
d <- getFileData i nd
return $ Just $ M.NRspGetFileData d
(M.NReqGetFileIds) ->
do
ls <- getFileIds nd
return $ Just $ M.NRspGetFileIds ls
_ -> return Nothing
-- ----------------------------------------------------------------------------
--
-- ----------------------------------------------------------------------------
changeStorage :: (FS.FileStorage -> IO FS.FileStorage) -> Node -> IO ()
changeStorage f (Node node)
= modifyMVar node $
\nd ->
do
stor' <- f (nd_Storage nd)
return (nd {nd_Storage = stor'}, ())
readStorage :: (FS.FileStorage-> IO a) -> Node -> IO a
readStorage f (Node node)
= do
a <- withMVar node $ \nd -> f (nd_Storage nd)
return a
logStorage :: Node -> IO ()
logStorage (Node node) = withMVar node $ \nd -> logStorage2 (nd_Client nd)
where
logStorage2 (Client client) = withMVar client $ \cd -> debugM "measure.readStorage" ((show . cd_SiteId) cd)
{-
multiThread :: [S.FileId] -> Node -> MVar [(S.FileId,S.FileContent)] -> IO ()
multiThread l' nd mvar = do
l <- getMultiFileContent l' nd
putMVar mvar l
return ()
-}
-- ----------------------------------------------------------------------------
-- Typeclass instanciation (NodeClass)
-- ----------------------------------------------------------------------------
instance NodeClass Node where
closeNode (Node node)
= modifyMVar node $
\nd ->
do
infoM localLogger "closing filesystem node"
closeClient (nd_Client nd)
return (nd,())
--createFile :: S.FileId -> S.FileContent -> Node -> IO ()
createFile i c n@(Node node)
= do
client <- withMVar node $ \nd -> return (nd_Client nd)
nid <- getClientId client
case nid of
(Nothing) ->
do
--TODO better exception-handling
errorM localLogger $ "createFile \"" ++ i ++ "\" - no nid"
return ()
(Just nid') ->
do
changeStorage (\stor -> S.createFile stor i c) n
server <- getServerPort client
let cp = CP.newControllerPortFromServerPort server
C.createFile i nid' cp
return ()
-- createFiles l n = mapM_ (\(fid,c) -> createFile fid c n) l
--createFiles :: [(S.FileId,S.FileContent)] -> Node -> IO ()
createFiles l n@(Node node)
= do
client <- withMVar node $ \nd -> return (nd_Client nd)
nid <- getClientId client
case nid of
(Nothing) ->
do
--TODO better exception-handling
errorM localLogger $ "createFiles - no nid"
return ()
(Just nid') ->
do
mapM_ (\(i,c) -> changeStorage (\stor -> S.createFile stor i c) n) l
server <- getServerPort client
let cp = CP.newControllerPortFromServerPort server
let fns = map (\(i,_) -> (i,nid')) l
C.createFiles fns cp
return ()
--appendFile :: S.FileId -> S.FileContent -> Node -> IO ()
appendFile i c n@(Node node)
= do
client <- withMVar node $ \nd -> return (nd_Client nd)
nid <- getClientId client
case nid of
(Nothing) ->
do
--TODO better exception-handling
errorM localLogger $ "appendFile \"" ++ i ++ "\" - no nid"
return ()
(Just nid') ->
do
changeStorage (\stor -> S.appendFile stor i c) n
server <- getServerPort client
let cp = CP.newControllerPortFromServerPort server
-- Inform Controller that file has changed.
C.appendFile i nid' cp
return ()
--deleteFile :: S.FileId -> Node -> IO ()
deleteFile i b n@(Node node)
= do
client <- withMVar node $ \nd -> return (nd_Client nd)
nid <- getClientId client
case nid of
(Nothing) ->
do
--TODO better exception-handling
errorM localLogger $ "deleteFile \"" ++ i ++ "\" - no nid"
return ()
(Just nid') ->
do
changeStorage (\stor -> S.deleteFile stor i) n
if (b)
then do
server <- getServerPort client
let cp = CP.newControllerPortFromServerPort server
C.deleteFile i nid' cp
return ()
else return ()
copyFile i cp n
= do
let np = newNodePort cp
c <- getFileContent i np
-- TODO do not create new file data
--d <- getFileData i np
if (isJust c)
then do
createFile i (fromJust c) n
return ()
else do
errorM localLogger $ "copyFile: no content for \"" ++ i ++ "\" found"
return ()
--containsFile :: S.FileId -> Node -> IO Bool
containsFile i n
= do
readStorage (\stor -> S.containsFile stor i) n
--getFileContent :: S.FileId -> Node -> IO (Maybe S.FileContent)
getFileContent i n
= do
c <- readStorage (\stor -> S.getFileContent stor i) n
debugM localLogger $ "getFileContent: " ++ show c
logStorage n
return c
--getMultiFileContent :: [S.FileId] -> Node -> IO [(S.FileId,S.FileContent)]
getMultiFileContent l n
= do
result <- foldM f [] l
debugM localLogger $ "getFileContents: " ++ show result
logStorage n
return result
where
f :: [(S.FileId,S.FileContent)] -> S.FileId -> IO [(S.FileId,S.FileContent)]
f res filename = do
maybecontent <- readStorage (\stor -> S.getFileContent stor filename) n
case maybecontent of
(Just c) -> return ((filename,c):res)
Nothing -> return res
--getFileData :: S.FileId -> Node -> IO (Maybe S.FileData)
getFileData i nd
= do
readStorage (\stor -> S.getFileData stor i) nd
--getFileIds :: Node -> IO [S.FileId]
getFileIds nd
= do
readStorage (\stor -> S.getFileIds stor) nd
instance Debug Node where
printDebug (Node node)
= do
putStrLn "Node-Object (full)"
withMVar node $
\nd ->
do
printDebug (nd_Client nd)
putStrLn $ prettyRecordLine gap "Storage:" (nd_Storage nd)
where
gap = 20
getDebug (Node node)
= do
tmp <- withMVar node $
\nd ->
do
tmp <- getDebug (nd_Client nd)
return (tmp++"\n"++ (prettyRecordLine gap "Storage:" (nd_Storage nd)) ++"\n")
return ("Node-Object (full)"++"\n"++tmp++"\n")
where
gap = 20