1 {-| Implementation of the Ganeti LUXI interface.
7 Copyright (C) 2009 Google Inc.
9 This program is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 2 of the License, or
12 (at your option) any later version.
14 This program is distributed in the hope that it will be useful, but
15 WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 General Public License for more details.
19 You should have received a copy of the GNU General Public License
20 along with this program; if not, write to the Free Software
21 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
39 import Text.JSON (JSObject, JSValue, toJSObject, encodeStrict, decodeStrict)
40 import qualified Text.JSON as J
41 import Text.JSON.Types
43 import qualified Network.Socket as S
45 import Ganeti.HTools.Utils
46 import Ganeti.HTools.Types
48 import Ganeti.Jobs (JobStatus)
50 -- * Utility functions
52 -- | Wrapper over System.Timeout.timeout that fails in the IO monad.
53 withTimeout :: Int -> String -> IO a -> IO a
54 withTimeout secs descr action = do
55 result <- timeout (secs * 1000000) action
57 Nothing -> fail $ "Timeout in " ++ descr
60 -- * Generic protocol functionality
62 -- | Currently supported Luxi operations.
63 data LuxiOp = QueryInstances
68 -- | The serialisation of LuxiOps into strings in messages.
69 strOfOp :: LuxiOp -> String
70 strOfOp QueryNodes = "QueryNodes"
71 strOfOp QueryInstances = "QueryInstances"
72 strOfOp QueryJobs = "QueryJobs"
73 strOfOp SubmitManyJobs = "SubmitManyJobs"
75 -- | The end-of-message separator.
79 -- | Valid keys in the requests and responses.
85 -- | The serialisation of MsgKeys into strings in messages.
86 strOfKey :: MsgKeys -> String
87 strOfKey Method = "method"
88 strOfKey Args = "args"
89 strOfKey Success = "success"
90 strOfKey Result = "result"
92 -- | Luxi client encapsulation.
93 data Client = Client { socket :: S.Socket -- ^ The socket of the client
94 , rbuf :: IORef String -- ^ Already received buffer
97 -- | Connects to the master daemon and returns a luxi Client.
98 getClient :: String -> IO Client
100 s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
101 withTimeout connTimeout "creating luxi connection" $
102 S.connect s (S.SockAddrUnix path)
104 return Client { socket=s, rbuf=rf}
106 -- | Closes the client socket.
107 closeClient :: Client -> IO ()
108 closeClient = S.sClose . socket
110 -- | Sends a message over a luxi transport.
111 sendMsg :: Client -> String -> IO ()
114 sbytes <- withTimeout queryTimeout
115 "sending luxi message" $
116 S.send (socket s) obuf
117 unless (sbytes == length obuf) $ _send (drop sbytes obuf)
118 in _send (buf ++ [eOM])
120 -- | Waits for a message over a luxi transport.
121 recvMsg :: Client -> IO String
124 nbuf <- withTimeout queryTimeout "reading luxi response" $
125 S.recv (socket s) 4096
126 let (msg, remaining) = break ((==) eOM) (obuf ++ nbuf)
129 else return (msg, tail remaining))
130 cbuf <- readIORef $ rbuf s
131 (msg, nbuf) <- _recv cbuf
132 writeIORef (rbuf s) nbuf
135 -- | Serialize a request to String.
136 buildCall :: LuxiOp -- ^ The method
137 -> JSValue -- ^ The arguments
138 -> String -- ^ The serialized form
140 let ja = [(strOfKey Method,
141 JSString $ toJSString $ strOfOp msg::JSValue),
148 -- | Check that luxi responses contain the required keys and that the
149 -- call was successful.
150 validateResult :: String -> Result JSValue
151 validateResult s = do
152 arr <- fromJResult $ decodeStrict s::Result (JSObject JSValue)
153 status <- fromObj (strOfKey Success) arr::Result Bool
154 let rkey = strOfKey Result
156 then fromObj rkey arr
157 else fromObj rkey arr >>= fail)
159 -- | Generic luxi method call.
160 callMethod :: LuxiOp -> JSValue -> Client -> IO (Result JSValue)
161 callMethod method args s = do
162 sendMsg s $ buildCall method args
164 let rval = validateResult result
167 -- | Specialized submitManyJobs call.
168 submitManyJobs :: Client -> JSValue -> IO (Result [String])
169 submitManyJobs s jobs = do
170 rval <- callMethod SubmitManyJobs jobs s
171 -- map each result (status, payload) pair into a nice Result ADT
172 return $ case rval of
175 mapM (\v -> case v of
176 JSArray [JSBool True, JSString x] ->
178 JSArray [JSBool False, JSString x] ->
180 _ -> Bad "Unknown result from the master daemon"
182 x -> Bad ("Cannot parse response from Ganeti: " ++ show x)
184 -- | Custom queryJobs call.
185 queryJobsStatus :: Client -> [String] -> IO (Result [JobStatus])
186 queryJobsStatus s jids = do
187 rval <- callMethod QueryJobs (J.showJSON (jids, ["status"])) s
188 return $ case rval of
190 Ok y -> case J.readJSON y::(J.Result [[JobStatus]]) of
191 J.Ok vals -> if any null vals
192 then Bad "Missing job status field"
193 else Ok (map head vals)