module Ganeti.THH.HsRPC
( RpcClientMonad
, runRpcClient
, mkRpcCall
, mkRpcCalls
) where
#define MIN_VERSION_monad_control(maj,min,rev) \
(((maj)<MONAD_CONTROL_MAJOR)|| \
(((maj)==MONAD_CONTROL_MAJOR)&&((min)<=MONAD_CONTROL_MINOR))|| \
(((maj)==MONAD_CONTROL_MAJOR)&&((min)==MONAD_CONTROL_MINOR)&& \
((rev)<=MONAD_CONTROL_REV)))
import Control.Applicative
import Control.Monad
import Control.Monad.Base
import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.Trans.Control
import Language.Haskell.TH
import qualified Text.JSON as J
import Ganeti.BasicTypes
import Ganeti.Errors
import Ganeti.JSON (fromJResultE)
import Ganeti.THH.Types
import Ganeti.UDSServer
newtype RpcClientMonad a =
RpcClientMonad { runRpcClientMonad :: ReaderT Client ResultG a }
deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO,
MonadError GanetiException)
instance MonadBaseControl IO RpcClientMonad where
#if MIN_VERSION_monad_control(1,0,0)
type StM RpcClientMonad b = StM (ReaderT Client ResultG) b
liftBaseWith f = RpcClientMonad . liftBaseWith
$ \r -> f (r . runRpcClientMonad)
restoreM = RpcClientMonad . restoreM
#else
newtype StM RpcClientMonad b = StMRpcClientMonad
{ runStMRpcClientMonad :: StM (ReaderT Client ResultG) b }
liftBaseWith f = RpcClientMonad . liftBaseWith
$ \r -> f (liftM StMRpcClientMonad . r . runRpcClientMonad)
restoreM = RpcClientMonad . restoreM . runStMRpcClientMonad
#endif
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
mkRpcCall :: Name -> Q [Dec]
mkRpcCall name = do
let bname = nameBase name
fname = mkName bname
(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) []
]
mkRpcCalls :: [Name] -> Q [Dec]
mkRpcCalls = liftM concat . mapM mkRpcCall