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

   1 {-# LANGUAGE BangPatterns #-}
   2
   3 {-| Implementation of the Ganeti Query2 server.
   4
   5 -}
   6
   7 {-
   8
   9 Copyright (C) 2012, 2013 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   , prepQueryD
  31   , runQueryD
  32   ) where
  33
  34 import Control.Applicative
  35 import Control.Concurrent
  36 import Control.Exception
  37 import Data.Bits (bitSize)
  38 import Data.Maybe
  39 import qualified Network.Socket as S
  40 import qualified Text.JSON as J
  41 import Text.JSON (showJSON, JSValue(..))
  42 import System.Info (arch)
  43
  44 import qualified Ganeti.Constants as C
  45 import Ganeti.Errors
  46 import qualified Ganeti.Path as Path
  47 import Ganeti.Daemon
  48 import Ganeti.Objects
  49 import qualified Ganeti.Config as Config
  50 import Ganeti.BasicTypes
  51 import Ganeti.Logging
  52 import Ganeti.Luxi
  53 import Ganeti.OpCodes (TagObject(..))
  54 import qualified Ganeti.Query.Language as Qlang
  55 import qualified Ganeti.Query.Cluster as QCluster
  56 import Ganeti.Query.Query
  57 import Ganeti.Query.Filter (FilterConstructor, makeSimpleFilter
  58                            , makeHostnameFilter)
  59
  60 -- | A type for functions that can return the configuration when
  61 -- executed.
  62 type ConfigReader = IO (Result ConfigData)
  63
  64 -- | Helper for classic queries.
  65 handleClassicQuery :: ConfigData      -- ^ Cluster config
  66                    -> Qlang.ItemType  -- ^ Query type
  67                    -> [Either String Integer] -- ^ Requested names
  68                                               -- (empty means all)
  69                    -> [String]        -- ^ Requested fields
  70                    -> Maybe FilterConstructor -- ^ the filter algorithm
  71                                               -- to be used, defaults to
  72                                               -- makeSimpleFilter
  73                    -> Bool            -- ^ Whether to do sync queries or not
  74                    -> IO (GenericResult GanetiException JSValue)
  75 handleClassicQuery _ _ _ _ _ True =
  76   return . Bad $ OpPrereqError "Sync queries are not allowed" ECodeInval
  77 handleClassicQuery cfg qkind names fields filterconstr _ = do
  78   let fltcon = fromMaybe makeSimpleFilter filterconstr
  79       flt = fltcon (nameField qkind) names
  80   qr <- query cfg True (Qlang.Query qkind fields flt)
  81   return $ showJSON <$> (qr >>= queryCompat)
  82
  83 -- | Minimal wrapper to handle the missing config case.
  84 handleCallWrapper :: Result ConfigData -> LuxiOp -> IO (ErrorResult JSValue)
  85 handleCallWrapper (Bad msg) _ =
  86   return . Bad . ConfigurationError $
  87            "I do not have access to a valid configuration, cannot\
  88            \ process queries: " ++ msg
  89 handleCallWrapper (Ok config) op = handleCall config op
  90
  91 -- | Actual luxi operation handler.
  92 handleCall :: ConfigData -> LuxiOp -> IO (ErrorResult JSValue)
  93 handleCall cdata QueryClusterInfo =
  94   let cluster = configCluster cdata
  95       master = QCluster.clusterMasterNodeName cdata
  96       hypervisors = clusterEnabledHypervisors cluster
  97       diskTemplates = clusterEnabledDiskTemplates cluster
  98       def_hv = case hypervisors of
  99                  x:_ -> showJSON x
 100                  [] -> JSNull
 101       bits = show (bitSize (0::Int)) ++ "bits"
 102       arch_tuple = [bits, arch]
 103       obj = [ ("software_version", showJSON C.releaseVersion)
 104             , ("protocol_version", showJSON C.protocolVersion)
 105             , ("config_version", showJSON C.configVersion)
 106             , ("os_api_version", showJSON $ maximum C.osApiVersions)
 107             , ("export_version", showJSON C.exportVersion)
 108             , ("architecture", showJSON arch_tuple)
 109             , ("name", showJSON $ clusterClusterName cluster)
 110             , ("master", showJSON (case master of
 111                                      Ok name -> name
 112                                      _ -> undefined))
 113             , ("default_hypervisor", def_hv)
 114             , ("enabled_hypervisors", showJSON hypervisors)
 115             , ("hvparams", showJSON $ clusterHvparams cluster)
 116             , ("os_hvp", showJSON $ clusterOsHvp cluster)
 117             , ("beparams", showJSON $ clusterBeparams cluster)
 118             , ("osparams", showJSON $ clusterOsparams cluster)
 119             , ("ipolicy", showJSON $ clusterIpolicy cluster)
 120             , ("nicparams", showJSON $ clusterNicparams cluster)
 121             , ("ndparams", showJSON $ clusterNdparams cluster)
 122             , ("diskparams", showJSON $ clusterDiskparams cluster)
 123             , ("candidate_pool_size",
 124                showJSON $ clusterCandidatePoolSize cluster)
 125             , ("master_netdev",  showJSON $ clusterMasterNetdev cluster)
 126             , ("master_netmask", showJSON $ clusterMasterNetmask cluster)
 127             , ("use_external_mip_script",
 128                showJSON $ clusterUseExternalMipScript cluster)
 129             , ("volume_group_name",
 130                maybe JSNull showJSON (clusterVolumeGroupName cluster))
 131             , ("drbd_usermode_helper",
 132                maybe JSNull showJSON (clusterDrbdUsermodeHelper cluster))
 133             , ("file_storage_dir", showJSON $ clusterFileStorageDir cluster)
 134             , ("shared_file_storage_dir",
 135                showJSON $ clusterSharedFileStorageDir cluster)
 136             , ("maintain_node_health",
 137                showJSON $ clusterMaintainNodeHealth cluster)
 138             , ("ctime", showJSON $ clusterCtime cluster)
 139             , ("mtime", showJSON $ clusterMtime cluster)
 140             , ("uuid", showJSON $ clusterUuid cluster)
 141             , ("tags", showJSON $ clusterTags cluster)
 142             , ("uid_pool", showJSON $ clusterUidPool cluster)
 143             , ("default_iallocator",
 144                showJSON $ clusterDefaultIallocator cluster)
 145             , ("reserved_lvs", showJSON $ clusterReservedLvs cluster)
 146             , ("primary_ip_version",
 147                showJSON . ipFamilyToVersion $ clusterPrimaryIpFamily cluster)
 148             , ("prealloc_wipe_disks",
 149                showJSON $ clusterPreallocWipeDisks cluster)
 150             , ("hidden_os", showJSON $ clusterHiddenOs cluster)
 151             , ("blacklisted_os", showJSON $ clusterBlacklistedOs cluster)
 152             , ("enabled_disk_templates", showJSON diskTemplates)
 153             ]
 154
 155   in case master of
 156     Ok _ -> return . Ok . J.makeObj $ obj
 157     Bad ex -> return $ Bad ex
 158
 159 handleCall cfg (QueryTags kind) =
 160   let tags = case kind of
 161                TagCluster       -> Ok . clusterTags $ configCluster cfg
 162                TagGroup    name -> groupTags <$> Config.getGroup    cfg name
 163                TagNode     name -> nodeTags  <$> Config.getNode     cfg name
 164                TagInstance name -> instTags  <$> Config.getInstance cfg name
 165   in return (J.showJSON <$> tags)
 166
 167 handleCall cfg (Query qkind qfields qfilter) = do
 168   result <- query cfg True (Qlang.Query qkind qfields qfilter)
 169   return $ J.showJSON <$> result
 170
 171 handleCall _ (QueryFields qkind qfields) = do
 172   let result = queryFields (Qlang.QueryFields qkind qfields)
 173   return $ J.showJSON <$> result
 174
 175 handleCall cfg (QueryNodes names fields lock) =
 176   handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRNode)
 177     (map Left names) fields (Just makeHostnameFilter) lock
 178
 179 handleCall cfg (QueryGroups names fields lock) =
 180   handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRGroup)
 181     (map Left names) fields Nothing lock
 182
 183 handleCall cfg (QueryJobs names fields) =
 184   handleClassicQuery cfg (Qlang.ItemTypeLuxi Qlang.QRJob)
 185     (map (Right . fromIntegral . fromJobId) names)  fields Nothing False
 186
 187 handleCall _ op =
 188   return . Bad $
 189     GenericError ("Luxi call '" ++ strOfOp op ++ "' not implemented")
 190
 191 -- | Given a decoded luxi request, executes it and sends the luxi
 192 -- response back to the client.
 193 handleClientMsg :: Client -> ConfigReader -> LuxiOp -> IO Bool
 194 handleClientMsg client creader args = do
 195   cfg <- creader
 196   logDebug $ "Request: " ++ show args
 197   call_result <- handleCallWrapper cfg args
 198   (!status, !rval) <-
 199     case call_result of
 200       Bad err -> do
 201         logWarning $ "Failed to execute request " ++ show args ++ ": "
 202                      ++ show err
 203         return (False, showJSON err)
 204       Ok result -> do
 205         -- only log the first 2,000 chars of the result
 206         logDebug $ "Result (truncated): " ++ take 2000 (J.encode result)
 207         logInfo $ "Successfully handled " ++ strOfOp args
 208         return (True, result)
 209   sendMsg client $ buildResponse status rval
 210   return True
 211
 212 -- | Handles one iteration of the client protocol: receives message,
 213 -- checks it for validity and decodes it, returns response.
 214 handleClient :: Client -> ConfigReader -> IO Bool
 215 handleClient client creader = do
 216   !msg <- recvMsgExt client
 217   case msg of
 218     RecvConnClosed -> logDebug "Connection closed" >> return False
 219     RecvError err -> logWarning ("Error during message receiving: " ++ err) >>
 220                      return False
 221     RecvOk payload ->
 222       case validateCall payload >>= decodeCall of
 223         Bad err -> do
 224              let errmsg = "Failed to parse request: " ++ err
 225              logWarning errmsg
 226              sendMsg client $ buildResponse False (showJSON errmsg)
 227              return False
 228         Ok args -> handleClientMsg client creader args
 229
 230 -- | Main client loop: runs one loop of 'handleClient', and if that
 231 -- doesn't report a finished (closed) connection, restarts itself.
 232 clientLoop :: Client -> ConfigReader -> IO ()
 233 clientLoop client creader = do
 234   result <- handleClient client creader
 235   if result
 236     then clientLoop client creader
 237     else closeClient client
 238
 239 -- | Main loop: accepts clients, forks an I/O thread to handle that
 240 -- client, and then restarts.
 241 mainLoop :: ConfigReader -> S.Socket -> IO ()
 242 mainLoop creader socket = do
 243   client <- acceptClient socket
 244   _ <- forkIO $ clientLoop client creader
 245   mainLoop creader socket
 246
 247 -- | Function that prepares the server socket.
 248 prepQueryD :: Maybe FilePath -> IO (FilePath, S.Socket)
 249 prepQueryD fpath = do
 250   def_socket <- Path.defaultQuerySocket
 251   let socket_path = fromMaybe def_socket fpath
 252   cleanupSocket socket_path
 253   s <- describeError "binding to the Luxi socket"
 254          Nothing (Just socket_path) $ getServer socket_path
 255   return (socket_path, s)
 256
 257 -- | Main function that runs the query endpoint.
 258 runQueryD :: (FilePath, S.Socket) -> ConfigReader -> IO ()
 259 runQueryD (socket_path, server) creader =
 260   finally
 261     (mainLoop creader server)
 262     (closeServer socket_path server)