code.grnet.gr Git - ganeti-local/blob - src/Ganeti/Confd/Server.hs

   1 {-| Implementation of the Ganeti confd server functionality.
   2
   3 -}
   4
   5 {-
   6
   7 Copyright (C) 2011, 2012, 2013 Google Inc.
   8
   9 This program is free software; you can redistribute it and/or modify
  10 it under the terms of the GNU General Public License as published by
  11 the Free Software Foundation; either version 2 of the License, or
  12 (at your option) any later version.
  13
  14 This program is distributed in the hope that it will be useful, but
  15 WITHOUT ANY WARRANTY; without even the implied warranty of
  16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 General Public License for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with this program; if not, write to the Free Software
  21 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  22 02110-1301, USA.
  23
  24 -}
  25
  26 module Ganeti.Confd.Server
  27   ( main
  28   , checkMain
  29   , prepMain
  30   ) where
  31
  32 import Control.Concurrent
  33 import Control.Monad (forever, liftM)
  34 import Data.IORef
  35 import Data.List
  36 import qualified Data.Map as M
  37 import Data.Maybe (fromMaybe)
  38 import qualified Network.Socket as S
  39 import System.Exit
  40 import System.IO
  41 import qualified Text.JSON as J
  42
  43 import Ganeti.BasicTypes
  44 import Ganeti.Errors
  45 import Ganeti.Daemon
  46 import Ganeti.JSON
  47 import Ganeti.Objects
  48 import Ganeti.Confd.Types
  49 import Ganeti.Confd.Utils
  50 import Ganeti.Config
  51 import Ganeti.ConfigReader
  52 import Ganeti.Hash
  53 import Ganeti.Logging
  54 import qualified Ganeti.Constants as C
  55 import qualified Ganeti.Query.Cluster as QCluster
  56 import Ganeti.Utils
  57
  58 -- * Types and constants definitions
  59
  60 -- | What we store as configuration.
  61 type CRef = IORef (Result (ConfigData, LinkIpMap))
  62
  63 -- | A small type alias for readability.
  64 type StatusAnswer = (ConfdReplyStatus, J.JSValue)
  65
  66 -- | Unknown entry standard response.
  67 queryUnknownEntry :: StatusAnswer
  68 queryUnknownEntry = (ReplyStatusError, J.showJSON ConfdErrorUnknownEntry)
  69
  70 {- not used yet
  71 -- | Internal error standard response.
  72 queryInternalError :: StatusAnswer
  73 queryInternalError = (ReplyStatusError, J.showJSON ConfdErrorInternal)
  74 -}
  75
  76 -- | Argument error standard response.
  77 queryArgumentError :: StatusAnswer
  78 queryArgumentError = (ReplyStatusError, J.showJSON ConfdErrorArgument)
  79
  80 -- | Converter from specific error to a string format.
  81 gntErrorToResult :: ErrorResult a -> Result a
  82 gntErrorToResult (Bad err) = Bad (show err)
  83 gntErrorToResult (Ok x) = Ok x
  84
  85 -- * Confd base functionality
  86
  87 -- | Computes the node role.
  88 nodeRole :: ConfigData -> String -> Result ConfdNodeRole
  89 nodeRole cfg name = do
  90   cmaster <- errToResult $ QCluster.clusterMasterNodeName cfg
  91   mnode <- errToResult $ getNode cfg name
  92   let role = case mnode of
  93                node | cmaster == name -> NodeRoleMaster
  94                     | nodeDrained node -> NodeRoleDrained
  95                     | nodeOffline node -> NodeRoleOffline
  96                     | nodeMasterCandidate node -> NodeRoleCandidate
  97                _ -> NodeRoleRegular
  98   return role
  99
 100 -- | Does an instance ip -> instance -> primary node -> primary ip
 101 -- transformation.
 102 getNodePipByInstanceIp :: ConfigData
 103                        -> LinkIpMap
 104                        -> String
 105                        -> String
 106                        -> StatusAnswer
 107 getNodePipByInstanceIp cfg linkipmap link instip =
 108   case M.lookup instip (M.findWithDefault M.empty link linkipmap) of
 109     Nothing -> queryUnknownEntry
 110     Just instname ->
 111       case getInstPrimaryNode cfg instname of
 112         Bad _ -> queryUnknownEntry -- either instance or node not found
 113         Ok node -> (ReplyStatusOk, J.showJSON (nodePrimaryIp node))
 114
 115 -- | Builds the response to a given query.
 116 buildResponse :: (ConfigData, LinkIpMap) -> ConfdRequest -> Result StatusAnswer
 117 buildResponse (cfg, _) (ConfdRequest { confdRqType = ReqPing }) =
 118   return (ReplyStatusOk, J.showJSON (configVersion cfg))
 119
 120 buildResponse cdata req@(ConfdRequest { confdRqType = ReqClusterMaster }) =
 121   case confdRqQuery req of
 122     EmptyQuery -> liftM ((,) ReplyStatusOk . J.showJSON) master_name
 123     PlainQuery _ -> return queryArgumentError
 124     DictQuery reqq -> do
 125       mnode <- gntErrorToResult $ getNode cfg master_uuid
 126       mname <- master_name
 127       let fvals = map (\field -> case field of
 128                                    ReqFieldName -> mname
 129                                    ReqFieldIp -> clusterMasterIp cluster
 130                                    ReqFieldMNodePip -> nodePrimaryIp mnode
 131                       ) (confdReqQFields reqq)
 132       return (ReplyStatusOk, J.showJSON fvals)
 133     where master_uuid = clusterMasterNode cluster
 134           master_name = errToResult $ QCluster.clusterMasterNodeName cfg
 135           cluster = configCluster cfg
 136           cfg = fst cdata
 137
 138 buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeRoleByName }) = do
 139   node_name <- case confdRqQuery req of
 140                  PlainQuery str -> return str
 141                  _ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
 142   role <- nodeRole (fst cdata) node_name
 143   return (ReplyStatusOk, J.showJSON role)
 144
 145 buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipList }) =
 146   -- note: we use foldlWithKey because that's present accross more
 147   -- versions of the library
 148   return (ReplyStatusOk, J.showJSON $
 149           M.foldlWithKey (\accu _ n -> nodePrimaryIp n:accu) []
 150           (fromContainer . configNodes . fst $ cdata))
 151
 152 buildResponse cdata (ConfdRequest { confdRqType = ReqMcPipList }) =
 153   -- note: we use foldlWithKey because that's present accross more
 154   -- versions of the library
 155   return (ReplyStatusOk, J.showJSON $
 156           M.foldlWithKey (\accu _ n -> if nodeMasterCandidate n
 157                                          then nodePrimaryIp n:accu
 158                                          else accu) []
 159           (fromContainer . configNodes . fst $ cdata))
 160
 161 buildResponse (cfg, linkipmap)
 162               req@(ConfdRequest { confdRqType = ReqInstIpsList }) = do
 163   link <- case confdRqQuery req of
 164             PlainQuery str -> return str
 165             EmptyQuery -> return (getDefaultNicLink cfg)
 166             _ -> fail "Invalid query type"
 167   return (ReplyStatusOk, J.showJSON $ getInstancesIpByLink linkipmap link)
 168
 169 buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipByInstPip
 170                                   , confdRqQuery = DictQuery query}) =
 171   let (cfg, linkipmap) = cdata
 172       link = fromMaybe (getDefaultNicLink cfg) (confdReqQLink query)
 173   in case confdReqQIp query of
 174        Just ip -> return $ getNodePipByInstanceIp cfg linkipmap link ip
 175        Nothing -> return (ReplyStatusOk,
 176                           J.showJSON $
 177                            map (getNodePipByInstanceIp cfg linkipmap link)
 178                            (confdReqQIpList query))
 179
 180 buildResponse _ (ConfdRequest { confdRqType = ReqNodePipByInstPip }) =
 181   return queryArgumentError
 182
 183 buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeDrbd }) = do
 184   let cfg = fst cdata
 185   node_name <- case confdRqQuery req of
 186                  PlainQuery str -> return str
 187                  _ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
 188   node <- gntErrorToResult $ getNode cfg node_name
 189   let minors = concatMap (getInstMinorsForNode (nodeName node)) .
 190                M.elems . fromContainer . configInstances $ cfg
 191       encoded = [J.JSArray [J.showJSON a, J.showJSON b, J.showJSON c,
 192                              J.showJSON d, J.showJSON e, J.showJSON f] |
 193                  (a, b, c, d, e, f) <- minors]
 194   return (ReplyStatusOk, J.showJSON encoded)
 195
 196 buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeInstances }) = do
 197   let cfg = fst cdata
 198   node_name <- case confdRqQuery req of
 199                 PlainQuery str -> return str
 200                 _ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
 201   let instances = getNodeInstances cfg node_name
 202   return (ReplyStatusOk, J.showJSON instances)
 203
 204 -- | Creates a ConfdReply from a given answer.
 205 serializeResponse :: Result StatusAnswer -> ConfdReply
 206 serializeResponse r =
 207     let (status, result) = case r of
 208                     Bad err -> (ReplyStatusError, J.showJSON err)
 209                     Ok (code, val) -> (code, val)
 210     in ConfdReply { confdReplyProtocol = 1
 211                   , confdReplyStatus   = status
 212                   , confdReplyAnswer   = result
 213                   , confdReplySerial   = 0 }
 214
 215 -- ** Client input/output handlers
 216
 217 -- | Main loop for a given client.
 218 responder :: CRef -> S.Socket -> HashKey -> String -> S.SockAddr -> IO ()
 219 responder cfgref socket hmac msg peer = do
 220   ctime <- getCurrentTime
 221   case parseRequest hmac msg ctime of
 222     Ok (origmsg, rq) -> do
 223               logDebug $ "Processing request: " ++ rStripSpace origmsg
 224               mcfg <- readIORef cfgref
 225               let response = respondInner mcfg hmac rq
 226               _ <- S.sendTo socket response peer
 227               return ()
 228     Bad err -> logInfo $ "Failed to parse incoming message: " ++ err
 229   return ()
 230
 231 -- | Inner helper function for a given client. This generates the
 232 -- final encoded message (as a string), ready to be sent out to the
 233 -- client.
 234 respondInner :: Result (ConfigData, LinkIpMap) -> HashKey
 235              -> ConfdRequest -> String
 236 respondInner cfg hmac rq =
 237   let rsalt = confdRqRsalt rq
 238       innermsg = serializeResponse (cfg >>= flip buildResponse rq)
 239       innerserialised = J.encodeStrict innermsg
 240       outermsg = signMessage hmac rsalt innerserialised
 241       outerserialised = confdMagicFourcc ++ J.encodeStrict outermsg
 242   in outerserialised
 243
 244 -- | Main listener loop.
 245 listener :: S.Socket -> HashKey
 246          -> (S.Socket -> HashKey -> String -> S.SockAddr -> IO ())
 247          -> IO ()
 248 listener s hmac resp = do
 249   (msg, _, peer) <- S.recvFrom s 4096
 250   if confdMagicFourcc `isPrefixOf` msg
 251     then forkIO (resp s hmac (drop 4 msg) peer) >> return ()
 252     else logDebug "Invalid magic code!" >> return ()
 253   return ()
 254
 255 -- | Type alias for prepMain results
 256 type PrepResult = (S.Socket, IORef (Result (ConfigData, LinkIpMap)))
 257
 258 -- | Check function for confd.
 259 checkMain :: CheckFn (S.Family, S.SockAddr)
 260 checkMain opts = do
 261   parseresult <- parseAddress opts C.defaultConfdPort
 262   case parseresult of
 263     Bad msg -> do
 264       hPutStrLn stderr $ "parsing bind address: " ++ msg
 265       return . Left $ ExitFailure 1
 266     Ok v -> return $ Right v
 267
 268 -- | Prepare function for confd.
 269 prepMain :: PrepFn (S.Family, S.SockAddr) PrepResult
 270 prepMain _ (af_family, bindaddr) = do
 271   s <- S.socket af_family S.Datagram S.defaultProtocol
 272   S.bindSocket s bindaddr
 273   cref <- newIORef (Bad "Configuration not yet loaded")
 274   return (s, cref)
 275
 276 -- | Main function.
 277 main :: MainFn (S.Family, S.SockAddr) PrepResult
 278 main _ _ (s, cref) = do
 279   let cfg_transform :: Result ConfigData -> Result (ConfigData, LinkIpMap)
 280       cfg_transform = liftM (\cfg -> (cfg, buildLinkIpInstnameMap cfg))
 281   initConfigReader cfg_transform cref
 282
 283   hmac <- getClusterHmac
 284   -- enter the responder loop
 285   forever $ listener s hmac (responder cref)