Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Luxi.hs @ 9131274c

History | View | Annotate | Download (11.9 kB)

1
{-# LANGUAGE TemplateHaskell #-}
2

    
3
{-| Implementation of the Ganeti LUXI interface.
4

    
5
-}
6

    
7
{-
8

    
9
Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
10

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

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

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

    
26
-}
27

    
28
module Ganeti.Luxi
29
  ( LuxiOp(..)
30
  , LuxiReq(..)
31
  , Client
32
  , Server
33
  , JobId
34
  , fromJobId
35
  , makeJobId
36
  , RecvResult(..)
37
  , strOfOp
38
  , getLuxiClient
39
  , getLuxiServer
40
  , acceptClient
41
  , closeClient
42
  , closeServer
43
  , callMethod
44
  , submitManyJobs
45
  , queryJobsStatus
46
  , buildCall
47
  , buildResponse
48
  , decodeLuxiCall
49
  , recvMsg
50
  , recvMsgExt
51
  , sendMsg
52
  , allLuxiCalls
53
  ) where
54

    
55
import Control.Monad
56
import qualified Data.ByteString.UTF8 as UTF8
57
import Text.JSON (encodeStrict, decodeStrict)
58
import qualified Text.JSON as J
59
import Text.JSON.Pretty (pp_value)
60
import Text.JSON.Types
61

    
62
import Ganeti.BasicTypes
63
import Ganeti.Constants
64
import Ganeti.Errors
65
import Ganeti.JSON
66
import Ganeti.UDSServer
67
import Ganeti.OpParams (pTagsObject)
68
import Ganeti.OpCodes
69
import qualified Ganeti.Query.Language as Qlang
70
import Ganeti.Runtime (GanetiDaemon(..))
71
import Ganeti.THH
72
import Ganeti.Types
73

    
74

    
75
-- | Currently supported Luxi operations and JSON serialization.
76
$(genLuxiOp "LuxiOp"
77
  [ (luxiReqQuery,
78
    [ simpleField "what"    [t| Qlang.ItemType |]
79
    , simpleField "fields"  [t| [String]  |]
80
    , simpleField "qfilter" [t| Qlang.Filter Qlang.FilterField |]
81
    ])
82
  , (luxiReqQueryFields,
83
    [ simpleField "what"    [t| Qlang.ItemType |]
84
    , simpleField "fields"  [t| [String]  |]
85
    ])
86
  , (luxiReqQueryNodes,
87
     [ simpleField "names"  [t| [String] |]
88
     , simpleField "fields" [t| [String] |]
89
     , simpleField "lock"   [t| Bool     |]
90
     ])
91
  , (luxiReqQueryGroups,
92
     [ simpleField "names"  [t| [String] |]
93
     , simpleField "fields" [t| [String] |]
94
     , simpleField "lock"   [t| Bool     |]
95
     ])
96
  , (luxiReqQueryNetworks,
97
     [ simpleField "names"  [t| [String] |]
98
     , simpleField "fields" [t| [String] |]
99
     , simpleField "lock"   [t| Bool     |]
100
     ])
101
  , (luxiReqQueryInstances,
102
     [ simpleField "names"  [t| [String] |]
103
     , simpleField "fields" [t| [String] |]
104
     , simpleField "lock"   [t| Bool     |]
105
     ])
106
  , (luxiReqQueryJobs,
107
     [ simpleField "ids"    [t| [JobId]  |]
108
     , simpleField "fields" [t| [String] |]
109
     ])
110
  , (luxiReqQueryExports,
111
     [ simpleField "nodes" [t| [String] |]
112
     , simpleField "lock"  [t| Bool     |]
113
     ])
114
  , (luxiReqQueryConfigValues,
115
     [ simpleField "fields" [t| [String] |] ]
116
    )
117
  , (luxiReqQueryClusterInfo, [])
118
  , (luxiReqQueryTags,
119
     [ pTagsObject
120
     , simpleField "name" [t| String |]
121
     ])
122
  , (luxiReqSubmitJob,
123
     [ simpleField "job" [t| [MetaOpCode] |] ]
124
    )
125
  , (luxiReqSubmitJobToDrainedQueue,
126
     [ simpleField "job" [t| [MetaOpCode] |] ]
127
    )
128
  , (luxiReqSubmitManyJobs,
129
     [ simpleField "ops" [t| [[MetaOpCode]] |] ]
130
    )
131
  , (luxiReqWaitForJobChange,
132
     [ simpleField "job"      [t| JobId   |]
133
     , simpleField "fields"   [t| [String]|]
134
     , simpleField "prev_job" [t| JSValue |]
135
     , simpleField "prev_log" [t| JSValue |]
136
     , simpleField "tmout"    [t| Int     |]
137
     ])
138
  , (luxiReqPickupJob,
139
     [ simpleField "job" [t| JobId |] ]
140
    )
141
  , (luxiReqArchiveJob,
142
     [ simpleField "job" [t| JobId |] ]
143
    )
144
  , (luxiReqAutoArchiveJobs,
145
     [ simpleField "age"   [t| Int |]
146
     , simpleField "tmout" [t| Int |]
147
     ])
148
  , (luxiReqCancelJob,
149
     [ simpleField "job" [t| JobId |] ]
150
    )
151
  , (luxiReqChangeJobPriority,
152
     [ simpleField "job"      [t| JobId |]
153
     , simpleField "priority" [t| Int |] ]
154
    )
155
  , (luxiReqSetDrainFlag,
156
     [ simpleField "flag" [t| Bool |] ]
157
    )
158
  , (luxiReqSetWatcherPause,
159
     [ optionalNullSerField
160
         $ simpleField "duration" [t| Double |] ]
161
    )
162
  ])
163

    
164
$(makeJSONInstance ''LuxiReq)
165

    
166
-- | List of all defined Luxi calls.
167
$(genAllConstr (drop 3) ''LuxiReq "allLuxiCalls")
168

    
169
-- | The serialisation of LuxiOps into strings in messages.
170
$(genStrOfOp ''LuxiOp "strOfOp")
171

    
172

    
173
luxiConnectConfig :: ConnectConfig
174
luxiConnectConfig = ConnectConfig { connDaemon = GanetiLuxid
175
                                  , recvTmo    = luxiDefRwto
176
                                  , sendTmo    = luxiDefRwto
177
                                  }
178

    
179
-- | Connects to the master daemon and returns a luxi Client.
180
getLuxiClient :: String -> IO Client
181
getLuxiClient = connectClient luxiConnectConfig luxiDefCtmo
182

    
183
-- | Creates and returns a server endpoint.
184
getLuxiServer :: Bool -> FilePath -> IO Server
185
getLuxiServer = connectServer luxiConnectConfig
186

    
187
-- | Serialize a request to String.
188
buildCall :: LuxiOp  -- ^ The method
189
          -> String  -- ^ The serialized form
190
buildCall lo =
191
  let ja = [ (strOfKey Method, J.showJSON $ strOfOp lo)
192
           , (strOfKey Args, opToArgs lo)
193
           ]
194
      jo = toJSObject ja
195
  in encodeStrict jo
196

    
197

    
198
-- | Converts Luxi call arguments into a 'LuxiOp' data structure.
199
-- This is used for building a Luxi 'Handler'.
200
--
201
-- This is currently hand-coded until we make it more uniform so that
202
-- it can be generated using TH.
203
decodeLuxiCall :: JSValue -> JSValue -> Result LuxiOp
204
decodeLuxiCall method args = do
205
  call <- fromJResult "Unable to parse LUXI request method" $ J.readJSON method
206
  case call of
207
    ReqQueryJobs -> do
208
              (jids, jargs) <- fromJVal args
209
              jids' <- case jids of
210
                         JSNull -> return []
211
                         _ -> fromJVal jids
212
              return $ QueryJobs jids' jargs
213
    ReqQueryInstances -> do
214
              (names, fields, locking) <- fromJVal args
215
              return $ QueryInstances names fields locking
216
    ReqQueryNodes -> do
217
              (names, fields, locking) <- fromJVal args
218
              return $ QueryNodes names fields locking
219
    ReqQueryGroups -> do
220
              (names, fields, locking) <- fromJVal args
221
              return $ QueryGroups names fields locking
222
    ReqQueryClusterInfo ->
223
              return QueryClusterInfo
224
    ReqQueryNetworks -> do
225
              (names, fields, locking) <- fromJVal args
226
              return $ QueryNetworks names fields locking
227
    ReqQuery -> do
228
              (what, fields, qfilter) <- fromJVal args
229
              return $ Query what fields qfilter
230
    ReqQueryFields -> do
231
              (what, fields) <- fromJVal args
232
              fields' <- case fields of
233
                           JSNull -> return []
234
                           _ -> fromJVal fields
235
              return $ QueryFields what fields'
236
    ReqSubmitJob -> do
237
              [ops1] <- fromJVal args
238
              ops2 <- mapM (fromJResult (luxiReqToRaw call) . J.readJSON) ops1
239
              return $ SubmitJob ops2
240
    ReqSubmitJobToDrainedQueue -> do
241
              [ops1] <- fromJVal args
242
              ops2 <- mapM (fromJResult (luxiReqToRaw call) . J.readJSON) ops1
243
              return $ SubmitJobToDrainedQueue ops2
244
    ReqSubmitManyJobs -> do
245
              [ops1] <- fromJVal args
246
              ops2 <- mapM (fromJResult (luxiReqToRaw call) . J.readJSON) ops1
247
              return $ SubmitManyJobs ops2
248
    ReqWaitForJobChange -> do
249
              (jid, fields, pinfo, pidx, wtmout) <-
250
                -- No instance for 5-tuple, code copied from the
251
                -- json sources and adapted
252
                fromJResult "Parsing WaitForJobChange message" $
253
                case args of
254
                  JSArray [a, b, c, d, e] ->
255
                    (,,,,) `fmap`
256
                    J.readJSON a `ap`
257
                    J.readJSON b `ap`
258
                    J.readJSON c `ap`
259
                    J.readJSON d `ap`
260
                    J.readJSON e
261
                  _ -> J.Error "Not enough values"
262
              return $ WaitForJobChange jid fields pinfo pidx wtmout
263
    ReqPickupJob -> do
264
              [jid] <- fromJVal args
265
              return $ PickupJob jid
266
    ReqArchiveJob -> do
267
              [jid] <- fromJVal args
268
              return $ ArchiveJob jid
269
    ReqAutoArchiveJobs -> do
270
              (age, tmout) <- fromJVal args
271
              return $ AutoArchiveJobs age tmout
272
    ReqQueryExports -> do
273
              (nodes, lock) <- fromJVal args
274
              return $ QueryExports nodes lock
275
    ReqQueryConfigValues -> do
276
              [fields] <- fromJVal args
277
              return $ QueryConfigValues fields
278
    ReqQueryTags -> do
279
              (kind, name) <- fromJVal args
280
              return $ QueryTags kind name
281
    ReqCancelJob -> do
282
              [jid] <- fromJVal args
283
              return $ CancelJob jid
284
    ReqChangeJobPriority -> do
285
              (jid, priority) <- fromJVal args
286
              return $ ChangeJobPriority jid priority
287
    ReqSetDrainFlag -> do
288
              [flag] <- fromJVal args
289
              return $ SetDrainFlag flag
290
    ReqSetWatcherPause -> do
291
              let duration = case args of
292
                               JSArray [JSRational _ x] 
293
                                 -> Just (fromRational x :: Double)
294
                               _ -> Nothing
295
              return $ SetWatcherPause duration
296

    
297
-- | Check that luxi responses contain the required keys and that the
298
-- call was successful.
299
validateResult :: String -> ErrorResult JSValue
300
validateResult s = do
301
  when (UTF8.replacement_char `elem` s) $
302
       fail "Failed to decode UTF-8, detected replacement char after decoding"
303
  oarr <- fromJResult "Parsing LUXI response" (decodeStrict s)
304
  let arr = J.fromJSObject oarr
305
  status <- fromObj arr (strOfKey Success)
306
  result <- fromObj arr (strOfKey Result)
307
  if status
308
    then return result
309
    else decodeError result
310

    
311
-- | Try to decode an error from the server response. This function
312
-- will always fail, since it's called only on the error path (when
313
-- status is False).
314
decodeError :: JSValue -> ErrorResult JSValue
315
decodeError val =
316
  case fromJVal val of
