ExportedService.hs

-- | An ExportedService is a set of methods which can be involved over the
--   network. Each method has a name, which is unique within the service and
--   the name of the service is unique within the Port that it's bound to.
module Network.RPCA.ExportedService
  ( Callback
  , DispatchTable
  , MethodInfo(..)
  , State(..)
  , newService
  , rpcFunction
  ) where

import Control.Concurrent.STM

import qualified Data.ByteString as BS
import qualified Data.Map as Map

import Network.RPCA.Structs
import Network.RPCA.Util
import qualified Network.RPCA.Port as Port

import qualified Codec.Libevent.Class as Tagged

type DispatchTable = Map.Map String MethodInfo

-- | This is the type of a callback from the RPC system to the client
--   application. The first ByteString is the payload of the RPC
--   and the application should call the callback with a reply structure
--   that has the reply_code filled in
type Callback = Rpcrequest
              -> BS.ByteString
              -> (Rpcreply -> BS.ByteString -> STM ())
              -> IO ()

data MethodInfo = MethodInfo { methcallback :: Callback
                             , methargument :: ()  -- ^ for future reflection
                             , methreply :: () -- ^ for future reflection
                             }

data Service = Service { servname :: String
                       , servstate :: TVar State
                       , servport :: Port.Port
                       , servcbs :: DispatchTable }

data State = Up | Lame | Down deriving (Show, Eq)

-- | This wraps a callback function into the format expected by newService.
--   Until this point, the RPC system is payload format agnostic. This
--   wrapper introduces the assumption that the payload is a codec-libevent
--   structure.
rpcFunction :: (Tagged.TaggedStructure a, Tagged.TaggedStructure b)
            => (a -> ((Maybe b) -> STM ()) -> IO ())
            -- ^ the callback function. The first argument is the decoded
            --   arguments structure. The callback is passed a continuation
            --   which takes a possible reply structure.
            -> a  -- ^ dummy value needed for type inference, can be undefined
            -> b  -- ^ dummy value needed for type inference, can be undefined
            -> Callback
rpcFunction handler _ _ request payload cb = do
  let request = Tagged.deserialise payload
  case request of
       (Left _) -> atomically $ cb (rpcreplyEmpty { rpcreply_reply_code = fromIntegral $ fromEnum ErrPayloadParseFailed }) BS.empty
       (Right request) -> do
         let cb' Nothing = cb (rpcreplyEmpty { rpcreply_reply_code = 32 }) BS.empty
             cb' (Just reply) = cb rpcreplyEmpty $ Tagged.serialise reply
         handler request cb'

-- | Export a new service on a given Port
newService :: Port.Port  -- ^ the port to export the service on
           -> String  -- ^ the service name
           -> State  -- ^ initial state of the service
           -> DispatchTable  -- ^ information about the methods
           -> IO ()
newService port name initstate dispatcht = do
  st <- atomically $ newTVar initstate
  let serv = Service name st port dispatcht
  atomically $ Port.addService port name $ dispatch serv

dispatch :: Service -> Port.Callback
dispatch serv obreq payload cb = do
  state <- atomically $ readTVar $ servstate serv
  let good = case state of Up -> 1; otherwise -> 0
  let id = outboundrequest_id obreq

  case outboundrequest_probe obreq of
    Just _ -> atomically $ cb (inboundreplyEmpty { inboundreply_health = Just (healthreplyEmpty { healthreply_good = good}), inboundreply_id = id }) BS.empty
    Nothing -> return ()

  case outboundrequest_rpc obreq of
    Just rpcreq -> do
      let mmethod = Map.lookup (rpcrequest_method rpcreq) $ servcbs serv
      case mmethod of
        Nothing -> do
          -- return unknown method
          let replyCode = fromIntegral $ fromEnum ErrMethodUnknown
          atomically $ cb (inboundreplyEmpty { inboundreply_rpc = Just (rpcreplyEmpty { rpcreply_reply_code = replyCode }), inboundreply_id = id }) BS.empty
        Just method -> (methcallback method) rpcreq payload $ handleReply obreq cb
    Nothing -> return ()

-- | This is a callback from the service implementation which is called when an
--   RPC is finished and the reply is ready
handleReply :: Outboundrequest  -- ^ the request which resulted in this reply
            -> (Inboundreply -> BS.ByteString -> STM ())
               -- ^ the Port's callback action
            -> Rpcreply  -- ^ the method's reply
            -> BS.ByteString  -- ^ ... and payload
            -> STM ()
handleReply obreq cb rpcreply payload = do
  let ibreply = inboundreplyEmpty { inboundreply_id = outboundrequest_id obreq
                                  , inboundreply_rpc = Just rpcreply }
  cb ibreply payload