Statistics
| Branch: | Tag: | Revision:

root / Ganeti / HTools / Utils.hs @ a334d536

History | View | Annotate | Download (7 kB)

1 e4f08c46 Iustin Pop
{-| Utility functions -}
2 e4f08c46 Iustin Pop
3 e2fa2baf Iustin Pop
{-
4 e2fa2baf Iustin Pop
5 adc5c176 Iustin Pop
Copyright (C) 2009, 2010 Google Inc.
6 e2fa2baf Iustin Pop
7 e2fa2baf Iustin Pop
This program is free software; you can redistribute it and/or modify
8 e2fa2baf Iustin Pop
it under the terms of the GNU General Public License as published by
9 e2fa2baf Iustin Pop
the Free Software Foundation; either version 2 of the License, or
10 e2fa2baf Iustin Pop
(at your option) any later version.
11 e2fa2baf Iustin Pop
12 e2fa2baf Iustin Pop
This program is distributed in the hope that it will be useful, but
13 e2fa2baf Iustin Pop
WITHOUT ANY WARRANTY; without even the implied warranty of
14 e2fa2baf Iustin Pop
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
15 e2fa2baf Iustin Pop
General Public License for more details.
16 e2fa2baf Iustin Pop
17 e2fa2baf Iustin Pop
You should have received a copy of the GNU General Public License
18 e2fa2baf Iustin Pop
along with this program; if not, write to the Free Software
19 e2fa2baf Iustin Pop
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
20 e2fa2baf Iustin Pop
02110-1301, USA.
21 e2fa2baf Iustin Pop
22 e2fa2baf Iustin Pop
-}
23 e2fa2baf Iustin Pop
24 209b3711 Iustin Pop
module Ganeti.HTools.Utils
25 209b3711 Iustin Pop
    (
26 209b3711 Iustin Pop
      debug
27 adc5c176 Iustin Pop
    , debugFn
28 adc5c176 Iustin Pop
    , debugXy
29 209b3711 Iustin Pop
    , sepSplit
30 209b3711 Iustin Pop
    , varianceCoeff
31 3d7cd10b Iustin Pop
    , commaJoin
32 9ba5c28f Iustin Pop
    , readEitherString
33 9ba5c28f Iustin Pop
    , loadJSArray
34 9ba5c28f Iustin Pop
    , fromObj
35 f36a8028 Iustin Pop
    , maybeFromObj
36 117dc2d8 Iustin Pop
    , tryFromObj
37 117dc2d8 Iustin Pop
    , fromJVal
38 3f6af65c Iustin Pop
    , asJSObject
39 3f6af65c Iustin Pop
    , asObjectList
40 942403e6 Iustin Pop
    , fromJResult
41 5b763470 Iustin Pop
    , tryRead
42 c5f7412e Iustin Pop
    , formatTable
43 117dc2d8 Iustin Pop
    , annotateResult
44 c4d98278 Iustin Pop
    , defaultGroupID
45 209b3711 Iustin Pop
    ) where
