Revision f3baf5ef
b/Makefile.am | ||
---|---|---|
387 | 387 |
HS_LIB_SRCS = \ |
388 | 388 |
htools/Ganeti/HTools/CLI.hs \ |
389 | 389 |
htools/Ganeti/HTools/Cluster.hs \ |
390 |
htools/Ganeti/HTools/Compat.hs \ |
|
391 | 390 |
htools/Ganeti/HTools/Container.hs \ |
392 | 391 |
htools/Ganeti/HTools/ExtLoader.hs \ |
393 | 392 |
htools/Ganeti/HTools/Group.hs \ |
394 | 393 |
htools/Ganeti/HTools/IAlloc.hs \ |
395 | 394 |
htools/Ganeti/HTools/Instance.hs \ |
396 |
htools/Ganeti/HTools/JSON.hs \ |
|
397 | 395 |
htools/Ganeti/HTools/Loader.hs \ |
398 | 396 |
htools/Ganeti/HTools/Luxi.hs \ |
399 | 397 |
htools/Ganeti/HTools/Node.hs \ |
... | ... | |
412 | 410 |
htools/Ganeti/HTools/Program/Hscan.hs \ |
413 | 411 |
htools/Ganeti/HTools/Program/Hspace.hs \ |
414 | 412 |
htools/Ganeti/BasicTypes.hs \ |
413 |
htools/Ganeti/Compat.hs \ |
|
415 | 414 |
htools/Ganeti/Confd.hs \ |
416 | 415 |
htools/Ganeti/Confd/Server.hs \ |
417 | 416 |
htools/Ganeti/Confd/Utils.hs \ |
... | ... | |
419 | 418 |
htools/Ganeti/Daemon.hs \ |
420 | 419 |
htools/Ganeti/Hash.hs \ |
421 | 420 |
htools/Ganeti/Jobs.hs \ |
421 |
htools/Ganeti/JSON.hs \ |
|
422 | 422 |
htools/Ganeti/Logging.hs \ |
423 | 423 |
htools/Ganeti/Luxi.hs \ |
424 | 424 |
htools/Ganeti/Objects.hs \ |
b/htest/Test/Ganeti/HTools/Utils.hs | ||
---|---|---|
35 | 35 |
import Test.Ganeti.TestHelper |
36 | 36 |
import Test.Ganeti.TestCommon |
37 | 37 |
|
38 |
import qualified Ganeti.HTools.JSON as JSON
|
|
38 |
import qualified Ganeti.JSON as JSON |
|
39 | 39 |
import qualified Ganeti.HTools.Types as Types |
40 | 40 |
import qualified Ganeti.HTools.Utils as Utils |
41 | 41 |
|
b/htools/Ganeti/Compat.hs | ||
---|---|---|
1 |
{-# LANGUAGE CPP #-} |
|
2 |
|
|
3 |
{- | Compatibility helper module. |
|
4 |
|
|
5 |
This module holds definitions that help with supporting multiple |
|
6 |
library versions or transitions between versions. |
|
7 |
|
|
8 |
-} |
|
9 |
|
|
10 |
{- |
|
11 |
|
|
12 |
Copyright (C) 2011, 2012 Google Inc. |
|
13 |
|
|
14 |
This program is free software; you can redistribute it and/or modify |
|
15 |
it under the terms of the GNU General Public License as published by |
|
16 |
the Free Software Foundation; either version 2 of the License, or |
|
17 |
(at your option) any later version. |
|
18 |
|
|
19 |
This program is distributed in the hope that it will be useful, but |
|
20 |
WITHOUT ANY WARRANTY; without even the implied warranty of |
|
21 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
|
22 |
General Public License for more details. |
|
23 |
|
|
24 |
You should have received a copy of the GNU General Public License |
|
25 |
along with this program; if not, write to the Free Software |
|
26 |
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
|
27 |
02110-1301, USA. |
|
28 |
|
|
29 |
-} |
|
30 |
|
|
31 |
module Ganeti.Compat |
|
32 |
( rwhnf |
|
33 |
, Control.Parallel.Strategies.parMap |
|
34 |
) where |
|
35 |
|
|
36 |
import qualified Control.Parallel.Strategies |
|
37 |
|
|
38 |
-- | Wrapper over the function exported from |
|
39 |
-- "Control.Parallel.Strategies". |
|
40 |
-- |
|
41 |
-- This wraps either the old or the new name of the function, |
|
42 |
-- depending on the detected library version. |
|
43 |
rwhnf :: Control.Parallel.Strategies.Strategy a |
|
44 |
#ifdef PARALLEL3 |
|
45 |
rwhnf = Control.Parallel.Strategies.rseq |
|
46 |
#else |
|
47 |
rwhnf = Control.Parallel.Strategies.rwhnf |
|
48 |
#endif |
b/htools/Ganeti/Confd.hs | ||
---|---|---|
50 | 50 |
|
51 | 51 |
import qualified Ganeti.Constants as C |
52 | 52 |
import Ganeti.THH |
53 |
import Ganeti.HTools.JSON
|
|
53 |
import Ganeti.JSON |
|
54 | 54 |
|
55 | 55 |
{- |
56 | 56 |
Note that we re-export as is from Constants the following simple items: |
b/htools/Ganeti/Confd/Server.hs | ||
---|---|---|
45 | 45 |
import System.INotify |
46 | 46 |
|
47 | 47 |
import Ganeti.Daemon |
48 |
import Ganeti.HTools.JSON
|
|
48 |
import Ganeti.JSON |
|
49 | 49 |
import Ganeti.HTools.Types |
50 | 50 |
import Ganeti.HTools.Utils |
51 | 51 |
import Ganeti.Objects |
b/htools/Ganeti/Confd/Utils.hs | ||
---|---|---|
40 | 40 |
import Ganeti.Confd |
41 | 41 |
import Ganeti.Hash |
42 | 42 |
import qualified Ganeti.Constants as C |
43 |
import Ganeti.HTools.JSON
|
|
43 |
import Ganeti.JSON |
|
44 | 44 |
import Ganeti.HTools.Utils |
45 | 45 |
|
46 | 46 |
-- | Returns the HMAC key. |
b/htools/Ganeti/Config.hs | ||
---|---|---|
49 | 49 |
import qualified Data.Set as S |
50 | 50 |
import qualified Text.JSON as J |
51 | 51 |
|
52 |
import Ganeti.HTools.JSON
|
|
52 |
import Ganeti.JSON |
|
53 | 53 |
import Ganeti.BasicTypes |
54 | 54 |
|
55 | 55 |
import qualified Ganeti.Constants as C |
b/htools/Ganeti/HTools/Cluster.hs | ||
---|---|---|
87 | 87 |
import qualified Ganeti.HTools.Group as Group |
88 | 88 |
import Ganeti.HTools.Types |
89 | 89 |
import Ganeti.HTools.Utils |
90 |
import Ganeti.HTools.Compat
|
|
90 |
import Ganeti.Compat |
|
91 | 91 |
import qualified Ganeti.OpCodes as OpCodes |
92 | 92 |
|
93 | 93 |
-- * Types |
/dev/null | ||
---|---|---|
1 |
{-# LANGUAGE CPP #-} |
|
2 |
|
|
3 |
{- | Compatibility helper module. |
|
4 |
|
|
5 |
This module holds definitions that help with supporting multiple |
|
6 |
library versions or transitions between versions. |
|
7 |
|
|
8 |
-} |
|
9 |
|
|
10 |
{- |
|
11 |
|
|
12 |
Copyright (C) 2011 Google Inc. |
|
13 |
|
|
14 |
This program is free software; you can redistribute it and/or modify |
|
15 |
it under the terms of the GNU General Public License as published by |
|
16 |
the Free Software Foundation; either version 2 of the License, or |
|
17 |
(at your option) any later version. |
|
18 |
|
|
19 |
This program is distributed in the hope that it will be useful, but |
|
20 |
WITHOUT ANY WARRANTY; without even the implied warranty of |
|
21 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
|
22 |
General Public License for more details. |
|
23 |
|
|
24 |
You should have received a copy of the GNU General Public License |
|
25 |
along with this program; if not, write to the Free Software |
|
26 |
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
|
27 |
02110-1301, USA. |
|
28 |
|
|
29 |
-} |
|
30 |
|
|
31 |
module Ganeti.HTools.Compat |
|
32 |
( rwhnf |
|
33 |
, Control.Parallel.Strategies.parMap |
|
34 |
) where |
|
35 |
|
|
36 |
import qualified Control.Parallel.Strategies |
|
37 |
|
|
38 |
-- | Wrapper over the function exported from |
|
39 |
-- "Control.Parallel.Strategies". |
|
40 |
-- |
|
41 |
-- This wraps either the old or the new name of the function, |
|
42 |
-- depending on the detected library version. |
|
43 |
rwhnf :: Control.Parallel.Strategies.Strategy a |
|
44 |
#ifdef PARALLEL3 |
|
45 |
rwhnf = Control.Parallel.Strategies.rseq |
|
46 |
#else |
|
47 |
rwhnf = Control.Parallel.Strategies.rwhnf |
|
48 |
#endif |
b/htools/Ganeti/HTools/IAlloc.hs | ||
---|---|---|
47 | 47 |
import qualified Ganeti.Constants as C |
48 | 48 |
import Ganeti.HTools.CLI |
49 | 49 |
import Ganeti.HTools.Loader |
50 |
import Ganeti.HTools.JSON |
|
51 | 50 |
import Ganeti.HTools.Types |
51 |
import Ganeti.JSON |
|
52 | 52 |
|
53 | 53 |
{-# ANN module "HLint: ignore Eta reduce" #-} |
54 | 54 |
|
/dev/null | ||
---|---|---|
1 |
{-| JSON utility functions. -} |
|
2 |
|
|
3 |
{- |
|
4 |
|
|
5 |
Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |
|
6 |
|
|
7 |
This program is free software; you can redistribute it and/or modify |
|
8 |
it under the terms of the GNU General Public License as published by |
|
9 |
the Free Software Foundation; either version 2 of the License, or |
|
10 |
(at your option) any later version. |
|
11 |
|
|
12 |
This program is distributed in the hope that it will be useful, but |
|
13 |
WITHOUT ANY WARRANTY; without even the implied warranty of |
|
14 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
|
15 |
General Public License for more details. |
|
16 |
|
|
17 |
You should have received a copy of the GNU General Public License |
|
18 |
along with this program; if not, write to the Free Software |
|
19 |
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
|
20 |
02110-1301, USA. |
|
21 |
|
|
22 |
-} |
|
23 |
|
|
24 |
module Ganeti.HTools.JSON |
|
25 |
( fromJResult |
|
26 |
, readEitherString |
|
27 |
, JSRecord |
|
28 |
, loadJSArray |
|
29 |
, fromObj |
|
30 |
, maybeFromObj |
|
31 |
, fromObjWithDefault |
|
32 |
, fromKeyValue |
|
33 |
, fromJVal |
|
34 |
, asJSObject |
|
35 |
, asObjectList |
|
36 |
, tryFromObj |
|
37 |
, toArray |
|
38 |
, Container(..) |
|
39 |
) |
|
40 |
where |
|
41 |
|
|
42 |
import Control.Arrow (second) |
|
43 |
import Control.Monad (liftM) |
|
44 |
import Data.Maybe (fromMaybe) |
|
45 |
import qualified Data.Map as Map |
|
46 |
import Text.Printf (printf) |
|
47 |
|
|
48 |
import qualified Text.JSON as J |
|
49 |
import Text.JSON.Pretty (pp_value) |
|
50 |
|
|
51 |
import Ganeti.BasicTypes |
|
52 |
|
|
53 |
-- * JSON-related functions |
|
54 |
|
|
55 |
-- | A type alias for the list-based representation of J.JSObject. |
|
56 |
type JSRecord = [(String, J.JSValue)] |
|
57 |
|
|
58 |
-- | Converts a JSON Result into a monadic value. |
|
59 |
fromJResult :: Monad m => String -> J.Result a -> m a |
|
60 |
fromJResult s (J.Error x) = fail (s ++ ": " ++ x) |
|
61 |
fromJResult _ (J.Ok x) = return x |
|
62 |
|
|
63 |
-- | Tries to read a string from a JSON value. |
|
64 |
-- |
|
65 |
-- In case the value was not a string, we fail the read (in the |
|
66 |
-- context of the current monad. |
|
67 |
readEitherString :: (Monad m) => J.JSValue -> m String |
|
68 |
readEitherString v = |
|
69 |
case v of |
|
70 |
J.JSString s -> return $ J.fromJSString s |
|
71 |
_ -> fail "Wrong JSON type" |
|
72 |
|
|
73 |
-- | Converts a JSON message into an array of JSON objects. |
|
74 |
loadJSArray :: (Monad m) |
|
75 |
=> String -- ^ Operation description (for error reporting) |
|
76 |
-> String -- ^ Input message |
|
77 |
-> m [J.JSObject J.JSValue] |
|
78 |
loadJSArray s = fromJResult s . J.decodeStrict |
|
79 |
|
|
80 |
-- | Reads the value of a key in a JSON object. |
|
81 |
fromObj :: (J.JSON a, Monad m) => JSRecord -> String -> m a |
|
82 |
fromObj o k = |
|
83 |
case lookup k o of |
|
84 |
Nothing -> fail $ printf "key '%s' not found, object contains only %s" |
|
85 |
k (show (map fst o)) |
|
86 |
Just val -> fromKeyValue k val |
|
87 |
|
|
88 |
-- | Reads the value of an optional key in a JSON object. Missing |
|
89 |
-- keys, or keys that have a \'null\' value, will be returned as |
|
90 |
-- 'Nothing', otherwise we attempt deserialisation and return a 'Just' |
|
91 |
-- value. |
|
92 |
maybeFromObj :: (J.JSON a, Monad m) => |
|
93 |
JSRecord -> String -> m (Maybe a) |
|
94 |
maybeFromObj o k = |
|
95 |
case lookup k o of |
|
96 |
Nothing -> return Nothing |
|
97 |
-- a optional key with value JSNull is the same as missing, since |
|
98 |
-- we can't convert it meaningfully anyway to a Haskell type, and |
|
99 |
-- the Python code can emit 'null' for optional values (depending |
|
100 |
-- on usage), and finally our encoding rules treat 'null' values |
|
101 |
-- as 'missing' |
|
102 |
Just J.JSNull -> return Nothing |
|
103 |
Just val -> liftM Just (fromKeyValue k val) |
|
104 |
|
|
105 |
-- | Reads the value of a key in a JSON object with a default if |
|
106 |
-- missing. Note that both missing keys and keys with value \'null\' |
|
107 |
-- will case the default value to be returned. |
|
108 |
fromObjWithDefault :: (J.JSON a, Monad m) => |
|
109 |
JSRecord -> String -> a -> m a |
|
110 |
fromObjWithDefault o k d = liftM (fromMaybe d) $ maybeFromObj o k |
|
111 |
|
|
112 |
-- | Reads a JValue, that originated from an object key. |
|
113 |
fromKeyValue :: (J.JSON a, Monad m) |
|
114 |
=> String -- ^ The key name |
|
115 |
-> J.JSValue -- ^ The value to read |
|
116 |
-> m a |
|
117 |
fromKeyValue k val = |
|
118 |
fromJResult (printf "key '%s'" k) (J.readJSON val) |
|
119 |
|
|
120 |
-- | Small wrapper over readJSON. |
|
121 |
fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a |
|
122 |
fromJVal v = |
|
123 |
case J.readJSON v of |
|
124 |
J.Error s -> fail ("Cannot convert value '" ++ show (pp_value v) ++ |
|
125 |
"', error: " ++ s) |
|
126 |
J.Ok x -> return x |
|
127 |
|
|
128 |
-- | Converts a JSON value into a JSON object. |
|
129 |
asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue) |
|
130 |
asJSObject (J.JSObject a) = return a |
|
131 |
asJSObject _ = fail "not an object" |
|
132 |
|
|
133 |
-- | Coneverts a list of JSON values into a list of JSON objects. |
|
134 |
asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue] |
|
135 |
asObjectList = mapM asJSObject |
|
136 |
|
|
137 |
-- | Try to extract a key from a object with better error reporting |
|
138 |
-- than fromObj. |
|
139 |
tryFromObj :: (J.JSON a) => |
|
140 |
String -- ^ Textual "owner" in error messages |
|
141 |
-> JSRecord -- ^ The object array |
|
142 |
-> String -- ^ The desired key from the object |
|
143 |
-> Result a |
|
144 |
tryFromObj t o = annotateResult t . fromObj o |
|
145 |
|
|
146 |
-- | Ensure a given JSValue is actually a JSArray. |
|
147 |
toArray :: (Monad m) => J.JSValue -> m [J.JSValue] |
|
148 |
toArray (J.JSArray arr) = return arr |
|
149 |
toArray o = |
|
150 |
fail $ "Invalid input, expected array but got " ++ show (pp_value o) |
|
151 |
|
|
152 |
-- * Container type (special type for JSON serialisation) |
|
153 |
|
|
154 |
-- | The container type, a wrapper over Data.Map |
|
155 |
newtype Container a = Container { fromContainer :: Map.Map String a } |
|
156 |
deriving (Show, Read, Eq) |
|
157 |
|
|
158 |
-- | Container loader. |
|
159 |
readContainer :: (Monad m, J.JSON a) => |
|
160 |
J.JSObject J.JSValue -> m (Container a) |
|
161 |
readContainer obj = do |
|
162 |
let kjvlist = J.fromJSObject obj |
|
163 |
kalist <- mapM (\(k, v) -> fromKeyValue k v >>= \a -> return (k, a)) kjvlist |
|
164 |
return $ Container (Map.fromList kalist) |
|
165 |
|
|
166 |
-- | Container dumper. |
|
167 |
showContainer :: (J.JSON a) => Container a -> J.JSValue |
|
168 |
showContainer = |
|
169 |
J.makeObj . map (second J.showJSON) . Map.toList . fromContainer |
|
170 |
|
|
171 |
instance (J.JSON a) => J.JSON (Container a) where |
|
172 |
showJSON = showContainer |
|
173 |
readJSON (J.JSObject o) = readContainer o |
|
174 |
readJSON v = fail $ "Failed to load container, expected object but got " |
|
175 |
++ show (pp_value v) |
b/htools/Ganeti/HTools/Luxi.hs | ||
---|---|---|
39 | 39 |
import qualified Ganeti.HTools.Group as Group |
40 | 40 |
import qualified Ganeti.HTools.Node as Node |
41 | 41 |
import qualified Ganeti.HTools.Instance as Instance |
42 |
import Ganeti.HTools.JSON
|
|
42 |
import Ganeti.JSON |
|
43 | 43 |
|
44 | 44 |
{-# ANN module "HLint: ignore Eta reduce" #-} |
45 | 45 |
|
b/htools/Ganeti/HTools/QC.hs | ||
---|---|---|
79 | 79 |
import qualified Ganeti.HTools.Group as Group |
80 | 80 |
import qualified Ganeti.HTools.IAlloc as IAlloc |
81 | 81 |
import qualified Ganeti.HTools.Instance as Instance |
82 |
import qualified Ganeti.HTools.JSON as JSON
|
|
82 |
import qualified Ganeti.JSON as JSON |
|
83 | 83 |
import qualified Ganeti.HTools.Loader as Loader |
84 | 84 |
import qualified Ganeti.HTools.Luxi as HTools.Luxi |
85 | 85 |
import qualified Ganeti.HTools.Node as Node |
b/htools/Ganeti/HTools/Rapi.hs | ||
---|---|---|
46 | 46 |
|
47 | 47 |
import Ganeti.HTools.Loader |
48 | 48 |
import Ganeti.HTools.Types |
49 |
import Ganeti.HTools.JSON
|
|
49 |
import Ganeti.JSON |
|
50 | 50 |
import qualified Ganeti.HTools.Group as Group |
51 | 51 |
import qualified Ganeti.HTools.Node as Node |
52 | 52 |
import qualified Ganeti.HTools.Instance as Instance |
b/htools/Ganeti/HTools/Types.hs | ||
---|---|---|
87 | 87 |
import qualified Ganeti.Constants as C |
88 | 88 |
import qualified Ganeti.THH as THH |
89 | 89 |
import Ganeti.BasicTypes |
90 |
import Ganeti.HTools.JSON
|
|
90 |
import Ganeti.JSON |
|
91 | 91 |
|
92 | 92 |
-- | The instance index type. |
93 | 93 |
type Idx = Int |
b/htools/Ganeti/JSON.hs | ||
---|---|---|
1 |
{-| JSON utility functions. -} |
|
2 |
|
|
3 |
{- |
|
4 |
|
|
5 |
Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |
|
6 |
|
|
7 |
This program is free software; you can redistribute it and/or modify |
|
8 |
it under the terms of the GNU General Public License as published by |
|
9 |
the Free Software Foundation; either version 2 of the License, or |
|
10 |
(at your option) any later version. |
|
11 |
|
|
12 |
This program is distributed in the hope that it will be useful, but |
|
13 |
WITHOUT ANY WARRANTY; without even the implied warranty of |
|
14 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
|
15 |
General Public License for more details. |
|
16 |
|
|
17 |
You should have received a copy of the GNU General Public License |
|
18 |
along with this program; if not, write to the Free Software |
|
19 |
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
|
20 |
02110-1301, USA. |
|
21 |
|
|
22 |
-} |
|
23 |
|
|
24 |
module Ganeti.JSON |
|
25 |
( fromJResult |
|
26 |
, readEitherString |
|
27 |
, JSRecord |
|
28 |
, loadJSArray |
|
29 |
, fromObj |
|
30 |
, maybeFromObj |
|
31 |
, fromObjWithDefault |
|
32 |
, fromKeyValue |
|
33 |
, fromJVal |
|
34 |
, asJSObject |
|
35 |
, asObjectList |
|
36 |
, tryFromObj |
|
37 |
, toArray |
|
38 |
, Container(..) |
|
39 |
) |
|
40 |
where |
|
41 |
|
|
42 |
import Control.Arrow (second) |
|
43 |
import Control.Monad (liftM) |
|
44 |
import Data.Maybe (fromMaybe) |
|
45 |
import qualified Data.Map as Map |
|
46 |
import Text.Printf (printf) |
|
47 |
|
|
48 |
import qualified Text.JSON as J |
|
49 |
import Text.JSON.Pretty (pp_value) |
|
50 |
|
|
51 |
import Ganeti.BasicTypes |
|
52 |
|
|
53 |
-- * JSON-related functions |
|
54 |
|
|
55 |
-- | A type alias for the list-based representation of J.JSObject. |
|
56 |
type JSRecord = [(String, J.JSValue)] |
|
57 |
|
|
58 |
-- | Converts a JSON Result into a monadic value. |
|
59 |
fromJResult :: Monad m => String -> J.Result a -> m a |
|
60 |
fromJResult s (J.Error x) = fail (s ++ ": " ++ x) |
|
61 |
fromJResult _ (J.Ok x) = return x |
|
62 |
|
|
63 |
-- | Tries to read a string from a JSON value. |
|
64 |
-- |
|
65 |
-- In case the value was not a string, we fail the read (in the |
|
66 |
-- context of the current monad. |
|
67 |
readEitherString :: (Monad m) => J.JSValue -> m String |
|
68 |
readEitherString v = |
|
69 |
case v of |
|
70 |
J.JSString s -> return $ J.fromJSString s |
|
71 |
_ -> fail "Wrong JSON type" |
|
72 |
|
|
73 |
-- | Converts a JSON message into an array of JSON objects. |
|
74 |
loadJSArray :: (Monad m) |
|
75 |
=> String -- ^ Operation description (for error reporting) |
|
76 |
-> String -- ^ Input message |
|
77 |
-> m [J.JSObject J.JSValue] |
|
78 |
loadJSArray s = fromJResult s . J.decodeStrict |
|
79 |
|
|
80 |
-- | Reads the value of a key in a JSON object. |
|
81 |
fromObj :: (J.JSON a, Monad m) => JSRecord -> String -> m a |
|
82 |
fromObj o k = |
|
83 |
case lookup k o of |
|
84 |
Nothing -> fail $ printf "key '%s' not found, object contains only %s" |
|
85 |
k (show (map fst o)) |
|
86 |
Just val -> fromKeyValue k val |
|
87 |
|
|
88 |
-- | Reads the value of an optional key in a JSON object. Missing |
|
89 |
-- keys, or keys that have a \'null\' value, will be returned as |
|
90 |
-- 'Nothing', otherwise we attempt deserialisation and return a 'Just' |
|
91 |
-- value. |
|
92 |
maybeFromObj :: (J.JSON a, Monad m) => |
|
93 |
JSRecord -> String -> m (Maybe a) |
|
94 |
maybeFromObj o k = |
|
95 |
case lookup k o of |
|
96 |
Nothing -> return Nothing |
|
97 |
-- a optional key with value JSNull is the same as missing, since |
|
98 |
-- we can't convert it meaningfully anyway to a Haskell type, and |
|
99 |
-- the Python code can emit 'null' for optional values (depending |
|
100 |
-- on usage), and finally our encoding rules treat 'null' values |
|
101 |
-- as 'missing' |
|
102 |
Just J.JSNull -> return Nothing |
|
103 |
Just val -> liftM Just (fromKeyValue k val) |
|
104 |
|
|
105 |
-- | Reads the value of a key in a JSON object with a default if |
|
106 |
-- missing. Note that both missing keys and keys with value \'null\' |
|
107 |
-- will case the default value to be returned. |
|
108 |
fromObjWithDefault :: (J.JSON a, Monad m) => |
|
109 |
JSRecord -> String -> a -> m a |
|
110 |
fromObjWithDefault o k d = liftM (fromMaybe d) $ maybeFromObj o k |
|
111 |
|
|
112 |
-- | Reads a JValue, that originated from an object key. |
|
113 |
fromKeyValue :: (J.JSON a, Monad m) |
|
114 |
=> String -- ^ The key name |
|
115 |
-> J.JSValue -- ^ The value to read |
|
116 |
-> m a |
|
117 |
fromKeyValue k val = |
|
118 |
fromJResult (printf "key '%s'" k) (J.readJSON val) |
|
119 |
|
|
120 |
-- | Small wrapper over readJSON. |
|
121 |
fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a |
|
122 |
fromJVal v = |
|
123 |
case J.readJSON v of |
|
124 |
J.Error s -> fail ("Cannot convert value '" ++ show (pp_value v) ++ |
|
125 |
"', error: " ++ s) |
|
126 |
J.Ok x -> return x |
|
127 |
|
|
128 |
-- | Converts a JSON value into a JSON object. |
|
129 |
asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue) |
|
130 |
asJSObject (J.JSObject a) = return a |
|
131 |
asJSObject _ = fail "not an object" |
|
132 |
|
|
133 |
-- | Coneverts a list of JSON values into a list of JSON objects. |
|
134 |
asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue] |
|
135 |
asObjectList = mapM asJSObject |
|
136 |
|
|
137 |
-- | Try to extract a key from a object with better error reporting |
|
138 |
-- than fromObj. |
|
139 |
tryFromObj :: (J.JSON a) => |
|
140 |
String -- ^ Textual "owner" in error messages |
|
141 |
-> JSRecord -- ^ The object array |
|
142 |
-> String -- ^ The desired key from the object |
|
143 |
-> Result a |
|
144 |
tryFromObj t o = annotateResult t . fromObj o |
|
145 |
|
|
146 |
-- | Ensure a given JSValue is actually a JSArray. |
|
147 |
toArray :: (Monad m) => J.JSValue -> m [J.JSValue] |
|
148 |
toArray (J.JSArray arr) = return arr |
|
149 |
toArray o = |
|
150 |
fail $ "Invalid input, expected array but got " ++ show (pp_value o) |
|
151 |
|
|
152 |
-- * Container type (special type for JSON serialisation) |
|
153 |
|
|
154 |
-- | The container type, a wrapper over Data.Map |
|
155 |
newtype Container a = Container { fromContainer :: Map.Map String a } |
|
156 |
deriving (Show, Read, Eq) |
|
157 |
|
|
158 |
-- | Container loader. |
|
159 |
readContainer :: (Monad m, J.JSON a) => |
|
160 |
J.JSObject J.JSValue -> m (Container a) |
|
161 |
readContainer obj = do |
|
162 |
let kjvlist = J.fromJSObject obj |
|
163 |
kalist <- mapM (\(k, v) -> fromKeyValue k v >>= \a -> return (k, a)) kjvlist |
|
164 |
return $ Container (Map.fromList kalist) |
|
165 |
|
|
166 |
-- | Container dumper. |
|
167 |
showContainer :: (J.JSON a) => Container a -> J.JSValue |
|
168 |
showContainer = |
|
169 |
J.makeObj . map (second J.showJSON) . Map.toList . fromContainer |
|
170 |
|
|
171 |
instance (J.JSON a) => J.JSON (Container a) where |
|
172 |
showJSON = showContainer |
|
173 |
readJSON (J.JSObject o) = readContainer o |
|
174 |
readJSON v = fail $ "Failed to load container, expected object but got " |
|
175 |
++ show (pp_value v) |
b/htools/Ganeti/Luxi.hs | ||
---|---|---|
67 | 67 |
import System.Timeout |
68 | 68 |
import qualified Network.Socket as S |
69 | 69 |
|
70 |
import Ganeti.HTools.JSON
|
|
70 |
import Ganeti.JSON |
|
71 | 71 |
import Ganeti.HTools.Types |
72 | 72 |
import Ganeti.HTools.Utils |
73 | 73 |
|
b/htools/Ganeti/Objects.hs | ||
---|---|---|
96 | 96 |
import qualified Text.JSON as J |
97 | 97 |
|
98 | 98 |
import qualified Ganeti.Constants as C |
99 |
import Ganeti.HTools.JSON
|
|
99 |
import Ganeti.JSON |
|
100 | 100 |
|
101 | 101 |
import Ganeti.THH |
102 | 102 |
|
b/htools/Ganeti/OpCodes.hs | ||
---|---|---|
40 | 40 |
import qualified Ganeti.Constants as C |
41 | 41 |
import Ganeti.THH |
42 | 42 |
|
43 |
import Ganeti.HTools.JSON
|
|
43 |
import Ganeti.JSON |
|
44 | 44 |
|
45 | 45 |
-- | Replace disks type. |
46 | 46 |
$(declareSADT "ReplaceDisksMode" |
b/htools/Ganeti/Query/Filter.hs | ||
---|---|---|
60 | 60 |
import Ganeti.Objects |
61 | 61 |
import Ganeti.Query.Language |
62 | 62 |
import Ganeti.Query.Types |
63 |
import Ganeti.HTools.JSON
|
|
63 |
import Ganeti.JSON |
|
64 | 64 |
|
65 | 65 |
-- | Compiles a filter based on field names to one based on getters. |
66 | 66 |
compileFilter :: FieldMap a b |
b/htools/Ganeti/Query/Language.hs | ||
---|---|---|
61 | 61 |
|
62 | 62 |
import qualified Ganeti.Constants as C |
63 | 63 |
import Ganeti.THH |
64 |
import Ganeti.HTools.JSON
|
|
64 |
import Ganeti.JSON |
|
65 | 65 |
|
66 | 66 |
-- * THH declarations, that require ordering. |
67 | 67 |
|
b/htools/Ganeti/Query/Query.hs | ||
---|---|---|
55 | 55 |
import qualified Data.Map as Map |
56 | 56 |
|
57 | 57 |
import Ganeti.BasicTypes |
58 |
import Ganeti.HTools.JSON
|
|
58 |
import Ganeti.JSON |
|
59 | 59 |
import Ganeti.Query.Language |
60 | 60 |
import Ganeti.Query.Common |
61 | 61 |
import Ganeti.Query.Filter |
b/htools/Ganeti/Rpc.hs | ||
---|---|---|
65 | 65 |
import qualified Ganeti.Constants as C |
66 | 66 |
import Ganeti.Objects |
67 | 67 |
import Ganeti.THH |
68 |
import Ganeti.HTools.Compat
|
|
69 |
import Ganeti.HTools.JSON
|
|
68 |
import Ganeti.Compat |
|
69 |
import Ganeti.JSON |
|
70 | 70 |
|
71 | 71 |
#ifndef NO_CURL |
72 | 72 |
-- | The curl options used for RPC. |
Also available in: Unified diff