Add a copy of Rapi.HS as IAlloc.hs

This will be used in two ways:
  - format the response to Ganeti (easy, implemented)
  - parse the input data and build the node/instance lists (hard :)

diff --git a/Ganeti/HTools/IAlloc.hs b/Ganeti/HTools/IAlloc.hs
new file mode 100644 (file)
index 0000000..483d6c9
--- /dev/null
+++ b/Ganeti/HTools/IAlloc.hs
@@ -0,0 +1,149 @@
+{-| Implementation of the iallocator interface.
+
+-}
+
+module Ganeti.HTools.IAlloc
+    (
+      parseData
+    , formatResponse
+    ) where
+
+import Data.Either ()
+import Data.Maybe
+import Control.Monad
+import Text.JSON
+import Text.Printf (printf)
+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
+        disk = case getIntElement "disk_usage" a of
+                 Left _ -> let log_sz = apply2 (+)
+                                        (getIntElement "sda_size" a)
+                                        (getIntElement "sdb_size" a)
+                           in apply2 (+) log_sz (Right $ 128 * 2)
+                 Right x -> Right x
+        bep = fromObj "beparams" a
+        pnode = getStringElement "pnode" a
+        snode = (listHead $ getListElement "snodes" a) `combine` readString
+        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
+
+parseNode :: JSObject JSValue -> Either String String
+parseNode a =
+    let name = getStringElement "name" a
+        mtotal = getIntElement "mtotal" a
+        mnode = getIntElement "mnode" 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)
+
+parseData :: String -> Maybe String
+
+parseData x = Just x
+
+formatResponse :: Bool -> String -> [String] -> String
+formatResponse success info nodes =
+    let
+        e_success = ("success", JSBool success)
+        e_info = ("info", JSString . toJSString $ info)
+        e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes)
+    in encodeStrict $ makeObj [e_success, e_info, e_nodes]