Revision a4f35477
b/src/Ganeti/JSON.hs | ||
---|---|---|
39 | 39 |
, asJSObject |
40 | 40 |
, asObjectList |
41 | 41 |
, tryFromObj |
42 |
, tryArrayMaybeFromObj |
|
42 | 43 |
, toArray |
43 | 44 |
, optionalJSField |
44 | 45 |
, optFieldsToObj |
... | ... | |
104 | 105 |
-> m [J.JSObject J.JSValue] |
105 | 106 |
loadJSArray s = fromJResult s . J.decodeStrict |
106 | 107 |
|
108 |
-- | Helper function for missing-key errors |
|
109 |
buildNoKeyError :: JSRecord -> String -> String |
|
110 |
buildNoKeyError o k = |
|
111 |
printf "key '%s' not found, object contains only %s" k (show (map fst o)) |
|
112 |
|
|
107 | 113 |
-- | Reads the value of a key in a JSON object. |
108 | 114 |
fromObj :: (J.JSON a, Monad m) => JSRecord -> String -> m a |
109 | 115 |
fromObj o k = |
110 | 116 |
case lookup k o of |
111 |
Nothing -> fail $ printf "key '%s' not found, object contains only %s" |
|
112 |
k (show (map fst o)) |
|
117 |
Nothing -> fail $ buildNoKeyError o k |
|
113 | 118 |
Just val -> fromKeyValue k val |
114 | 119 |
|
115 | 120 |
-- | Reads the value of an optional key in a JSON object. Missing |
... | ... | |
136 | 141 |
JSRecord -> String -> a -> m a |
137 | 142 |
fromObjWithDefault o k d = liftM (fromMaybe d) $ maybeFromObj o k |
138 | 143 |
|
144 |
-- | Reads an array of optional items |
|
145 |
arrayMaybeFromObj :: (J.JSON a, Monad m) => |
|
146 |
JSRecord -> String -> m [Maybe a] |
|
147 |
arrayMaybeFromObj o k = |
|
148 |
case lookup k o of |
|
149 |
Just (J.JSArray xs) -> mapM parse xs |
|
150 |
where |
|
151 |
parse J.JSNull = return Nothing |
|
152 |
parse x = liftM Just $ fromJVal x |
|
153 |
_ -> fail $ buildNoKeyError o k |
|
154 |
|
|
155 |
-- | Wrapper for arrayMaybeFromObj with better diagnostic |
|
156 |
tryArrayMaybeFromObj :: (J.JSON a) |
|
157 |
=> String -- ^ Textual "owner" in error messages |
|
158 |
-> JSRecord -- ^ The object array |
|
159 |
-> String -- ^ The desired key from the object |
|
160 |
-> Result [Maybe a] |
|
161 |
tryArrayMaybeFromObj t o = annotateResult t . arrayMaybeFromObj o |
|
162 |
|
|
139 | 163 |
-- | Reads a JValue, that originated from an object key. |
140 | 164 |
fromKeyValue :: (J.JSON a, Monad m) |
141 | 165 |
=> String -- ^ The key name |
b/test/hs/Test/Ganeti/JSON.hs | ||
---|---|---|
28 | 28 |
|
29 | 29 |
module Test.Ganeti.JSON (testJSON) where |
30 | 30 |
|
31 |
import Data.List |
|
31 | 32 |
import Test.QuickCheck |
32 | 33 |
|
33 | 34 |
import qualified Text.JSON as J |
... | ... | |
53 | 54 |
BasicTypes.Bad _ -> passTest |
54 | 55 |
BasicTypes.Ok result -> failTest $ "Unexpected parse, got " ++ show result |
55 | 56 |
|
57 |
arrayMaybeToJson :: (J.JSON a) => [Maybe a] -> String -> JSON.JSRecord |
|
58 |
arrayMaybeToJson xs k = [(k, J.JSArray $ map sh xs)] |
|
59 |
where |
|
60 |
sh x = case x of |
|
61 |
Just v -> J.showJSON v |
|
62 |
Nothing -> J.JSNull |
|
63 |
|
|
64 |
prop_arrayMaybeFromObj :: String -> [Maybe Int] -> String -> Property |
|
65 |
prop_arrayMaybeFromObj t xs k = |
|
66 |
case JSON.tryArrayMaybeFromObj t (arrayMaybeToJson xs k) k of |
|
67 |
BasicTypes.Ok xs' -> xs' ==? xs |
|
68 |
BasicTypes.Bad e -> failTest $ "Parsing failing, got: " ++ show e |
|
69 |
|
|
70 |
prop_arrayMaybeFromObjFail :: String -> String -> Property |
|
71 |
prop_arrayMaybeFromObjFail t k = |
|
72 |
case JSON.tryArrayMaybeFromObj t [] k of |
|
73 |
BasicTypes.Ok r -> fail $ |
|
74 |
"Unexpected result, got: " ++ show (r::[Maybe Int]) |
|
75 |
BasicTypes.Bad e -> conjoin [ Data.List.isInfixOf t e ==? True |
|
76 |
, Data.List.isInfixOf k e ==? True |
|
77 |
] |
|
78 |
|
|
56 | 79 |
testSuite "JSON" |
57 | 80 |
[ 'prop_toArray |
58 | 81 |
, 'prop_toArrayFail |
82 |
, 'prop_arrayMaybeFromObj |
|
83 |
, 'prop_arrayMaybeFromObjFail |
|
59 | 84 |
] |
Also available in: Unified diff