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