Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / Luxi.hs @ 519edd9f

History | View | Annotate | Download (8.6 kB)

1
{-| Implementation of the Ganeti LUXI interface.
2

    
3
-}
4

    
5
{-
6

    
7
Copyright (C) 2009, 2010, 2011 Google Inc.
8

    
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.
13

    
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.
18

    
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
22
02110-1301, USA.
23

    
24
-}
25

    
26
module Ganeti.Luxi
27
    ( LuxiOp(..)
28
    , Client
29
    , getClient
30
    , closeClient
31
    , callMethod
32
    , submitManyJobs
33
    , queryJobsStatus
34
    ) where
35

    
36
import Data.IORef
37
import Control.Monad
38
import Text.JSON (encodeStrict, decodeStrict)
39
import qualified Text.JSON as J
40
import Text.JSON.Types
41
import System.Timeout
42
import qualified Network.Socket as S
43

    
44
import Ganeti.HTools.Utils
45
import Ganeti.HTools.Types
46

    
47
import Ganeti.Jobs (JobStatus)
48
import Ganeti.OpCodes (OpCode)
49

    
50
-- * Utility functions
51

    
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
56
    (case result of
57
       Nothing -> fail $ "Timeout in " ++ descr
58
       Just v -> return v)
59

    
60
-- * Generic protocol functionality
61

    
62
-- | Currently supported Luxi operations.
63
data LuxiOp = QueryInstances [String] [String] Bool
64
            | QueryNodes [String] [String] Bool
65
            | QueryGroups [String] [String] Bool
66
            | QueryJobs [Int] [String]
67
            | QueryExports [String] Bool
68
            | QueryConfigValues [String]
69
            | QueryClusterInfo
70
            | QueryTags String String
71
            | SubmitJob [OpCode]
72
            | SubmitManyJobs [[OpCode]]
73
            | WaitForJobChange Int [String] JSValue JSValue Int
74
            | ArchiveJob Int
75
            | AutoArchiveJobs Int Int
76
            | CancelJob Int
77
            | SetDrainFlag Bool
78
            | SetWatcherPause Double
79
              deriving (Show, Read)
80

    
81
-- | The serialisation of LuxiOps into strings in messages.
82
strOfOp :: LuxiOp -> String
83
strOfOp QueryNodes {}        = "QueryNodes"
84
strOfOp QueryGroups {}       = "QueryGroups"
85
strOfOp QueryInstances {}    = "QueryInstances"
86
strOfOp QueryJobs {}         = "QueryJobs"
87
strOfOp QueryExports {}      = "QueryExports"
88
strOfOp QueryConfigValues {} = "QueryConfigValues"
89
strOfOp QueryClusterInfo {}  = "QueryClusterInfo"
90
strOfOp QueryTags {}         = "QueryTags"
91
strOfOp SubmitManyJobs {}    = "SubmitManyJobs"
92
strOfOp WaitForJobChange {}  = "WaitForJobChange"
93
strOfOp SubmitJob {}         = "SubmitJob"
94
strOfOp ArchiveJob {}        = "ArchiveJob"
95
strOfOp AutoArchiveJobs {}   = "AutoArchiveJobs"
96
strOfOp CancelJob {}         = "CancelJob"
97
strOfOp SetDrainFlag {}      = "SetDrainFlag"
98
strOfOp SetWatcherPause {}   = "SetWatcherPause"
99

    
100
-- | The end-of-message separator.
101
eOM :: Char
102
eOM = '\3'
103

    
104
-- | Valid keys in the requests and responses.
105
data MsgKeys = Method
106
             | Args
107
             | Success
108
             | Result
109

    
110
-- | The serialisation of MsgKeys into strings in messages.
111
strOfKey :: MsgKeys -> String
112
strOfKey Method = "method"
113
strOfKey Args = "args"
114
strOfKey Success = "success"
115
strOfKey Result = "result"
116

    
117
-- | Luxi client encapsulation.
118
data Client = Client { socket :: S.Socket   -- ^ The socket of the client
119
                     , rbuf :: IORef String -- ^ Already received buffer
120
                     }
121

    
122
-- | Connects to the master daemon and returns a luxi Client.
123
getClient :: String -> IO Client
124
getClient path = do
125
    s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
126
    withTimeout connTimeout "creating luxi connection" $
127
                S.connect s (S.SockAddrUnix path)
128
    rf <- newIORef ""
129
    return Client { socket=s, rbuf=rf}
130

    
131
-- | Closes the client socket.
132
closeClient :: Client -> IO ()
133
closeClient = S.sClose . socket
134

    
135
-- | Sends a message over a luxi transport.
136
sendMsg :: Client -> String -> IO ()
137
sendMsg s buf =
138
    let _send obuf = do
139
          sbytes <- withTimeout queryTimeout
140
                    "sending luxi message" $
141
                    S.send (socket s) obuf
142
          unless (sbytes == length obuf) $ _send (drop sbytes obuf)
143
    in _send (buf ++ [eOM])
144

    
145
-- | Waits for a message over a luxi transport.
146
recvMsg :: Client -> IO String
147
recvMsg s = do
148
  let _recv obuf = do
