Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Rpc.hs @ 35cded14

History | View | Annotate | Download (21.9 kB)

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

    
12
This program is free software; you can redistribute it and/or modify
13
it under the terms of the GNU General Public License as published by
14
the Free Software Foundation; either version 2 of the License, or
15
(at your option) any later version.
16

    
17
This program is distributed in the hope that it will be useful, but
18
WITHOUT ANY WARRANTY; without even the implied warranty of
19
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
20
General Public License for more details.
21

    
22
You should have received a copy of the GNU General Public License
23
along with this program; if not, write to the Free Software
24
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
25
02110-1301, USA.
26

    
27
-}
28

    
29
module Ganeti.Rpc
30
  ( RpcCall
31
  , Rpc
32
  , RpcError(..)
33
  , ERpcError
34
  , explainRpcError
35
  , executeRpcCall
36
  , executeRpcCalls
37
  , logRpcErrors
38

    
39
  , rpcCallName
40
  , rpcCallTimeout
41
  , rpcCallData
42
  , rpcCallAcceptOffline
43

    
44
  , rpcResultFill
45

    
46
  , RpcCallInstanceInfo(..)
47
  , InstanceState(..)
48
  , InstanceInfo(..)
49
  , RpcResultInstanceInfo(..)
50

    
51
  , RpcCallAllInstancesInfo(..)
52
  , RpcResultAllInstancesInfo(..)
53

    
54
  , InstanceConsoleInfoParams(..)
55
  , InstanceConsoleInfo(..)
56
  , RpcCallInstanceConsoleInfo(..)
57
  , RpcResultInstanceConsoleInfo(..)
58

    
59
  , RpcCallInstanceList(..)
60
  , RpcResultInstanceList(..)
61

    
62
  , HvInfo(..)
63
  , StorageInfo(..)
64
  , RpcCallNodeInfo(..)
65
  , RpcResultNodeInfo(..)
66

    
67
  , RpcCallVersion(..)
68
  , RpcResultVersion(..)
69

    
70
  , RpcCallStorageList(..)
71
  , RpcResultStorageList(..)
72

    
73
  , RpcCallTestDelay(..)
74
  , RpcResultTestDelay(..)
75

    
76
  , RpcCallExportList(..)
77
  , RpcResultExportList(..)
78

    
79
  , RpcCallJobqueueUpdate(..)
80
  , RpcCallJobqueueRename(..)
81
  , RpcCallSetWatcherPause(..)
82
  , RpcCallSetDrainFlag(..)
83
  ) where
84

    
85
import Control.Arrow (second)
86
import qualified Codec.Compression.Zlib as Zlib
87
import qualified Data.ByteString.Lazy.Char8 as BL
88
import qualified Data.Map as Map
89
import Data.Maybe (fromMaybe)
90
import qualified Text.JSON as J
91
import Text.JSON.Pretty (pp_value)
92
import qualified Data.ByteString.Base64.Lazy as Base64
93
import System.Directory
94

    
95
import Network.Curl hiding (content)
96
import qualified Ganeti.Path as P
97

    
98
import Ganeti.BasicTypes
99
import qualified Ganeti.Constants as C
100
import Ganeti.JSON
101
import Ganeti.Logging
102
import Ganeti.Objects
103
import Ganeti.THH
104
import Ganeti.Types
105
import Ganeti.Curl.Multi
106
import Ganeti.Utils
107

    
108
-- * Base RPC functionality and types
109

    
110
-- | The curl options used for RPC.
111
curlOpts :: [CurlOption]
112
curlOpts = [ CurlFollowLocation False
113
           , CurlSSLVerifyHost 0
114
           , CurlSSLVerifyPeer True
115
           , CurlSSLCertType "PEM"
116
           , CurlSSLKeyType "PEM"
117
           , CurlConnectTimeout (fromIntegral C.rpcConnectTimeout)
118
           ]
119

    
120
-- | Data type for RPC error reporting.
121
data RpcError
122
  = CurlLayerError String
123
  | JsonDecodeError String
124
  | RpcResultError String
125
  | OfflineNodeError
126
  deriving (Show, Eq)
127

    
128
-- | Provide explanation to RPC errors.
129
explainRpcError :: RpcError -> String
130
explainRpcError (CurlLayerError code) =
131
    "Curl error:" ++ code
