InterfacesDFunction.hs

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

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

  Maintainer : Stefan Schmidt (stefanschmidt@web.de)
  Stability  : experimental
  Portability: portable
  Version    : 0.1
  
-}

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

module InterfacesDFunction
(
    RegisterClientFunction
  , UnregisterClientFunction
  , SendChatMessageFunction

  , ServerInterfaceStub
  , RemoteServerInterface(..)
  , createLocalServerInterfaceStub
  , closeLocalServerInterfaceStub
  , createRemoveServerInterface



  , ReceiveChatMessageFunction

  , ClientInterfaceStub
  , RemoteClientInterface(..)
  , createLocalClientInterfaceStub
  , closeLocalClientInterfaceStub
  , createRemoteClientInterface
)
where

import           Data.Binary

import           Holumbus.Distribution.DNode
import           Holumbus.Distribution.DFunction


-- ----------------------------------------------------------------------------
-- the servers' interface
-- ----------------------------------------------------------------------------

-- functions of the chat server
type RegisterClientFunction = String -> DNodeId -> ClientInterfaceStub -> IO (Maybe Int)
type UnregisterClientFunction = Int -> IO ()
type SendChatMessageFunction = Int -> String -> IO ()

-- in theory this could be made binary, but we don't need this
data ServerInterfaceStub = ServerInterfaceStub {
    sifs_register   :: DFunction RegisterClientFunction
  , sifs_unregister :: DFunction UnregisterClientFunction
  , sifs_send       :: DFunction SendChatMessageFunction
  }

-- this cannot be binary, but it is much nicer to call the real functions
data RemoteServerInterface = RemoteServerInterface {
    sif_register   :: RegisterClientFunction
  , sif_unregister :: UnregisterClientFunction
  , sif_send       :: SendChatMessageFunction
  }

createLocalServerInterfaceStub
  :: RegisterClientFunction
  -> UnregisterClientFunction
  -> SendChatMessageFunction
  -> IO ServerInterfaceStub
createLocalServerInterfaceStub f1 f2 f3
  = do
    df1 <- newDFunction "register" f1
    df2 <- newDFunction "unregister" f2
    df3 <- newDFunction "send" f3
    return (ServerInterfaceStub df1 df2 df3)

closeLocalServerInterfaceStub :: ServerInterfaceStub -> IO ()
closeLocalServerInterfaceStub (ServerInterfaceStub df1 df2 df3)
  = do
    closeDFunction df1
    closeDFunction df2
    closeDFunction df3

createRemoveServerInterface :: String -> IO RemoteServerInterface
createRemoveServerInterface sn
  = do
    f1 <- mkNamedServerFunction "register" sn
    f2 <- mkNamedServerFunction "unregister" sn
    f3 <- mkNamedServerFunction "send" sn
    return (RemoteServerInterface f1 f2 f3)
    where
    mkNamedServerFunction :: (BinaryFunction a) => String -> String -> IO a
    mkNamedServerFunction fn sn
      = do
        df <- newRemoteDFunction fn sn
        return (accessDFunction df)


-- ----------------------------------------------------------------------------
-- the client's interface
-- ----------------------------------------------------------------------------

-- functions of the client
type ReceiveChatMessageFunction = String -> String -> IO ()

-- this needs to be binary, because we send this to the server
data ClientInterfaceStub = ClientInterfaceStub {
    cifs_receive :: DFunction ReceiveChatMessageFunction
  }

instance Binary ClientInterfaceStub where
  put (ClientInterfaceStub f1) = put f1
  get = get >>= \f1 -> return (ClientInterfaceStub f1)

-- this cannot be binary, but it is much nicer to call the real functions
data RemoteClientInterface = RemoteClientInterface {
    cif_receive :: ReceiveChatMessageFunction
  }

createLocalClientInterfaceStub :: ReceiveChatMessageFunction -> IO ClientInterfaceStub
createLocalClientInterfaceStub f1
  = do
    df1 <- newDFunction "receive" f1
    return (ClientInterfaceStub df1)

closeLocalClientInterfaceStub :: ClientInterfaceStub -> IO ()
closeLocalClientInterfaceStub (ClientInterfaceStub df1)
  = do
    closeDFunction df1

createRemoteClientInterface :: ClientInterfaceStub -> RemoteClientInterface
createRemoteClientInterface (ClientInterfaceStub df1)
  = (RemoteClientInterface f1)
    where
    f1 = (accessDFunction df1)