Revision 9ba5c28f Ganeti/HTools/Rapi.hs

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)

Also available in: Unified diff