Prefer the UuidObject type class over specific functions
[ganeti-github.git] / src / Ganeti / Rpc.hs
1 {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
2 BangPatterns, TemplateHaskell #-}
3
4 {-| Implementation of the RPC client.
5
6 -}
7
8 {-
9
10 Copyright (C) 2012, 2013 Google Inc.
11 All rights reserved.
12
13 Redistribution and use in source and binary forms, with or without
14 modification, are permitted provided that the following conditions are
15 met:
16
17 1. Redistributions of source code must retain the above copyright notice,
18 this list of conditions and the following disclaimer.
19
20 2. Redistributions in binary form must reproduce the above copyright
21 notice, this list of conditions and the following disclaimer in the
22 documentation and/or other materials provided with the distribution.
23
24 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
25 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
26 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
27 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
28 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
29 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
30 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
31 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
32 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
33 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
34 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
35
36 -}
37
38 module Ganeti.Rpc
39 ( RpcCall
40 , Rpc
41 , RpcError(..)
42 , ERpcError
43 , explainRpcError
44 , executeRpcCall
45 , executeRpcCalls
46 , rpcErrors
47 , logRpcErrors
48
49 , rpcCallName
50 , rpcCallTimeout
51 , rpcCallData
52 , rpcCallAcceptOffline
53
54 , rpcResultFill
55
56 , Compressed
57 , packCompressed
58 , toCompressed
59 , getCompressed
60
61 , RpcCallNodeActivateMasterIp(..)
62 , RpcResultNodeActivateMasterIp(..)
63
64 , RpcCallInstanceInfo(..)
65 , InstanceState(..)
66 , InstanceInfo(..)
67 , RpcResultInstanceInfo(..)
68
69 , RpcCallAllInstancesInfo(..)
70 , RpcResultAllInstancesInfo(..)
71
72 , InstanceConsoleInfoParams(..)
73 , InstanceConsoleInfo(..)
74 , RpcCallInstanceConsoleInfo(..)
75 , RpcResultInstanceConsoleInfo(..)
76
77 , RpcCallInstanceList(..)
78 , RpcResultInstanceList(..)
79
80 , HvInfo(..)
81 , StorageInfo(..)
82 , RpcCallNodeInfo(..)
83 , RpcResultNodeInfo(..)
84
85 , RpcCallVersion(..)
86 , RpcResultVersion(..)
87
88 , RpcCallMasterNodeName(..)
89 , RpcResultMasterNodeName(..)
90
91 , RpcCallStorageList(..)
92 , RpcResultStorageList(..)
93
94 , RpcCallTestDelay(..)
95 , RpcResultTestDelay(..)
96
97 , RpcCallExportList(..)
98 , RpcResultExportList(..)
99
100 , RpcCallJobqueueUpdate(..)
101 , RpcCallJobqueueRename(..)
102 , RpcCallSetWatcherPause(..)
103 , RpcCallSetDrainFlag(..)
104
105 , RpcCallUploadFile(..)
106 , prepareRpcCallUploadFile
107 , RpcCallWriteSsconfFiles(..)
108 ) where
109
110 import Control.Arrow (second)
111 import Control.Monad
112 import qualified Data.ByteString.Lazy.Char8 as BL
113 import qualified Data.Map as Map
114 import Data.Maybe (fromMaybe, mapMaybe)
115 import qualified Text.JSON as J
116 import Text.JSON.Pretty (pp_value)
117 import qualified Data.ByteString.Base64.Lazy as Base64
118 import System.Directory
119 import System.Posix.Files ( modificationTime, accessTime, fileOwner
120 , fileGroup, fileMode, getFileStatus)
121
122 import Network.BSD (getServiceByName, servicePort)
123 import Network.Curl hiding (content)
124 import qualified Ganeti.Path as P
125
126 import Ganeti.BasicTypes
127 import qualified Ganeti.Constants as C
128 import Ganeti.Codec
129 import Ganeti.Curl.Multi
130 import Ganeti.Errors
131 import Ganeti.JSON
132 import Ganeti.Logging
133 import Ganeti.Objects
134 import Ganeti.Runtime
135 import Ganeti.Ssconf
136 import Ganeti.THH
137 import Ganeti.THH.Field
138 import Ganeti.Types
139 import Ganeti.Utils
140 import Ganeti.VCluster
141
142 -- * Base RPC functionality and types
143
144 -- | The curl options used for RPC.
145 curlOpts :: [CurlOption]
146 curlOpts = [ CurlFollowLocation False
147 , CurlSSLVerifyHost 0
148 , CurlSSLVerifyPeer True
149 , CurlSSLCertType "PEM"
150 , CurlSSLKeyType "PEM"
151 , CurlConnectTimeout (fromIntegral C.rpcConnectTimeout)
152 ]
153
154 -- | Data type for RPC error reporting.
155 data RpcError
156 = CurlLayerError String
157 | JsonDecodeError String
158 | RpcResultError String
159 | OfflineNodeError
160 deriving (Show, Eq)
161
162 -- | Provide explanation to RPC errors.
163 explainRpcError :: RpcError -> String
164 explainRpcError (CurlLayerError code) =
165 "Curl error:" ++ code
166 explainRpcError (JsonDecodeError msg) =
167 "Error while decoding JSON from HTTP response: " ++ msg
168 explainRpcError (RpcResultError msg) =
169 "Error reponse received from RPC server: " ++ msg
170 explainRpcError OfflineNodeError =
171 "Node is marked offline"
172
173 type ERpcError = Either RpcError
174
175 -- | A generic class for RPC calls.
176 class (ArrayObject a) => RpcCall a where
177 -- | Give the (Python) name of the procedure.
178 rpcCallName :: a -> String
179 -- | Calculate the timeout value for the call execution.
180 rpcCallTimeout :: a -> Int
181 -- | Prepare arguments of the call to be send as POST.
182 rpcCallData :: Node -> a -> String
183 rpcCallData _ = J.encode . J.JSArray . toJSArray
184 -- | Whether we accept offline nodes when making a call.
185 rpcCallAcceptOffline :: a -> Bool
186
187 -- | Generic class that ensures matching RPC call with its respective
188 -- result.
189 class (RpcCall a, J.JSON b) => Rpc a b | a -> b, b -> a where
190 -- | Create a result based on the received HTTP response.
191 rpcResultFill :: a -> J.JSValue -> ERpcError b
192
193 -- | Http Request definition.
194 data HttpClientRequest = HttpClientRequest
195 { requestUrl :: String -- ^ The actual URL for the node endpoint
196 , requestData :: String -- ^ The arguments for the call
197 , requestOpts :: [CurlOption] -- ^ The various curl options
198 }
199
200 -- | Check if a string represented address is IPv6
201 isIpV6 :: String -> Bool
202 isIpV6 = (':' `elem`)
203
204 -- | Prepare url for the HTTP request.
205 prepareUrl :: (RpcCall a) => Int -> Node -> a -> String
206 prepareUrl port node call =
207 let node_ip = nodePrimaryIp node
208 node_address = if isIpV6 node_ip
209 then "[" ++ node_ip ++ "]"
210 else node_ip
211 path_prefix = "https://" ++ node_address ++ ":" ++ show port
212 in path_prefix ++ "/" ++ rpcCallName call
213
214 -- | Create HTTP request for a given node provided it is online,
215 -- otherwise create empty response.
216 prepareHttpRequest :: (RpcCall a) => Int -> [CurlOption] -> Node -> a
217 -> ERpcError HttpClientRequest
218 prepareHttpRequest port opts node call
219 | rpcCallAcceptOffline call || not (nodeOffline node) =
220 Right HttpClientRequest { requestUrl = prepareUrl port node call
221 , requestData = rpcCallData node call
222 , requestOpts = opts ++ curlOpts
223 }
224 | otherwise = Left OfflineNodeError
225
226 -- | Parse an HTTP reply.
227 parseHttpReply :: (Rpc a b) =>
228 a -> ERpcError (CurlCode, String) -> ERpcError b
229 parseHttpReply _ (Left e) = Left e
230 parseHttpReply call (Right (CurlOK, body)) = parseHttpResponse call body
231 parseHttpReply _ (Right (code, err)) =
232 Left . CurlLayerError $ "code: " ++ show code ++ ", explanation: " ++ err
233
234 -- | Parse a result based on the received HTTP response.
235 parseHttpResponse :: (Rpc a b) => a -> String -> ERpcError b
236 parseHttpResponse call res =
237 case J.decode res of
238 J.Error val -> Left $ JsonDecodeError val
239 J.Ok (True, res'') -> rpcResultFill call res''
240 J.Ok (False, jerr) -> case jerr of
241 J.JSString msg -> Left $ RpcResultError (J.fromJSString msg)
242 _ -> Left . JsonDecodeError $ show (pp_value jerr)
243
244 -- | Scan the list of results produced by executeRpcCall and extract
245 -- all the RPC errors.
246 rpcErrors :: [(a, ERpcError b)] -> [(a, RpcError)]
247 rpcErrors =
248 let rpcErr (node, Left err) = Just (node, err)
249 rpcErr _ = Nothing
250 in mapMaybe rpcErr
251
252 -- | Scan the list of results produced by executeRpcCall and log all the RPC
253 -- errors. Returns the list of errors for further processing.
254 logRpcErrors :: (MonadLog m, Show a) => [(a, ERpcError b)]
255 -> m [(a, RpcError)]
256 logRpcErrors rs =
257 let logOneRpcErr (node, err) =
258 logError $ "Error in the RPC HTTP reply from '" ++
259 show node ++ "': " ++ show err
260 errs = rpcErrors rs
261 in mapM_ logOneRpcErr errs >> return errs
262
263 -- | Get options for RPC call
264 getOptionsForCall :: (Rpc a b) => FilePath -> FilePath -> a -> [CurlOption]
265 getOptionsForCall cert_path client_cert_path call =
266 [ CurlTimeout (fromIntegral $ rpcCallTimeout call)
267 , CurlSSLCert client_cert_path
268 , CurlSSLKey client_cert_path
269 , CurlCAInfo cert_path
270 ]
271
272 -- | Determine to port to call noded at.
273 getNodedPort :: IO Int
274 getNodedPort = withDefaultOnIOError C.defaultNodedPort
275 . liftM (fromIntegral . servicePort)
276 $ getServiceByName C.noded "tcp"
277
278 -- | Execute multiple RPC calls in parallel
279 executeRpcCalls :: (Rpc a b) => [(Node, a)] -> IO [(Node, ERpcError b)]
280 executeRpcCalls nodeCalls = do
281 port <- getNodedPort
282 cert_file <- P.nodedCertFile
283 client_cert_file_name <- P.nodedClientCertFile
284 client_file_exists <- doesFileExist client_cert_file_name
285 -- This is needed to allow upgrades from 2.10 or earlier;
286 -- note that Ganeti supports jump-upgrades.
287 let client_cert_file = if client_file_exists
288 then client_cert_file_name
289 else cert_file
290 (nodes, calls) = unzip nodeCalls
291 opts = map (getOptionsForCall cert_file client_cert_file) calls
292 opts_urls = zipWith3 (\n c o ->
293 case prepareHttpRequest port o n c of
294 Left v -> Left v
295 Right request ->
296 Right (CurlPostFields [requestData request]:
297 requestOpts request,
298 requestUrl request)
299 ) nodes calls opts
300 -- split the opts_urls list; we don't want to pass the
301 -- failed-already nodes to Curl
302 let (lefts, rights, trail) = splitEithers opts_urls
303 results <- execMultiCall rights
304 results' <- case recombineEithers lefts results trail of
305 Bad msg -> error msg
306 Ok r -> return r
307 -- now parse the replies
308 let results'' = zipWith parseHttpReply calls results'
309 pairedList = zip nodes results''
310 _ <- logRpcErrors pairedList
311 return pairedList
312
313 -- | Execute an RPC call for many nodes in parallel.
314 executeRpcCall :: (Rpc a b) => [Node] -> a -> IO [(Node, ERpcError b)]
315 executeRpcCall nodes call = executeRpcCalls . zip nodes $ repeat call
316
317 -- | Helper function that is used to read dictionaries of values.
318 sanitizeDictResults :: [(String, J.Result a)] -> ERpcError [(String, a)]
319 sanitizeDictResults =
320 foldr sanitize1 (Right [])
321 where
322 sanitize1 _ (Left e) = Left e
323 sanitize1 (_, J.Error e) _ = Left $ JsonDecodeError e
324 sanitize1 (name, J.Ok v) (Right res) = Right $ (name, v) : res
325
326 -- | Helper function to tranform JSON Result to Either RpcError b.
327 -- Note: For now we really only use it for b s.t. Rpc c b for some c
328 fromJResultToRes :: J.Result a -> (a -> b) -> ERpcError b
329 fromJResultToRes (J.Error v) _ = Left $ JsonDecodeError v
330 fromJResultToRes (J.Ok v) f = Right $ f v
331
332 -- | Helper function transforming JSValue to Rpc result type.
333 fromJSValueToRes :: (J.JSON a) => J.JSValue -> (a -> b) -> ERpcError b
334 fromJSValueToRes val = fromJResultToRes (J.readJSON val)
335
336 -- | An opaque data type for representing data that should be compressed
337 -- over the wire.
338 --
339 -- On Python side it is decompressed by @backend._Decompress@.
340 newtype Compressed = Compressed { getCompressed :: BL.ByteString }
341 deriving (Eq, Ord, Show)
342
343 -- TODO Add a unit test for all octets
344 instance J.JSON Compressed where
345 showJSON = J.showJSON
346 . (,) C.rpcEncodingZlibBase64
347 . Base64.encode . compressZlib . getCompressed
348 readJSON = J.readJSON >=> decompress
349 where
350 decompress (enc, cont)
351 | enc == C.rpcEncodingNone =
352 return $ Compressed cont
353 | enc == C.rpcEncodingZlibBase64 =
354 liftM Compressed
355 . either fail return . decompressZlib
356 <=< either (fail . ("Base64: " ++)) return . Base64.decode
357 $ cont
358 | otherwise =
359 fail $ "Unknown RPC encoding type: " ++ show enc
360
361 packCompressed :: BL.ByteString -> Compressed
362 packCompressed = Compressed
363
364 toCompressed :: String -> Compressed
365 toCompressed = packCompressed . BL.pack
366
367 -- * RPC calls and results
368
369 -- ** Instance info
370
371 -- | Returns information about a single instance
372 $(buildObject "RpcCallInstanceInfo" "rpcCallInstInfo"
373 [ simpleField "instance" [t| String |]
374 , simpleField "hname" [t| Hypervisor |]
375 ])
376
377 $(declareILADT "InstanceState"
378 [ ("InstanceStateRunning", 0)
379 , ("InstanceStateShutdown", 1)
380 ])
381
382 $(makeJSONInstance ''InstanceState)
383
384 instance PyValue InstanceState where
385 showValue = show . instanceStateToRaw
386
387 $(buildObject "InstanceInfo" "instInfo"
388 [ simpleField "memory" [t| Int|]
389 , simpleField "state" [t| InstanceState |]
390 , simpleField "vcpus" [t| Int |]
391 , simpleField "time" [t| Int |]
392 ])
393
394 -- This is optional here because the result may be empty if instance is
395 -- not on a node - and this is not considered an error.
396 $(buildObject "RpcResultInstanceInfo" "rpcResInstInfo"
397 [ optionalField $ simpleField "inst_info" [t| InstanceInfo |]])
398
399 instance RpcCall RpcCallInstanceInfo where
400 rpcCallName _ = "instance_info"
401 rpcCallTimeout _ = rpcTimeoutToRaw Urgent
402 rpcCallAcceptOffline _ = False
403
404 instance Rpc RpcCallInstanceInfo RpcResultInstanceInfo where
405 rpcResultFill _ res =
406 case res of
407 J.JSObject res' ->
408 case J.fromJSObject res' of
409 [] -> Right $ RpcResultInstanceInfo Nothing
410 _ -> fromJSValueToRes res (RpcResultInstanceInfo . Just)
411 _ -> Left $ JsonDecodeError
412 ("Expected JSObject, got " ++ show (pp_value res))
413
414 -- ** AllInstancesInfo
415
416 -- | Returns information about all running instances on the given nodes
417 $(buildObject "RpcCallAllInstancesInfo" "rpcCallAllInstInfo"
418 [ simpleField "hypervisors" [t| [(Hypervisor, HvParams)] |] ])
419
420 $(buildObject "RpcResultAllInstancesInfo" "rpcResAllInstInfo"
421 [ simpleField "instances" [t| [(String, InstanceInfo)] |] ])
422
423 instance RpcCall RpcCallAllInstancesInfo where
424 rpcCallName _ = "all_instances_info"
425 rpcCallTimeout _ = rpcTimeoutToRaw Urgent
426 rpcCallAcceptOffline _ = False
427 rpcCallData _ call = J.encode (
428 map fst $ rpcCallAllInstInfoHypervisors call,
429 GenericContainer . Map.fromList $ rpcCallAllInstInfoHypervisors call)
430
431 instance Rpc RpcCallAllInstancesInfo RpcResultAllInstancesInfo where
432 -- FIXME: Is there a simpler way to do it?
433 rpcResultFill _ res =
434 case res of
435 J.JSObject res' ->
436 let res'' = map (second J.readJSON) (J.fromJSObject res')
437 :: [(String, J.Result InstanceInfo)] in
438 case sanitizeDictResults res'' of
439 Left err -> Left err
440 Right insts -> Right $ RpcResultAllInstancesInfo insts
441 _ -> Left $ JsonDecodeError
442 ("Expected JSObject, got " ++ show (pp_value res))
443
444 -- ** InstanceConsoleInfo
445
446 -- | Returns information about how to access instances on the given node
447 $(buildObject "InstanceConsoleInfoParams" "instConsInfoParams"
448 [ simpleField "instance" [t| Instance |]
449 , simpleField "node" [t| Node |]
450 , simpleField "group" [t| NodeGroup |]
451 , simpleField "hvParams" [t| HvParams |]
452 , simpleField "beParams" [t| FilledBeParams |]
453 ])
454
455 $(buildObject "RpcCallInstanceConsoleInfo" "rpcCallInstConsInfo"
456 [ simpleField "instanceInfo" [t| [(String, InstanceConsoleInfoParams)] |] ])
457
458 $(buildObject "InstanceConsoleInfo" "instConsInfo"
459 [ simpleField "instance" [t| String |]
460 , simpleField "kind" [t| String |]
461 , optionalField $
462 simpleField "message" [t| String |]
463 , optionalField $
464 simpleField "host" [t| String |]
465 , optionalField $
466 simpleField "port" [t| Int |]
467 , optionalField $
468 simpleField "user" [t| String |]
469 , optionalField $
470 simpleField "command" [t| [String] |]
471 , optionalField $
472 simpleField "display" [t| String |]
473 ])
474
475 $(buildObject "RpcResultInstanceConsoleInfo" "rpcResInstConsInfo"
476 [ simpleField "instancesInfo" [t| [(String, InstanceConsoleInfo)] |] ])
477
478 instance RpcCall RpcCallInstanceConsoleInfo where
479 rpcCallName _ = "instance_console_info"
480 rpcCallTimeout _ = rpcTimeoutToRaw Urgent
481 rpcCallAcceptOffline _ = False
482 rpcCallData _ call = J.encode .
483 GenericContainer $ Map.fromList (rpcCallInstConsInfoInstanceInfo call)
484
485 instance Rpc RpcCallInstanceConsoleInfo RpcResultInstanceConsoleInfo where
486 rpcResultFill _ res =
487 case res of
488 J.JSObject res' ->
489 let res'' = map (second J.readJSON) (J.fromJSObject res')
490 :: [(String, J.Result InstanceConsoleInfo)] in
491 case sanitizeDictResults res'' of
492 Left err -> Left err
493 Right instInfos -> Right $ RpcResultInstanceConsoleInfo instInfos
494 _ -> Left $ JsonDecodeError
495 ("Expected JSObject, got " ++ show (pp_value res))
496
497 -- ** InstanceList
498
499 -- | Returns the list of running instances on the given nodes
500 $(buildObject "RpcCallInstanceList" "rpcCallInstList"
501 [ simpleField "hypervisors" [t| [Hypervisor] |] ])
502
503 $(buildObject "RpcResultInstanceList" "rpcResInstList"
504 [ simpleField "instances" [t| [String] |] ])
505
506 instance RpcCall RpcCallInstanceList where
507 rpcCallName _ = "instance_list"
508 rpcCallTimeout _ = rpcTimeoutToRaw Urgent
509 rpcCallAcceptOffline _ = False
510
511 instance Rpc RpcCallInstanceList RpcResultInstanceList where
512 rpcResultFill _ res = fromJSValueToRes res RpcResultInstanceList
513
514 -- ** NodeInfo
515
516 -- | Returns node information
517 $(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo"
518 [ simpleField "storage_units" [t| Map.Map String [StorageUnit] |]
519 , simpleField "hypervisors" [t| [ (Hypervisor, HvParams) ] |]
520 ])
521
522 $(buildObject "StorageInfo" "storageInfo"
523 [ simpleField "name" [t| String |]
524 , simpleField "type" [t| String |]
525 , optionalField $ simpleField "storage_free" [t| Int |]
526 , optionalField $ simpleField "storage_size" [t| Int |]
527 ])
528
529 -- | Common fields (as described in hv_base.py) are mandatory,
530 -- other fields are optional.
531 $(buildObject "HvInfo" "hvInfo"
532 [ optionalField $ simpleField C.hvNodeinfoKeyVersion [t| [Int] |]
533 , simpleField "memory_total" [t| Int |]
534 , simpleField "memory_free" [t| Int |]
535 , simpleField "memory_dom0" [t| Int |]
536 , optionalField $ simpleField "memory_hv" [t| Int |]
537 , simpleField "cpu_total" [t| Int |]
538 , simpleField "cpu_nodes" [t| Int |]
539 , simpleField "cpu_sockets" [t| Int |]
540 , simpleField "cpu_dom0" [t| Int |]
541 ])
542
543 $(buildObject "RpcResultNodeInfo" "rpcResNodeInfo"
544 [ simpleField "boot_id" [t| String |]
545 , simpleField "storage_info" [t| [StorageInfo] |]
546 , simpleField "hv_info" [t| [HvInfo] |]
547 ])
548
549 instance RpcCall RpcCallNodeInfo where
550 rpcCallName _ = "node_info"
551 rpcCallTimeout _ = rpcTimeoutToRaw Urgent
552 rpcCallAcceptOffline _ = False
553 rpcCallData n call = J.encode
554 ( fromMaybe (error $ "Programmer error: missing parameter for node named "
555 ++ nodeName n)
556 $ Map.lookup (uuidOf n) (rpcCallNodeInfoStorageUnits call)
557 , rpcCallNodeInfoHypervisors call
558 )
559
560 instance Rpc RpcCallNodeInfo RpcResultNodeInfo where
561 rpcResultFill _ res =
562 fromJSValueToRes res (\(b, vg, hv) -> RpcResultNodeInfo b vg hv)
563
564 -- ** Version
565
566 -- | Query node version.
567 $(buildObject "RpcCallVersion" "rpcCallVersion" [])
568
569 -- | Query node reply.
570 $(buildObject "RpcResultVersion" "rpcResultVersion"
571 [ simpleField "version" [t| Int |]
572 ])
573
574 instance RpcCall RpcCallVersion where
575 rpcCallName _ = "version"
576 rpcCallTimeout _ = rpcTimeoutToRaw Urgent
577 rpcCallAcceptOffline _ = True
578 rpcCallData _ = J.encode
579
580 instance Rpc RpcCallVersion RpcResultVersion where
581 rpcResultFill _ res = fromJSValueToRes res RpcResultVersion
582
583 -- ** StorageList
584
585 $(buildObject "RpcCallStorageList" "rpcCallStorageList"
586 [ simpleField "su_name" [t| StorageType |]
587 , simpleField "su_args" [t| [String] |]
588 , simpleField "name" [t| String |]
589 , simpleField "fields" [t| [StorageField] |]
590 ])
591
592 -- FIXME: The resulting JSValues should have types appropriate for their
593 -- StorageField value: Used -> Bool, Name -> String etc
594 $(buildObject "RpcResultStorageList" "rpcResStorageList"
595 [ simpleField "storage" [t| [[(StorageField, J.JSValue)]] |] ])
596
597 instance RpcCall RpcCallStorageList where
598 rpcCallName _ = "storage_list"
599 rpcCallTimeout _ = rpcTimeoutToRaw Normal
600 rpcCallAcceptOffline _ = False
601
602 instance Rpc RpcCallStorageList RpcResultStorageList where
603 rpcResultFill call res =
604 let sfields = rpcCallStorageListFields call in
605 fromJSValueToRes res (RpcResultStorageList . map (zip sfields))
606
607 -- ** TestDelay
608
609 -- | Call definition for test delay.
610 $(buildObject "RpcCallTestDelay" "rpcCallTestDelay"
611 [ simpleField "duration" [t| Double |]
612 ])
613
614 -- | Result definition for test delay.
615 data RpcResultTestDelay = RpcResultTestDelay
616 deriving Show
617
618 -- | Custom JSON instance for null result.
619 instance J.JSON RpcResultTestDelay where
620 showJSON _ = J.JSNull
621 readJSON J.JSNull = return RpcResultTestDelay
622 readJSON _ = fail "Unable to read RpcResultTestDelay"
623
624 instance RpcCall RpcCallTestDelay where
625 rpcCallName _ = "test_delay"
626 rpcCallTimeout = ceiling . (+ 5) . rpcCallTestDelayDuration
627 rpcCallAcceptOffline _ = False
628
629 instance Rpc RpcCallTestDelay RpcResultTestDelay where
630 rpcResultFill _ res = fromJSValueToRes res id
631
632 -- ** ExportList
633
634 -- | Call definition for export list.
635
636 $(buildObject "RpcCallExportList" "rpcCallExportList" [])
637
638 -- | Result definition for export list.
639 $(buildObject "RpcResultExportList" "rpcResExportList"
640 [ simpleField "exports" [t| [String] |]
641 ])
642
643 instance RpcCall RpcCallExportList where
644 rpcCallName _ = "export_list"
645 rpcCallTimeout _ = rpcTimeoutToRaw Fast
646 rpcCallAcceptOffline _ = False
647 rpcCallData _ = J.encode
648
649 instance Rpc RpcCallExportList RpcResultExportList where
650 rpcResultFill _ res = fromJSValueToRes res RpcResultExportList
651
652 -- ** Job Queue Replication
653
654 -- | Update a job queue file
655
656 $(buildObject "RpcCallJobqueueUpdate" "rpcCallJobqueueUpdate"
657 [ simpleField "file_name" [t| String |]
658 , simpleField "content" [t| String |]
659 ])
660
661 $(buildObject "RpcResultJobQueueUpdate" "rpcResultJobQueueUpdate" [])
662
663 instance RpcCall RpcCallJobqueueUpdate where
664 rpcCallName _ = "jobqueue_update"
665 rpcCallTimeout _ = rpcTimeoutToRaw Fast
666 rpcCallAcceptOffline _ = False
667 rpcCallData _ call = J.encode
668 ( rpcCallJobqueueUpdateFileName call
669 , toCompressed $ rpcCallJobqueueUpdateContent call
670 )
671
672 instance Rpc RpcCallJobqueueUpdate RpcResultJobQueueUpdate where
673 rpcResultFill _ res =
674 case res of
675 J.JSNull -> Right RpcResultJobQueueUpdate
676 _ -> Left $ JsonDecodeError
677 ("Expected JSNull, got " ++ show (pp_value res))
678
679 -- | Rename a file in the job queue
680
681 $(buildObject "RpcCallJobqueueRename" "rpcCallJobqueueRename"
682 [ simpleField "rename" [t| [(String, String)] |]
683 ])
684
685 $(buildObject "RpcResultJobqueueRename" "rpcResultJobqueueRename" [])
686
687 instance RpcCall RpcCallJobqueueRename where
688 rpcCallName _ = "jobqueue_rename"
689 rpcCallTimeout _ = rpcTimeoutToRaw Fast
690 rpcCallAcceptOffline _ = False
691
692 instance Rpc RpcCallJobqueueRename RpcResultJobqueueRename where
693 rpcResultFill call res =
694 -- Upon success, the RPC returns the list of return values of
695 -- the rename operations, which is always None, serialized to
696 -- null in JSON.
697 let expected = J.showJSON . map (const J.JSNull)
698 $ rpcCallJobqueueRenameRename call
699 in if res == expected
700 then Right RpcResultJobqueueRename
701 else Left
702 $ JsonDecodeError ("Expected JSNull, got " ++ show (pp_value res))
703
704 -- ** Watcher Status Update
705
706 -- | Set the watcher status
707
708 $(buildObject "RpcCallSetWatcherPause" "rpcCallSetWatcherPause"
709 [ optionalField $ timeAsDoubleField "time"
710 ])
711
712 instance RpcCall RpcCallSetWatcherPause where
713 rpcCallName _ = "set_watcher_pause"
714 rpcCallTimeout _ = rpcTimeoutToRaw Fast
715 rpcCallAcceptOffline _ = False
716
717 $(buildObject "RpcResultSetWatcherPause" "rpcResultSetWatcherPause" [])
718
719 instance Rpc RpcCallSetWatcherPause RpcResultSetWatcherPause where
720 rpcResultFill _ res =
721 case res of
722 J.JSNull -> Right RpcResultSetWatcherPause
723 _ -> Left $ JsonDecodeError
724 ("Expected JSNull, got " ++ show (pp_value res))
725
726 -- ** Queue drain status
727
728 -- | Set the queu drain flag
729
730 $(buildObject "RpcCallSetDrainFlag" "rpcCallSetDrainFlag"
731 [ simpleField "value" [t| Bool |]
732 ])
733
734 instance RpcCall RpcCallSetDrainFlag where
735 rpcCallName _ = "jobqueue_set_drain_flag"
736 rpcCallTimeout _ = rpcTimeoutToRaw Fast
737 rpcCallAcceptOffline _ = False
738
739 $(buildObject "RpcResultSetDrainFlag" "rpcResultSetDrainFalg" [])
740
741 instance Rpc RpcCallSetDrainFlag RpcResultSetDrainFlag where
742 rpcResultFill _ res =
743 case res of
744 J.JSNull -> Right RpcResultSetDrainFlag
745 _ -> Left $ JsonDecodeError
746 ("Expected JSNull, got " ++ show (pp_value res))
747
748 -- ** Configuration files upload to nodes
749
750 -- | Upload a configuration file to nodes
751
752 $(buildObject "RpcCallUploadFile" "rpcCallUploadFile"
753 [ simpleField "file_name" [t| FilePath |]
754 , simpleField "content" [t| Compressed |]
755 , optionalField $ fileModeAsIntField "mode"
756 , simpleField "uid" [t| String |]
757 , simpleField "gid" [t| String |]
758 , timeAsDoubleField "atime"
759 , timeAsDoubleField "mtime"
760 ])
761
762 instance RpcCall RpcCallUploadFile where
763 rpcCallName _ = "upload_file_single"
764 rpcCallTimeout _ = rpcTimeoutToRaw Normal
765 rpcCallAcceptOffline _ = False
766
767 $(buildObject "RpcResultUploadFile" "rpcResultUploadFile" [])
768
769 instance Rpc RpcCallUploadFile RpcResultUploadFile where
770 rpcResultFill _ res =
771 case res of
772 J.JSNull -> Right RpcResultUploadFile
773 _ -> Left $ JsonDecodeError
774 ("Expected JSNull, got " ++ show (pp_value res))
775
776 -- | Reads a file and constructs the corresponding 'RpcCallUploadFile' value.
777 prepareRpcCallUploadFile :: RuntimeEnts -> FilePath
778 -> ResultG RpcCallUploadFile
779 prepareRpcCallUploadFile re path = do
780 status <- liftIO $ getFileStatus path
781 content <- liftIO $ BL.readFile path
782 let lookupM x m = maybe (failError $ "Uid/gid " ++ show x ++
783 " not found, probably file " ++
784 show path ++ " isn't a Ganeti file")
785 return
786 (Map.lookup x m)
787 uid <- lookupM (fileOwner status) (reUidToUser re)
788 gid <- lookupM (fileGroup status) (reGidToGroup re)
789 vpath <- liftIO $ makeVirtualPath path
790 return $ RpcCallUploadFile
791 vpath
792 (packCompressed content)
793 (Just $ fileMode status)
794 uid
795 gid
796 (cTimeToClockTime $ accessTime status)
797 (cTimeToClockTime $ modificationTime status)
798
799 -- | Upload ssconf files to nodes
800
801 $(buildObject "RpcCallWriteSsconfFiles" "rpcCallWriteSsconfFiles"
802 [ simpleField "values" [t| SSConf |]
803 ])
804
805 instance RpcCall RpcCallWriteSsconfFiles where
806 rpcCallName _ = "write_ssconf_files"
807 rpcCallTimeout _ = rpcTimeoutToRaw Fast
808 rpcCallAcceptOffline _ = False
809
810 $(buildObject "RpcResultWriteSsconfFiles" "rpcResultWriteSsconfFiles" [])
811
812 instance Rpc RpcCallWriteSsconfFiles RpcResultWriteSsconfFiles where
813 rpcResultFill _ res =
814 case res of
815 J.JSNull -> Right RpcResultWriteSsconfFiles
816 _ -> Left $ JsonDecodeError
817 ("Expected JSNull, got " ++ show (pp_value res))
818
819 -- | Activate the master IP address
820
821 $(buildObject "RpcCallNodeActivateMasterIp" "rpcCallNodeActivateMasterIp"
822 [ simpleField "params" [t| MasterNetworkParameters |]
823 , simpleField "ems" [t| Bool |]
824 ])
825
826 instance RpcCall RpcCallNodeActivateMasterIp where
827 rpcCallName _ = "node_activate_master_ip"
828 rpcCallTimeout _ = rpcTimeoutToRaw Fast
829 rpcCallAcceptOffline _ = False
830
831 $(buildObject "RpcResultNodeActivateMasterIp" "rpcResultNodeActivateMasterIp"
832 [])
833
834 instance Rpc RpcCallNodeActivateMasterIp RpcResultNodeActivateMasterIp where
835 rpcResultFill _ res =
836 case res of
837 J.JSNull -> Right RpcResultNodeActivateMasterIp
838 _ -> Left $ JsonDecodeError
839 ("Expected JSNull, got " ++ show (pp_value res))
840
841 -- | Ask who the node believes is the master.
842
843 $(buildObject "RpcCallMasterNodeName" "rpcCallMasterNodeName" [])
844
845 instance RpcCall RpcCallMasterNodeName where
846 rpcCallName _ = "master_node_name"
847 rpcCallTimeout _ = rpcTimeoutToRaw Slow
848 rpcCallAcceptOffline _ = True
849
850 $(buildObject "RpcResultMasterNodeName" "rpcResultMasterNodeName"
851 [ simpleField "master" [t| String |]
852 ])
853
854 instance Rpc RpcCallMasterNodeName RpcResultMasterNodeName where
855 rpcResultFill _ res =
856 case res of
857 J.JSString master -> Right . RpcResultMasterNodeName
858 $ J.fromJSString master
859 _ -> Left . JsonDecodeError . (++) "expected string, but got " . show
860 $ pp_value res