Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / Luxi.hs @ 97936d51

History | View | Annotate | Download (8.6 kB)

1 6583e677 Iustin Pop
{-| Implementation of the Ganeti LUXI interface.
2 6583e677 Iustin Pop
3 6583e677 Iustin Pop
-}
4 6583e677 Iustin Pop
5 6583e677 Iustin Pop
{-
6 6583e677 Iustin Pop
7 e8230242 Iustin Pop
Copyright (C) 2009, 2010, 2011 Google Inc.
8 6583e677 Iustin Pop
9 6583e677 Iustin Pop
This program is free software; you can redistribute it and/or modify
10 6583e677 Iustin Pop
it under the terms of the GNU General Public License as published by
11 6583e677 Iustin Pop
the Free Software Foundation; either version 2 of the License, or
12 6583e677 Iustin Pop
(at your option) any later version.
13 6583e677 Iustin Pop
14 6583e677 Iustin Pop
This program is distributed in the hope that it will be useful, but
15 6583e677 Iustin Pop
WITHOUT ANY WARRANTY; without even the implied warranty of
16 6583e677 Iustin Pop
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
17 6583e677 Iustin Pop
General Public License for more details.
18 6583e677 Iustin Pop
19 6583e677 Iustin Pop
You should have received a copy of the GNU General Public License
20 6583e677 Iustin Pop
along with this program; if not, write to the Free Software
21 6583e677 Iustin Pop
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
22 6583e677 Iustin Pop
02110-1301, USA.
23 6583e677 Iustin Pop
24 6583e677 Iustin Pop
-}
25 6583e677 Iustin Pop
26 6583e677 Iustin Pop
module Ganeti.Luxi
27 6583e677 Iustin Pop
    ( LuxiOp(..)
28 6583e677 Iustin Pop
    , Client
29 6583e677 Iustin Pop
    , getClient
30 6583e677 Iustin Pop
    , closeClient
31 6583e677 Iustin Pop
    , callMethod
32 9a2ff880 Iustin Pop
    , submitManyJobs
33 9a2ff880 Iustin Pop
    , queryJobsStatus
34 6583e677 Iustin Pop
    ) where
35 6583e677 Iustin Pop
36 6583e677 Iustin Pop
import Data.IORef
37 6583e677 Iustin Pop
import Control.Monad
38 0903280b Iustin Pop
import Text.JSON (encodeStrict, decodeStrict)
39 6583e677 Iustin Pop
import qualified Text.JSON as J
40 6583e677 Iustin Pop
import Text.JSON.Types
41 6583e677 Iustin Pop
import System.Timeout
42 6583e677 Iustin Pop
import qualified Network.Socket as S
43 6583e677 Iustin Pop
44 6583e677 Iustin Pop
import Ganeti.HTools.Utils
45 6583e677 Iustin Pop
import Ganeti.HTools.Types
46 6583e677 Iustin Pop
47 9a2ff880 Iustin Pop
import Ganeti.Jobs (JobStatus)
48 683b1ca7 Iustin Pop
import Ganeti.OpCodes (OpCode)
49 9a2ff880 Iustin Pop
50 6583e677 Iustin Pop
-- * Utility functions
51 6583e677 Iustin Pop
52 6583e677 Iustin Pop
-- | Wrapper over System.Timeout.timeout that fails in the IO monad.
53 6583e677 Iustin Pop
withTimeout :: Int -> String -> IO a -> IO a
54 6583e677 Iustin Pop
withTimeout secs descr action = do
55 6583e677 Iustin Pop
    result <- timeout (secs * 1000000) action
56 6583e677 Iustin Pop
    (case result of
57 6583e677 Iustin Pop
       Nothing -> fail $ "Timeout in " ++ descr
58 6583e677 Iustin Pop
       Just v -> return v)
59 6583e677 Iustin Pop
60 6583e677 Iustin Pop
-- * Generic protocol functionality
61 6583e677 Iustin Pop
62 6583e677 Iustin Pop
-- | Currently supported Luxi operations.
63 683b1ca7 Iustin Pop
data LuxiOp = QueryInstances [String] [String] Bool
64 683b1ca7 Iustin Pop
            | QueryNodes [String] [String] Bool
65 edd0a48f Iustin Pop
            | QueryGroups [String] [String] Bool
66 683b1ca7 Iustin Pop
            | QueryJobs [Int] [String]
67 04282772 Iustin Pop
            | QueryExports [String] Bool
68 04282772 Iustin Pop
            | QueryConfigValues [String]
69 f89235f1 Iustin Pop
            | QueryClusterInfo
70 04282772 Iustin Pop
            | QueryTags String String
71 9622919d Iustin Pop
            | SubmitJob [OpCode]
