1 {-| Implementation of the LUXI loader.
7 Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
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.
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.
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
26 module Ganeti.HTools.Luxi
31 import qualified Control.Exception as E
32 import Text.JSON.Types
33 import qualified Text.JSON
35 import qualified Ganeti.Luxi as L
36 import Ganeti.HTools.Loader
37 import Ganeti.HTools.Types
38 import qualified Ganeti.HTools.Group as Group
39 import qualified Ganeti.HTools.Node as Node
40 import qualified Ganeti.HTools.Instance as Instance
41 import Ganeti.HTools.JSON
42 import Ganeti.Qlang as Qlang
44 {-# ANN module "HLint: ignore Eta reduce" #-}
46 -- * Utility functions
48 -- | Get values behind \"data\" part of the result.
49 getData :: (Monad m) => JSValue -> m JSValue
50 getData (JSObject o) = fromObj (fromJSObject o) "data"
51 getData x = fail $ "Invalid input, expected dict entry but got " ++ show x
53 -- | Converts a (status, value) into m value, if possible.
54 parseQueryField :: (Monad m) => JSValue -> m (JSValue, JSValue)
55 parseQueryField (JSArray [status, result]) = return (status, result)
57 fail $ "Invalid query field, expected (status, value) but got " ++ show o
59 -- | Parse a result row.
60 parseQueryRow :: (Monad m) => JSValue -> m [(JSValue, JSValue)]
61 parseQueryRow (JSArray arr) = mapM parseQueryField arr
63 fail $ "Invalid query row result, expected array but got " ++ show o
65 -- | Parse an overall query result and get the [(status, value)] list
66 -- for each element queried.
67 parseQueryResult :: (Monad m) => JSValue -> m [[(JSValue, JSValue)]]
68 parseQueryResult (JSArray arr) = mapM parseQueryRow arr
70 fail $ "Invalid query result, expected array but got " ++ show o
72 -- | Prepare resulting output as parsers expect it.
73 extractArray :: (Monad m) => JSValue -> m [[(JSValue, JSValue)]]
75 getData v >>= parseQueryResult
77 -- | Testing result status for more verbose error message.
78 fromJValWithStatus :: (Text.JSON.JSON a, Monad m) => (JSValue, JSValue) -> m a
79 fromJValWithStatus (st, v) = do
81 L.checkRS st' v >>= fromJVal
83 -- | Annotate errors when converting values with owner/attribute for
85 genericConvert :: (Text.JSON.JSON a) =>
86 String -- ^ The object type
87 -> String -- ^ The object name
88 -> String -- ^ The attribute we're trying to convert
89 -> (JSValue, JSValue) -- ^ The value we're trying to convert
90 -> Result a -- ^ The annotated result
91 genericConvert otype oname oattr =
92 annotateResult (otype ++ " '" ++ oname ++
93 "', error while reading attribute '" ++
94 oattr ++ "'") . fromJValWithStatus
96 -- * Data querying functionality
98 -- | The input data for node query.
99 queryNodesMsg :: L.LuxiOp
101 L.Query Qlang.QRNode ["name", "mtotal", "mnode", "mfree", "dtotal", "dfree",
102 "ctotal", "offline", "drained", "vm_capable",
103 "ndp/spindle_count", "group.uuid"] Qlang.EmptyFilter
105 -- | The input data for instance query.
106 queryInstancesMsg :: L.LuxiOp
108 L.Query Qlang.QRInstance ["name", "disk_usage", "be/memory", "be/vcpus",
109 "status", "pnode", "snodes", "tags", "oper_ram",
110 "be/auto_balance", "disk_template",
111 "be/spindle_use"] Qlang.EmptyFilter
113 -- | The input data for cluster query.
114 queryClusterInfoMsg :: L.LuxiOp
115 queryClusterInfoMsg = L.QueryClusterInfo
117 -- | The input data for node group query.
118 queryGroupsMsg :: L.LuxiOp
120 L.Query Qlang.QRGroup ["uuid", "name", "alloc_policy", "ipolicy"]
123 -- | Wraper over 'callMethod' doing node query.
124 queryNodes :: L.Client -> IO (Result JSValue)
125 queryNodes = L.callMethod queryNodesMsg
127 -- | Wraper over 'callMethod' doing instance query.
128 queryInstances :: L.Client -> IO (Result JSValue)
129 queryInstances = L.callMethod queryInstancesMsg
131 -- | Wrapper over 'callMethod' doing cluster information query.
132 queryClusterInfo :: L.Client -> IO (Result JSValue)
133 queryClusterInfo = L.callMethod queryClusterInfoMsg
135 -- | Wrapper over callMethod doing group query.
136 queryGroups :: L.Client -> IO (Result JSValue)
137 queryGroups = L.callMethod queryGroupsMsg
139 -- | Parse a instance list in JSON format.
140 getInstances :: NameAssoc
142 -> Result [(String, Instance.Instance)]
143 getInstances ktn arr = extractArray arr >>= mapM (parseInstance ktn)
145 -- | Construct an instance from a JSON object.
146 parseInstance :: NameAssoc
147 -> [(JSValue, JSValue)]
148 -> Result (String, Instance.Instance)
149 parseInstance ktn [ name, disk, mem, vcpus
150 , status, pnode, snodes, tags, oram
151 , auto_balance, disk_template, su ] = do
152 xname <- annotateResult "Parsing new instance" (fromJValWithStatus name)
153 let convert a = genericConvert "Instance" xname a
154 xdisk <- convert "disk_usage" disk
155 xmem <- case oram of -- FIXME: remove the "guessing"
156 (_, JSRational _ _) -> convert "oper_ram" oram
157 _ -> convert "be/memory" mem
158 xvcpus <- convert "be/vcpus" vcpus
159 xpnode <- convert "pnode" pnode >>= lookupNode ktn xname
160 xsnodes <- convert "snodes" snodes::Result [JSString]
161 snode <- if null xsnodes
162 then return Node.noSecondary
163 else lookupNode ktn xname (fromJSString $ head xsnodes)
164 xrunning <- convert "status" status
165 xtags <- convert "tags" tags
166 xauto_balance <- convert "auto_balance" auto_balance
167 xdt <- convert "disk_template" disk_template
168 xsu <- convert "be/spindle_use" su
169 let inst = Instance.create xname xmem xdisk xvcpus
170 xrunning xtags xauto_balance xpnode snode xdt xsu
173 parseInstance _ v = fail ("Invalid instance query result: " ++ show v)
175 -- | Parse a node list in JSON format.
176 getNodes :: NameAssoc -> JSValue -> Result [(String, Node.Node)]
177 getNodes ktg arr = extractArray arr >>= mapM (parseNode ktg)
179 -- | Construct a node from a JSON object.
180 parseNode :: NameAssoc -> [(JSValue, JSValue)] -> Result (String, Node.Node)
181 parseNode ktg [ name, mtotal, mnode, mfree, dtotal, dfree
182 , ctotal, offline, drained, vm_capable, spindles, g_uuid ]
184 xname <- annotateResult "Parsing new node" (fromJValWithStatus name)
185 let convert a = genericConvert "Node" xname a
186 xoffline <- convert "offline" offline
187 xdrained <- convert "drained" drained
188 xvm_capable <- convert "vm_capable" vm_capable
189 xspindles <- convert "spindles" spindles
190 xgdx <- convert "group.uuid" g_uuid >>= lookupGroup ktg xname
191 node <- if xoffline || xdrained || not xvm_capable
192 then return $ Node.create xname 0 0 0 0 0 0 True xspindles xgdx
194 xmtotal <- convert "mtotal" mtotal
195 xmnode <- convert "mnode" mnode
196 xmfree <- convert "mfree" mfree
197 xdtotal <- convert "dtotal" dtotal
198 xdfree <- convert "dfree" dfree
199 xctotal <- convert "ctotal" ctotal
200 return $ Node.create xname xmtotal xmnode xmfree
201 xdtotal xdfree xctotal False xspindles xgdx
204 parseNode _ v = fail ("Invalid node query result: " ++ show v)
206 -- | Parses the cluster tags.
207 getClusterData :: JSValue -> Result ([String], IPolicy)
208 getClusterData (JSObject obj) = do
209 let errmsg = "Parsing cluster info"
210 obj' = fromJSObject obj
211 ctags <- tryFromObj errmsg obj' "tags"
212 cpol <- tryFromObj errmsg obj' "ipolicy"
215 getClusterData _ = Bad $ "Cannot parse cluster info, not a JSON record"
217 -- | Parses the cluster groups.
218 getGroups :: JSValue -> Result [(String, Group.Group)]
219 getGroups jsv = extractArray jsv >>= mapM parseGroup
221 -- | Parses a given group information.
222 parseGroup :: [(JSValue, JSValue)] -> Result (String, Group.Group)
223 parseGroup [uuid, name, apol, ipol] = do
224 xname <- annotateResult "Parsing new group" (fromJValWithStatus name)
225 let convert a = genericConvert "Group" xname a
226 xuuid <- convert "uuid" uuid
227 xapol <- convert "alloc_policy" apol
228 xipol <- convert "ipolicy" ipol
229 return (xuuid, Group.create xname xuuid xapol xipol)
231 parseGroup v = fail ("Invalid group query result: " ++ show v)
233 -- * Main loader functionality
235 -- | Builds the cluster data by querying a given socket name.
236 readData :: String -- ^ Unix socket to use as source
237 -> IO (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
243 nodes <- queryNodes s
244 instances <- queryInstances s
245 cinfo <- queryClusterInfo s
246 groups <- queryGroups s
247 return (groups, nodes, instances, cinfo)
250 -- | Converts the output of 'readData' into the internal cluster
252 parseData :: (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
253 -> Result ClusterData
254 parseData (groups, nodes, instances, cinfo) = do
255 group_data <- groups >>= getGroups
256 let (group_names, group_idx) = assignIndices group_data
257 node_data <- nodes >>= getNodes group_names
258 let (node_names, node_idx) = assignIndices node_data
259 inst_data <- instances >>= getInstances node_names
260 let (_, inst_idx) = assignIndices inst_data
261 (ctags, cpol) <- cinfo >>= getClusterData
262 return (ClusterData group_idx node_idx inst_idx ctags cpol)
264 -- | Top level function for data loading.
265 loadData :: String -- ^ Unix socket to use as source
266 -> IO (Result ClusterData)
267 loadData = fmap parseData . readData