132
explainRpcError (JsonDecodeError msg) =
133
    "Error while decoding JSON from HTTP response: " ++ msg
134
explainRpcError (RpcResultError msg) =
135
    "Error reponse received from RPC server: " ++ msg
136
explainRpcError OfflineNodeError =
137
    "Node is marked offline"
138

    
139
type ERpcError = Either RpcError
140

    
141
-- | A generic class for RPC calls.
142
class (ArrayObject a) => RpcCall a where
143
  -- | Give the (Python) name of the procedure.
144
  rpcCallName :: a -> String
145
  -- | Calculate the timeout value for the call execution.
146
  rpcCallTimeout :: a -> Int
147
  -- | Prepare arguments of the call to be send as POST.
148
  rpcCallData :: Node -> a -> String
149
  rpcCallData _ = J.encode . J.JSArray . toJSArray
150
  -- | Whether we accept offline nodes when making a call.
151
  rpcCallAcceptOffline :: a -> Bool
152

    
153
-- | Generic class that ensures matching RPC call with its respective
154
-- result.
155
class (RpcCall a, J.JSON b) => Rpc a b  | a -> b, b -> a where
156
  -- | Create a result based on the received HTTP response.
157
  rpcResultFill :: a -> J.JSValue -> ERpcError b
158

    
159
-- | Http Request definition.
160
data HttpClientRequest = HttpClientRequest
161
  { requestUrl  :: String       -- ^ The actual URL for the node endpoint
162
  , requestData :: String       -- ^ The arguments for the call
163
  , requestOpts :: [CurlOption] -- ^ The various curl options
164
  }
165

    
166
-- | Check if a string represented address is IPv6
167
isIpV6 :: String -> Bool
168
isIpV6 = (':' `elem`)
169

    
170
-- | Prepare url for the HTTP request.
171
prepareUrl :: (RpcCall a) => Node -> a -> String
172
prepareUrl node call =
173
  let node_ip = nodePrimaryIp node
174
      node_address = if isIpV6 node_ip
175
                     then "[" ++ node_ip ++ "]"
176
                     else node_ip
177
      port = C.defaultNodedPort
178
      path_prefix = "https://" ++ node_address ++ ":" ++ show port
179
  in path_prefix ++ "/" ++ rpcCallName call
180

    
181
-- | Create HTTP request for a given node provided it is online,
182
-- otherwise create empty response.
183
prepareHttpRequest :: (RpcCall a) => [CurlOption] -> Node -> a
184
                   -> ERpcError HttpClientRequest
185
prepareHttpRequest opts node call
186
  | rpcCallAcceptOffline call || not (nodeOffline node) =
187
      Right HttpClientRequest { requestUrl  = prepareUrl node call
188
                              , requestData = rpcCallData node call
189
                              , requestOpts = opts ++ curlOpts
190
                              }
191
  | otherwise = Left OfflineNodeError
192

    
193
-- | Parse an HTTP reply.
194
parseHttpReply :: (Rpc a b) =>
195
                  a -> ERpcError (CurlCode, String) -> ERpcError b
196
parseHttpReply _ (Left e) = Left e
197
parseHttpReply call (Right (CurlOK, body)) = parseHttpResponse call body
198
parseHttpReply _ (Right (code, err)) =
199
  Left . CurlLayerError $ "code: " ++ show code ++ ", explanation: " ++ err
200

    
201
-- | Parse a result based on the received HTTP response.
202
parseHttpResponse :: (Rpc a b) => a -> String -> ERpcError b
203
parseHttpResponse call res =
204
  case J.decode res of
205
    J.Error val -> Left $ JsonDecodeError val
206
    J.Ok (True, res'') -> rpcResultFill call res''
207
    J.Ok (False, jerr) -> case jerr of
208
       J.JSString msg -> Left $ RpcResultError (J.fromJSString msg)
209
       _ -> Left . JsonDecodeError $ show (pp_value jerr)
210

    
211
-- | Scan the list of results produced by executeRpcCall and log all the RPC
212
-- errors.
213
logRpcErrors :: [(a, ERpcError b)] -> IO ()
214
logRpcErrors allElems =
215
  let logOneRpcErr (_, Right _) = return ()
