Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Luxi.hs @ 795d035d

History | View | Annotate | Download (15.6 kB)

1 a0090487 Agata Murawska
{-# LANGUAGE TemplateHaskell #-}
2 a0090487 Agata Murawska
3 6583e677 Iustin Pop
{-| Implementation of the Ganeti LUXI interface.
4 6583e677 Iustin Pop
5 6583e677 Iustin Pop
-}
6 6583e677 Iustin Pop
7 6583e677 Iustin Pop
{-
8 6583e677 Iustin Pop
9 fae980e5 Iustin Pop
Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
10 6583e677 Iustin Pop
11 6583e677 Iustin Pop
This program is free software; you can redistribute it and/or modify
12 6583e677 Iustin Pop
it under the terms of the GNU General Public License as published by
13 6583e677 Iustin Pop
the Free Software Foundation; either version 2 of the License, or
14 6583e677 Iustin Pop
(at your option) any later version.
15 6583e677 Iustin Pop
16 6583e677 Iustin Pop
This program is distributed in the hope that it will be useful, but
17 6583e677 Iustin Pop
WITHOUT ANY WARRANTY; without even the implied warranty of
18 6583e677 Iustin Pop
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
19 6583e677 Iustin Pop
General Public License for more details.
20 6583e677 Iustin Pop
21 6583e677 Iustin Pop
You should have received a copy of the GNU General Public License
22 6583e677 Iustin Pop
along with this program; if not, write to the Free Software
23 6583e677 Iustin Pop
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
24 6583e677 Iustin Pop
02110-1301, USA.
25 6583e677 Iustin Pop
26 6583e677 Iustin Pop
-}
27 6583e677 Iustin Pop
28 6583e677 Iustin Pop
module Ganeti.Luxi
29 ebf38064 Iustin Pop
  ( LuxiOp(..)
30 95d0d502 Iustin Pop
  , LuxiReq(..)
31 ebf38064 Iustin Pop
  , Client
32 ccc817a2 Iustin Pop
  , JobId
33 c48711d5 Iustin Pop
  , fromJobId
34 c48711d5 Iustin Pop
  , makeJobId
35 0aff2293 Iustin Pop
  , RecvResult(..)
36 0aff2293 Iustin Pop
  , strOfOp
37 ebf38064 Iustin Pop
  , getClient
38 13f2321c Iustin Pop
  , getServer
39 13f2321c Iustin Pop
  , acceptClient
40 ebf38064 Iustin Pop
  , closeClient
41 0aff2293 Iustin Pop
  , closeServer
42 ebf38064 Iustin Pop
  , callMethod
43 ebf38064 Iustin Pop
  , submitManyJobs
44 ebf38064 Iustin Pop
  , queryJobsStatus
45 cdd495ae Iustin Pop
  , buildCall
46 0aff2293 Iustin Pop
  , buildResponse
47 cdd495ae Iustin Pop
  , validateCall
48 cdd495ae Iustin Pop
  , decodeCall
49 13f2321c Iustin Pop
  , recvMsg
50 0aff2293 Iustin Pop
  , recvMsgExt
51 13f2321c Iustin Pop
  , sendMsg
52 471b6c46 Iustin Pop
  , allLuxiCalls
53 ebf38064 Iustin Pop
  ) where
54 6583e677 Iustin Pop
55 0aff2293 Iustin Pop
import Control.Exception (catch)
56 6583e677 Iustin Pop
import Data.IORef
57 e821050d Iustin Pop
import qualified Data.ByteString as B
58 62d5242b Iustin Pop
import qualified Data.ByteString.Lazy as BL
59 e821050d Iustin Pop
import qualified Data.ByteString.UTF8 as UTF8
60 62d5242b Iustin Pop
import qualified Data.ByteString.Lazy.UTF8 as UTF8L
61 e821050d Iustin Pop
import Data.Word (Word8)
62 6583e677 Iustin Pop
import Control.Monad
63 0903280b Iustin Pop
import Text.JSON (encodeStrict, decodeStrict)
64 6583e677 Iustin Pop
import qualified Text.JSON as J
65 7adb7dff Iustin Pop
import Text.JSON.Pretty (pp_value)
66 6583e677 Iustin Pop
import Text.JSON.Types
67 0aff2293 Iustin Pop
import System.Directory (removeFile)
68 e821050d Iustin Pop
import System.IO (hClose, hFlush, hWaitForInput, Handle, IOMode(..))
69 0aff2293 Iustin Pop
import System.IO.Error (isEOFError)
70 6583e677 Iustin Pop
import System.Timeout
71 6583e677 Iustin Pop
import qualified Network.Socket as S
72 6583e677 Iustin Pop
73 4cd79ca8 Iustin Pop
import Ganeti.BasicTypes
74 92678b3c Iustin Pop
import Ganeti.Constants
75 7adb7dff Iustin Pop
import Ganeti.Errors
76 7adb7dff Iustin Pop
import Ganeti.JSON
77 fa10983e Iustin Pop
import Ganeti.OpParams (pTagsObject)
78 367c4241 Dato Simó
import Ganeti.OpCodes
79 4cab6703 Iustin Pop
import qualified Ganeti.Query.Language as Qlang
80 a0090487 Agata Murawska
import Ganeti.THH
81 c48711d5 Iustin Pop
import Ganeti.Types
82 9a2ff880 Iustin Pop
83 6583e677 Iustin Pop
-- * Utility functions
84 6583e677 Iustin Pop
85 6583e677 Iustin Pop
-- | Wrapper over System.Timeout.timeout that fails in the IO monad.
86 6583e677 Iustin Pop
withTimeout :: Int -> String -> IO a -> IO a
87 6583e677 Iustin Pop
withTimeout secs descr action = do
88 ebf38064 Iustin Pop
  result <- timeout (secs * 1000000) action
89 3603605a Iustin Pop
  case result of
90 3603605a Iustin Pop
    Nothing -> fail $ "Timeout in " ++ descr
91 3603605a Iustin Pop
    Just v -> return v
92 6583e677 Iustin Pop
93 6583e677 Iustin Pop
-- * Generic protocol functionality
94 6583e677 Iustin Pop
95 0aff2293 Iustin Pop
-- | Result of receiving a message from the socket.
96 0aff2293 Iustin Pop
data RecvResult = RecvConnClosed    -- ^ Connection closed
97 0aff2293 Iustin Pop
                | RecvError String  -- ^ Any other error
98 0aff2293 Iustin Pop
                | RecvOk String     -- ^ Successfull receive
99 139c0683 Iustin Pop
                  deriving (Show, Eq)
100 0aff2293 Iustin Pop
101 a0090487 Agata Murawska
-- | Currently supported Luxi operations and JSON serialization.
102 a0090487 Agata Murawska
$(genLuxiOp "LuxiOp"
103 72295708 Iustin Pop
  [ (luxiReqQuery,
104 88609f00 Iustin Pop
    [ simpleField "what"    [t| Qlang.ItemType |]
105 88609f00 Iustin Pop
    , simpleField "fields"  [t| [String]  |]
106 88609f00 Iustin Pop
    , simpleField "qfilter" [t| Qlang.Filter Qlang.FilterField |]
107 ebf38064 Iustin Pop
    ])
108 72295708 Iustin Pop
  , (luxiReqQueryFields,
109 88609f00 Iustin Pop
    [ simpleField "what"    [t| Qlang.ItemType |]
110 88609f00 Iustin Pop
    , simpleField "fields"  [t| [String]  |]
111 72295708 Iustin Pop
    ])
112 fae980e5 Iustin Pop
  , (luxiReqQueryNodes,
113 88609f00 Iustin Pop
     [ simpleField "names"  [t| [String] |]
114 88609f00 Iustin Pop
     , simpleField "fields" [t| [String] |]
115 88609f00 Iustin Pop
     , simpleField "lock"   [t| Bool     |]
116 ebf38064 Iustin Pop
     ])
117 fae980e5 Iustin Pop
  , (luxiReqQueryGroups,
118 88609f00 Iustin Pop
     [ simpleField "names"  [t| [String] |]
119 88609f00 Iustin Pop
     , simpleField "fields" [t| [String] |]
120 88609f00 Iustin Pop
     , simpleField "lock"   [t| Bool     |]
121 ebf38064 Iustin Pop
     ])
122 795d035d Klaus Aehlig
  , (luxiReqQueryNetworks,
123 795d035d Klaus Aehlig
     [ simpleField "names"  [t| [String] |]
124 795d035d Klaus Aehlig
     , simpleField "fields" [t| [String] |]
125 795d035d Klaus Aehlig
     , simpleField "lock"   [t| Bool     |]
126 795d035d Klaus Aehlig
     ])
127 fae980e5 Iustin Pop
  , (luxiReqQueryInstances,
128 88609f00 Iustin Pop
     [ simpleField "names"  [t| [String] |]
129 88609f00 Iustin Pop
     , simpleField "fields" [t| [String] |]
130 88609f00 Iustin Pop
     , simpleField "lock"   [t| Bool     |]
131 ebf38064 Iustin Pop
     ])
132 fae980e5 Iustin Pop
  , (luxiReqQueryJobs,
133 c48711d5 Iustin Pop
     [ simpleField "ids"    [t| [JobId]  |]
134 88609f00 Iustin Pop
     , simpleField "fields" [t| [String] |]
135 ebf38064 Iustin Pop
     ])
136 fae980e5 Iustin Pop
  , (luxiReqQueryExports,
137 88609f00 Iustin Pop
     [ simpleField "nodes" [t| [String] |]
138 88609f00 Iustin Pop
     , simpleField "lock"  [t| Bool     |]
139 ebf38064 Iustin Pop
     ])
140 fae980e5 Iustin Pop
  , (luxiReqQueryConfigValues,
141 88609f00 Iustin Pop
     [ simpleField "fields" [t| [String] |] ]
142 ebf38064 Iustin Pop
    )
143 fae980e5 Iustin Pop
  , (luxiReqQueryClusterInfo, [])
144 fae980e5 Iustin Pop
  , (luxiReqQueryTags,
145 fa10983e Iustin Pop
     [ pTagsObject ])
146 fae980e5 Iustin Pop
  , (luxiReqSubmitJob,
147 7e723913 Iustin Pop
     [ simpleField "job" [t| [MetaOpCode] |] ]
148 ebf38064 Iustin Pop
    )
149 fae980e5 Iustin Pop
  , (luxiReqSubmitManyJobs,
150 7e723913 Iustin Pop
     [ simpleField "ops" [t| [[MetaOpCode]] |] ]
151 ebf38064 Iustin Pop
    )
152 fae980e5 Iustin Pop
  , (luxiReqWaitForJobChange,
153 c48711d5 Iustin Pop
     [ simpleField "job"      [t| JobId   |]
154 88609f00 Iustin Pop
     , simpleField "fields"   [t| [String]|]
155 88609f00 Iustin Pop
     , simpleField "prev_job" [t| JSValue |]
156 88609f00 Iustin Pop
     , simpleField "prev_log" [t| JSValue |]
157 88609f00 Iustin Pop
     , simpleField "tmout"    [t| Int     |]
158 ebf38064 Iustin Pop
     ])
159 fae980e5 Iustin Pop
  , (luxiReqArchiveJob,
160 c48711d5 Iustin Pop
     [ simpleField "job" [t| JobId |] ]
161 ebf38064 Iustin Pop
    )
162 fae980e5 Iustin Pop
  , (luxiReqAutoArchiveJobs,
163 88609f00 Iustin Pop
     [ simpleField "age"   [t| Int |]
164 88609f00 Iustin Pop
     , simpleField "tmout" [t| Int |]
165 ebf38064 Iustin Pop
     ])
166 fae980e5 Iustin Pop
  , (luxiReqCancelJob,
167 c48711d5 Iustin Pop
     [ simpleField "job" [t| JobId |] ]
168 ebf38064 Iustin Pop
    )
169 f63ffb37 Michael Hanselmann
  , (luxiReqChangeJobPriority,
170 c48711d5 Iustin Pop
     [ simpleField "job"      [t| JobId |]
171 f63ffb37 Michael Hanselmann
     , simpleField "priority" [t| Int |] ]
172 f63ffb37 Michael Hanselmann
    )
173 fae980e5 Iustin Pop
  , (luxiReqSetDrainFlag,
174 88609f00 Iustin Pop
     [ simpleField "flag" [t| Bool |] ]
175 ebf38064 Iustin Pop
    )
176 fae980e5 Iustin Pop
  , (luxiReqSetWatcherPause,
177 88609f00 Iustin Pop
     [ simpleField "duration" [t| Double |] ]
178 ebf38064 Iustin Pop
    )
179 a0090487 Agata Murawska
  ])
180 6583e677 Iustin Pop
181 95d0d502 Iustin Pop
$(makeJSONInstance ''LuxiReq)
182 95d0d502 Iustin Pop
183 471b6c46 Iustin Pop
-- | List of all defined Luxi calls.
184 471b6c46 Iustin Pop
$(genAllConstr (drop 3) ''LuxiReq "allLuxiCalls")
185 471b6c46 Iustin Pop
186 6583e677 Iustin Pop
-- | The serialisation of LuxiOps into strings in messages.
187 a0090487 Agata Murawska
$(genStrOfOp ''LuxiOp "strOfOp")
188 6583e677 Iustin Pop
189 cdd495ae Iustin Pop
-- | Type holding the initial (unparsed) Luxi call.
190 cdd495ae Iustin Pop
data LuxiCall = LuxiCall LuxiReq JSValue
191 cdd495ae Iustin Pop
192 6583e677 Iustin Pop
-- | The end-of-message separator.
193 e821050d Iustin Pop
eOM :: Word8
194 e821050d Iustin Pop
eOM = 3
195 e821050d Iustin Pop
196 e821050d Iustin Pop
-- | The end-of-message encoded as a ByteString.
197 e821050d Iustin Pop
bEOM :: B.ByteString
198 e821050d Iustin Pop
bEOM = B.singleton eOM
199 6583e677 Iustin Pop
200 6583e677 Iustin Pop
-- | Valid keys in the requests and responses.
201 6583e677 Iustin Pop
data MsgKeys = Method
202 6583e677 Iustin Pop
             | Args
203 6583e677 Iustin Pop
             | Success
204 6583e677 Iustin Pop
             | Result
205 6583e677 Iustin Pop
206 6583e677 Iustin Pop
-- | The serialisation of MsgKeys into strings in messages.
207 a0090487 Agata Murawska
$(genStrOfKey ''MsgKeys "strOfKey")
208 6583e677 Iustin Pop
209 6583e677 Iustin Pop
-- | Luxi client encapsulation.
210 e821050d Iustin Pop
data Client = Client { socket :: Handle           -- ^ The socket of the client
211 e821050d Iustin Pop
                     , rbuf :: IORef B.ByteString -- ^ Already received buffer
212 6583e677 Iustin Pop
                     }
213 6583e677 Iustin Pop
214 6583e677 Iustin Pop
-- | Connects to the master daemon and returns a luxi Client.
215 6583e677 Iustin Pop
getClient :: String -> IO Client
216 6583e677 Iustin Pop
getClient path = do
217 ebf38064 Iustin Pop
  s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
218 4cd79ca8 Iustin Pop
  withTimeout luxiDefCtmo "creating luxi connection" $
219 ebf38064 Iustin Pop
              S.connect s (S.SockAddrUnix path)
220 e821050d Iustin Pop
  rf <- newIORef B.empty
221 e821050d Iustin Pop
  h <- S.socketToHandle s ReadWriteMode
222 e821050d Iustin Pop
  return Client { socket=h, rbuf=rf }
223 6583e677 Iustin Pop
224 13f2321c Iustin Pop
-- | Creates and returns a server endpoint.
225 13f2321c Iustin Pop
getServer :: FilePath -> IO S.Socket
226 13f2321c Iustin Pop
getServer path = do
227 13f2321c Iustin Pop
  s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
228 13f2321c Iustin Pop
  S.bindSocket s (S.SockAddrUnix path)
229 13f2321c Iustin Pop
  S.listen s 5 -- 5 is the max backlog
230 13f2321c Iustin Pop
  return s
231 13f2321c Iustin Pop
232 0aff2293 Iustin Pop
-- | Closes a server endpoint.
233 0aff2293 Iustin Pop
-- FIXME: this should be encapsulated into a nicer type.
234 0aff2293 Iustin Pop
closeServer :: FilePath -> S.Socket -> IO ()
235 0aff2293 Iustin Pop
closeServer path sock = do
236 0aff2293 Iustin Pop
  S.sClose sock
237 0aff2293 Iustin Pop
  removeFile path
238 0aff2293 Iustin Pop
239 13f2321c Iustin Pop
-- | Accepts a client
240 13f2321c Iustin Pop
acceptClient :: S.Socket -> IO Client
241 13f2321c Iustin Pop
acceptClient s = do
242 13f2321c Iustin Pop
  -- second return is the address of the client, which we ignore here
243 13f2321c Iustin Pop
  (client_socket, _) <- S.accept s
244 13f2321c Iustin Pop
  new_buffer <- newIORef B.empty
245 13f2321c Iustin Pop
  handle <- S.socketToHandle client_socket ReadWriteMode
246 13f2321c Iustin Pop
  return Client { socket=handle, rbuf=new_buffer }
247 13f2321c Iustin Pop
248 6583e677 Iustin Pop
-- | Closes the client socket.
249 6583e677 Iustin Pop
closeClient :: Client -> IO ()
250 e821050d Iustin Pop
closeClient = hClose . socket
251 6583e677 Iustin Pop
252 6583e677 Iustin Pop
-- | Sends a message over a luxi transport.
253 6583e677 Iustin Pop
sendMsg :: Client -> String -> IO ()
254 4cd79ca8 Iustin Pop
sendMsg s buf = withTimeout luxiDefRwto "sending luxi message" $ do
255 62d5242b Iustin Pop
  let encoded = UTF8L.fromString buf
256 e821050d Iustin Pop
      handle = socket s
257 62d5242b Iustin Pop
  BL.hPut handle encoded
258 e821050d Iustin Pop
  B.hPut handle bEOM
259 e821050d Iustin Pop
  hFlush handle
260 e821050d Iustin Pop
261 e821050d Iustin Pop
-- | Given a current buffer and the handle, it will read from the
262 e821050d Iustin Pop
-- network until we get a full message, and it will return that
263 e821050d Iustin Pop
-- message and the leftover buffer contents.
264 e821050d Iustin Pop
recvUpdate :: Handle -> B.ByteString -> IO (B.ByteString, B.ByteString)
265 e821050d Iustin Pop
recvUpdate handle obuf = do
266 4cd79ca8 Iustin Pop
  nbuf <- withTimeout luxiDefRwto "reading luxi response" $ do
267 e821050d Iustin Pop
            _ <- hWaitForInput handle (-1)
268 e821050d Iustin Pop
            B.hGetNonBlocking handle 4096
269 e821050d Iustin Pop
  let (msg, remaining) = B.break (eOM ==) nbuf
270 e821050d Iustin Pop
      newbuf = B.append obuf msg
271 e821050d Iustin Pop
  if B.null remaining
272 e821050d Iustin Pop
    then recvUpdate handle newbuf
273 e821050d Iustin Pop
    else return (newbuf, B.tail remaining)
274 6583e677 Iustin Pop
275 6583e677 Iustin Pop
-- | Waits for a message over a luxi transport.
276 6583e677 Iustin Pop
recvMsg :: Client -> IO String
277 6583e677 Iustin Pop
recvMsg s = do
278 6583e677 Iustin Pop
  cbuf <- readIORef $ rbuf s
279 e821050d Iustin Pop
  let (imsg, ibuf) = B.break (eOM ==) cbuf
280 95f490de Iustin Pop
  (msg, nbuf) <-
281 e821050d Iustin Pop
    if B.null ibuf      -- if old buffer didn't contain a full message
282 e821050d Iustin Pop
      then recvUpdate (socket s) cbuf   -- then we read from network
283 e821050d Iustin Pop
      else return (imsg, B.tail ibuf)   -- else we return data from our buffer
284 6583e677 Iustin Pop
  writeIORef (rbuf s) nbuf
285 e821050d Iustin Pop
  return $ UTF8.toString msg
286 6583e677 Iustin Pop
287 0aff2293 Iustin Pop
-- | Extended wrapper over recvMsg.
288 0aff2293 Iustin Pop
recvMsgExt :: Client -> IO RecvResult
289 0aff2293 Iustin Pop
recvMsgExt s =
290 7ae5d703 Iustin Pop
  Control.Exception.catch (liftM RecvOk (recvMsg s)) $ \e ->
291 66ad857a Iustin Pop
    return $ if isEOFError e
292 66ad857a Iustin Pop
               then RecvConnClosed
293 66ad857a Iustin Pop
               else RecvError (show e)
294 0aff2293 Iustin Pop
295 6583e677 Iustin Pop
-- | Serialize a request to String.
296 6583e677 Iustin Pop
buildCall :: LuxiOp  -- ^ The method
297 6583e677 Iustin Pop
          -> String  -- ^ The serialized form
298 683b1ca7 Iustin Pop
buildCall lo =
299 2cdaf225 Iustin Pop
  let ja = [ (strOfKey Method, J.showJSON $ strOfOp lo)
300 2cdaf225 Iustin Pop
           , (strOfKey Args, opToArgs lo)
301 ebf38064 Iustin Pop
           ]
302 ebf38064 Iustin Pop
      jo = toJSObject ja
303 ebf38064 Iustin Pop
  in encodeStrict jo
304 6583e677 Iustin Pop
305 0aff2293 Iustin Pop
-- | Serialize the response to String.
306 0aff2293 Iustin Pop
buildResponse :: Bool    -- ^ Success
307 0aff2293 Iustin Pop
              -> JSValue -- ^ The arguments
308 0aff2293 Iustin Pop
              -> String  -- ^ The serialized form
309 0aff2293 Iustin Pop
buildResponse success args =
310 0aff2293 Iustin Pop
  let ja = [ (strOfKey Success, JSBool success)
311 0aff2293 Iustin Pop
           , (strOfKey Result, args)]
312 0aff2293 Iustin Pop
      jo = toJSObject ja
313 0aff2293 Iustin Pop
  in encodeStrict jo
314 0aff2293 Iustin Pop
315 cdd495ae Iustin Pop
-- | Check that luxi request contains the required keys and parse it.
316 cdd495ae Iustin Pop
validateCall :: String -> Result LuxiCall
317 cdd495ae Iustin Pop
validateCall s = do
318 0aff2293 Iustin Pop
  arr <- fromJResult "parsing top-level luxi message" $
319 0aff2293 Iustin Pop
         decodeStrict s::Result (JSObject JSValue)
320 cdd495ae Iustin Pop
  let aobj = fromJSObject arr
321 cdd495ae Iustin Pop
  call <- fromObj aobj (strOfKey Method)::Result LuxiReq
322 cdd495ae Iustin Pop
  args <- fromObj aobj (strOfKey Args)
323 cdd495ae Iustin Pop
  return (LuxiCall call args)
324 cdd495ae Iustin Pop
325 cdd495ae Iustin Pop
-- | Converts Luxi call arguments into a 'LuxiOp' data structure.
326 cdd495ae Iustin Pop
--
327 cdd495ae Iustin Pop
-- This is currently hand-coded until we make it more uniform so that
328 cdd495ae Iustin Pop
-- it can be generated using TH.
329 cdd495ae Iustin Pop
decodeCall :: LuxiCall -> Result LuxiOp
330 cdd495ae Iustin Pop
decodeCall (LuxiCall call args) =
331 cdd495ae Iustin Pop
  case call of
332 cdd495ae Iustin Pop
    ReqQueryJobs -> do
333 c48711d5 Iustin Pop
              (jids, jargs) <- fromJVal args
334 d2970809 Iustin Pop
              jids' <- case jids of
335 d2970809 Iustin Pop
                         JSNull -> return []
336 d2970809 Iustin Pop
                         _ -> fromJVal jids
337 d2970809 Iustin Pop
              return $ QueryJobs jids' jargs
338 cdd495ae Iustin Pop
    ReqQueryInstances -> do
339 cdd495ae Iustin Pop
              (names, fields, locking) <- fromJVal args
340 cdd495ae Iustin Pop
              return $ QueryInstances names fields locking
341 cdd495ae Iustin Pop
    ReqQueryNodes -> do
342 cdd495ae Iustin Pop
              (names, fields, locking) <- fromJVal args
343 cdd495ae Iustin Pop
              return $ QueryNodes names fields locking
344 cdd495ae Iustin Pop
    ReqQueryGroups -> do
345 cdd495ae Iustin Pop
              (names, fields, locking) <- fromJVal args
346 cdd495ae Iustin Pop
              return $ QueryGroups names fields locking
347 5b11f8db Iustin Pop
    ReqQueryClusterInfo ->
348 cdd495ae Iustin Pop
              return QueryClusterInfo
349 795d035d Klaus Aehlig
    ReqQueryNetworks -> do
350 795d035d Klaus Aehlig
              (names, fields, locking) <- fromJVal args
351 795d035d Klaus Aehlig
              return $ QueryNetworks names fields locking
352 cdd495ae Iustin Pop
    ReqQuery -> do
353 9a94c848 Iustin Pop
              (what, fields, qfilter) <- fromJVal args
354 9a94c848 Iustin Pop
              return $ Query what fields qfilter
355 72295708 Iustin Pop
    ReqQueryFields -> do
356 72295708 Iustin Pop
              (what, fields) <- fromJVal args
357 72295708 Iustin Pop
              fields' <- case fields of
358 72295708 Iustin Pop
                           JSNull -> return []
359 72295708 Iustin Pop
                           _ -> fromJVal fields
360 72295708 Iustin Pop
              return $ QueryFields what fields'
361 cdd495ae Iustin Pop
    ReqSubmitJob -> do
362 cdd495ae Iustin Pop
              [ops1] <- fromJVal args
363 cdd495ae Iustin Pop
              ops2 <- mapM (fromJResult (luxiReqToRaw call) . J.readJSON) ops1
364 cdd495ae Iustin Pop
              return $ SubmitJob ops2
365 cdd495ae Iustin Pop
    ReqSubmitManyJobs -> do
366 cdd495ae Iustin Pop
              [ops1] <- fromJVal args
367 cdd495ae Iustin Pop
              ops2 <- mapM (fromJResult (luxiReqToRaw call) . J.readJSON) ops1
368 cdd495ae Iustin Pop
              return $ SubmitManyJobs ops2
369 cdd495ae Iustin Pop
    ReqWaitForJobChange -> do
370 cdd495ae Iustin Pop
              (jid, fields, pinfo, pidx, wtmout) <-
371 cdd495ae Iustin Pop
                -- No instance for 5-tuple, code copied from the
372 cdd495ae Iustin Pop
                -- json sources and adapted
373 cdd495ae Iustin Pop
                fromJResult "Parsing WaitForJobChange message" $
374 cdd495ae Iustin Pop
                case args of
375 cdd495ae Iustin Pop
                  JSArray [a, b, c, d, e] ->
376 cdd495ae Iustin Pop
                    (,,,,) `fmap`
377 cdd495ae Iustin Pop
                    J.readJSON a `ap`
378 cdd495ae Iustin Pop
                    J.readJSON b `ap`
379 cdd495ae Iustin Pop
                    J.readJSON c `ap`
380 cdd495ae Iustin Pop
                    J.readJSON d `ap`
381 cdd495ae Iustin Pop
                    J.readJSON e
382 cdd495ae Iustin Pop
                  _ -> J.Error "Not enough values"
383 c48711d5 Iustin Pop
              return $ WaitForJobChange jid fields pinfo pidx wtmout
384 cdd495ae Iustin Pop
    ReqArchiveJob -> do
385 cdd495ae Iustin Pop
              [jid] <- fromJVal args
386 c48711d5 Iustin Pop
              return $ ArchiveJob jid
387 cdd495ae Iustin Pop
    ReqAutoArchiveJobs -> do
388 cdd495ae Iustin Pop
              (age, tmout) <- fromJVal args
389 cdd495ae Iustin Pop
              return $ AutoArchiveJobs age tmout
390 cdd495ae Iustin Pop
    ReqQueryExports -> do
391 cdd495ae Iustin Pop
              (nodes, lock) <- fromJVal args
392 cdd495ae Iustin Pop
              return $ QueryExports nodes lock
393 cdd495ae Iustin Pop
    ReqQueryConfigValues -> do
394 cdd495ae Iustin Pop
              [fields] <- fromJVal args
395 cdd495ae Iustin Pop
              return $ QueryConfigValues fields
396 cdd495ae Iustin Pop
    ReqQueryTags -> do
397 cdd495ae Iustin Pop
              (kind, name) <- fromJVal args
398 d8e7c45e Iustin Pop
              item <- tagObjectFrom kind name
399 d8e7c45e Iustin Pop
              return $ QueryTags item
400 cdd495ae Iustin Pop
    ReqCancelJob -> do
401 c48711d5 Iustin Pop
              [jid] <- fromJVal args
402 c48711d5 Iustin Pop
              return $ CancelJob jid
403 f63ffb37 Michael Hanselmann
    ReqChangeJobPriority -> do
404 c48711d5 Iustin Pop
              (jid, priority) <- fromJVal args
405 c48711d5 Iustin Pop
              return $ ChangeJobPriority jid priority
406 cdd495ae Iustin Pop
    ReqSetDrainFlag -> do
407 cdd495ae Iustin Pop
              [flag] <- fromJVal args
408 cdd495ae Iustin Pop
              return $ SetDrainFlag flag
409 cdd495ae Iustin Pop
    ReqSetWatcherPause -> do
410 cdd495ae Iustin Pop
              [duration] <- fromJVal args
411 cdd495ae Iustin Pop
              return $ SetWatcherPause duration
412 cdd495ae Iustin Pop
413 6583e677 Iustin Pop
-- | Check that luxi responses contain the required keys and that the
414 6583e677 Iustin Pop
-- call was successful.
415 7adb7dff Iustin Pop
validateResult :: String -> ErrorResult JSValue
416 6583e677 Iustin Pop
validateResult s = do
417 e821050d Iustin Pop
  when (UTF8.replacement_char `elem` s) $
418 e821050d Iustin Pop
       fail "Failed to decode UTF-8, detected replacement char after decoding"
419 7adb7dff Iustin Pop
  oarr <- fromJResult "Parsing LUXI response" (decodeStrict s)
420 262f3e6c Iustin Pop
  let arr = J.fromJSObject oarr
421 7adb7dff Iustin Pop
  status <- fromObj arr (strOfKey Success)
422 7adb7dff Iustin Pop
  result <- fromObj arr (strOfKey Result)
423 3603605a Iustin Pop
  if status
424 7adb7dff Iustin Pop
    then return result
425 7adb7dff Iustin Pop
    else decodeError result
426 7adb7dff Iustin Pop
427 7adb7dff Iustin Pop
-- | Try to decode an error from the server response. This function
428 7adb7dff Iustin Pop
-- will always fail, since it's called only on the error path (when
429 7adb7dff Iustin Pop
-- status is False).
430 7adb7dff Iustin Pop
decodeError :: JSValue -> ErrorResult JSValue
431 7adb7dff Iustin Pop
decodeError val =
432 7adb7dff Iustin Pop
  case fromJVal val of
433 7adb7dff Iustin Pop
    Ok e -> Bad e
434 7adb7dff Iustin Pop
    Bad msg -> Bad $ GenericError msg
435 6583e677 Iustin Pop
436 6583e677 Iustin Pop
-- | Generic luxi method call.
437 7adb7dff Iustin Pop
callMethod :: LuxiOp -> Client -> IO (ErrorResult JSValue)
438 683b1ca7 Iustin Pop
callMethod method s = do
439 683b1ca7 Iustin Pop
  sendMsg s $ buildCall method
440 6583e677 Iustin Pop
  result <- recvMsg s
441 6583e677 Iustin Pop
  let rval = validateResult result
442 6583e677 Iustin Pop
  return rval
443 9a2ff880 Iustin Pop
444 619e89c8 Iustin Pop
-- | Parse job submission result.
445 7adb7dff Iustin Pop
parseSubmitJobResult :: JSValue -> ErrorResult JobId
446 7adb7dff Iustin Pop
parseSubmitJobResult (JSArray [JSBool True, v]) =
447 c48711d5 Iustin Pop
  case J.readJSON v of
448 c48711d5 Iustin Pop
    J.Error msg -> Bad $ LuxiError msg
449 c48711d5 Iustin Pop
    J.Ok v' -> Ok v'
450 619e89c8 Iustin Pop
parseSubmitJobResult (JSArray [JSBool False, JSString x]) =
451 7adb7dff Iustin Pop
  Bad . LuxiError $ fromJSString x
452 7adb7dff Iustin Pop
parseSubmitJobResult v =
453 7adb7dff Iustin Pop
  Bad . LuxiError $ "Unknown result from the master daemon: " ++
454 7adb7dff Iustin Pop
      show (pp_value v)
455 619e89c8 Iustin Pop
456 9a2ff880 Iustin Pop
-- | Specialized submitManyJobs call.
457 7e723913 Iustin Pop
submitManyJobs :: Client -> [[MetaOpCode]] -> IO (ErrorResult [JobId])
458 9a2ff880 Iustin Pop
submitManyJobs s jobs = do
459 683b1ca7 Iustin Pop
  rval <- callMethod (SubmitManyJobs jobs) s
460 9a2ff880 Iustin Pop
  -- map each result (status, payload) pair into a nice Result ADT
461 9a2ff880 Iustin Pop
  return $ case rval of
462 9a2ff880 Iustin Pop
             Bad x -> Bad x
463 619e89c8 Iustin Pop
             Ok (JSArray r) -> mapM parseSubmitJobResult r
464 7adb7dff Iustin Pop
             x -> Bad . LuxiError $
465 7adb7dff Iustin Pop
                  "Cannot parse response from Ganeti: " ++ show x
466 9a2ff880 Iustin Pop
467 9a2ff880 Iustin Pop
-- | Custom queryJobs call.
468 7adb7dff Iustin Pop
queryJobsStatus :: Client -> [JobId] -> IO (ErrorResult [JobStatus])
469 9a2ff880 Iustin Pop
queryJobsStatus s jids = do
470 76b62028 Iustin Pop
  rval <- callMethod (QueryJobs jids ["status"]) s
471 9a2ff880 Iustin Pop
  return $ case rval of
472 9a2ff880 Iustin Pop
             Bad x -> Bad x
473 9a2ff880 Iustin Pop
             Ok y -> case J.readJSON y::(J.Result [[JobStatus]]) of
474 9a2ff880 Iustin Pop
                       J.Ok vals -> if any null vals
475 7adb7dff Iustin Pop
                                    then Bad $
476 7adb7dff Iustin Pop
                                         LuxiError "Missing job status field"
477 9a2ff880 Iustin Pop
                                    else Ok (map head vals)
478 7adb7dff Iustin Pop
                       J.Error x -> Bad $ LuxiError x