Revision 117dc2d8
b/Ganeti/HTools/Luxi.hs | ||
---|---|---|
31 | 31 |
import Data.List |
32 | 32 |
import qualified Control.Exception as E |
33 | 33 |
import Control.Monad |
34 |
import Text.JSON (JSValue, readJSON, JSON) |
|
35 |
import qualified Text.JSON as J |
|
36 | 34 |
import Text.JSON.Types |
37 | 35 |
|
38 | 36 |
import qualified Ganeti.Luxi as L |
... | ... | |
40 | 38 |
import Ganeti.HTools.Types |
41 | 39 |
import qualified Ganeti.HTools.Node as Node |
42 | 40 |
import qualified Ganeti.HTools.Instance as Instance |
41 |
import Ganeti.HTools.Utils (fromJVal, annotateResult) |
|
43 | 42 |
|
44 | 43 |
-- * Utility functions |
45 | 44 |
|
46 |
-- | Small wrapper over readJSON. |
|
47 |
fromJVal :: (Monad m, JSON a) => JSValue -> m a |
|
48 |
fromJVal v = |
|
49 |
case readJSON v of |
|
50 |
J.Error s -> fail ("Cannot convert value " ++ show v ++ ", error: " ++ s) |
|
51 |
J.Ok x -> return x |
|
52 |
|
|
53 | 45 |
-- | Ensure a given JSValue is actually a JSArray. |
54 | 46 |
toArray :: (Monad m) => JSValue -> m [JSValue] |
55 | 47 |
toArray v = |
... | ... | |
102 | 94 |
-> JSValue |
103 | 95 |
-> Result (String, Instance.Instance) |
104 | 96 |
parseInstance ktn (JSArray (name:disk:mem:vcpus:status:pnode:snodes:[])) = do |
105 |
xname <- fromJVal name |
|
106 |
xdisk <- fromJVal disk |
|
107 |
xmem <- fromJVal mem |
|
108 |
xvcpus <- fromJVal vcpus |
|
109 |
xpnode <- fromJVal pnode >>= lookupNode ktn xname |
|
110 |
xsnodes <- fromJVal snodes::Result [JSString] |
|
97 |
xname <- annotateResult "Parsing new instance" (fromJVal name) |
|
98 |
let convert v = annotateResult ("Instance '" ++ xname ++ "'") (fromJVal v) |
|
99 |
xdisk <- convert disk |
|
100 |
xmem <- convert mem |
|
101 |
xvcpus <- convert vcpus |
|
102 |
xpnode <- convert pnode >>= lookupNode ktn xname |
|
103 |
xsnodes <- convert snodes::Result [JSString] |
|
111 | 104 |
snode <- (if null xsnodes then return Node.noSecondary |
112 | 105 |
else lookupNode ktn xname (fromJSString $ head xsnodes)) |
113 |
xrunning <- fromJVal status
|
|
106 |
xrunning <- convert status
|
|
114 | 107 |
let inst = Instance.create xname xmem xdisk xvcpus xrunning xpnode snode |
115 | 108 |
return (xname, inst) |
116 | 109 |
|
... | ... | |
125 | 118 |
parseNode (JSArray |
126 | 119 |
(name:mtotal:mnode:mfree:dtotal:dfree:ctotal:offline:drained:[])) |
127 | 120 |
= do |
128 |
xname <- fromJVal name |
|
129 |
xoffline <- fromJVal offline |
|
121 |
xname <- annotateResult "Parsing new node" (fromJVal name) |
|
122 |
let convert v = annotateResult ("Node '" ++ xname ++ "'") (fromJVal v) |
|
123 |
xoffline <- convert offline |
|
130 | 124 |
node <- (if xoffline |
131 | 125 |
then return $ Node.create xname 0 0 0 0 0 0 True |
132 | 126 |
else do |
133 |
xdrained <- fromJVal drained
|
|
134 |
xmtotal <- fromJVal mtotal
|
|
135 |
xmnode <- fromJVal mnode
|
|
136 |
xmfree <- fromJVal mfree
|
|
137 |
xdtotal <- fromJVal dtotal
|
|
138 |
xdfree <- fromJVal dfree
|
|
139 |
xctotal <- fromJVal ctotal
|
|
127 |
xdrained <- convert drained
|
|
128 |
xmtotal <- convert mtotal
|
|
129 |
xmnode <- convert mnode
|
|
130 |
xmfree <- convert mfree
|
|
131 |
xdtotal <- convert dtotal
|
|
132 |
xdfree <- convert dfree
|
|
133 |
xctotal <- convert ctotal
|
|
140 | 134 |
return $ Node.create xname xmtotal xmnode xmfree |
141 | 135 |
xdtotal xdfree xctotal (xoffline || xdrained)) |
142 | 136 |
return (xname, node) |
b/Ganeti/HTools/Rapi.hs | ||
---|---|---|
77 | 77 |
-> [(String, JSValue)] |
78 | 78 |
-> Result (String, Instance.Instance) |
79 | 79 |
parseInstance ktn a = do |
80 |
name <- fromObj "name" a |
|
81 |
disk <- fromObj "disk_usage" a |
|
82 |
mem <- fromObj "beparams" a >>= fromObj "memory" . fromJSObject |
|
83 |
vcpus <- fromObj "beparams" a >>= fromObj "vcpus" . fromJSObject |
|
84 |
pnode <- fromObj "pnode" a >>= lookupNode ktn name |
|
85 |
snodes <- fromObj "snodes" a |
|
80 |
name <- tryFromObj "Parsing new instance" a "name" |
|
81 |
let extract s x = tryFromObj ("Instance '" ++ name ++ "'") x s |
|
82 |
disk <- extract "disk_usage" a |
|
83 |
beparams <- liftM fromJSObject (extract "beparams" a) |
|
84 |
mem <- extract "memory" beparams |
|
85 |
vcpus <- extract "vcpus" beparams |
|
86 |
pnode <- extract "pnode" a >>= lookupNode ktn name |
|
87 |
snodes <- extract "snodes" a |
|
86 | 88 |
snode <- (if null snodes then return Node.noSecondary |
87 | 89 |
else readEitherString (head snodes) >>= lookupNode ktn name) |
88 |
running <- fromObj "status" a
|
|
90 |
running <- extract "status" a
|
|
89 | 91 |
let inst = Instance.create name mem disk vcpus running pnode snode |
90 | 92 |
return (name, inst) |
91 | 93 |
|
92 | 94 |
-- | Construct a node from a JSON object. |
93 | 95 |
parseNode :: [(String, JSValue)] -> Result (String, Node.Node) |
94 | 96 |
parseNode a = do |
95 |
name <- fromObj "name" a |
|
96 |
offline <- fromObj "offline" a |
|
97 |
name <- tryFromObj "Parsing new node" a "name" |
|
98 |
let extract s = tryFromObj ("Node '" ++ name ++ "'") a s |
|
99 |
offline <- extract "offline" |
|
97 | 100 |
node <- (if offline |
98 | 101 |
then return $ Node.create name 0 0 0 0 0 0 True |
99 | 102 |
else do |
100 |
drained <- fromObj "drained" a
|
|
101 |
mtotal <- fromObj "mtotal" a
|
|
102 |
mnode <- fromObj "mnode" a
|
|
103 |
mfree <- fromObj "mfree" a
|
|
104 |
dtotal <- fromObj "dtotal" a
|
|
105 |
dfree <- fromObj "dfree" a
|
|
106 |
ctotal <- fromObj "ctotal" a
|
|
103 |
drained <- extract "drained"
|
|
104 |
mtotal <- extract "mtotal"
|
|
105 |
mnode <- extract "mnode"
|
|
106 |
mfree <- extract "mfree"
|
|
107 |
dtotal <- extract "dtotal"
|
|
108 |
dfree <- extract "dfree"
|
|
109 |
ctotal <- extract "ctotal"
|
|
107 | 110 |
return $ Node.create name mtotal mnode mfree |
108 | 111 |
dtotal dfree ctotal (offline || drained)) |
109 | 112 |
return (name, node) |
b/Ganeti/HTools/Utils.hs | ||
---|---|---|
31 | 31 |
, readEitherString |
32 | 32 |
, loadJSArray |
33 | 33 |
, fromObj |
34 |
, tryFromObj |
|
35 |
, fromJVal |
|
34 | 36 |
, asJSObject |
35 | 37 |
, asObjectList |
36 | 38 |
, fromJResult |
37 | 39 |
, tryRead |
38 | 40 |
, formatTable |
41 |
, annotateResult |
|
39 | 42 |
) where |
40 | 43 |
|
41 | 44 |
import Data.List |
... | ... | |
45 | 48 |
|
46 | 49 |
import Debug.Trace |
47 | 50 |
|
51 |
import Ganeti.HTools.Types |
|
52 |
|
|
48 | 53 |
-- * Debug functions |
49 | 54 |
|
50 | 55 |
-- | To be used only for debugging, breaks referential integrity. |
... | ... | |
119 | 124 |
Nothing -> fail $ printf "key '%s' not found in %s" k (show o) |
120 | 125 |
Just val -> fromJResult $ J.readJSON val |
121 | 126 |
|
127 |
-- | Annotate a Result with an ownership information |
|
128 |
annotateResult :: String -> Result a -> Result a |
|
129 |
annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s |
|
130 |
annotateResult _ v = v |
|
131 |
|
|
132 |
-- | Try to extract a key from a object with better error reporting |
|
133 |
-- than fromObj |
|
134 |
tryFromObj :: (J.JSON a) => |
|
135 |
String -> [(String, J.JSValue)] -> String -> Result a |
|
136 |
tryFromObj t o k = annotateResult (t ++ " key '" ++ k ++ "'") (fromObj k o) |
|
137 |
|
|
138 |
-- | Small wrapper over readJSON. |
|
139 |
fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a |
|
140 |
fromJVal v = |
|
141 |
case J.readJSON v of |
|
142 |
J.Error s -> fail ("Cannot convert value " ++ show v ++ ", error: " ++ s) |
|
143 |
J.Ok x -> return x |
|
144 |
|
|
122 | 145 |
-- | Converts a JSON value into a JSON object. |
123 | 146 |
asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue) |
124 | 147 |
asJSObject (J.JSObject a) = return a |
Also available in: Unified diff