code.grnet.gr Git - ganeti-local/blob - htools/Ganeti/Query/Server.hs

   1 {-# LANGUAGE BangPatterns #-}
   2
   3 {-| Implementation of the Ganeti Query2 server.
   4
   5 -}
   6
   7 {-
   8
   9 Copyright (C) 2012 Google Inc.
  10
  11 This program is free software; you can redistribute it and/or modify
  12 it under the terms of the GNU General Public License as published by
  13 the Free Software Foundation; either version 2 of the License, or
  14 (at your option) any later version.
  15
  16 This program is distributed in the hope that it will be useful, but
  17 WITHOUT ANY WARRANTY; without even the implied warranty of
  18 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 General Public License for more details.
  20
  21 You should have received a copy of the GNU General Public License
  22 along with this program; if not, write to the Free Software
  23 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  24 02110-1301, USA.
  25
  26 -}
  27
  28 module Ganeti.Query.Server
  29   ( ConfigReader
  30   , runQueryD
  31   ) where
  32
  33 import Control.Applicative
  34 import Control.Concurrent
  35 import Control.Exception
  36 import Data.Bits (bitSize)
  37 import Data.Maybe
  38 import qualified Network.Socket as S
  39 import qualified Text.JSON as J
  40 import Text.JSON (showJSON, JSValue(..))
  41 import Text.JSON.Pretty (pp_value)
  42 import System.Info (arch)
  43
  44 import qualified Ganeti.Constants as C
  45 import qualified Ganeti.Path as Path
  46 import Ganeti.Daemon
  47 import Ganeti.Objects
  48 import qualified Ganeti.Config as Config
  49 import Ganeti.BasicTypes
  50 import Ganeti.Logging
  51 import Ganeti.Luxi
  52 import qualified Ganeti.Query.Language as Qlang
  53 import Ganeti.Query.Query
  54 import Ganeti.Query.Filter (makeSimpleFilter)
  55
  56 -- | A type for functions that can return the configuration when
  57 -- executed.
  58 type ConfigReader = IO (Result ConfigData)
  59
  60 -- | Helper for classic queries.
  61 handleClassicQuery :: ConfigData      -- ^ Cluster config
  62                    -> Qlang.ItemType  -- ^ Query type
  63                    -> [String]        -- ^ Requested names (empty means all)
  64                    -> [String]        -- ^ Requested fields
  65                    -> Bool            -- ^ Whether to do sync queries or not
  66                    -> IO (Result JSValue)
  67 handleClassicQuery _ _ _ _ True = return . Bad $ "Sync queries are not allowed"
  68 handleClassicQuery cfg qkind names fields _ = do
  69   let flt = makeSimpleFilter (nameField qkind) names
  70   qr <- query cfg True (Qlang.Query qkind fields flt)
  71   return $ showJSON <$> (qr >>= queryCompat)
  72
  73 -- | Minimal wrapper to handle the missing config case.
  74 handleCallWrapper :: Result ConfigData -> LuxiOp -> IO (Result JSValue)
  75 handleCallWrapper (Bad msg) _ =
  76   return . Bad $ "I do not have access to a valid configuration, cannot\
  77                  \ process queries: " ++ msg
  78 handleCallWrapper (Ok config) op = handleCall config op
  79
  80 -- | Actual luxi operation handler.
  81 handleCall :: ConfigData -> LuxiOp -> IO (Result JSValue)
  82 handleCall cdata QueryClusterInfo =
  83   let cluster = configCluster cdata
  84       hypervisors = clusterEnabledHypervisors cluster
  85       bits = show (bitSize (0::Int)) ++ "bits"
  86       arch_tuple = [bits, arch]
  87       obj = [ ("software_version", showJSON C.releaseVersion)
  88             , ("protocol_version", showJSON C.protocolVersion)
  89             , ("config_version", showJSON C.configVersion)
  90             , ("os_api_version", showJSON $ maximum C.osApiVersions)
  91             , ("export_version", showJSON C.exportVersion)
  92             , ("architecture", showJSON arch_tuple)
  93             , ("name", showJSON $ clusterClusterName cluster)
  94             , ("master", showJSON $ clusterMasterNode cluster)
  95             , ("default_hypervisor", showJSON $ head hypervisors)
  96             , ("enabled_hypervisors", showJSON hypervisors)
  97             , ("hvparams", showJSON $ clusterHvparams cluster)
  98             , ("os_hvp", showJSON $ clusterOsHvp cluster)
  99             , ("beparams", showJSON $ clusterBeparams cluster)
 100             , ("osparams", showJSON $ clusterOsparams cluster)
 101             , ("ipolicy", showJSON $ clusterIpolicy cluster)
 102             , ("nicparams", showJSON $ clusterNicparams cluster)
 103             , ("ndparams", showJSON $ clusterNdparams cluster)
 104             , ("diskparams", showJSON $ clusterDiskparams cluster)
 105             , ("candidate_pool_size",
 106                showJSON $ clusterCandidatePoolSize cluster)
 107             , ("master_netdev",  showJSON $ clusterMasterNetdev cluster)
 108             , ("master_netmask", showJSON $ clusterMasterNetmask cluster)
 109             , ("use_external_mip_script",
 110                showJSON $ clusterUseExternalMipScript cluster)
 111             , ("volume_group_name", showJSON $ clusterVolumeGroupName cluster)
 112             , ("drbd_usermode_helper",
 113                maybe JSNull showJSON (clusterDrbdUsermodeHelper cluster))
 114             , ("file_storage_dir", showJSON $ clusterFileStorageDir cluster)
 115             , ("shared_file_storage_dir",
 116                showJSON $ clusterSharedFileStorageDir cluster)
 117             , ("maintain_node_health",
 118                showJSON $ clusterMaintainNodeHealth cluster)
 119             , ("ctime", showJSON $ clusterCtime cluster)
 120             , ("mtime", showJSON $ clusterMtime cluster)
 121             , ("uuid", showJSON $ clusterUuid cluster)
 122             , ("tags", showJSON $ clusterTags cluster)
 123             , ("uid_pool", showJSON $ clusterUidPool cluster)
 124             , ("default_iallocator",
 125                showJSON $ clusterDefaultIallocator cluster)
 126             , ("reserved_lvs", showJSON $ clusterReservedLvs cluster)
 127             , ("primary_ip_version",
 128                showJSON . ipFamilyToVersion $ clusterPrimaryIpFamily cluster)
 129              , ("prealloc_wipe_disks",
 130                 showJSON $ clusterPreallocWipeDisks cluster)
 131              , ("hidden_os", showJSON $ clusterHiddenOs cluster)
 132              , ("blacklisted_os", showJSON $ clusterBlacklistedOs cluster)
 133             ]
 134
 135   in return . Ok . J.makeObj $ obj
 136
 137 handleCall cfg (QueryTags kind name) =
 138   let tags = case kind of
 139                TagCluster -> Ok . clusterTags $ configCluster cfg
 140                TagGroup -> groupTags <$> Config.getGroup cfg name
 141                TagNode -> nodeTags <$> Config.getNode cfg name
 142                TagInstance -> instTags <$> Config.getInstance cfg name
 143   in return (J.showJSON <$> tags)
 144
 145 handleCall cfg (Query qkind qfields qfilter) = do
 146   result <- query cfg True (Qlang.Query qkind qfields qfilter)
 147   return $ J.showJSON <$> result
 148
 149 handleCall _ (QueryFields qkind qfields) = do
 150   let result = queryFields (Qlang.QueryFields qkind qfields)
 151   return $ J.showJSON <$> result
 152
 153 handleCall cfg (QueryNodes names fields lock) =
 154   handleClassicQuery cfg Qlang.QRNode names fields lock
 155
 156 handleCall cfg (QueryGroups names fields lock) =
 157   handleClassicQuery cfg Qlang.QRGroup names fields lock
 158
 159 handleCall _ op =
 160   return . Bad $ "Luxi call '" ++ strOfOp op ++ "' not implemented"
 161
 162
 163 -- | Given a decoded luxi request, executes it and sends the luxi
 164 -- response back to the client.
 165 handleClientMsg :: Client -> ConfigReader -> LuxiOp -> IO Bool
 166 handleClientMsg client creader args = do
 167   cfg <- creader
 168   logDebug $ "Request: " ++ show args
 169   call_result <- handleCallWrapper cfg args
 170   (!status, !rval) <-
 171     case call_result of
 172       Bad err -> do
 173         let errmsg = "Failed to execute request: " ++ err
 174         logWarning errmsg
 175         return (False, showJSON errmsg)
 176       Ok result -> do
 177         logDebug $ "Result " ++ show (pp_value result)
 178         return (True, result)
 179   sendMsg client $ buildResponse status rval
 180   return True
 181
 182 -- | Handles one iteration of the client protocol: receives message,
 183 -- checks for validity and decods, returns response.
 184 handleClient :: Client -> ConfigReader -> IO Bool
 185 handleClient client creader = do
 186   !msg <- recvMsgExt client
 187   case msg of
 188     RecvConnClosed -> logDebug "Connection closed" >> return False
 189     RecvError err -> logWarning ("Error during message receiving: " ++ err) >>
 190                      return False
 191     RecvOk payload ->
 192       case validateCall payload >>= decodeCall of
 193         Bad err -> do
 194              let errmsg = "Failed to parse request: " ++ err
 195              logWarning errmsg
 196              sendMsg client $ buildResponse False (showJSON errmsg)
 197              return False
 198         Ok args -> handleClientMsg client creader args
 199
 200 -- | Main client loop: runs one loop of 'handleClient', and if that
 201 -- doesn't repot a finished (closed) connection, restarts itself.
 202 clientLoop :: Client -> ConfigReader -> IO ()
 203 clientLoop client creader = do
 204   result <- handleClient client creader
 205   if result
 206     then clientLoop client creader
 207     else closeClient client
 208
 209 -- | Main loop: accepts clients, forks an I/O thread to handle that
 210 -- client, and then restarts.
 211 mainLoop :: ConfigReader -> S.Socket -> IO ()
 212 mainLoop creader socket = do
 213   client <- acceptClient socket
 214   _ <- forkIO $ clientLoop client creader
 215   mainLoop creader socket
 216
 217 -- | Main function that runs the query endpoint. This should be the
 218 -- only one exposed from this module.
 219 runQueryD :: Maybe FilePath -> ConfigReader -> IO ()
 220 runQueryD fpath creader = do
 221   let socket_path = fromMaybe Path.defaultQuerySocket fpath
 222   cleanupSocket socket_path
 223   bracket
 224     (getServer socket_path)
 225     (closeServer socket_path)
 226     (mainLoop creader)