root / src / Ganeti / Confd / Server.hs @ 3a9fe2bc
History | View | Annotate | Download (10.5 kB)
1 |
{-| Implementation of the Ganeti confd server functionality. |
---|---|
2 |
|
3 |
-} |
4 |
|
5 |
{- |
6 |
|
7 |
Copyright (C) 2011, 2012, 2013 Google Inc. |
8 |
|
9 |
This program is free software; you can redistribute it and/or modify |
10 |
it under the terms of the GNU General Public License as published by |
11 |
the Free Software Foundation; either version 2 of the License, or |
12 |
(at your option) any later version. |
13 |
|
14 |
This program is distributed in the hope that it will be useful, but |
15 |
WITHOUT ANY WARRANTY; without even the implied warranty of |
16 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
17 |
General Public License for more details. |
18 |
|
19 |
You should have received a copy of the GNU General Public License |
20 |
along with this program; if not, write to the Free Software |
21 |
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
22 |
02110-1301, USA. |
23 |
|
24 |
-} |
25 |
|
26 |
module Ganeti.Confd.Server |
27 |
( main |
28 |
, checkMain |
29 |
, prepMain |
30 |
) where |
31 |
|
32 |
import Control.Concurrent |
33 |
import Control.Monad (forever, liftM) |
34 |
import Data.IORef |
35 |
import Data.List |
36 |
import qualified Data.Map as M |
37 |
import Data.Maybe (fromMaybe) |
38 |
import qualified Network.Socket as S |
39 |
import System.Exit |
40 |
import System.IO |
41 |
import qualified Text.JSON as J |
42 |
|
43 |
import Ganeti.BasicTypes |
44 |
import Ganeti.Errors |
45 |
import Ganeti.Daemon |
46 |
import Ganeti.JSON |
47 |
import Ganeti.Objects |
48 |
import Ganeti.Confd.Types |
49 |
import Ganeti.Confd.Utils |
50 |
import Ganeti.Config |
51 |
import Ganeti.ConfigReader |
52 |
import Ganeti.Hash |
53 |
import Ganeti.Logging |
54 |
import qualified Ganeti.Constants as C |
55 |
import Ganeti.Utils |
56 |
|
57 |
-- * Types and constants definitions |
58 |
|
59 |
-- | What we store as configuration. |
60 |
type CRef = IORef (Result (ConfigData, LinkIpMap)) |
61 |
|
62 |
-- | A small type alias for readability. |
63 |
type StatusAnswer = (ConfdReplyStatus, J.JSValue) |
64 |
|
65 |
-- | Unknown entry standard response. |
66 |
queryUnknownEntry :: StatusAnswer |
67 |
queryUnknownEntry = (ReplyStatusError, J.showJSON ConfdErrorUnknownEntry) |
68 |
|
69 |
{- not used yet |
70 |
-- | Internal error standard response. |
71 |
queryInternalError :: StatusAnswer |
72 |
queryInternalError = (ReplyStatusError, J.showJSON ConfdErrorInternal) |
73 |
-} |
74 |
|
75 |
-- | Argument error standard response. |
76 |
queryArgumentError :: StatusAnswer |
77 |
queryArgumentError = (ReplyStatusError, J.showJSON ConfdErrorArgument) |
78 |
|
79 |
-- | Converter from specific error to a string format. |
80 |
gntErrorToResult :: ErrorResult a -> Result a |
81 |
gntErrorToResult (Bad err) = Bad (show err) |
82 |
gntErrorToResult (Ok x) = Ok x |
83 |
|
84 |
-- * Confd base functionality |
85 |
|
86 |
-- | Computes the node role. |
87 |
nodeRole :: ConfigData -> String -> Result ConfdNodeRole |
88 |
nodeRole cfg name = |
89 |
let cmaster = clusterMasterNode . configCluster $ cfg |
90 |
mnode = M.lookup name . fromContainer . configNodes $ cfg |
91 |
in case mnode of |
92 |
Nothing -> Bad "Node not found" |
93 |
Just node | cmaster == name -> Ok NodeRoleMaster |
94 |
| nodeDrained node -> Ok NodeRoleDrained |
95 |
| nodeOffline node -> Ok NodeRoleOffline |
96 |
| nodeMasterCandidate node -> Ok NodeRoleCandidate |
97 |
_ -> Ok NodeRoleRegular |
98 |
|
99 |
-- | Does an instance ip -> instance -> primary node -> primary ip |
100 |
-- transformation. |
101 |
getNodePipByInstanceIp :: ConfigData |
102 |
-> LinkIpMap |
103 |
-> String |
104 |
-> String |
105 |
-> StatusAnswer |
106 |
getNodePipByInstanceIp cfg linkipmap link instip = |
107 |
case M.lookup instip (M.findWithDefault M.empty link linkipmap) of |
108 |
Nothing -> queryUnknownEntry |
109 |
Just instname -> |
110 |
case getInstPrimaryNode cfg instname of |
111 |
Bad _ -> queryUnknownEntry -- either instance or node not found |
112 |
Ok node -> (ReplyStatusOk, J.showJSON (nodePrimaryIp node)) |
113 |
|
114 |
-- | Builds the response to a given query. |
115 |
buildResponse :: (ConfigData, LinkIpMap) -> ConfdRequest -> Result StatusAnswer |
116 |
buildResponse (cfg, _) (ConfdRequest { confdRqType = ReqPing }) = |
117 |
return (ReplyStatusOk, J.showJSON (configVersion cfg)) |
118 |
|
119 |
buildResponse cdata req@(ConfdRequest { confdRqType = ReqClusterMaster }) = |
120 |
case confdRqQuery req of |
121 |
EmptyQuery -> return (ReplyStatusOk, J.showJSON master_name) |
122 |
PlainQuery _ -> return queryArgumentError |
123 |
DictQuery reqq -> do |
124 |
mnode <- gntErrorToResult $ getNode cfg master_name |
125 |
let fvals = map (\field -> case field of |
126 |
ReqFieldName -> master_name |
127 |
ReqFieldIp -> clusterMasterIp cluster |
128 |
ReqFieldMNodePip -> nodePrimaryIp mnode |
129 |
) (confdReqQFields reqq) |
130 |
return (ReplyStatusOk, J.showJSON fvals) |
131 |
where master_name = clusterMasterNode cluster |
132 |
cluster = configCluster cfg |
133 |
cfg = fst cdata |
134 |
|
135 |
buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeRoleByName }) = do |
136 |
node_name <- case confdRqQuery req of |
137 |
PlainQuery str -> return str |
138 |
_ -> fail $ "Invalid query type " ++ show (confdRqQuery req) |
139 |
role <- nodeRole (fst cdata) node_name |
140 |
return (ReplyStatusOk, J.showJSON role) |
141 |
|
142 |
buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipList }) = |
143 |
-- note: we use foldlWithKey because that's present accross more |
144 |
-- versions of the library |
145 |
return (ReplyStatusOk, J.showJSON $ |
146 |
M.foldlWithKey (\accu _ n -> nodePrimaryIp n:accu) [] |
147 |
(fromContainer . configNodes . fst $ cdata)) |
148 |
|
149 |
buildResponse cdata (ConfdRequest { confdRqType = ReqMcPipList }) = |
150 |
-- note: we use foldlWithKey because that's present accross more |
151 |
-- versions of the library |
152 |
return (ReplyStatusOk, J.showJSON $ |
153 |
M.foldlWithKey (\accu _ n -> if nodeMasterCandidate n |
154 |
then nodePrimaryIp n:accu |
155 |
else accu) [] |
156 |
(fromContainer . configNodes . fst $ cdata)) |
157 |
|
158 |
buildResponse (cfg, linkipmap) |
159 |
req@(ConfdRequest { confdRqType = ReqInstIpsList }) = do |
160 |
link <- case confdRqQuery req of |
161 |
PlainQuery str -> return str |
162 |
EmptyQuery -> return (getDefaultNicLink cfg) |
163 |
_ -> fail "Invalid query type" |
164 |
return (ReplyStatusOk, J.showJSON $ getInstancesIpByLink linkipmap link) |
165 |
|
166 |
buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipByInstPip |
167 |
, confdRqQuery = DictQuery query}) = |
168 |
let (cfg, linkipmap) = cdata |
169 |
link = fromMaybe (getDefaultNicLink cfg) (confdReqQLink query) |
170 |
in case confdReqQIp query of |
171 |
Just ip -> return $ getNodePipByInstanceIp cfg linkipmap link ip |
172 |
Nothing -> return (ReplyStatusOk, |
173 |
J.showJSON $ |
174 |
map (getNodePipByInstanceIp cfg linkipmap link) |
175 |
(confdReqQIpList query)) |
176 |
|
177 |
buildResponse _ (ConfdRequest { confdRqType = ReqNodePipByInstPip }) = |
178 |
return queryArgumentError |
179 |
|
180 |
buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeDrbd }) = do |
181 |
let cfg = fst cdata |
182 |
node_name <- case confdRqQuery req of |
183 |
PlainQuery str -> return str |
184 |
_ -> fail $ "Invalid query type " ++ show (confdRqQuery req) |
185 |
node <- gntErrorToResult $ getNode cfg node_name |
186 |
let minors = concatMap (getInstMinorsForNode (nodeName node)) . |
187 |
M.elems . fromContainer . configInstances $ cfg |
188 |
encoded = [J.JSArray [J.showJSON a, J.showJSON b, J.showJSON c, |
189 |
J.showJSON d, J.showJSON e, J.showJSON f] | |
190 |
(a, b, c, d, e, f) <- minors] |
191 |
return (ReplyStatusOk, J.showJSON encoded) |
192 |
|
193 |
buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeInstances }) = do |
194 |
let cfg = fst cdata |
195 |
node_name <- case confdRqQuery req of |
196 |
PlainQuery str -> return str |
197 |
_ -> fail $ "Invalid query type " ++ show (confdRqQuery req) |
198 |
let instances = getNodeInstances cfg node_name |
199 |
return (ReplyStatusOk, J.showJSON instances) |
200 |
|
201 |
-- | Creates a ConfdReply from a given answer. |
202 |
serializeResponse :: Result StatusAnswer -> ConfdReply |
203 |
serializeResponse r = |
204 |
let (status, result) = case r of |
205 |
Bad err -> (ReplyStatusError, J.showJSON err) |
206 |
Ok (code, val) -> (code, val) |
207 |
in ConfdReply { confdReplyProtocol = 1 |
208 |
, confdReplyStatus = status |
209 |
, confdReplyAnswer = result |
210 |
, confdReplySerial = 0 } |
211 |
|
212 |
-- ** Client input/output handlers |
213 |
|
214 |
-- | Main loop for a given client. |
215 |
responder :: CRef -> S.Socket -> HashKey -> String -> S.SockAddr -> IO () |
216 |
responder cfgref socket hmac msg peer = do |
217 |
ctime <- getCurrentTime |
218 |
case parseRequest hmac msg ctime of |
219 |
Ok (origmsg, rq) -> do |
220 |
logDebug $ "Processing request: " ++ rStripSpace origmsg |
221 |
mcfg <- readIORef cfgref |
222 |
let response = respondInner mcfg hmac rq |
223 |
_ <- S.sendTo socket response peer |
224 |
return () |
225 |
Bad err -> logInfo $ "Failed to parse incoming message: " ++ err |
226 |
return () |
227 |
|
228 |
-- | Inner helper function for a given client. This generates the |
229 |
-- final encoded message (as a string), ready to be sent out to the |
230 |
-- client. |
231 |
respondInner :: Result (ConfigData, LinkIpMap) -> HashKey |
232 |
-> ConfdRequest -> String |
233 |
respondInner cfg hmac rq = |
234 |
let rsalt = confdRqRsalt rq |
235 |
innermsg = serializeResponse (cfg >>= flip buildResponse rq) |
236 |
innerserialised = J.encodeStrict innermsg |
237 |
outermsg = signMessage hmac rsalt innerserialised |
238 |
outerserialised = confdMagicFourcc ++ J.encodeStrict outermsg |
239 |
in outerserialised |
240 |
|
241 |
-- | Main listener loop. |
242 |
listener :: S.Socket -> HashKey |
243 |
-> (S.Socket -> HashKey -> String -> S.SockAddr -> IO ()) |
244 |
-> IO () |
245 |
listener s hmac resp = do |
246 |
(msg, _, peer) <- S.recvFrom s 4096 |
247 |
if confdMagicFourcc `isPrefixOf` msg |
248 |
then forkIO (resp s hmac (drop 4 msg) peer) >> return () |
249 |
else logDebug "Invalid magic code!" >> return () |
250 |
return () |
251 |
|
252 |
-- | Type alias for prepMain results |
253 |
type PrepResult = (S.Socket, IORef (Result (ConfigData, LinkIpMap))) |
254 |
|
255 |
-- | Check function for confd. |
256 |
checkMain :: CheckFn (S.Family, S.SockAddr) |
257 |
checkMain opts = do |
258 |
parseresult <- parseAddress opts C.defaultConfdPort |
259 |
case parseresult of |
260 |
Bad msg -> do |
261 |
hPutStrLn stderr $ "parsing bind address: " ++ msg |
262 |
return . Left $ ExitFailure 1 |
263 |
Ok v -> return $ Right v |
264 |
|
265 |
-- | Prepare function for confd. |
266 |
prepMain :: PrepFn (S.Family, S.SockAddr) PrepResult |
267 |
prepMain _ (af_family, bindaddr) = do |
268 |
s <- S.socket af_family S.Datagram S.defaultProtocol |
269 |
S.bindSocket s bindaddr |
270 |
cref <- newIORef (Bad "Configuration not yet loaded") |
271 |
return (s, cref) |
272 |
|
273 |
-- | Main function. |
274 |
main :: MainFn (S.Family, S.SockAddr) PrepResult |
275 |
main _ _ (s, cref) = do |
276 |
let cfg_transform :: Result ConfigData -> Result (ConfigData, LinkIpMap) |
277 |
cfg_transform = liftM (\cfg -> (cfg, buildLinkIpInstnameMap cfg)) |
278 |
initConfigReader cfg_transform cref |
279 |
|
280 |
hmac <- getClusterHmac |
281 |
-- enter the responder loop |
282 |
forever $ listener s hmac (responder cref) |