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