1 {-# LANGUAGE TemplateHaskell #-}
3 {-| Implementation of the Ganeti LUXI interface.
9 Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
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.
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.
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
48 import Text.JSON (encodeStrict, decodeStrict)
49 import qualified Text.JSON as J
50 import Text.JSON.Types
52 import qualified Network.Socket as S
54 import Ganeti.HTools.JSON
55 import Ganeti.HTools.Types
56 import Ganeti.HTools.Utils
58 import Ganeti.Constants
59 import Ganeti.Jobs (JobStatus)
60 import Ganeti.OpCodes (OpCode)
63 -- * Utility functions
65 -- | Wrapper over System.Timeout.timeout that fails in the IO monad.
66 withTimeout :: Int -> String -> IO a -> IO a
67 withTimeout secs descr action = do
68 result <- timeout (secs * 1000000) action
70 Nothing -> fail $ "Timeout in " ++ descr
73 -- * Generic protocol functionality
75 -- | The Ganeti job type.
78 $(declareSADT "QrViaLuxi"
80 , ("QRInstance", 'qrInstance)
82 , ("QRGroup", 'qrGroup)
85 $(makeJSONInstance ''QrViaLuxi)
87 -- | Currently supported Luxi operations and JSON serialization.
90 [ ("what", [t| QrViaLuxi |], [| id |])
91 , ("fields", [t| [String] |], [| id |])
92 , ("qfilter", [t| () |], [| const JSNull |])
95 [ ("names", [t| [String] |], [| id |])
96 , ("fields", [t| [String] |], [| id |])
97 , ("lock", [t| Bool |], [| id |])
99 , (luxiReqQueryGroups,
100 [ ("names", [t| [String] |], [| id |])
101 , ("fields", [t| [String] |], [| id |])
102 , ("lock", [t| Bool |], [| id |])
104 , (luxiReqQueryInstances,
105 [ ("names", [t| [String] |], [| id |])
106 , ("fields", [t| [String] |], [| id |])
107 , ("lock", [t| Bool |], [| id |])
110 [ ("ids", [t| [Int] |], [| map show |])
111 , ("fields", [t| [String] |], [| id |])
113 , (luxiReqQueryExports,
114 [ ("nodes", [t| [String] |], [| id |])
115 , ("lock", [t| Bool |], [| id |])
117 , (luxiReqQueryConfigValues,
118 [ ("fields", [t| [String] |], [| id |]) ]
120 , (luxiReqQueryClusterInfo, [])
122 [ ("kind", [t| String |], [| id |])
123 , ("name", [t| String |], [| id |])
126 [ ("job", [t| [OpCode] |], [| id |]) ]
128 , (luxiReqSubmitManyJobs,
129 [ ("ops", [t| [[OpCode]] |], [| id |]) ]
131 , (luxiReqWaitForJobChange,
132 [ ("job", [t| Int |], [| show |])
133 , ("fields", [t| [String]|], [| id |])
134 , ("prev_job", [t| JSValue |], [| id |])
135 , ("prev_log", [t| JSValue |], [| id |])
136 , ("tmout", [t| Int |], [| id |])
138 , (luxiReqArchiveJob,
139 [ ("job", [t| Int |], [| show |]) ]
141 , (luxiReqAutoArchiveJobs,
142 [ ("age", [t| Int |], [| id |])
143 , ("tmout", [t| Int |], [| id |])
146 [ ("job", [t| Int |], [| show |]) ]
148 , (luxiReqSetDrainFlag,
149 [ ("flag", [t| Bool |], [| id |]) ]
151 , (luxiReqSetWatcherPause,
152 [ ("duration", [t| Double |], [| id |]) ]
156 $(makeJSONInstance ''LuxiReq)
158 -- | The serialisation of LuxiOps into strings in messages.
159 $(genStrOfOp ''LuxiOp "strOfOp")
161 $(declareIADT "ResultStatus"
162 [ ("RSNormal", 'rsNormal)
163 , ("RSUnknown", 'rsUnknown)
164 , ("RSNoData", 'rsNodata)
165 , ("RSUnavailable", 'rsUnavail)
166 , ("RSOffline", 'rsOffline)
169 $(makeJSONInstance ''ResultStatus)
171 -- | Type holding the initial (unparsed) Luxi call.
172 data LuxiCall = LuxiCall LuxiReq JSValue
174 -- | Check that ResultStatus is success or fail with descriptive message.
175 checkRS :: (Monad m) => ResultStatus -> a -> m a
176 checkRS RSNormal val = return val
177 checkRS RSUnknown _ = fail "Unknown field"
178 checkRS RSNoData _ = fail "No data for a field"
179 checkRS RSUnavailable _ = fail "Ganeti reports unavailable data"
180 checkRS RSOffline _ = fail "Ganeti reports resource as offline"
182 -- | The end-of-message separator.
186 -- | Valid keys in the requests and responses.
187 data MsgKeys = Method
192 -- | The serialisation of MsgKeys into strings in messages.
193 $(genStrOfKey ''MsgKeys "strOfKey")
195 -- | Luxi client encapsulation.
196 data Client = Client { socket :: S.Socket -- ^ The socket of the client
197 , rbuf :: IORef String -- ^ Already received buffer
200 -- | Connects to the master daemon and returns a luxi Client.
201 getClient :: String -> IO Client
203 s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
204 withTimeout connTimeout "creating luxi connection" $
205 S.connect s (S.SockAddrUnix path)
207 return Client { socket=s, rbuf=rf}
209 -- | Closes the client socket.
210 closeClient :: Client -> IO ()
211 closeClient = S.sClose . socket
213 -- | Sends a message over a luxi transport.
214 sendMsg :: Client -> String -> IO ()
217 sbytes <- withTimeout queryTimeout
218 "sending luxi message" $
219 S.send (socket s) obuf
220 unless (sbytes == length obuf) $ _send (drop sbytes obuf)
221 in _send (buf ++ [eOM])
223 -- | Waits for a message over a luxi transport.
224 recvMsg :: Client -> IO String
227 nbuf <- withTimeout queryTimeout "reading luxi response" $
228 S.recv (socket s) 4096
229 let (msg, remaining) = break (eOM ==) nbuf
231 then _recv (obuf ++ msg)
232 else return (obuf ++ msg, tail remaining)
233 cbuf <- readIORef $ rbuf s
234 let (imsg, ibuf) = break (eOM ==) cbuf
236 if null ibuf -- if old buffer didn't contain a full message
237 then _recv cbuf -- then we read from network
238 else return (imsg, tail ibuf) -- else we return data from our buffer
239 writeIORef (rbuf s) nbuf
242 -- | Serialize a request to String.
243 buildCall :: LuxiOp -- ^ The method
244 -> String -- ^ The serialized form
246 let ja = [ (strOfKey Method, JSString $ toJSString $ strOfOp lo::JSValue)
247 , (strOfKey Args, opToArgs lo::JSValue)
252 -- | Check that luxi request contains the required keys and parse it.
253 validateCall :: String -> Result LuxiCall
255 arr <- fromJResult "luxi call" $ decodeStrict s::Result (JSObject JSValue)
256 let aobj = fromJSObject arr
257 call <- fromObj aobj (strOfKey Method)::Result LuxiReq
258 args <- fromObj aobj (strOfKey Args)
259 return (LuxiCall call args)
261 -- | Converts Luxi call arguments into a 'LuxiOp' data structure.
263 -- This is currently hand-coded until we make it more uniform so that
264 -- it can be generated using TH.
265 decodeCall :: LuxiCall -> Result LuxiOp
266 decodeCall (LuxiCall call args) =
269 (jid, jargs) <- fromJVal args
270 rid <- mapM (tryRead "parsing job ID" . fromJSString) jid
271 let rargs = map fromJSString jargs
272 return $ QueryJobs rid rargs
273 ReqQueryInstances -> do
274 (names, fields, locking) <- fromJVal args
275 return $ QueryInstances names fields locking
277 (names, fields, locking) <- fromJVal args
278 return $ QueryNodes names fields locking
280 (names, fields, locking) <- fromJVal args
281 return $ QueryGroups names fields locking
282 ReqQueryClusterInfo -> do
283 return QueryClusterInfo
286 fromJVal args::Result (QrViaLuxi, [String], JSValue)
287 return $ Query what fields ()
289 [ops1] <- fromJVal args
290 ops2 <- mapM (fromJResult (luxiReqToRaw call) . J.readJSON) ops1
291 return $ SubmitJob ops2
292 ReqSubmitManyJobs -> do
293 [ops1] <- fromJVal args
294 ops2 <- mapM (fromJResult (luxiReqToRaw call) . J.readJSON) ops1
295 return $ SubmitManyJobs ops2
296 ReqWaitForJobChange -> do
297 (jid, fields, pinfo, pidx, wtmout) <-
298 -- No instance for 5-tuple, code copied from the
299 -- json sources and adapted
300 fromJResult "Parsing WaitForJobChange message" $
302 JSArray [a, b, c, d, e] ->
309 _ -> J.Error "Not enough values"
310 rid <- tryRead "parsing job ID" jid
311 return $ WaitForJobChange rid fields pinfo pidx wtmout
313 [jid] <- fromJVal args
314 rid <- tryRead "parsing job ID" jid
315 return $ ArchiveJob rid
316 ReqAutoArchiveJobs -> do
317 (age, tmout) <- fromJVal args
318 return $ AutoArchiveJobs age tmout
319 ReqQueryExports -> do
320 (nodes, lock) <- fromJVal args
321 return $ QueryExports nodes lock
322 ReqQueryConfigValues -> do
323 [fields] <- fromJVal args
324 return $ QueryConfigValues fields
326 (kind, name) <- fromJVal args
327 return $ QueryTags kind name
329 [job] <- fromJVal args
330 rid <- tryRead "parsing job ID" job
331 return $ CancelJob rid
332 ReqSetDrainFlag -> do
333 [flag] <- fromJVal args
334 return $ SetDrainFlag flag
335 ReqSetWatcherPause -> do
336 [duration] <- fromJVal args
337 return $ SetWatcherPause duration
339 -- | Check that luxi responses contain the required keys and that the
340 -- call was successful.
341 validateResult :: String -> Result JSValue
342 validateResult s = do
343 oarr <- fromJResult "Parsing LUXI response"
344 (decodeStrict s)::Result (JSObject JSValue)
345 let arr = J.fromJSObject oarr
346 status <- fromObj arr (strOfKey Success)::Result Bool
347 let rkey = strOfKey Result
349 then fromObj arr rkey
350 else fromObj arr rkey >>= fail
352 -- | Generic luxi method call.
353 callMethod :: LuxiOp -> Client -> IO (Result JSValue)
354 callMethod method s = do
355 sendMsg s $ buildCall method
357 let rval = validateResult result
360 -- | Parses a job ID.
361 parseJobId :: JSValue -> Result JobId
362 parseJobId (JSString x) = Ok $ fromJSString x
363 parseJobId x = Bad $ "Wrong type/value for job id: " ++ show x
365 -- | Parse job submission result.
366 parseSubmitJobResult :: JSValue -> Result JobId
367 parseSubmitJobResult (JSArray [JSBool True, v]) = parseJobId v
368 parseSubmitJobResult (JSArray [JSBool False, JSString x]) =
370 parseSubmitJobResult v = Bad $ "Unknown result from the master daemon" ++
373 -- | Specialized submitManyJobs call.
374 submitManyJobs :: Client -> [[OpCode]] -> IO (Result [JobId])
375 submitManyJobs s jobs = do
376 rval <- callMethod (SubmitManyJobs jobs) s
377 -- map each result (status, payload) pair into a nice Result ADT
378 return $ case rval of
380 Ok (JSArray r) -> mapM parseSubmitJobResult r
381 x -> Bad ("Cannot parse response from Ganeti: " ++ show x)
383 -- | Custom queryJobs call.
384 queryJobsStatus :: Client -> [JobId] -> IO (Result [JobStatus])
385 queryJobsStatus s jids = do
386 rval <- callMethod (QueryJobs (map read jids) ["status"]) s
387 return $ case rval of
389 Ok y -> case J.readJSON y::(J.Result [[JobStatus]]) of
390 J.Ok vals -> if any null vals
391 then Bad "Missing job status field"
392 else Ok (map head vals)