1 {-# LANGUAGE BangPatterns #-}
3 {-| Implementation of the Ganeti Query2 server.
9 Copyright (C) 2012, 2013 Google Inc.
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.
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.
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
28 module Ganeti.Query.Server
34 import Control.Applicative
35 import Control.Concurrent
36 import Control.Exception
37 import Control.Monad (forever)
38 import Data.Bits (bitSize)
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)
45 import qualified Ganeti.Constants as C
47 import qualified Ganeti.Path as Path
50 import qualified Ganeti.Config as Config
51 import Ganeti.ConfigReader
52 import Ganeti.BasicTypes
55 import Ganeti.OpCodes (TagObject(..))
56 import qualified Ganeti.Query.Language as Qlang
57 import Ganeti.Query.Query
58 import Ganeti.Query.Filter (makeSimpleFilter)
60 -- | Helper for classic queries.
61 handleClassicQuery :: ConfigData -- ^ Cluster config
62 -> Qlang.ItemType -- ^ Query type
63 -> [Either String Integer] -- ^ Requested names
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)
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
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
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)
144 in return . Ok . J.makeObj $ obj
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)
154 handleCall cfg (Query qkind qfields qfilter) = do
155 result <- query cfg True (Qlang.Query qkind qfields qfilter)
156 return $ J.showJSON <$> result
158 handleCall _ (QueryFields qkind qfields) = do
159 let result = queryFields (Qlang.QueryFields qkind qfields)
160 return $ J.showJSON <$> result
162 handleCall cfg (QueryNodes names fields lock) =
163 handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRNode)
164 (map Left names) fields lock
166 handleCall cfg (QueryGroups names fields lock) =
167 handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRGroup)
168 (map Left names) fields lock
170 handleCall cfg (QueryJobs names fields) =
171 handleClassicQuery cfg (Qlang.ItemTypeLuxi Qlang.QRJob)
172 (map (Right . fromIntegral . fromJobId) names) fields False
174 handleCall cfg (QueryNetworks names fields lock) =
175 handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRNetwork)
176 (map Left names) fields lock
180 GenericError ("Luxi call '" ++ strOfOp op ++ "' not implemented")
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
187 logDebug $ "Request: " ++ show args
188 call_result <- handleCallWrapper cfg args
192 logWarning $ "Failed to execute request " ++ show args ++ ": "
194 return (False, showJSON err)
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
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
210 RecvConnClosed -> logDebug "Connection closed" >> return False
211 RecvError err -> logWarning ("Error during message receiving: " ++ err) >>
214 case validateCall payload >>= decodeCall of
216 let errmsg = "Failed to parse request: " ++ err
218 sendMsg client $ buildResponse False (showJSON errmsg)
220 Ok args -> handleClientMsg client creader args
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
228 then clientLoop client creader
229 else closeClient client
231 -- | Main listener loop: accepts clients, forks an I/O thread to handle
233 listener :: ConfigReader -> S.Socket -> IO ()
234 listener creader socket = do
235 client <- acceptClient socket
236 _ <- forkIO $ clientLoop client creader
239 -- | Type alias for prepMain results
240 type PrepResult = (FilePath, S.Socket, IORef (Result ConfigData))
242 -- | Check function for luxid.
243 checkMain :: CheckFn ()
244 checkMain _ = return $ Right ()
246 -- | Prepare function for luxid.
247 prepMain :: PrepFn () PrepResult
249 socket_path <- Path.defaultQuerySocket
250 cleanupSocket socket_path
251 s <- describeError "binding to the Luxi socket"
252 Nothing (Just socket_path) $ getServer True socket_path
253 cref <- newIORef (Bad "Configuration not yet loaded")
254 return (socket_path, s, cref)
257 main :: MainFn () PrepResult
258 main _ _ (socket_path, server, cref) = do
259 initConfigReader id cref
260 let creader = readIORef cref
263 (forever $ listener creader server)
264 (closeServer socket_path server)