Revision 9ba5c28f

b/Ganeti/HTools/IAlloc.hs
16 16
import Ganeti.HTools.Utils ()
17 17

  
18 18

  
19
-- Some constants
20

  
21
{-- Our cheap monad-like stuff.
22

  
23
Thi is needed since Either e a is already a monad instance somewhere
24
in the standard libraries (Control.Monad.Error) and we don't need that
25
entire thing.
26

  
27
-}
28
combine :: (Either String a) -> (a -> Either String b)  -> (Either String b)
29
combine (Left s) _ = Left s
30
combine (Right s) f = f s
31

  
32
ensureList :: [Either String a] -> Either String [a]
33
ensureList lst =
34
    foldr (\elem accu ->
35
               case (elem, accu) of
36
                 (Left x, _) -> Left x
37
                 (_, Left x) -> Left x -- should never happen
38
                 (Right e, Right a) -> Right (e:a)
39
          )
40
    (Right []) lst
41

  
42
listHead :: Either String [a] -> Either String a
43
listHead lst =
44
    case lst of
45
      Left x -> Left x
46
      Right (x:_) -> Right x
47
      Right [] -> Left "List empty"
48

  
49
loadJSArray :: String -> Either String [JSObject JSValue]
50
loadJSArray s = resultToEither $ decodeStrict s
51

  
52
fromObj :: JSON a => String -> JSObject JSValue -> Either String a
53
fromObj k o =
54
    case lookup k (fromJSObject o) of
55
      Nothing -> Left $ printf "key '%s' not found" k
56
      Just val -> resultToEither $ readJSON val
57

  
58
getStringElement :: String -> JSObject JSValue -> Either String String
59
getStringElement = fromObj
60

  
61
getIntElement :: String -> JSObject JSValue -> Either String Int
62
getIntElement = fromObj
63

  
64
getListElement :: String -> JSObject JSValue
65
               -> Either String [JSValue]
66
getListElement = fromObj
67

  
68
readString :: JSValue -> Either String String
69
readString v =
70
    case v of
71
      JSString s -> Right $ fromJSString s
72
      _ -> Left "Wrong JSON type"
73

  
74
concatElems :: Either String String
75
            -> Either String String
76
            -> Either String String
77
concatElems = apply2 (\x y -> x ++ "|" ++ y)
78

  
79
apply1 :: (a -> b) -> Either String a -> Either String b
80
apply1 fn a =
81
    case a of
82
      Left x -> Left x
83
      Right y -> Right $ fn y
84

  
85
apply2 :: (a -> b -> c)
86
       -> Either String a
87
       -> Either String b
88
       -> Either String c
89
apply2 fn a b =
90
    case (a, b) of
91
      (Right x, Right y) -> Right $ fn x y
92
      (Left x, _) -> Left x
93
      (_, Left y) -> Left y
94

  
95
parseList :: (JSObject JSValue -> Either String String)
96
          -> [JSObject JSValue]
97
          ->Either String String
98
parseList fn idata =
99
    let ml = ensureList $ map fn idata
100
    in ml `combine` (Right . unlines)
101

  
102 19
parseInstance :: JSObject JSValue -> Either String String
103 20
parseInstance a =
104 21
    let name = getStringElement "name" a
