X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/3f6af65cbc62ec654f491b7bc0e154287adac7ad..497e30a1b9417b47b20a785551615e40ffac30a6:/Ganeti/HTools/IAlloc.hs?ds=sidebyside

diff --git a/Ganeti/HTools/IAlloc.hs b/Ganeti/HTools/IAlloc.hs
index d3a7e98..241bbd8 100644
--- a/Ganeti/HTools/IAlloc.hs
+++ b/Ganeti/HTools/IAlloc.hs
@@ -9,76 +9,100 @@ module Ganeti.HTools.IAlloc
     ) where
 
 import Data.Either ()
-import Data.Maybe
+--import Data.Maybe
 import Control.Monad
-import Text.JSON
-import Text.Printf (printf)
+import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray),
+                  makeObj, encodeStrict, decodeStrict,
+                  fromJSObject, toJSString)
+--import Text.Printf (printf)
+import qualified Ganeti.HTools.Node as Node
+import qualified Ganeti.HTools.Instance as Instance
+import Ganeti.HTools.Loader
 import Ganeti.HTools.Utils
+import Ganeti.HTools.Types
 
-parseInstance :: String -> JSObject JSValue -> Either String String
-parseInstance n a =
-    let name = Right n
-        disk = case getIntElement "disk_usage" a of
-                 Left _ -> let all_d = getListElement "disks" a `combineEithers`
-                                       asObjectList
-                               szd = all_d `combineEithers`
-                                     (ensureEitherList .
-                                      map (getIntElement "size"))
-                               sze = applyEither1 (map (+128)) szd
-                               szf = applyEither1 sum sze
-                           in szf
-                 Right x -> Right x
-        nodes = getListElement "nodes" a
-        pnode = eitherListHead nodes
-                `combineEithers` readEitherString
-        snode = applyEither1 (head . tail) nodes
-                `combineEithers` readEitherString
-        mem = getIntElement "memory" a
-        running = Right "running" --getStringElement "status" a
-    in
-      concatEitherElems name $
-                  concatEitherElems (show `applyEither1` mem) $
-                  concatEitherElems (show `applyEither1` disk) $
-                  concatEitherElems running $
-                  concatEitherElems pnode snode
+data RqType
+    = Allocate String Instance.Instance
+    | Relocate Int
+    deriving (Show)
 
-parseNode :: String -> JSObject JSValue -> Either String String
-parseNode n a =
-    let name = Right n
-        mtotal = getIntElement "total_memory" a
-        mnode = getIntElement "reserved_memory" a
-        mfree = getIntElement "free_memory" a
-        dtotal = getIntElement "total_disk" a
-        dfree = getIntElement "free_disk" a
-    in concatEitherElems name $
-       concatEitherElems (show `applyEither1` mtotal) $
-       concatEitherElems (show `applyEither1` mnode) $
-       concatEitherElems (show `applyEither1` mfree) $
-       concatEitherElems (show `applyEither1` dtotal)
-                             (show `applyEither1` dfree)
+data Request = Request RqType IdxNode IdxInstance NameList NameList
+    deriving (Show)
 
-parseData :: String -> Either String (String, String)
-parseData body =
-    let
-        decoded = resultToEither $ decodeStrict body
-        obj = decoded -- decoded `combineEithers` fromJSObject
-        request = obj `combineEithers` getObjectElement "request"
-        rname = request `combineEithers` getStringElement "name"
-        ilist = obj `combineEithers` getObjectElement "instances"
-        nlist = obj `combineEithers` getObjectElement "nodes"
-        idata = applyEither1 fromJSObject ilist
-        ndata = applyEither1 fromJSObject nlist
-        iobj = idata `combineEithers` (ensureEitherList .
-                                       map (\(x,y) ->
-                                           asJSObject y `combineEithers`
-                                                      parseInstance x))
-        ilines = iobj `combineEithers` (Right . unlines)
-        nobj = ndata `combineEithers` (ensureEitherList .
-                                       map (\(x,y) ->
-                                           asJSObject y `combineEithers`
-                                                      parseNode x))
-        nlines = nobj `combineEithers` (Right . unlines)
-    in applyEither2 (,) nlines ilines
+parseBaseInstance :: String
+                  -> JSObject JSValue
+                  -> Result (String, Instance.Instance)
+parseBaseInstance n a = do
+  disk <- case fromObj "disk_usage" a of
+            Bad _ -> do
+                all_d <- fromObj "disks" a >>= asObjectList
+                szd <- mapM (fromObj "size") all_d
+                let sze = map (+128) szd
+                    szf = (sum sze)::Int
+                return szf
+            x@(Ok _) -> x
+  mem <- fromObj "memory" a
+  let running = "running"
+  return $ (n, Instance.create n mem disk running 0 0)
+
+parseInstance :: NameAssoc
+              -> String
+              -> JSObject JSValue
+              -> Result (String, Instance.Instance)
+parseInstance ktn n a = do
+    base <- parseBaseInstance n a
+    nodes <- fromObj "nodes" a
+    pnode <- readEitherString $ head nodes
+    snode <- readEitherString $ (head . tail) nodes
+    pidx <- lookupNode ktn n pnode
+    sidx <- lookupNode ktn n snode
+    return (n, Instance.setBoth (snd base) pidx sidx)
+
+parseNode :: String -> JSObject JSValue -> Result (String, Node.Node)
+parseNode n a = do
+    let name = n
+    mtotal <- fromObj "total_memory" a
+    mnode <- fromObj "reserved_memory" a
+    mfree <- fromObj "free_memory" a
+    dtotal <- fromObj "total_disk" a
+    dfree <- fromObj "free_disk" a
+    offline <- fromObj "offline" a
+    drained <- fromObj "offline" a
+    return $ (name, Node.create n mtotal mnode mfree dtotal dfree
+                      (offline || drained))
+
+parseData :: String -> Result Request
+parseData body = do
+  decoded <- fromJResult $ decodeStrict body
+  let obj = decoded
+  -- request parser
+  request <- fromObj "request" obj
+  rname <- fromObj "name" request
+  -- existing node parsing
+  nlist <- fromObj "nodes" obj
+  let ndata = fromJSObject nlist
+  nobj <- (mapM (\(x,y) -> asJSObject y >>= parseNode x)) ndata
+  let (ktn, nl) = assignIndices nobj
+  -- existing instance parsing
+  ilist <- fromObj "instances" obj
+  let idata = fromJSObject ilist
+  iobj <- (mapM (\(x,y) -> asJSObject y >>= parseInstance ktn x)) idata
+  let (kti, il) = assignIndices iobj
+  optype <- fromObj "type" request
+  rqtype <-
+      case optype of
+        "allocate" ->
+            do
+              inew <- parseBaseInstance rname request
+              let (iname, io) = inew
+              return $ Allocate iname io
+        "relocate" ->
+            do
+              ridx <- lookupNode kti rname rname
+              return $ Relocate ridx
+        other -> fail $ ("Invalid request type '" ++ other ++ "'")
+
+  return $ Request rqtype nl il (swapPairs ktn) (swapPairs kti)
 
 formatResponse :: Bool -> String -> [String] -> String
 formatResponse success info nodes =