DFunction.hs

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

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

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

  This idea behind this is to implement RPC based on DNodes. You specify
  a function which could be called from other programs and register this
  as a resource in your local DNode. Then the foreign DNodes can create
  a link to this function an execute it. The function parameters will be
  serialized and send to the local DNode. There the parameters are deserialized
  and the function will be called. After this the return-value will be send
  back to the calling node. 
-}

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

{-# OPTIONS_GHC -XMultiParamTypeClasses -XFunctionalDependencies -XFlexibleInstances -XFlexibleContexts #-}
module Holumbus.Distribution.DFunction 
(
  -- * datatypes
    DFunction
  , BinaryFunction
   
  -- * creating and closing function references
  , newDFunction
  , newRemoteDFunction
  , closeDFunction
  
  -- * invoking functions
  , accessDFunction
)
where

import           Prelude hiding (catch)

import           Control.Exception
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.DFunction"

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

-- | Binary function typeclass. You can only use functions whose parameters
--   and return value are serializable. The idea of this typeclass comes from
--   the haxr library by Bjorn Bringert (http://www.haskell.org/haskellwiki/HaXR)
class BinaryFunction a where
    toFun :: a -> [B.ByteString] -> IO B.ByteString
    remoteCall :: ([B.ByteString] -> IO B.ByteString) -> a

instance (Binary a) => BinaryFunction (IO a) where
    toFun x [] = x >>= return . encode
    toFun _ _ = fail "Too many arguments"
    remoteCall f = f [] >>= return . decode

instance (Binary a, BinaryFunction b) => BinaryFunction (a -> b) where
    toFun f (x:xs) = toFun (f (decode x)) xs
    toFun _ _ = error "Too few arguments"
    remoteCall f x = remoteCall (\xs -> f (encode x:xs))




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

dFunctionType :: DResourceType
dFunctionType = mkDResourceType "DFUNCTION"

mkDFunctionEntry :: (BinaryFunction a) => DFunctionReference a -> DResourceEntry
mkDFunctionEntry d = DResourceEntry {
    dre_Dispatcher   = dispatchDFunctionRequest d 
  }


data DFunctionRequestMessage
  = DFMReqCall [B.ByteString]
  deriving (Show)
  
instance Binary DFunctionRequestMessage where
  put(DFMReqCall bs) = put bs
  get = get >>= \bs -> return (DFMReqCall bs)


data DFunctionResponseMessage
  = DFMRspCallResult B.ByteString
  | DFMRspCallException String

instance Binary DFunctionResponseMessage where
  put(DFMRspCallResult b) = putWord8 1 >> put b
  put(DFMRspCallException e) = putWord8 2 >> put e
  get
    = do
      t <- getWord8
      case t of
        1 -> get >>= \b -> return (DFMRspCallResult b)
        2 -> get >>= \e -> return (DFMRspCallException e)
        _ -> error "DFunctionResponseMessage: wrong encoding"


dispatchDFunctionRequest :: (BinaryFunction a) => DFunctionReference a -> DNodeId -> Handle -> IO () 
dispatchDFunctionRequest dfun _ hdl
  = do
    debugM localLogger "dispatcher: getting message from handle"
    raw <- getByteStringMessage hdl
    let msg = (decode raw)::(DFunctionRequestMessage)
    -- debugM localLogger $ "dispatcher: Message: " ++ show msg
    case msg of
      (DFMReqCall l)  -> handleCall dfun l hdl


-- | The DFunction datatype. This is more like a reference to
--   a function located on a different node. You can call this
--   function via the accessDFunction function.
data DFunction a
  = DFunctionLocal DResourceAddress a
  | DFunctionRemote DResourceAddress

instance Binary (DFunction a) where
  put(DFunctionLocal dra _) = put dra
  put(DFunctionRemote dra)  = put dra
  get = get >>= \dra -> return (DFunctionRemote dra)
  
  
data DFunctionReference a = DFunctionReference DResourceAddress a


-- | Creates a new distributed function. Only functions which are registered
--   at the local node can be called from the outside. The string parameter
--   specifies the name of the function which could the used by other nodes
--   to call it. If you leave it empty, a random name will be generated.
newDFunction :: (BinaryFunction a) => String -> a -> IO (DFunction a)
newDFunction s f
  = do
    a <- genLocalResourceAddress dFunctionType s
    let df  = (DFunctionLocal a f)
        dfr = (DFunctionReference a f)
        dfd = (mkDFunctionEntry dfr)
    addLocalResource a dfd
    return df


-- | Created a reference to a function on a remote node. The first parameter
--   is the name of the function, the second parameter is the name of the node.
newRemoteDFunction :: (BinaryFunction a) => String -> String -> IO (DFunction a)
newRemoteDFunction r n
  = do
    return $ DFunctionRemote dra
    where
    dra = mkDResourceAddress dFunctionType r n


-- | Closes a DFunction reference.
closeDFunction :: DFunction a -> IO ()
closeDFunction (DFunctionLocal dra _)
  = do
    delLocalResource dra
closeDFunction (DFunctionRemote dra)
  = do
    delForeignResource dra


requestCall :: [B.ByteString] -> Handle -> IO B.ByteString
requestCall bs hdl
  = do
    putByteStringMessage (encode $ DFMReqCall bs) hdl
    raw <- getByteStringMessage hdl
    let rsp = (decode raw)
    case rsp of
      (DFMRspCallResult b) -> return b
      (DFMRspCallException e) -> throwIO $ DistributedException e "requestCall" "DFunction"


handleCall :: BinaryFunction a => DFunctionReference a -> [B.ByteString] -> Handle -> IO ()
handleCall (DFunctionReference _ f) bs hdl
  = do
    catch
      (do
       b <- toFun f bs
       putByteStringMessage (encode $ DFMRspCallResult b) hdl)
      (\(SomeException e) -> do
       putByteStringMessage (encode $ DFMRspCallException (show e)) hdl)


-- | Transforms a DFunction object to a normal function which could be called and passed around.
--   Because you have network tranfer everytime you call the function, this might throw a
--   DistributedException when the foreign node becomes unreachable.
accessDFunction :: (BinaryFunction a) => DFunction a -> a
accessDFunction (DFunctionLocal _ f) = f
accessDFunction (DFunctionRemote a)
  = remoteCall $ \bs ->
      unsafeAccessForeignResource a (requestCall bs)


{-
Example Code:

addInt :: Int -> Int -> IO Int
addInt i1 i2 = return $ i1 + i2 

test :: IO ()
test
  = do
    -- dfun <- newDFunction "add" (addInt)
    dfun <- (newRemoteDFunction address)::(IO (DFunction (Int -> Int -> IO Int)))
    let f = accessDFunction dfun
    res <- f 1 2
    putStrLn $ show res
    return ()
-}