216
      logOneRpcErr (_, Left err) =
217
        logError $ "Error in the RPC HTTP reply: " ++ show err
218
  in mapM_ logOneRpcErr allElems
219

    
220
-- | Get options for RPC call
221
getOptionsForCall :: (Rpc a b) => FilePath -> FilePath -> a -> [CurlOption]
222
getOptionsForCall cert_path client_cert_path call =
223
  [ CurlTimeout (fromIntegral $ rpcCallTimeout call)
224
  , CurlSSLCert client_cert_path
225
  , CurlSSLKey client_cert_path
226
  , CurlCAInfo cert_path
227
  ]
228

    
229
-- | Execute multiple RPC calls in parallel
230
executeRpcCalls :: (Rpc a b) => [(Node, a)] -> IO [(Node, ERpcError b)]
231
executeRpcCalls nodeCalls = do
232
  cert_file <- P.nodedCertFile
233
  client_cert_file_name <- P.nodedClientCertFile
234
  client_file_exists <- doesFileExist client_cert_file_name
235
  -- FIXME: This is needed to ensure upgradability to 2.11
236
  -- Remove in 2.12.
237
  let client_cert_file = if client_file_exists
238
                         then client_cert_file_name
239
                         else cert_file
240
      (nodes, calls) = unzip nodeCalls
241
      opts = map (getOptionsForCall cert_file client_cert_file) calls
242
      opts_urls = zipWith3 (\n c o ->
243
                         case prepareHttpRequest o n c of
244
                           Left v -> Left v
245
                           Right request ->
246
                             Right (CurlPostFields [requestData request]:
247
                                    requestOpts request,
248
                                    requestUrl request)
249
                    ) nodes calls opts
250
  -- split the opts_urls list; we don't want to pass the
251
  -- failed-already nodes to Curl
252
  let (lefts, rights, trail) = splitEithers opts_urls
253
  results <- execMultiCall rights
254
  results' <- case recombineEithers lefts results trail of
255
                Bad msg -> error msg
256
                Ok r -> return r
257
  -- now parse the replies
258
  let results'' = zipWith parseHttpReply calls results'
259
      pairedList = zip nodes results''
260
  logRpcErrors pairedList
261
  return pairedList
262

    
263
-- | Execute an RPC call for many nodes in parallel.
264
executeRpcCall :: (Rpc a b) => [Node] -> a -> IO [(Node, ERpcError b)]
265
executeRpcCall nodes call = executeRpcCalls . zip nodes $ repeat call
266

    
267
-- | Helper function that is used to read dictionaries of values.
268
sanitizeDictResults :: [(String, J.Result a)] -> ERpcError [(String, a)]
269
sanitizeDictResults =
270
  foldr sanitize1 (Right [])
271
  where
272
    sanitize1 _ (Left e) = Left e
273
    sanitize1 (_, J.Error e) _ = Left $ JsonDecodeError e
274
    sanitize1 (name, J.Ok v) (Right res) = Right $ (name, v) : res
275

    
276
-- | Helper function to tranform JSON Result to Either RpcError b.
277
-- Note: For now we really only use it for b s.t. Rpc c b for some c
278
fromJResultToRes :: J.Result a -> (a -> b) -> ERpcError b
279
fromJResultToRes (J.Error v) _ = Left $ JsonDecodeError v
280
fromJResultToRes (J.Ok v) f = Right $ f v
281

    
282
-- | Helper function transforming JSValue to Rpc result type.
283
fromJSValueToRes :: (J.JSON a) => J.JSValue -> (a -> b) -> ERpcError b
284
fromJSValueToRes val = fromJResultToRes (J.readJSON val)
285

    
286
-- * RPC calls and results
287

    
288
-- ** Instance info
289

    
290
-- | Returns information about a single instance
291
$(buildObject "RpcCallInstanceInfo" "rpcCallInstInfo"
292
  [ simpleField "instance" [t| String |]
293
  , simpleField "hname" [t| Hypervisor |]
294
  ])
295

    
296
$(declareILADT "InstanceState"
297
  [ ("InstanceStateRunning", 0)
298
  , ("InstanceStateShutdown", 1)
299
  ])
