root / htools / Ganeti / Queryd.hs @ 25779212
History | View | Annotate | Download (7.9 kB)
1 | 25b54de0 | Iustin Pop | {-# LANGUAGE BangPatterns #-} |
---|---|---|---|
2 | 25b54de0 | Iustin Pop | |
3 | 25b54de0 | Iustin Pop | {-| Implementation of the Ganeti confd types. |
4 | 25b54de0 | Iustin Pop | |
5 | 25b54de0 | Iustin Pop | -} |
6 | 25b54de0 | Iustin Pop | |
7 | 25b54de0 | Iustin Pop | {- |
8 | 25b54de0 | Iustin Pop | |
9 | 25b54de0 | Iustin Pop | Copyright (C) 2012 Google Inc. |
10 | 25b54de0 | Iustin Pop | |
11 | 25b54de0 | Iustin Pop | This program is free software; you can redistribute it and/or modify |
12 | 25b54de0 | Iustin Pop | it under the terms of the GNU General Public License as published by |
13 | 25b54de0 | Iustin Pop | the Free Software Foundation; either version 2 of the License, or |
14 | 25b54de0 | Iustin Pop | (at your option) any later version. |
15 | 25b54de0 | Iustin Pop | |
16 | 25b54de0 | Iustin Pop | This program is distributed in the hope that it will be useful, but |
17 | 25b54de0 | Iustin Pop | WITHOUT ANY WARRANTY; without even the implied warranty of |
18 | 25b54de0 | Iustin Pop | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
19 | 25b54de0 | Iustin Pop | General Public License for more details. |
20 | 25b54de0 | Iustin Pop | |
21 | 25b54de0 | Iustin Pop | You should have received a copy of the GNU General Public License |
22 | 25b54de0 | Iustin Pop | along with this program; if not, write to the Free Software |
23 | 25b54de0 | Iustin Pop | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
24 | 25b54de0 | Iustin Pop | 02110-1301, USA. |
25 | 25b54de0 | Iustin Pop | |
26 | 25b54de0 | Iustin Pop | -} |
27 | 25b54de0 | Iustin Pop | |
28 | 25b54de0 | Iustin Pop | module Ganeti.Queryd |
29 | 0d0ac025 | Iustin Pop | ( ConfigReader |
30 | 0d0ac025 | Iustin Pop | , runQueryD |
31 | 0d0ac025 | Iustin Pop | ) where |
32 | 25b54de0 | Iustin Pop | |
33 | f2374060 | Iustin Pop | import Control.Applicative |
34 | 25b54de0 | Iustin Pop | import Control.Concurrent |
35 | 25b54de0 | Iustin Pop | import Control.Exception |
36 | 25b54de0 | Iustin Pop | import Data.Bits (bitSize) |
37 | 25b54de0 | Iustin Pop | import Data.Maybe |
38 | 25b54de0 | Iustin Pop | import qualified Network.Socket as S |
39 | 25b54de0 | Iustin Pop | import qualified Text.JSON as J |
40 | 25b54de0 | Iustin Pop | import Text.JSON (showJSON, JSValue(..)) |
41 | 25b54de0 | Iustin Pop | import Text.JSON.Pretty (pp_value) |
42 | 25b54de0 | Iustin Pop | import System.Info (arch) |
43 | 25b54de0 | Iustin Pop | |
44 | 25b54de0 | Iustin Pop | import qualified Ganeti.Constants as C |
45 | 0d0ac025 | Iustin Pop | import Ganeti.Daemon |
46 | 25b54de0 | Iustin Pop | import Ganeti.Objects |
47 | f2374060 | Iustin Pop | import qualified Ganeti.Config as Config |
48 | 25b54de0 | Iustin Pop | import Ganeti.BasicTypes |
49 | 25b54de0 | Iustin Pop | import Ganeti.Logging |
50 | 25b54de0 | Iustin Pop | import Ganeti.Luxi |
51 | 4cbe9bda | Iustin Pop | import qualified Ganeti.Qlang as Qlang |
52 | 4cbe9bda | Iustin Pop | import Ganeti.Query.Query |
53 | 25b54de0 | Iustin Pop | |
54 | 25b54de0 | Iustin Pop | -- | A type for functions that can return the configuration when |
55 | 25b54de0 | Iustin Pop | -- executed. |
56 | 25b54de0 | Iustin Pop | type ConfigReader = IO (Result ConfigData) |
57 | 25b54de0 | Iustin Pop | |
58 | 25b54de0 | Iustin Pop | -- | Minimal wrapper to handle the missing config case. |
59 | 25b54de0 | Iustin Pop | handleCallWrapper :: Result ConfigData -> LuxiOp -> IO (Result JSValue) |
60 | 25b54de0 | Iustin Pop | handleCallWrapper (Bad msg) _ = |
61 | 25b54de0 | Iustin Pop | return . Bad $ "I do not have access to a valid configuration, cannot\ |
62 | 25b54de0 | Iustin Pop | \ process queries: " ++ msg |
63 | 25b54de0 | Iustin Pop | handleCallWrapper (Ok config) op = handleCall config op |
64 | 25b54de0 | Iustin Pop | |
65 | 25b54de0 | Iustin Pop | -- | Actual luxi operation handler. |
66 | 25b54de0 | Iustin Pop | handleCall :: ConfigData -> LuxiOp -> IO (Result JSValue) |
67 | 25b54de0 | Iustin Pop | handleCall cdata QueryClusterInfo = |
68 | 25b54de0 | Iustin Pop | let cluster = configCluster cdata |
69 | 25b54de0 | Iustin Pop | hypervisors = clusterEnabledHypervisors cluster |
70 | 25b54de0 | Iustin Pop | bits = show (bitSize (0::Int)) ++ "bits" |
71 | 25b54de0 | Iustin Pop | arch_tuple = [bits, arch] |
72 | 25b54de0 | Iustin Pop | obj = [ ("software_version", showJSON $ C.releaseVersion) |
73 | 25b54de0 | Iustin Pop | , ("protocol_version", showJSON $ C.protocolVersion) |
74 | 25b54de0 | Iustin Pop | , ("config_version", showJSON $ C.configVersion) |
75 | 25b54de0 | Iustin Pop | , ("os_api_version", showJSON $ maximum C.osApiVersions) |
76 | 25b54de0 | Iustin Pop | , ("export_version", showJSON $ C.exportVersion) |
77 | 25b54de0 | Iustin Pop | , ("architecture", showJSON $ arch_tuple) |
78 | 25b54de0 | Iustin Pop | , ("name", showJSON $ clusterClusterName cluster) |
79 | 25b54de0 | Iustin Pop | , ("master", showJSON $ clusterMasterNode cluster) |
80 | 25b54de0 | Iustin Pop | , ("default_hypervisor", showJSON $ head hypervisors) |
81 | 25b54de0 | Iustin Pop | , ("enabled_hypervisors", showJSON $ hypervisors) |
82 | a2160e57 | Iustin Pop | , ("hvparams", showJSON $ clusterHvparams cluster) |
83 | a2160e57 | Iustin Pop | , ("os_hvp", showJSON $ clusterOsHvp cluster) |
84 | 25b54de0 | Iustin Pop | , ("beparams", showJSON $ clusterBeparams cluster) |
85 | 25b54de0 | Iustin Pop | , ("osparams", showJSON $ clusterOsparams cluster) |
86 | 25b54de0 | Iustin Pop | , ("ipolicy", showJSON $ clusterIpolicy cluster) |
87 | 25b54de0 | Iustin Pop | , ("nicparams", showJSON $ clusterNicparams cluster) |
88 | 25b54de0 | Iustin Pop | , ("ndparams", showJSON $ clusterNdparams cluster) |
89 | a2160e57 | Iustin Pop | , ("diskparams", showJSON $ clusterDiskparams cluster) |
90 | 25b54de0 | Iustin Pop | , ("candidate_pool_size", |
91 | 25b54de0 | Iustin Pop | showJSON $ clusterCandidatePoolSize cluster) |
92 | 25b54de0 | Iustin Pop | , ("master_netdev", showJSON $ clusterMasterNetdev cluster) |
93 | 25b54de0 | Iustin Pop | , ("master_netmask", showJSON $ clusterMasterNetmask cluster) |
94 | 25b54de0 | Iustin Pop | , ("use_external_mip_script", |
95 | 25b54de0 | Iustin Pop | showJSON $ clusterUseExternalMipScript cluster) |
96 | 25b54de0 | Iustin Pop | , ("volume_group_name", showJSON $clusterVolumeGroupName cluster) |
97 | 25b54de0 | Iustin Pop | , ("drbd_usermode_helper", |
98 | 25b54de0 | Iustin Pop | maybe JSNull showJSON (clusterDrbdUsermodeHelper cluster)) |
99 | 25b54de0 | Iustin Pop | , ("file_storage_dir", showJSON $ clusterFileStorageDir cluster) |
100 | 25b54de0 | Iustin Pop | , ("shared_file_storage_dir", |
101 | 25b54de0 | Iustin Pop | showJSON $ clusterSharedFileStorageDir cluster) |
102 | 25b54de0 | Iustin Pop | , ("maintain_node_health", |
103 | 25b54de0 | Iustin Pop | showJSON $ clusterMaintainNodeHealth cluster) |
104 | 25b54de0 | Iustin Pop | , ("ctime", showJSON $ clusterCtime cluster) |
105 | 25b54de0 | Iustin Pop | , ("mtime", showJSON $ clusterMtime cluster) |
106 | 25b54de0 | Iustin Pop | , ("uuid", showJSON $ clusterUuid cluster) |
107 | 25b54de0 | Iustin Pop | , ("tags", showJSON $ clusterTags cluster) |
108 | 25b54de0 | Iustin Pop | , ("uid_pool", showJSON $ clusterUidPool cluster) |
109 | 25b54de0 | Iustin Pop | , ("default_iallocator", |
110 | 25b54de0 | Iustin Pop | showJSON $ clusterDefaultIallocator cluster) |
111 | 25b54de0 | Iustin Pop | , ("reserved_lvs", showJSON $ clusterReservedLvs cluster) |
112 | 25b54de0 | Iustin Pop | , ("primary_ip_version", |
113 | 25b54de0 | Iustin Pop | showJSON . ipFamilyToVersion $ clusterPrimaryIpFamily cluster) |
114 | 25b54de0 | Iustin Pop | , ("prealloc_wipe_disks", |
115 | 25b54de0 | Iustin Pop | showJSON $ clusterPreallocWipeDisks cluster) |
116 | 25b54de0 | Iustin Pop | , ("hidden_os", showJSON $ clusterHiddenOs cluster) |
117 | 25b54de0 | Iustin Pop | , ("blacklisted_os", showJSON $ clusterBlacklistedOs cluster) |
118 | 25b54de0 | Iustin Pop | ] |
119 | 25b54de0 | Iustin Pop | |
120 | 25b54de0 | Iustin Pop | in return . Ok . J.makeObj $ obj |
121 | 25b54de0 | Iustin Pop | |
122 | f2374060 | Iustin Pop | handleCall cfg (QueryTags kind name) = |
123 | f2374060 | Iustin Pop | let tags = case kind of |
124 | f2374060 | Iustin Pop | TagCluster -> Ok . clusterTags $ configCluster cfg |
125 | f2374060 | Iustin Pop | TagGroup -> groupTags <$> Config.getGroup cfg name |
126 | f2374060 | Iustin Pop | TagNode -> nodeTags <$> Config.getNode cfg name |
127 | f2374060 | Iustin Pop | TagInstance -> instTags <$> Config.getInstance cfg name |
128 | f2374060 | Iustin Pop | in return (J.showJSON <$> tags) |
129 | f2374060 | Iustin Pop | |
130 | 4cbe9bda | Iustin Pop | handleCall cfg (Query qkind qfields qfilter) = do |
131 | 4cbe9bda | Iustin Pop | result <- query cfg (Qlang.Query qkind qfields qfilter) |
132 | 4cbe9bda | Iustin Pop | return $ J.showJSON <$> result |
133 | 4cbe9bda | Iustin Pop | |
134 | 518023a9 | Iustin Pop | handleCall _ (QueryFields qkind qfields) = do |
135 | 518023a9 | Iustin Pop | let result = queryFields (Qlang.QueryFields qkind qfields) |
136 | 518023a9 | Iustin Pop | return $ J.showJSON <$> result |
137 | 518023a9 | Iustin Pop | |
138 | 25b54de0 | Iustin Pop | handleCall _ op = |
139 | 25b54de0 | Iustin Pop | return . Bad $ "Luxi call '" ++ strOfOp op ++ "' not implemented" |
140 | 25b54de0 | Iustin Pop | |
141 | 25b54de0 | Iustin Pop | |
142 | 25b54de0 | Iustin Pop | -- | Given a decoded luxi request, executes it and sends the luxi |
143 | 25b54de0 | Iustin Pop | -- response back to the client. |
144 | 25b54de0 | Iustin Pop | handleClientMsg :: Client -> ConfigReader -> LuxiOp -> IO Bool |
145 | 25b54de0 | Iustin Pop | handleClientMsg client creader args = do |
146 | 25b54de0 | Iustin Pop | cfg <- creader |
147 | 25b54de0 | Iustin Pop | logDebug $ "Request: " ++ show args |
148 | 25b54de0 | Iustin Pop | call_result <- handleCallWrapper cfg args |
149 | 25b54de0 | Iustin Pop | (!status, !rval) <- |
150 | 25b54de0 | Iustin Pop | case call_result of |
151 | 9abbb084 | Iustin Pop | Bad err -> do |
152 | 9abbb084 | Iustin Pop | let errmsg = "Failed to execute request: " ++ err |
153 | 9abbb084 | Iustin Pop | logWarning errmsg |
154 | 9abbb084 | Iustin Pop | return (False, showJSON errmsg) |
155 | 25b54de0 | Iustin Pop | Ok result -> do |
156 | 25b54de0 | Iustin Pop | logDebug $ "Result " ++ show (pp_value result) |
157 | 25b54de0 | Iustin Pop | return (True, result) |
158 | 25b54de0 | Iustin Pop | sendMsg client $ buildResponse status rval |
159 | 25b54de0 | Iustin Pop | return True |
160 | 25b54de0 | Iustin Pop | |
161 | 25b54de0 | Iustin Pop | -- | Handles one iteration of the client protocol: receives message, |
162 | 25b54de0 | Iustin Pop | -- checks for validity and decods, returns response. |
163 | 25b54de0 | Iustin Pop | handleClient :: Client -> ConfigReader -> IO Bool |
164 | 25b54de0 | Iustin Pop | handleClient client creader = do |
165 | 25b54de0 | Iustin Pop | !msg <- recvMsgExt client |
166 | 25b54de0 | Iustin Pop | case msg of |
167 | 25b54de0 | Iustin Pop | RecvConnClosed -> logDebug "Connection closed" >> return False |
168 | 25b54de0 | Iustin Pop | RecvError err -> logWarning ("Error during message receiving: " ++ err) >> |
169 | 25b54de0 | Iustin Pop | return False |
170 | 25b54de0 | Iustin Pop | RecvOk payload -> |
171 | 25b54de0 | Iustin Pop | case validateCall payload >>= decodeCall of |
172 | 9abbb084 | Iustin Pop | Bad err -> do |
173 | 9abbb084 | Iustin Pop | let errmsg = "Failed to parse request: " ++ err |
174 | 9abbb084 | Iustin Pop | logWarning errmsg |
175 | 9abbb084 | Iustin Pop | sendMsg client $ buildResponse False (showJSON errmsg) |
176 | 9abbb084 | Iustin Pop | return False |
177 | 25b54de0 | Iustin Pop | Ok args -> handleClientMsg client creader args |
178 | 25b54de0 | Iustin Pop | |
179 | 25b54de0 | Iustin Pop | -- | Main client loop: runs one loop of 'handleClient', and if that |
180 | 25b54de0 | Iustin Pop | -- doesn't repot a finished (closed) connection, restarts itself. |
181 | 25b54de0 | Iustin Pop | clientLoop :: Client -> ConfigReader -> IO () |
182 | 25b54de0 | Iustin Pop | clientLoop client creader = do |
183 | 25b54de0 | Iustin Pop | result <- handleClient client creader |
184 | 25b54de0 | Iustin Pop | if result |
185 | 25b54de0 | Iustin Pop | then clientLoop client creader |
186 | 25b54de0 | Iustin Pop | else closeClient client |
187 | 25b54de0 | Iustin Pop | |
188 | 25b54de0 | Iustin Pop | -- | Main loop: accepts clients, forks an I/O thread to handle that |
189 | 25b54de0 | Iustin Pop | -- client, and then restarts. |
190 | 25b54de0 | Iustin Pop | mainLoop :: ConfigReader -> S.Socket -> IO () |
191 | 25b54de0 | Iustin Pop | mainLoop creader socket = do |
192 | 25b54de0 | Iustin Pop | client <- acceptClient socket |
193 | 25b54de0 | Iustin Pop | _ <- forkIO $ clientLoop client creader |
194 | 25b54de0 | Iustin Pop | mainLoop creader socket |
195 | 25b54de0 | Iustin Pop | |
196 | 25b54de0 | Iustin Pop | -- | Main function that runs the query endpoint. This should be the |
197 | 25b54de0 | Iustin Pop | -- only one exposed from this module. |
198 | 25b54de0 | Iustin Pop | runQueryD :: Maybe FilePath -> ConfigReader -> IO () |
199 | 25b54de0 | Iustin Pop | runQueryD fpath creader = do |
200 | 25b54de0 | Iustin Pop | let socket_path = fromMaybe C.querySocket fpath |
201 | 0d0ac025 | Iustin Pop | cleanupSocket socket_path |
202 | 25b54de0 | Iustin Pop | bracket |
203 | 25b54de0 | Iustin Pop | (getServer socket_path) |
204 | 25b54de0 | Iustin Pop | (closeServer socket_path) |
205 | 25b54de0 | Iustin Pop | (mainLoop creader) |