317
    Ok e -> Bad e
318
    Bad msg -> Bad $ GenericError msg
319

    
320
-- | Generic luxi method call.
321
callMethod :: LuxiOp -> Client -> IO (ErrorResult JSValue)
322
callMethod method s = do
323
  sendMsg s $ buildCall method
324
  result <- recvMsg s
325
  let rval = validateResult result
326
  return rval
327

    
328
-- | Parse job submission result.
329
parseSubmitJobResult :: JSValue -> ErrorResult JobId
330
parseSubmitJobResult (JSArray [JSBool True, v]) =
331
  case J.readJSON v of
332
    J.Error msg -> Bad $ LuxiError msg
333
    J.Ok v' -> Ok v'
334
parseSubmitJobResult (JSArray [JSBool False, JSString x]) =
335
  Bad . LuxiError $ fromJSString x
336
parseSubmitJobResult v =
337
  Bad . LuxiError $ "Unknown result from the master daemon: " ++
338
      show (pp_value v)
339

    
340
-- | Specialized submitManyJobs call.
341
submitManyJobs :: Client -> [[MetaOpCode]] -> IO (ErrorResult [JobId])
342
submitManyJobs s jobs = do
343
  rval <- callMethod (SubmitManyJobs jobs) s
344
  -- map each result (status, payload) pair into a nice Result ADT
345
  return $ case rval of
346
             Bad x -> Bad x
347
             Ok (JSArray r) -> mapM parseSubmitJobResult r
348
             x -> Bad . LuxiError $
349
                  "Cannot parse response from Ganeti: " ++ show x
350

    
351
-- | Custom queryJobs call.
352
queryJobsStatus :: Client -> [JobId] -> IO (ErrorResult [JobStatus])
353
queryJobsStatus s jids = do
354
  rval <- callMethod (QueryJobs jids ["status"]) s
355
  return $ case rval of
356
             Bad x -> Bad x
357
             Ok y -> case J.readJSON y::(J.Result [[JobStatus]]) of
358
                       J.Ok vals -> if any null vals
359
                                    then Bad $
360
                                         LuxiError "Missing job status field"
361
                                    else Ok (map head vals)
362
                       J.Error x -> Bad $ LuxiError x