b/Ganeti/HTools/Rapi.hs
16 16
import Control.Monad
17 17
import Text.JSON
18 18
import Text.Printf (printf)
19
import Ganeti.HTools.Utils ()
19
import Ganeti.HTools.Utils
20 20

  
21 21

  
22 22
-- Some constants
......
24 24
-- | The fixed drbd overhead per disk (only used with 1.2's sdx_size)
25 25
drbdOverhead = 128
26 26

  
27
{-- Our cheap monad-like stuff.
28

  
29
Thi is needed since Either e a is already a monad instance somewhere
30
in the standard libraries (Control.Monad.Error) and we don't need that
31
entire thing.
32

  
33
-}
34
combine :: (Either String a) -> (a -> Either String b)  -> (Either String b)
35
combine (Left s) _ = Left s
36
combine (Right s) f = f s
37

  
38
ensureList :: [Either String a] -> Either String [a]
39
ensureList lst =
40
    foldr (\elem accu ->
41
               case (elem, accu) of
42
                 (Left x, _) -> Left x
43
                 (_, Left x) -> Left x -- should never happen
44
                 (Right e, Right a) -> Right (e:a)
45
          )
46
    (Right []) lst
47

  
48
listHead :: Either String [a] -> Either String a
49
listHead lst =
50
    case lst of
51
      Left x -> Left x
52
      Right (x:_) -> Right x
53
      Right [] -> Left "List empty"
54

  
55
loadJSArray :: String -> Either String [JSObject JSValue]
56
loadJSArray s = resultToEither $ decodeStrict s
57

  
58
fromObj :: JSON a => String -> JSObject JSValue -> Either String a
59
fromObj k o =
60
    case lookup k (fromJSObject o) of
61
      Nothing -> Left $ printf "key '%s' not found" k
62
      Just val -> resultToEither $ readJSON val
63

  
64
getStringElement :: String -> JSObject JSValue -> Either String String
65
getStringElement = fromObj
66

  
67
getIntElement :: String -> JSObject JSValue -> Either String Int
68
getIntElement = fromObj
69

  
70
getListElement :: String -> JSObject JSValue
71
               -> Either String [JSValue]
72
getListElement = fromObj
73

  
74
readString :: JSValue -> Either String String
75
readString v =
76
    case v of
77
      JSString s -> Right $ fromJSString s
78
      _ -> Left "Wrong JSON type"
79

  
80
concatElems :: Either String String
81
            -> Either String String
82
            -> Either String String
83
concatElems = apply2 (\x y -> x ++ "|" ++ y)
84

  
85
apply1 :: (a -> b) -> Either String a -> Either String b
86
apply1 fn a =
87
    case a of
88
      Left x -> Left x
89
      Right y -> Right $ fn y
90

  
91
apply2 :: (a -> b -> c)
92
       -> Either String a
93
       -> Either String b
94
       -> Either String c
95
apply2 fn a b =
96
    case (a, b) of
97
      (Right x, Right y) -> Right $ fn x y
98
      (Left x, _) -> Left x
99
      (_, Left y) -> Left y
100

  
101 27
getUrl :: String -> IO (Either String String)
102 28
getUrl url = do
103 29
  (code, body) <- curlGetString url [CurlSSLVerifyPeer False,
......
122 48
        url1 = printf "http://%s:5080/instances?bulk=1" master
123 49
    in do
124 50
      body <- tryRapi url1 url2
125
      let inst = body `combine` loadJSArray `combine` (parseList parseInstance)
51
      let inst = body `combineEithers`
52
                 loadJSArray `combineEithers`
53
                 (parseEitherList parseInstance)
126 54
      return inst
127 55

  
128 56
getNodes :: String -> IO (Either String String)
......
132 60
        url1 = printf "http://%s:5080/nodes?bulk=1" master
133 61
    in do
134 62
      body <- tryRapi url1 url2
135
      let inst = body `combine` loadJSArray `combine` (parseList parseNode)
63
      let inst = body `combineEithers`
64
                 loadJSArray `combineEithers`
65
                 (parseEitherList parseNode)
136 66
      return inst
137 67

  
138
parseList :: (JSObject JSValue -> Either String String)
139
          -> [JSObject JSValue]
140
          ->Either String String
141
parseList fn idata =
142
    let ml = ensureList $ map fn idata
143
    in ml `combine` (Right . unlines)
144

  
145 68
parseInstance :: JSObject JSValue -> Either String String
146 69
parseInstance a =
147 70
    let name = getStringElement "name" a
148 71
        disk = case getIntElement "disk_usage" a of
149
                 Left _ -> let log_sz = apply2 (+)
72
                 Left _ -> let log_sz = applyEither2 (+)
150 73
                                        (getIntElement "sda_size" a)
151 74
                                        (getIntElement "sdb_size" a)
152
                           in apply2 (+) log_sz (Right $ drbdOverhead * 2)
75
                           in applyEither2 (+) log_sz
76
                                  (Right $ drbdOverhead * 2)
153 77
                 Right x -> Right x
154 78
        bep = fromObj "beparams" a
155 79
        pnode = getStringElement "pnode" a
156
        snode = (listHead $ getListElement "snodes" a) `combine` readString
80
        snode = (eitherListHead $ getListElement "snodes" a)
81
                `combineEithers` readEitherString
157 82
        mem = case bep of
158 83
                Left _ -> getIntElement "admin_ram" a
159 84
                Right o -> getIntElement "memory" o
160 85
        running = getStringElement "status" a
161 86
    in
162
      concatElems name $
163
                  concatElems (show `apply1` mem) $
164
                  concatElems (show `apply1` disk) $
165
                  concatElems running $
166
                  concatElems pnode snode
87
      concatEitherElems name $
88
                  concatEitherElems (show `applyEither1` mem) $
89
                  concatEitherElems (show `applyEither1` disk) $
90
                  concatEitherElems running $
91
                  concatEitherElems pnode snode
167 92

  
168 93
parseNode :: JSObject JSValue -> Either String String
169 94
parseNode a =
......
173 98
        mfree = getIntElement "mfree" a
174 99
        dtotal = getIntElement "dtotal" a
175 100
        dfree = getIntElement "dfree" a
176
    in concatElems name $
177
       concatElems (show `apply1` mtotal) $
178
       concatElems (show `apply1` mnode) $
179
       concatElems (show `apply1` mfree) $
180
       concatElems (show `apply1` dtotal) (show `apply1` dfree)
101
    in concatEitherElems name $
102
       concatEitherElems (show `applyEither1` mtotal) $
103
       concatEitherElems (show `applyEither1` mnode) $
104
       concatEitherElems (show `applyEither1` mfree) $
105
       concatEitherElems (show `applyEither1` dtotal)
106
                             (show `applyEither1` dfree)
b/Ganeti/HTools/Utils.hs
11 11
    , varianceCoeff
12 12
    , readData
13 13
    , commaJoin
14
    , combineEithers
15
    , ensureEitherList
16
    , eitherListHead
17
    , readEitherString
18
    , parseEitherList
19
    , loadJSArray
20
    , fromObj
21
    , getStringElement
22
    , getIntElement
23
    , getListElement
24
    , concatEitherElems
25
    , applyEither1
26
    , applyEither2
14 27
    ) where
15 28

  
16 29
import Data.Either
......
18 31
import Monad
19 32
import System
20 33
import System.IO
34
import Text.JSON
35
import Text.Printf (printf)
21 36

  
22 37
import Debug.Trace
23 38

  
......
88 103
         putStrLn $ fromLeft nd
89 104
         exitWith $ ExitFailure 1
90 105
  return $ fromRight nd
106

  
107
{-- Our cheap monad-like stuff.
108

  
109
Thi is needed since Either e a is already a monad instance somewhere
110
in the standard libraries (Control.Monad.Error) and we don't need that
111
entire thing.
112

  
113
-}
114
combineEithers :: (Either String a)
115
               -> (a -> Either String b)
116
               -> (Either String b)
117
combineEithers (Left s) _ = Left s
118
combineEithers (Right s) f = f s
119

  
120
ensureEitherList :: [Either String a] -> Either String [a]
121
ensureEitherList lst =
122
    foldr (\elem accu ->
123
               case (elem, accu) of
124
                 (Left x, _) -> Left x
125
                 (_, Left x) -> Left x -- should never happen
126
                 (Right e, Right a) -> Right (e:a)
127
          )
128
    (Right []) lst
129

  
130
eitherListHead :: Either String [a] -> Either String a
131
eitherListHead lst =
132
    case lst of
133
      Left x -> Left x
134
      Right (x:_) -> Right x
135
      Right [] -> Left "List empty"
136

  
137
readEitherString :: JSValue -> Either String String
138
readEitherString v =
139
    case v of
140
      JSString s -> Right $ fromJSString s
141
      _ -> Left "Wrong JSON type"
142

  
143
parseEitherList :: (JSObject JSValue -> Either String String)
144
          -> [JSObject JSValue]
145
          -> Either String String
146
parseEitherList fn idata =
147
    let ml = ensureEitherList $ map fn idata
148
    in ml `combineEithers` (Right . unlines)
149

  
150
loadJSArray :: String -> Either String [JSObject JSValue]
151
loadJSArray s = resultToEither $ decodeStrict s
152

  
153
fromObj :: JSON a => String -> JSObject JSValue -> Either String a
154
fromObj k o =
155
    case lookup k (fromJSObject o) of
156
      Nothing -> Left $ printf "key '%s' not found" k
157
      Just val -> resultToEither $ readJSON val
158

  
159
getStringElement :: String -> JSObject JSValue -> Either String String
160
getStringElement = fromObj
161

  
162
getIntElement :: String -> JSObject JSValue -> Either String Int
163
getIntElement = fromObj
164

  
165
getListElement :: String -> JSObject JSValue
166
               -> Either String [JSValue]
167
getListElement = fromObj
168

  
169
concatEitherElems :: Either String String
170
            -> Either String String
171
            -> Either String String
172
concatEitherElems = applyEither2 (\x y -> x ++ "|" ++ y)
173

  
174
applyEither1 :: (a -> b) -> Either String a -> Either String b
175
applyEither1 fn a =
176
    case a of
177
      Left x -> Left x
178
      Right y -> Right $ fn y
179

  
180
applyEither2 :: (a -> b -> c)
181
       -> Either String a
182
       -> Either String b
183
       -> Either String c
184
applyEither2 fn a b =
185
    case (a, b) of
186
      (Right x, Right y) -> Right $ fn x y
187
      (Left x, _) -> Left x
188
      (_, Left y) -> Left y

Also available in: Unified diff