From 358a0a8fff16046d068168f0856694c363dbe5d2 Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Thu, 24 Nov 2011 15:04:32 +0100
Subject: [PATCH] htools: add confd server module
This contains a more-or-less complete implementation for the
server-side confd.
Note that most of the code is behaving identical to the Python code,
with a notable exception: the asyncore/inotify code was changed (since
Haskell doesn't have asyncore) to 3-thread system. While otherwise I
tried to keep the code flow identical, I found the original Python
code not easily to reason about, and as such I changed the
architecture in this regard.
Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Guido Trotter <ultrotter@google.com>
---
Makefile.am | 8 +-
htools/Ganeti/Confd/Server.hs | 519 ++++++++++++++++++++++++++++++++++
2 files changed, 526 insertions(+), 1 deletion(-)
create mode 100644 htools/Ganeti/Confd/Server.hs
diff --git a/Makefile.am b/Makefile.am
index 58be12344..03448c33e 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -56,6 +56,7 @@ myexeclibdir = $(pkglibdir)
HTOOLS_DIRS = \
htools \
htools/Ganeti \
+ htools/Ganeti/Confd \
htools/Ganeti/HTools \
htools/Ganeti/HTools/Program
@@ -94,7 +95,9 @@ BUILDTIME_DIR_AUTOCREATE = \
$(APIDOC_DIR) \
$(APIDOC_PY_DIR) \
$(APIDOC_HS_DIR) \
- $(APIDOC_HS_DIR)/Ganeti $(APIDOC_HS_DIR)/Ganeti/HTools \
+ $(APIDOC_HS_DIR)/Ganeti \
+ $(APIDOC_HS_DIR)/Ganeti/Confd \
+ $(APIDOC_HS_DIR)/Ganeti/HTools \
$(APIDOC_HS_DIR)/Ganeti/HTools/Program \
$(COVERAGE_DIR) \
$(COVERAGE_PY_DIR) \
@@ -396,6 +399,7 @@ HS_LIB_SRCS = \
htools/Ganeti/HTools/Program/Hspace.hs \
htools/Ganeti/BasicTypes.hs \
htools/Ganeti/Confd.hs \
+ htools/Ganeti/Confd/Server.hs \
htools/Ganeti/Config.hs \
htools/Ganeti/Daemon.hs \
htools/Ganeti/Hash.hs \
@@ -1322,8 +1326,10 @@ hs-apidoc: $(HS_BUILT_SRCS)
{ echo 'haddock' not found during configure; exit 1; }
rm -rf $(APIDOC_HS_DIR)/*
@mkdir_p@ $(APIDOC_HS_DIR)/Ganeti/HTools/Program
+ @mkdir_p@ $(APIDOC_HS_DIR)/Ganeti/Confd
$(HSCOLOUR) -print-css > $(APIDOC_HS_DIR)/Ganeti/hscolour.css
$(LN_S) ../hscolour.css $(APIDOC_HS_DIR)/Ganeti/HTools/hscolour.css
+ $(LN_S) ../hscolour.css $(APIDOC_HS_DIR)/Ganeti/Confd/hscolour.css
set -e ; \
cd htools; \
if [ "$(HTOOLS_NOCURL)" ]; \
diff --git a/htools/Ganeti/Confd/Server.hs b/htools/Ganeti/Confd/Server.hs
new file mode 100644
index 000000000..743f54dcb
--- /dev/null
+++ b/htools/Ganeti/Confd/Server.hs
@@ -0,0 +1,519 @@
+{-# LANGUAGE BangPatterns #-}
+
+{-| Implementation of the Ganeti confd server functionality.
+
+-}
+
+{-
+
+Copyright (C) 2011 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
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+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.Confd.Server
+ ( main
+ ) where
+
+import Control.Concurrent
+import Control.Monad (forever)
+import qualified Data.ByteString as B
+import Data.IORef
+import Data.List
+import qualified Data.Map as M
+import qualified Network.Socket as S
+import System.Posix.Files
+import System.Posix.Types
+import System.Time
+import qualified Text.JSON as J
+import System.INotify
+
+import Ganeti.Daemon
+import Ganeti.HTools.JSON
+import Ganeti.HTools.Types
+import Ganeti.HTools.Utils
+import Ganeti.Objects
+import Ganeti.Confd
+import Ganeti.Config
+import Ganeti.Hash
+import Ganeti.Logging
+import qualified Ganeti.Constants as C
+
+-- * Types and constants definitions
+
+-- | What we store as configuration.
+type CRef = IORef (Result (ConfigData, LinkIpMap))
+
+-- | File stat identifier.
+type FStat = (EpochTime, FileID, FileOffset)
+
+-- | Null 'FStat' value.
+nullFStat :: FStat
+nullFStat = (-1, -1, -1)
+
+-- | A small type alias for readability.
+type StatusAnswer = (ConfdReplyStatus, J.JSValue)
+
+-- | Reload model data type.
+data ReloadModel = ReloadNotify -- ^ We are using notifications
+ | ReloadPoll Int -- ^ We are using polling
+ deriving (Eq, Show)
+
+-- | Server state data type.
+data ServerState = ServerState
+ { reloadModel :: ReloadModel
+ , reloadTime :: Integer
+ , reloadFStat :: FStat
+ }
+
+-- | Maximum no-reload poll rounds before reverting to inotify.
+maxIdlePollRounds :: Int
+maxIdlePollRounds = 2
+
+-- | Reload timeout in microseconds.
+configReloadTimeout :: Int
+configReloadTimeout = C.confdConfigReloadTimeout * 1000000
+
+-- | Ratelimit timeout in microseconds.
+configReloadRatelimit :: Int
+configReloadRatelimit = C.confdConfigReloadRatelimit * 1000000
+
+-- | Initial poll round.
+initialPoll :: ReloadModel
+initialPoll = ReloadPoll 0
+
+-- | Initial server state.
+initialState :: ServerState
+initialState = ServerState initialPoll 0 nullFStat
+
+-- | Reload status data type.
+data ConfigReload = ConfigToDate -- ^ No need to reload
+ | ConfigReloaded -- ^ Configuration reloaded
+ | ConfigIOError -- ^ Error during configuration reload
+
+-- | Unknown entry standard response.
+queryUnknownEntry :: StatusAnswer
+queryUnknownEntry = (ReplyStatusError, J.showJSON ConfdErrorUnknownEntry)
+
+{- not used yet
+-- | Internal error standard response.
+queryInternalError :: StatusAnswer
+queryInternalError = (ReplyStatusError, J.showJSON ConfdErrorInternal)
+-}
+
+-- | Argument error standard response.
+queryArgumentError :: StatusAnswer
+queryArgumentError = (ReplyStatusError, J.showJSON ConfdErrorArgument)
+
+-- | Returns the current time.
+getCurrentTime :: IO Integer
+getCurrentTime = do
+ TOD ctime _ <- getClockTime
+ return ctime
+
+-- * Confd base functionality
+
+-- | Returns the HMAC key.
+getClusterHmac :: IO HashKey
+getClusterHmac = fmap B.unpack $ B.readFile C.confdHmacKey
+
+-- | Computes the node role.
+nodeRole :: ConfigData -> String -> Result ConfdNodeRole
+nodeRole cfg name =
+ let cmaster = clusterMasterNode . configCluster $ cfg
+ mnode = M.lookup name . configNodes $ cfg
+ in case mnode of
+ Nothing -> Bad "Node not found"
+ Just node | cmaster == name -> Ok NodeRoleMaster
+ | nodeDrained node -> Ok NodeRoleDrained
+ | nodeOffline node -> Ok NodeRoleOffline
+ | nodeMasterCandidate node -> Ok NodeRoleCandidate
+ _ -> Ok NodeRoleRegular
+
+-- | Does an instance ip -> instance -> primary node -> primary ip
+-- transformation.
+getNodePipByInstanceIp :: ConfigData
+ -> LinkIpMap
+ -> String
+ -> String
+ -> StatusAnswer
+getNodePipByInstanceIp cfg linkipmap link instip =
+ case M.lookup instip (M.findWithDefault M.empty link linkipmap) of
+ Nothing -> queryUnknownEntry
+ Just instname ->
+ case getInstPrimaryNode cfg instname of
+ Bad _ -> queryUnknownEntry -- either instance or node not found
+ Ok node -> (ReplyStatusOk, J.showJSON (nodePrimaryIp node))
+
+-- | Builds the response to a given query.
+buildResponse :: (ConfigData, LinkIpMap) -> ConfdRequest -> Result StatusAnswer
+buildResponse (cfg, _) (ConfdRequest { confdRqType = ReqPing }) =
+ return (ReplyStatusOk, J.showJSON (configVersion cfg))
+
+buildResponse cdata req@(ConfdRequest { confdRqType = ReqClusterMaster }) =
+ case confdRqQuery req of
+ EmptyQuery -> return (ReplyStatusOk, J.showJSON master_name)
+ PlainQuery _ -> return queryArgumentError
+ DictQuery reqq -> do
+ mnode <- getNode cfg master_name
+ let fvals =map (\field -> case field of
+ ReqFieldName -> master_name
+ ReqFieldIp -> clusterMasterIp cluster
+ ReqFieldMNodePip -> nodePrimaryIp mnode
+ ) (confdReqQFields reqq)
+ return (ReplyStatusOk, J.showJSON fvals)
+ where master_name = clusterMasterNode cluster
+ cluster = configCluster cfg
+ cfg = fst cdata
+
+buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeRoleByName }) = do
+ node_name <- case confdRqQuery req of
+ PlainQuery str -> return str
+ _ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
+ role <- nodeRole (fst cdata) node_name
+ return (ReplyStatusOk, J.showJSON role)
+
+buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipList }) =
+ -- note: we use foldlWithKey because that's present accross more
+ -- versions of the library
+ return (ReplyStatusOk, J.showJSON $
+ M.foldlWithKey (\accu _ n -> nodePrimaryIp n:accu) []
+ (configNodes (fst cdata)))
+
+buildResponse cdata (ConfdRequest { confdRqType = ReqMcPipList }) =
+ -- note: we use foldlWithKey because that's present accross more
+ -- versions of the library
+ return (ReplyStatusOk, J.showJSON $
+ M.foldlWithKey (\accu _ n -> if nodeMasterCandidate n
+ then nodePrimaryIp n:accu
+ else accu) []
+ (configNodes (fst cdata)))
+
+buildResponse (cfg, linkipmap)
+ req@(ConfdRequest { confdRqType = ReqInstIpsList }) = do
+ link <- case confdRqQuery req of
+ PlainQuery str -> return str
+ EmptyQuery -> return (getDefaultNicLink cfg)
+ _ -> fail "Invalid query type"
+ return (ReplyStatusOk, J.showJSON $ getInstancesIpByLink linkipmap link)
+
+buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipByInstPip
+ , confdRqQuery = DictQuery query}) =
+ let (cfg, linkipmap) = cdata
+ link = maybe (getDefaultNicLink cfg) id (confdReqQLink query)
+ in case confdReqQIp query of
+ Just ip -> return $ getNodePipByInstanceIp cfg linkipmap link ip
+ Nothing -> return (ReplyStatusOk,
+ J.showJSON $
+ map (getNodePipByInstanceIp cfg linkipmap link)
+ (confdReqQIpList query))
+
+buildResponse _ (ConfdRequest { confdRqType = ReqNodePipByInstPip }) =
+ return queryArgumentError
+
+-- | Parses a signed request.
+parseRequest :: HashKey -> String -> Result (String, String, ConfdRequest)
+parseRequest key str = do
+ (SignedMessage hmac msg salt) <- fromJResult "parsing request" $ J.decode str
+ req <- if verifyMac key (Just salt) msg hmac
+ then fromJResult "parsing message" $ J.decode msg
+ else Bad "HMAC verification failed"
+ return (salt, msg, req)
+
+-- | Creates a ConfdReply from a given answer.
+serializeResponse :: Result StatusAnswer -> ConfdReply
+serializeResponse r =
+ let (status, result) = case r of
+ Bad err -> (ReplyStatusError, J.showJSON err)
+ Ok (code, val) -> (code, val)
+ in ConfdReply { confdReplyProtocol = 1
+ , confdReplyStatus = status
+ , confdReplyAnswer = result
+ , confdReplySerial = 0 }
+
+-- | Signs a message with a given key and salt.
+signMessage :: HashKey -> String -> String -> SignedMessage
+signMessage key salt msg =
+ SignedMessage { signedMsgMsg = msg
+ , signedMsgSalt = salt
+ , signedMsgHmac = hmac
+ }
+ where hmac = computeMac key (Just salt) msg
+
+-- * Configuration handling
+
+-- ** Helper functions
+
+-- | Helper function for logging transition into polling mode.
+moveToPolling :: String -> INotify -> FilePath -> CRef -> MVar ServerState
+ -> IO ReloadModel
+moveToPolling msg inotify path cref mstate = do
+ logInfo $ "Moving to polling mode: " ++ msg
+ let inotiaction = addNotifier inotify path cref mstate
+ _ <- forkIO $ onReloadTimer inotiaction path cref mstate
+ return initialPoll
+
+-- | Helper function for logging transition into inotify mode.
+moveToNotify :: IO ReloadModel
+moveToNotify = do
+ logInfo "Moving to inotify mode"
+ return ReloadNotify
+
+-- ** Configuration loading
+
+-- | (Re)loads the configuration.
+updateConfig :: FilePath -> CRef -> IO ()
+updateConfig path r = do
+ newcfg <- loadConfig path
+ let !newdata = case newcfg of
+ Ok !cfg -> Ok (cfg, buildLinkIpInstnameMap cfg)
+ Bad _ -> Bad "Cannot load configuration"
+ writeIORef r newdata
+ case newcfg of
+ Ok cfg -> logInfo ("Loaded new config, serial " ++
+ show (configSerial cfg))
+ Bad msg -> logError $ "Failed to load config: " ++ msg
+ return ()
+
+-- | Wrapper over 'updateConfig' that handles IO errors.
+safeUpdateConfig :: FilePath -> FStat -> CRef -> IO (FStat, ConfigReload)
+safeUpdateConfig path oldfstat cref = do
+ catch (do
+ nt <- needsReload oldfstat path
+ case nt of
+ Nothing -> return (oldfstat, ConfigToDate)
+ Just nt' -> do
+ updateConfig path cref
+ return (nt', ConfigReloaded)
+ ) (\e -> do
+ let msg = "Failure during configuration update: " ++ show e
+ writeIORef cref (Bad msg)
+ return (nullFStat, ConfigIOError)
+ )
+
+-- | Computes the file cache data from a FileStatus structure.
+buildFileStatus :: FileStatus -> FStat
+buildFileStatus ofs =
+ let modt = modificationTime ofs
+ inum = fileID ofs
+ fsize = fileSize ofs
+ in (modt, inum, fsize)
+
+-- | Wrapper over 'buildFileStatus'. This reads the data from the
+-- filesystem and then builds our cache structure.
+getFStat :: FilePath -> IO FStat
+getFStat p = getFileStatus p >>= (return . buildFileStatus)
+
+-- | Check if the file needs reloading
+needsReload :: FStat -> FilePath -> IO (Maybe FStat)
+needsReload oldstat path = do
+ newstat <- getFStat path
+ return $ if newstat /= oldstat
+ then Just newstat
+ else Nothing
+
+-- ** Watcher threads
+
+-- $watcher
+-- We have three threads/functions that can mutate the server state:
+--
+-- 1. the long-interval watcher ('onTimeoutTimer')
+--
+-- 2. the polling watcher ('onReloadTimer')
+--
+-- 3. the inotify event handler ('onInotify')
+--
+-- All of these will mutate the server state under 'modifyMVar' or
+-- 'modifyMVar_', so that server transitions are more or less
+-- atomic. The inotify handler remains active during polling mode, but
+-- checks for polling mode and doesn't do anything in this case (this
+-- check is needed even if we would unregister the event handler due
+-- to how events are serialised).
+
+-- | Long-interval reload watcher.
+--
+-- This is on top of the inotify-based triggered reload.
+onTimeoutTimer :: IO Bool -> FilePath -> CRef -> MVar ServerState -> IO ()
+onTimeoutTimer inotiaction path cref state = do
+ threadDelay configReloadTimeout
+ modifyMVar_ state (onTimeoutInner path cref)
+ _ <- inotiaction
+ onTimeoutTimer inotiaction path cref state
+
+-- | Inner onTimeout handler.
+--
+-- This mutates the server state under a modifyMVar_ call. It never
+-- changes the reload model, just does a safety reload and tried to
+-- re-establish the inotify watcher.
+onTimeoutInner :: FilePath -> CRef -> ServerState -> IO ServerState
+onTimeoutInner path cref state = do
+ (newfstat, _) <- safeUpdateConfig path (reloadFStat state) cref
+ return state { reloadFStat = newfstat }
+
+-- | Short-interval (polling) reload watcher.
+--
+-- This is only active when we're in polling mode; it will
+-- automatically exit when it detects that the state has changed to
+-- notification.
+onReloadTimer :: IO Bool -> FilePath -> CRef -> MVar ServerState -> IO ()
+onReloadTimer inotiaction path cref state = do
+ continue <- modifyMVar state (onReloadInner inotiaction path cref)
+ if continue
+ then do
+ threadDelay configReloadRatelimit
+ onReloadTimer inotiaction path cref state
+ else -- the inotify watch has been re-established, we can exit
+ return ()
+
+-- | Inner onReload handler.
+--
+-- This again mutates the state under a modifyMVar call, and also
+-- returns whether the thread should continue or not.
+onReloadInner :: IO Bool -> FilePath -> CRef -> ServerState
+ -> IO (ServerState, Bool)
+onReloadInner _ _ _ state@(ServerState { reloadModel = ReloadNotify } ) =
+ return (state, False)
+onReloadInner inotiaction path cref
+ state@(ServerState { reloadModel = ReloadPoll pround } ) = do
+ (newfstat, reload) <- safeUpdateConfig path (reloadFStat state) cref
+ let state' = state { reloadFStat = newfstat }
+ -- compute new poll model based on reload data; however, failure to
+ -- re-establish the inotifier means we stay on polling
+ newmode <- case reload of
+ ConfigToDate ->
+ if pround >= maxIdlePollRounds
+ then do -- try to switch to notify
+ result <- inotiaction
+ if result
+ then moveToNotify
+ else return initialPoll
+ else return (ReloadPoll (pround + 1))
+ _ -> return initialPoll
+ let continue = case newmode of
+ ReloadNotify -> False
+ _ -> True
+ return (state' { reloadModel = newmode }, continue)
+
+-- | Setup inotify watcher.
+--
+-- This tries to setup the watch descriptor; in case of any IO errors,
+-- it will return False.
+addNotifier :: INotify -> FilePath -> CRef -> MVar ServerState -> IO Bool
+addNotifier inotify path cref mstate = do
+ catch (addWatch inotify [CloseWrite] path
+ (onInotify inotify path cref mstate) >> return True)
+ (const $ return False)
+
+-- | Inotify event handler.
+onInotify :: INotify -> String -> CRef -> MVar ServerState -> Event -> IO ()
+onInotify inotify path cref mstate Ignored = do
+ logInfo "File lost, trying to re-establish notifier"
+ modifyMVar_ mstate $ \state -> do
+ result <- addNotifier inotify path cref mstate
+ (newfstat, _) <- safeUpdateConfig path (reloadFStat state) cref
+ let state' = state { reloadFStat = newfstat }
+ if result
+ then return state' -- keep notify
+ else do
+ mode <- moveToPolling "cannot re-establish inotify watch" inotify
+ path cref mstate
+ return state' { reloadModel = mode }
+
+onInotify inotify path cref mstate _ = do
+ modifyMVar_ mstate $ \state ->
+ if (reloadModel state == ReloadNotify)
+ then do
+ ctime <- getCurrentTime
+ (newfstat, _) <- safeUpdateConfig path (reloadFStat state) cref
+ let state' = state { reloadFStat = newfstat, reloadTime = ctime }
+ if abs (reloadTime state - ctime) <
+ fromIntegral C.confdConfigReloadRatelimit
+ then do
+ mode <- moveToPolling "too many reloads" inotify path cref mstate
+ return state' { reloadModel = mode }
+ else return state'
+ else return state
+
+-- ** Client input/output handlers
+
+-- | Main loop for a given client.
+responder :: CRef -> S.Socket -> HashKey -> String -> S.SockAddr -> IO ()
+responder cfgref socket hmac msg peer = do
+ ctime <- getCurrentTime
+ case parseMessage hmac msg ctime of
+ Ok (origmsg, rq) -> do
+ logDebug $ "Processing request: " ++ origmsg
+ mcfg <- readIORef cfgref
+ let response = respondInner mcfg hmac rq
+ _ <- S.sendTo socket response peer
+ return ()
+ Bad err -> logInfo $ "Failed to parse incoming message: " ++ err
+ return ()
+
+-- | Mesage parsing. This can either result in a good, valid message,
+-- or fail in the Result monad.
+parseMessage :: HashKey -> String -> Integer
+ -> Result (String, ConfdRequest)
+parseMessage hmac msg curtime = do
+ (salt, origmsg, request) <- parseRequest hmac msg
+ ts <- tryRead "Parsing timestamp" salt::Result Integer
+ if (abs (ts - curtime) > (fromIntegral C.confdMaxClockSkew))
+ then fail "Too old/too new timestamp or clock skew"
+ else return (origmsg, request)
+
+-- | Inner helper function for a given client. This generates the
+-- final encoded message (as a string), ready to be sent out to the
+-- client.
+respondInner :: Result (ConfigData, LinkIpMap) -> HashKey
+ -> ConfdRequest -> String
+respondInner cfg hmac rq =
+ let rsalt = confdRqRsalt rq
+ innermsg = serializeResponse (cfg >>= flip buildResponse rq)
+ innerserialised = J.encodeStrict innermsg
+ outermsg = signMessage hmac rsalt innerserialised
+ outerserialised = confdMagicFourcc ++ J.encodeStrict outermsg
+ in outerserialised
+
+-- | Main listener loop.
+listener :: S.Socket -> HashKey
+ -> (S.Socket -> HashKey -> String -> S.SockAddr -> IO ())
+ -> IO ()
+listener s hmac resp = do
+ (msg, _, peer) <- S.recvFrom s 4096
+ if confdMagicFourcc `isPrefixOf` msg
+ then (forkIO $ resp s hmac (drop 4 msg) peer) >> return ()
+ else logDebug "Invalid magic code!" >> return ()
+ return ()
+
+-- | Main function.
+main :: DaemonOptions -> IO ()
+main opts = do
+ s <- S.socket S.AF_INET S.Datagram S.defaultProtocol
+ let port = maybe C.defaultConfdPort fromIntegral $ optPort opts
+ S.bindSocket s (S.SockAddrInet (fromIntegral port) S.iNADDR_ANY)
+ cref <- newIORef (Bad "Configuration not yet loaded")
+ statemvar <- newMVar initialState
+ hmac <- getClusterHmac
+ -- Inotify setup
+ inotify <- initINotify
+ let inotiaction = addNotifier inotify C.clusterConfFile cref statemvar
+ -- fork the timeout timer
+ _ <- forkIO $ onTimeoutTimer inotiaction C.clusterConfFile cref statemvar
+ -- fork the polling timer
+ _ <- forkIO $ onReloadTimer inotiaction C.clusterConfFile cref statemvar
+ -- and finally enter the responder loop
+ forever $ listener s hmac (responder cref)
--
GitLab