1 {-| Implementation of the LUXI loader.
7 Copyright (C) 2009 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
34 import Text.JSON.Types
36 import qualified Ganeti.Luxi as L
37 import Ganeti.HTools.Loader
38 import Ganeti.HTools.Types
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 :: JSValue
57 let nnames = JSArray []
59 "mtotal", "mnode", "mfree",
63 fields = JSArray $ map (JSString . toJSString) fnames
64 use_locking = JSBool False
65 in JSArray [nnames, fields, use_locking]
67 -- | The input data for instance query.
68 queryInstancesMsg :: JSValue
70 let nnames = JSArray []
72 "disk_usage", "be/memory", "be/vcpus",
73 "status", "pnode", "snodes", "tags"]
74 fields = JSArray $ map (JSString . toJSString) fnames
75 use_locking = JSBool False
76 in JSArray [nnames, fields, use_locking]
78 -- | The input data for cluster query
79 queryClusterInfoMsg :: JSValue
80 queryClusterInfoMsg = JSArray []
82 -- | Wraper over callMethod doing node query.
83 queryNodes :: L.Client -> IO (Result JSValue)
84 queryNodes = L.callMethod L.QueryNodes queryNodesMsg
86 -- | Wraper over callMethod doing instance query.
87 queryInstances :: L.Client -> IO (Result JSValue)
88 queryInstances = L.callMethod L.QueryInstances queryInstancesMsg
90 queryClusterInfo :: L.Client -> IO (Result JSValue)
91 queryClusterInfo = L.callMethod L.QueryClusterInfo queryClusterInfoMsg
93 -- | Parse a instance list in JSON format.
94 getInstances :: NameAssoc
96 -> Result [(String, Instance.Instance)]
97 getInstances ktn arr = toArray arr >>= mapM (parseInstance ktn)
99 -- | Construct an instance from a JSON object.
100 parseInstance :: [(String, Ndx)]
102 -> Result (String, Instance.Instance)
103 parseInstance ktn (JSArray [ name, disk, mem, vcpus
104 , status, pnode, snodes, tags ]) = do
105 xname <- annotateResult "Parsing new instance" (fromJVal name)
106 let convert v = annotateResult ("Instance '" ++ xname ++ "'") (fromJVal v)
107 xdisk <- convert disk
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 :: JSValue -> Result [(String, Node.Node)]
124 getNodes arr = toArray arr >>= mapM parseNode
126 -- | Construct a node from a JSON object.
127 parseNode :: JSValue -> Result (String, Node.Node)
128 parseNode (JSArray [ name, mtotal, mnode, mfree, dtotal, dfree
129 , ctotal, offline, drained ])
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 node <- (if xoffline || xdrained
136 then return $ Node.create xname 0 0 0 0 0 0 True
138 xmtotal <- convert mtotal
139 xmnode <- convert mnode
140 xmfree <- convert mfree
141 xdtotal <- convert dtotal
142 xdfree <- convert dfree
143 xctotal <- convert ctotal
144 return $ Node.create xname xmtotal xmnode xmfree
145 xdtotal xdfree xctotal False)
148 parseNode v = fail ("Invalid node query result: " ++ show v)
150 getClusterTags :: JSValue -> Result [String]
151 getClusterTags v = do
152 let errmsg = "Parsing cluster info"
153 obj <- annotateResult errmsg $ asJSObject v
154 tags <- tryFromObj errmsg (fromJSObject obj) "tags"
157 -- * Main loader functionality
159 -- | Builds the cluster data from an URL.
160 loadData :: String -- ^ Unix socket to use as source
161 -> IO (Result (Node.AssocList, Instance.AssocList, [String]))
167 nodes <- queryNodes s
168 instances <- queryInstances s
169 cinfo <- queryClusterInfo s
170 return $ do -- Result monad
171 node_data <- nodes >>= getNodes
172 let (node_names, node_idx) = assignIndices node_data
173 inst_data <- instances >>= getInstances node_names
174 let (_, inst_idx) = assignIndices inst_data
175 ctags <- cinfo >>= getClusterTags
176 return (node_idx, inst_idx, ctags)