Revision 26d62e4c

b/Makefile.am
421 421
	htools/Ganeti/HTools/Simu.hs \
422 422
	htools/Ganeti/HTools/Text.hs \
423 423
	htools/Ganeti/HTools/Types.hs \
424
	htools/Ganeti/HTools/Utils.hs \
425 424
	htools/Ganeti/HTools/Program.hs \
426 425
	htools/Ganeti/HTools/Program/Hail.hs \
427 426
	htools/Ganeti/HTools/Program/Hbal.hs \
......
456 455
	htools/Ganeti/Rpc.hs \
457 456
	htools/Ganeti/Runtime.hs \
458 457
	htools/Ganeti/Ssconf.hs \
459
	htools/Ganeti/THH.hs
458
	htools/Ganeti/THH.hs \
459
	htools/Ganeti/Utils.hs
460 460

  
461 461
HS_TEST_SRCS = \
462 462
	htest/Test/Ganeti/BasicTypes.hs \
......
473 473
	htest/Test/Ganeti/HTools/Simu.hs \
474 474
	htest/Test/Ganeti/HTools/Text.hs \
475 475
	htest/Test/Ganeti/HTools/Types.hs \
476
	htest/Test/Ganeti/HTools/Utils.hs \
477 476
	htest/Test/Ganeti/JSON.hs \
478 477
	htest/Test/Ganeti/Jobs.hs \
479 478
	htest/Test/Ganeti/Luxi.hs \
......
486 485
	htest/Test/Ganeti/Ssconf.hs \
487 486
	htest/Test/Ganeti/TestCommon.hs \
488 487
	htest/Test/Ganeti/TestHTools.hs \
489
	htest/Test/Ganeti/TestHelper.hs
488
	htest/Test/Ganeti/TestHelper.hs \
489
	htest/Test/Ganeti/Utils.hs
