{-
-Copyright (C) 2009, 2010, 2011 Google Inc.
+Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
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
( LuxiOp(..)
, QrViaLuxi(..)
, ResultStatus(..)
+ , LuxiReq(..)
, Client
, checkRS
, getClient
, callMethod
, submitManyJobs
, queryJobsStatus
+ , buildCall
+ , validateCall
+ , decodeCall
) where
import Data.IORef
import System.Timeout
import qualified Network.Socket as S
-import Ganeti.HTools.Utils
+import Ganeti.HTools.JSON
import Ganeti.HTools.Types
+import Ganeti.HTools.Utils
import Ganeti.Constants
import Ganeti.Jobs (JobStatus)
withTimeout :: Int -> String -> IO a -> IO a
withTimeout secs descr action = do
result <- timeout (secs * 1000000) action
- (case result of
- Nothing -> fail $ "Timeout in " ++ descr
- Just v -> return v)
+ case result of
+ Nothing -> fail $ "Timeout in " ++ descr
+ Just v -> return v
-- * Generic protocol functionality
-- | Currently supported Luxi operations and JSON serialization.
$(genLuxiOp "LuxiOp"
- [("Query" ,
+ [(luxiReqQuery,
[ ("what", [t| QrViaLuxi |], [| id |])
, ("fields", [t| [String] |], [| id |])
, ("qfilter", [t| () |], [| const JSNull |])
])
- , ("QueryNodes",
+ , (luxiReqQueryNodes,
[ ("names", [t| [String] |], [| id |])
, ("fields", [t| [String] |], [| id |])
, ("lock", [t| Bool |], [| id |])
])
- , ("QueryGroups",
+ , (luxiReqQueryGroups,
[ ("names", [t| [String] |], [| id |])
, ("fields", [t| [String] |], [| id |])
, ("lock", [t| Bool |], [| id |])
])
- , ("QueryInstances",
+ , (luxiReqQueryInstances,
[ ("names", [t| [String] |], [| id |])
, ("fields", [t| [String] |], [| id |])
, ("lock", [t| Bool |], [| id |])
])
- , ("QueryJobs",
+ , (luxiReqQueryJobs,
[ ("ids", [t| [Int] |], [| map show |])
, ("fields", [t| [String] |], [| id |])
])
- , ("QueryExports",
+ , (luxiReqQueryExports,
[ ("nodes", [t| [String] |], [| id |])
, ("lock", [t| Bool |], [| id |])
])
- , ("QueryConfigValues",
+ , (luxiReqQueryConfigValues,
[ ("fields", [t| [String] |], [| id |]) ]
)
- , ("QueryClusterInfo", [])
- , ("QueryTags",
+ , (luxiReqQueryClusterInfo, [])
+ , (luxiReqQueryTags,
[ ("kind", [t| String |], [| id |])
, ("name", [t| String |], [| id |])
])
- , ("SubmitJob",
+ , (luxiReqSubmitJob,
[ ("job", [t| [OpCode] |], [| id |]) ]
)
- , ("SubmitManyJobs",
+ , (luxiReqSubmitManyJobs,
[ ("ops", [t| [[OpCode]] |], [| id |]) ]
)
- , ("WaitForJobChange",
- [ ("job", [t| Int |], [| id |])
+ , (luxiReqWaitForJobChange,
+ [ ("job", [t| Int |], [| show |])
, ("fields", [t| [String]|], [| id |])
, ("prev_job", [t| JSValue |], [| id |])
, ("prev_log", [t| JSValue |], [| id |])
, ("tmout", [t| Int |], [| id |])
])
- , ("ArchiveJob",
+ , (luxiReqArchiveJob,
[ ("job", [t| Int |], [| show |]) ]
)
- , ("AutoArchiveJobs",
+ , (luxiReqAutoArchiveJobs,
[ ("age", [t| Int |], [| id |])
, ("tmout", [t| Int |], [| id |])
])
- , ("CancelJob",
+ , (luxiReqCancelJob,
[ ("job", [t| Int |], [| show |]) ]
)
- , ("SetDrainFlag",
+ , (luxiReqSetDrainFlag,
[ ("flag", [t| Bool |], [| id |]) ]
)
- , ("SetWatcherPause",
+ , (luxiReqSetWatcherPause,
[ ("duration", [t| Double |], [| id |]) ]
)
])
+$(makeJSONInstance ''LuxiReq)
+
-- | The serialisation of LuxiOps into strings in messages.
$(genStrOfOp ''LuxiOp "strOfOp")
$(makeJSONInstance ''ResultStatus)
+-- | Type holding the initial (unparsed) Luxi call.
+data LuxiCall = LuxiCall LuxiReq JSValue
+
-- | Check that ResultStatus is success or fail with descriptive message.
checkRS :: (Monad m) => ResultStatus -> a -> m a
checkRS RSNormal val = return val
nbuf <- withTimeout queryTimeout "reading luxi response" $
S.recv (socket s) 4096
let (msg, remaining) = break (eOM ==) nbuf
- (if null remaining
- then _recv (obuf ++ msg)
- else return (obuf ++ msg, tail remaining))
+ if null remaining
+ then _recv (obuf ++ msg)
+ else return (obuf ++ msg, tail remaining)
cbuf <- readIORef $ rbuf s
let (imsg, ibuf) = break (eOM ==) cbuf
(msg, nbuf) <-
- (if null ibuf -- if old buffer didn't contain a full message
- then _recv cbuf -- then we read from network
- else return (imsg, tail ibuf)) -- else we return data from our buffer
+ if null ibuf -- if old buffer didn't contain a full message
+ then _recv cbuf -- then we read from network
+ else return (imsg, tail ibuf) -- else we return data from our buffer
writeIORef (rbuf s) nbuf
return msg
jo = toJSObject ja
in encodeStrict jo
+-- | Check that luxi request contains the required keys and parse it.
+validateCall :: String -> Result LuxiCall
+validateCall s = do
+ arr <- fromJResult "luxi call" $ decodeStrict s::Result (JSObject JSValue)
+ 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
+ (jid, jargs) <- fromJVal args
+ rid <- mapM (tryRead "parsing job ID" . fromJSString) jid
+ let rargs = map fromJSString jargs
+ return $ QueryJobs rid rargs
+ 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
+ ReqQueryClusterInfo -> do
+ return QueryClusterInfo
+ ReqQuery -> do
+ (what, fields, _) <-
+ fromJVal args::Result (QrViaLuxi, [String], JSValue)
+ return $ Query what fields ()
+ 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"
+ rid <- tryRead "parsing job ID" jid
+ return $ WaitForJobChange rid fields pinfo pidx wtmout
+ ReqArchiveJob -> do
+ [jid] <- fromJVal args
+ rid <- tryRead "parsing job ID" jid
+ return $ ArchiveJob rid
+ 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
+ return $ QueryTags kind name
+ ReqCancelJob -> do
+ [job] <- fromJVal args
+ rid <- tryRead "parsing job ID" job
+ return $ CancelJob rid
+ ReqSetDrainFlag -> do
+ [flag] <- fromJVal args
+ return $ SetDrainFlag flag
+ ReqSetWatcherPause -> do
+ [duration] <- fromJVal args
+ return $ SetWatcherPause duration
+
-- | Check that luxi responses contain the required keys and that the
-- call was successful.
validateResult :: String -> Result JSValue
let arr = J.fromJSObject oarr
status <- fromObj arr (strOfKey Success)::Result Bool
let rkey = strOfKey Result
- (if status
- then fromObj arr rkey
- else fromObj arr rkey >>= fail)
+ if status
+ then fromObj arr rkey
+ else fromObj arr rkey >>= fail
-- | Generic luxi method call.
callMethod :: LuxiOp -> Client -> IO (Result JSValue)
projects / ganeti-local / blobdiff