Statistics
| Branch: | Tag: | Revision:

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

History | View | Annotate | Download (8.8 kB)

1
{-# LANGUAGE TemplateHaskell #-}
2

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

    
5
-}
6

    
7
{-
8

    
9
Copyright (C) 2009, 2010, 2011, 2012 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
  , LuxiReq(..)
33
  , Client
34
  , checkRS
35
  , getClient
36
  , closeClient
37
  , callMethod
38
  , submitManyJobs
39
  , queryJobsStatus
40
  ) where
41

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

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

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

    
58
-- * Utility functions
59

    
60
-- | Wrapper over System.Timeout.timeout that fails in the IO monad.
61
withTimeout :: Int -> String -> IO a -> IO a
62
withTimeout secs descr action = do
63
  result <- timeout (secs * 1000000) action
64
  case result of
65
    Nothing -> fail $ "Timeout in " ++ descr
66
    Just v -> return v
67

    
68
-- * Generic protocol functionality
69

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

    
79
-- | Currently supported Luxi operations and JSON serialization.
80
$(genLuxiOp "LuxiOp"
81
  [(luxiReqQuery,
82
    [ ("what",    [t| QrViaLuxi |], [| id |])
83
    , ("fields",  [t| [String]  |], [| id |])
84
    , ("qfilter", [t| ()        |], [| const JSNull |])
85
    ])
86
  , (luxiReqQueryNodes,
87
     [ ("names",  [t| [String] |], [| id |])
88
     , ("fields", [t| [String] |], [| id |])
89
     , ("lock",   [t| Bool     |], [| id |])
90
     ])
91
  , (luxiReqQueryGroups,
92
     [ ("names",  [t| [String] |], [| id |])
93
     , ("fields", [t| [String] |], [| id |])
94
     , ("lock",   [t| Bool     |], [| id |])
95
     ])
96
  , (luxiReqQueryInstances,
97
     [ ("names",  [t| [String] |], [| id |])
98
     , ("fields", [t| [String] |], [| id |])
99
     , ("lock",   [t| Bool     |], [| id |])
100
     ])
101
  , (luxiReqQueryJobs,
102
     [ ("ids",    [t| [Int]    |], [| map show |])
103
     , ("fields", [t| [String] |], [| id |])
104
     ])
105
  , (luxiReqQueryExports,
106
     [ ("nodes", [t| [String] |], [| id |])
107
     , ("lock",  [t| Bool     |], [| id |])
108
     ])
109
  , (luxiReqQueryConfigValues,
110
     [ ("fields", [t| [String] |], [| id |]) ]
111
    )
112
  , (luxiReqQueryClusterInfo, [])
113
  , (luxiReqQueryTags,
114
     [ ("kind", [t| String |], [| id |])
115
     , ("name", [t| String |], [| id |])
116
     ])
117
  , (luxiReqSubmitJob,
118
     [ ("job", [t| [OpCode] |], [| id |]) ]
119
    )
120
  , (luxiReqSubmitManyJobs,
121
     [ ("ops", [t| [[OpCode]] |], [| id |]) ]
122
    )
123
  , (luxiReqWaitForJobChange,
124
     [ ("job",      [t| Int     |], [| id |])
125
     , ("fields",   [t| [String]|], [| id |])
126
     , ("prev_job", [t| JSValue |], [| id |])
127
     , ("prev_log", [t| JSValue |], [| id |])
128
     , ("tmout",    [t| Int     |], [| id |])
129
     ])
130
  , (luxiReqArchiveJob,
131
     [ ("job", [t| Int |], [| show |]) ]
132
    )
133
  , (luxiReqAutoArchiveJobs,
134
     [ ("age",   [t| Int |], [| id |])
135
     , ("tmout", [t| Int |], [| id |])
136
     ])
137
  , (luxiReqCancelJob,
138
     [ ("job", [t| Int |], [| show |]) ]
139
    )
140
  , (luxiReqSetDrainFlag,
141
     [ ("flag", [t| Bool |], [| id |]) ]
142
    )
143
  , (luxiReqSetWatcherPause,
144
     [ ("duration", [t| Double |], [| id |]) ]
145
    )
146
  ])
147

    
148
$(makeJSONInstance ''LuxiReq)
149

    
150
-- | The serialisation of LuxiOps into strings in messages.
151
$(genStrOfOp ''LuxiOp "strOfOp")
152

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

    
161
$(makeJSONInstance ''ResultStatus)
162

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

    
171
-- | The end-of-message separator.
172
eOM :: Char
173
eOM = '\3'
174

    
175
-- | Valid keys in the requests and responses.
176
data MsgKeys = Method
177
             | Args
178
             | Success
179
             | Result
180

    
181
-- | The serialisation of MsgKeys into strings in messages.
182
$(genStrOfKey ''MsgKeys "strOfKey")
183

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

    
189
-- | Connects to the master daemon and returns a luxi Client.
190
getClient :: String -> IO Client
191
getClient path = do
192
  s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
193
  withTimeout connTimeout "creating luxi connection" $
194
              S.connect s (S.SockAddrUnix path)
195
  rf <- newIORef ""
196
  return Client { socket=s, rbuf=rf}
197

    
198
-- | Closes the client socket.
199
closeClient :: Client -> IO ()
200
closeClient = S.sClose . socket
201

    
202
-- | Sends a message over a luxi transport.
203
sendMsg :: Client -> String -> IO ()
204
sendMsg s buf =
205
  let _send obuf = do
206
        sbytes <- withTimeout queryTimeout
207
                  "sending luxi message" $
208
                  S.send (socket s) obuf
209
        unless (sbytes == length obuf) $ _send (drop sbytes obuf)
210
  in _send (buf ++ [eOM])
211

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

    
231
-- | Serialize a request to String.
232
buildCall :: LuxiOp  -- ^ The method
233
          -> String  -- ^ The serialized form
234
buildCall lo =
235
  let ja = [ (strOfKey Method, JSString $ toJSString $ strOfOp lo::JSValue)
236
           , (strOfKey Args, opToArgs lo::JSValue)
237
           ]
238
      jo = toJSObject ja
239
  in encodeStrict jo
240

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

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

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

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