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

   1 {-# LANGUAGE BangPatterns #-}
   2
   3 {-| Implementation of the Ganeti confd types.
   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.Queryd
  29
  30 where
  31
  32 import Control.Applicative
  33 import Control.Concurrent
  34 import Control.Exception
  35 import Data.Bits (bitSize)
  36 import Data.Maybe
  37 import qualified Network.Socket as S
  38 import qualified Text.JSON as J
  39 import Text.JSON (showJSON, JSValue(..))
  40 import Text.JSON.Pretty (pp_value)
  41 import System.Info (arch)
  42
  43 import qualified Ganeti.Constants as C
  44 import Ganeti.Objects
  45 import qualified Ganeti.Config as Config
  46 import Ganeti.BasicTypes
  47 import Ganeti.Logging
  48 import Ganeti.Luxi
  49
  50
  51 -- | A type for functions that can return the configuration when
  52 -- executed.
  53 type ConfigReader = IO (Result ConfigData)
  54
  55 -- | Minimal wrapper to handle the missing config case.
  56 handleCallWrapper :: Result ConfigData -> LuxiOp -> IO (Result JSValue)
  57 handleCallWrapper (Bad msg) _ =
  58   return . Bad $ "I do not have access to a valid configuration, cannot\
  59                  \ process queries: " ++ msg
  60 handleCallWrapper (Ok config) op = handleCall config op
  61
  62 -- | Actual luxi operation handler.
  63 handleCall :: ConfigData -> LuxiOp -> IO (Result JSValue)
  64 handleCall cdata QueryClusterInfo =
  65   let cluster = configCluster cdata
  66       hypervisors = clusterEnabledHypervisors cluster
  67       bits = show (bitSize (0::Int)) ++ "bits"
  68       arch_tuple = [bits, arch]
  69       -- FIXME: this is for the missing *params fields
  70       empty_params = showJSON $ J.makeObj ([]::[(String, JSValue)])
  71       obj = [ ("software_version", showJSON $ C.releaseVersion)
  72             , ("protocol_version", showJSON $ C.protocolVersion)
  73             , ("config_version", showJSON $ C.configVersion)
  74             , ("os_api_version", showJSON $ maximum C.osApiVersions)
  75             , ("export_version", showJSON $ C.exportVersion)
  76             , ("architecture", showJSON $ arch_tuple)
  77             , ("name", showJSON $ clusterClusterName cluster)
  78             , ("master", showJSON $ clusterMasterNode cluster)
  79             , ("default_hypervisor", showJSON $ head hypervisors)
  80             , ("enabled_hypervisors", showJSON $ hypervisors)
  81             -- FIXME: *params missing
  82             , ("hvparams", empty_params)
  83             , ("os_hvp", empty_params)
  84             , ("beparams", showJSON $ clusterBeparams cluster)
  85             , ("osparams", showJSON $ clusterOsparams cluster)
  86             , ("ipolicy", showJSON $ clusterIpolicy cluster)
  87             , ("nicparams", showJSON $ clusterNicparams cluster)
  88             , ("ndparams", showJSON $ clusterNdparams cluster)
  89             , ("diskparams", empty_params)
  90             , ("candidate_pool_size",
  91                showJSON $ clusterCandidatePoolSize cluster)
  92             , ("master_netdev",  showJSON $ clusterMasterNetdev cluster)
  93             , ("master_netmask", showJSON $ clusterMasterNetmask cluster)
  94             , ("use_external_mip_script",
  95                showJSON $ clusterUseExternalMipScript cluster)
  96             , ("volume_group_name", showJSON $clusterVolumeGroupName cluster)
  97             , ("drbd_usermode_helper",
  98                maybe JSNull showJSON (clusterDrbdUsermodeHelper cluster))
  99             , ("file_storage_dir", showJSON $ clusterFileStorageDir cluster)
 100             , ("shared_file_storage_dir",
 101                showJSON $ clusterSharedFileStorageDir cluster)
 102             , ("maintain_node_health",
 103                showJSON $ clusterMaintainNodeHealth cluster)
 104             , ("ctime", showJSON $ clusterCtime cluster)
 105             , ("mtime", showJSON $ clusterMtime cluster)
 106             , ("uuid", showJSON $ clusterUuid cluster)
 107             , ("tags", showJSON $ clusterTags cluster)
 108             , ("uid_pool", showJSON $ clusterUidPool cluster)
 109             , ("default_iallocator",
 110                showJSON $ clusterDefaultIallocator cluster)
 111             , ("reserved_lvs", showJSON $ clusterReservedLvs cluster)
 112             , ("primary_ip_version",
 113                showJSON . ipFamilyToVersion $ clusterPrimaryIpFamily cluster)
 114              , ("prealloc_wipe_disks",
 115                 showJSON $ clusterPreallocWipeDisks cluster)
 116              , ("hidden_os", showJSON $ clusterHiddenOs cluster)
 117              , ("blacklisted_os", showJSON $ clusterBlacklistedOs cluster)
 118             ]
 119
 120   in return . Ok . J.makeObj $ obj
 121
 122 handleCall cfg (QueryTags kind name) =
 123   let tags = case kind of
 124                TagCluster -> Ok . clusterTags $ configCluster cfg
 125                TagGroup -> groupTags <$> Config.getGroup cfg name
 126                TagNode -> nodeTags <$> Config.getNode cfg name
 127                TagInstance -> instTags <$> Config.getInstance cfg name
 128   in return (J.showJSON <$> tags)
 129
 130 handleCall _ op =
 131   return . Bad $ "Luxi call '" ++ strOfOp op ++ "' not implemented"
 132
 133
 134 -- | Given a decoded luxi request, executes it and sends the luxi
 135 -- response back to the client.
 136 handleClientMsg :: Client -> ConfigReader -> LuxiOp -> IO Bool
 137 handleClientMsg client creader args = do
 138   cfg <- creader
 139   logDebug $ "Request: " ++ show args
 140   call_result <- handleCallWrapper cfg args
 141   (!status, !rval) <-
 142     case call_result of
 143       Bad x -> do
 144         logWarning $ "Failed to execute request: " ++ x
 145         return (False, JSString $ J.toJSString x)
 146       Ok result -> do
 147         logDebug $ "Result " ++ show (pp_value result)
 148         return (True, result)
 149   sendMsg client $ buildResponse status rval
 150   return True
 151
 152 -- | Handles one iteration of the client protocol: receives message,
 153 -- checks for validity and decods, returns response.
 154 handleClient :: Client -> ConfigReader -> IO Bool
 155 handleClient client creader = do
 156   !msg <- recvMsgExt client
 157   case msg of
 158     RecvConnClosed -> logDebug "Connection closed" >> return False
 159     RecvError err -> logWarning ("Error during message receiving: " ++ err) >>
 160                      return False
 161     RecvOk payload ->
 162       case validateCall payload >>= decodeCall of
 163         Bad err -> logWarning ("Failed to parse request: " ++ err) >>
 164                    return False
 165         Ok args -> handleClientMsg client creader args
 166
 167 -- | Main client loop: runs one loop of 'handleClient', and if that
 168 -- doesn't repot a finished (closed) connection, restarts itself.
 169 clientLoop :: Client -> ConfigReader -> IO ()
 170 clientLoop client creader = do
 171   result <- handleClient client creader
 172   if result
 173     then clientLoop client creader
 174     else closeClient client
 175
 176 -- | Main loop: accepts clients, forks an I/O thread to handle that
 177 -- client, and then restarts.
 178 mainLoop :: ConfigReader -> S.Socket -> IO ()
 179 mainLoop creader socket = do
 180   client <- acceptClient socket
 181   _ <- forkIO $ clientLoop client creader
 182   mainLoop creader socket
 183
 184 -- | Main function that runs the query endpoint. This should be the
 185 -- only one exposed from this module.
 186 runQueryD :: Maybe FilePath -> ConfigReader -> IO ()
 187 runQueryD fpath creader = do
 188   let socket_path = fromMaybe C.querySocket fpath
 189   bracket
 190     (getServer socket_path)
 191     (closeServer socket_path)
 192     (mainLoop creader)