Prefer the UuidObject type class over specific functions
[ganeti-github.git] / src / Ganeti / Confd / Server.hs
1 {-# LANGUAGE TupleSections #-}
2
3 {-| Implementation of the Ganeti confd server functionality.
4
5 -}
6
7 {-
8
9 Copyright (C) 2011, 2012, 2013 Google Inc.
10 All rights reserved.
11
12 Redistribution and use in source and binary forms, with or without
13 modification, are permitted provided that the following conditions are
14 met:
15
16 1. Redistributions of source code must retain the above copyright notice,
17 this list of conditions and the following disclaimer.
18
19 2. Redistributions in binary form must reproduce the above copyright
20 notice, this list of conditions and the following disclaimer in the
21 documentation and/or other materials provided with the distribution.
22
23 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
24 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
25 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
26 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
27 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
28 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
29 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
30 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
31 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
32 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
33 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
34
35 -}
36
37 module Ganeti.Confd.Server
38 ( main
39 , checkMain
40 , prepMain
41 ) where
42
43 import Control.Applicative((<$>))
44 import Control.Concurrent
45 import Control.Monad (forever, liftM)
46 import Data.IORef
47 import Data.List
48 import qualified Data.Map as M
49 import Data.Maybe (fromMaybe)
50 import Network.BSD (getServicePortNumber)
51 import qualified Network.Socket as S
52 import System.Exit
53 import System.IO
54 import qualified Text.JSON as J
55
56 import Ganeti.BasicTypes
57 import Ganeti.Errors
58 import Ganeti.Daemon
59 import Ganeti.JSON
60 import Ganeti.Objects
61 import Ganeti.Confd.Types
62 import Ganeti.Confd.Utils
63 import Ganeti.Config
64 import Ganeti.ConfigReader
65 import Ganeti.Hash
66 import Ganeti.Logging
67 import qualified Ganeti.Constants as C
68 import qualified Ganeti.Query.Cluster as QCluster
69 import Ganeti.Utils
70 import Ganeti.DataCollectors.Types (DataCollector(..))
71 import Ganeti.DataCollectors (collectors)
72
73 -- * Types and constants definitions
74
75 -- | What we store as configuration.
76 type CRef = IORef (Result (ConfigData, LinkIpMap))
77
78 -- | A small type alias for readability.
79 type StatusAnswer = (ConfdReplyStatus, J.JSValue, Int)
80
81 -- | Unknown entry standard response.
82 queryUnknownEntry :: StatusAnswer
83 queryUnknownEntry = (ReplyStatusError, J.showJSON ConfdErrorUnknownEntry, 0)
84
85 {- not used yet
86 -- | Internal error standard response.
87 queryInternalError :: StatusAnswer
88 queryInternalError = (ReplyStatusError, J.showJSON ConfdErrorInternal)
89 -}
90
91 -- | Argument error standard response.
92 queryArgumentError :: StatusAnswer
93 queryArgumentError = (ReplyStatusError, J.showJSON ConfdErrorArgument, 0)
94
95 -- | Converter from specific error to a string format.
96 gntErrorToResult :: ErrorResult a -> Result a
97 gntErrorToResult (Bad err) = Bad (show err)
98 gntErrorToResult (Ok x) = Ok x
99
100 -- * Confd base functionality
101
102 -- | Computes the node role
103 nodeRole :: ConfigData -> String -> Result ConfdNodeRole
104 nodeRole cfg name = do
105 cmaster <- errToResult $ QCluster.clusterMasterNodeName cfg
106 mnode <- errToResult $ getNode cfg name
107 let role = case mnode of
108 node | cmaster == name -> NodeRoleMaster
109 | nodeDrained node -> NodeRoleDrained
110 | nodeOffline node -> NodeRoleOffline
111 | nodeMasterCandidate node -> NodeRoleCandidate
112 _ -> NodeRoleRegular
113 return role
114
115 -- | Does an instance ip -> instance -> primary node -> primary ip
116 -- transformation.
117 getNodePipByInstanceIp :: ConfigData
118 -> LinkIpMap
119 -> String
120 -> String
121 -> StatusAnswer
122 getNodePipByInstanceIp cfg linkipmap link instip =
123 case M.lookup instip (M.findWithDefault M.empty link linkipmap) of
124 Nothing -> queryUnknownEntry
125 Just instname ->
126 case getInstPrimaryNode cfg instname of
127 Bad _ -> queryUnknownEntry -- either instance or node not found
128 Ok node -> (ReplyStatusOk, J.showJSON (nodePrimaryIp node),
129 clusterSerial $ configCluster cfg)
130
131 -- | Returns a node name for a given UUID
132 uuidToNodeName :: ConfigData -> String -> Result String
133 uuidToNodeName cfg uuid = gntErrorToResult $ nodeName <$> getNode cfg uuid
134
135 -- | Encodes a list of minors into a JSON representation, converting UUIDs to
136 -- names in the process
137 encodeMinors :: ConfigData -> (String, Int, String, String, String, String)
138 -> Result J.JSValue
139 encodeMinors cfg (node_uuid, a, b, c, d, peer_uuid) = do
140 node_name <- uuidToNodeName cfg node_uuid
141 peer_name <- uuidToNodeName cfg peer_uuid
142 return . J.JSArray $ [J.showJSON node_name, J.showJSON a, J.showJSON b,
143 J.showJSON c, J.showJSON d, J.showJSON peer_name]
144
145 -- | Builds the response to a given query.
146 buildResponse :: (ConfigData, LinkIpMap) -> ConfdRequest -> Result StatusAnswer
147 buildResponse (cfg, _) (ConfdRequest { confdRqType = ReqPing }) =
148 return (ReplyStatusOk, J.showJSON (configVersion cfg), 0)
149
150 buildResponse cdata req@(ConfdRequest { confdRqType = ReqClusterMaster }) =
151 case confdRqQuery req of
152 EmptyQuery -> liftM ((ReplyStatusOk,,serial) . J.showJSON) master_name
153 PlainQuery _ -> return queryArgumentError
154 DictQuery reqq -> do
155 mnode <- gntErrorToResult $ getNode cfg master_uuid
156 mname <- master_name
157 let fvals = map (\field -> case field of
158 ReqFieldName -> mname
159 ReqFieldIp -> clusterMasterIp cluster
160 ReqFieldMNodePip -> nodePrimaryIp mnode
161 ) (confdReqQFields reqq)
162 return (ReplyStatusOk, J.showJSON fvals, serial)
163 where master_uuid = clusterMasterNode cluster
164 master_name = errToResult $ QCluster.clusterMasterNodeName cfg
165 cluster = configCluster cfg
166 cfg = fst cdata
167 serial = clusterSerial $ configCluster cfg
168
169 buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeRoleByName }) = do
170 node_name <- case confdRqQuery req of
171 PlainQuery str -> return str
172 _ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
173 role <- nodeRole (fst cdata) node_name
174 return (ReplyStatusOk, J.showJSON role,
175 clusterSerial . configCluster $ fst cdata)
176
177 buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipList }) =
178 -- note: we use foldlWithKey because that's present accross more
179 -- versions of the library
180 return (ReplyStatusOk, J.showJSON $
181 M.foldlWithKey (\accu _ n -> nodePrimaryIp n:accu) []
182 (fromContainer . configNodes . fst $ cdata),
183 clusterSerial . configCluster $ fst cdata)
184
185 buildResponse cdata (ConfdRequest { confdRqType = ReqMcPipList }) =
186 -- note: we use foldlWithKey because that's present accross more
187 -- versions of the library
188 return (ReplyStatusOk, J.showJSON $
189 M.foldlWithKey (\accu _ n -> if nodeMasterCandidate n
190 then nodePrimaryIp n:accu
191 else accu) []
192 (fromContainer . configNodes . fst $ cdata),
193 clusterSerial . configCluster $ fst cdata)
194
195 buildResponse (cfg, linkipmap)
196 req@(ConfdRequest { confdRqType = ReqInstIpsList }) = do
197 link <- case confdRqQuery req of
198 PlainQuery str -> return str
199 EmptyQuery -> return (getDefaultNicLink cfg)
200 _ -> fail "Invalid query type"
201 return (ReplyStatusOk, J.showJSON $ getInstancesIpByLink linkipmap link,
202 clusterSerial $ configCluster cfg)
203
204 buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipByInstPip
205 , confdRqQuery = DictQuery query}) =
206 let (cfg, linkipmap) = cdata
207 link = fromMaybe (getDefaultNicLink cfg) (confdReqQLink query)
208 in case confdReqQIp query of
209 Just ip -> return $ getNodePipByInstanceIp cfg linkipmap link ip
210 Nothing -> return (ReplyStatusOk,
211 J.showJSON $
212 map (getNodePipByInstanceIp cfg linkipmap link)
213 (confdReqQIpList query),
214 clusterSerial . configCluster $ fst cdata)
215
216 buildResponse _ (ConfdRequest { confdRqType = ReqNodePipByInstPip }) =
217 return queryArgumentError
218
219 buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeDrbd }) = do
220 let cfg = fst cdata
221 node_name <- case confdRqQuery req of
222 PlainQuery str -> return str
223 _ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
224 node <- gntErrorToResult $ getNode cfg node_name
225 let minors = concatMap (getInstMinorsForNode cfg (uuidOf node)) .
226 M.elems . fromContainer . configInstances $ cfg
227 encoded <- mapM (encodeMinors cfg) minors
228 return (ReplyStatusOk, J.showJSON encoded, nodeSerial node)
229
230 -- | Return the list of instances for a node (as ([primary], [secondary])) given
231 -- the node name.
232 buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeInstances }) = do
233 let cfg = fst cdata
234 node_name <- case confdRqQuery req of
235 PlainQuery str -> return str
236 _ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
237 node <-
238 case getNode cfg node_name of
239 Ok n -> return n
240 Bad e -> fail $ "Node not found in the configuration: " ++ show e
241 let node_uuid = uuidOf node
242 instances = getNodeInstances cfg node_uuid
243 return (ReplyStatusOk, J.showJSON instances, nodeSerial node)
244
245 -- | Return the list of disks for an instance given the instance uuid.
246 buildResponse cdata req@(ConfdRequest { confdRqType = ReqInstanceDisks }) = do
247 let cfg = fst cdata
248 inst_name <-
249 case confdRqQuery req of
250 PlainQuery str -> return str
251 _ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
252 inst <-
253 case getInstance cfg inst_name of
254 Ok i -> return i
255 Bad e -> fail $ "Instance not found in the configuration: " ++ show e
256 case getInstDisks cfg . uuidOf $ inst of
257 Ok disks -> return (ReplyStatusOk, J.showJSON disks, instSerial inst)
258 Bad e -> fail $ "Could not retrieve disks: " ++ show e
259
260 -- | Return arbitrary configuration value given by a path.
261 buildResponse cdata req@(ConfdRequest { confdRqType = ReqConfigQuery
262 , confdRqQuery = pathQ }) = do
263 let cfg = fst cdata
264 path <-
265 case pathQ of
266 PlainQuery path -> return path
267 _ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
268 let configValue = extractJSONPath path cfg
269 case configValue of
270 J.Ok jsvalue -> return (ReplyStatusOk, jsvalue,
271 clusterSerial $ configCluster cfg)
272 J.Error _ -> return queryArgumentError
273
274 -- | Return activation state of data collectors
275 buildResponse (cdata,_) (ConfdRequest { confdRqType = ReqDataCollectors }) = do
276 let mkConfig col =
277 (dName col, DataCollectorConfig
278 (dActive col (dName col) cdata)
279 (dInterval col (dName col) cdata))
280 datacollectors = containerFromList $ map mkConfig collectors
281 return (ReplyStatusOk, J.showJSON datacollectors,
282 clusterSerial . configCluster $ cdata)
283
284 -- | Creates a ConfdReply from a given answer.
285 serializeResponse :: Result StatusAnswer -> ConfdReply
286 serializeResponse r =
287 let (status, result, serial) = case r of
288 Bad err -> (ReplyStatusError, J.showJSON err, 0)
289 Ok (code, val, ser) -> (code, val, ser)
290 in ConfdReply { confdReplyProtocol = 1
291 , confdReplyStatus = status
292 , confdReplyAnswer = result
293 , confdReplySerial = serial }
294
295 -- ** Client input/output handlers
296
297 -- | Main loop for a given client.
298 responder :: CRef -> S.Socket -> HashKey -> String -> S.SockAddr -> IO ()
299 responder cfgref socket hmac msg peer = do
300 ctime <- getCurrentTime
301 case parseRequest hmac msg ctime of
302 Ok (origmsg, rq) -> do
303 logDebug $ "Processing request: " ++ rStripSpace origmsg
304 mcfg <- readIORef cfgref
305 let response = respondInner mcfg hmac rq
306 _ <- S.sendTo socket response peer
307 logDebug $ "Response sent: " ++ response
308 return ()
309 Bad err -> logInfo $ "Failed to parse incoming message: " ++ err
310 return ()
311
312 -- | Inner helper function for a given client. This generates the
313 -- final encoded message (as a string), ready to be sent out to the
314 -- client.
315 respondInner :: Result (ConfigData, LinkIpMap) -> HashKey
316 -> ConfdRequest -> String
317 respondInner cfg hmac rq =
318 let rsalt = confdRqRsalt rq
319 innermsg = serializeResponse (cfg >>= flip buildResponse rq)
320 innerserialised = J.encodeStrict innermsg
321 outermsg = signMessage hmac rsalt innerserialised
322 outerserialised = C.confdMagicFourcc ++ J.encodeStrict outermsg
323 in outerserialised
324
325 -- | Main listener loop.
326 listener :: S.Socket -> HashKey
327 -> (S.Socket -> HashKey -> String -> S.SockAddr -> IO ())
328 -> IO ()
329 listener s hmac resp = do
330 (msg, _, peer) <- S.recvFrom s 4096
331 if C.confdMagicFourcc `isPrefixOf` msg
332 then forkIO (resp s hmac (drop 4 msg) peer) >> return ()
333 else logDebug "Invalid magic code!" >> return ()
334 return ()
335
336 -- | Type alias for prepMain results
337 type PrepResult = (S.Socket, IORef (Result (ConfigData, LinkIpMap)))
338
339 -- | Check function for confd.
340 checkMain :: CheckFn (S.Family, S.SockAddr)
341 checkMain opts = do
342 defaultPort <- withDefaultOnIOError C.defaultConfdPort
343 . liftM fromIntegral
344 $ getServicePortNumber C.confd
345 parseresult <- parseAddress opts defaultPort
346 case parseresult of
347 Bad msg -> do
348 hPutStrLn stderr $ "parsing bind address: " ++ msg
349 return . Left $ ExitFailure 1
350 Ok v -> return $ Right v
351
352 -- | Prepare function for confd.
353 prepMain :: PrepFn (S.Family, S.SockAddr) PrepResult
354 prepMain _ (af_family, bindaddr) = do
355 s <- S.socket af_family S.Datagram S.defaultProtocol
356 S.setSocketOption s S.ReuseAddr 1
357 S.bindSocket s bindaddr
358 cref <- newIORef (Bad "Configuration not yet loaded")
359 return (s, cref)
360
361 -- | Main function.
362 main :: MainFn (S.Family, S.SockAddr) PrepResult
363 main _ _ (s, cref) = do
364 let cfg_transform :: Result ConfigData -> Result (ConfigData, LinkIpMap)
365 cfg_transform = liftM (\cfg -> (cfg, buildLinkIpInstnameMap cfg))
366 initConfigReader (writeIORef cref . cfg_transform)
367
368 hmac <- getClusterHmac
369 -- enter the responder loop
370 forever $ listener s hmac (responder cref)