Statistics
| Branch: | Tag: | Revision:

root / Ganeti / HTools / Luxi.hs @ 1cea2e1e

History | View | Annotate | Download (6 kB)

1
{-| Implementation of the LUXI loader.
2

    
3
-}
4

    
5
{-
6

    
7
Copyright (C) 2009 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
    ) where
30

    
31
import Data.List
32
import qualified Control.Exception as E
33
import Control.Monad
34
import Text.JSON.Types
35

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

    
43
-- * Utility functions
44

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

    
52
-- * Data querying functionality
53

    
54
-- | The input data for node query.
55
queryNodesMsg :: JSValue
56
queryNodesMsg =
57
    let nnames = JSArray []
58
        fnames = ["name",
59
                  "mtotal", "mnode", "mfree",
60
                  "dtotal", "dfree",
61
                  "ctotal",
62
                  "offline", "drained"]
63
        fields = JSArray $ map (JSString . toJSString) fnames
64
        use_locking = JSBool False
65
    in JSArray [nnames, fields, use_locking]
66

    
67
-- | The input data for instance query.
68
queryInstancesMsg :: JSValue
69
queryInstancesMsg =
70
    let nnames = JSArray []
71
        fnames = ["name",
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]
77

    
78
-- | The input data for cluster query
79
queryClusterInfoMsg :: JSValue
80
queryClusterInfoMsg = JSArray []
81

    
82
-- | Wraper over callMethod doing node query.
83
queryNodes :: L.Client -> IO (Result JSValue)
84
queryNodes = L.callMethod L.QueryNodes queryNodesMsg
85

    
86
-- | Wraper over callMethod doing instance query.
87
queryInstances :: L.Client -> IO (Result JSValue)
88
queryInstances = L.callMethod L.QueryInstances queryInstancesMsg
89

    
90
queryClusterInfo :: L.Client -> IO (Result JSValue)
91
queryClusterInfo = L.callMethod L.QueryClusterInfo queryClusterInfoMsg
92

    
93
-- | Parse a instance list in JSON format.
94
getInstances :: NameAssoc
95
             -> JSValue
96
             -> Result [(String, Instance.Instance)]
97
getInstances ktn arr = toArray arr >>= mapM (parseInstance ktn)
98

    
99
-- | Construct an instance from a JSON object.
100
parseInstance :: [(String, Ndx)]
101
              -> JSValue
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
108
  xmem <- convert mem
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
118
  return (xname, inst)
119

    
120
parseInstance _ v = fail ("Invalid instance query result: " ++ show v)
121

    
122
-- | Parse a node list in JSON format.
123
getNodes :: JSValue -> Result [(String, Node.Node)]
124
getNodes arr = toArray arr >>= mapM parseNode
125

    
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 ])
130
    = do
131
  xname <- annotateResult "Parsing new node" (fromJVal name)
132
  let convert v = annotateResult ("Node '" ++ xname ++ "'") (fromJVal v)
133
  xoffline <- convert offline
134
  node <- (if xoffline
135
           then return $ Node.create xname 0 0 0 0 0 0 True
136
           else do
137
             xdrained <- convert drained
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 (xoffline || xdrained))
146
  return (xname, node)
147

    
148
parseNode v = fail ("Invalid node query result: " ++ show v)
149

    
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"
155
  return tags
156

    
157
-- * Main loader functionality
158

    
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]))
162
loadData master =
163
  E.bracket
164
       (L.getClient master)
165
       L.closeClient
166
       (\s -> do
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)
177
       )