1 {-| Utility functions. -}
5 Copyright (C) 2009, 2010, 2011 Google Inc.
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.
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.
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
24 module Ganeti.HTools.Utils
49 import Control.Monad (liftM)
51 import Data.Maybe (fromMaybe)
52 import qualified Text.JSON as J
53 import Text.Printf (printf)
57 import Ganeti.HTools.Types
61 -- | To be used only for debugging, breaks referential integrity.
62 debug :: Show a => a -> a
63 debug x = trace (show x) x
65 -- | Displays a modified form of the second parameter before returning
67 debugFn :: Show b => (a -> b) -> a -> a
68 debugFn fn x = debug (fn x) `seq` x
70 -- | Show the first parameter before returning the second one.
71 debugXy :: Show a => a -> b -> b
72 debugXy a b = debug a `seq` b
76 -- | Comma-join a string list.
77 commaJoin :: [String] -> String
78 commaJoin = intercalate ","
80 -- | Split a list on a separator and return an array.
81 sepSplit :: Eq a => a -> [a] -> [[a]]
86 | otherwise = x:sepSplit sep ys
87 where (x, xs) = break (== sep) s
90 -- * Mathematical functions
92 -- Simple and slow statistical functions, please replace with better
95 -- | Standard deviation function.
96 stdDev :: [Double] -> Double
98 -- first, calculate the list length and sum lst in a single step,
99 -- for performance reasons
100 let (ll', sx) = foldl' (\(rl, rs) e ->
103 in rl' `seq` rs' `seq` (rl', rs')) (0::Int, 0) lst
104 ll = fromIntegral ll'::Double
106 av = foldl' (\accu em -> let d = em - mv in accu + d * d) 0.0 lst
107 in sqrt (av / ll) -- stddev
109 -- * JSON-related functions
111 -- | A type alias for the list-based representation of J.JSObject.
112 type JSRecord = [(String, J.JSValue)]
114 -- | Converts a JSON Result into a monadic value.
115 fromJResult :: Monad m => String -> J.Result a -> m a
116 fromJResult s (J.Error x) = fail (s ++ ": " ++ x)
117 fromJResult _ (J.Ok x) = return x
119 -- | Tries to read a string from a JSON value.
121 -- In case the value was not a string, we fail the read (in the
122 -- context of the current monad.
123 readEitherString :: (Monad m) => J.JSValue -> m String
126 J.JSString s -> return $ J.fromJSString s
127 _ -> fail "Wrong JSON type"
129 -- | Converts a JSON message into an array of JSON objects.
130 loadJSArray :: (Monad m)
131 => String -- ^ Operation description (for error reporting)
132 -> String -- ^ Input message
133 -> m [J.JSObject J.JSValue]
134 loadJSArray s = fromJResult s . J.decodeStrict
136 -- | Reads the value of a key in a JSON object.
137 fromObj :: (J.JSON a, Monad m) => JSRecord -> String -> m a
140 Nothing -> fail $ printf "key '%s' not found, object contains only %s"
142 Just val -> fromKeyValue k val
144 -- | Reads the value of an optional key in a JSON object.
145 maybeFromObj :: (J.JSON a, Monad m) =>
146 JSRecord -> String -> m (Maybe a)
149 Nothing -> return Nothing
150 Just val -> liftM Just (fromKeyValue k val)
152 -- | Reads the value of a key in a JSON object with a default if missing.
153 fromObjWithDefault :: (J.JSON a, Monad m) =>
154 JSRecord -> String -> a -> m a
155 fromObjWithDefault o k d = liftM (fromMaybe d) $ maybeFromObj o k
157 -- | Reads a JValue, that originated from an object key.
158 fromKeyValue :: (J.JSON a, Monad m)
159 => String -- ^ The key name
160 -> J.JSValue -- ^ The value to read
163 fromJResult (printf "key '%s', value '%s'" k (show val)) (J.readJSON val)
165 -- | Annotate a Result with an ownership information.
166 annotateResult :: String -> Result a -> Result a
167 annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s
168 annotateResult _ v = v
170 -- | Try to extract a key from a object with better error reporting
172 tryFromObj :: (J.JSON a) =>
173 String -- ^ Textual "owner" in error messages
174 -> JSRecord -- ^ The object array
175 -> String -- ^ The desired key from the object
177 tryFromObj t o = annotateResult t . fromObj o
179 -- | Small wrapper over readJSON.
180 fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a
183 J.Error s -> fail ("Cannot convert value '" ++ show v ++
187 -- | Converts a JSON value into a JSON object.
188 asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue)
189 asJSObject (J.JSObject a) = return a
190 asJSObject _ = fail "not an object"
192 -- | Coneverts a list of JSON values into a list of JSON objects.
193 asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue]
194 asObjectList = mapM asJSObject
196 -- * Parsing utility functions
198 -- | Parse results from readsPrec.
199 parseChoices :: (Monad m, Read a) => String -> String -> [(a, String)] -> m a
200 parseChoices _ _ ((v, ""):[]) = return v
201 parseChoices name s ((_, e):[]) =
202 fail $ name ++ ": leftover characters when parsing '"
203 ++ s ++ "': '" ++ e ++ "'"
204 parseChoices name s _ = fail $ name ++ ": cannot parse string '" ++ s ++ "'"
206 -- | Safe 'read' function returning data encapsulated in a Result.
207 tryRead :: (Monad m, Read a) => String -> String -> m a
208 tryRead name s = parseChoices name s $ reads s
210 -- | Format a table of strings to maintain consistent length.
211 formatTable :: [[String]] -> [Bool] -> [[String]]
212 formatTable vals numpos =
213 let vtrans = transpose vals -- transpose, so that we work on rows
214 -- rather than columns
215 mlens = map (maximum . map length) vtrans
216 expnd = map (\(flds, isnum, ml) ->
218 let delta = ml - length val
219 filler = replicate delta ' '
226 ) (zip3 vtrans numpos mlens)
229 -- | Default group UUID (just a string, not a real UUID).
230 defaultGroupID :: GroupID
231 defaultGroupID = "00000000-0000-0000-0000-000000000000"