DMVar.hs

-- ----------------------------------------------------------------------------

{- |
  Module     : Holumbus.Distribution.DMVar 
  Copyright  : Copyright (C) 2009 Stefan Schmidt
  License    : MIT

  Maintainer : Stefan Schmidt (stefanschmidt@web.de)
  Stability  : experimental
  Portability: portable
  Version    : 0.1
  
  This module offers the distributed MVar datatype.

  The datatype behaves just like a normal MVar, but the content of the
  variable may be stored on a different DNode. When accessing the DMVar,
  the content will be fetched from the external node and written back.

  It is guaranteed, that only one node at a time can take the content
  of the DMVar. Just like normal DMVars, you can produce deadlocks.

  When a node dies which holds the content of a DMVar, the node which
  created the variable will reset its value to the last known value.
  
  If the owner dies, the other nodes cannot access the content of the
  DMVar any more.
-}

-- ----------------------------------------------------------------------------

module Holumbus.Distribution.DMVar
(
  -- * datatype
    DMVar

  -- * creating and closing DMVars
  , newDMVar
  , newEmptyDMVar
  , newRemoteDMVar
  , closeDMVar

  -- * acccessing DMVars
  , readDMVar
  , takeDMVar
  , putDMVar
)
where

import           Prelude hiding (catch)

import           Control.Concurrent.MVar
import           Data.Binary
import qualified Data.ByteString.Lazy as B
import           System.IO
import           System.Log.Logger

import           Holumbus.Distribution.DNode.Base


localLogger :: String
localLogger = "Holumbus.Distribution.DMVar"

dMVarType :: DResourceType
dMVarType = mkDResourceType "DMVAR"

mkDMVarEntry :: (Binary a) => DMVarReference a -> DResourceEntry
mkDMVarEntry d = DResourceEntry {
    dre_Dispatcher   = dispatchDMVarRequest d 
  }


data DMVarRequestMessage
  = DVMReqRead
  | DVMReqTake
  | DVMReqPut B.ByteString
  deriving (Show)
    
instance Binary DMVarRequestMessage where
  put(DVMReqRead)  = putWord8 1
  put(DVMReqTake)  = putWord8 2
  put(DVMReqPut b) = putWord8 3 >> put b
  get
    = do
      t <- getWord8
      case t of
        1 -> return (DVMReqRead)
        2 -> return (DVMReqTake)
        3 -> get >>= \b -> return (DVMReqPut b)
        _ -> error "DMVarRequestMessage: wrong encoding"


data DMVarResponseMessage
  = DVMRspRead B.ByteString
  | DVMRspTake B.ByteString
  | DVMRspPut
  deriving (Show)

instance Binary DMVarResponseMessage where
  put(DVMRspRead b) = putWord8 1 >> put b
  put(DVMRspTake b) = putWord8 2 >> put b
  put(DVMRspPut)    = putWord8 3
  get
    = do
      t <- getWord8
      case t of
        1 -> get >>= \b -> return (DVMRspRead b)
        2 -> get >>= \b -> return (DVMRspTake b)
        3 -> return (DVMRspPut)
        _ -> error "DMVarResponseMessage: wrong encoding"


dispatchDMVarRequest :: (Binary a) => DMVarReference a -> DNodeId -> Handle -> IO () 
dispatchDMVarRequest dch dna hdl
  = do
    debugM localLogger "dispatcher: getting message from handle"
    raw <- getByteStringMessage hdl
    let msg = (decode raw)
    debugM localLogger $ "dispatcher: Message: " ++ show msg
    case msg of
      (DVMReqRead)  -> handleRead dch hdl
      (DVMReqTake)  -> handleTake dch dna hdl
      (DVMReqPut b) -> handlePut dch (decode b) hdl


-- | The DMVar datatype.
data DMVar a
  = DMVarLocal DResourceAddress (MVar a) (MVar (a, Maybe DHandlerId))
  | DMVarRemote DResourceAddress

instance Binary (DMVar a) where
  put(DMVarLocal dra _ _) = put dra
  put(DMVarRemote dra)    = put dra
  get = get >>= \dra -> return (DMVarRemote dra)

data DMVarReference a = DMVarReference DResourceAddress (MVar a) (MVar (a, Maybe DHandlerId))
  

-- | Creates a new local DMVar with a start value.
--   The string parameter specifies the name of the variable.
--   If you leave it empty, a random value will be generated.
newDMVar :: (Binary a) => String -> a -> IO (DMVar a)
newDMVar s d
  = do
    dra <- genLocalResourceAddress dMVarType s
    v <- newMVar d
    o <- newEmptyMVar
    let dmv = (DMVarLocal dra v o)
        dvr = (DMVarReference dra v o)
        dve = (mkDMVarEntry dvr)
    addLocalResource dra dve
    return dmv


