[Pkg-ganeti-devel] [ganeti] 72/165: Create a monad in which all Metad operations run

[Apollon Oikonomopoulos]

This is an automated email from the git hooks/post-receive script.

apoikos pushed a commit to branch master
in repository ganeti.

commit 6e876afe6eacc9cbb7fd80b22de0145f6eb5bdf1
Author: Petr Pudlak <pudlak at google.com>
Date:   Tue Jan 27 15:37:52 2015 +0100

    Create a monad in which all Metad operations run
    
    Put the monad, as well as move the current single Metad function into a
    new module ConfigCore.
    
    This is the first step towards using our generated RPC client/server
    mechanism in Metad, just like we do it with WConfd.
    
    The functionality is not changed.
    
    Signed-off-by: Petr Pudlak <pudlak at google.com>
    Reviewed-by: Klaus Aehlig <aehlig at google.com>
---
 Makefile.am                      |   2 +
 src/Ganeti/Metad/ConfigCore.hs   | 123 +++++++++++++++++++++++++++++++++++++++
 src/Ganeti/Metad/ConfigServer.hs |  55 ++++++-----------
 3 files changed, 143 insertions(+), 37 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 2be3981..cab7e21 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1027,6 +1027,7 @@ endif
 if ENABLE_METADATA
 HS_LIB_SRCS += \
 	src/Ganeti/Metad/Config.hs \
+	src/Ganeti/Metad/ConfigCore.hs \
 	src/Ganeti/Metad/ConfigServer.hs \
 	src/Ganeti/Metad/Server.hs \
 	src/Ganeti/Metad/Types.hs \
@@ -1034,6 +1035,7 @@ HS_LIB_SRCS += \
 else
 EXTRA_DIST += \
 	src/Ganeti/Metad/Config.hs \
+	src/Ganeti/Metad/ConfigCore.hs \
 	src/Ganeti/Metad/ConfigServer.hs \
 	src/Ganeti/Metad/Server.hs \
 	src/Ganeti/Metad/Types.hs \
diff --git a/src/Ganeti/Metad/ConfigCore.hs b/src/Ganeti/Metad/ConfigCore.hs
new file mode 100644
index 0000000..6d3295e
--- /dev/null
+++ b/src/Ganeti/Metad/ConfigCore.hs
@@ -0,0 +1,123 @@
+{-# LANGUAGE TupleSections, TemplateHaskell,
+    MultiParamTypeClasses, TypeFamilies, GeneralizedNewtypeDeriving #-}
+{-| Functions of the metadata daemon exported for RPC
+
+-}
+
+{-
+
+Copyright (C) 2014 Google Inc.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+1. Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+-}
+module Ganeti.Metad.ConfigCore where
+
+import Control.Applicative
+import Control.Concurrent.MVar.Lifted
+import Control.Monad
+import Control.Monad.Base
+import Control.Monad.IO.Class
+import Control.Monad.Reader
+import Control.Monad.Trans.Control
+import Language.Haskell.TH (Name)
+import qualified Text.JSON as J
+
+import Ganeti.BasicTypes
+import Ganeti.Errors
+import qualified Ganeti.JSON as J
+import Ganeti.Logging as L
+import Ganeti.Metad.Config as Config
+import Ganeti.Metad.Types (InstanceParams)
+
+-- * The monad in which all the Metad functions execute
+
+data MetadHandle = MetadHandle
+  { mhInstParams :: MVar InstanceParams
+  }
+
+-- | A type alias for easier referring to the actual content of the monad
+-- when implementing its instances.
+type MetadMonadIntType = ReaderT MetadHandle IO
+
+-- | The internal part of the monad without error handling.
+newtype MetadMonadInt a = MetadMonadInt
+  { getMetadMonadInt :: MetadMonadIntType a }
+  deriving ( Functor, Applicative, Monad, MonadIO, MonadBase IO
+           , L.MonadLog )
+
+instance MonadBaseControl IO MetadMonadInt where
+  newtype StM MetadMonadInt b = StMMetadMonadInt
+    { runStMMetadMonadInt :: StM MetadMonadIntType b }
+  liftBaseWith f = MetadMonadInt . liftBaseWith
+                   $ \r -> f (liftM StMMetadMonadInt . r . getMetadMonadInt)
+  restoreM = MetadMonadInt . restoreM . runStMMetadMonadInt
+
+-- | Runs the internal part of the MetadMonad monad on a given daemon
+-- handle.
+runMetadMonadInt :: MetadMonadInt a -> MetadHandle -> IO a
+runMetadMonadInt (MetadMonadInt k) = runReaderT k
+
+-- | The complete monad with error handling.
+type MetadMonad = ResultT GanetiException MetadMonadInt
+
+-- * Basic functions in the monad
+
+metadHandle :: MetadMonad MetadHandle
+metadHandle = lift . MetadMonadInt $ ask
+
+instParams :: MetadMonad InstanceParams
+instParams = readMVar . mhInstParams =<< metadHandle
+
+modifyInstParams :: (InstanceParams -> MetadMonad (InstanceParams, a))
+                 -> MetadMonad a
+modifyInstParams f = do
+  h <- metadHandle
+  modifyMVar (mhInstParams h) f
+
+-- * Functions available to the RPC module
+
+-- Just a debugging function
+echo :: String -> MetadMonad String
+echo = return
+
+-- | Update the configuration with the received instance parameters.
+updateConfig :: J.JSValue -> MetadMonad ()
+updateConfig input = do
+  (name, instanceParams) <- J.fromJResultE "Could not get instance parameters"
+                            $ Config.getInstanceParams input
+  cfg' <- modifyInstParams $ \cfg ->
+    let cfg' = mergeConfig cfg instanceParams
+     in return (cfg', cfg')
+  L.logInfo $
+    "Updated instance " ++ show name ++ " configuration"
+  L.logDebug $ "Instance configuration: " ++ show cfg'
+
+-- * The list of all functions exported to RPC.
+
+exportedFunctions :: [Name]
+exportedFunctions = [ 'echo
+                    , 'updateConfig
+                    ]
diff --git a/src/Ganeti/Metad/ConfigServer.hs b/src/Ganeti/Metad/ConfigServer.hs
index fa492f1..1f1cbb3 100644
--- a/src/Ganeti/Metad/ConfigServer.hs
+++ b/src/Ganeti/Metad/ConfigServer.hs
@@ -34,57 +34,38 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 -}
 module Ganeti.Metad.ConfigServer where
 
-import Control.Concurrent
-import Control.Exception (try, finally)
-import Control.Monad (unless)
-import Text.JSON
-import System.IO.Error (isEOFError)
+import Control.Concurrent (forkIO)
+import Control.Concurrent.MVar (MVar)
+import Control.Exception (finally)
+import qualified Text.JSON as J
 
+import Ganeti.BasicTypes
 import Ganeti.Path as Path
 import Ganeti.Daemon (DaemonOptions, cleanupSocket, describeError)
+import qualified Ganeti.JSON as J
 import qualified Ganeti.Logging as Logging
 import Ganeti.Runtime (GanetiDaemon(..))
 import Ganeti.UDSServer (Client, ConnectConfig(..), Server, ServerConfig(..))
 import qualified Ganeti.UDSServer as UDSServer
 
-import Ganeti.Metad.Config as Config
+import Ganeti.Metad.ConfigCore
 import Ganeti.Metad.Types (InstanceParams)
 
--- | Update the configuration with the received instance parameters.
-updateConfig :: MVar InstanceParams -> String -> IO ()
-updateConfig config str =
-  case decode str of
-    Error err ->
-      Logging.logDebug $ show err
-    Ok x ->
-      case Config.getInstanceParams x of
-        Error err ->
-          Logging.logError $ "Could not get instance parameters: " ++ err
-        Ok (name, instanceParams) -> do
-          cfg <- takeMVar config
-          let cfg' = mergeConfig cfg instanceParams
-          putMVar config cfg'
-          Logging.logInfo $
-            "Updated instance " ++ show name ++ " configuration"
-          Logging.logDebug $ "Instance configuration: " ++ show cfg'
-
 -- | Reads messages from clients and update the configuration
 -- according to these messages.
-acceptConfig :: MVar InstanceParams -> Client -> IO ()
-acceptConfig config client =
-  do res <- try $ UDSServer.recvMsg client
-     case res of
-       Left err -> do
-         unless (isEOFError err) .
-           Logging.logDebug $ show err
-         return ()
-       Right str -> do
-         Logging.logDebug $ "Received: " ++ str
-         updateConfig config str
+acceptConfig :: MetadHandle -> Client -> IO ()
+acceptConfig config client = do
+  result <- runResultT $ do
+    msg <- liftIO $ UDSServer.recvMsg client
+    Logging.logDebug $ "Received: " ++ msg
+    instData <- toErrorStr . J.fromJResultE "Parsing instance data" . J.decode
+                $ msg
+    runMetadMonad (updateConfig instData) config
+  annotateResult "Updating Metad instance configuration" $ withError show result
 
 -- | Loop that accepts clients and dispatches them to an isolated
 -- thread that will handle the client's requests.
-acceptClients :: MVar InstanceParams -> Server -> IO ()
+acceptClients :: MetadHandle -> Server -> IO ()
 acceptClients config server =
   do client <- UDSServer.acceptClient server
      _ <- forkIO $ acceptConfig config client
@@ -97,7 +78,7 @@ start _ config = do
      server <- describeError "binding to the socket" Nothing (Just socket_path)
                $ UDSServer.connectServer metadConfig True socket_path
      finally
-       (acceptClients config server)
+       (acceptClients (MetadHandle config) server)
        (UDSServer.closeServer server)
   where
     metadConfig = ServerConfig GanetiMetad $ ConnectConfig 60 60

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-ganeti/ganeti.git