Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / HTools / Luxi.hs @ a86fbf36

History | View | Annotate | Download (8.1 kB)

1
{-| Implementation of the LUXI loader.
2

    
3
-}
4

    
5
{-
6

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

    
32
import qualified Control.Exception as E
33
import Text.JSON.Types
34
import qualified Text.JSON
35

    
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)
43

    
44
-- * Utility functions
45

    
46
-- | Ensure a given JSValue is actually a JSArray.
47
toArray :: (Monad m) => JSValue -> m [JSValue]
48
toArray v =
49
    case v of
50
      JSArray arr -> return arr
51
      o -> fail ("Invalid input, expected array but got " ++ show o)
52

    
53
-- | Annotate errors when converting values with owner/attribute for
54
-- better debugging.
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
65

    
66
-- * Data querying functionality
67

    
68
-- | The input data for node query.
69
queryNodesMsg :: L.LuxiOp
70
queryNodesMsg =
71
  L.QueryNodes [] ["name", "mtotal", "mnode", "mfree", "dtotal", "dfree",
72
                   "ctotal", "offline", "drained", "vm_capable",
73
                   "group.uuid"] False
74

    
75
-- | The input data for instance query.
76
queryInstancesMsg :: L.LuxiOp
77
queryInstancesMsg =
78
  L.QueryInstances [] ["name", "disk_usage", "be/memory", "be/vcpus",
79
                       "status", "pnode", "snodes", "tags", "oper_ram",
80
                       "be/auto_balance", "disk_template"] False
81

    
82
-- | The input data for cluster query.
83
queryClusterInfoMsg :: L.LuxiOp
84
queryClusterInfoMsg = L.QueryClusterInfo
85

    
86
-- | The input data for node group query.
87
queryGroupsMsg :: L.LuxiOp
88
queryGroupsMsg =
89
  L.QueryGroups [] ["uuid", "name", "alloc_policy"] False
90

    
91
-- | Wraper over callMethod doing node query.
92
queryNodes :: L.Client -> IO (Result JSValue)
93
queryNodes = L.callMethod queryNodesMsg
94

    
95
-- | Wraper over callMethod doing instance query.
96
queryInstances :: L.Client -> IO (Result JSValue)
97
queryInstances = L.callMethod queryInstancesMsg
98

    
99
queryClusterInfo :: L.Client -> IO (Result JSValue)
100
queryClusterInfo = L.callMethod queryClusterInfoMsg
101

    
102
-- | Wrapper over callMethod doing group query.
103
queryGroups :: L.Client -> IO (Result JSValue)
104
queryGroups = L.callMethod queryGroupsMsg
105

    
106
-- | Parse a instance list in JSON format.
107
getInstances :: NameAssoc
108
             -> JSValue
109
             -> Result [(String, Instance.Instance)]
110
getInstances ktn arr = toArray arr >>= mapM (parseInstance ktn)
111

    
112
-- | Construct an instance from a JSON object.
113
parseInstance :: NameAssoc
114
              -> JSValue
115
              -> Result (String, Instance.Instance)
116
parseInstance ktn (JSArray [ name, disk, mem, vcpus
117
                           , status, pnode, snodes, tags, oram
118
                           , auto_balance, disk_template ]) = do
119
  xname <- annotateResult "Parsing new instance" (fromJVal name)
120
  let convert a = genericConvert "Instance" xname a
121
  xdisk <- convert "disk_usage" disk
122
  xmem <- (case oram of
123
             JSRational _ _ -> convert "oper_ram" oram
124
             _ -> convert "be/memory" mem)
125
  xvcpus <- convert "be/vcpus" vcpus
126
  xpnode <- convert "pnode" pnode >>= lookupNode ktn xname
127
  xsnodes <- convert "snodes" snodes::Result [JSString]
128
  snode <- (if null xsnodes then return Node.noSecondary
129
            else lookupNode ktn xname (fromJSString $ head xsnodes))
130
  xrunning <- convert "status" status
131
  xtags <- convert "tags" tags
132
  xauto_balance <- convert "auto_balance" auto_balance
133
  xdt <- convert "disk_template" disk_template
134
  let inst = Instance.create xname xmem xdisk xvcpus
