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