Luxi.hs 15.1 KB
Newer Older
1
2
{-# LANGUAGE TemplateHaskell #-}

3
4
5
6
7
8
{-| Implementation of the Ganeti LUXI interface.

-}

{-

9
Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28

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

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

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

-}

module Ganeti.Luxi
29
  ( LuxiOp(..)
Iustin Pop's avatar
Iustin Pop committed
30
  , LuxiReq(..)
31
  , Client
32
  , JobId
Iustin Pop's avatar
Iustin Pop committed
33
34
  , fromJobId
  , makeJobId
35
36
  , RecvResult(..)
  , strOfOp
37
  , getClient
38
39
  , getServer
  , acceptClient
40
  , closeClient
41
  , closeServer
42
43
44
  , callMethod
  , submitManyJobs
  , queryJobsStatus
45
  , buildCall
46
  , buildResponse
47
48
  , validateCall
  , decodeCall
49
  , recvMsg
50
  , recvMsgExt
51
  , sendMsg
52
  , allLuxiCalls
53
  ) where
54

55
import Control.Exception (catch)
56
import Data.IORef
57
58
59
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as UTF8
import Data.Word (Word8)
60
import Control.Monad
Iustin Pop's avatar
Iustin Pop committed
61
import Text.JSON (encodeStrict, decodeStrict)
62
import qualified Text.JSON as J
63
import Text.JSON.Pretty (pp_value)
64
import Text.JSON.Types
65
import System.Directory (removeFile)
66
import System.IO (hClose, hFlush, hWaitForInput, Handle, IOMode(..))
67
import System.IO.Error (isEOFError)
68
69
70
import System.Timeout
import qualified Network.Socket as S

71
import Ganeti.BasicTypes
72
import Ganeti.Constants
73
74
import Ganeti.Errors
import Ganeti.JSON
Iustin Pop's avatar
Iustin Pop committed
75
import Ganeti.Jobs (JobStatus)
Iustin Pop's avatar
Iustin Pop committed
76
import Ganeti.OpParams (pTagsObject)
77
import Ganeti.OpCodes
78
import qualified Ganeti.Query.Language as Qlang
79
import Ganeti.THH
Iustin Pop's avatar
Iustin Pop committed
80
import Ganeti.Types
Iustin Pop's avatar
Iustin Pop committed
81

82
83
84
85
86
-- * Utility functions

-- | Wrapper over System.Timeout.timeout that fails in the IO monad.
withTimeout :: Int -> String -> IO a -> IO a
withTimeout secs descr action = do
87
  result <- timeout (secs * 1000000) action
Iustin Pop's avatar
Iustin Pop committed
88
89
90
  case result of
    Nothing -> fail $ "Timeout in " ++ descr
    Just v -> return v
91
92
93

-- * Generic protocol functionality

94
95
96
97
-- | Result of receiving a message from the socket.
data RecvResult = RecvConnClosed    -- ^ Connection closed
                | RecvError String  -- ^ Any other error
                | RecvOk String     -- ^ Successfull receive
98
                  deriving (Show, Eq)
99

100
101
-- | Currently supported Luxi operations and JSON serialization.
$(genLuxiOp "LuxiOp"
102
  [ (luxiReqQuery,
103
104
105
    [ simpleField "what"    [t| Qlang.ItemType |]
    , simpleField "fields"  [t| [String]  |]
    , simpleField "qfilter" [t| Qlang.Filter Qlang.FilterField |]
106
    ])
107
  , (luxiReqQueryFields,
108
109
    [ simpleField "what"    [t| Qlang.ItemType |]
    , simpleField "fields"  [t| [String]  |]
110
    ])
111
  , (luxiReqQueryNodes,
112
113
114
     [ simpleField "names"  [t| [String] |]
     , simpleField "fields" [t| [String] |]
     , simpleField "lock"   [t| Bool     |]
115
     ])
116
  , (luxiReqQueryGroups,
117
118
119
     [ simpleField "names"  [t| [String] |]
     , simpleField "fields" [t| [String] |]
     , simpleField "lock"   [t| Bool     |]
120
     ])
121
  , (luxiReqQueryInstances,
122
123
124
     [ simpleField "names"  [t| [String] |]
     , simpleField "fields" [t| [String] |]
     , simpleField "lock"   [t| Bool     |]
125
     ])
126
  , (luxiReqQueryJobs,
Iustin Pop's avatar
Iustin Pop committed
127
     [ simpleField "ids"    [t| [JobId]  |]
128
     , simpleField "fields" [t| [String] |]
129
     ])
130
  , (luxiReqQueryExports,
131
132
     [ simpleField "nodes" [t| [String] |]
     , simpleField "lock"  [t| Bool     |]
133
     ])
134
  , (luxiReqQueryConfigValues,
135
     [ simpleField "fields" [t| [String] |] ]
136
    )
137
138
  , (luxiReqQueryClusterInfo, [])
  , (luxiReqQueryTags,
Iustin Pop's avatar
Iustin Pop committed
139
     [ pTagsObject ])
140
  , (luxiReqSubmitJob,
141
     [ simpleField "job" [t| [OpCode] |] ]
142
    )
143
  , (luxiReqSubmitManyJobs,
144
     [ simpleField "ops" [t| [[OpCode]] |] ]
145
    )
146
  , (luxiReqWaitForJobChange,
Iustin Pop's avatar
Iustin Pop committed
147
     [ simpleField "job"      [t| JobId   |]
148
149
150
151
     , simpleField "fields"   [t| [String]|]
     , simpleField "prev_job" [t| JSValue |]
     , simpleField "prev_log" [t| JSValue |]
     , simpleField "tmout"    [t| Int     |]
152
     ])
153
  , (luxiReqArchiveJob,
Iustin Pop's avatar
Iustin Pop committed
154
     [ simpleField "job" [t| JobId |] ]
155
    )
156
  , (luxiReqAutoArchiveJobs,
157
158
     [ simpleField "age"   [t| Int |]
     , simpleField "tmout" [t| Int |]
159
     ])
160
  , (luxiReqCancelJob,
Iustin Pop's avatar
Iustin Pop committed
161
     [ simpleField "job" [t| JobId |] ]
162
    )
163
  , (luxiReqChangeJobPriority,
Iustin Pop's avatar
Iustin Pop committed
164
     [ simpleField "job"      [t| JobId |]
165
166
     , simpleField "priority" [t| Int |] ]
    )
167
  , (luxiReqSetDrainFlag,
168
     [ simpleField "flag" [t| Bool |] ]
169
    )
170
  , (luxiReqSetWatcherPause,
171
     [ simpleField "duration" [t| Double |] ]
172
    )
173
  ])
174

Iustin Pop's avatar
Iustin Pop committed
175
176
$(makeJSONInstance ''LuxiReq)

177
178
179
-- | List of all defined Luxi calls.
$(genAllConstr (drop 3) ''LuxiReq "allLuxiCalls")

180
-- | The serialisation of LuxiOps into strings in messages.
181
$(genStrOfOp ''LuxiOp "strOfOp")
182

183
184
185
-- | Type holding the initial (unparsed) Luxi call.
data LuxiCall = LuxiCall LuxiReq JSValue

186
-- | The end-of-message separator.
187
188
189
190
191
192
eOM :: Word8
eOM = 3

-- | The end-of-message encoded as a ByteString.
bEOM :: B.ByteString
bEOM = B.singleton eOM
193
194
195
196
197
198
199
200

-- | Valid keys in the requests and responses.
data MsgKeys = Method
             | Args
             | Success
             | Result

-- | The serialisation of MsgKeys into strings in messages.
201
$(genStrOfKey ''MsgKeys "strOfKey")
202
203

-- | Luxi client encapsulation.
204
205
data Client = Client { socket :: Handle           -- ^ The socket of the client
                     , rbuf :: IORef B.ByteString -- ^ Already received buffer
206
207
208
209
210
                     }

-- | Connects to the master daemon and returns a luxi Client.
getClient :: String -> IO Client
getClient path = do
211
  s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
212
  withTimeout luxiDefCtmo "creating luxi connection" $
213
              S.connect s (S.SockAddrUnix path)
214
215
216
  rf <- newIORef B.empty
  h <- S.socketToHandle s ReadWriteMode
  return Client { socket=h, rbuf=rf }
217

218
219
220
221
222
223
224
225
-- | Creates and returns a server endpoint.
getServer :: FilePath -> IO S.Socket
getServer path = do
  s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
  S.bindSocket s (S.SockAddrUnix path)
  S.listen s 5 -- 5 is the max backlog
  return s

226
227
228
229
230
231
232
-- | Closes a server endpoint.
-- FIXME: this should be encapsulated into a nicer type.
closeServer :: FilePath -> S.Socket -> IO ()
closeServer path sock = do
  S.sClose sock
  removeFile path

233
234
235
236
237
238
239
240
241
-- | Accepts a client
acceptClient :: S.Socket -> IO Client
acceptClient s = do
  -- second return is the address of the client, which we ignore here
  (client_socket, _) <- S.accept s
  new_buffer <- newIORef B.empty
  handle <- S.socketToHandle client_socket ReadWriteMode
  return Client { socket=handle, rbuf=new_buffer }

242
243
-- | Closes the client socket.
closeClient :: Client -> IO ()
244
closeClient = hClose . socket
245
246
247

-- | Sends a message over a luxi transport.
sendMsg :: Client -> String -> IO ()
248
sendMsg s buf = withTimeout luxiDefRwto "sending luxi message" $ do
249
250
251
252
253
254
255
256
257
258
259
  let encoded = UTF8.fromString buf
      handle = socket s
  B.hPut handle encoded
  B.hPut handle bEOM
  hFlush handle

-- | Given a current buffer and the handle, it will read from the
-- network until we get a full message, and it will return that
-- message and the leftover buffer contents.
recvUpdate :: Handle -> B.ByteString -> IO (B.ByteString, B.ByteString)
recvUpdate handle obuf = do
260
  nbuf <- withTimeout luxiDefRwto "reading luxi response" $ do
261
262
263
264
265
266
267
            _ <- hWaitForInput handle (-1)
            B.hGetNonBlocking handle 4096
  let (msg, remaining) = B.break (eOM ==) nbuf
      newbuf = B.append obuf msg
  if B.null remaining
    then recvUpdate handle newbuf
    else return (newbuf, B.tail remaining)
268
269
270
271
272

-- | Waits for a message over a luxi transport.
recvMsg :: Client -> IO String
recvMsg s = do
  cbuf <- readIORef $ rbuf s
273
  let (imsg, ibuf) = B.break (eOM ==) cbuf
274
  (msg, nbuf) <-
275
276
277
    if B.null ibuf      -- if old buffer didn't contain a full message
      then recvUpdate (socket s) cbuf   -- then we read from network
      else return (imsg, B.tail ibuf)   -- else we return data from our buffer
278
  writeIORef (rbuf s) nbuf
279
  return $ UTF8.toString msg
280

281
282
283
-- | Extended wrapper over recvMsg.
recvMsgExt :: Client -> IO RecvResult
recvMsgExt s =
Iustin Pop's avatar
Iustin Pop committed
284
  Control.Exception.catch (liftM RecvOk (recvMsg s)) $ \e ->
285
286
287
    return $ if isEOFError e
               then RecvConnClosed
               else RecvError (show e)
288

289
290
291
-- | Serialize a request to String.
buildCall :: LuxiOp  -- ^ The method
          -> String  -- ^ The serialized form
292
buildCall lo =
Iustin Pop's avatar
Iustin Pop committed
293
294
  let ja = [ (strOfKey Method, J.showJSON $ strOfOp lo)
           , (strOfKey Args, opToArgs lo)
295
296
297
           ]
      jo = toJSObject ja
  in encodeStrict jo
298

299
300
301
302
303
304
305
306
307
308
-- | Serialize the response to String.
buildResponse :: Bool    -- ^ Success
              -> JSValue -- ^ The arguments
              -> String  -- ^ The serialized form
buildResponse success args =
  let ja = [ (strOfKey Success, JSBool success)
           , (strOfKey Result, args)]
      jo = toJSObject ja
  in encodeStrict jo

309
310
311
-- | Check that luxi request contains the required keys and parse it.
validateCall :: String -> Result LuxiCall
validateCall s = do
312
313
  arr <- fromJResult "parsing top-level luxi message" $
         decodeStrict s::Result (JSObject JSValue)
314
315
316
317
318
319
320
321
322
323
324
325
326
  let aobj = fromJSObject arr
  call <- fromObj aobj (strOfKey Method)::Result LuxiReq
  args <- fromObj aobj (strOfKey Args)
  return (LuxiCall call args)

-- | Converts Luxi call arguments into a 'LuxiOp' data structure.
--
-- This is currently hand-coded until we make it more uniform so that
-- it can be generated using TH.
decodeCall :: LuxiCall -> Result LuxiOp
decodeCall (LuxiCall call args) =
  case call of
    ReqQueryJobs -> do
Iustin Pop's avatar
Iustin Pop committed
327
              (jids, jargs) <- fromJVal args
328
              let rargs = map fromJSString jargs
Iustin Pop's avatar
Iustin Pop committed
329
              return $ QueryJobs jids rargs
330
331
332
333
334
335
336
337
338
    ReqQueryInstances -> do
              (names, fields, locking) <- fromJVal args
              return $ QueryInstances names fields locking
    ReqQueryNodes -> do
              (names, fields, locking) <- fromJVal args
              return $ QueryNodes names fields locking
    ReqQueryGroups -> do
              (names, fields, locking) <- fromJVal args
              return $ QueryGroups names fields locking
Iustin Pop's avatar
Iustin Pop committed
339
    ReqQueryClusterInfo ->
340
341
              return QueryClusterInfo
    ReqQuery -> do
342
343
              (what, fields, qfilter) <- fromJVal args
              return $ Query what fields qfilter
344
345
346
347
348
349
    ReqQueryFields -> do
              (what, fields) <- fromJVal args
              fields' <- case fields of
                           JSNull -> return []
                           _ -> fromJVal fields
              return $ QueryFields what fields'
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
    ReqSubmitJob -> do
              [ops1] <- fromJVal args
              ops2 <- mapM (fromJResult (luxiReqToRaw call) . J.readJSON) ops1
              return $ SubmitJob ops2
    ReqSubmitManyJobs -> do
              [ops1] <- fromJVal args
              ops2 <- mapM (fromJResult (luxiReqToRaw call) . J.readJSON) ops1
              return $ SubmitManyJobs ops2
    ReqWaitForJobChange -> do
              (jid, fields, pinfo, pidx, wtmout) <-
                -- No instance for 5-tuple, code copied from the
                -- json sources and adapted
                fromJResult "Parsing WaitForJobChange message" $
                case args of
                  JSArray [a, b, c, d, e] ->
                    (,,,,) `fmap`
                    J.readJSON a `ap`
                    J.readJSON b `ap`
                    J.readJSON c `ap`
                    J.readJSON d `ap`
                    J.readJSON e
                  _ -> J.Error "Not enough values"
Iustin Pop's avatar
Iustin Pop committed
372
              return $ WaitForJobChange jid fields pinfo pidx wtmout
373
374
    ReqArchiveJob -> do
              [jid] <- fromJVal args
Iustin Pop's avatar
Iustin Pop committed
375
              return $ ArchiveJob jid
376
377
378
379
380
381
382
383
384
385
386
    ReqAutoArchiveJobs -> do
              (age, tmout) <- fromJVal args
              return $ AutoArchiveJobs age tmout
    ReqQueryExports -> do
              (nodes, lock) <- fromJVal args
              return $ QueryExports nodes lock
    ReqQueryConfigValues -> do
              [fields] <- fromJVal args
              return $ QueryConfigValues fields
    ReqQueryTags -> do
              (kind, name) <- fromJVal args
387
388
              item <- tagObjectFrom kind name
              return $ QueryTags item
389
    ReqCancelJob -> do
Iustin Pop's avatar
Iustin Pop committed
390
391
              [jid] <- fromJVal args
              return $ CancelJob jid
392
    ReqChangeJobPriority -> do
Iustin Pop's avatar
Iustin Pop committed
393
394
              (jid, priority) <- fromJVal args
              return $ ChangeJobPriority jid priority
395
396
397
398
399
400
401
    ReqSetDrainFlag -> do
              [flag] <- fromJVal args
              return $ SetDrainFlag flag
    ReqSetWatcherPause -> do
              [duration] <- fromJVal args
              return $ SetWatcherPause duration

402
403
-- | Check that luxi responses contain the required keys and that the
-- call was successful.
404
validateResult :: String -> ErrorResult JSValue
405
validateResult s = do
406
407
  when (UTF8.replacement_char `elem` s) $
       fail "Failed to decode UTF-8, detected replacement char after decoding"
408
  oarr <- fromJResult "Parsing LUXI response" (decodeStrict s)
409
  let arr = J.fromJSObject oarr
410
411
  status <- fromObj arr (strOfKey Success)
  result <- fromObj arr (strOfKey Result)
Iustin Pop's avatar
Iustin Pop committed
412
  if status
413
414
415
416
417
418
419
420
421
422
423
    then return result
    else decodeError result

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

-- | Generic luxi method call.
426
callMethod :: LuxiOp -> Client -> IO (ErrorResult JSValue)
427
428
callMethod method s = do
  sendMsg s $ buildCall method
429
430
431
  result <- recvMsg s
  let rval = validateResult result
  return rval
Iustin Pop's avatar
Iustin Pop committed
432

433
-- | Parse job submission result.
434
435
parseSubmitJobResult :: JSValue -> ErrorResult JobId
parseSubmitJobResult (JSArray [JSBool True, v]) =
Iustin Pop's avatar
Iustin Pop committed
436
437
438
  case J.readJSON v of
    J.Error msg -> Bad $ LuxiError msg
    J.Ok v' -> Ok v'
439
parseSubmitJobResult (JSArray [JSBool False, JSString x]) =
440
441
442
443
  Bad . LuxiError $ fromJSString x
parseSubmitJobResult v =
  Bad . LuxiError $ "Unknown result from the master daemon: " ++
      show (pp_value v)
444

Iustin Pop's avatar
Iustin Pop committed
445
-- | Specialized submitManyJobs call.
446
submitManyJobs :: Client -> [[OpCode]] -> IO (ErrorResult [JobId])
Iustin Pop's avatar
Iustin Pop committed
447
submitManyJobs s jobs = do
448
  rval <- callMethod (SubmitManyJobs jobs) s
Iustin Pop's avatar
Iustin Pop committed
449
450
451
  -- map each result (status, payload) pair into a nice Result ADT
  return $ case rval of
             Bad x -> Bad x
452
             Ok (JSArray r) -> mapM parseSubmitJobResult r
453
454
             x -> Bad . LuxiError $
                  "Cannot parse response from Ganeti: " ++ show x
Iustin Pop's avatar
Iustin Pop committed
455
456

-- | Custom queryJobs call.
457
queryJobsStatus :: Client -> [JobId] -> IO (ErrorResult [JobStatus])
Iustin Pop's avatar
Iustin Pop committed
458
queryJobsStatus s jids = do
Iustin Pop's avatar
Iustin Pop committed
459
  rval <- callMethod (QueryJobs jids ["status"]) s
Iustin Pop's avatar
Iustin Pop committed
460
461
462
463
  return $ case rval of
             Bad x -> Bad x
             Ok y -> case J.readJSON y::(J.Result [[JobStatus]]) of
                       J.Ok vals -> if any null vals
464
465
                                    then Bad $
                                         LuxiError "Missing job status field"
Iustin Pop's avatar
Iustin Pop committed
466
                                    else Ok (map head vals)
467
                       J.Error x -> Bad $ LuxiError x