72 683b1ca7 Iustin Pop
            | SubmitManyJobs [[OpCode]]
73 9622919d Iustin Pop
            | WaitForJobChange Int [String] JSValue JSValue Int
74 9622919d Iustin Pop
            | ArchiveJob Int
75 9622919d Iustin Pop
            | AutoArchiveJobs Int Int
76 04282772 Iustin Pop
            | CancelJob Int
77 04282772 Iustin Pop
            | SetDrainFlag Bool
78 04282772 Iustin Pop
            | SetWatcherPause Double
79 6bc39970 Iustin Pop
              deriving (Show, Read)
80 6583e677 Iustin Pop
81 6583e677 Iustin Pop
-- | The serialisation of LuxiOps into strings in messages.
82 6583e677 Iustin Pop
strOfOp :: LuxiOp -> String
83 04282772 Iustin Pop
strOfOp QueryNodes {}        = "QueryNodes"
84 edd0a48f Iustin Pop
strOfOp QueryGroups {}       = "QueryGroups"
85 04282772 Iustin Pop
strOfOp QueryInstances {}    = "QueryInstances"
86 04282772 Iustin Pop
strOfOp QueryJobs {}         = "QueryJobs"
87 04282772 Iustin Pop
strOfOp QueryExports {}      = "QueryExports"
88 04282772 Iustin Pop
strOfOp QueryConfigValues {} = "QueryConfigValues"
89 04282772 Iustin Pop
strOfOp QueryClusterInfo {}  = "QueryClusterInfo"
90 04282772 Iustin Pop
strOfOp QueryTags {}         = "QueryTags"
91 04282772 Iustin Pop
strOfOp SubmitManyJobs {}    = "SubmitManyJobs"
92 04282772 Iustin Pop
strOfOp WaitForJobChange {}  = "WaitForJobChange"
93 04282772 Iustin Pop
strOfOp SubmitJob {}         = "SubmitJob"
94 04282772 Iustin Pop
strOfOp ArchiveJob {}        = "ArchiveJob"
95 04282772 Iustin Pop
strOfOp AutoArchiveJobs {}   = "AutoArchiveJobs"
96 04282772 Iustin Pop
strOfOp CancelJob {}         = "CancelJob"
97 04282772 Iustin Pop
strOfOp SetDrainFlag {}      = "SetDrainFlag"
98 04282772 Iustin Pop
strOfOp SetWatcherPause {}   = "SetWatcherPause"
99 6583e677 Iustin Pop
100 6583e677 Iustin Pop
-- | The end-of-message separator.
101 6583e677 Iustin Pop
eOM :: Char
102 6583e677 Iustin Pop
eOM = '\3'
103 6583e677 Iustin Pop
104 6583e677 Iustin Pop
-- | Valid keys in the requests and responses.
105 6583e677 Iustin Pop
data MsgKeys = Method
106 6583e677 Iustin Pop
             | Args
107 6583e677 Iustin Pop
             | Success
108 6583e677 Iustin Pop
             | Result
109 6583e677 Iustin Pop
110 6583e677 Iustin Pop
-- | The serialisation of MsgKeys into strings in messages.
111 6583e677 Iustin Pop
strOfKey :: MsgKeys -> String
112 6583e677 Iustin Pop
strOfKey Method = "method"
113 6583e677 Iustin Pop
strOfKey Args = "args"
114 6583e677 Iustin Pop
strOfKey Success = "success"
115 6583e677 Iustin Pop
strOfKey Result = "result"
116 6583e677 Iustin Pop
117 6583e677 Iustin Pop
-- | Luxi client encapsulation.
118 6583e677 Iustin Pop
data Client = Client { socket :: S.Socket   -- ^ The socket of the client
119 6583e677 Iustin Pop
                     , rbuf :: IORef String -- ^ Already received buffer
120 6583e677 Iustin Pop
                     }
121 6583e677 Iustin Pop
122 6583e677 Iustin Pop
-- | Connects to the master daemon and returns a luxi Client.
123 6583e677 Iustin Pop
getClient :: String -> IO Client
124 6583e677 Iustin Pop
getClient path = do
125 6583e677 Iustin Pop
    s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
126 6583e677 Iustin Pop
    withTimeout connTimeout "creating luxi connection" $
127 6583e677 Iustin Pop
                S.connect s (S.SockAddrUnix path)
128 6583e677 Iustin Pop
    rf <- newIORef ""
129 6583e677 Iustin Pop
    return Client { socket=s, rbuf=rf}
