Move the JSON utilities to Utils.hs

This patch moves the generic/reusable JSON functions to Utils.hs, so
that they're shared between RAPI/IAlloc.

diff --git a/Ganeti/HTools/IAlloc.hs b/Ganeti/HTools/IAlloc.hs
index 483d6c9..b30b985 100644 (file)
--- a/Ganeti/HTools/IAlloc.hs
+++ b/Ganeti/HTools/IAlloc.hs
@@ -16,89 +16,6 @@ import Text.Printf (printf)
 import Ganeti.HTools.Utils ()
 
 
 import Ganeti.HTools.Utils ()
 
 

--- Some constants
-
-{-- Our cheap monad-like stuff.
-
-Thi is needed since Either e a is already a monad instance somewhere
-in the standard libraries (Control.Monad.Error) and we don't need that
-entire thing.
-
--}
-combine :: (Either String a) -> (a -> Either String b)  -> (Either String b)
-combine (Left s) _ = Left s
-combine (Right s) f = f s
-
-ensureList :: [Either String a] -> Either String [a]
-ensureList lst =
-    foldr (\elem accu ->
-               case (elem, accu) of
-                 (Left x, _) -> Left x
-                 (_, Left x) -> Left x -- should never happen
-                 (Right e, Right a) -> Right (e:a)
-          )
-    (Right []) lst
-
-listHead :: Either String [a] -> Either String a
-listHead lst =
-    case lst of
-      Left x -> Left x
-      Right (x:_) -> Right x
-      Right [] -> Left "List empty"
-
-loadJSArray :: String -> Either String [JSObject JSValue]
-loadJSArray s = resultToEither $ decodeStrict s
-
-fromObj :: JSON a => String -> JSObject JSValue -> Either String a
-fromObj k o =
-    case lookup k (fromJSObject o) of
-      Nothing -> Left $ printf "key '%s' not found" k
-      Just val -> resultToEither $ readJSON val
-
-getStringElement :: String -> JSObject JSValue -> Either String String
-getStringElement = fromObj
-
-getIntElement :: String -> JSObject JSValue -> Either String Int
-getIntElement = fromObj
-
-getListElement :: String -> JSObject JSValue
-               -> Either String [JSValue]
-getListElement = fromObj
-
-readString :: JSValue -> Either String String
-readString v =
-    case v of
-      JSString s -> Right $ fromJSString s
-      _ -> Left "Wrong JSON type"
-
-concatElems :: Either String String
-            -> Either String String
-            -> Either String String
-concatElems = apply2 (\x y -> x ++ "|" ++ y)
-
-apply1 :: (a -> b) -> Either String a -> Either String b
-apply1 fn a =
-    case a of
-      Left x -> Left x
-      Right y -> Right $ fn y
-
-apply2 :: (a -> b -> c)
-       -> Either String a
-       -> Either String b
-       -> Either String c
-apply2 fn a b =
-    case (a, b) of
-      (Right x, Right y) -> Right $ fn x y
-      (Left x, _) -> Left x
-      (_, Left y) -> Left y
-
-parseList :: (JSObject JSValue -> Either String String)
-          -> [JSObject JSValue]
-          ->Either String String
-parseList fn idata =
-    let ml = ensureList $ map fn idata
-    in ml `combine` (Right . unlines)
-

 parseInstance :: JSObject JSValue -> Either String String
 parseInstance a =
     let name = getStringElement "name" a
 parseInstance :: JSObject JSValue -> Either String String
 parseInstance a =
     let name = getStringElement "name" a

diff --git a/Ganeti/HTools/Rapi.hs b/Ganeti/HTools/Rapi.hs
index da1a9b5..c6db593 100644 (file)
--- a/Ganeti/HTools/Rapi.hs
+++ b/Ganeti/HTools/Rapi.hs
@@ -16,7 +16,7 @@ import Data.Maybe
 import Control.Monad
 import Text.JSON
 import Text.Printf (printf)
 import Control.Monad
 import Text.JSON
 import Text.Printf (printf)

