Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / HTools / JSON.hs @ 84835174

History | View | Annotate | Download (5.2 kB)

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

    
50
import Ganeti.BasicTypes
51

    
52
-- * JSON-related functions
53

    
54
-- | A type alias for the list-based representation of J.JSObject.
55
type JSRecord = [(String, J.JSValue)]
56

    
57
-- | Converts a JSON Result into a monadic value.
58
fromJResult :: Monad m => String -> J.Result a -> m a
59
fromJResult s (J.Error x) = fail (s ++ ": " ++ x)
60
fromJResult _ (J.Ok x) = return x
61

    
62
-- | Tries to read a string from a JSON value.
63
--
64
-- In case the value was not a string, we fail the read (in the
65
-- context of the current monad.
66
readEitherString :: (Monad m) => J.JSValue -> m String
67
readEitherString v =
68
  case v of
69
    J.JSString s -> return $ J.fromJSString s
70
    _ -> fail "Wrong JSON type"
71

    
72
-- | Converts a JSON message into an array of JSON objects.
73
loadJSArray :: (Monad m)
74
               => String -- ^ Operation description (for error reporting)
75
               -> String -- ^ Input message
76
               -> m [J.JSObject J.JSValue]
77
loadJSArray s = fromJResult s . J.decodeStrict
78

    
79
-- | Reads the value of a key in a JSON object.
80
fromObj :: (J.JSON a, Monad m) => JSRecord -> String -> m a
81
fromObj o k =
82
  case lookup k o of
83
    Nothing -> fail $ printf "key '%s' not found, object contains only %s"
84
               k (show (map fst o))
85
    Just val -> fromKeyValue k val
86

    
87
-- | Reads the value of an optional key in a JSON object.
88
maybeFromObj :: (J.JSON a, Monad m) =>
89
                JSRecord -> String -> m (Maybe a)
90
maybeFromObj o k =
91
  case lookup k o of
92
    Nothing -> return Nothing
93
    Just val -> liftM Just (fromKeyValue k val)
94

    
95
-- | Reads the value of a key in a JSON object with a default if missing.
96
fromObjWithDefault :: (J.JSON a, Monad m) =>
97
                      JSRecord -> String -> a -> m a
98
fromObjWithDefault o k d = liftM (fromMaybe d) $ maybeFromObj o k
99

    
100
-- | Reads a JValue, that originated from an object key.
101
fromKeyValue :: (J.JSON a, Monad m)
102
              => String     -- ^ The key name
103
              -> J.JSValue  -- ^ The value to read
104
              -> m a
105
fromKeyValue k val =
106
  fromJResult (printf "key '%s'" k) (J.readJSON val)
107

    
108
-- | Small wrapper over readJSON.
109
fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a
110
fromJVal v =
111
  case J.readJSON v of
112
    J.Error s -> fail ("Cannot convert value '" ++ show v ++
113
                       "', error: " ++ s)
114
    J.Ok x -> return x
115

    
116
-- | Converts a JSON value into a JSON object.
117
asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue)
118
asJSObject (J.JSObject a) = return a
119
asJSObject _ = fail "not an object"
120

    
121
-- | Coneverts a list of JSON values into a list of JSON objects.
122
asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue]
123
asObjectList = mapM asJSObject
124

    
125
-- | Try to extract a key from a object with better error reporting
126
-- than fromObj.
127
tryFromObj :: (J.JSON a) =>
128
              String     -- ^ Textual "owner" in error messages
129
           -> JSRecord   -- ^ The object array
130
           -> String     -- ^ The desired key from the object
131
           -> Result a
132
tryFromObj t o = annotateResult t . fromObj o
133

    
134
-- | Ensure a given JSValue is actually a JSArray.
135
toArray :: (Monad m) => J.JSValue -> m [J.JSValue]
136
toArray (J.JSArray arr) = return arr
137
toArray o = fail $ "Invalid input, expected array but got " ++ show o
138

    
139
-- * Container type (special type for JSON serialisation)
140

    
141
-- | The container type, a wrapper over Data.Map
142
newtype Container a = Container { fromContainer :: Map.Map String a }
143
  deriving (Show, Read, Eq)
144

    
145
-- | Container loader.
146
readContainer :: (Monad m, J.JSON a) =>
147
                 J.JSObject J.JSValue -> m (Container a)
148
readContainer obj = do
149
  let kjvlist = J.fromJSObject obj
150
  kalist <- mapM (\(k, v) -> fromKeyValue k v >>= \a -> return (k, a)) kjvlist
151
  return $ Container (Map.fromList kalist)
152

    
153
-- | Container dumper.
154
showContainer :: (J.JSON a) => Container a -> J.JSValue
155
showContainer =
156
  J.makeObj . map (second J.showJSON) . Map.toList . fromContainer
157

    
158
instance (J.JSON a) => J.JSON (Container a) where
159
  showJSON = showContainer
160
  readJSON (J.JSObject o) = readContainer o
161
  readJSON v = fail $ "Failed to load container, expected object but got "
162
               ++ show v