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   ( main
  30   , checkMain
  31   , prepMain
  32   ) where
  33
  34 import Control.Applicative
  35 import Control.Concurrent
  36 import Control.Exception
  37 import Control.Monad (forever)
  38 import Data.Bits (bitSize)
  39 import Data.IORef
  40 import qualified Network.Socket as S
  41 import qualified Text.JSON as J
  42 import Text.JSON (showJSON, JSValue(..))
  43 import System.Info (arch)
  44
  45 import qualified Ganeti.Constants as C
  46 import Ganeti.Errors
  47 import qualified Ganeti.Path as Path
  48 import Ganeti.Daemon
  49 import Ganeti.Objects
  50 import qualified Ganeti.Config as Config
  51 import Ganeti.ConfigReader
  52 import Ganeti.BasicTypes
  53 import Ganeti.Logging
  54 import Ganeti.Luxi
  55 import Ganeti.OpCodes (TagObject(..))
  56 import qualified Ganeti.Query.Language as Qlang
  57 import Ganeti.Query.Query
  58 import Ganeti.Query.Filter (makeSimpleFilter)
  59
  60 -- | Helper for classic queries.
  61 handleClassicQuery :: ConfigData      -- ^ Cluster config
  62                    -> Qlang.ItemType  -- ^ Query type
  63                    -> [Either String Integer] -- ^ Requested names
  64                                               -- (empty means all)
  65                    -> [String]        -- ^ Requested fields
  66                    -> Bool            -- ^ Whether to do sync queries or not
  67                    -> IO (GenericResult GanetiException JSValue)
  68 handleClassicQuery _ _ _ _ True =
  69   return . Bad $ OpPrereqError "Sync queries are not allowed" ECodeInval
  70 handleClassicQuery cfg qkind names fields _ = do
  71   let flt = makeSimpleFilter (nameField qkind) names
  72   qr <- query cfg True (Qlang.Query qkind fields flt)
  73   return $ showJSON <$> (qr >>= queryCompat)
  74
  75 -- | Minimal wrapper to handle the missing config case.
  76 handleCallWrapper :: Result ConfigData -> LuxiOp -> IO (ErrorResult JSValue)
  77 handleCallWrapper (Bad msg) _ =
  78   return . Bad . ConfigurationError $
  79            "I do not have access to a valid configuration, cannot\
  80            \ process queries: " ++ msg
  81 handleCallWrapper (Ok config) op = handleCall config op
  82
  83 -- | Actual luxi operation handler.
  84 handleCall :: ConfigData -> LuxiOp -> IO (ErrorResult JSValue)
  85 handleCall cdata QueryClusterInfo =
  86   let cluster = configCluster cdata
  87       hypervisors = clusterEnabledHypervisors cluster
  88       diskTemplates = clusterEnabledDiskTemplates cluster
  89       def_hv = case hypervisors of
  90                  x:_ -> showJSON x
  91                  [] -> JSNull
  92       bits = show (bitSize (0::Int)) ++ "bits"
  93       arch_tuple = [bits, arch]
  94       obj = [ ("software_version", showJSON C.releaseVersion)
  95             , ("protocol_version", showJSON C.protocolVersion)
  96             , ("config_version", showJSON C.configVersion)
  97             , ("os_api_version", showJSON $ maximum C.osApiVersions)
  98             , ("export_version", showJSON C.exportVersion)
  99             , ("architecture", showJSON arch_tuple)
 100             , ("name", showJSON $ clusterClusterName cluster)
 101             , ("master", showJSON $ clusterMasterNode cluster)
 102             , ("default_hypervisor", def_hv)
 103             , ("enabled_hypervisors", showJSON hypervisors)
 104             , ("hvparams", showJSON $ clusterHvparams cluster)
 105             , ("os_hvp", showJSON $ clusterOsHvp cluster)
 106             , ("beparams", showJSON $ clusterBeparams cluster)
 107             , ("osparams", showJSON $ clusterOsparams cluster)
 108             , ("ipolicy", showJSON $ clusterIpolicy cluster)
 109             , ("nicparams", showJSON $ clusterNicparams cluster)
 110             , ("ndparams", showJSON $ clusterNdparams cluster)
 111             , ("diskparams", showJSON $ clusterDiskparams cluster)
 112             , ("candidate_pool_size",
 113                showJSON $ clusterCandidatePoolSize cluster)
 114             , ("master_netdev",  showJSON $ clusterMasterNetdev cluster)
 115             , ("master_netmask", showJSON $ clusterMasterNetmask cluster)
 116             , ("use_external_mip_script",
 117                showJSON $ clusterUseExternalMipScript cluster)
 118             , ("volume_group_name",
 119                maybe JSNull showJSON (clusterVolumeGroupName cluster))
 120             , ("drbd_usermode_helper",
 121                maybe JSNull showJSON (clusterDrbdUsermodeHelper cluster))
 122             , ("file_storage_dir", showJSON $ clusterFileStorageDir cluster)
 123             , ("shared_file_storage_dir",
 124                showJSON $ clusterSharedFileStorageDir cluster)
 125             , ("maintain_node_health",
 126                showJSON $ clusterMaintainNodeHealth cluster)
 127             , ("ctime", showJSON $ clusterCtime cluster)
 128             , ("mtime", showJSON $ clusterMtime cluster)
 129             , ("uuid", showJSON $ clusterUuid cluster)
 130             , ("tags", showJSON $ clusterTags cluster)
 131             , ("uid_pool", showJSON $ clusterUidPool cluster)
 132             , ("default_iallocator",
 133                showJSON $ clusterDefaultIallocator cluster)
 134             , ("reserved_lvs", showJSON $ clusterReservedLvs cluster)
 135             , ("primary_ip_version",
 136                showJSON . ipFamilyToVersion $ clusterPrimaryIpFamily cluster)
 137             , ("prealloc_wipe_disks",
 138                showJSON $ clusterPreallocWipeDisks cluster)
 139             , ("hidden_os", showJSON $ clusterHiddenOs cluster)
 140             , ("blacklisted_os", showJSON $ clusterBlacklistedOs cluster)
 141             , ("enabled_disk_templates", showJSON diskTemplates)
 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 cfg (QueryNetworks names fields lock) =
 175   handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRNetwork)
 176     (map Left names) fields lock
 177
 178 handleCall _ op =
 179   return . Bad $
 180     GenericError ("Luxi call '" ++ strOfOp op ++ "' not implemented")
 181
 182 -- | Given a decoded luxi request, executes it and sends the luxi
 183 -- response back to the client.
 184 handleClientMsg :: Client -> ConfigReader -> LuxiOp -> IO Bool
 185 handleClientMsg client creader args = do
 186   cfg <- creader
 187   logDebug $ "Request: " ++ show args
 188   call_result <- handleCallWrapper cfg args
 189   (!status, !rval) <-
 190     case call_result of
 191       Bad err -> do
 192         logWarning $ "Failed to execute request " ++ show args ++ ": "
 193                      ++ show err
 194         return (False, showJSON err)
 195       Ok result -> do
 196         -- only log the first 2,000 chars of the result
 197         logDebug $ "Result (truncated): " ++ take 2000 (J.encode result)
 198         logInfo $ "Successfully handled " ++ strOfOp args
 199         return (True, result)
 200   sendMsg client $ buildResponse status rval
 201   return True
 202
 203 -- | Handles one iteration of the client protocol: receives message,
 204 -- checks it for validity and decodes it, returns response.
 205 handleClient :: Client -> ConfigReader -> IO Bool
 206 handleClient client creader = do
 207   !msg <- recvMsgExt client
 208   logDebug $ "Received message: " ++ show msg
 209   case msg of
 210     RecvConnClosed -> logDebug "Connection closed" >> return False
 211     RecvError err -> logWarning ("Error during message receiving: " ++ err) >>
 212                      return False
 213     RecvOk payload ->
 214       case validateCall payload >>= decodeCall of
 215         Bad err -> do
 216              let errmsg = "Failed to parse request: " ++ err
 217              logWarning errmsg
 218              sendMsg client $ buildResponse False (showJSON errmsg)
 219              return False
 220         Ok args -> handleClientMsg client creader args
 221
 222 -- | Main client loop: runs one loop of 'handleClient', and if that
 223 -- doesn't report a finished (closed) connection, restarts itself.
 224 clientLoop :: Client -> ConfigReader -> IO ()
 225 clientLoop client creader = do
 226   result <- handleClient client creader
 227   if result
 228     then clientLoop client creader
 229     else closeClient client
 230
 231 -- | Main listener loop: accepts clients, forks an I/O thread to handle
 232 -- that client.
 233 listener :: ConfigReader -> S.Socket -> IO ()
 234 listener creader socket = do
 235   client <- acceptClient socket
 236   _ <- forkIO $ clientLoop client creader
 237   return ()
 238
 239 -- | Type alias for prepMain results
 240 type PrepResult = (FilePath, S.Socket, IORef (Result ConfigData))
 241
 242 -- | Check function for queryd.
 243 checkMain :: CheckFn ()
 244 checkMain _ = return $ Right ()
 245
 246 -- | Prepare function for queryd.
 247 prepMain :: PrepFn () PrepResult
 248 prepMain _ _ = do
 249   socket_path <- Path.defaultQuerySocket
 250   cleanupSocket socket_path
 251   s <- describeError "binding to the Luxi socket"
 252          Nothing (Just socket_path) $ getServer socket_path
 253   cref <- newIORef (Bad "Configuration not yet loaded")
 254   return (socket_path, s, cref)
 255
 256 -- | Main function.
 257 main :: MainFn () PrepResult
 258 main _ _ (socket_path, server, cref) = do
 259   initConfigReader id cref
 260   let creader = readIORef cref
 261
 262   finally
 263     (forever $ listener creader server)
 264     (closeServer socket_path server)