Synnefo » snf-ganeti » ganeti-local

{-# LANGUAGE BangPatterns #-}

import Control.Exception

import Control.Monad (forever, liftM, unless)

import System.Posix.Files

import System.Posix.Types

import System.INotify

import qualified Ganeti.Path as Path

-- | File stat identifier.

type FStat = (EpochTime, FileID, FileOffset)

-- | Null 'FStat' value.

nullFStat :: FStat

nullFStat = (-1, -1, -1)

-- | 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      -- ^ Reload time (epoch) in microseconds

  , reloadFStat  :: FStat

  }

-- | Maximum no-reload poll rounds before reverting to inotify.

maxIdlePollRounds :: Int

maxIdlePollRounds = 3

-- | Reload timeout in microseconds.

watchInterval :: Int

watchInterval = C.confdConfigReloadTimeout * 1000000

-- | Ratelimit timeout in microseconds.

pollInterval :: Int

pollInterval = C.confdConfigReloadRatelimit

-- | Ratelimit timeout in microseconds, as an 'Integer'.

reloadRatelimit :: Integer

reloadRatelimit = fromIntegral C.confdConfigReloadRatelimit

-- | Initial poll round.

initialPoll :: ReloadModel

initialPoll = ReloadPoll 0

-- | Reload status data type.

data ConfigReload = ConfigToDate    -- ^ No need to reload

                  | ConfigReloaded  -- ^ Configuration reloaded

                  | ConfigIOError   -- ^ Error during configuration reload

                    deriving (Eq)

-- * 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 $ onPollTimer 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 =

  Control.Exception.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::IOError)

             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 = liftM buildFileStatus (getFileStatus p)

-- | 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 ('onWatcherTimer')

--

-- 2. the polling watcher ('onPollTimer')

--

-- 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.

onWatcherTimer :: IO Bool -> FilePath -> CRef -> MVar ServerState -> IO ()

onWatcherTimer inotiaction path cref state = do

  threadDelay watchInterval

  logDebug "Watcher timer fired"

  modifyMVar_ state (onWatcherInner path cref)

  _ <- inotiaction

  onWatcherTimer inotiaction path cref state

-- | Inner onWatcher 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.

onWatcherInner :: FilePath -> CRef -> ServerState -> IO ServerState

onWatcherInner 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.

onPollTimer :: IO Bool -> FilePath -> CRef -> MVar ServerState -> IO ()

onPollTimer inotiaction path cref state = do

  threadDelay pollInterval

  logDebug "Poll timer fired"

  continue <- modifyMVar state (onPollInner inotiaction path cref)

  if continue

    then onPollTimer inotiaction path cref state

    else logDebug "Inotify watch active, polling thread exiting"

-- | Inner onPoll handler.

--

-- This again mutates the state under a modifyMVar call, and also

-- returns whether the thread should continue or not.

onPollInner :: IO Bool -> FilePath -> CRef -> ServerState

              -> IO (ServerState, Bool)

onPollInner _ _ _ state@(ServerState { reloadModel = ReloadNotify } ) =

  return (state, False)

onPollInner 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)

-- the following hint is because hlint doesn't understand our const

-- (return False) is so that we can give a signature to 'e'

{-# ANN addNotifier "HLint: ignore Evaluate" #-}

-- | 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 =

  Control.Exception.catch

        (addWatch inotify [CloseWrite] path

                    (onInotify inotify path cref mstate) >> return True)

        (\e -> const (return False) (e::IOError))

-- | Inotify event handler.

onInotify :: INotify -> String -> CRef -> MVar ServerState -> Event -> IO ()

onInotify inotify path cref mstate Ignored = do

  logDebug "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 _ =

  modifyMVar_ mstate $ \state ->

    if reloadModel state == ReloadNotify

       then do

         ctime <- getCurrentTimeUSec

         (newfstat, _) <- safeUpdateConfig path (reloadFStat state) cref

         let state' = state { reloadFStat = newfstat, reloadTime = ctime }

         if abs (reloadTime state - ctime) < reloadRatelimit

           then do

             mode <- moveToPolling "too many reloads" inotify path cref mstate

             return state' { reloadModel = mode }

           else return state'

      else return state

configReader :: CRef -> IO (Result ConfigData)

  -- Inotify setup

  inotify <- initINotify

  -- try to load the configuration, if possible

  conf_file <- Path.clusterConfFile

  (fstat, reloaded) <- safeUpdateConfig conf_file nullFStat cref

  ctime <- getCurrentTime

  statemvar <- newMVar $ ServerState ReloadNotify ctime fstat

  let inotiaction = addNotifier inotify conf_file cref statemvar

  has_inotify <- if reloaded == ConfigReloaded

                   then inotiaction

                   else return False

  if has_inotify

    then logInfo "Starting up in inotify mode"

    else do

      -- inotify was not enabled, we need to update the reload model

      logInfo "Starting up in polling mode"

      modifyMVar_ statemvar

        (\state -> return state { reloadModel = initialPoll })

  -- fork the timeout timer

  _ <- forkIO $ onWatcherTimer inotiaction conf_file cref statemvar

  -- fork the polling timer

  unless has_inotify $ do

    _ <- forkIO $ onPollTimer inotiaction conf_file cref statemvar

    return ()