1 {-| Implementation of the LUXI loader.
7 Copyright (C) 2009, 2010 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
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.Utils (fromJVal, annotateResult, tryFromObj, asJSObject)
43 -- * Utility functions
45 -- | Ensure a given JSValue is actually a JSArray.
46 toArray :: (Monad m) => JSValue -> m [JSValue]
49 JSArray arr -> return arr
50 o -> fail ("Invalid input, expected array but got " ++ show o)
52 -- * Data querying functionality
54 -- | The input data for node query.
55 queryNodesMsg :: L.LuxiOp
57 L.QueryNodes [] ["name", "mtotal", "mnode", "mfree", "dtotal", "dfree",
58 "ctotal", "offline", "drained", "vm_capable",
61 -- | The input data for instance query.
62 queryInstancesMsg :: L.LuxiOp
64 L.QueryInstances [] ["name", "disk_usage", "be/memory", "be/vcpus",
65 "status", "pnode", "snodes", "tags", "oper_ram"] False
67 -- | The input data for cluster query.
68 queryClusterInfoMsg :: L.LuxiOp
69 queryClusterInfoMsg = L.QueryClusterInfo
71 -- | The input data for node group query.
72 queryGroupsMsg :: L.LuxiOp
74 L.QueryGroups [] ["uuid", "name", "alloc_policy"] False
76 -- | Wraper over callMethod doing node query.
77 queryNodes :: L.Client -> IO (Result JSValue)
78 queryNodes = L.callMethod queryNodesMsg
80 -- | Wraper over callMethod doing instance query.
81 queryInstances :: L.Client -> IO (Result JSValue)
82 queryInstances = L.callMethod queryInstancesMsg
84 queryClusterInfo :: L.Client -> IO (Result JSValue)
85 queryClusterInfo = L.callMethod queryClusterInfoMsg
87 -- | Wrapper over callMethod doing group query.
88 queryGroups :: L.Client -> IO (Result JSValue)
89 queryGroups = L.callMethod queryGroupsMsg
91 -- | Parse a instance list in JSON format.
92 getInstances :: NameAssoc
94 -> Result [(String, Instance.Instance)]
95 getInstances ktn arr = toArray arr >>= mapM (parseInstance ktn)
97 -- | Construct an instance from a JSON object.
98 parseInstance :: NameAssoc
100 -> Result (String, Instance.Instance)
101 parseInstance ktn (JSArray [ name, disk, mem, vcpus
102 , status, pnode, snodes, tags, oram ]) = do
103 xname <- annotateResult "Parsing new instance" (fromJVal name)
104 let convert v = annotateResult ("Instance '" ++ xname ++ "'") (fromJVal v)
105 xdisk <- convert disk
106 xmem <- (case oram of
107 JSRational _ _ -> convert oram
109 xvcpus <- convert vcpus
110 xpnode <- convert pnode >>= lookupNode ktn xname
111 xsnodes <- convert snodes::Result [JSString]
112 snode <- (if null xsnodes then return Node.noSecondary
113 else lookupNode ktn xname (fromJSString $ head xsnodes))
114 xrunning <- convert status
115 xtags <- convert tags
116 let inst = Instance.create xname xmem xdisk xvcpus
117 xrunning xtags xpnode snode
120 parseInstance _ v = fail ("Invalid instance query result: " ++ show v)
122 -- | Parse a node list in JSON format.
123 getNodes :: NameAssoc -> JSValue -> Result [(String, Node.Node)]
124 getNodes ktg arr = toArray arr >>= mapM (parseNode ktg)
126 -- | Construct a node from a JSON object.
127 parseNode :: NameAssoc -> JSValue -> Result (String, Node.Node)
128 parseNode ktg (JSArray [ name, mtotal, mnode, mfree, dtotal, dfree
129 , ctotal, offline, drained, vm_capable, g_uuid ])
131 xname <- annotateResult "Parsing new node" (fromJVal name)
132 let convert v = annotateResult ("Node '" ++ xname ++ "'") (fromJVal v)
133 xoffline <- convert offline
134 xdrained <- convert drained
135 xvm_capable <- convert vm_capable
136 xgdx <- convert g_uuid >>= lookupGroup ktg xname
137 node <- (if xoffline || xdrained || not xvm_capable
138 then return $ Node.create xname 0 0 0 0 0 0 True xgdx
140 xmtotal <- convert mtotal
141 xmnode <- convert mnode
142 xmfree <- convert mfree
143 xdtotal <- convert dtotal
144 xdfree <- convert dfree
145 xctotal <- convert ctotal
146 return $ Node.create xname xmtotal xmnode xmfree
147 xdtotal xdfree xctotal False xgdx)
150 parseNode _ v = fail ("Invalid node query result: " ++ show v)
152 getClusterTags :: JSValue -> Result [String]
153 getClusterTags v = do
154 let errmsg = "Parsing cluster info"
155 obj <- annotateResult errmsg $ asJSObject v
156 tryFromObj errmsg (fromJSObject obj) "tags"
158 getGroups :: JSValue -> Result [(String, Group.Group)]
159 getGroups arr = toArray arr >>= mapM parseGroup
161 parseGroup :: JSValue -> Result (String, Group.Group)
162 parseGroup (JSArray [ uuid, name, apol ]) = do
163 xname <- annotateResult "Parsing new group" (fromJVal name)
164 let convert v = annotateResult ("Node '" ++ xname ++ "'") (fromJVal v)
165 xuuid <- convert uuid
166 xapol <- convert apol
167 return $ (xuuid, Group.create xname xuuid xapol)
169 parseGroup v = fail ("Invalid group query result: " ++ show v)
171 -- * Main loader functionality
173 -- | Builds the cluster data from an URL.
174 readData :: String -- ^ Unix socket to use as source
175 -> IO (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
181 nodes <- queryNodes s
182 instances <- queryInstances s
183 cinfo <- queryClusterInfo s
184 groups <- queryGroups s
185 return (groups, nodes, instances, cinfo)
188 parseData :: (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
189 -> Result ClusterData
190 parseData (groups, nodes, instances, cinfo) = do
191 group_data <- groups >>= getGroups
192 let (group_names, group_idx) = assignIndices group_data
193 node_data <- nodes >>= getNodes group_names
194 let (node_names, node_idx) = assignIndices node_data
195 inst_data <- instances >>= getInstances node_names
196 let (_, inst_idx) = assignIndices inst_data
197 ctags <- cinfo >>= getClusterTags
198 return (ClusterData group_idx node_idx inst_idx ctags)
200 -- | Top level function for data loading
201 loadData :: String -- ^ Unix socket to use as source
202 -> IO (Result ClusterData)
203 loadData master = readData master >>= return . parseData