130 6583e677 Iustin Pop
131 6583e677 Iustin Pop
-- | Closes the client socket.
132 6583e677 Iustin Pop
closeClient :: Client -> IO ()
133 6583e677 Iustin Pop
closeClient = S.sClose . socket
134 6583e677 Iustin Pop
135 6583e677 Iustin Pop
-- | Sends a message over a luxi transport.
136 6583e677 Iustin Pop
sendMsg :: Client -> String -> IO ()
137 6583e677 Iustin Pop
sendMsg s buf =
138 6583e677 Iustin Pop
    let _send obuf = do
139 6583e677 Iustin Pop
          sbytes <- withTimeout queryTimeout
140 6583e677 Iustin Pop
                    "sending luxi message" $
141 6583e677 Iustin Pop
                    S.send (socket s) obuf
142 3a3c1eb4 Iustin Pop
          unless (sbytes == length obuf) $ _send (drop sbytes obuf)
143 6583e677 Iustin Pop
    in _send (buf ++ [eOM])
144 6583e677 Iustin Pop
145 6583e677 Iustin Pop
-- | Waits for a message over a luxi transport.
146 6583e677 Iustin Pop
recvMsg :: Client -> IO String
147 6583e677 Iustin Pop
recvMsg s = do
148 6583e677 Iustin Pop
  let _recv obuf = do
149 6583e677 Iustin Pop
              nbuf <- withTimeout queryTimeout "reading luxi response" $
150 6583e677 Iustin Pop
                      S.recv (socket s) 4096
151 95f490de Iustin Pop
              let (msg, remaining) = break (eOM ==) nbuf
152 6583e677 Iustin Pop
              (if null remaining
153 95f490de Iustin Pop
               then _recv (obuf ++ msg)
154 95f490de Iustin Pop
               else return (obuf ++ msg, tail remaining))
155 6583e677 Iustin Pop
  cbuf <- readIORef $ rbuf s
156 95f490de Iustin Pop
  let (imsg, ibuf) = break (eOM ==) cbuf
157 95f490de Iustin Pop
  (msg, nbuf) <-
158 95f490de Iustin Pop
      (if null ibuf      -- if old buffer didn't contain a full message
159 95f490de Iustin Pop
       then _recv cbuf   -- then we read from network
160 95f490de Iustin Pop
       else return (imsg, tail ibuf)) -- else we return data from our buffer
161 6583e677 Iustin Pop
  writeIORef (rbuf s) nbuf
162 6583e677 Iustin Pop
  return msg
163 6583e677 Iustin Pop
164 525bfb36 Iustin Pop
-- | Compute the serialized form of a Luxi operation.
165 683b1ca7 Iustin Pop
opToArgs :: LuxiOp -> JSValue
166 683b1ca7 Iustin Pop
opToArgs (QueryNodes names fields lock) = J.showJSON (names, fields, lock)
167 edd0a48f Iustin Pop
opToArgs (QueryGroups names fields lock) = J.showJSON (names, fields, lock)
168 04282772 Iustin Pop
opToArgs (QueryInstances names fields lock) = J.showJSON (names, fields, lock)
169 683b1ca7 Iustin Pop
opToArgs (QueryJobs ids fields) = J.showJSON (map show ids, fields)
170 04282772 Iustin Pop
opToArgs (QueryExports nodes lock) = J.showJSON (nodes, lock)
171 04282772 Iustin Pop
opToArgs (QueryConfigValues fields) = J.showJSON fields
172 683b1ca7 Iustin Pop
opToArgs (QueryClusterInfo) = J.showJSON ()
173 04282772 Iustin Pop
opToArgs (QueryTags kind name) =  J.showJSON (kind, name)
174 9622919d Iustin Pop
opToArgs (SubmitJob j) = J.showJSON j
175 04282772 Iustin Pop
opToArgs (SubmitManyJobs ops) = J.showJSON ops
176 9622919d Iustin Pop
-- This is special, since the JSON library doesn't export an instance
177 9622919d Iustin Pop
-- of a 5-tuple
178 9622919d Iustin Pop
opToArgs (WaitForJobChange a b c d e) =
179 9622919d Iustin Pop
    JSArray [ J.showJSON a, J.showJSON b, J.showJSON c
180 9622919d Iustin Pop
            , J.showJSON d, J.showJSON e]
181 04282772 Iustin Pop
opToArgs (ArchiveJob a) = J.showJSON (show a)
182 9622919d Iustin Pop
opToArgs (AutoArchiveJobs a b) = J.showJSON (a, b)
183 04282772 Iustin Pop
opToArgs (CancelJob a) = J.showJSON (show a)
184 04282772 Iustin Pop
opToArgs (SetDrainFlag flag) = J.showJSON flag
185 04282772 Iustin Pop
opToArgs (SetWatcherPause duration) = J.showJSON [duration]
186 683b1ca7 Iustin Pop
187 6583e677 Iustin Pop
-- | Serialize a request to String.
188 6583e677 Iustin Pop
buildCall :: LuxiOp  -- ^ The method
189 6583e677 Iustin Pop
          -> String  -- ^ The serialized form
