-----------------------------------------------------------------------------
--
-- Module      :  Control.Concurrent.Network.NVar
-- Copyright   :  (C) 2010, Paul Sonkoly
-- License     :  BSD style
--
-- Maintainer  :  Paul Sonkoly
-- Stability   :  provisional
-- Portability :
--
-- | Network variables.
--    Communication is done by using 'NVar' variables similar to 'MVar' in Concurrent.
--
--    Every read and every write results in network transaction with the master process,
--    so handle with care.
--
--    This is done with a push style implementation so 'putNVar' propagets the value to
--    the master process, but other slaves won't get automatically notified
--    about the change. The next 'takeNVar' will result in the updated value.
--
--    To save network bandwith and load on the master, it is possible to wait for an
--    'NVar' to change value using 'pollWithOp'.
-----------------------------------------------------------------------------

module Control.Concurrent.Network.NVar
    (
    -- * Functions
      newNVar
    , putNVar
    , takeNVar
    , tryPutNVar
    , tryTakeNVar
    , readNVar
    , pollWithOp
    ) where

import Control.Concurrent.MVar
import Control.Concurrent.Network.Slave
import Control.Concurrent.Network.Protocol
import Data.Binary
import Data.Maybe
import Data.Int


-- | Creates a new empty 'NVar' on the master. Doesn't block the caller.
newNVar :: NCContext -> String -> IO ()
newNVar nc name = do
    hdl' <- takeMVar (hdl nc)
    writeProtoId hdl' NNV
    writeBinary hdl' name
    putMVar (hdl nc) hdl'


-- | Puts a value into 'NVar' specified by the name.
--   If the 'NVar' doesn't exist this blocks the caller until it's
--    created potentially by an  other slave.
--
--   If the 'NVar' already has a value this blocks the caller until
--    an other slave calls 'takeNVar'.
--
--   If the 'NVar' is empty this returns immediately after the network
--    transactions.
putNVar :: (Binary a) => NCContext -> String -> a -> IO ()
putNVar nc name a = do
    hdl' <- takeMVar (hdl nc)
    writeProtoId hdl' PNV
    writeBinary hdl' name
    writeBinary hdl' a
    readProtoId hdl'
    putMVar (hdl nc) hdl'


-- | Takes the latest value of 'NVar' from the master.
--   If the 'NVar' doesn't exist this blocks the caller until it's
--    created potentially by an other slave.
--
--   If the 'NVar' is empty this blocks the caller until
--    an other slave calls 'putNVar'.
--
--   If the 'NVar' has a value this returns immediately after the network
--    transactions.
takeNVar :: (Binary a) =>  NCContext -> String -> IO a
takeNVar nc name = do
    hdl' <- takeMVar (hdl nc)
    writeProtoId hdl' TNV
    writeBinary hdl' name
    res <- readBinary hdl'
    putMVar (hdl nc) hdl'
    return res


-- | Tries to put a value into 'NVar' specified by the name.
--   If the 'NVar' doesn't exist returns 'IO' 'False'.
--
--   If the 'NVar' already has a value returns 'IO' 'False' and
--    leaves the value untouched.
--
--   If the 'NVar' is empty this sets it to the specified value
--    and returns 'IO' 'True'.
tryPutNVar :: (Binary a) => NCContext -> String -> a -> IO Bool
tryPutNVar nc name a = do
    hdl' <- takeMVar (hdl nc)
    writeProtoId hdl' TPN
    writeBinary hdl' name
    writeBinary hdl' a
    ret <- readBinary hdl'
    putMVar (hdl nc) hdl'
    return ret


-- | Takes the latest value of 'NVar' from the master.
--   If the 'NVar' doesn't exist this blocks the caller until it's
--    created potentially by an other slave.
--
--   If the 'NVar' is empty this blocks the caller until
--    an other slave calls 'putNVar'.
--
--   If the 'NVar' has a value this returns immediately after the network
--    transactions.
tryTakeNVar :: (Binary a) =>  NCContext -> String -> IO (Maybe a)
tryTakeNVar nc name = do
    hdl' <- takeMVar (hdl nc)
    writeProtoId hdl' TTN
    writeBinary hdl' name
    s <- (readBinary hdl' :: IO Bool)
    if s
        then do
            res <- readBinary hdl'
            putMVar (hdl nc) hdl'
            return $ Just res
        else do
            putMVar (hdl nc) hdl'
            return Nothing


-- | Like with 'MVar's this takes an 'NVar' put's the taken value back,
--   and returns it.
readNVar :: (Binary a) =>  NCContext -> String -> IO a
readNVar nc name = do
    val <- takeNVar nc name
    putNVar nc name val
    return val


-- | Polls while the given condition is true for 'NVar' called 'name'.
--    As this call doesn't return while the condition is true, it's much
--    more efficient than busy waiting in the slave generating network
--    traffic.
pollWithOp :: (Binary a) => NCContext -> String  -> Equality -> a -> IO ()
pollWithOp nc name eq a = do
    hdl' <- takeMVar (hdl nc)
    writeProtoId hdl' PWO
    writeBinary hdl' name
    writeBinary hdl' eq
    writeBinary hdl' a
    readProtoId hdl'
    putMVar (hdl nc) hdl'