Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / Luxi.hs @ e85444d0

History | View | Annotate | Download (8.7 kB)

1
{-# LANGUAGE TemplateHaskell #-}
2

    
3
{-| Implementation of the Ganeti LUXI interface.
4

    
5
-}
6

    
7
{-
8

    
9
Copyright (C) 2009, 2010, 2011 Google Inc.
10

    
11
This program is free software; you can redistribute it and/or modify
12
it under the terms of the GNU General Public License as published by
13
the Free Software Foundation; either version 2 of the License, or
14
(at your option) any later version.
15

    
16
This program is distributed in the hope that it will be useful, but
17
WITHOUT ANY WARRANTY; without even the implied warranty of
18
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
19
General Public License for more details.
20

    
21
You should have received a copy of the GNU General Public License
22
along with this program; if not, write to the Free Software
23
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
24
02110-1301, USA.
25

    
26
-}
27

    
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
40

    
41
import Data.IORef
42
import Control.Monad
43
import Text.JSON (encodeStrict, decodeStrict)
44
import qualified Text.JSON as J
45
import Text.JSON.Types
46
import System.Timeout
47
import qualified Network.Socket as S
48

    
49
import Ganeti.HTools.JSON
50
import Ganeti.HTools.Types
51

    
52
import Ganeti.Constants
53
import Ganeti.Jobs (JobStatus)
54
import Ganeti.OpCodes (OpCode)
55
import Ganeti.THH
56

    
57
-- * Utility functions
58

    
59
-- | Wrapper over System.Timeout.timeout that fails in the IO monad.
60
withTimeout :: Int -> String -> IO a -> IO a
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
66

    
67
-- * Generic protocol functionality
68

    
69
$(declareSADT "QrViaLuxi"
70
  [ ("QRLock", 'qrLock)
71
  , ("QRInstance", 'qrInstance)
72
  , ("QRNode", 'qrNode)
73
  , ("QRGroup", 'qrGroup)
74
  , ("QROs", 'qrOs)
75
  ])
76
$(makeJSONInstance ''QrViaLuxi)
77

    
78
-- | Currently supported Luxi operations and JSON serialization.
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
    )
145
  ])
146

    
147
-- | The serialisation of LuxiOps into strings in messages.
148
$(genStrOfOp ''LuxiOp "strOfOp")
149

    
150
$(declareIADT "ResultStatus"
151
  [ ("RSNormal", 'rsNormal)
152
  , ("RSUnknown", 'rsUnknown)
153
  , ("RSNoData", 'rsNodata)
154
  , ("RSUnavailable", 'rsUnavail)
155
  , ("RSOffline", 'rsOffline)
156
  ])
157

    
158
$(makeJSONInstance ''ResultStatus)
159

    
160
-- | Check that ResultStatus is success or fail with descriptive message.
161
checkRS :: (Monad m) => ResultStatus -> a -> m a
162
checkRS RSNormal val    = return val
163
checkRS RSUnknown _     = fail "Unknown field"
164
checkRS RSNoData _      = fail "No data for a field"
165
checkRS RSUnavailable _ = fail "Ganeti reports unavailable data"
166
checkRS RSOffline _     = fail "Ganeti reports resource as offline"
167

    
168
-- | The end-of-message separator.
169
eOM :: Char
170
eOM = '\3'
171

    
172
-- | Valid keys in the requests and responses.
173
data MsgKeys = Method
174
             | Args
175
             | Success
176
             | Result
177

    
178
-- | The serialisation of MsgKeys into strings in messages.
179
$(genStrOfKey ''MsgKeys "strOfKey")
180

    
181
-- | Luxi client encapsulation.
182
data Client = Client { socket :: S.Socket   -- ^ The socket of the client
183
                     , rbuf :: IORef String -- ^ Already received buffer
184
                     }
185

    
186
-- | Connects to the master daemon and returns a luxi Client.
187
getClient :: String -> IO Client
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}
194

    
195
-- | Closes the client socket.
196
closeClient :: Client -> IO ()
197
closeClient = S.sClose . socket
198

    
199
-- | Sends a message over a luxi transport.
200
sendMsg :: Client -> String -> IO ()
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])
208

    
209
-- | Waits for a message over a luxi transport.
210
recvMsg :: Client -> IO String
211
recvMsg s = do
212
  let _recv obuf = do
213
              nbuf <- withTimeout queryTimeout "reading luxi response" $
214
                      S.recv (socket s) 4096
215
              let (msg, remaining) = break (eOM ==) nbuf
216
              if null remaining
217
                then _recv (obuf ++ msg)
218
                else return (obuf ++ msg, tail remaining)
219
  cbuf <- readIORef $ rbuf s
220
  let (imsg, ibuf) = break (eOM ==) cbuf
221
  (msg, nbuf) <-
222
    if null ibuf      -- if old buffer didn't contain a full message
223
      then _recv cbuf   -- then we read from network
224
      else return (imsg, tail ibuf) -- else we return data from our buffer
225
  writeIORef (rbuf s) nbuf
226
  return msg
227

    
228
-- | Serialize a request to String.
229
buildCall :: LuxiOp  -- ^ The method
230
          -> String  -- ^ The serialized form
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
237

    
238
-- | Check that luxi responses contain the required keys and that the
239
-- call was successful.
240
validateResult :: String -> Result JSValue
241
validateResult s = do
242
  oarr <- fromJResult "Parsing LUXI response"
243
          (decodeStrict s)::Result (JSObject JSValue)
244
  let arr = J.fromJSObject oarr
245
  status <- fromObj arr (strOfKey Success)::Result Bool
246
  let rkey = strOfKey Result
247
  if status
248
    then fromObj arr rkey
249
    else fromObj arr rkey >>= fail
250

    
251
-- | Generic luxi method call.
252
callMethod :: LuxiOp -> Client -> IO (Result JSValue)
253
callMethod method s = do
254
  sendMsg s $ buildCall method
255
  result <- recvMsg s
256
  let rval = validateResult result
257
  return rval
258

    
259
-- | Specialized submitManyJobs call.
260
submitManyJobs :: Client -> [[OpCode]] -> IO (Result [String])
261
submitManyJobs s jobs = do
262
  rval <- callMethod (SubmitManyJobs jobs) s
263
  -- map each result (status, payload) pair into a nice Result ADT
264
  return $ case rval of
265
             Bad x -> Bad x
266
             Ok (JSArray r) ->
267
                 mapM (\v -> case v of
268
                               JSArray [JSBool True, JSString x] ->
269
                                   Ok (fromJSString x)
270
                               JSArray [JSBool False, JSString x] ->
271
                                   Bad (fromJSString x)
272
                               _ -> Bad "Unknown result from the master daemon"
273
                      ) r
274
             x -> Bad ("Cannot parse response from Ganeti: " ++ show x)
275

    
276
-- | Custom queryJobs call.
277
queryJobsStatus :: Client -> [String] -> IO (Result [JobStatus])
278
queryJobsStatus s jids = do
279
  rval <- callMethod (QueryJobs (map read jids) ["status"]) s
280
  return $ case rval of
281
             Bad x -> Bad x
282
             Ok y -> case J.readJSON y::(J.Result [[JobStatus]]) of
283
                       J.Ok vals -> if any null vals
284
                                    then Bad "Missing job status field"
285
                                    else Ok (map head vals)
286
                       J.Error x -> Bad x