190 683b1ca7 Iustin Pop
buildCall lo =
191 683b1ca7 Iustin Pop
    let ja = [ (strOfKey Method, JSString $ toJSString $ strOfOp lo::JSValue)
192 683b1ca7 Iustin Pop
             , (strOfKey Args, opToArgs lo::JSValue)
193 6583e677 Iustin Pop
             ]
194 6583e677 Iustin Pop
        jo = toJSObject ja
195 6583e677 Iustin Pop
    in encodeStrict jo
196 6583e677 Iustin Pop
197 6583e677 Iustin Pop
-- | Check that luxi responses contain the required keys and that the
198 6583e677 Iustin Pop
-- call was successful.
199 6583e677 Iustin Pop
validateResult :: String -> Result JSValue
200 6583e677 Iustin Pop
validateResult s = do
201 c96d44df Iustin Pop
  oarr <- fromJResult "Parsing LUXI response"
202 c96d44df Iustin Pop
          (decodeStrict s)::Result (JSObject JSValue)
203 262f3e6c Iustin Pop
  let arr = J.fromJSObject oarr
204 e8230242 Iustin Pop
  status <- fromObj arr (strOfKey Success)::Result Bool
205 6583e677 Iustin Pop
  let rkey = strOfKey Result
206 6583e677 Iustin Pop
  (if status
207 e8230242 Iustin Pop
   then fromObj arr rkey
208 e8230242 Iustin Pop
   else fromObj arr rkey >>= fail)
209 6583e677 Iustin Pop
210 6583e677 Iustin Pop
-- | Generic luxi method call.
211 683b1ca7 Iustin Pop
callMethod :: LuxiOp -> Client -> IO (Result JSValue)
212 683b1ca7 Iustin Pop
callMethod method s = do
213 683b1ca7 Iustin Pop
  sendMsg s $ buildCall method
214 6583e677 Iustin Pop
  result <- recvMsg s
215 6583e677 Iustin Pop
  let rval = validateResult result
216 6583e677 Iustin Pop
  return rval
217 9a2ff880 Iustin Pop
218 9a2ff880 Iustin Pop
-- | Specialized submitManyJobs call.
219 683b1ca7 Iustin Pop
submitManyJobs :: Client -> [[OpCode]] -> IO (Result [String])
220 9a2ff880 Iustin Pop
submitManyJobs s jobs = do
221 683b1ca7 Iustin Pop
  rval <- callMethod (SubmitManyJobs jobs) s
222 9a2ff880 Iustin Pop
  -- map each result (status, payload) pair into a nice Result ADT
223 9a2ff880 Iustin Pop
  return $ case rval of
224 9a2ff880 Iustin Pop
             Bad x -> Bad x
225 9a2ff880 Iustin Pop
             Ok (JSArray r) ->
226 9a2ff880 Iustin Pop
                 mapM (\v -> case v of
227 9a2ff880 Iustin Pop
                               JSArray [JSBool True, JSString x] ->
228 9a2ff880 Iustin Pop
                                   Ok (fromJSString x)
229 9a2ff880 Iustin Pop
                               JSArray [JSBool False, JSString x] ->
230 9a2ff880 Iustin Pop
                                   Bad (fromJSString x)
231 9a2ff880 Iustin Pop
                               _ -> Bad "Unknown result from the master daemon"
232 9a2ff880 Iustin Pop
                      ) r
233 9a2ff880 Iustin Pop
             x -> Bad ("Cannot parse response from Ganeti: " ++ show x)
234 9a2ff880 Iustin Pop
235 9a2ff880 Iustin Pop
-- | Custom queryJobs call.
236 9a2ff880 Iustin Pop
queryJobsStatus :: Client -> [String] -> IO (Result [JobStatus])
237 9a2ff880 Iustin Pop
queryJobsStatus s jids = do
238 683b1ca7 Iustin Pop
  rval <- callMethod (QueryJobs (map read jids) ["status"]) s
239 9a2ff880 Iustin Pop
  return $ case rval of
240 9a2ff880 Iustin Pop
             Bad x -> Bad x
241 9a2ff880 Iustin Pop
             Ok y -> case J.readJSON y::(J.Result [[JobStatus]]) of
242 9a2ff880 Iustin Pop
                       J.Ok vals -> if any null vals
243 9a2ff880 Iustin Pop
                                    then Bad "Missing job status field"
244 9a2ff880 Iustin Pop
                                    else Ok (map head vals)
245 9a2ff880 Iustin Pop
                       J.Error x -> Bad x