Make confd answer disk requests querying by name
[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 qualified Network.Socket as S
51 import System.Exit
52 import System.IO
53 import qualified Text.JSON as J
54
55 import Ganeti.BasicTypes
56 import Ganeti.Errors
57 import Ganeti.Daemon
58 import Ganeti.JSON
59 import Ganeti.Objects
60 import Ganeti.Confd.Types
61 import Ganeti.Confd.Utils
62 import Ganeti.Config
63 import Ganeti.ConfigReader
64 import Ganeti.Hash
65 import Ganeti.Logging
66 import qualified Ganeti.Constants as C
67 import qualified Ganeti.Query.Cluster as QCluster
68 import Ganeti.Utils
69
70 -- * Types and constants definitions
71
72 -- | What we store as configuration.
73 type CRef = IORef (Result (ConfigData, LinkIpMap))
74
75 -- | A small type alias for readability.
76 type StatusAnswer = (ConfdReplyStatus, J.JSValue, Int)
77
78 -- | Unknown entry standard response.
79 queryUnknownEntry :: StatusAnswer
80 queryUnknownEntry = (ReplyStatusError, J.showJSON ConfdErrorUnknownEntry, 0)
81
82 {- not used yet
83 -- | Internal error standard response.
84 queryInternalError :: StatusAnswer
85 queryInternalError = (ReplyStatusError, J.showJSON ConfdErrorInternal)
86 -}
87
88 -- | Argument error standard response.
89 queryArgumentError :: StatusAnswer
90 queryArgumentError = (ReplyStatusError, J.showJSON ConfdErrorArgument, 0)
91
92 -- | Converter from specific error to a string format.
93 gntErrorToResult :: ErrorResult a -> Result a
94 gntErrorToResult (Bad err) = Bad (show err)
95 gntErrorToResult (Ok x) = Ok x
96
97 -- * Confd base functionality
98
99 -- | Computes the node role
100 nodeRole :: ConfigData -> String -> Result ConfdNodeRole
101 nodeRole cfg name = do
102 cmaster <- errToResult $ QCluster.clusterMasterNodeName cfg
103 mnode <- errToResult $ getNode cfg name
104 let role = case mnode of
105 node | cmaster == name -> NodeRoleMaster
106 | nodeDrained node -> NodeRoleDrained
107 | nodeOffline node -> NodeRoleOffline
108 | nodeMasterCandidate node -> NodeRoleCandidate
109 _ -> NodeRoleRegular
110 return role
111
112 -- | Does an instance ip -> instance -> primary node -> primary ip
113 -- transformation.
114 getNodePipByInstanceIp :: ConfigData
115 -> LinkIpMap
116 -> String
117 -> String
118 -> StatusAnswer
119 getNodePipByInstanceIp cfg linkipmap link instip =
120 case M.lookup instip (M.findWithDefault M.empty link linkipmap) of
121 Nothing -> queryUnknownEntry
122 Just instname ->
123 case getInstPrimaryNode cfg instname of
124 Bad _ -> queryUnknownEntry -- either instance or node not found
125 Ok node -> (ReplyStatusOk, J.showJSON (nodePrimaryIp node),
126 clusterSerial $ configCluster cfg)
127
128 -- | Returns a node name for a given UUID
129 uuidToNodeName :: ConfigData -> String -> Result String
130 uuidToNodeName cfg uuid = gntErrorToResult $ nodeName <$> getNode cfg uuid
131
132 -- | Encodes a list of minors into a JSON representation, converting UUIDs to
133 -- names in the process
134 encodeMinors :: ConfigData -> (String, Int, String, String, String, String)
135 -> Result J.JSValue
136 encodeMinors cfg (node_uuid, a, b, c, d, peer_uuid) = do
137 node_name <- uuidToNodeName cfg node_uuid
138 peer_name <- uuidToNodeName cfg peer_uuid
139 return . J.JSArray $ [J.showJSON node_name, J.showJSON a, J.showJSON b,
140 J.showJSON c, J.showJSON d, J.showJSON peer_name]
141
142 -- | Builds the response to a given query.
143 buildResponse :: (ConfigData, LinkIpMap) -> ConfdRequest -> Result StatusAnswer
144 buildResponse (cfg, _) (ConfdRequest { confdRqType = ReqPing }) =
145 return (ReplyStatusOk, J.showJSON (configVersion cfg), 0)
146
147 buildResponse cdata req@(ConfdRequest { confdRqType = ReqClusterMaster }) =
148 case confdRqQuery req of
149 EmptyQuery -> liftM ((ReplyStatusOk,,serial) . J.showJSON) master_name
150 PlainQuery _ -> return queryArgumentError
151 DictQuery reqq -> do
152 mnode <- gntErrorToResult $ getNode cfg master_uuid
153 mname <- master_name
154 let fvals = map (\field -> case field of
155 ReqFieldName -> mname
156 ReqFieldIp -> clusterMasterIp cluster
157 ReqFieldMNodePip -> nodePrimaryIp mnode
158 ) (confdReqQFields reqq)
159 return (ReplyStatusOk, J.showJSON fvals, serial)
160 where master_uuid = clusterMasterNode cluster
161 master_name = errToResult $ QCluster.clusterMasterNodeName cfg
162 cluster = configCluster cfg
163 cfg = fst cdata
164 serial = clusterSerial $ configCluster cfg
165
166 buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeRoleByName }) = do
167 node_name <- case confdRqQuery req of
168 PlainQuery str -> return str
169 _ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
170 role <- nodeRole (fst cdata) node_name
171 return (ReplyStatusOk, J.showJSON role,
172 clusterSerial . configCluster $ fst cdata)
173
174 buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipList }) =
175 -- note: we use foldlWithKey because that's present accross more
176 -- versions of the library
177 return (ReplyStatusOk, J.showJSON $
178 M.foldlWithKey (\accu _ n -> nodePrimaryIp n:accu) []
179 (fromContainer . configNodes . fst $ cdata),
180 clusterSerial . configCluster $ fst cdata)
181
182 buildResponse cdata (ConfdRequest { confdRqType = ReqMcPipList }) =
183 -- note: we use foldlWithKey because that's present accross more
184 -- versions of the library
185 return (ReplyStatusOk, J.showJSON $
186 M.foldlWithKey (\accu _ n -> if nodeMasterCandidate n
187 then nodePrimaryIp n:accu
188 else accu) []
189 (fromContainer . configNodes . fst $ cdata),
190 clusterSerial . configCluster $ fst cdata)
191
192 buildResponse (cfg, linkipmap)
193 req@(ConfdRequest { confdRqType = ReqInstIpsList }) = do
194 link <- case confdRqQuery req of
195 PlainQuery str -> return str
196 EmptyQuery -> return (getDefaultNicLink cfg)
197 _ -> fail "Invalid query type"
198 return (ReplyStatusOk, J.showJSON $ getInstancesIpByLink linkipmap link,
199 clusterSerial $ configCluster cfg)
200
201 buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipByInstPip
202 , confdRqQuery = DictQuery query}) =
203 let (cfg, linkipmap) = cdata
204 link = fromMaybe (getDefaultNicLink cfg) (confdReqQLink query)
205 in case confdReqQIp query of
206 Just ip -> return $ getNodePipByInstanceIp cfg linkipmap link ip
207 Nothing -> return (ReplyStatusOk,
208 J.showJSON $
209 map (getNodePipByInstanceIp cfg linkipmap link)
210 (confdReqQIpList query),
211 clusterSerial . configCluster $ fst cdata)
212
213 buildResponse _ (ConfdRequest { confdRqType = ReqNodePipByInstPip }) =
214 return queryArgumentError
215
216 buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeDrbd }) = do
217 let cfg = fst cdata
218 node_name <- case confdRqQuery req of
219 PlainQuery str -> return str
220 _ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
221 node <- gntErrorToResult $ getNode cfg node_name
222 let minors = concatMap (getInstMinorsForNode cfg (nodeUuid node)) .
223 M.elems . fromContainer . configInstances $ cfg
224 encoded <- mapM (encodeMinors cfg) minors
225 return (ReplyStatusOk, J.showJSON encoded, nodeSerial node)
226
227 -- | Return the list of instances for a node (as ([primary], [secondary])) given
228 -- the node name.
229 buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeInstances }) = do
230 let cfg = fst cdata
231 node_name <- case confdRqQuery req of
232 PlainQuery str -> return str
233 _ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
234 node <-
235 case getNode cfg node_name of
236 Ok n -> return n
237 Bad e -> fail $ "Node not found in the configuration: " ++ show e
238 let node_uuid = nodeUuid node
239 instances = getNodeInstances cfg node_uuid
240 return (ReplyStatusOk, J.showJSON instances, nodeSerial node)
241
242 -- | Return the list of disks for an instance given the instance uuid.
243 buildResponse cdata req@(ConfdRequest { confdRqType = ReqInstanceDisks }) = do
244 let cfg = fst cdata
245 inst_name <-
246 case confdRqQuery req of
247 PlainQuery str -> return str
248 _ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
249 inst <-
250 case getInstance cfg inst_name of
251 Ok i -> return i
252 Bad e -> fail $ "Instance not found in the configuration: " ++ show e
253 case getInstDisks cfg . instUuid $ inst of
254 Ok disks -> return (ReplyStatusOk, J.showJSON disks, instSerial inst)
255 Bad e -> fail $ "Could not retrieve disks: " ++ show e
256
257 -- | Creates a ConfdReply from a given answer.
258 serializeResponse :: Result StatusAnswer -> ConfdReply
259 serializeResponse r =
260 let (status, result, serial) = case r of
261 Bad err -> (ReplyStatusError, J.showJSON err, 0)
262 Ok (code, val, ser) -> (code, val, ser)
263 in ConfdReply { confdReplyProtocol = 1
264 , confdReplyStatus = status
265 , confdReplyAnswer = result
266 , confdReplySerial = serial }
267
268 -- ** Client input/output handlers
269
270 -- | Main loop for a given client.
271 responder :: CRef -> S.Socket -> HashKey -> String -> S.SockAddr -> IO ()
272 responder cfgref socket hmac msg peer = do
273 ctime <- getCurrentTime
274 case parseRequest hmac msg ctime of
275 Ok (origmsg, rq) -> do
276 logDebug $ "Processing request: " ++ rStripSpace origmsg
277 mcfg <- readIORef cfgref
278 let response = respondInner mcfg hmac rq
279 _ <- S.sendTo socket response peer
280 logDebug $ "Response sent: " ++ response
281 return ()
282 Bad err -> logInfo $ "Failed to parse incoming message: " ++ err
283 return ()
284
285 -- | Inner helper function for a given client. This generates the
286 -- final encoded message (as a string), ready to be sent out to the
287 -- client.
288 respondInner :: Result (ConfigData, LinkIpMap) -> HashKey
289 -> ConfdRequest -> String
290 respondInner cfg hmac rq =
291 let rsalt = confdRqRsalt rq
292 innermsg = serializeResponse (cfg >>= flip buildResponse rq)
293 innerserialised = J.encodeStrict innermsg
294 outermsg = signMessage hmac rsalt innerserialised
295 outerserialised = C.confdMagicFourcc ++ J.encodeStrict outermsg
296 in outerserialised
297
298 -- | Main listener loop.
299 listener :: S.Socket -> HashKey
300 -> (S.Socket -> HashKey -> String -> S.SockAddr -> IO ())
301 -> IO ()
302 listener s hmac resp = do
303 (msg, _, peer) <- S.recvFrom s 4096
304 if C.confdMagicFourcc `isPrefixOf` msg
305 then forkIO (resp s hmac (drop 4 msg) peer) >> return ()
306 else logDebug "Invalid magic code!" >> return ()
307 return ()
308
309 -- | Type alias for prepMain results
310 type PrepResult = (S.Socket, IORef (Result (ConfigData, LinkIpMap)))
311
312 -- | Check function for confd.
313 checkMain :: CheckFn (S.Family, S.SockAddr)
314 checkMain opts = do
315 parseresult <- parseAddress opts C.defaultConfdPort
316 case parseresult of
317 Bad msg -> do
318 hPutStrLn stderr $ "parsing bind address: " ++ msg
319 return . Left $ ExitFailure 1
320 Ok v -> return $ Right v
321
322 -- | Prepare function for confd.
323 prepMain :: PrepFn (S.Family, S.SockAddr) PrepResult
324 prepMain _ (af_family, bindaddr) = do
325 s <- S.socket af_family S.Datagram S.defaultProtocol
326 S.setSocketOption s S.ReuseAddr 1
327 S.bindSocket s bindaddr
328 cref <- newIORef (Bad "Configuration not yet loaded")
329 return (s, cref)
330
331 -- | Main function.
332 main :: MainFn (S.Family, S.SockAddr) PrepResult
333 main _ _ (s, cref) = do
334 let cfg_transform :: Result ConfigData -> Result (ConfigData, LinkIpMap)
335 cfg_transform = liftM (\cfg -> (cfg, buildLinkIpInstnameMap cfg))
336 initConfigReader cfg_transform cref
337
338 hmac <- getClusterHmac
339 -- enter the responder loop
340 forever $ listener s hmac (responder cref)