Commit 358a0a8f authored by Iustin Pop's avatar Iustin Pop
Browse files

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: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarGuido Trotter <ultrotter@google.com>
parent 6ec7a50e
......@@ -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)" ]; \
......
{-# 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)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment