Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / Luxi.hs @ 5f4464db

History | View | Annotate | Download (8.7 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 e8230242 Iustin Pop
Copyright (C) 2009, 2010, 2011 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 ebf38064 Iustin Pop
  , QrViaLuxi(..)
31 ebf38064 Iustin Pop
  , ResultStatus(..)
32 ebf38064 Iustin Pop
  , Client
33 ebf38064 Iustin Pop
  , checkRS
34 ebf38064 Iustin Pop
  , getClient
35 ebf38064 Iustin Pop
  , closeClient
36 ebf38064 Iustin Pop
  , callMethod
37 ebf38064 Iustin Pop
  , submitManyJobs
38 ebf38064 Iustin Pop
  , queryJobsStatus
39 ebf38064 Iustin Pop
  ) where
40 6583e677 Iustin Pop
41 6583e677 Iustin Pop
import Data.IORef
42 6583e677 Iustin Pop
import Control.Monad
43 0903280b Iustin Pop
import Text.JSON (encodeStrict, decodeStrict)
44 6583e677 Iustin Pop
import qualified Text.JSON as J
45 6583e677 Iustin Pop
import Text.JSON.Types
46 6583e677 Iustin Pop
import System.Timeout
47 6583e677 Iustin Pop
import qualified Network.Socket as S
48 6583e677 Iustin Pop
49 b69be409 Iustin Pop
import Ganeti.HTools.JSON
50 6583e677 Iustin Pop
import Ganeti.HTools.Types
51 6583e677 Iustin Pop
52 92678b3c Iustin Pop
import Ganeti.Constants
53 9a2ff880 Iustin Pop
import Ganeti.Jobs (JobStatus)
54 683b1ca7 Iustin Pop
import Ganeti.OpCodes (OpCode)
55 a0090487 Agata Murawska
import Ganeti.THH
56 9a2ff880 Iustin Pop
57 6583e677 Iustin Pop
-- * Utility functions
58 6583e677 Iustin Pop
59 6583e677 Iustin Pop
-- | Wrapper over System.Timeout.timeout that fails in the IO monad.
60 6583e677 Iustin Pop
withTimeout :: Int -> String -> IO a -> IO a
61 6583e677 Iustin Pop
withTimeout secs descr action = do
62 ebf38064 Iustin Pop
  result <- timeout (secs * 1000000) action
63 3603605a Iustin Pop
  case result of
64 3603605a Iustin Pop
    Nothing -> fail $ "Timeout in " ++ descr
65 3603605a Iustin Pop
    Just v -> return v
66 6583e677 Iustin Pop
67 6583e677 Iustin Pop
-- * Generic protocol functionality
68 6583e677 Iustin Pop
69 92678b3c Iustin Pop
$(declareSADT "QrViaLuxi"
70 ebf38064 Iustin Pop
  [ ("QRLock", 'qrLock)
71 ebf38064 Iustin Pop
  , ("QRInstance", 'qrInstance)
72 ebf38064 Iustin Pop
  , ("QRNode", 'qrNode)
73 ebf38064 Iustin Pop
  , ("QRGroup", 'qrGroup)
74 ebf38064 Iustin Pop
  , ("QROs", 'qrOs)
75 ebf38064 Iustin Pop
  ])
76 92678b3c Iustin Pop
$(makeJSONInstance ''QrViaLuxi)
77 92678b3c Iustin Pop
78 a0090487 Agata Murawska
-- | Currently supported Luxi operations and JSON serialization.
79 a0090487 Agata Murawska
$(genLuxiOp "LuxiOp"
80 ebf38064 Iustin Pop
  [("Query" ,
81 ebf38064 Iustin Pop
    [ ("what",    [t| QrViaLuxi |], [| id |])
82 ebf38064 Iustin Pop
    , ("fields",  [t| [String]  |], [| id |])
83 ebf38064 Iustin Pop
    , ("qfilter", [t| ()        |], [| const JSNull |])
84 ebf38064 Iustin Pop
    ])
85 ebf38064 Iustin Pop
  , ("QueryNodes",
86 ebf38064 Iustin Pop
     [ ("names",  [t| [String] |], [| id |])
87 ebf38064 Iustin Pop
     , ("fields", [t| [String] |], [| id |])
88 ebf38064 Iustin Pop
     , ("lock",   [t| Bool     |], [| id |])
89 ebf38064 Iustin Pop
     ])
90 ebf38064 Iustin Pop
  , ("QueryGroups",
91 ebf38064 Iustin Pop
     [ ("names",  [t| [String] |], [| id |])
92 ebf38064 Iustin Pop
     , ("fields", [t| [String] |], [| id |])
93 ebf38064 Iustin Pop
     , ("lock",   [t| Bool     |], [| id |])
94 ebf38064 Iustin Pop
     ])
95 ebf38064 Iustin Pop
  , ("QueryInstances",
96 ebf38064 Iustin Pop
     [ ("names",  [t| [String] |], [| id |])
97 ebf38064 Iustin Pop
     , ("fields", [t| [String] |], [| id |])
98 ebf38064 Iustin Pop
     , ("lock",   [t| Bool     |], [| id |])
99 ebf38064 Iustin Pop
     ])
100 ebf38064 Iustin Pop
  , ("QueryJobs",
101 ebf38064 Iustin Pop
     [ ("ids",    [t| [Int]    |], [| map show |])
102 ebf38064 Iustin Pop
     , ("fields", [t| [String] |], [| id |])
103 ebf38064 Iustin Pop
     ])
104 ebf38064 Iustin Pop
  , ("QueryExports",
105 ebf38064 Iustin Pop
     [ ("nodes", [t| [String] |], [| id |])
106 ebf38064 Iustin Pop
     , ("lock",  [t| Bool     |], [| id |])
107 ebf38064 Iustin Pop
     ])
108 ebf38064 Iustin Pop
  , ("QueryConfigValues",
109 ebf38064 Iustin Pop
     [ ("fields", [t| [String] |], [| id |]) ]
110 ebf38064 Iustin Pop
    )
111 ebf38064 Iustin Pop
  , ("QueryClusterInfo", [])
112 ebf38064 Iustin Pop
  , ("QueryTags",
113 ebf38064 Iustin Pop
     [ ("kind", [t| String |], [| id |])
114 ebf38064 Iustin Pop
     , ("name", [t| String |], [| id |])
115 ebf38064 Iustin Pop
     ])
116 ebf38064 Iustin Pop
  , ("SubmitJob",
117 ebf38064 Iustin Pop
     [ ("job", [t| [OpCode] |], [| id |]) ]
118 ebf38064 Iustin Pop
    )
119 ebf38064 Iustin Pop
  , ("SubmitManyJobs",
120 ebf38064 Iustin Pop
     [ ("ops", [t| [[OpCode]] |], [| id |]) ]
121 ebf38064 Iustin Pop
    )
122 ebf38064 Iustin Pop
  , ("WaitForJobChange",
123 ebf38064 Iustin Pop
     [ ("job",      [t| Int     |], [| id |])
124 ebf38064 Iustin Pop
     , ("fields",   [t| [String]|], [| id |])
125 ebf38064 Iustin Pop
     , ("prev_job", [t| JSValue |], [| id |])
126 ebf38064 Iustin Pop
     , ("prev_log", [t| JSValue |], [| id |])
127 ebf38064 Iustin Pop
     , ("tmout",    [t| Int     |], [| id |])
128 ebf38064 Iustin Pop
     ])
129 ebf38064 Iustin Pop
  , ("ArchiveJob",
130 ebf38064 Iustin Pop
     [ ("job", [t| Int |], [| show |]) ]
131 ebf38064 Iustin Pop
    )
132 ebf38064 Iustin Pop
  , ("AutoArchiveJobs",
133 ebf38064 Iustin Pop
     [ ("age",   [t| Int |], [| id |])
134 ebf38064 Iustin Pop
     , ("tmout", [t| Int |], [| id |])
135 ebf38064 Iustin Pop
     ])
136 ebf38064 Iustin Pop
  , ("CancelJob",
137 ebf38064 Iustin Pop
     [ ("job", [t| Int |], [| show |]) ]
138 ebf38064 Iustin Pop
    )
139 ebf38064 Iustin Pop
  , ("SetDrainFlag",
140 ebf38064 Iustin Pop
     [ ("flag", [t| Bool |], [| id |]) ]
141 ebf38064 Iustin Pop
    )
142 ebf38064 Iustin Pop
  , ("SetWatcherPause",
143 ebf38064 Iustin Pop
     [ ("duration", [t| Double |], [| id |]) ]
144 ebf38064 Iustin Pop
    )
145 a0090487 Agata Murawska
  ])
146 6583e677 Iustin Pop
147 6583e677 Iustin Pop
-- | The serialisation of LuxiOps into strings in messages.
148 a0090487 Agata Murawska
$(genStrOfOp ''LuxiOp "strOfOp")
149 6583e677 Iustin Pop
150 260d0bda Agata Murawska
$(declareIADT "ResultStatus"
151 ebf38064 Iustin Pop
  [ ("RSNormal", 'rsNormal)
152 ebf38064 Iustin Pop
  , ("RSUnknown", 'rsUnknown)
153 ebf38064 Iustin Pop
  , ("RSNoData", 'rsNodata)
154 ebf38064 Iustin Pop
  , ("RSUnavailable", 'rsUnavail)
155 ebf38064 Iustin Pop
  , ("RSOffline", 'rsOffline)
156 ebf38064 Iustin Pop
  ])
157 5f828ce4 Agata Murawska
158 5f828ce4 Agata Murawska
$(makeJSONInstance ''ResultStatus)
159 260d0bda Agata Murawska
160 260d0bda Agata Murawska
-- | Check that ResultStatus is success or fail with descriptive message.
161 260d0bda Agata Murawska
checkRS :: (Monad m) => ResultStatus -> a -> m a
162 260d0bda Agata Murawska
checkRS RSNormal val    = return val
163 260d0bda Agata Murawska
checkRS RSUnknown _     = fail "Unknown field"
164 260d0bda Agata Murawska
checkRS RSNoData _      = fail "No data for a field"
165 260d0bda Agata Murawska
checkRS RSUnavailable _ = fail "Ganeti reports unavailable data"
166 260d0bda Agata Murawska
checkRS RSOffline _     = fail "Ganeti reports resource as offline"
167 260d0bda Agata Murawska
168 6583e677 Iustin Pop
-- | The end-of-message separator.
169 6583e677 Iustin Pop
eOM :: Char
170 6583e677 Iustin Pop
eOM = '\3'
171 6583e677 Iustin Pop
172 6583e677 Iustin Pop
-- | Valid keys in the requests and responses.
173 6583e677 Iustin Pop
data MsgKeys = Method
174 6583e677 Iustin Pop
             | Args
175 6583e677 Iustin Pop
             | Success
176 6583e677 Iustin Pop
             | Result
177 6583e677 Iustin Pop
178 6583e677 Iustin Pop
-- | The serialisation of MsgKeys into strings in messages.
179 a0090487 Agata Murawska
$(genStrOfKey ''MsgKeys "strOfKey")
180 6583e677 Iustin Pop
181 6583e677 Iustin Pop
-- | Luxi client encapsulation.
182 6583e677 Iustin Pop
data Client = Client { socket :: S.Socket   -- ^ The socket of the client
183 6583e677 Iustin Pop
                     , rbuf :: IORef String -- ^ Already received buffer
184 6583e677 Iustin Pop
                     }
185 6583e677 Iustin Pop
186 6583e677 Iustin Pop
-- | Connects to the master daemon and returns a luxi Client.
187 6583e677 Iustin Pop
getClient :: String -> IO Client
188 6583e677 Iustin Pop
getClient path = do
189 ebf38064 Iustin Pop
  s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
190 ebf38064 Iustin Pop
  withTimeout connTimeout "creating luxi connection" $
191 ebf38064 Iustin Pop
              S.connect s (S.SockAddrUnix path)
192 ebf38064 Iustin Pop
  rf <- newIORef ""
193 ebf38064 Iustin Pop
  return Client { socket=s, rbuf=rf}
194 6583e677 Iustin Pop
195 6583e677 Iustin Pop
-- | Closes the client socket.
196 6583e677 Iustin Pop
closeClient :: Client -> IO ()
197 6583e677 Iustin Pop
closeClient = S.sClose . socket
198 6583e677 Iustin Pop
199 6583e677 Iustin Pop
-- | Sends a message over a luxi transport.
200 6583e677 Iustin Pop
sendMsg :: Client -> String -> IO ()
201 6583e677 Iustin Pop
sendMsg s buf =
202 ebf38064 Iustin Pop
  let _send obuf = do
203 ebf38064 Iustin Pop
        sbytes <- withTimeout queryTimeout
204 ebf38064 Iustin Pop
                  "sending luxi message" $
205 ebf38064 Iustin Pop
                  S.send (socket s) obuf
206 ebf38064 Iustin Pop
        unless (sbytes == length obuf) $ _send (drop sbytes obuf)
207 ebf38064 Iustin Pop
  in _send (buf ++ [eOM])
208 6583e677 Iustin Pop
209 6583e677 Iustin Pop
-- | Waits for a message over a luxi transport.
210 6583e677 Iustin Pop
recvMsg :: Client -> IO String
211 6583e677 Iustin Pop
recvMsg s = do
212 6583e677 Iustin Pop
  let _recv obuf = do
213 6583e677 Iustin Pop
              nbuf <- withTimeout queryTimeout "reading luxi response" $
214 6583e677 Iustin Pop
                      S.recv (socket s) 4096
215 95f490de Iustin Pop
              let (msg, remaining) = break (eOM ==) nbuf
216 3603605a Iustin Pop
              if null remaining
217 3603605a Iustin Pop
                then _recv (obuf ++ msg)
218 3603605a Iustin Pop
                else return (obuf ++ msg, tail remaining)
219 6583e677 Iustin Pop
  cbuf <- readIORef $ rbuf s
220 95f490de Iustin Pop
  let (imsg, ibuf) = break (eOM ==) cbuf
221 95f490de Iustin Pop
  (msg, nbuf) <-
222 3603605a Iustin Pop
    if null ibuf      -- if old buffer didn't contain a full message
223 3603605a Iustin Pop
      then _recv cbuf   -- then we read from network
224 3603605a Iustin Pop
      else return (imsg, tail ibuf) -- else we return data from our buffer
225 6583e677 Iustin Pop
  writeIORef (rbuf s) nbuf
226 6583e677 Iustin Pop
  return msg
227 6583e677 Iustin Pop
228 6583e677 Iustin Pop
-- | Serialize a request to String.
229 6583e677 Iustin Pop
buildCall :: LuxiOp  -- ^ The method
230 6583e677 Iustin Pop
          -> String  -- ^ The serialized form
231 683b1ca7 Iustin Pop
buildCall lo =
232 ebf38064 Iustin Pop
  let ja = [ (strOfKey Method, JSString $ toJSString $ strOfOp lo::JSValue)
233 ebf38064 Iustin Pop
           , (strOfKey Args, opToArgs lo::JSValue)
234 ebf38064 Iustin Pop
           ]
235 ebf38064 Iustin Pop
      jo = toJSObject ja
236 ebf38064 Iustin Pop
  in encodeStrict jo
237 6583e677 Iustin Pop
238 6583e677 Iustin Pop
-- | Check that luxi responses contain the required keys and that the
239 6583e677 Iustin Pop
-- call was successful.
240 6583e677 Iustin Pop
validateResult :: String -> Result JSValue
241 6583e677 Iustin Pop
validateResult s = do
242 c96d44df Iustin Pop
  oarr <- fromJResult "Parsing LUXI response"
243 c96d44df Iustin Pop
          (decodeStrict s)::Result (JSObject JSValue)
244 262f3e6c Iustin Pop
  let arr = J.fromJSObject oarr
245 e8230242 Iustin Pop
  status <- fromObj arr (strOfKey Success)::Result Bool
246 6583e677 Iustin Pop
  let rkey = strOfKey Result
247 3603605a Iustin Pop
  if status
248 3603605a Iustin Pop
    then fromObj arr rkey
249 3603605a Iustin Pop
    else fromObj arr rkey >>= fail
250 6583e677 Iustin Pop
251 6583e677 Iustin Pop
-- | Generic luxi method call.
252 683b1ca7 Iustin Pop
callMethod :: LuxiOp -> Client -> IO (Result JSValue)
253 683b1ca7 Iustin Pop
callMethod method s = do
254 683b1ca7 Iustin Pop
  sendMsg s $ buildCall method
255 6583e677 Iustin Pop
  result <- recvMsg s
256 6583e677 Iustin Pop
  let rval = validateResult result
257 6583e677 Iustin Pop
  return rval
258 9a2ff880 Iustin Pop
259 9a2ff880 Iustin Pop
-- | Specialized submitManyJobs call.
260 683b1ca7 Iustin Pop
submitManyJobs :: Client -> [[OpCode]] -> IO (Result [String])
261 9a2ff880 Iustin Pop
submitManyJobs s jobs = do
262 683b1ca7 Iustin Pop
  rval <- callMethod (SubmitManyJobs jobs) s
263 9a2ff880 Iustin Pop
  -- map each result (status, payload) pair into a nice Result ADT
264 9a2ff880 Iustin Pop
  return $ case rval of
265 9a2ff880 Iustin Pop
             Bad x -> Bad x
266 9a2ff880 Iustin Pop
             Ok (JSArray r) ->
267 9a2ff880 Iustin Pop
                 mapM (\v -> case v of
268 9a2ff880 Iustin Pop
                               JSArray [JSBool True, JSString x] ->
269 9a2ff880 Iustin Pop
                                   Ok (fromJSString x)
270 9a2ff880 Iustin Pop
                               JSArray [JSBool False, JSString x] ->
271 9a2ff880 Iustin Pop
                                   Bad (fromJSString x)
272 9a2ff880 Iustin Pop
                               _ -> Bad "Unknown result from the master daemon"
273 9a2ff880 Iustin Pop
                      ) r
274 9a2ff880 Iustin Pop
             x -> Bad ("Cannot parse response from Ganeti: " ++ show x)
275 9a2ff880 Iustin Pop
276 9a2ff880 Iustin Pop
-- | Custom queryJobs call.
277 9a2ff880 Iustin Pop
queryJobsStatus :: Client -> [String] -> IO (Result [JobStatus])
278 9a2ff880 Iustin Pop
queryJobsStatus s jids = do
279 683b1ca7 Iustin Pop
  rval <- callMethod (QueryJobs (map read jids) ["status"]) s
280 9a2ff880 Iustin Pop
  return $ case rval of
281 9a2ff880 Iustin Pop
             Bad x -> Bad x
282 9a2ff880 Iustin Pop
             Ok y -> case J.readJSON y::(J.Result [[JobStatus]]) of
283 9a2ff880 Iustin Pop
                       J.Ok vals -> if any null vals
284 9a2ff880 Iustin Pop
                                    then Bad "Missing job status field"
285 9a2ff880 Iustin Pop
                                    else Ok (map head vals)
286 9a2ff880 Iustin Pop
                       J.Error x -> Bad x