300

    
301
$(makeJSONInstance ''InstanceState)
302

    
303
instance PyValue InstanceState where
304
  showValue = show . instanceStateToRaw
305

    
306
$(buildObject "InstanceInfo" "instInfo"
307
  [ simpleField "memory" [t| Int|]
308
  , simpleField "state"  [t| InstanceState |]
309
  , simpleField "vcpus"  [t| Int |]
310
  , simpleField "time"   [t| Int |]
311
  ])
312

    
313
-- This is optional here because the result may be empty if instance is
314
-- not on a node - and this is not considered an error.
315
$(buildObject "RpcResultInstanceInfo" "rpcResInstInfo"
316
  [ optionalField $ simpleField "inst_info" [t| InstanceInfo |]])
317

    
318
instance RpcCall RpcCallInstanceInfo where
319
  rpcCallName _          = "instance_info"
320
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
321
  rpcCallAcceptOffline _ = False
322

    
323
instance Rpc RpcCallInstanceInfo RpcResultInstanceInfo where
324
  rpcResultFill _ res =
325
    case res of
326
      J.JSObject res' ->
327
        case J.fromJSObject res' of
328
          [] -> Right $ RpcResultInstanceInfo Nothing
329
          _ -> fromJSValueToRes res (RpcResultInstanceInfo . Just)
330
      _ -> Left $ JsonDecodeError
331
           ("Expected JSObject, got " ++ show (pp_value res))
332

    
333
-- ** AllInstancesInfo
334

    
335
-- | Returns information about all running instances on the given nodes
336
$(buildObject "RpcCallAllInstancesInfo" "rpcCallAllInstInfo"
337
  [ simpleField "hypervisors" [t| [(Hypervisor, HvParams)] |] ])
338

    
339
$(buildObject "RpcResultAllInstancesInfo" "rpcResAllInstInfo"
340
  [ simpleField "instances" [t| [(String, InstanceInfo)] |] ])
341

    
342
instance RpcCall RpcCallAllInstancesInfo where
343
  rpcCallName _          = "all_instances_info"
344
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
345
  rpcCallAcceptOffline _ = False
346
  rpcCallData _ call     = J.encode (
347
    map fst $ rpcCallAllInstInfoHypervisors call,
348
    GenericContainer . Map.fromList $ rpcCallAllInstInfoHypervisors call)
349

    
350
instance Rpc RpcCallAllInstancesInfo RpcResultAllInstancesInfo where
351
  -- FIXME: Is there a simpler way to do it?
352
  rpcResultFill _ res =
353
    case res of
354
      J.JSObject res' ->