149
              nbuf <- withTimeout queryTimeout "reading luxi response" $
150
                      S.recv (socket s) 4096
151
              let (msg, remaining) = break (eOM ==) nbuf
152
              (if null remaining
153
               then _recv (obuf ++ msg)
154
               else return (obuf ++ msg, tail remaining))
155
  cbuf <- readIORef $ rbuf s
156
  let (imsg, ibuf) = break (eOM ==) cbuf
157
  (msg, nbuf) <-
158
      (if null ibuf      -- if old buffer didn't contain a full message
159
       then _recv cbuf   -- then we read from network
160
       else return (imsg, tail ibuf)) -- else we return data from our buffer
161
  writeIORef (rbuf s) nbuf
162
  return msg
163

    
164
-- | Compute the serialized form of a Luxi operation.
165
opToArgs :: LuxiOp -> JSValue
166
opToArgs (QueryNodes names fields lock) = J.showJSON (names, fields, lock)
167
opToArgs (QueryGroups names fields lock) = J.showJSON (names, fields, lock)
168
opToArgs (QueryInstances names fields lock) = J.showJSON (names, fields, lock)
169
opToArgs (QueryJobs ids fields) = J.showJSON (map show ids, fields)
170
opToArgs (QueryExports nodes lock) = J.showJSON (nodes, lock)
171
opToArgs (QueryConfigValues fields) = J.showJSON fields
172
opToArgs (QueryClusterInfo) = J.showJSON ()
173
opToArgs (QueryTags kind name) =  J.showJSON (kind, name)
174
opToArgs (SubmitJob j) = J.showJSON j
175
opToArgs (SubmitManyJobs ops) = J.showJSON ops
176
-- This is special, since the JSON library doesn't export an instance
177
-- of a 5-tuple
178
opToArgs (WaitForJobChange a b c d e) =
179
    JSArray [ J.showJSON a, J.showJSON b, J.showJSON c
180
            , J.showJSON d, J.showJSON e]
181
opToArgs (ArchiveJob a) = J.showJSON (show a)
182
opToArgs (AutoArchiveJobs a b) = J.showJSON (a, b)
183
opToArgs (CancelJob a) = J.showJSON (show a)
184
opToArgs (SetDrainFlag flag) = J.showJSON flag
185
opToArgs (SetWatcherPause duration) = J.showJSON [duration]
186

    
187
-- | Serialize a request to String.
188
buildCall :: LuxiOp  -- ^ The method
189
          -> String  -- ^ The serialized form
190
buildCall lo =
191
    let ja = [ (strOfKey Method, JSString $ toJSString $ strOfOp lo::JSValue)
192
             , (strOfKey Args, opToArgs lo::JSValue)
193
             ]
194
        jo = toJSObject ja
195
    in encodeStrict jo
196

    
197
-- | Check that luxi responses contain the required keys and that the
198
-- call was successful.
199
validateResult :: String -> Result JSValue
200
validateResult s = do
201
  oarr <- fromJResult "Parsing LUXI response"
202
          (decodeStrict s)::Result (JSObject JSValue)
203
  let arr = J.fromJSObject oarr
204
  status <- fromObj arr (strOfKey Success)::Result Bool
205
  let rkey = strOfKey Result
206
  (if status
207
   then fromObj arr rkey
208
   else fromObj arr rkey >>= fail)
209

    
210
-- | Generic luxi method call.
211
callMethod :: LuxiOp -> Client -> IO (Result JSValue)
212
callMethod method s = do
213
  sendMsg s $ buildCall method
214
  result <- recvMsg s
215
  let rval = validateResult result
216
  return rval
217

    
218
-- | Specialized submitManyJobs call.
219
submitManyJobs :: Client -> [[OpCode]] -> IO (Result [String])
220
submitManyJobs s jobs = do
221
  rval <- callMethod (SubmitManyJobs jobs) s
222
  -- map each result (status, payload) pair into a nice Result ADT
223
  return $ case rval of
224
             Bad x -> Bad x
225
             Ok (JSArray r) ->
226
                 mapM (\v -> case v of
227
                               JSArray [JSBool True, JSString x] ->
228
                                   Ok (fromJSString x)
229
                               JSArray [JSBool False, JSString x] ->
230
                                   Bad (fromJSString x)
231
                               _ -> Bad "Unknown result from the master daemon"
232
                      ) r
233
             x -> Bad ("Cannot parse response from Ganeti: " ++ show x)
234

    
235
-- | Custom queryJobs call.
236
queryJobsStatus :: Client -> [String] -> IO (Result [JobStatus])
237
queryJobsStatus s jids = do
238
  rval <- callMethod (QueryJobs (map read jids) ["status"]) s
239
  return $ case rval of
240
             Bad x -> Bad x
241
             Ok y -> case J.readJSON y::(J.Result [[JobStatus]]) of
242
                       J.Ok vals -> if any null vals
243
                                    then Bad "Missing job status field"
244
                                    else Ok (map head vals)
245
                       J.Error x -> Bad x