root / htools / Ganeti / Luxi.hs @ 56c094b4
History | View | Annotate | Download (8.6 kB)
1 | 6583e677 | Iustin Pop | {-| Implementation of the Ganeti LUXI interface. |
---|---|---|---|
2 | 6583e677 | Iustin Pop | |
3 | 6583e677 | Iustin Pop | -} |
4 | 6583e677 | Iustin Pop | |
5 | 6583e677 | Iustin Pop | {- |
6 | 6583e677 | Iustin Pop | |
7 | e8230242 | Iustin Pop | Copyright (C) 2009, 2010, 2011 Google Inc. |
8 | 6583e677 | Iustin Pop | |
9 | 6583e677 | Iustin Pop | This program is free software; you can redistribute it and/or modify |
10 | 6583e677 | Iustin Pop | it under the terms of the GNU General Public License as published by |
11 | 6583e677 | Iustin Pop | the Free Software Foundation; either version 2 of the License, or |
12 | 6583e677 | Iustin Pop | (at your option) any later version. |
13 | 6583e677 | Iustin Pop | |
14 | 6583e677 | Iustin Pop | This program is distributed in the hope that it will be useful, but |
15 | 6583e677 | Iustin Pop | WITHOUT ANY WARRANTY; without even the implied warranty of |
16 | 6583e677 | Iustin Pop | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
17 | 6583e677 | Iustin Pop | General Public License for more details. |
18 | 6583e677 | Iustin Pop | |
19 | 6583e677 | Iustin Pop | You should have received a copy of the GNU General Public License |
20 | 6583e677 | Iustin Pop | along with this program; if not, write to the Free Software |
21 | 6583e677 | Iustin Pop | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
22 | 6583e677 | Iustin Pop | 02110-1301, USA. |
23 | 6583e677 | Iustin Pop | |
24 | 6583e677 | Iustin Pop | -} |
25 | 6583e677 | Iustin Pop | |
26 | 6583e677 | Iustin Pop | module Ganeti.Luxi |
27 | 6583e677 | Iustin Pop | ( LuxiOp(..) |
28 | 6583e677 | Iustin Pop | , Client |
29 | 6583e677 | Iustin Pop | , getClient |
30 | 6583e677 | Iustin Pop | , closeClient |
31 | 6583e677 | Iustin Pop | , callMethod |
32 | 9a2ff880 | Iustin Pop | , submitManyJobs |
33 | 9a2ff880 | Iustin Pop | , queryJobsStatus |
34 | 6583e677 | Iustin Pop | ) where |
35 | 6583e677 | Iustin Pop | |
36 | 6583e677 | Iustin Pop | import Data.IORef |
37 | 6583e677 | Iustin Pop | import Control.Monad |
38 | 0903280b | Iustin Pop | import Text.JSON (encodeStrict, decodeStrict) |
39 | 6583e677 | Iustin Pop | import qualified Text.JSON as J |
40 | 6583e677 | Iustin Pop | import Text.JSON.Types |
41 | 6583e677 | Iustin Pop | import System.Timeout |
42 | 6583e677 | Iustin Pop | import qualified Network.Socket as S |
43 | 6583e677 | Iustin Pop | |
44 | 6583e677 | Iustin Pop | import Ganeti.HTools.Utils |
45 | 6583e677 | Iustin Pop | import Ganeti.HTools.Types |
46 | 6583e677 | Iustin Pop | |
47 | 9a2ff880 | Iustin Pop | import Ganeti.Jobs (JobStatus) |
48 | 683b1ca7 | Iustin Pop | import Ganeti.OpCodes (OpCode) |
49 | 9a2ff880 | Iustin Pop | |
50 | 6583e677 | Iustin Pop | -- * Utility functions |
51 | 6583e677 | Iustin Pop | |
52 | 6583e677 | Iustin Pop | -- | Wrapper over System.Timeout.timeout that fails in the IO monad. |
53 | 6583e677 | Iustin Pop | withTimeout :: Int -> String -> IO a -> IO a |
54 | 6583e677 | Iustin Pop | withTimeout secs descr action = do |
55 | 6583e677 | Iustin Pop | result <- timeout (secs * 1000000) action |
56 | 6583e677 | Iustin Pop | (case result of |
57 | 6583e677 | Iustin Pop | Nothing -> fail $ "Timeout in " ++ descr |
58 | 6583e677 | Iustin Pop | Just v -> return v) |
59 | 6583e677 | Iustin Pop | |
60 | 6583e677 | Iustin Pop | -- * Generic protocol functionality |
61 | 6583e677 | Iustin Pop | |
62 | 6583e677 | Iustin Pop | -- | Currently supported Luxi operations. |
63 | 683b1ca7 | Iustin Pop | data LuxiOp = QueryInstances [String] [String] Bool |
64 | 683b1ca7 | Iustin Pop | | QueryNodes [String] [String] Bool |
65 | edd0a48f | Iustin Pop | | QueryGroups [String] [String] Bool |
66 | 683b1ca7 | Iustin Pop | | QueryJobs [Int] [String] |
67 | 04282772 | Iustin Pop | | QueryExports [String] Bool |
68 | 04282772 | Iustin Pop | | QueryConfigValues [String] |
69 | f89235f1 | Iustin Pop | | QueryClusterInfo |
70 | 04282772 | Iustin Pop | | QueryTags String String |
71 | 9622919d | Iustin Pop | | SubmitJob [OpCode] |
72 | 683b1ca7 | Iustin Pop | | SubmitManyJobs [[OpCode]] |
73 | 9622919d | Iustin Pop | | WaitForJobChange Int [String] JSValue JSValue Int |
74 | 9622919d | Iustin Pop | | ArchiveJob Int |
75 | 9622919d | Iustin Pop | | AutoArchiveJobs Int Int |
76 | 04282772 | Iustin Pop | | CancelJob Int |
77 | 04282772 | Iustin Pop | | SetDrainFlag Bool |
78 | 04282772 | Iustin Pop | | SetWatcherPause Double |
79 | 6bc39970 | Iustin Pop | deriving (Show, Read) |
80 | 6583e677 | Iustin Pop | |
81 | 6583e677 | Iustin Pop | -- | The serialisation of LuxiOps into strings in messages. |
82 | 6583e677 | Iustin Pop | strOfOp :: LuxiOp -> String |
83 | 04282772 | Iustin Pop | strOfOp QueryNodes {} = "QueryNodes" |
84 | edd0a48f | Iustin Pop | strOfOp QueryGroups {} = "QueryGroups" |
85 | 04282772 | Iustin Pop | strOfOp QueryInstances {} = "QueryInstances" |
86 | 04282772 | Iustin Pop | strOfOp QueryJobs {} = "QueryJobs" |
87 | 04282772 | Iustin Pop | strOfOp QueryExports {} = "QueryExports" |
88 | 04282772 | Iustin Pop | strOfOp QueryConfigValues {} = "QueryConfigValues" |
89 | 04282772 | Iustin Pop | strOfOp QueryClusterInfo {} = "QueryClusterInfo" |
90 | 04282772 | Iustin Pop | strOfOp QueryTags {} = "QueryTags" |
91 | 04282772 | Iustin Pop | strOfOp SubmitManyJobs {} = "SubmitManyJobs" |
92 | 04282772 | Iustin Pop | strOfOp WaitForJobChange {} = "WaitForJobChange" |
93 | 04282772 | Iustin Pop | strOfOp SubmitJob {} = "SubmitJob" |
94 | 04282772 | Iustin Pop | strOfOp ArchiveJob {} = "ArchiveJob" |
95 | 04282772 | Iustin Pop | strOfOp AutoArchiveJobs {} = "AutoArchiveJobs" |
96 | 04282772 | Iustin Pop | strOfOp CancelJob {} = "CancelJob" |
97 | 04282772 | Iustin Pop | strOfOp SetDrainFlag {} = "SetDrainFlag" |
98 | 04282772 | Iustin Pop | strOfOp SetWatcherPause {} = "SetWatcherPause" |
99 | 6583e677 | Iustin Pop | |
100 | 6583e677 | Iustin Pop | -- | The end-of-message separator. |
101 | 6583e677 | Iustin Pop | eOM :: Char |
102 | 6583e677 | Iustin Pop | eOM = '\3' |
103 | 6583e677 | Iustin Pop | |
104 | 6583e677 | Iustin Pop | -- | Valid keys in the requests and responses. |
105 | 6583e677 | Iustin Pop | data MsgKeys = Method |
106 | 6583e677 | Iustin Pop | | Args |
107 | 6583e677 | Iustin Pop | | Success |
108 | 6583e677 | Iustin Pop | | Result |
109 | 6583e677 | Iustin Pop | |
110 | 6583e677 | Iustin Pop | -- | The serialisation of MsgKeys into strings in messages. |
111 | 6583e677 | Iustin Pop | strOfKey :: MsgKeys -> String |
112 | 6583e677 | Iustin Pop | strOfKey Method = "method" |
113 | 6583e677 | Iustin Pop | strOfKey Args = "args" |
114 | 6583e677 | Iustin Pop | strOfKey Success = "success" |
115 | 6583e677 | Iustin Pop | strOfKey Result = "result" |
116 | 6583e677 | Iustin Pop | |
117 | 6583e677 | Iustin Pop | -- | Luxi client encapsulation. |
118 | 6583e677 | Iustin Pop | data Client = Client { socket :: S.Socket -- ^ The socket of the client |
119 | 6583e677 | Iustin Pop | , rbuf :: IORef String -- ^ Already received buffer |
120 | 6583e677 | Iustin Pop | } |
121 | 6583e677 | Iustin Pop | |
122 | 6583e677 | Iustin Pop | -- | Connects to the master daemon and returns a luxi Client. |
123 | 6583e677 | Iustin Pop | getClient :: String -> IO Client |
124 | 6583e677 | Iustin Pop | getClient path = do |
125 | 6583e677 | Iustin Pop | s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol |
126 | 6583e677 | Iustin Pop | withTimeout connTimeout "creating luxi connection" $ |
127 | 6583e677 | Iustin Pop | S.connect s (S.SockAddrUnix path) |
128 | 6583e677 | Iustin Pop | rf <- newIORef "" |
129 | 6583e677 | Iustin Pop | return Client { socket=s, rbuf=rf} |
130 | 6583e677 | Iustin Pop | |
131 | 6583e677 | Iustin Pop | -- | Closes the client socket. |
132 | 6583e677 | Iustin Pop | closeClient :: Client -> IO () |
133 | 6583e677 | Iustin Pop | closeClient = S.sClose . socket |
134 | 6583e677 | Iustin Pop | |
135 | 6583e677 | Iustin Pop | -- | Sends a message over a luxi transport. |
136 | 6583e677 | Iustin Pop | sendMsg :: Client -> String -> IO () |
137 | 6583e677 | Iustin Pop | sendMsg s buf = |
138 | 6583e677 | Iustin Pop | let _send obuf = do |
139 | 6583e677 | Iustin Pop | sbytes <- withTimeout queryTimeout |
140 | 6583e677 | Iustin Pop | "sending luxi message" $ |
141 | 6583e677 | Iustin Pop | S.send (socket s) obuf |
142 | 3a3c1eb4 | Iustin Pop | unless (sbytes == length obuf) $ _send (drop sbytes obuf) |
143 | 6583e677 | Iustin Pop | in _send (buf ++ [eOM]) |
144 | 6583e677 | Iustin Pop | |
145 | 6583e677 | Iustin Pop | -- | Waits for a message over a luxi transport. |
146 | 6583e677 | Iustin Pop | recvMsg :: Client -> IO String |
147 | 6583e677 | Iustin Pop | recvMsg s = do |
148 | 6583e677 | Iustin Pop | let _recv obuf = do |
149 | 6583e677 | Iustin Pop | nbuf <- withTimeout queryTimeout "reading luxi response" $ |
150 | 6583e677 | Iustin Pop | S.recv (socket s) 4096 |
151 | 95f490de | Iustin Pop | let (msg, remaining) = break (eOM ==) nbuf |
152 | 6583e677 | Iustin Pop | (if null remaining |
153 | 95f490de | Iustin Pop | then _recv (obuf ++ msg) |
154 | 95f490de | Iustin Pop | else return (obuf ++ msg, tail remaining)) |
155 | 6583e677 | Iustin Pop | cbuf <- readIORef $ rbuf s |
156 | 95f490de | Iustin Pop | let (imsg, ibuf) = break (eOM ==) cbuf |
157 | 95f490de | Iustin Pop | (msg, nbuf) <- |
158 | 95f490de | Iustin Pop | (if null ibuf -- if old buffer didn't contain a full message |
159 | 95f490de | Iustin Pop | then _recv cbuf -- then we read from network |
160 | 95f490de | Iustin Pop | else return (imsg, tail ibuf)) -- else we return data from our buffer |
161 | 6583e677 | Iustin Pop | writeIORef (rbuf s) nbuf |
162 | 6583e677 | Iustin Pop | return msg |
163 | 6583e677 | Iustin Pop | |
164 | 683b1ca7 | Iustin Pop | -- | Compute the serialized form of a Luxi operation |
165 | 683b1ca7 | Iustin Pop | opToArgs :: LuxiOp -> JSValue |
166 | 683b1ca7 | Iustin Pop | opToArgs (QueryNodes names fields lock) = J.showJSON (names, fields, lock) |
167 | edd0a48f | Iustin Pop | opToArgs (QueryGroups names fields lock) = J.showJSON (names, fields, lock) |
168 | 04282772 | Iustin Pop | opToArgs (QueryInstances names fields lock) = J.showJSON (names, fields, lock) |
169 | 683b1ca7 | Iustin Pop | opToArgs (QueryJobs ids fields) = J.showJSON (map show ids, fields) |
170 | 04282772 | Iustin Pop | opToArgs (QueryExports nodes lock) = J.showJSON (nodes, lock) |
171 | 04282772 | Iustin Pop | opToArgs (QueryConfigValues fields) = J.showJSON fields |
172 | 683b1ca7 | Iustin Pop | opToArgs (QueryClusterInfo) = J.showJSON () |
173 | 04282772 | Iustin Pop | opToArgs (QueryTags kind name) = J.showJSON (kind, name) |
174 | 9622919d | Iustin Pop | opToArgs (SubmitJob j) = J.showJSON j |
175 | 04282772 | Iustin Pop | opToArgs (SubmitManyJobs ops) = J.showJSON ops |
176 | 9622919d | Iustin Pop | -- This is special, since the JSON library doesn't export an instance |
177 | 9622919d | Iustin Pop | -- of a 5-tuple |
178 | 9622919d | Iustin Pop | opToArgs (WaitForJobChange a b c d e) = |
179 | 9622919d | Iustin Pop | JSArray [ J.showJSON a, J.showJSON b, J.showJSON c |
180 | 9622919d | Iustin Pop | , J.showJSON d, J.showJSON e] |
181 | 04282772 | Iustin Pop | opToArgs (ArchiveJob a) = J.showJSON (show a) |
182 | 9622919d | Iustin Pop | opToArgs (AutoArchiveJobs a b) = J.showJSON (a, b) |
183 | 04282772 | Iustin Pop | opToArgs (CancelJob a) = J.showJSON (show a) |
184 | 04282772 | Iustin Pop | opToArgs (SetDrainFlag flag) = J.showJSON flag |
185 | 04282772 | Iustin Pop | opToArgs (SetWatcherPause duration) = J.showJSON [duration] |
186 | 683b1ca7 | Iustin Pop | |
187 | 6583e677 | Iustin Pop | -- | Serialize a request to String. |
188 | 6583e677 | Iustin Pop | buildCall :: LuxiOp -- ^ The method |
189 | 6583e677 | Iustin Pop | -> String -- ^ The serialized form |
190 | 683b1ca7 | Iustin Pop | buildCall lo = |
191 | 683b1ca7 | Iustin Pop | let ja = [ (strOfKey Method, JSString $ toJSString $ strOfOp lo::JSValue) |
192 | 683b1ca7 | Iustin Pop | , (strOfKey Args, opToArgs lo::JSValue) |
193 | 6583e677 | Iustin Pop | ] |
194 | 6583e677 | Iustin Pop | jo = toJSObject ja |
195 | 6583e677 | Iustin Pop | in encodeStrict jo |
196 | 6583e677 | Iustin Pop | |
197 | 6583e677 | Iustin Pop | -- | Check that luxi responses contain the required keys and that the |
198 | 6583e677 | Iustin Pop | -- call was successful. |
199 | 6583e677 | Iustin Pop | validateResult :: String -> Result JSValue |
200 | 6583e677 | Iustin Pop | validateResult s = do |
201 | c96d44df | Iustin Pop | oarr <- fromJResult "Parsing LUXI response" |
202 | c96d44df | Iustin Pop | (decodeStrict s)::Result (JSObject JSValue) |
203 | 262f3e6c | Iustin Pop | let arr = J.fromJSObject oarr |
204 | e8230242 | Iustin Pop | status <- fromObj arr (strOfKey Success)::Result Bool |
205 | 6583e677 | Iustin Pop | let rkey = strOfKey Result |
206 | 6583e677 | Iustin Pop | (if status |
207 | e8230242 | Iustin Pop | then fromObj arr rkey |
208 | e8230242 | Iustin Pop | else fromObj arr rkey >>= fail) |
209 | 6583e677 | Iustin Pop | |
210 | 6583e677 | Iustin Pop | -- | Generic luxi method call. |
211 | 683b1ca7 | Iustin Pop | callMethod :: LuxiOp -> Client -> IO (Result JSValue) |
212 | 683b1ca7 | Iustin Pop | callMethod method s = do |
213 | 683b1ca7 | Iustin Pop | sendMsg s $ buildCall method |
214 | 6583e677 | Iustin Pop | result <- recvMsg s |
215 | 6583e677 | Iustin Pop | let rval = validateResult result |
216 | 6583e677 | Iustin Pop | return rval |
217 | 9a2ff880 | Iustin Pop | |
218 | 9a2ff880 | Iustin Pop | -- | Specialized submitManyJobs call. |
219 | 683b1ca7 | Iustin Pop | submitManyJobs :: Client -> [[OpCode]] -> IO (Result [String]) |
220 | 9a2ff880 | Iustin Pop | submitManyJobs s jobs = do |
221 | 683b1ca7 | Iustin Pop | rval <- callMethod (SubmitManyJobs jobs) s |
222 | 9a2ff880 | Iustin Pop | -- map each result (status, payload) pair into a nice Result ADT |
223 | 9a2ff880 | Iustin Pop | return $ case rval of |
224 | 9a2ff880 | Iustin Pop | Bad x -> Bad x |
225 | 9a2ff880 | Iustin Pop | Ok (JSArray r) -> |
226 | 9a2ff880 | Iustin Pop | mapM (\v -> case v of |
227 | 9a2ff880 | Iustin Pop | JSArray [JSBool True, JSString x] -> |
228 | 9a2ff880 | Iustin Pop | Ok (fromJSString x) |
229 | 9a2ff880 | Iustin Pop | JSArray [JSBool False, JSString x] -> |
230 | 9a2ff880 | Iustin Pop | Bad (fromJSString x) |
231 | 9a2ff880 | Iustin Pop | _ -> Bad "Unknown result from the master daemon" |
232 | 9a2ff880 | Iustin Pop | ) r |
233 | 9a2ff880 | Iustin Pop | x -> Bad ("Cannot parse response from Ganeti: " ++ show x) |
234 | 9a2ff880 | Iustin Pop | |
235 | 9a2ff880 | Iustin Pop | -- | Custom queryJobs call. |
236 | 9a2ff880 | Iustin Pop | queryJobsStatus :: Client -> [String] -> IO (Result [JobStatus]) |
237 | 9a2ff880 | Iustin Pop | queryJobsStatus s jids = do |
238 | 683b1ca7 | Iustin Pop | rval <- callMethod (QueryJobs (map read jids) ["status"]) s |
239 | 9a2ff880 | Iustin Pop | return $ case rval of |
240 | 9a2ff880 | Iustin Pop | Bad x -> Bad x |
241 | 9a2ff880 | Iustin Pop | Ok y -> case J.readJSON y::(J.Result [[JobStatus]]) of |
242 | 9a2ff880 | Iustin Pop | J.Ok vals -> if any null vals |
243 | 9a2ff880 | Iustin Pop | then Bad "Missing job status field" |
244 | 9a2ff880 | Iustin Pop | else Ok (map head vals) |
245 | 9a2ff880 | Iustin Pop | J.Error x -> Bad x |