490 490

  
491 491
HS_LIBTEST_SRCS = $(HS_LIB_SRCS) $(HS_TEST_SRCS)
492 492

  
b/htest/Test/Ganeti/HTools/Text.hs
48 48
import qualified Ganeti.HTools.Node as Node
49 49
import qualified Ganeti.HTools.Text as Text
50 50
import qualified Ganeti.HTools.Types as Types
51
import qualified Ganeti.HTools.Utils as Utils
51
import qualified Ganeti.Utils as Utils
52 52

  
53 53
-- * Instance text loader tests
54 54

  
/dev/null
1
{-# LANGUAGE TemplateHaskell #-}
2
{-# OPTIONS_GHC -fno-warn-orphans #-}
3

  
4
{-| Unittests for ganeti-htools.
5

  
6
-}
7

  
8
{-
9

  
10
Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
11

  
12
This program is free software; you can redistribute it and/or modify
13
it under the terms of the GNU General Public License as published by
14
the Free Software Foundation; either version 2 of the License, or
15
(at your option) any later version.
16

  
17
This program is distributed in the hope that it will be useful, but
18
WITHOUT ANY WARRANTY; without even the implied warranty of
19
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
20
General Public License for more details.
21

  
22
You should have received a copy of the GNU General Public License
23
along with this program; if not, write to the Free Software
24
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
25
02110-1301, USA.
26

  
27
-}
28

  
29
module Test.Ganeti.HTools.Utils (testHTools_Utils) where
30

  
31
import Test.QuickCheck
32

  
33
import qualified Text.JSON as J
34

  
35
import Test.Ganeti.TestHelper
36
import Test.Ganeti.TestCommon
37

  
38
import qualified Ganeti.JSON as JSON
39
import qualified Ganeti.HTools.Types as Types
40
import qualified Ganeti.HTools.Utils as Utils
41

  
42
-- | Helper to generate a small string that doesn't contain commas.
43
genNonCommaString :: Gen String
44
genNonCommaString = do
45
  size <- choose (0, 20) -- arbitrary max size
46
  vectorOf size (arbitrary `suchThat` (/=) ',')
47

  
48
-- | If the list is not just an empty element, and if the elements do
49
-- not contain commas, then join+split should be idempotent.
50
prop_commaJoinSplit :: Property
51
prop_commaJoinSplit =
52
  forAll (choose (0, 20)) $ \llen ->
53
  forAll (vectorOf llen genNonCommaString `suchThat` (/=) [""]) $ \lst ->
54
  Utils.sepSplit ',' (Utils.commaJoin lst) ==? lst
55

  
56
-- | Split and join should always be idempotent.
57
prop_commaSplitJoin :: String -> Property
58
prop_commaSplitJoin s =
59
  Utils.commaJoin (Utils.sepSplit ',' s) ==? s
60

  
61
-- | fromObjWithDefault, we test using the Maybe monad and an integer
62
-- value.
63
prop_fromObjWithDefault :: Integer -> String -> Bool
64
prop_fromObjWithDefault def_value random_key =
65
  -- a missing key will be returned with the default
66
  JSON.fromObjWithDefault [] random_key def_value == Just def_value &&
67
  -- a found key will be returned as is, not with default
68
  JSON.fromObjWithDefault [(random_key, J.showJSON def_value)]
69
       random_key (def_value+1) == Just def_value
70

  
71
-- | Test that functional if' behaves like the syntactic sugar if.
72
prop_if'if :: Bool -> Int -> Int -> Gen Prop
73
prop_if'if cnd a b =
74
  Utils.if' cnd a b ==? if cnd then a else b
75

  
76
-- | Test basic select functionality
77
prop_select :: Int      -- ^ Default result
78
            -> [Int]    -- ^ List of False values
79
            -> [Int]    -- ^ List of True values
80
            -> Gen Prop -- ^ Test result
81
prop_select def lst1 lst2 =
82
  Utils.select def (flist ++ tlist) ==? expectedresult
83
    where expectedresult = Utils.if' (null lst2) def (head lst2)
84
          flist = zip (repeat False) lst1
85
          tlist = zip (repeat True)  lst2
86

  
87
-- | Test basic select functionality with undefined default
88
prop_select_undefd :: [Int]            -- ^ List of False values
89
                   -> NonEmptyList Int -- ^ List of True values
90
                   -> Gen Prop         -- ^ Test result
91
prop_select_undefd lst1 (NonEmpty lst2) =
92
  Utils.select undefined (flist ++ tlist) ==? head lst2
93
    where flist = zip (repeat False) lst1
94
          tlist = zip (repeat True)  lst2
95

  
96
-- | Test basic select functionality with undefined list values
97
prop_select_undefv :: [Int]            -- ^ List of False values
98
                   -> NonEmptyList Int -- ^ List of True values
99
                   -> Gen Prop         -- ^ Test result
100
prop_select_undefv lst1 (NonEmpty lst2) =
101
  Utils.select undefined cndlist ==? head lst2
102
    where flist = zip (repeat False) lst1
103
          tlist = zip (repeat True)  lst2
104
          cndlist = flist ++ tlist ++ [undefined]
105

  
106
prop_parseUnit :: NonNegative Int -> Property
107
prop_parseUnit (NonNegative n) =
108
  Utils.parseUnit (show n) ==? Types.Ok n .&&.
109
  Utils.parseUnit (show n ++ "m") ==? Types.Ok n .&&.
110
  Utils.parseUnit (show n ++ "M") ==? Types.Ok (truncate n_mb::Int) .&&.
111
  Utils.parseUnit (show n ++ "g") ==? Types.Ok (n*1024) .&&.
112
  Utils.parseUnit (show n ++ "G") ==? Types.Ok (truncate n_gb::Int) .&&.
113
  Utils.parseUnit (show n ++ "t") ==? Types.Ok (n*1048576) .&&.
114
  Utils.parseUnit (show n ++ "T") ==? Types.Ok (truncate n_tb::Int) .&&.
115
  printTestCase "Internal error/overflow?"
116
    (n_mb >=0 && n_gb >= 0 && n_tb >= 0) .&&.
117
  property (Types.isBad (Utils.parseUnit (show n ++ "x")::Types.Result Int))
118
  where n_mb = (fromIntegral n::Rational) * 1000 * 1000 / 1024 / 1024
119
        n_gb = n_mb * 1000
120
        n_tb = n_gb * 1000
121

  
122
-- | Test list for the Utils module.
123
testSuite "HTools/Utils"
124
            [ 'prop_commaJoinSplit
125
            , 'prop_commaSplitJoin
126
            , 'prop_fromObjWithDefault
127
            , 'prop_if'if
128
            , 'prop_select
129
            , 'prop_select_undefd
130
            , 'prop_select_undefv
131
            , 'prop_parseUnit
132
            ]
b/htest/Test/Ganeti/Utils.hs
1
{-# LANGUAGE TemplateHaskell #-}
2
{-# OPTIONS_GHC -fno-warn-orphans #-}
3

  
4
{-| Unittests for ganeti-htools.
5

  
6
-}
7

  
8
{-
9

  
10
Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
11

  
12
This program is free software; you can redistribute it and/or modify
13
it under the terms of the GNU General Public License as published by
14
the Free Software Foundation; either version 2 of the License, or
15
(at your option) any later version.
16

  
17
This program is distributed in the hope that it will be useful, but
18
WITHOUT ANY WARRANTY; without even the implied warranty of
19
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
20
General Public License for more details.
21

  
22
You should have received a copy of the GNU General Public License
23
along with this program; if not, write to the Free Software
24
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
25
02110-1301, USA.
26

  
27
-}
28

  
29
module Test.Ganeti.Utils (testUtils) where
30

  
31
import Test.QuickCheck
32

  
33
import qualified Text.JSON as J
34

  
35
import Test.Ganeti.TestHelper
36
import Test.Ganeti.TestCommon
37

  
38
import qualified Ganeti.JSON as JSON
39
import qualified Ganeti.HTools.Types as Types
40
import qualified Ganeti.Utils as Utils
41

  
42
-- | Helper to generate a small string that doesn't contain commas.
43
genNonCommaString :: Gen String
44
genNonCommaString = do
45
  size <- choose (0, 20) -- arbitrary max size
46
  vectorOf size (arbitrary `suchThat` (/=) ',')
47

  
48
-- | If the list is not just an empty element, and if the elements do
49
-- not contain commas, then join+split should be idempotent.
50
prop_commaJoinSplit :: Property
51
prop_commaJoinSplit =
52
  forAll (choose (0, 20)) $ \llen ->
53
  forAll (vectorOf llen genNonCommaString `suchThat` (/=) [""]) $ \lst ->
54
  Utils.sepSplit ',' (Utils.commaJoin lst) ==? lst
55

  
56
-- | Split and join should always be idempotent.
57
prop_commaSplitJoin :: String -> Property
58
prop_commaSplitJoin s =
59
  Utils.commaJoin (Utils.sepSplit ',' s) ==? s
60

  
61
-- | fromObjWithDefault, we test using the Maybe monad and an integer
62
-- value.
63
prop_fromObjWithDefault :: Integer -> String -> Bool
64
prop_fromObjWithDefault def_value random_key =
65
  -- a missing key will be returned with the default
66
  JSON.fromObjWithDefault [] random_key def_value == Just def_value &&
67
  -- a found key will be returned as is, not with default
68
  JSON.fromObjWithDefault [(random_key, J.showJSON def_value)]
69
       random_key (def_value+1) == Just def_value
70

  
71
-- | Test that functional if' behaves like the syntactic sugar if.
72
prop_if'if :: Bool -> Int -> Int -> Gen Prop
73
prop_if'if cnd a b =
74
  Utils.if' cnd a b ==? if cnd then a else b
75

  
76
-- | Test basic select functionality
77
prop_select :: Int      -- ^ Default result
78
            -> [Int]    -- ^ List of False values
79
            -> [Int]    -- ^ List of True values
80
            -> Gen Prop -- ^ Test result
81
prop_select def lst1 lst2 =
82
  Utils.select def (flist ++ tlist) ==? expectedresult
83
    where expectedresult = Utils.if' (null lst2) def (head lst2)
84
          flist = zip (repeat False) lst1
85
          tlist = zip (repeat True)  lst2
86

  
87
-- | Test basic select functionality with undefined default
88
prop_select_undefd :: [Int]            -- ^ List of False values
89
                   -> NonEmptyList Int -- ^ List of True values
90
                   -> Gen Prop         -- ^ Test result
91
prop_select_undefd lst1 (NonEmpty lst2) =
92
  Utils.select undefined (flist ++ tlist) ==? head lst2
93
    where flist = zip (repeat False) lst1
94
          tlist = zip (repeat True)  lst2
95

  
96
-- | Test basic select functionality with undefined list values
97
prop_select_undefv :: [Int]            -- ^ List of False values
98
                   -> NonEmptyList Int -- ^ List of True values
99
                   -> Gen Prop         -- ^ Test result
100
prop_select_undefv lst1 (NonEmpty lst2) =
101
  Utils.select undefined cndlist ==? head lst2
102
    where flist = zip (repeat False) lst1
103
          tlist = zip (repeat True)  lst2
104
          cndlist = flist ++ tlist ++ [undefined]
105

  
106
prop_parseUnit :: NonNegative Int -> Property
107
prop_parseUnit (NonNegative n) =
108
  Utils.parseUnit (show n) ==? Types.Ok n .&&.
109
  Utils.parseUnit (show n ++ "m") ==? Types.Ok n .&&.
110
  Utils.parseUnit (show n ++ "M") ==? Types.Ok (truncate n_mb::Int) .&&.
111
  Utils.parseUnit (show n ++ "g") ==? Types.Ok (n*1024) .&&.
112
  Utils.parseUnit (show n ++ "G") ==? Types.Ok (truncate n_gb::Int) .&&.
113
  Utils.parseUnit (show n ++ "t") ==? Types.Ok (n*1048576) .&&.
114
  Utils.parseUnit (show n ++ "T") ==? Types.Ok (truncate n_tb::Int) .&&.
115
  printTestCase "Internal error/overflow?"
116
    (n_mb >=0 && n_gb >= 0 && n_tb >= 0) .&&.
117
  property (Types.isBad (Utils.parseUnit (show n ++ "x")::Types.Result Int))
118
  where n_mb = (fromIntegral n::Rational) * 1000 * 1000 / 1024 / 1024
119
        n_gb = n_mb * 1000
120
        n_tb = n_gb * 1000
121

  
122
-- | Test list for the Utils module.
123
testSuite "Utils"
124
            [ 'prop_commaJoinSplit
125
            , 'prop_commaSplitJoin
126
            , 'prop_fromObjWithDefault
127
            , 'prop_if'if
128
            , 'prop_select
129
            , 'prop_select_undefd
130
            , 'prop_select_undefv
131
            , 'prop_parseUnit
132
            ]
b/htest/test.hs
44 44
import Test.Ganeti.HTools.Simu
45 45
import Test.Ganeti.HTools.Text
46 46
import Test.Ganeti.HTools.Types
47
import Test.Ganeti.HTools.Utils
48 47
import Test.Ganeti.Jobs
49 48
import Test.Ganeti.JSON
50 49
import Test.Ganeti.Luxi
......
55 54
import Test.Ganeti.Query.Query
56 55
import Test.Ganeti.Rpc
57 56
import Test.Ganeti.Ssconf
57
import Test.Ganeti.Utils
58 58

  
59 59
-- | Our default test options, overring the built-in test-framework
60 60
-- ones (but not the supplied command line parameters).
......
85 85
  , testHTools_Simu
86 86
  , testHTools_Text
87 87
  , testHTools_Types
88
  , testHTools_Utils
89 88
  , testJSON
90 89
  , testJobs
91 90
  , testLuxi
......
96 95
  , testQuery_Query
97 96
  , testRpc
98 97
  , testSsconf
98
  , testUtils
99 99
  ]
100 100

  
101 101
-- | Main function. Note we don't use defaultMain since we want to
b/htools/Ganeti/Confd/Server.hs
47 47
import Ganeti.Daemon
48 48
import Ganeti.JSON
49 49
import Ganeti.HTools.Types
50
import Ganeti.HTools.Utils
51 50
import Ganeti.Objects
52 51
import Ganeti.Confd
53 52
import Ganeti.Confd.Utils
54 53
import Ganeti.Config
55 54
import Ganeti.Hash
56 55
import Ganeti.Logging
56
import Ganeti.Utils
57 57
import qualified Ganeti.Constants as C
58 58
import qualified Ganeti.Path as Path
59 59
import Ganeti.Query.Server (runQueryD)
b/htools/Ganeti/Confd/Utils.hs
42 42
import qualified Ganeti.Constants as C
43 43
import qualified Ganeti.Path as Path
44 44
import Ganeti.JSON
45
import Ganeti.HTools.Utils
45
import Ganeti.Utils
46 46

  
47 47
-- | Returns the HMAC key.
48 48
getClusterHmac :: IO HashKey
b/htools/Ganeti/Daemon.hs
65 65
import Ganeti.Logging
66 66
import Ganeti.Runtime
67 67
import Ganeti.BasicTypes
68
import Ganeti.HTools.Utils
68
import Ganeti.Utils
69 69
import qualified Ganeti.Constants as C
70 70
import qualified Ganeti.Ssconf as Ssconf
71 71

  
b/htools/Ganeti/HTools/CLI.hs
1 1
{-| Implementation of command-line functions.
2 2

  
3 3
This module holds the common command-line related functions for the
4
binaries, separated into this module since "Ganeti.HTools.Utils" is
4
binaries, separated into this module since "Ganeti.Utils" is
5 5
used in many other places and this is more IO oriented.
6 6

  
7 7
-}
......
95 95
import qualified Ganeti.HTools.Node as Node
96 96
import qualified Ganeti.Path as Path
97 97
import Ganeti.HTools.Types
98
import Ganeti.HTools.Utils
99 98
import Ganeti.BasicTypes
100 99
import Ganeti.Common as Common
100
import Ganeti.Utils
101 101

  
102 102
-- * Data types
103 103

  
b/htools/Ganeti/HTools/Cluster.hs
86 86
import qualified Ganeti.HTools.Node as Node
87 87
import qualified Ganeti.HTools.Group as Group
88 88
import Ganeti.HTools.Types
89
import Ganeti.HTools.Utils
90 89
import Ganeti.Compat
91 90
import qualified Ganeti.OpCodes as OpCodes
91
import Ganeti.Utils
92 92

  
93 93
-- * Types
94 94

  
b/htools/Ganeti/HTools/ExtLoader.hs
51 51

  
52 52
import Ganeti.HTools.Types
53 53
import Ganeti.HTools.CLI
54
import Ganeti.HTools.Utils (sepSplit, tryRead, exitIfBad, exitWhen)
54
import Ganeti.Utils (sepSplit, tryRead, exitIfBad, exitWhen)
55 55

  
56 56
-- | Error beautifier.
57 57
wrapIO :: IO (Result a) -> IO (Result a)
b/htools/Ganeti/HTools/Instance.hs
60 60
import qualified Ganeti.HTools.Types as T
61 61
import qualified Ganeti.HTools.Container as Container
62 62

  
63
import Ganeti.HTools.Utils
63
import Ganeti.Utils
64 64

  
65 65
-- * Type declarations
66 66

  
b/htools/Ganeti/HTools/Loader.hs
52 52

  
53 53
import Ganeti.BasicTypes
54 54
import Ganeti.HTools.Types
55
import Ganeti.HTools.Utils
55
import Ganeti.Utils
56 56

  
57 57
-- * Constants
58 58

  
b/htools/Ganeti/HTools/Program/Hbal.hs
50 50

  
51 51
import Ganeti.HTools.CLI
52 52
import Ganeti.HTools.ExtLoader
53
import Ganeti.HTools.Utils
54 53
import Ganeti.HTools.Types
55 54
import Ganeti.HTools.Loader
55
import Ganeti.Utils
56 56

  
57 57
import qualified Ganeti.Luxi as L
58 58
import Ganeti.Jobs
b/htools/Ganeti/HTools/Program/Hinfo.hs
38 38
import qualified Ganeti.HTools.Group as Group
39 39
import qualified Ganeti.HTools.Instance as Instance
40 40

  
41
import Ganeti.HTools.Utils
42 41
import Ganeti.HTools.CLI
43 42
import Ganeti.HTools.ExtLoader
44 43
import Ganeti.HTools.Loader
44
import Ganeti.Utils
45 45

  
46 46
-- | Options list and functions.
47 47
options :: [OptType]
b/htools/Ganeti/HTools/Program/Hspace.hs
40 40
import qualified Ganeti.HTools.Node as Node
41 41
import qualified Ganeti.HTools.Instance as Instance
42 42

  
43
import Ganeti.HTools.Utils
44 43
import Ganeti.HTools.Types
45 44
import Ganeti.HTools.CLI
46 45
import Ganeti.HTools.ExtLoader
47 46
import Ganeti.HTools.Loader
47
import Ganeti.Utils
48 48

  
49 49
-- | Options list and functions.
50 50
options :: [OptType]
b/htools/Ganeti/HTools/Simu.hs
33 33
import Control.Monad (mplus, zipWithM)
34 34
import Text.Printf (printf)
35 35

  
36
import Ganeti.HTools.Utils
36
import Ganeti.Utils
37 37
import Ganeti.HTools.Types
38 38
import Ganeti.HTools.Loader
39 39
import qualified Ganeti.HTools.Container as Container
b/htools/Ganeti/HTools/Text.hs
47 47

  
48 48
import Text.Printf (printf)
49 49

  
50
import Ganeti.HTools.Utils
50
import Ganeti.Utils
51 51
import Ganeti.HTools.Loader
52 52
import Ganeti.HTools.Types
53 53
import qualified Ganeti.HTools.Container as Container
/dev/null
1
{-| Utility functions. -}
2

  
3
{-
4

  
5
Copyright (C) 2009, 2010, 2011, 2012 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
  ( debug
26
  , debugFn
27
  , debugXy
28
  , sepSplit
29
  , stdDev
30
  , if'
31
  , select
32
  , applyIf
33
  , commaJoin
34
  , ensureQuoted
35
  , tryRead
36
  , formatTable
37
  , printTable
38
  , parseUnit
39
  , plural
40
  , exitIfBad
41
  , exitErr
42
  , exitWhen
43
  , exitUnless
44
  ) where
45

  
46
import Data.Char (toUpper, isAlphaNum)
47
import Data.List
48

  
49
import Debug.Trace
50

  
51
import Ganeti.BasicTypes
52
import System.IO
53
import System.Exit
54

  
55
-- * Debug functions
56

  
57
-- | To be used only for debugging, breaks referential integrity.
58
debug :: Show a => a -> a
59
debug x = trace (show x) x
60

  
61
-- | Displays a modified form of the second parameter before returning
62
-- it.
63
debugFn :: Show b => (a -> b) -> a -> a
64
debugFn fn x = debug (fn x) `seq` x
65

  
66
-- | Show the first parameter before returning the second one.
67
debugXy :: Show a => a -> b -> b
68
debugXy = seq . debug
69

  
70
-- * Miscellaneous
71

  
72
-- | Apply the function if condition holds, otherwise use default value.
73
applyIf :: Bool -> (a -> a) -> a -> a
74
applyIf b f x = if b then f x else x
75

  
76
-- | Comma-join a string list.
77
commaJoin :: [String] -> String
78
commaJoin = intercalate ","
79

  
80
-- | Split a list on a separator and return an array.
81
sepSplit :: Eq a => a -> [a] -> [[a]]
82
sepSplit sep s
83
  | null s    = []
84
  | null xs   = [x]
85
  | null ys   = [x,[]]
86
  | otherwise = x:sepSplit sep ys
87
  where (x, xs) = break (== sep) s
88
        ys = drop 1 xs
89

  
90
-- | Simple pluralize helper
91
plural :: Int -> String -> String -> String
92
plural 1 s _ = s
93
plural _ _ p = p
94

  
95
-- | Ensure a value is quoted if needed.
96
ensureQuoted :: String -> String
97
ensureQuoted v = if not (all (\c -> isAlphaNum c || c == '.') v)
98
                 then '\'':v ++ "'"
99
                 else v
100

  
101
-- * Mathematical functions
102

  
103
-- Simple and slow statistical functions, please replace with better
104
-- versions
105

  
106
-- | Standard deviation function.
107
stdDev :: [Double] -> Double
108
stdDev lst =
109
  -- first, calculate the list length and sum lst in a single step,
110
  -- for performance reasons
111
  let (ll', sx) = foldl' (\(rl, rs) e ->
112
                           let rl' = rl + 1
113
                               rs' = rs + e
114
                           in rl' `seq` rs' `seq` (rl', rs')) (0::Int, 0) lst
115
      ll = fromIntegral ll'::Double
116
      mv = sx / ll
117
      av = foldl' (\accu em -> let d = em - mv in accu + d * d) 0.0 lst
118
  in sqrt (av / ll) -- stddev
119

  
120
-- *  Logical functions
121

  
122
-- Avoid syntactic sugar and enhance readability. These functions are proposed
123
-- by some for inclusion in the Prelude, and at the moment they are present
124
-- (with various definitions) in the utility-ht package. Some rationale and
125
-- discussion is available at <http://www.haskell.org/haskellwiki/If-then-else>
126

  
127
-- | \"if\" as a function, rather than as syntactic sugar.
128
if' :: Bool -- ^ condition
129
    -> a    -- ^ \"then\" result
130
    -> a    -- ^ \"else\" result
131
    -> a    -- ^ \"then\" or "else" result depending on the condition
132
if' True x _ = x
133
if' _    _ y = y
134

  
135
-- * Parsing utility functions
136

  
137
-- | Parse results from readsPrec.
138
parseChoices :: (Monad m, Read a) => String -> String -> [(a, String)] -> m a
139
parseChoices _ _ ((v, ""):[]) = return v
140
parseChoices name s ((_, e):[]) =
141
    fail $ name ++ ": leftover characters when parsing '"
142
           ++ s ++ "': '" ++ e ++ "'"
143
parseChoices name s _ = fail $ name ++ ": cannot parse string '" ++ s ++ "'"
144

  
145
-- | Safe 'read' function returning data encapsulated in a Result.
146
tryRead :: (Monad m, Read a) => String -> String -> m a
147
tryRead name s = parseChoices name s $ reads s
148

  
149
-- | Format a table of strings to maintain consistent length.
150
formatTable :: [[String]] -> [Bool] -> [[String]]
151
formatTable vals numpos =
152
    let vtrans = transpose vals  -- transpose, so that we work on rows
153
                                 -- rather than columns
154
        mlens = map (maximum . map length) vtrans
155
        expnd = map (\(flds, isnum, ml) ->
156
                         map (\val ->
157
                                  let delta = ml - length val
158
                                      filler = replicate delta ' '
159
                                  in if delta > 0
160
                                     then if isnum
161
                                          then filler ++ val
162
                                          else val ++ filler
163
                                     else val
164
                             ) flds
165
                    ) (zip3 vtrans numpos mlens)
166
   in transpose expnd
167

  
168
-- | Constructs a printable table from given header and rows
169
printTable :: String -> [String] -> [[String]] -> [Bool] -> String
170
printTable lp header rows isnum =
171
  unlines . map ((++) lp . (:) ' ' . unwords) $
172
  formatTable (header:rows) isnum
173

  
174
-- | Converts a unit (e.g. m or GB) into a scaling factor.
175
parseUnitValue :: (Monad m) => String -> m Rational
176
parseUnitValue unit
177
  -- binary conversions first
178
  | null unit                     = return 1
179
  | unit == "m" || upper == "MIB" = return 1
180
  | unit == "g" || upper == "GIB" = return kbBinary
181
  | unit == "t" || upper == "TIB" = return $ kbBinary * kbBinary
182
  -- SI conversions
183
  | unit == "M" || upper == "MB"  = return mbFactor
184
  | unit == "G" || upper == "GB"  = return $ mbFactor * kbDecimal
185
  | unit == "T" || upper == "TB"  = return $ mbFactor * kbDecimal * kbDecimal
186
  | otherwise = fail $ "Unknown unit '" ++ unit ++ "'"
187
  where upper = map toUpper unit
188
        kbBinary = 1024 :: Rational
189
        kbDecimal = 1000 :: Rational
190
        decToBin = kbDecimal / kbBinary -- factor for 1K conversion
191
        mbFactor = decToBin * decToBin -- twice the factor for just 1K
192

  
193
-- | Tries to extract number and scale from the given string.
194
--
195
-- Input must be in the format NUMBER+ SPACE* [UNIT]. If no unit is
196
-- specified, it defaults to MiB. Return value is always an integral
197
-- value in MiB.
198
parseUnit :: (Monad m, Integral a, Read a) => String -> m a
199
parseUnit str =
200
  -- TODO: enhance this by splitting the unit parsing code out and
201
  -- accepting floating-point numbers
202
  case (reads str::[(Int, String)]) of
203
    [(v, suffix)] ->
204
      let unit = dropWhile (== ' ') suffix
205
      in do
206
        scaling <- parseUnitValue unit
207
        return $ truncate (fromIntegral v * scaling)
208
    _ -> fail $ "Can't parse string '" ++ str ++ "'"
209

  
210
-- | Unwraps a 'Result', exiting the program if it is a 'Bad' value,
211
-- otherwise returning the actual contained value.
212
exitIfBad :: String -> Result a -> IO a
213
exitIfBad msg (Bad s) = do
214
  hPutStrLn stderr $ "Error: " ++ msg ++ ": " ++ s
215
  exitWith (ExitFailure 1)
216
exitIfBad _ (Ok v) = return v
217

  
218
-- | Exits immediately with an error message.
219
exitErr :: String -> IO a
220
exitErr errmsg = do
221
  hPutStrLn stderr $ "Error: " ++ errmsg ++ "."
222
  exitWith (ExitFailure 1)
223

  
224
-- | Exits with an error message if the given boolean condition if true.
225
exitWhen :: Bool -> String -> IO ()
226
exitWhen True msg = exitErr msg
227
exitWhen False _  = return ()
228

  
229
-- | Exits with an error message /unless/ the given boolean condition
230
-- if true, the opposite of 'exitWhen'.
231
exitUnless :: Bool -> String -> IO ()
232
exitUnless cond = exitWhen (not cond)
b/htools/Ganeti/Luxi.hs
69 69

  
70 70
import Ganeti.JSON
71 71
import Ganeti.HTools.Types
72
import Ganeti.HTools.Utils
72
import Ganeti.Utils
73 73

  
74 74
import Ganeti.Constants
75 75
import Ganeti.Jobs (JobStatus)
b/htools/Ganeti/Ssconf.hs
48 48
import qualified Ganeti.Constants as C
49 49
import qualified Ganeti.Path as Path
50 50
import Ganeti.BasicTypes
51
import Ganeti.HTools.Utils
51
import Ganeti.Utils
52 52

  
53 53
-- | Maximum ssconf file size we support.
54 54
maxFileSize :: Int
b/htools/Ganeti/Utils.hs
1
{-| Utility functions. -}
2

  
3
{-
4

  
5
Copyright (C) 2009, 2010, 2011, 2012 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.Utils
25
  ( debug
26
  , debugFn
27
  , debugXy
28
  , sepSplit
29
  , stdDev
30
  , if'
31
  , select
32
  , applyIf
33
  , commaJoin
34
  , ensureQuoted
35
  , tryRead
36
  , formatTable
37
  , printTable
38
  , parseUnit
39
  , plural
40
  , exitIfBad
41
  , exitErr
42
  , exitWhen
43
  , exitUnless
44
  ) where
45

  
46
import Data.Char (toUpper, isAlphaNum)
47
import Data.List
48

  
49
import Debug.Trace
50

  
51
import Ganeti.BasicTypes
52
import System.IO
53
import System.Exit
54

  
55
-- * Debug functions
56

  
57
-- | To be used only for debugging, breaks referential integrity.
58
debug :: Show a => a -> a
59
debug x = trace (show x) x
60

  
61
-- | Displays a modified form of the second parameter before returning
62
-- it.
63
debugFn :: Show b => (a -> b) -> a -> a
64
debugFn fn x = debug (fn x) `seq` x
65

  
66
-- | Show the first parameter before returning the second one.
67
debugXy :: Show a => a -> b -> b
68
debugXy = seq . debug
69

  
70
-- * Miscellaneous
71

  
72
-- | Apply the function if condition holds, otherwise use default value.
73
applyIf :: Bool -> (a -> a) -> a -> a
74
applyIf b f x = if b then f x else x
75

  
76
-- | Comma-join a string list.
77
commaJoin :: [String] -> String
78
commaJoin = intercalate ","
79

  
80
-- | Split a list on a separator and return an array.
81
sepSplit :: Eq a => a -> [a] -> [[a]]
82
sepSplit sep s
83
  | null s    = []
84
  | null xs   = [x]
85
  | null ys   = [x,[]]
86
  | otherwise = x:sepSplit sep ys
87
  where (x, xs) = break (== sep) s
88
        ys = drop 1 xs
89

  
90
-- | Simple pluralize helper
91
plural :: Int -> String -> String -> String
92
plural 1 s _ = s
93
plural _ _ p = p
94

  
95
-- | Ensure a value is quoted if needed.
96
ensureQuoted :: String -> String
97
ensureQuoted v = if not (all (\c -> isAlphaNum c || c == '.') v)
98
                 then '\'':v ++ "'"
99
                 else v
100

  
101
-- * Mathematical functions
102

  
103
-- Simple and slow statistical functions, please replace with better
104
-- versions
105

  
106
-- | Standard deviation function.
107
stdDev :: [Double] -> Double
108
stdDev lst =
109
  -- first, calculate the list length and sum lst in a single step,
110
  -- for performance reasons
111
  let (ll', sx) = foldl' (\(rl, rs) e ->
112
                           let rl' = rl + 1
113
                               rs' = rs + e
114
                           in rl' `seq` rs' `seq` (rl', rs')) (0::Int, 0) lst
115
      ll = fromIntegral ll'::Double
116
      mv = sx / ll
117
      av = foldl' (\accu em -> let d = em - mv in accu + d * d) 0.0 lst
118
  in sqrt (av / ll) -- stddev
119

  
120
-- *  Logical functions
121

  
122
-- Avoid syntactic sugar and enhance readability. These functions are proposed
123
-- by some for inclusion in the Prelude, and at the moment they are present
124
-- (with various definitions) in the utility-ht package. Some rationale and
125
-- discussion is available at <http://www.haskell.org/haskellwiki/If-then-else>
126

  
127
-- | \"if\" as a function, rather than as syntactic sugar.
128
if' :: Bool -- ^ condition
129
    -> a    -- ^ \"then\" result
130
    -> a    -- ^ \"else\" result
131
    -> a    -- ^ \"then\" or "else" result depending on the condition
132
if' True x _ = x
133
if' _    _ y = y
134

  
135
-- * Parsing utility functions
136

  
137
-- | Parse results from readsPrec.
138
parseChoices :: (Monad m, Read a) => String -> String -> [(a, String)] -> m a
139
parseChoices _ _ ((v, ""):[]) = return v
140
parseChoices name s ((_, e):[]) =
141
    fail $ name ++ ": leftover characters when parsing '"
142
           ++ s ++ "': '" ++ e ++ "'"
143
parseChoices name s _ = fail $ name ++ ": cannot parse string '" ++ s ++ "'"
144

  
145
-- | Safe 'read' function returning data encapsulated in a Result.
146
tryRead :: (Monad m, Read a) => String -> String -> m a
147
tryRead name s = parseChoices name s $ reads s
148

  
149
-- | Format a table of strings to maintain consistent length.
150
formatTable :: [[String]] -> [Bool] -> [[String]]
151
formatTable vals numpos =
152
    let vtrans = transpose vals  -- transpose, so that we work on rows
153
                                 -- rather than columns
154
        mlens = map (maximum . map length) vtrans
155
        expnd = map (\(flds, isnum, ml) ->
156
                         map (\val ->
157
                                  let delta = ml - length val
158
                                      filler = replicate delta ' '
159
                                  in if delta > 0
160
                                     then if isnum
161
                                          then filler ++ val
162
                                          else val ++ filler
163
                                     else val
164
                             ) flds
165
                    ) (zip3 vtrans numpos mlens)
166
   in transpose expnd
167

  
168
-- | Constructs a printable table from given header and rows
169
printTable :: String -> [String] -> [[String]] -> [Bool] -> String
170
printTable lp header rows isnum =
171
  unlines . map ((++) lp . (:) ' ' . unwords) $
172
  formatTable (header:rows) isnum
173

  
174
-- | Converts a unit (e.g. m or GB) into a scaling factor.
175
parseUnitValue :: (Monad m) => String -> m Rational
176
parseUnitValue unit
177
  -- binary conversions first
178
  | null unit                     = return 1
179
  | unit == "m" || upper == "MIB" = return 1
180
  | unit == "g" || upper == "GIB" = return kbBinary
181
  | unit == "t" || upper == "TIB" = return $ kbBinary * kbBinary
182
  -- SI conversions
183
  | unit == "M" || upper == "MB"  = return mbFactor
184
  | unit == "G" || upper == "GB"  = return $ mbFactor * kbDecimal
185
  | unit == "T" || upper == "TB"  = return $ mbFactor * kbDecimal * kbDecimal
186
  | otherwise = fail $ "Unknown unit '" ++ unit ++ "'"
187
  where upper = map toUpper unit
188
        kbBinary = 1024 :: Rational
189
        kbDecimal = 1000 :: Rational
190
        decToBin = kbDecimal / kbBinary -- factor for 1K conversion
191
        mbFactor = decToBin * decToBin -- twice the factor for just 1K
192

  
193
-- | Tries to extract number and scale from the given string.
194
--
195
-- Input must be in the format NUMBER+ SPACE* [UNIT]. If no unit is
196
-- specified, it defaults to MiB. Return value is always an integral
197
-- value in MiB.
198
parseUnit :: (Monad m, Integral a, Read a) => String -> m a
199
parseUnit str =
200
  -- TODO: enhance this by splitting the unit parsing code out and
201
  -- accepting floating-point numbers
202
  case (reads str::[(Int, String)]) of
203
    [(v, suffix)] ->
204
      let unit = dropWhile (== ' ') suffix
205
      in do
206
        scaling <- parseUnitValue unit
207
        return $ truncate (fromIntegral v * scaling)
208
    _ -> fail $ "Can't parse string '" ++ str ++ "'"
209

  
210
-- | Unwraps a 'Result', exiting the program if it is a 'Bad' value,
211
-- otherwise returning the actual contained value.
212
exitIfBad :: String -> Result a -> IO a
213
exitIfBad msg (Bad s) = do
214
  hPutStrLn stderr $ "Error: " ++ msg ++ ": " ++ s
215
  exitWith (ExitFailure 1)
216
exitIfBad _ (Ok v) = return v
217

  
218
-- | Exits immediately with an error message.
219
exitErr :: String -> IO a
220
exitErr errmsg = do
221
  hPutStrLn stderr $ "Error: " ++ errmsg ++ "."
222
  exitWith (ExitFailure 1)
223

  
224
-- | Exits with an error message if the given boolean condition if true.
225
exitWhen :: Bool -> String -> IO ()
226
exitWhen True msg = exitErr msg
227
exitWhen False _  = return ()
228

  
229
-- | Exits with an error message /unless/ the given boolean condition
230
-- if true, the opposite of 'exitWhen'.
231
exitUnless :: Bool -> String -> IO ()
232
exitUnless cond = exitWhen (not cond)
b/htools/htools.hs
34 34
import System.IO
35 35
import System.IO.Error (isDoesNotExistError)
36 36

  
37
import Ganeti.HTools.Utils
37
import Ganeti.Utils
38 38
import Ganeti.HTools.CLI (parseOpts, genericOpts)
39 39
import Ganeti.HTools.Program (personalities)
40 40

  

Also available in: Unified diff