-import Ganeti.HTools.Utils ()
+import Ganeti.HTools.Utils

 
 
 -- Some constants
 
 
 -- Some constants

@@ -24,80 +24,6 @@ import Ganeti.HTools.Utils ()
 -- | The fixed drbd overhead per disk (only used with 1.2's sdx_size)
 drbdOverhead = 128
 
 -- | The fixed drbd overhead per disk (only used with 1.2's sdx_size)
 drbdOverhead = 128
 

-{-- Our cheap monad-like stuff.
-
-Thi is needed since Either e a is already a monad instance somewhere
-in the standard libraries (Control.Monad.Error) and we don't need that
-entire thing.
-
--}
-combine :: (Either String a) -> (a -> Either String b)  -> (Either String b)
-combine (Left s) _ = Left s
-combine (Right s) f = f s
-
-ensureList :: [Either String a] -> Either String [a]
-ensureList lst =
-    foldr (\elem accu ->
-               case (elem, accu) of
-                 (Left x, _) -> Left x
-                 (_, Left x) -> Left x -- should never happen
-                 (Right e, Right a) -> Right (e:a)
-          )
-    (Right []) lst
-
-listHead :: Either String [a] -> Either String a
-listHead lst =
-    case lst of
-      Left x -> Left x
-      Right (x:_) -> Right x
-      Right [] -> Left "List empty"
-
-loadJSArray :: String -> Either String [JSObject JSValue]
-loadJSArray s = resultToEither $ decodeStrict s
-
-fromObj :: JSON a => String -> JSObject JSValue -> Either String a
-fromObj k o =
-    case lookup k (fromJSObject o) of
-      Nothing -> Left $ printf "key '%s' not found" k
-      Just val -> resultToEither $ readJSON val
-
-getStringElement :: String -> JSObject JSValue -> Either String String
-getStringElement = fromObj
-
-getIntElement :: String -> JSObject JSValue -> Either String Int
-getIntElement = fromObj
-
-getListElement :: String -> JSObject JSValue
-               -> Either String [JSValue]
-getListElement = fromObj
-
-readString :: JSValue -> Either String String
-readString v =
-    case v of
-      JSString s -> Right $ fromJSString s
-      _ -> Left "Wrong JSON type"
-
-concatElems :: Either String String
-            -> Either String String
-            -> Either String String
-concatElems = apply2 (\x y -> x ++ "|" ++ y)
-
-apply1 :: (a -> b) -> Either String a -> Either String b
-apply1 fn a =
-    case a of
-      Left x -> Left x
-      Right y -> Right $ fn y
-
-apply2 :: (a -> b -> c)
-       -> Either String a
-       -> Either String b
-       -> Either String c
-apply2 fn a b =
-    case (a, b) of
-      (Right x, Right y) -> Right $ fn x y
-      (Left x, _) -> Left x
-      (_, Left y) -> Left y
-

 getUrl :: String -> IO (Either String String)
 getUrl url = do
   (code, body) <- curlGetString url [CurlSSLVerifyPeer False,
 getUrl :: String -> IO (Either String String)
 getUrl url = do
   (code, body) <- curlGetString url [CurlSSLVerifyPeer False,

@@ -122,7 +48,9 @@ getInstances master =
         url1 = printf "http://%s:5080/instances?bulk=1" master
     in do
       body <- tryRapi url1 url2
         url1 = printf "http://%s:5080/instances?bulk=1" master
     in do
       body <- tryRapi url1 url2

-      let inst = body `combine` loadJSArray `combine` (parseList parseInstance)
+      let inst = body `combineEithers`
+                 loadJSArray `combineEithers`
+                 (parseEitherList parseInstance)

       return inst
 
 getNodes :: String -> IO (Either String String)
       return inst
 
 getNodes :: String -> IO (Either String String)

@@ -132,38 +60,35 @@ getNodes master =
         url1 = printf "http://%s:5080/nodes?bulk=1" master
     in do
       body <- tryRapi url1 url2
         url1 = printf "http://%s:5080/nodes?bulk=1" master
     in do
       body <- tryRapi url1 url2

-      let inst = body `combine` loadJSArray `combine` (parseList parseNode)
+      let inst = body `combineEithers`
+                 loadJSArray `combineEithers`
+                 (parseEitherList parseNode)

       return inst
 
       return inst
 

-parseList :: (JSObject JSValue -> Either String String)
-          -> [JSObject JSValue]
-          ->Either String String
-parseList fn idata =
-    let ml = ensureList $ map fn idata
-    in ml `combine` (Right . unlines)
-

 parseInstance :: JSObject JSValue -> Either String String
 parseInstance a =
     let name = getStringElement "name" a
         disk = case getIntElement "disk_usage" a of
 parseInstance :: JSObject JSValue -> Either String String
 parseInstance a =
     let name = getStringElement "name" a
         disk = case getIntElement "disk_usage" a of

-                 Left _ -> let log_sz = apply2 (+)
+                 Left _ -> let log_sz = applyEither2 (+)

                                         (getIntElement "sda_size" a)
                                         (getIntElement "sdb_size" a)
                                         (getIntElement "sda_size" a)
                                         (getIntElement "sdb_size" a)

-                           in apply2 (+) log_sz (Right $ drbdOverhead * 2)
+                           in applyEither2 (+) log_sz
+                                  (Right $ drbdOverhead * 2)

                  Right x -> Right x
         bep = fromObj "beparams" a
         pnode = getStringElement "pnode" a
                  Right x -> Right x
         bep = fromObj "beparams" a
         pnode = getStringElement "pnode" a

-        snode = (listHead $ getListElement "snodes" a) `combine` readString
+        snode = (eitherListHead $ getListElement "snodes" a)
+                `combineEithers` readEitherString

         mem = case bep of
                 Left _ -> getIntElement "admin_ram" a
                 Right o -> getIntElement "memory" o
         running = getStringElement "status" a
     in
         mem = case bep of
                 Left _ -> getIntElement "admin_ram" a
                 Right o -> getIntElement "memory" o
         running = getStringElement "status" a
     in

-      concatElems name $
-                  concatElems (show `apply1` mem) $
-                  concatElems (show `apply1` disk) $
-                  concatElems running $
-                  concatElems pnode snode
+      concatEitherElems name $
+                  concatEitherElems (show `applyEither1` mem) $
+                  concatEitherElems (show `applyEither1` disk) $
+                  concatEitherElems running $
+                  concatEitherElems pnode snode

 
 parseNode :: JSObject JSValue -> Either String String
 parseNode a =
 
 parseNode :: JSObject JSValue -> Either String String
 parseNode a =

@@ -173,8 +98,9 @@ parseNode a =
         mfree = getIntElement "mfree" a
         dtotal = getIntElement "dtotal" a
         dfree = getIntElement "dfree" a
         mfree = getIntElement "mfree" a
         dtotal = getIntElement "dtotal" a
         dfree = getIntElement "dfree" a

-    in concatElems name $
-       concatElems (show `apply1` mtotal) $
-       concatElems (show `apply1` mnode) $
-       concatElems (show `apply1` mfree) $
-       concatElems (show `apply1` dtotal) (show `apply1` dfree)
+    in concatEitherElems name $
+       concatEitherElems (show `applyEither1` mtotal) $
+       concatEitherElems (show `applyEither1` mnode) $
+       concatEitherElems (show `applyEither1` mfree) $
+       concatEitherElems (show `applyEither1` dtotal)
+                             (show `applyEither1` dfree)

diff --git a/Ganeti/HTools/Utils.hs b/Ganeti/HTools/Utils.hs
index d1aa975..cb29e0f 100644 (file)
--- a/Ganeti/HTools/Utils.hs
+++ b/Ganeti/HTools/Utils.hs
@@ -11,6 +11,19 @@ module Ganeti.HTools.Utils
     , varianceCoeff
     , readData
     , commaJoin
     , varianceCoeff
     , readData
     , commaJoin

+    , combineEithers
+    , ensureEitherList
+    , eitherListHead
+    , readEitherString
+    , parseEitherList
+    , loadJSArray
+    , fromObj
+    , getStringElement
+    , getIntElement
+    , getListElement
+    , concatEitherElems
+    , applyEither1
+    , applyEither2

     ) where
 
 import Data.Either
     ) where
 
 import Data.Either

@@ -18,6 +31,8 @@ import Data.List
 import Monad
 import System
 import System.IO
 import Monad
 import System
 import System.IO

+import Text.JSON
+import Text.Printf (printf)

 
 import Debug.Trace
 
 
 import Debug.Trace
 

@@ -88,3 +103,86 @@ readData fn host = do
          putStrLn $ fromLeft nd
          exitWith $ ExitFailure 1
   return $ fromRight nd
          putStrLn $ fromLeft nd
          exitWith $ ExitFailure 1
   return $ fromRight nd

+
+{-- Our cheap monad-like stuff.
+
+Thi is needed since Either e a is already a monad instance somewhere
+in the standard libraries (Control.Monad.Error) and we don't need that
+entire thing.
+
+-}
+combineEithers :: (Either String a)
+               -> (a -> Either String b)
+               -> (Either String b)
+combineEithers (Left s) _ = Left s
+combineEithers (Right s) f = f s
+
+ensureEitherList :: [Either String a] -> Either String [a]
+ensureEitherList lst =
+    foldr (\elem accu ->
+               case (elem, accu) of
+                 (Left x, _) -> Left x
+                 (_, Left x) -> Left x -- should never happen
+                 (Right e, Right a) -> Right (e:a)
+          )
+    (Right []) lst
+
+eitherListHead :: Either String [a] -> Either String a
+eitherListHead lst =
+    case lst of
+      Left x -> Left x
+      Right (x:_) -> Right x
+      Right [] -> Left "List empty"
+
+readEitherString :: JSValue -> Either String String
+readEitherString v =
+    case v of
+      JSString s -> Right $ fromJSString s
+      _ -> Left "Wrong JSON type"
+
+parseEitherList :: (JSObject JSValue -> Either String String)
+          -> [JSObject JSValue]
+          -> Either String String
+parseEitherList fn idata =
+    let ml = ensureEitherList $ map fn idata
+    in ml `combineEithers` (Right . unlines)
+
+loadJSArray :: String -> Either String [JSObject JSValue]
+loadJSArray s = resultToEither $ decodeStrict s
+
+fromObj :: JSON a => String -> JSObject JSValue -> Either String a
+fromObj k o =
+    case lookup k (fromJSObject o) of
+      Nothing -> Left $ printf "key '%s' not found" k
+      Just val -> resultToEither $ readJSON val
+
+getStringElement :: String -> JSObject JSValue -> Either String String
+getStringElement = fromObj
+
+getIntElement :: String -> JSObject JSValue -> Either String Int
+getIntElement = fromObj
+
+getListElement :: String -> JSObject JSValue
+               -> Either String [JSValue]
+getListElement = fromObj
+
+concatEitherElems :: Either String String
+            -> Either String String
+            -> Either String String
+concatEitherElems = applyEither2 (\x y -> x ++ "|" ++ y)
+
+applyEither1 :: (a -> b) -> Either String a -> Either String b
+applyEither1 fn a =
+    case a of
+      Left x -> Left x
+      Right y -> Right $ fn y
+
+applyEither2 :: (a -> b -> c)
+       -> Either String a
+       -> Either String b
+       -> Either String c
+applyEither2 fn a b =
+    case (a, b) of
+      (Right x, Right y) -> Right $ fn x y
+      (Left x, _) -> Left x
+      (_, Left y) -> Left y