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