This fixes two problems:
- first, when we deserialise a big object, showing its value is not
useful, as it will hide the actual error message
- second, we shouldn't deserialise a container at once, because then
we will lose the detail of which 'key' failed to deserialise; we
change to manual deserialisation of each key/value pair, so that we
can keep this information
The last point requires that we import JSON.hs into THH.hs, in order
not to duplicate functionality.
---
htools/Ganeti/HTools/JSON.hs | 3 ++-
htools/Ganeti/THH.hs | 10 ++++++++--
2 files changed, 10 insertions(+), 3 deletions(-)
diff --git a/htools/Ganeti/HTools/JSON.hs b/htools/Ganeti/HTools/JSON.hs
index 6fe45ba..185201f 100644
--- a/htools/Ganeti/HTools/JSON.hs
+++ b/htools/Ganeti/HTools/JSON.hs
@@ -29,6 +29,7 @@ module Ganeti.HTools.JSON
, fromObj
, maybeFromObj
, fromObjWithDefault
+ , fromKeyValue
, fromJVal
, asJSObject
, asObjectList
@@ -95,7 +96,7 @@ fromKeyValue :: (J.JSON a, Monad m)
-> J.JSValue -- ^ The value to read
-> m a
fromKeyValue k val =
- fromJResult (printf "key '%s', value '%s'" k (show val)) (J.readJSON val)
+ fromJResult (printf "key '%s'" k) (J.readJSON val)
-- | Small wrapper over readJSON.
fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a
diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs
index 102ef49..cd43c20 100644
--- a/htools/Ganeti/THH.hs
+++ b/htools/Ganeti/THH.hs
@@ -63,6 +63,8 @@ import Language.Haskell.TH
import qualified Text.JSON as JSON
+import Ganeti.HTools.JSON
+
-- * Exported types
type Container = M.Map String
@@ -205,8 +207,12 @@ appFn f x | f == VarE 'id = x
| otherwise = AppE f x
-- | Container loader
-readContainer :: (Monad m) => JSON.JSObject a -> m (Container a)
-readContainer = return . M.fromList . JSON.fromJSObject
+readContainer :: (Monad m, JSON.JSON a) =>
+ JSON.JSObject JSON.JSValue -> m (Container a)
+readContainer obj = do
+ let kjvlist = JSON.fromJSObject obj
+ kalist <- mapM (\(k, v) -> fromKeyValue k v >>= \a -> return (k, a)) kjvlist
+ return $ M.fromList kalist
-- | Container dumper
showContainer :: (JSON.JSON a) => Container a -> JSON.JSValue
--
1.7.3.1
