1 {-| Implementation of the LUXI loader.
7 Copyright (C) 2009, 2010, 2011 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
32 import qualified Control.Exception as E
33 import Text.JSON.Types
34 import qualified Text.JSON
36 import qualified Ganeti.Luxi as L
37 import Ganeti.HTools.Loader
38 import Ganeti.HTools.Types
39 import qualified Ganeti.HTools.Group as Group
40 import qualified Ganeti.HTools.Node as Node
41 import qualified Ganeti.HTools.Instance as Instance
42 import Ganeti.HTools.Utils (fromJVal, annotateResult, tryFromObj, asJSObject)
44 -- * Utility functions
46 -- | Ensure a given JSValue is actually a JSArray.
47 toArray :: (Monad m) => JSValue -> m [JSValue]
50 JSArray arr -> return arr
51 o -> fail ("Invalid input, expected array but got " ++ show o)
53 -- | Annotate errors when converting values with owner/attribute for
55 genericConvert :: (Text.JSON.JSON a) =>
56 String -- ^ The object type
57 -> String -- ^ The object name
58 -> String -- ^ The attribute we're trying to convert
59 -> JSValue -- ^ The value we try to convert
60 -> Result a -- ^ The annotated result
61 genericConvert otype oname oattr =
62 annotateResult (otype ++ " '" ++ oname ++
63 "', error while reading attribute '" ++
64 oattr ++ "'") . fromJVal
66 -- * Data querying functionality
68 -- | The input data for node query.
69 queryNodesMsg :: L.LuxiOp
71 L.QueryNodes [] ["name", "mtotal", "mnode", "mfree", "dtotal", "dfree",
72 "ctotal", "offline", "drained", "vm_capable",
75 -- | The input data for instance query.
76 queryInstancesMsg :: L.LuxiOp
78 L.QueryInstances [] ["name", "disk_usage", "be/memory", "be/vcpus",
79 "status", "pnode", "snodes", "tags", "oper_ram",
80 "be/auto_balance", "disk_template"] False
82 -- | The input data for cluster query.
83 queryClusterInfoMsg :: L.LuxiOp
84 queryClusterInfoMsg = L.QueryClusterInfo
86 -- | The input data for node group query.
87 queryGroupsMsg :: L.LuxiOp
89 L.QueryGroups [] ["uuid", "name", "alloc_policy"] False
91 -- | Wraper over 'callMethod' doing node query.
92 queryNodes :: L.Client -> IO (Result JSValue)
93 queryNodes = L.callMethod queryNodesMsg
95 -- | Wraper over 'callMethod' doing instance query.
96 queryInstances :: L.Client -> IO (Result JSValue)
97 queryInstances = L.callMethod queryInstancesMsg
99 -- | Wrapper over 'callMethod' doing cluster information query.
100 queryClusterInfo :: L.Client -> IO (Result JSValue)
101 queryClusterInfo = L.callMethod queryClusterInfoMsg
103 -- | Wrapper over callMethod doing group query.
104 queryGroups :: L.Client -> IO (Result JSValue)
105 queryGroups = L.callMethod queryGroupsMsg
107 -- | Parse a instance list in JSON format.
108 getInstances :: NameAssoc
110 -> Result [(String, Instance.Instance)]
111 getInstances ktn arr = toArray arr >>= mapM (parseInstance ktn)
113 -- | Construct an instance from a JSON object.
114 parseInstance :: NameAssoc
116 -> Result (String, Instance.Instance)
117 parseInstance ktn (JSArray [ name, disk, mem, vcpus
118 , status, pnode, snodes, tags, oram
119 , auto_balance, disk_template ]) = do
120 xname <- annotateResult "Parsing new instance" (fromJVal name)
121 let convert a = genericConvert "Instance" xname a
122 xdisk <- convert "disk_usage" disk
123 xmem <- (case oram of
124 JSRational _ _ -> convert "oper_ram" oram
125 _ -> convert "be/memory" mem)
126 xvcpus <- convert "be/vcpus" vcpus
127 xpnode <- convert "pnode" pnode >>= lookupNode ktn xname
128 xsnodes <- convert "snodes" snodes::Result [JSString]
129 snode <- (if null xsnodes then return Node.noSecondary
130 else lookupNode ktn xname (fromJSString $ head xsnodes))
131 xrunning <- convert "status" status
132 xtags <- convert "tags" tags
133 xauto_balance <- convert "auto_balance" auto_balance
134 xdt <- convert "disk_template" disk_template
135 let inst = Instance.create xname xmem xdisk xvcpus
136 xrunning xtags xauto_balance xpnode snode xdt
139 parseInstance _ v = fail ("Invalid instance query result: " ++ show v)
141 -- | Parse a node list in JSON format.
142 getNodes :: NameAssoc -> JSValue -> Result [(String, Node.Node)]
143 getNodes ktg arr = toArray arr >>= mapM (parseNode ktg)
145 -- | Construct a node from a JSON object.
146 parseNode :: NameAssoc -> JSValue -> Result (String, Node.Node)
147 parseNode ktg (JSArray [ name, mtotal, mnode, mfree, dtotal, dfree
148 , ctotal, offline, drained, vm_capable, g_uuid ])
150 xname <- annotateResult "Parsing new node" (fromJVal name)
151 let convert a = genericConvert "Node" xname a
152 xoffline <- convert "offline" offline
153 xdrained <- convert "drained" drained
154 xvm_capable <- convert "vm_capable" vm_capable
155 xgdx <- convert "group.uuid" g_uuid >>= lookupGroup ktg xname
156 node <- (if xoffline || xdrained || not xvm_capable
157 then return $ Node.create xname 0 0 0 0 0 0 True xgdx
159 xmtotal <- convert "mtotal" mtotal
160 xmnode <- convert "mnode" mnode
161 xmfree <- convert "mfree" mfree
162 xdtotal <- convert "dtotal" dtotal
163 xdfree <- convert "dfree" dfree
164 xctotal <- convert "ctotal" ctotal
165 return $ Node.create xname xmtotal xmnode xmfree
166 xdtotal xdfree xctotal False xgdx)
169 parseNode _ v = fail ("Invalid node query result: " ++ show v)
171 -- | Parses the cluster tags.
172 getClusterTags :: JSValue -> Result [String]
173 getClusterTags v = do
174 let errmsg = "Parsing cluster info"
175 obj <- annotateResult errmsg $ asJSObject v
176 tryFromObj errmsg (fromJSObject obj) "tags"
178 -- | Parses the cluster groups.
179 getGroups :: JSValue -> Result [(String, Group.Group)]
180 getGroups arr = toArray arr >>= mapM parseGroup
182 -- | Parses a given group information.
183 parseGroup :: JSValue -> Result (String, Group.Group)
184 parseGroup (JSArray [ uuid, name, apol ]) = do
185 xname <- annotateResult "Parsing new group" (fromJVal name)
186 let convert a = genericConvert "Group" xname a
187 xuuid <- convert "uuid" uuid
188 xapol <- convert "alloc_policy" apol
189 return (xuuid, Group.create xname xuuid xapol)
191 parseGroup v = fail ("Invalid group query result: " ++ show v)
193 -- * Main loader functionality
195 -- | Builds the cluster data by querying a given socket name.
196 readData :: String -- ^ Unix socket to use as source
197 -> IO (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
203 nodes <- queryNodes s
204 instances <- queryInstances s
205 cinfo <- queryClusterInfo s
206 groups <- queryGroups s
207 return (groups, nodes, instances, cinfo)
210 -- | Converts the output of 'readData' into the internal cluster
212 parseData :: (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
213 -> Result ClusterData
214 parseData (groups, nodes, instances, cinfo) = do
215 group_data <- groups >>= getGroups
216 let (group_names, group_idx) = assignIndices group_data
217 node_data <- nodes >>= getNodes group_names
218 let (node_names, node_idx) = assignIndices node_data
219 inst_data <- instances >>= getInstances node_names
220 let (_, inst_idx) = assignIndices inst_data
221 ctags <- cinfo >>= getClusterTags
222 return (ClusterData group_idx node_idx inst_idx ctags)
224 -- | Top level function for data loading.
225 loadData :: String -- ^ Unix socket to use as source
226 -> IO (Result ClusterData)
227 loadData = fmap parseData . readData