135
             xrunning xtags xauto_balance xpnode snode xdt
136
  return (xname, inst)
137

    
138
parseInstance _ v = fail ("Invalid instance query result: " ++ show v)
139

    
140
-- | Parse a node list in JSON format.
141
getNodes :: NameAssoc -> JSValue -> Result [(String, Node.Node)]
142
getNodes ktg arr = toArray arr >>= mapM (parseNode ktg)
143

    
144
-- | Construct a node from a JSON object.
145
parseNode :: NameAssoc -> JSValue -> Result (String, Node.Node)
146
parseNode ktg (JSArray [ name, mtotal, mnode, mfree, dtotal, dfree
147
                       , ctotal, offline, drained, vm_capable, g_uuid ])
148
    = do
149
  xname <- annotateResult "Parsing new node" (fromJVal name)
150
  let convert a = genericConvert "Node" xname a
151
  xoffline <- convert "offline" offline
152
  xdrained <- convert "drained" drained
153
  xvm_capable <- convert "vm_capable" vm_capable
154
  xgdx   <- convert "group.uuid" g_uuid >>= lookupGroup ktg xname
155
  node <- (if xoffline || xdrained || not xvm_capable
156
           then return $ Node.create xname 0 0 0 0 0 0 True xgdx
157
           else do
158
             xmtotal  <- convert "mtotal" mtotal
159
             xmnode   <- convert "mnode" mnode
160
             xmfree   <- convert "mfree" mfree
161
             xdtotal  <- convert "dtotal" dtotal
162
             xdfree   <- convert "dfree" dfree
163
             xctotal  <- convert "ctotal" ctotal
164
             return $ Node.create xname xmtotal xmnode xmfree
165
                    xdtotal xdfree xctotal False xgdx)
166
  return (xname, node)
167

    
168
parseNode _ v = fail ("Invalid node query result: " ++ show v)
169

    
170
getClusterTags :: JSValue -> Result [String]
171
getClusterTags v = do
172
  let errmsg = "Parsing cluster info"
173
  obj <- annotateResult errmsg $ asJSObject v
174
  tryFromObj errmsg (fromJSObject obj) "tags"
175

    
176
getGroups :: JSValue -> Result [(String, Group.Group)]
177
getGroups arr = toArray arr >>= mapM parseGroup
178

    
179
parseGroup :: JSValue -> Result (String, Group.Group)
180
parseGroup (JSArray [ uuid, name, apol ]) = do
181
  xname <- annotateResult "Parsing new group" (fromJVal name)
182
  let convert a = genericConvert "Group" xname a
183
  xuuid <- convert "uuid" uuid
184
  xapol <- convert "alloc_policy" apol
185
  return (xuuid, Group.create xname xuuid xapol)
186

    
187
parseGroup v = fail ("Invalid group query result: " ++ show v)
188

    
189
-- * Main loader functionality
190

    
191
-- | Builds the cluster data by querying a given socket name.
192
readData :: String -- ^ Unix socket to use as source
193
         -> IO (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
194
readData master =
195
  E.bracket
196
       (L.getClient master)
197
       L.closeClient
198
       (\s -> do
199
          nodes <- queryNodes s
200
          instances <- queryInstances s
201
          cinfo <- queryClusterInfo s
202
          groups <- queryGroups s
203
          return (groups, nodes, instances, cinfo)
204
       )
205

    
206
-- | Converts the output of 'readData' into the internal cluster
207
-- representation.
208
parseData :: (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
209
          -> Result ClusterData
210
parseData (groups, nodes, instances, cinfo) = do
211
  group_data <- groups >>= getGroups
212
  let (group_names, group_idx) = assignIndices group_data
213
  node_data <- nodes >>= getNodes group_names
214
  let (node_names, node_idx) = assignIndices node_data
215
  inst_data <- instances >>= getInstances node_names
216
  let (_, inst_idx) = assignIndices inst_data
217
  ctags <- cinfo >>= getClusterTags
218
  return (ClusterData group_idx node_idx inst_idx ctags)
219

    
220
-- | Top level function for data loading.
221
loadData :: String -- ^ Unix socket to use as source
222
         -> IO (Result ClusterData)
223
loadData = fmap parseData . readData