[RFC master 2/6] Add MonadBaseControl instance for RpcClientMonad

['Niklas Hambuechen' via ganeti-devel]

So that exceptions can be caught in the `RpcClientMonad`.

Signed-off-by: Niklas Hambuechen <nikl...@google.com>
---
 src/Ganeti/THH/HsRPC.hs | 11 ++++++++++-
 1 file changed, 10 insertions(+), 1 deletion(-)

diff --git a/src/Ganeti/THH/HsRPC.hs b/src/Ganeti/THH/HsRPC.hs
index 1198e37..751ebfb 100644
--- a/src/Ganeti/THH/HsRPC.hs
+++ b/src/Ganeti/THH/HsRPC.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE TemplateHaskell, FunctionalDependencies, FlexibleContexts #-}
+{-# LANGUAGE TemplateHaskell, FunctionalDependencies, FlexibleContexts,
+  TypeFamilies #-}
 -- {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 
 {-| Creates a client out of list of RPC server components.
@@ -38,6 +39,7 @@ 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
 
@@ -70,6 +72,13 @@ instance Monad RpcClientMonad where
 instance MonadBase IO RpcClientMonad where
   liftBase = RpcClientMonad . liftBase
 
+instance MonadBaseControl IO RpcClientMonad where
+  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
+
 instance MonadIO RpcClientMonad where
   liftIO = RpcClientMonad . liftIO
 
-- 
2.1.0.rc2.206.gedb03e5