-- | Creates a new empty local DMVar. The string parameter specifies the name of
--   the variable. If you leave it empty, a random value will be generated.
newEmptyDMVar :: (Binary a) => String -> IO (DMVar a)
newEmptyDMVar s
  = do
    dra <- genLocalResourceAddress dMVarType s
    v <- newEmptyMVar
    o <- newMVar (undefined, Nothing)
    let dmv = (DMVarLocal dra v o)
        dvr = (DMVarReference dra v o)
        dve = (mkDMVarEntry dvr)
    addLocalResource dra dve
    return dmv


-- | Creates a reference to an external DMVar.
--   The first parameter is the name of the resource and the second one
--   the name of the node.
newRemoteDMVar :: String -> String -> IO (DMVar a)
newRemoteDMVar r n
  = do
    return $ DMVarRemote dra
    where
    dra = mkDResourceAddress dMVarType r n


-- | Closes a DMVar
closeDMVar :: (DMVar a) -> IO ()
closeDMVar (DMVarLocal dra _ _)
  = do
    delLocalResource dra
closeDMVar (DMVarRemote dra)
  = do
    delForeignResource dra



requestRead :: (Binary a) => Handle -> IO a
requestRead hdl
  = do
    putByteStringMessage (encode $ DVMReqRead) hdl
    raw <- getByteStringMessage hdl
    let rsp = (decode raw)
    case rsp of
      (DVMRspRead d) -> return $ decode d
      _ -> error "DMVar - requestRead: invalid response"


handleRead :: (Binary a) => DMVarReference a -> Handle -> IO ()
handleRead (DMVarReference _ v _) hdl
  = do
    a <- readMVar v
    putByteStringMessage (encode $ DVMRspRead $ encode a) hdl



requestTake :: (Binary a) => Handle -> IO a
requestTake hdl
  = do
    putByteStringMessage (encode $ DVMReqTake) hdl
    raw <- getByteStringMessage hdl
    let rsp = (decode raw)
    case rsp of
      (DVMRspTake d) -> return $ decode d
      _ -> error "DMVar - requestTake: invalid response"


handleTake :: (Binary a) => DMVarReference a -> DNodeId -> Handle -> IO ()
handleTake r@(DMVarReference _ v o) dni hdl
  = do
    debugM localLogger $ "handleTake: 1"
    a <- takeMVar v
    debugM localLogger $ "handleTake: 2"
    -- install handler and save backup
    mbDhi <- addForeignDNodeHandler False dni (handleErrorTake r)
    debugM localLogger $ "handleTake: 3"
    putMVar o (a, mbDhi)
    debugM localLogger $ "handleTake: 4"
    putByteStringMessage (encode $ DVMRspTake $ encode a) hdl
    debugM localLogger $ "handleTake: 5"
    

handleErrorTake :: (Binary a) => DMVarReference a -> DHandlerId -> IO ()
handleErrorTake (DMVarReference _ v o) dhi
  = do
    debugM localLogger $ "handleErrorTake: 1"
    (a,_ ) <- takeMVar o
    delForeignHandler dhi
    debugM localLogger $ "handleErrorTake: 2"
    putMVar v a


requestPut :: (Binary a) => a -> Handle -> IO ()
requestPut d hdl
  = do
    putByteStringMessage (encode $ DVMReqPut $ encode d) hdl
    raw <- getByteStringMessage hdl
    let rsp = (decode raw)
    case rsp of
      (DVMRspPut) -> return ()
      _ -> error "DMVar - requestWrite: invalid response"


handlePut :: (Binary a) => DMVarReference a -> a -> Handle -> IO ()
handlePut (DMVarReference _ v o) a hdl
  = do
    -- delete backup and kill handler 
    (_,mbDhi) <- takeMVar o
    case mbDhi of
      (Just dhi) -> delForeignHandler dhi
      (Nothing)  -> return ()
    putMVar v a
    putByteStringMessage (encode $ DVMRspPut) hdl



-- | Reads the content of a DMVar. Blocks if the Variable is empty.
--   This may throw an exception if the owner of the variable is unreachable.
readDMVar :: (Binary a) => DMVar a -> IO a
readDMVar (DMVarLocal _ v _)
  = do
    readMVar v
readDMVar (DMVarRemote a)
  = do
    unsafeAccessForeignResource a requestRead


-- | Takes the content of a DMVar. Blocks if the Variable is empty.
--   This may throw an exception if the owner of the variable is unreachable.
takeDMVar :: (Binary a) => DMVar a -> IO a
takeDMVar (DMVarLocal _ v o)
  = do
    a <- takeMVar v
    putMVar o (a, Nothing)
    return a
takeDMVar (DMVarRemote a)
  = do
    unsafeAccessForeignResource a requestTake


-- | Writes a value to the DMvar. Blocks if the Variable is not empty.
--   This may throw an exception if the owner of the variable is unreachable.
putDMVar :: (Binary a) => DMVar a -> a -> IO ()  
putDMVar (DMVarLocal _ v o) d
  = do
    (_,mbDhi) <- takeMVar o
    case mbDhi of
      (Just dhi) -> delForeignHandler dhi
      (Nothing)  -> return ()
    putMVar v d
putDMVar (DMVarRemote a) d
  = do
    unsafeAccessForeignResource a (requestPut d)