355
        let res'' = map (second J.readJSON) (J.fromJSObject res')
356
                        :: [(String, J.Result InstanceInfo)] in
357
        case sanitizeDictResults res'' of
358
          Left err -> Left err
359
          Right insts -> Right $ RpcResultAllInstancesInfo insts
360
      _ -> Left $ JsonDecodeError
361
           ("Expected JSObject, got " ++ show (pp_value res))
362

    
363
-- ** InstanceConsoleInfo
364

    
365
-- | Returns information about how to access instances on the given node
366
$(buildObject "InstanceConsoleInfoParams" "instConsInfoParams"
367
  [ simpleField "instance"    [t| Instance |]
368
  , simpleField "node"        [t| Node |]
369
  , simpleField "group"       [t| NodeGroup |]
370
  , simpleField "hvParams"    [t| HvParams |]
371
  , simpleField "beParams"    [t| FilledBeParams |]
372
  ])
373

    
374
$(buildObject "RpcCallInstanceConsoleInfo" "rpcCallInstConsInfo"
375
  [ simpleField "instanceInfo" [t| [(String, InstanceConsoleInfoParams)] |] ])
376

    
377
$(buildObject "InstanceConsoleInfo" "instConsInfo"
378
  [ simpleField "instance"    [t| String |]
379
  , simpleField "kind"        [t| String |]
380
  , optionalField $
381
    simpleField "message"     [t| String |]
382
  , optionalField $
383
    simpleField "host"        [t| String |]
384
  , optionalField $
385
    simpleField "port"        [t| Int |]
386
  , optionalField $
387
    simpleField "user"        [t| String |]
388
  , optionalField $
389
    simpleField "command"     [t| [String] |]
390
  , optionalField $
391
    simpleField "display"     [t| String |]
392
  ])
393

    
394
$(buildObject "RpcResultInstanceConsoleInfo" "rpcResInstConsInfo"
395
  [ simpleField "instancesInfo" [t| [(String, InstanceConsoleInfo)] |] ])
396

    
397
instance RpcCall RpcCallInstanceConsoleInfo where
398
  rpcCallName _          = "instance_console_info"
399
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
400
  rpcCallAcceptOffline _ = False
401
  rpcCallData _ call     = J.encode .
402
    GenericContainer $ Map.fromList (rpcCallInstConsInfoInstanceInfo call)
403

    
404
instance Rpc RpcCallInstanceConsoleInfo RpcResultInstanceConsoleInfo where
405
  rpcResultFill _ res =
406
    case res of
407
      J.JSObject res' ->
408
        let res'' = map (second J.readJSON) (J.fromJSObject res')
409
                        :: [(String, J.Result InstanceConsoleInfo)] in
410
        case sanitizeDictResults res'' of
411
          Left err -> Left err
412
          Right instInfos -> Right $ RpcResultInstanceConsoleInfo instInfos
413
      _ -> Left $ JsonDecodeError
414
           ("Expected JSObject, got " ++ show (pp_value res))
415

    
416
-- ** InstanceList
417

    
418
-- | Returns the list of running instances on the given nodes
419
$(buildObject "RpcCallInstanceList" "rpcCallInstList"
420
  [ simpleField "hypervisors" [t| [Hypervisor] |] ])
421

    
422
$(buildObject "RpcResultInstanceList" "rpcResInstList"
423
  [ simpleField "instances" [t| [String] |] ])
424

    
425
instance RpcCall RpcCallInstanceList where
426
  rpcCallName _          = "instance_list"
427
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
428
  rpcCallAcceptOffline _ = False
429

    
430
instance Rpc RpcCallInstanceList RpcResultInstanceList where
431
  rpcResultFill _ res = fromJSValueToRes res RpcResultInstanceList
432

    
433
-- ** NodeInfo
434

    
435
-- | Returns node information
436
$(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo"
437
  [ simpleField "storage_units" [t| Map.Map String [StorageUnit] |]
438
  , simpleField "hypervisors" [t| [ (Hypervisor, HvParams) ] |]
439
  ])
440

    
441
$(buildObject "StorageInfo" "storageInfo"
442
  [ simpleField "name" [t| String |]
443
  , simpleField "type" [t| String |]
444
  , optionalField $ simpleField "storage_free" [t| Int |]
445
  , optionalField $ simpleField "storage_size" [t| Int |]
446
  ])
447

    
448
-- | We only provide common fields as described in hv_base.py.
449
$(buildObject "HvInfo" "hvInfo"
450
  [ simpleField "memory_total" [t| Int |]
451
  , simpleField "memory_free" [t| Int |]
452
  , simpleField "memory_dom0" [t| Int |]
453
  , simpleField "cpu_total" [t| Int |]
454
  , simpleField "cpu_nodes" [t| Int |]
455
  , simpleField "cpu_sockets" [t| Int |]
456
  , simpleField "cpu_dom0" [t| Int |]
457
  ])
458

    
459
$(buildObject "RpcResultNodeInfo" "rpcResNodeInfo"
460
  [ simpleField "boot_id" [t| String |]
461
  , simpleField "storage_info" [t| [StorageInfo] |]
462
  , simpleField "hv_info" [t| [HvInfo] |]
463
  ])
464

    
465
instance RpcCall RpcCallNodeInfo where
466
  rpcCallName _          = "node_info"
467
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
468
  rpcCallAcceptOffline _ = False
469
  rpcCallData n call     = J.encode
470
    ( fromMaybe (error $ "Programmer error: missing parameter for node named "
471
                         ++ nodeName n)
472
          $ Map.lookup (nodeUuid n) (rpcCallNodeInfoStorageUnits call)
473
    , rpcCallNodeInfoHypervisors call
474
    )
475

    
476
instance Rpc RpcCallNodeInfo RpcResultNodeInfo where
477
  rpcResultFill _ res =
478
    fromJSValueToRes res (\(b, vg, hv) -> RpcResultNodeInfo b vg hv)
479

    
480
-- ** Version
481

    
482
-- | Query node version.
483
$(buildObject "RpcCallVersion" "rpcCallVersion" [])
484

    
485
-- | Query node reply.
486
$(buildObject "RpcResultVersion" "rpcResultVersion"
487
  [ simpleField "version" [t| Int |]
488
  ])
489

    
490
instance RpcCall RpcCallVersion where
491
  rpcCallName _          = "version"
492
  rpcCallTimeout _       = rpcTimeoutToRaw Urgent
493
  rpcCallAcceptOffline _ = True
494
  rpcCallData _          = J.encode
495

    
496
instance Rpc RpcCallVersion RpcResultVersion where
497
  rpcResultFill _ res = fromJSValueToRes res RpcResultVersion
498

    
499
-- ** StorageList
500

    
501
$(buildObject "RpcCallStorageList" "rpcCallStorageList"
502
  [ simpleField "su_name" [t| StorageType |]
503
  , simpleField "su_args" [t| [String] |]
504
  , simpleField "name"    [t| String |]
505
  , simpleField "fields"  [t| [StorageField] |]
506
  ])
507

    
508
-- FIXME: The resulting JSValues should have types appropriate for their
509
-- StorageField value: Used -> Bool, Name -> String etc
510
$(buildObject "RpcResultStorageList" "rpcResStorageList"
511
  [ simpleField "storage" [t| [[(StorageField, J.JSValue)]] |] ])
512

    
513
instance RpcCall RpcCallStorageList where
514
  rpcCallName _          = "storage_list"
515
  rpcCallTimeout _       = rpcTimeoutToRaw Normal
516
  rpcCallAcceptOffline _ = False
517

    
518
instance Rpc RpcCallStorageList RpcResultStorageList where
519
  rpcResultFill call res =
520
    let sfields = rpcCallStorageListFields call in
521
    fromJSValueToRes res (RpcResultStorageList . map (zip sfields))
522

    
523
-- ** TestDelay
524

    
525
-- | Call definition for test delay.
526
$(buildObject "RpcCallTestDelay" "rpcCallTestDelay"
527
  [ simpleField "duration" [t| Double |]
528
  ])
529

    
530
-- | Result definition for test delay.
531
data RpcResultTestDelay = RpcResultTestDelay
532
                          deriving Show
533

    
534
-- | Custom JSON instance for null result.
535
instance J.JSON RpcResultTestDelay where
536
  showJSON _        = J.JSNull
537
  readJSON J.JSNull = return RpcResultTestDelay
538
  readJSON _        = fail "Unable to read RpcResultTestDelay"
539

    
540
instance RpcCall RpcCallTestDelay where
541
  rpcCallName _          = "test_delay"
542
  rpcCallTimeout         = ceiling . (+ 5) . rpcCallTestDelayDuration
543
  rpcCallAcceptOffline _ = False
544

    
545
instance Rpc RpcCallTestDelay RpcResultTestDelay where
546
  rpcResultFill _ res = fromJSValueToRes res id
547

    
548
-- ** ExportList
549

    
550
-- | Call definition for export list.
551

    
552
$(buildObject "RpcCallExportList" "rpcCallExportList" [])
553

    
554
-- | Result definition for export list.
555
$(buildObject "RpcResultExportList" "rpcResExportList"
556
  [ simpleField "exports" [t| [String] |]
557
  ])
558

    
559
instance RpcCall RpcCallExportList where
560
  rpcCallName _          = "export_list"
561
  rpcCallTimeout _       = rpcTimeoutToRaw Fast
562
  rpcCallAcceptOffline _ = False
563
  rpcCallData _          = J.encode
564

    
565
instance Rpc RpcCallExportList RpcResultExportList where
566
  rpcResultFill _ res = fromJSValueToRes res RpcResultExportList
567

    
568
-- ** Job Queue Replication
569
  
570
-- | Update a job queue file
571
  
572
$(buildObject "RpcCallJobqueueUpdate" "rpcCallJobqueueUpdate"
573
  [ simpleField "file_name" [t| String |]
574
  , simpleField "content" [t| String |]
575
  ])
576

    
577
$(buildObject "RpcResultJobQueueUpdate" "rpcResultJobQueueUpdate" [])
578

    
579
instance RpcCall RpcCallJobqueueUpdate where
580
  rpcCallName _          = "jobqueue_update"
581
  rpcCallTimeout _       = rpcTimeoutToRaw Fast
582
  rpcCallAcceptOffline _ = False
583
  rpcCallData _ call     = J.encode
584
    ( rpcCallJobqueueUpdateFileName call
585
    , ( C.rpcEncodingZlibBase64
586
      , BL.unpack . Base64.encode . Zlib.compress . BL.pack
587
          $ rpcCallJobqueueUpdateContent call
588
      )
589
    )
590

    
591
instance Rpc RpcCallJobqueueUpdate RpcResultJobQueueUpdate where
592
  rpcResultFill _ res =
593
    case res of
594
      J.JSNull ->  Right RpcResultJobQueueUpdate
595
      _ -> Left $ JsonDecodeError
596
           ("Expected JSNull, got " ++ show (pp_value res))
597

    
598
-- | Rename a file in the job queue
599

    
600
$(buildObject "RpcCallJobqueueRename" "rpcCallJobqueueRename"
601
  [ simpleField "rename" [t| [(String, String)] |]
602
  ])
603

    
604
$(buildObject "RpcResultJobqueueRename" "rpcResultJobqueueRename" [])
605

    
606
instance RpcCall RpcCallJobqueueRename where
607
  rpcCallName _          = "jobqueue_rename"
608
  rpcCallTimeout _       = rpcTimeoutToRaw Fast
609
  rpcCallAcceptOffline _ = False
610

    
611
instance Rpc RpcCallJobqueueRename RpcResultJobqueueRename where
612
  rpcResultFill call res =
613
    -- Upon success, the RPC returns the list of return values of
614
    -- the rename operations, which is always None, serialized to
615
    -- null in JSON.
616
    let expected = J.showJSON . map (const J.JSNull)
617
                     $ rpcCallJobqueueRenameRename call
618
    in if res == expected
619
      then Right RpcResultJobqueueRename
620
      else Left
621
             $ JsonDecodeError ("Expected JSNull, got " ++ show (pp_value res))
622

    
623
-- ** Watcher Status Update
624
      
625
-- | Set the watcher status
626
      
627
$(buildObject "RpcCallSetWatcherPause" "rpcCallSetWatcherPause"
628
  [ optionalField $ timeAsDoubleField "time"
629
  ])
630

    
631
instance RpcCall RpcCallSetWatcherPause where
632
  rpcCallName _          = "set_watcher_pause"
633
  rpcCallTimeout _       = rpcTimeoutToRaw Fast
634
  rpcCallAcceptOffline _ = False
635

    
636
$(buildObject "RpcResultSetWatcherPause" "rpcResultSetWatcherPause" [])
637

    
638
instance Rpc RpcCallSetWatcherPause RpcResultSetWatcherPause where
639
  rpcResultFill _ res =
640
    case res of
641
      J.JSNull ->  Right RpcResultSetWatcherPause
642
      _ -> Left $ JsonDecodeError
643
           ("Expected JSNull, got " ++ show (pp_value res))
644

    
645
-- ** Queue drain status
646
      
647
-- | Set the queu drain flag
648
      
649
$(buildObject "RpcCallSetDrainFlag" "rpcCallSetDrainFlag"
650
  [ simpleField "value" [t| Bool |]
651
  ])
652

    
653
instance RpcCall RpcCallSetDrainFlag where
654
  rpcCallName _          = "jobqueue_set_drain_flag"
655
  rpcCallTimeout _       = rpcTimeoutToRaw Fast
656
  rpcCallAcceptOffline _ = False
657

    
658
$(buildObject "RpcResultSetDrainFlag" "rpcResultSetDrainFalg" [])
659

    
660
instance Rpc RpcCallSetDrainFlag RpcResultSetDrainFlag where
661
  rpcResultFill _ res =
662
    case res of
663
      J.JSNull ->  Right RpcResultSetDrainFlag
664
      _ -> Left $ JsonDecodeError
665
           ("Expected JSNull, got " ++ show (pp_value res))
666