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 it
66 debugFn :: Show b => (a -> b) -> a -> a
67 debugFn fn x = debug (fn x) `seq` x
69 -- | Show the first parameter before returning the second one
70 debugXy :: Show a => a -> b -> b
71 debugXy a b = debug a `seq` b
75 -- | Comma-join a string list.
76 commaJoin :: [String] -> String
77 commaJoin = intercalate ","
79 -- | Split a list on a separator and return an array.
80 sepSplit :: Eq a => a -> [a] -> [[a]]
85 | otherwise = x:sepSplit sep ys
86 where (x, xs) = break (== sep) s
89 -- * Mathematical functions
91 -- Simple and slow statistical functions, please replace with better
94 -- | Standard deviation function
95 stdDev :: [Double] -> Double
97 -- first, calculate the list length and sum lst in a single step,
98 -- for performance reasons
99 let (ll', sx) = foldl' (\(rl, rs) e ->
102 in rl' `seq` rs' `seq` (rl', rs')) (0::Int, 0) lst
103 ll = fromIntegral ll'::Double
105 av = foldl' (\accu em -> let d = em - mv in accu + d * d) 0.0 lst
106 in sqrt (av / ll) -- stddev
108 -- * JSON-related functions
110 -- | A type alias for the list-based representation of J.JSObject
111 type JSRecord = [(String, J.JSValue)]
113 -- | Converts a JSON Result into a monadic value.
114 fromJResult :: Monad m => String -> J.Result a -> m a
115 fromJResult s (J.Error x) = fail (s ++ ": " ++ x)
116 fromJResult _ (J.Ok x) = return x
118 -- | Tries to read a string from a JSON value.
120 -- In case the value was not a string, we fail the read (in the
121 -- context of the current monad.
122 readEitherString :: (Monad m) => J.JSValue -> m String
125 J.JSString s -> return $ J.fromJSString s
126 _ -> fail "Wrong JSON type"
128 -- | Converts a JSON message into an array of JSON objects.
129 loadJSArray :: (Monad m)
130 => String -- ^ Operation description (for error reporting)
131 -> String -- ^ Input message
132 -> m [J.JSObject J.JSValue]
133 loadJSArray s = fromJResult s . J.decodeStrict
135 -- | Reads the value of a key in a JSON object.
136 fromObj :: (J.JSON a, Monad m) => JSRecord -> String -> m a
139 Nothing -> fail $ printf "key '%s' not found, object contains only %s"
141 Just val -> fromKeyValue k val
143 -- | Reads the value of an optional key in a JSON object.
144 maybeFromObj :: (J.JSON a, Monad m) =>
145 JSRecord -> String -> m (Maybe a)
148 Nothing -> return Nothing
149 Just val -> liftM Just (fromKeyValue k val)
151 -- | Reads the value of a key in a JSON object with a default if missing.
152 fromObjWithDefault :: (J.JSON a, Monad m) =>
153 JSRecord -> String -> a -> m a
154 fromObjWithDefault o k d = liftM (fromMaybe d) $ maybeFromObj o k
156 -- | Reads a JValue, that originated from an object key
157 fromKeyValue :: (J.JSON a, Monad m)
158 => String -- ^ The key name
159 -> J.JSValue -- ^ The value to read
162 fromJResult (printf "key '%s', value '%s'" k (show val)) (J.readJSON val)
164 -- | Annotate a Result with an ownership information
165 annotateResult :: String -> Result a -> Result a
166 annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s
167 annotateResult _ v = v
169 -- | Try to extract a key from a object with better error reporting
171 tryFromObj :: (J.JSON a) =>
172 String -- ^ Textual "owner" in error messages
173 -> JSRecord -- ^ The object array
174 -> String -- ^ The desired key from the object
176 tryFromObj t o = annotateResult t . fromObj o
178 -- | Small wrapper over readJSON.
179 fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a
182 J.Error s -> fail ("Cannot convert value '" ++ show v ++
186 -- | Converts a JSON value into a JSON object.
187 asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue)
188 asJSObject (J.JSObject a) = return a
189 asJSObject _ = fail "not an object"
191 -- | Coneverts a list of JSON values into a list of JSON objects.
192 asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue]
193 asObjectList = mapM asJSObject
195 -- * Parsing utility functions
197 -- | Parse results from readsPrec
198 parseChoices :: (Monad m, Read a) => String -> String -> [(a, String)] -> m a
199 parseChoices _ _ ((v, ""):[]) = return v
200 parseChoices name s ((_, e):[]) =
201 fail $ name ++ ": leftover characters when parsing '"
202 ++ s ++ "': '" ++ e ++ "'"
203 parseChoices name s _ = fail $ name ++ ": cannot parse string '" ++ s ++ "'"
205 -- | Safe 'read' function returning data encapsulated in a Result.
206 tryRead :: (Monad m, Read a) => String -> String -> m a
207 tryRead name s = parseChoices name s $ reads s
209 -- | Format a table of strings to maintain consistent length
210 formatTable :: [[String]] -> [Bool] -> [[String]]
211 formatTable vals numpos =
212 let vtrans = transpose vals -- transpose, so that we work on rows
213 -- rather than columns
214 mlens = map (maximum . map length) vtrans
215 expnd = map (\(flds, isnum, ml) ->
217 let delta = ml - length val
218 filler = replicate delta ' '
225 ) (zip3 vtrans numpos mlens)
228 -- | Default group UUID (just a string, not a real UUID)
229 defaultGroupID :: GroupID
230 defaultGroupID = "00000000-0000-0000-0000-000000000000"