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
52 import Control.Monad (liftM)
53 import Data.Char (toUpper)
55 import Data.Maybe (fromMaybe)
56 import qualified Text.JSON as J
57 import Text.Printf (printf)
61 import Ganeti.HTools.Types
65 -- | To be used only for debugging, breaks referential integrity.
66 debug :: Show a => a -> a
67 debug x = trace (show x) x
69 -- | Displays a modified form of the second parameter before returning
71 debugFn :: Show b => (a -> b) -> a -> a
72 debugFn fn x = debug (fn x) `seq` x
74 -- | Show the first parameter before returning the second one.
75 debugXy :: Show a => a -> b -> b
76 debugXy a b = debug a `seq` b
80 -- | Comma-join a string list.
81 commaJoin :: [String] -> String
82 commaJoin = intercalate ","
84 -- | Split a list on a separator and return an array.
85 sepSplit :: Eq a => a -> [a] -> [[a]]
90 | otherwise = x:sepSplit sep ys
91 where (x, xs) = break (== sep) s
94 -- * Mathematical functions
96 -- Simple and slow statistical functions, please replace with better
99 -- | Standard deviation function.
100 stdDev :: [Double] -> Double
102 -- first, calculate the list length and sum lst in a single step,
103 -- for performance reasons
104 let (ll', sx) = foldl' (\(rl, rs) e ->
107 in rl' `seq` rs' `seq` (rl', rs')) (0::Int, 0) lst
108 ll = fromIntegral ll'::Double
110 av = foldl' (\accu em -> let d = em - mv in accu + d * d) 0.0 lst
111 in sqrt (av / ll) -- stddev
113 -- * Logical functions
115 -- Avoid syntactic sugar and enhance readability. These functions are proposed
116 -- by some for inclusion in the Prelude, and at the moment they are present
117 -- (with various definitions) in the utility-ht package. Some rationale and
118 -- discussion is available at <http://www.haskell.org/haskellwiki/If-then-else>
120 -- | \"if\" as a function, rather than as syntactic sugar.
121 if' :: Bool -- ^ condition
122 -> a -- ^ \"then\" result
123 -> a -- ^ \"else\" result
124 -> a -- ^ \"then\" or "else" result depending on the condition
128 -- | Return the first result with a True condition, or the default otherwise.
129 select :: a -- ^ default result
130 -> [(Bool, a)] -- ^ list of \"condition, result\"
131 -> a -- ^ first result which has a True condition, or default
132 select def = maybe def snd . find fst
134 -- * JSON-related functions
136 -- | A type alias for the list-based representation of J.JSObject.
137 type JSRecord = [(String, J.JSValue)]
139 -- | Converts a JSON Result into a monadic value.
140 fromJResult :: Monad m => String -> J.Result a -> m a
141 fromJResult s (J.Error x) = fail (s ++ ": " ++ x)
142 fromJResult _ (J.Ok x) = return x
144 -- | Tries to read a string from a JSON value.
146 -- In case the value was not a string, we fail the read (in the
147 -- context of the current monad.
148 readEitherString :: (Monad m) => J.JSValue -> m String
151 J.JSString s -> return $ J.fromJSString s
152 _ -> fail "Wrong JSON type"
154 -- | Converts a JSON message into an array of JSON objects.
155 loadJSArray :: (Monad m)
156 => String -- ^ Operation description (for error reporting)
157 -> String -- ^ Input message
158 -> m [J.JSObject J.JSValue]
159 loadJSArray s = fromJResult s . J.decodeStrict
161 -- | Reads the value of a key in a JSON object.
162 fromObj :: (J.JSON a, Monad m) => JSRecord -> String -> m a
165 Nothing -> fail $ printf "key '%s' not found, object contains only %s"
167 Just val -> fromKeyValue k val
169 -- | Reads the value of an optional key in a JSON object.
170 maybeFromObj :: (J.JSON a, Monad m) =>
171 JSRecord -> String -> m (Maybe a)
174 Nothing -> return Nothing
175 Just val -> liftM Just (fromKeyValue k val)
177 -- | Reads the value of a key in a JSON object with a default if missing.
178 fromObjWithDefault :: (J.JSON a, Monad m) =>
179 JSRecord -> String -> a -> m a
180 fromObjWithDefault o k d = liftM (fromMaybe d) $ maybeFromObj o k
182 -- | Reads a JValue, that originated from an object key.
183 fromKeyValue :: (J.JSON a, Monad m)
184 => String -- ^ The key name
185 -> J.JSValue -- ^ The value to read
188 fromJResult (printf "key '%s', value '%s'" k (show val)) (J.readJSON val)
190 -- | Annotate a Result with an ownership information.
191 annotateResult :: String -> Result a -> Result a
192 annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s
193 annotateResult _ v = v
195 -- | Try to extract a key from a object with better error reporting
197 tryFromObj :: (J.JSON a) =>
198 String -- ^ Textual "owner" in error messages
199 -> JSRecord -- ^ The object array
200 -> String -- ^ The desired key from the object
202 tryFromObj t o = annotateResult t . fromObj o
204 -- | Small wrapper over readJSON.
205 fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a
208 J.Error s -> fail ("Cannot convert value '" ++ show v ++
212 -- | Converts a JSON value into a JSON object.
213 asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue)
214 asJSObject (J.JSObject a) = return a
215 asJSObject _ = fail "not an object"
217 -- | Coneverts a list of JSON values into a list of JSON objects.
218 asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue]
219 asObjectList = mapM asJSObject
221 -- * Parsing utility functions
223 -- | Parse results from readsPrec.
224 parseChoices :: (Monad m, Read a) => String -> String -> [(a, String)] -> m a
225 parseChoices _ _ ((v, ""):[]) = return v
226 parseChoices name s ((_, e):[]) =
227 fail $ name ++ ": leftover characters when parsing '"
228 ++ s ++ "': '" ++ e ++ "'"
229 parseChoices name s _ = fail $ name ++ ": cannot parse string '" ++ s ++ "'"
231 -- | Safe 'read' function returning data encapsulated in a Result.
232 tryRead :: (Monad m, Read a) => String -> String -> m a
233 tryRead name s = parseChoices name s $ reads s
235 -- | Format a table of strings to maintain consistent length.
236 formatTable :: [[String]] -> [Bool] -> [[String]]
237 formatTable vals numpos =
238 let vtrans = transpose vals -- transpose, so that we work on rows
239 -- rather than columns
240 mlens = map (maximum . map length) vtrans
241 expnd = map (\(flds, isnum, ml) ->
243 let delta = ml - length val
244 filler = replicate delta ' '
251 ) (zip3 vtrans numpos mlens)
254 -- | Default group UUID (just a string, not a real UUID).
255 defaultGroupID :: GroupID
256 defaultGroupID = "00000000-0000-0000-0000-000000000000"
258 -- | Tries to extract number and scale from the given string.
260 -- Input must be in the format NUMBER+ SPACE* [UNIT]. If no unit is
261 -- specified, it defaults to MiB. Return value is always an integral
263 parseUnit :: (Monad m, Integral a, Read a) => String -> m a
265 -- TODO: enhance this by splitting the unit parsing code out and
266 -- accepting floating-point numbers
269 let unit = dropWhile (== ' ') suffix
270 upper = map toUpper unit
271 siConvert x = x * 1000000 `div` 1048576
273 _ | null unit -> return v
274 | unit == "m" || upper == "MIB" -> return v
275 | unit == "M" || upper == "MB" -> return $ siConvert v
276 | unit == "g" || upper == "GIB" -> return $ v * 1024
277 | unit == "G" || upper == "GB" -> return $ siConvert
279 | unit == "t" || upper == "TIB" -> return $ v * 1048576
280 | unit == "T" || upper == "TB" -> return $
281 siConvert (v * 1000000)
282 | otherwise -> fail $ "Unknown unit '" ++ unit ++ "'"
283 _ -> fail $ "Can't parse string '" ++ str ++ "'"