Revision ebf38064 htools/Ganeti/Luxi.hs
| b/htools/Ganeti/Luxi.hs | ||
|---|---|---|
| 26 | 26 |
-} |
| 27 | 27 |
|
| 28 | 28 |
module Ganeti.Luxi |
| 29 |
( LuxiOp(..)
|
|
| 30 |
, QrViaLuxi(..)
|
|
| 31 |
, ResultStatus(..)
|
|
| 32 |
, Client
|
|
| 33 |
, checkRS
|
|
| 34 |
, getClient
|
|
| 35 |
, closeClient
|
|
| 36 |
, callMethod
|
|
| 37 |
, submitManyJobs
|
|
| 38 |
, queryJobsStatus
|
|
| 39 |
) where
|
|
| 29 |
( LuxiOp(..) |
|
| 30 |
, QrViaLuxi(..) |
|
| 31 |
, ResultStatus(..) |
|
| 32 |
, Client |
|
| 33 |
, checkRS |
|
| 34 |
, getClient |
|
| 35 |
, closeClient |
|
| 36 |
, callMethod |
|
| 37 |
, submitManyJobs |
|
| 38 |
, queryJobsStatus |
|
| 39 |
) where |
|
| 40 | 40 |
|
| 41 | 41 |
import Data.IORef |
| 42 | 42 |
import Control.Monad |
| ... | ... | |
| 59 | 59 |
-- | Wrapper over System.Timeout.timeout that fails in the IO monad. |
| 60 | 60 |
withTimeout :: Int -> String -> IO a -> IO a |
| 61 | 61 |
withTimeout secs descr action = do |
| 62 |
result <- timeout (secs * 1000000) action
|
|
| 63 |
(case result of
|
|
| 64 |
Nothing -> fail $ "Timeout in " ++ descr
|
|
| 65 |
Just v -> return v)
|
|
| 62 |
result <- timeout (secs * 1000000) action |
|
| 63 |
(case result of |
|
| 64 |
Nothing -> fail $ "Timeout in " ++ descr |
|
| 65 |
Just v -> return v) |
|
| 66 | 66 |
|
| 67 | 67 |
-- * Generic protocol functionality |
| 68 | 68 |
|
| 69 | 69 |
$(declareSADT "QrViaLuxi" |
| 70 |
[ ("QRLock", 'qrLock)
|
|
| 71 |
, ("QRInstance", 'qrInstance)
|
|
| 72 |
, ("QRNode", 'qrNode)
|
|
| 73 |
, ("QRGroup", 'qrGroup)
|
|
| 74 |
, ("QROs", 'qrOs)
|
|
| 75 |
])
|
|
| 70 |
[ ("QRLock", 'qrLock)
|
|
| 71 |
, ("QRInstance", 'qrInstance)
|
|
| 72 |
, ("QRNode", 'qrNode)
|
|
| 73 |
, ("QRGroup", 'qrGroup)
|
|
| 74 |
, ("QROs", 'qrOs)
|
|
| 75 |
]) |
|
| 76 | 76 |
$(makeJSONInstance ''QrViaLuxi) |
| 77 | 77 |
|
| 78 | 78 |
-- | Currently supported Luxi operations and JSON serialization. |
| 79 | 79 |
$(genLuxiOp "LuxiOp" |
| 80 |
[("Query" ,
|
|
| 81 |
[ ("what", [t| QrViaLuxi |], [| id |])
|
|
| 82 |
, ("fields", [t| [String] |], [| id |])
|
|
| 83 |
, ("qfilter", [t| () |], [| const JSNull |])
|
|
| 84 |
])
|
|
| 85 |
, ("QueryNodes",
|
|
| 86 |
[ ("names", [t| [String] |], [| id |])
|
|
| 87 |
, ("fields", [t| [String] |], [| id |])
|
|
| 88 |
, ("lock", [t| Bool |], [| id |])
|
|
| 89 |
])
|
|
| 90 |
, ("QueryGroups",
|
|
| 91 |
[ ("names", [t| [String] |], [| id |])
|
|
| 92 |
, ("fields", [t| [String] |], [| id |])
|
|
| 93 |
, ("lock", [t| Bool |], [| id |])
|
|
| 94 |
])
|
|
| 95 |
, ("QueryInstances",
|
|
| 96 |
[ ("names", [t| [String] |], [| id |])
|
|
| 97 |
, ("fields", [t| [String] |], [| id |])
|
|
| 98 |
, ("lock", [t| Bool |], [| id |])
|
|
| 99 |
])
|
|
| 100 |
, ("QueryJobs",
|
|
| 101 |
[ ("ids", [t| [Int] |], [| map show |])
|
|
| 102 |
, ("fields", [t| [String] |], [| id |])
|
|
| 103 |
])
|
|
| 104 |
, ("QueryExports",
|
|
| 105 |
[ ("nodes", [t| [String] |], [| id |])
|
|
| 106 |
, ("lock", [t| Bool |], [| id |])
|
|
| 107 |
])
|
|
| 108 |
, ("QueryConfigValues",
|
|
| 109 |
[ ("fields", [t| [String] |], [| id |]) ]
|
|
| 110 |
)
|
|
| 111 |
, ("QueryClusterInfo", [])
|
|
| 112 |
, ("QueryTags",
|
|
| 113 |
[ ("kind", [t| String |], [| id |])
|
|
| 114 |
, ("name", [t| String |], [| id |])
|
|
| 115 |
])
|
|
| 116 |
, ("SubmitJob",
|
|
| 117 |
[ ("job", [t| [OpCode] |], [| id |]) ]
|
|
| 118 |
)
|
|
| 119 |
, ("SubmitManyJobs",
|
|
| 120 |
[ ("ops", [t| [[OpCode]] |], [| id |]) ]
|
|
| 121 |
)
|
|
| 122 |
, ("WaitForJobChange",
|
|
| 123 |
[ ("job", [t| Int |], [| id |])
|
|
| 124 |
, ("fields", [t| [String]|], [| id |])
|
|
| 125 |
, ("prev_job", [t| JSValue |], [| id |])
|
|
| 126 |
, ("prev_log", [t| JSValue |], [| id |])
|
|
| 127 |
, ("tmout", [t| Int |], [| id |])
|
|
| 128 |
])
|
|
| 129 |
, ("ArchiveJob",
|
|
| 130 |
[ ("job", [t| Int |], [| show |]) ]
|
|
| 131 |
)
|
|
| 132 |
, ("AutoArchiveJobs",
|
|
| 133 |
[ ("age", [t| Int |], [| id |])
|
|
| 134 |
, ("tmout", [t| Int |], [| id |])
|
|
| 135 |
])
|
|
| 136 |
, ("CancelJob",
|
|
| 137 |
[ ("job", [t| Int |], [| show |]) ]
|
|
| 138 |
)
|
|
| 139 |
, ("SetDrainFlag",
|
|
| 140 |
[ ("flag", [t| Bool |], [| id |]) ]
|
|
| 141 |
)
|
|
| 142 |
, ("SetWatcherPause",
|
|
| 143 |
[ ("duration", [t| Double |], [| id |]) ]
|
|
| 144 |
)
|
|
| 80 |
[("Query" ,
|
|
| 81 |
[ ("what", [t| QrViaLuxi |], [| id |])
|
|
| 82 |
, ("fields", [t| [String] |], [| id |])
|
|
| 83 |
, ("qfilter", [t| () |], [| const JSNull |])
|
|
| 84 |
]) |
|
| 85 |
, ("QueryNodes",
|
|
| 86 |
[ ("names", [t| [String] |], [| id |])
|
|
| 87 |
, ("fields", [t| [String] |], [| id |])
|
|
| 88 |
, ("lock", [t| Bool |], [| id |])
|
|
| 89 |
]) |
|
| 90 |
, ("QueryGroups",
|
|
| 91 |
[ ("names", [t| [String] |], [| id |])
|
|
| 92 |
, ("fields", [t| [String] |], [| id |])
|
|
| 93 |
, ("lock", [t| Bool |], [| id |])
|
|
| 94 |
]) |
|
| 95 |
, ("QueryInstances",
|
|
| 96 |
[ ("names", [t| [String] |], [| id |])
|
|
| 97 |
, ("fields", [t| [String] |], [| id |])
|
|
| 98 |
, ("lock", [t| Bool |], [| id |])
|
|
| 99 |
]) |
|
| 100 |
, ("QueryJobs",
|
|
| 101 |
[ ("ids", [t| [Int] |], [| map show |])
|
|
| 102 |
, ("fields", [t| [String] |], [| id |])
|
|
| 103 |
]) |
|
| 104 |
, ("QueryExports",
|
|
| 105 |
[ ("nodes", [t| [String] |], [| id |])
|
|
| 106 |
, ("lock", [t| Bool |], [| id |])
|
|
| 107 |
]) |
|
| 108 |
, ("QueryConfigValues",
|
|
| 109 |
[ ("fields", [t| [String] |], [| id |]) ]
|
|
| 110 |
) |
|
| 111 |
, ("QueryClusterInfo", [])
|
|
| 112 |
, ("QueryTags",
|
|
| 113 |
[ ("kind", [t| String |], [| id |])
|
|
| 114 |
, ("name", [t| String |], [| id |])
|
|
| 115 |
]) |
|
| 116 |
, ("SubmitJob",
|
|
| 117 |
[ ("job", [t| [OpCode] |], [| id |]) ]
|
|
| 118 |
) |
|
| 119 |
, ("SubmitManyJobs",
|
|
| 120 |
[ ("ops", [t| [[OpCode]] |], [| id |]) ]
|
|
| 121 |
) |
|
| 122 |
, ("WaitForJobChange",
|
|
| 123 |
[ ("job", [t| Int |], [| id |])
|
|
| 124 |
, ("fields", [t| [String]|], [| id |])
|
|
| 125 |
, ("prev_job", [t| JSValue |], [| id |])
|
|
| 126 |
, ("prev_log", [t| JSValue |], [| id |])
|
|
| 127 |
, ("tmout", [t| Int |], [| id |])
|
|
| 128 |
]) |
|
| 129 |
, ("ArchiveJob",
|
|
| 130 |
[ ("job", [t| Int |], [| show |]) ]
|
|
| 131 |
) |
|
| 132 |
, ("AutoArchiveJobs",
|
|
| 133 |
[ ("age", [t| Int |], [| id |])
|
|
| 134 |
, ("tmout", [t| Int |], [| id |])
|
|
| 135 |
]) |
|
| 136 |
, ("CancelJob",
|
|
| 137 |
[ ("job", [t| Int |], [| show |]) ]
|
|
| 138 |
) |
|
| 139 |
, ("SetDrainFlag",
|
|
| 140 |
[ ("flag", [t| Bool |], [| id |]) ]
|
|
| 141 |
) |
|
| 142 |
, ("SetWatcherPause",
|
|
| 143 |
[ ("duration", [t| Double |], [| id |]) ]
|
|
| 144 |
) |
|
| 145 | 145 |
]) |
| 146 | 146 |
|
| 147 | 147 |
-- | The serialisation of LuxiOps into strings in messages. |
| 148 | 148 |
$(genStrOfOp ''LuxiOp "strOfOp") |
| 149 | 149 |
|
| 150 | 150 |
$(declareIADT "ResultStatus" |
| 151 |
[ ("RSNormal", 'rsNormal)
|
|
| 152 |
, ("RSUnknown", 'rsUnknown)
|
|
| 153 |
, ("RSNoData", 'rsNodata)
|
|
| 154 |
, ("RSUnavailable", 'rsUnavail)
|
|
| 155 |
, ("RSOffline", 'rsOffline)
|
|
| 156 |
])
|
|
| 151 |
[ ("RSNormal", 'rsNormal)
|
|
| 152 |
, ("RSUnknown", 'rsUnknown)
|
|
| 153 |
, ("RSNoData", 'rsNodata)
|
|
| 154 |
, ("RSUnavailable", 'rsUnavail)
|
|
| 155 |
, ("RSOffline", 'rsOffline)
|
|
| 156 |
]) |
|
| 157 | 157 |
|
| 158 | 158 |
$(makeJSONInstance ''ResultStatus) |
| 159 | 159 |
|
| ... | ... | |
| 186 | 186 |
-- | Connects to the master daemon and returns a luxi Client. |
| 187 | 187 |
getClient :: String -> IO Client |
| 188 | 188 |
getClient path = do |
| 189 |
s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
|
|
| 190 |
withTimeout connTimeout "creating luxi connection" $
|
|
| 191 |
S.connect s (S.SockAddrUnix path)
|
|
| 192 |
rf <- newIORef ""
|
|
| 193 |
return Client { socket=s, rbuf=rf}
|
|
| 189 |
s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol |
|
| 190 |
withTimeout connTimeout "creating luxi connection" $ |
|
| 191 |
S.connect s (S.SockAddrUnix path) |
|
| 192 |
rf <- newIORef "" |
|
| 193 |
return Client { socket=s, rbuf=rf}
|
|
| 194 | 194 |
|
| 195 | 195 |
-- | Closes the client socket. |
| 196 | 196 |
closeClient :: Client -> IO () |
| ... | ... | |
| 199 | 199 |
-- | Sends a message over a luxi transport. |
| 200 | 200 |
sendMsg :: Client -> String -> IO () |
| 201 | 201 |
sendMsg s buf = |
| 202 |
let _send obuf = do
|
|
| 203 |
sbytes <- withTimeout queryTimeout
|
|
| 204 |
"sending luxi message" $
|
|
| 205 |
S.send (socket s) obuf
|
|
| 206 |
unless (sbytes == length obuf) $ _send (drop sbytes obuf)
|
|
| 207 |
in _send (buf ++ [eOM])
|
|
| 202 |
let _send obuf = do |
|
| 203 |
sbytes <- withTimeout queryTimeout |
|
| 204 |
"sending luxi message" $ |
|
| 205 |
S.send (socket s) obuf |
|
| 206 |
unless (sbytes == length obuf) $ _send (drop sbytes obuf) |
|
| 207 |
in _send (buf ++ [eOM]) |
|
| 208 | 208 |
|
| 209 | 209 |
-- | Waits for a message over a luxi transport. |
| 210 | 210 |
recvMsg :: Client -> IO String |
| ... | ... | |
| 229 | 229 |
buildCall :: LuxiOp -- ^ The method |
| 230 | 230 |
-> String -- ^ The serialized form |
| 231 | 231 |
buildCall lo = |
| 232 |
let ja = [ (strOfKey Method, JSString $ toJSString $ strOfOp lo::JSValue)
|
|
| 233 |
, (strOfKey Args, opToArgs lo::JSValue)
|
|
| 234 |
]
|
|
| 235 |
jo = toJSObject ja
|
|
| 236 |
in encodeStrict jo
|
|
| 232 |
let ja = [ (strOfKey Method, JSString $ toJSString $ strOfOp lo::JSValue) |
|
| 233 |
, (strOfKey Args, opToArgs lo::JSValue) |
|
| 234 |
] |
|
| 235 |
jo = toJSObject ja |
|
| 236 |
in encodeStrict jo |
|
| 237 | 237 |
|
| 238 | 238 |
-- | Check that luxi responses contain the required keys and that the |
| 239 | 239 |
-- call was successful. |
Also available in: Unified diff