Commit d808bf6e authored by Petr Pudlak's avatar Petr Pudlak
Browse files

Add a module for creating Haskell-to-Haskell RPC clients

It uses TH to create client functions with the corresponding signature
from a given list of server functions.
Signed-off-by: default avatarPetr Pudlak <>
Reviewed-by: default avatarKlaus Aehlig <>
parent 6e1e47d4
......@@ -812,6 +812,7 @@ HS_LIB_SRCS = \
src/Ganeti/Storage/Utils.hs \
src/Ganeti/THH.hs \
src/Ganeti/THH/Field.hs \
src/Ganeti/THH/HsRPC.hs \
src/Ganeti/THH/PyRPC.hs \
src/Ganeti/THH/PyType.hs \
src/Ganeti/THH/Types.hs \
{-# LANGUAGE TemplateHaskell, FunctionalDependencies, FlexibleContexts #-}
-- {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
{-| Creates a client out of list of RPC server components.
Copyright (C) 2014 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.
module Ganeti.THH.HsRPC
( RpcClientMonad
, runRpcClient
, mkRpcCall
, mkRpcCalls
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Base
import Control.Monad.Error
import Control.Monad.Reader
import Data.Char (toLower, toUpper)
import Data.Functor
import Data.List (concat)
import Data.Maybe (fromMaybe)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (liftString)
import qualified Text.JSON as J
import Ganeti.BasicTypes
import Ganeti.Errors
import Ganeti.JSON (fromJResultE)
import Ganeti.THH.Types
import Ganeti.UDSServer
-- * The monad for RPC clients
-- | The monad for all client RPC functions.
-- Given a client value, it runs the RPC call in IO and either retrieves the
-- result or the error.
newtype RpcClientMonad a =
RpcClientMonad { runRpcClientMonad :: ReaderT Client ResultG a }
instance Functor RpcClientMonad where
fmap f = RpcClientMonad . fmap f . runRpcClientMonad
instance Applicative RpcClientMonad where
pure = RpcClientMonad . pure
(RpcClientMonad f) <*> (RpcClientMonad k) = RpcClientMonad (f <*> k)
instance Monad RpcClientMonad where
return = RpcClientMonad . return
(RpcClientMonad k) >>= f = RpcClientMonad (k >>= runRpcClientMonad . f)
instance MonadBase IO RpcClientMonad where
liftBase = RpcClientMonad . liftBase
instance MonadIO RpcClientMonad where
liftIO = RpcClientMonad . liftIO
instance MonadError GanetiException RpcClientMonad where
throwError = RpcClientMonad . throwError
catchError (RpcClientMonad k) h =
RpcClientMonad (catchError k (runRpcClientMonad . h))
-- * The TH functions to construct RPC client functions from RPC server ones
-- | Given a client run a given client RPC action.
runRpcClient :: (MonadBase IO m, MonadError GanetiException m)
=> RpcClientMonad a -> Client -> m a
runRpcClient = (toErrorBase .) . runReaderT . runRpcClientMonad
callMethod :: (J.JSON r, J.JSON args) => String -> args -> RpcClientMonad r
callMethod method args = do
client <- RpcClientMonad ask
let request = buildCall method (J.showJSON args)
liftIO $ sendMsg client request
response <- liftIO $ recvMsg client
toError $ parseResponse response
>>= fromJResultE "Parsing RPC JSON response" . J.readJSON
-- | Given a server RPC function (such as from WConfd.Core), creates
-- the corresponding client function. The monad of the result type of the
-- given function is replaced by 'RpcClientMonad' and the new function
-- is implemented to issue a RPC call to the server.
mkRpcCall :: Name -> Q [Dec]
mkRpcCall name = do
let bname = nameBase name
fname = mkName bname -- the name of the generated function
(args, rtype) <- funArgs <$> typeOfFun name
rarg <- argumentType rtype
let ftype = foldr (\a t -> AppT (AppT ArrowT a) t)
(AppT (ConT ''RpcClientMonad) rarg) args
body <- [| $(curryN $ length args) (callMethod $(stringE bname)) |]
return [ SigD fname ftype
, ValD (VarP fname) (NormalB body) []
-- Given a list of server RPC functions creates the corresponding client
-- RPC functions.
-- See 'mkRpcCall'
mkRpcCalls :: [Name] -> Q [Dec]
mkRpcCalls = liftM concat . mapM mkRpcCall
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment