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 <[email protected]> --- Makefile.am | 2 + src/Ganeti/Metad/ConfigCore.hs | 123 +++++++++++++++++++++++++++++++++++++++ src/Ganeti/Metad/ConfigServer.hs | 55 ++++++----------- 3 files changed, 143 insertions(+), 37 deletions(-) create mode 100644 src/Ganeti/Metad/ConfigCore.hs diff --git a/Makefile.am b/Makefile.am index 4a71197..7ce3274 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 -- 2.2.0.rc0.207.ga3a616c