46 e4f08c46 Iustin Pop
47 f36a8028 Iustin Pop
import Control.Monad (liftM)
48 29ac5975 Iustin Pop
import Data.List
49 942403e6 Iustin Pop
import qualified Text.JSON as J
50 9ba5c28f Iustin Pop
import Text.Printf (printf)
51 e4f08c46 Iustin Pop
52 e4f08c46 Iustin Pop
import Debug.Trace
53 e4f08c46 Iustin Pop
54 117dc2d8 Iustin Pop
import Ganeti.HTools.Types
55 117dc2d8 Iustin Pop
56 9188aeef Iustin Pop
-- * Debug functions
57 9188aeef Iustin Pop
58 e4f08c46 Iustin Pop
-- | To be used only for debugging, breaks referential integrity.
59 e4f08c46 Iustin Pop
debug :: Show a => a -> a
60 e4f08c46 Iustin Pop
debug x = trace (show x) x
61 e4f08c46 Iustin Pop
62 adc5c176 Iustin Pop
-- | Displays a modified form of the second parameter before returning it
63 adc5c176 Iustin Pop
debugFn :: Show b => (a -> b) -> a -> a
64 adc5c176 Iustin Pop
debugFn fn x = debug (fn x) `seq` x
65 adc5c176 Iustin Pop
66 adc5c176 Iustin Pop
-- | Show the first parameter before returning the second one
67 adc5c176 Iustin Pop
debugXy :: Show a => a -> b -> b
68 adc5c176 Iustin Pop
debugXy a b = debug a `seq` b
69 adc5c176 Iustin Pop
70 9188aeef Iustin Pop
-- * Miscelaneous
71 1b7cf8ca Iustin Pop
72 e4f08c46 Iustin Pop
-- | Comma-join a string list.
73 e4f08c46 Iustin Pop
commaJoin :: [String] -> String
74 e4f08c46 Iustin Pop
commaJoin = intercalate ","
75 e4f08c46 Iustin Pop
76 e4f08c46 Iustin Pop
-- | Split a string on a separator and return an array.
77 e4f08c46 Iustin Pop
sepSplit :: Char -> String -> [String]
78 e4f08c46 Iustin Pop
sepSplit sep s
79 e4f08c46 Iustin Pop
    | x == "" && xs == [] = []
80 e4f08c46 Iustin Pop
    | xs == []            = [x]
81 9f6dcdea Iustin Pop
    | ys == []            = [x,""]
82 9f6dcdea Iustin Pop
    | otherwise           = x:sepSplit sep ys
83 e4f08c46 Iustin Pop
    where (x, xs) = break (== sep) s
84 e4f08c46 Iustin Pop
          ys = drop 1 xs
