Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / HTools / Backend / Luxi.hs @ f40fe08c

History | View | Annotate | Download (10.4 kB)

1
{-| Implementation of the LUXI loader.
2

    
3
-}
4

    
5
{-
6

    
7
Copyright (C) 2009, 2010, 2011, 2012, 2013 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.HTools.Backend.Luxi
27
  ( loadData
28
  , parseData
29
  ) where
30

    
31
import qualified Control.Exception as E
32
import Control.Monad (liftM)
33
import Text.JSON.Types
34
import qualified Text.JSON
35

    
36
import Ganeti.BasicTypes
37
import Ganeti.Errors
38
import qualified Ganeti.Luxi as L
39
import qualified Ganeti.Query.Language as Qlang
40
import Ganeti.HTools.Loader
41
import Ganeti.HTools.Types
42
import qualified Ganeti.HTools.Group as Group
43
import qualified Ganeti.HTools.Node as Node
44
import qualified Ganeti.HTools.Instance as Instance
45
import Ganeti.JSON
46

    
47
{-# ANN module "HLint: ignore Eta reduce" #-}
48

    
49
-- * Utility functions
50

    
51
-- | Get values behind \"data\" part of the result.
52
getData :: (Monad m) => JSValue -> m JSValue
53
getData (JSObject o) = fromObj (fromJSObject o) "data"
54
getData x = fail $ "Invalid input, expected dict entry but got " ++ show x
55

    
56
-- | Converts a (status, value) into m value, if possible.
57
parseQueryField :: (Monad m) => JSValue -> m (JSValue, JSValue)
58
parseQueryField (JSArray [status, result]) = return (status, result)
59
parseQueryField o =
60
  fail $ "Invalid query field, expected (status, value) but got " ++ show o
61

    
62
-- | Parse a result row.
63
parseQueryRow :: (Monad m) => JSValue -> m [(JSValue, JSValue)]
64
parseQueryRow (JSArray arr) = mapM parseQueryField arr
65
parseQueryRow o =
66
  fail $ "Invalid query row result, expected array but got " ++ show o
67

    
68
-- | Parse an overall query result and get the [(status, value)] list
69
-- for each element queried.
70
parseQueryResult :: (Monad m) => JSValue -> m [[(JSValue, JSValue)]]
71
parseQueryResult (JSArray arr) = mapM parseQueryRow arr
72
parseQueryResult o =
73
  fail $ "Invalid query result, expected array but got " ++ show o
74

    
75
-- | Prepare resulting output as parsers expect it.
76
extractArray :: (Monad m) => JSValue -> m [[(JSValue, JSValue)]]
77
extractArray v =
78
  getData v >>= parseQueryResult
79

    
80
-- | Testing result status for more verbose error message.
81
fromJValWithStatus :: (Text.JSON.JSON a, Monad m) => (JSValue, JSValue) -> m a
82
fromJValWithStatus (st, v) = do
83
  st' <- fromJVal st
84
  Qlang.checkRS st' v >>= fromJVal
85

    
86
-- | Annotate errors when converting values with owner/attribute for
87
-- better debugging.
88
genericConvert :: (Text.JSON.JSON a) =>
89
                  String             -- ^ The object type
90
               -> String             -- ^ The object name
91
               -> String             -- ^ The attribute we're trying to convert
92
               -> (JSValue, JSValue) -- ^ The value we're trying to convert
93
               -> Result a           -- ^ The annotated result
94
genericConvert otype oname oattr =
95
  annotateResult (otype ++ " '" ++ oname ++
96
                  "', error while reading attribute '" ++
97
                  oattr ++ "'") . fromJValWithStatus
98

    
99
-- * Data querying functionality
100

    
101
-- | The input data for node query.
102
queryNodesMsg :: L.LuxiOp
103
queryNodesMsg =
104
  L.Query (Qlang.ItemTypeOpCode Qlang.QRNode)
105
     ["name", "mtotal", "mnode", "mfree", "dtotal", "dfree",
106
      "ctotal", "offline", "drained", "vm_capable",
107
      "ndp/spindle_count", "group.uuid"] Qlang.EmptyFilter
108

    
109
-- | The input data for instance query.
110
queryInstancesMsg :: L.LuxiOp
111
queryInstancesMsg =
112
  L.Query (Qlang.ItemTypeOpCode Qlang.QRInstance)
113
     ["name", "disk_usage", "be/memory", "be/vcpus",
114
      "status", "pnode", "snodes", "tags", "oper_ram",
115
      "be/auto_balance", "disk_template",
116
      "be/spindle_use"] Qlang.EmptyFilter
117

    
118
-- | The input data for cluster query.
119
queryClusterInfoMsg :: L.LuxiOp
120
queryClusterInfoMsg = L.QueryClusterInfo
121

    
122
-- | The input data for node group query.
123
queryGroupsMsg :: L.LuxiOp
124
queryGroupsMsg =
125
  L.Query (Qlang.ItemTypeOpCode Qlang.QRGroup)
126
     ["uuid", "name", "alloc_policy", "ipolicy", "tags"]
127
     Qlang.EmptyFilter
128

    
129
-- | Wraper over 'callMethod' doing node query.
130
queryNodes :: L.Client -> IO (Result JSValue)
131
queryNodes = liftM errToResult . L.callMethod queryNodesMsg
132

    
133
-- | Wraper over 'callMethod' doing instance query.
134
queryInstances :: L.Client -> IO (Result JSValue)
135
queryInstances = liftM errToResult . L.callMethod queryInstancesMsg
136

    
137
-- | Wrapper over 'callMethod' doing cluster information query.
138
queryClusterInfo :: L.Client -> IO (Result JSValue)
139
queryClusterInfo = liftM errToResult . L.callMethod queryClusterInfoMsg
140

    
141
-- | Wrapper over callMethod doing group query.
142
queryGroups :: L.Client -> IO (Result JSValue)
143
queryGroups = liftM errToResult . L.callMethod queryGroupsMsg
144

    
145
-- | Parse a instance list in JSON format.
146
getInstances :: NameAssoc
147
             -> JSValue
148
             -> Result [(String, Instance.Instance)]
149
getInstances ktn arr = extractArray arr >>= mapM (parseInstance ktn)
150

    
151
-- | Construct an instance from a JSON object.
152
parseInstance :: NameAssoc
153
              -> [(JSValue, JSValue)]
154
              -> Result (String, Instance.Instance)
155
parseInstance ktn [ name, disk, mem, vcpus
156
                  , status, pnode, snodes, tags, oram
157
                  , auto_balance, disk_template, su ] = do
158
  xname <- annotateResult "Parsing new instance" (fromJValWithStatus name)
159
  let convert a = genericConvert "Instance" xname a
160
  xdisk <- convert "disk_usage" disk
161
  xmem <- case oram of -- FIXME: remove the "guessing"
162
            (_, JSRational _ _) -> convert "oper_ram" oram
163
            _ -> convert "be/memory" mem
164
  xvcpus <- convert "be/vcpus" vcpus
165
  xpnode <- convert "pnode" pnode >>= lookupNode ktn xname
166
  xsnodes <- convert "snodes" snodes::Result [String]
167
  snode <- case xsnodes of
168
             [] -> return Node.noSecondary
169
             x:_ -> lookupNode ktn xname x
170
  xrunning <- convert "status" status
171
  xtags <- convert "tags" tags
172
  xauto_balance <- convert "auto_balance" auto_balance
173
  xdt <- convert "disk_template" disk_template
174
  xsu <- convert "be/spindle_use" su
175
  let inst = Instance.create xname xmem xdisk [xdisk] xvcpus
176
             xrunning xtags xauto_balance xpnode snode xdt xsu
177
  return (xname, inst)
178

    
179
parseInstance _ v = fail ("Invalid instance query result: " ++ show v)
180

    
181
-- | Parse a node list in JSON format.
182
getNodes :: NameAssoc -> JSValue -> Result [(String, Node.Node)]
183
getNodes ktg arr = extractArray arr >>= mapM (parseNode ktg)
184

    
185
-- | Construct a node from a JSON object.
186
parseNode :: NameAssoc -> [(JSValue, JSValue)] -> Result (String, Node.Node)
187
parseNode ktg [ name, mtotal, mnode, mfree, dtotal, dfree
188
              , ctotal, offline, drained, vm_capable, spindles, g_uuid ]
189
    = do
190
  xname <- annotateResult "Parsing new node" (fromJValWithStatus name)
191
  let convert a = genericConvert "Node" xname a
192
  xoffline <- convert "offline" offline
193
  xdrained <- convert "drained" drained
194
  xvm_capable <- convert "vm_capable" vm_capable
195
  xspindles <- convert "spindles" spindles
196
  xgdx   <- convert "group.uuid" g_uuid >>= lookupGroup ktg xname
197
  node <- if xoffline || xdrained || not xvm_capable
198
            then return $ Node.create xname 0 0 0 0 0 0 True xspindles xgdx
199
            else do
200
              xmtotal  <- convert "mtotal" mtotal
201
              xmnode   <- convert "mnode" mnode
202
              xmfree   <- convert "mfree" mfree
203
              xdtotal  <- convert "dtotal" dtotal
204
              xdfree   <- convert "dfree" dfree
205
              xctotal  <- convert "ctotal" ctotal
206
              return $ Node.create xname xmtotal xmnode xmfree
207
                     xdtotal xdfree xctotal False xspindles xgdx
208
  return (xname, node)
209

    
210
parseNode _ v = fail ("Invalid node query result: " ++ show v)
211

    
212
-- | Parses the cluster tags.
213
getClusterData :: JSValue -> Result ([String], IPolicy, String)
214
getClusterData (JSObject obj) = do
215
  let errmsg = "Parsing cluster info"
216
      obj' = fromJSObject obj
217
  ctags <- tryFromObj errmsg obj' "tags"
218
  cpol <- tryFromObj errmsg obj' "ipolicy"
219
  master <- tryFromObj errmsg obj' "master"
220
  return (ctags, cpol, master)
221

    
222
getClusterData _ = Bad "Cannot parse cluster info, not a JSON record"
223

    
224
-- | Parses the cluster groups.
225
getGroups :: JSValue -> Result [(String, Group.Group)]
226
getGroups jsv = extractArray jsv >>= mapM parseGroup
227

    
228
-- | Parses a given group information.
229
parseGroup :: [(JSValue, JSValue)] -> Result (String, Group.Group)
230
parseGroup [uuid, name, apol, ipol, tags] = do
231
  xname <- annotateResult "Parsing new group" (fromJValWithStatus name)
232
  let convert a = genericConvert "Group" xname a
233
  xuuid <- convert "uuid" uuid
234
  xapol <- convert "alloc_policy" apol
235
  xipol <- convert "ipolicy" ipol
236
  xtags <- convert "tags" tags
237
  return (xuuid, Group.create xname xuuid xapol xipol xtags)
238

    
239
parseGroup v = fail ("Invalid group query result: " ++ show v)
240

    
241
-- * Main loader functionality
242

    
243
-- | Builds the cluster data by querying a given socket name.
244
readData :: String -- ^ Unix socket to use as source
245
         -> IO (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
246
readData master =
247
  E.bracket
248
       (L.getClient master)
249
       L.closeClient
250
       (\s -> do
251
          nodes <- queryNodes s
252
          instances <- queryInstances s
253
          cinfo <- queryClusterInfo s
254
          groups <- queryGroups s
255
          return (groups, nodes, instances, cinfo)
256
       )
257

    
258
-- | Converts the output of 'readData' into the internal cluster
259
-- representation.
260
parseData :: (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
261
          -> Result ClusterData
262
parseData (groups, nodes, instances, cinfo) = do
263
  group_data <- groups >>= getGroups
264
  let (group_names, group_idx) = assignIndices group_data
265
  node_data <- nodes >>= getNodes group_names
266
  let (node_names, node_idx) = assignIndices node_data
267
  inst_data <- instances >>= getInstances node_names
268
  let (_, inst_idx) = assignIndices inst_data
269
  (ctags, cpol, master) <- cinfo >>= getClusterData
270
  node_idx' <- setMaster node_names node_idx master
271
  return (ClusterData group_idx node_idx' inst_idx ctags cpol)
272

    
273
-- | Top level function for data loading.
274
loadData :: String -- ^ Unix socket to use as source
275
         -> IO (Result ClusterData)
276
loadData = fmap parseData . readData