code.grnet.gr Git - ganeti-local/blob - Ganeti/HTools/Utils.hs

   1 {-| Utility functions -}
   2
   3 {-
   4
   5 Copyright (C) 2009 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.Utils
  25     (
  26       debug
  27     , sepSplit
  28     , fst3
  29     , varianceCoeff
  30     , commaJoin
  31     , readEitherString
  32     , loadJSArray
  33     , fromObj
  34     , tryFromObj
  35     , fromJVal
  36     , asJSObject
  37     , asObjectList
  38     , fromJResult
  39     , tryRead
  40     , formatTable
  41     , annotateResult
  42     ) where
  43
  44 import Data.List
  45 import Control.Monad
  46 import qualified Text.JSON as J
  47 import Text.Printf (printf)
  48
  49 import Debug.Trace
  50
  51 import Ganeti.HTools.Types
  52
  53 -- * Debug functions
  54
  55 -- | To be used only for debugging, breaks referential integrity.
  56 debug :: Show a => a -> a
  57 debug x = trace (show x) x
  58
  59 -- * Miscelaneous
  60
  61 -- | Comma-join a string list.
  62 commaJoin :: [String] -> String
  63 commaJoin = intercalate ","
  64
  65 -- | Split a string on a separator and return an array.
  66 sepSplit :: Char -> String -> [String]
  67 sepSplit sep s
  68     | x == "" && xs == [] = []
  69     | xs == []            = [x]
  70     | ys == []            = [x,""]
  71     | otherwise           = x:sepSplit sep ys
  72     where (x, xs) = break (== sep) s
  73           ys = drop 1 xs
  74
  75 -- | Simple version of 'fst' for a triple
  76 fst3 :: (a, b, c) -> a
  77 fst3 (a, _, _) = a
  78
  79 -- * Mathematical functions
  80
  81 -- Simple and slow statistical functions, please replace with better versions
  82
  83 -- | Mean value of a list.
  84 meanValue :: [Double] -> Double
  85 meanValue lst = sum lst / fromIntegral (length lst)
  86
  87 -- | Standard deviation.
  88 stdDev :: [Double] -> Double
  89 stdDev lst =
  90     let mv = meanValue lst
  91         av = foldl' (\accu em -> let d = em - mv in accu + d * d) 0.0 lst
  92         bv = sqrt (av / fromIntegral (length lst))
  93     in bv
  94
  95 -- | Coefficient of variation.
  96 varianceCoeff :: [Double] -> Double
  97 varianceCoeff lst = stdDev lst / fromIntegral (length lst)
  98
  99 -- * JSON-related functions
 100
 101 -- | Converts a JSON Result into a monadic value.
 102 fromJResult :: Monad m => J.Result a -> m a
 103 fromJResult (J.Error x) = fail x
 104 fromJResult (J.Ok x) = return x
 105
 106 -- | Tries to read a string from a JSON value.
 107 --
 108 -- In case the value was not a string, we fail the read (in the
 109 -- context of the current monad.
 110 readEitherString :: (Monad m) => J.JSValue -> m String
 111 readEitherString v =
 112     case v of
 113       J.JSString s -> return $ J.fromJSString s
 114       _ -> fail "Wrong JSON type"
 115
 116 -- | Converts a JSON message into an array of JSON objects.
 117 loadJSArray :: (Monad m) => String -> m [J.JSObject J.JSValue]
 118 loadJSArray = fromJResult . J.decodeStrict
 119
 120 -- | Reads a the value of a key in a JSON object.
 121 fromObj :: (J.JSON a, Monad m) => String -> [(String, J.JSValue)] -> m a
 122 fromObj k o =
 123     case lookup k o of
 124       Nothing -> fail $ printf "key '%s' not found in %s" k (show o)
 125       Just val -> fromJResult $ J.readJSON val
 126
 127 -- | Annotate a Result with an ownership information
 128 annotateResult :: String -> Result a -> Result a
 129 annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s
 130 annotateResult _ v = v
 131
 132 -- | Try to extract a key from a object with better error reporting
 133 -- than fromObj
 134 tryFromObj :: (J.JSON a) =>
 135               String -> [(String, J.JSValue)] -> String -> Result a
 136 tryFromObj t o k = annotateResult (t ++ " key '" ++ k ++ "'") (fromObj k o)
 137
 138 -- | Small wrapper over readJSON.
 139 fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a
 140 fromJVal v =
 141     case J.readJSON v of
 142       J.Error s -> fail ("Cannot convert value " ++ show v ++ ", error: " ++ s)
 143       J.Ok x -> return x
 144
 145 -- | Converts a JSON value into a JSON object.
 146 asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue)
 147 asJSObject (J.JSObject a) = return a
 148 asJSObject _ = fail "not an object"
 149
 150 -- | Coneverts a list of JSON values into a list of JSON objects.
 151 asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue]
 152 asObjectList = mapM asJSObject
 153
 154 -- * Parsing utility functions
 155
 156 -- | Parse results from readsPrec
 157 parseChoices :: (Monad m, Read a) => String -> String -> [(a, String)] -> m a
 158 parseChoices _ _ ((v, ""):[]) = return v
 159 parseChoices name s ((_, e):[]) =
 160     fail $ name ++ ": leftover characters when parsing '"
 161            ++ s ++ "': '" ++ e ++ "'"
 162 parseChoices name s _ = fail $ name ++ ": cannot parse string '" ++ s ++ "'"
 163
 164 -- | Safe 'read' function returning data encapsulated in a Result.
 165 tryRead :: (Monad m, Read a) => String -> String -> m a
 166 tryRead name s = parseChoices name s $ reads s
 167
 168 -- | Format a table of strings to maintain consistent length
 169 formatTable :: [[String]] -> [Bool] -> [[String]]
 170 formatTable vals numpos =
 171     let vtrans = transpose vals  -- transpose, so that we work on rows
 172                                  -- rather than columns
 173         mlens = map (maximum . map length) vtrans
 174         expnd = map (\(flds, isnum, ml) ->
 175                          map (\val ->
 176                                   let delta = ml - length val
 177                                       filler = replicate delta ' '
 178                                   in if delta > 0
 179                                      then if isnum
 180                                           then filler ++ val
 181                                           else val ++ filler
 182                                      else val
 183                              ) flds
 184                     ) (zip3 vtrans numpos mlens)
 185    in transpose expnd