85 e4f08c46 Iustin Pop
86 9188aeef Iustin Pop
-- * Mathematical functions
87 9188aeef Iustin Pop
88 185297fa Iustin Pop
-- Simple and slow statistical functions, please replace with better
89 185297fa Iustin Pop
-- versions
90 e4f08c46 Iustin Pop
91 7570569e Iustin Pop
-- | Our modified standard deviation function (not, it's not the variance)
92 e27eb8ab Iustin Pop
varianceCoeff :: [Double] -> Double
93 185297fa Iustin Pop
varianceCoeff lst =
94 7570569e Iustin Pop
  -- first, calculate the list length and sum lst in a single step,
95 7570569e Iustin Pop
  -- for performance reasons
96 7570569e Iustin Pop
  let (ll', sx) = foldl' (\(rl, rs) e ->
97 7570569e Iustin Pop
                           let rl' = rl + 1
98 7570569e Iustin Pop
                               rs' = rs + e
99 7570569e Iustin Pop
                           in rl' `seq` rs' `seq` (rl', rs')) (0::Int, 0) lst
100 7570569e Iustin Pop
      ll = fromIntegral ll'::Double
101 7570569e Iustin Pop
      mv = sx / ll
102 7570569e Iustin Pop
      av = foldl' (\accu em -> let d = em - mv in accu + d * d) 0.0 lst
103 7570569e Iustin Pop
      bv = sqrt (av / ll) -- stddev
104 7570569e Iustin Pop
      cv = bv / ll        -- standard deviation divided by list length
105 7570569e Iustin Pop
  in cv
106 dd4c56ed Iustin Pop
107 9188aeef Iustin Pop
-- * JSON-related functions
108 9188aeef Iustin Pop
109 9188aeef Iustin Pop
-- | Converts a JSON Result into a monadic value.
110 c96d44df Iustin Pop
fromJResult :: Monad m => String -> J.Result a -> m a
111 c96d44df Iustin Pop
fromJResult s (J.Error x) = fail (s ++ ": " ++ x)
112 c96d44df Iustin Pop
fromJResult _ (J.Ok x) = return x
113 50d26669 Iustin Pop
114 9188aeef Iustin Pop
-- | Tries to read a string from a JSON value.
115 9188aeef Iustin Pop
--
116 9188aeef Iustin Pop
-- In case the value was not a string, we fail the read (in the
117 9188aeef Iustin Pop
-- context of the current monad.
118 5aa48dbe Iustin Pop
readEitherString :: (Monad m) => J.JSValue -> m String
119 9ba5c28f Iustin Pop
readEitherString v =
120 9ba5c28f Iustin Pop
    case v of
121 5aa48dbe Iustin Pop
      J.JSString s -> return $ J.fromJSString s
122 5aa48dbe Iustin Pop
      _ -> fail "Wrong JSON type"
123 9ba5c28f Iustin Pop
124 9188aeef Iustin Pop
-- | Converts a JSON message into an array of JSON objects.
125 c8b662f1 Iustin Pop
loadJSArray :: (Monad m)
126 c8b662f1 Iustin Pop
               => String -- ^ Operation description (for error reporting)
127 c8b662f1 Iustin Pop
               -> String -- ^ Input message
128 c8b662f1 Iustin Pop
               -> m [J.JSObject J.JSValue]
129 c96d44df Iustin Pop
loadJSArray s = fromJResult s . J.decodeStrict
130 9ba5c28f Iustin Pop
131 f36a8028 Iustin Pop
-- | Reads the value of a key in a JSON object.
132 262f3e6c Iustin Pop
fromObj :: (J.JSON a, Monad m) => String -> [(String, J.JSValue)] -> m a
133 9ba5c28f Iustin Pop
fromObj k o =
134 262f3e6c Iustin Pop
    case lookup k o of
135 585d4420 Iustin Pop
      Nothing -> fail $ printf "key '%s' not found in %s" k (show o)
136 f36a8028 Iustin Pop
      Just val -> fromKeyValue k val
137 f36a8028 Iustin Pop
138 f36a8028 Iustin Pop
-- | Reads the value of an optional key in a JSON object.
139 f36a8028 Iustin Pop
maybeFromObj :: (J.JSON a, Monad m) => String -> [(String, J.JSValue)]
140 f36a8028 Iustin Pop
                -> m (Maybe a)
141 f36a8028 Iustin Pop
maybeFromObj k o =
142 f36a8028 Iustin Pop
    case lookup k o of
143 f36a8028 Iustin Pop
      Nothing -> return Nothing
144 f36a8028 Iustin Pop
      Just val -> liftM Just (fromKeyValue k val)
145 f36a8028 Iustin Pop
146 f36a8028 Iustin Pop
-- | Reads a JValue, that originated from an object key
147 f36a8028 Iustin Pop
fromKeyValue :: (J.JSON a, Monad m)
148 f36a8028 Iustin Pop
              => String     -- ^ The key name
149 f36a8028 Iustin Pop
              -> J.JSValue  -- ^ The value to read
150 f36a8028 Iustin Pop
              -> m a
151 f36a8028 Iustin Pop
fromKeyValue k val =
152 f36a8028 Iustin Pop
  fromJResult (printf "key '%s', value '%s'" k (show val)) (J.readJSON val)
153 9ba5c28f Iustin Pop
154 117dc2d8 Iustin Pop
-- | Annotate a Result with an ownership information
155 117dc2d8 Iustin Pop
annotateResult :: String -> Result a -> Result a
156 117dc2d8 Iustin Pop
annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s
157 117dc2d8 Iustin Pop
annotateResult _ v = v
158 117dc2d8 Iustin Pop
159 117dc2d8 Iustin Pop
-- | Try to extract a key from a object with better error reporting
160 117dc2d8 Iustin Pop
-- than fromObj
161 117dc2d8 Iustin Pop
tryFromObj :: (J.JSON a) =>
162 117dc2d8 Iustin Pop
              String -> [(String, J.JSValue)] -> String -> Result a
163 50d26669 Iustin Pop
tryFromObj t o k = annotateResult t (fromObj k o)
164 117dc2d8 Iustin Pop
165 117dc2d8 Iustin Pop
-- | Small wrapper over readJSON.
166 117dc2d8 Iustin Pop
fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a
167 117dc2d8 Iustin Pop
fromJVal v =
168 117dc2d8 Iustin Pop
    case J.readJSON v of
169 117dc2d8 Iustin Pop
      J.Error s -> fail ("Cannot convert value " ++ show v ++ ", error: " ++ s)
170 117dc2d8 Iustin Pop
      J.Ok x -> return x
171 117dc2d8 Iustin Pop
172 9188aeef Iustin Pop
-- | Converts a JSON value into a JSON object.
173 5aa48dbe Iustin Pop
asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue)
174 5aa48dbe Iustin Pop
asJSObject (J.JSObject a) = return a
175 5aa48dbe Iustin Pop
asJSObject _ = fail "not an object"
176 942403e6 Iustin Pop
177 9188aeef Iustin Pop
-- | Coneverts a list of JSON values into a list of JSON objects.
178 5aa48dbe Iustin Pop
asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue]
179 9f6dcdea Iustin Pop
asObjectList = mapM asJSObject
180 5b763470 Iustin Pop
181 5b763470 Iustin Pop
-- * Parsing utility functions
182 5b763470 Iustin Pop
183 5b763470 Iustin Pop
-- | Parse results from readsPrec
184 5b763470 Iustin Pop
parseChoices :: (Monad m, Read a) => String -> String -> [(a, String)] -> m a
185 5b763470 Iustin Pop
parseChoices _ _ ((v, ""):[]) = return v
186 5b763470 Iustin Pop
parseChoices name s ((_, e):[]) =
187 5b763470 Iustin Pop
    fail $ name ++ ": leftover characters when parsing '"
188 5b763470 Iustin Pop
           ++ s ++ "': '" ++ e ++ "'"
189 5b763470 Iustin Pop
parseChoices name s _ = fail $ name ++ ": cannot parse string '" ++ s ++ "'"
190 5b763470 Iustin Pop
191 5b763470 Iustin Pop
-- | Safe 'read' function returning data encapsulated in a Result.
192 5b763470 Iustin Pop
tryRead :: (Monad m, Read a) => String -> String -> m a
193 5b763470 Iustin Pop
tryRead name s = parseChoices name s $ reads s
194 c5f7412e Iustin Pop
195 c5f7412e Iustin Pop
-- | Format a table of strings to maintain consistent length
196 c5f7412e Iustin Pop
formatTable :: [[String]] -> [Bool] -> [[String]]
197 c5f7412e Iustin Pop
formatTable vals numpos =
198 c5f7412e Iustin Pop
    let vtrans = transpose vals  -- transpose, so that we work on rows
199 c5f7412e Iustin Pop
                                 -- rather than columns
200 c5f7412e Iustin Pop
        mlens = map (maximum . map length) vtrans
201 c5f7412e Iustin Pop
        expnd = map (\(flds, isnum, ml) ->
202 c5f7412e Iustin Pop
                         map (\val ->
203 c5f7412e Iustin Pop
                                  let delta = ml - length val
204 c5f7412e Iustin Pop
                                      filler = replicate delta ' '
205 c5f7412e Iustin Pop
                                  in if delta > 0
206 c5f7412e Iustin Pop
                                     then if isnum
207 c5f7412e Iustin Pop
                                          then filler ++ val
208 c5f7412e Iustin Pop
                                          else val ++ filler
209 c5f7412e Iustin Pop
                                     else val
210 c5f7412e Iustin Pop
                             ) flds
211 c5f7412e Iustin Pop
                    ) (zip3 vtrans numpos mlens)
212 c5f7412e Iustin Pop
   in transpose expnd
213 9b9da389 Iustin Pop
214 c4d98278 Iustin Pop
-- | Default group UUID (just a string, not a real UUID)
215 c4d98278 Iustin Pop
defaultGroupID :: GroupID
216 c4d98278 Iustin Pop
defaultGroupID = "00000000-0000-0000-0000-000000000000"