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
  82 -- versions
  83
  84 -- | The covariance of the list
  85 varianceCoeff :: [Double] -> Double
  86 varianceCoeff lst =
  87     let ll = fromIntegral (length lst)::Double -- length of list
  88         mv = sum lst / ll   -- mean value
  89         av = foldl' (\accu em -> let d = em - mv in accu + d * d) 0.0 lst
  90         bv = sqrt (av / ll) -- stddev
  91         cv = bv / ll        -- covariance
  92     in cv
  93
  94 -- * JSON-related functions
  95
  96 -- | Converts a JSON Result into a monadic value.
  97 fromJResult :: Monad m => J.Result a -> m a
  98 fromJResult (J.Error x) = fail x
  99 fromJResult (J.Ok x) = return x
 100
 101 -- | Tries to read a string from a JSON value.
 102 --
 103 -- In case the value was not a string, we fail the read (in the
 104 -- context of the current monad.
 105 readEitherString :: (Monad m) => J.JSValue -> m String
 106 readEitherString v =
 107     case v of
 108       J.JSString s -> return $ J.fromJSString s
 109       _ -> fail "Wrong JSON type"
 110
 111 -- | Converts a JSON message into an array of JSON objects.
 112 loadJSArray :: (Monad m) => String -> m [J.JSObject J.JSValue]
 113 loadJSArray = fromJResult . J.decodeStrict
 114
 115 -- | Reads a the value of a key in a JSON object.
 116 fromObj :: (J.JSON a, Monad m) => String -> [(String, J.JSValue)] -> m a
 117 fromObj k o =
 118     case lookup k o of
 119       Nothing -> fail $ printf "key '%s' not found in %s" k (show o)
 120       Just val -> fromJResult $ J.readJSON val
 121
 122 -- | Annotate a Result with an ownership information
 123 annotateResult :: String -> Result a -> Result a
 124 annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s
 125 annotateResult _ v = v
 126
 127 -- | Try to extract a key from a object with better error reporting
 128 -- than fromObj
 129 tryFromObj :: (J.JSON a) =>
 130               String -> [(String, J.JSValue)] -> String -> Result a
 131 tryFromObj t o k = annotateResult (t ++ " key '" ++ k ++ "'") (fromObj k o)
 132
 133 -- | Small wrapper over readJSON.
 134 fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a
 135 fromJVal v =
 136     case J.readJSON v of
 137       J.Error s -> fail ("Cannot convert value " ++ show v ++ ", error: " ++ s)
 138       J.Ok x -> return x
 139
 140 -- | Converts a JSON value into a JSON object.
 141 asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue)
 142 asJSObject (J.JSObject a) = return a
 143 asJSObject _ = fail "not an object"
 144
 145 -- | Coneverts a list of JSON values into a list of JSON objects.
 146 asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue]
 147 asObjectList = mapM asJSObject
 148
 149 -- * Parsing utility functions
 150
 151 -- | Parse results from readsPrec
 152 parseChoices :: (Monad m, Read a) => String -> String -> [(a, String)] -> m a
 153 parseChoices _ _ ((v, ""):[]) = return v
 154 parseChoices name s ((_, e):[]) =
 155     fail $ name ++ ": leftover characters when parsing '"
 156            ++ s ++ "': '" ++ e ++ "'"
 157 parseChoices name s _ = fail $ name ++ ": cannot parse string '" ++ s ++ "'"
 158
 159 -- | Safe 'read' function returning data encapsulated in a Result.
 160 tryRead :: (Monad m, Read a) => String -> String -> m a
 161 tryRead name s = parseChoices name s $ reads s
 162
 163 -- | Format a table of strings to maintain consistent length
 164 formatTable :: [[String]] -> [Bool] -> [[String]]
 165 formatTable vals numpos =
 166     let vtrans = transpose vals  -- transpose, so that we work on rows
 167                                  -- rather than columns
 168         mlens = map (maximum . map length) vtrans
 169         expnd = map (\(flds, isnum, ml) ->
 170                          map (\val ->
 171                                   let delta = ml - length val
 172                                       filler = replicate delta ' '
 173                                   in if delta > 0
 174                                      then if isnum
 175                                           then filler ++ val
 176                                           else val ++ filler
 177                                      else val
 178                              ) flds
 179                     ) (zip3 vtrans numpos mlens)
 180    in transpose expnd