diff --git a/Ganeti/HTools/IAlloc.hs b/Ganeti/HTools/IAlloc.hs
index d993c13ebbfc4eac59cc66d0d033e9347d57e2ae..b5391f6e90da6ff7a09a173b83fc36fd94992df6 100644
--- a/Ganeti/HTools/IAlloc.hs
+++ b/Ganeti/HTools/IAlloc.hs
@@ -11,91 +11,94 @@ module Ganeti.HTools.IAlloc
import Data.Either ()
import Data.Maybe
import Control.Monad
-import Text.JSON
+import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray),
+ makeObj, encodeStrict, decodeStrict,
+ fromJSObject, toJSString)
import Text.Printf (printf)
import Ganeti.HTools.Utils
+import qualified Ganeti.HTools.Node as Node
+import qualified Ganeti.HTools.Instance as Instance
data RqType
= Allocate
| Relocate
- deriving (Show)
+ deriving (Eq, Show)
-parseInstance :: String -> JSObject JSValue -> Either String String
+data Request
+ = RqAlloc String String String
+ | RqReloc String String String
+
+parseInstance :: String -> JSObject JSValue -> Result String
parseInstance n a =
- let name = Right n
+ let name = Ok 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
+ Bad _ -> let all_d = getListElement "disks" a >>= asObjectList
+ szd = all_d >>=
+ (sequence .
+ map (getIntElement "size"))
+ sze = liftM (map (+128)) szd
+ szf = liftM sum sze
in szf
- Right x -> Right x
+ x@(Ok _) -> x
nodes = getListElement "nodes" a
- pnode = eitherListHead nodes
- `combineEithers` readEitherString
- snode = applyEither1 (head . tail) nodes
- `combineEithers` readEitherString
+ pnode = liftM head nodes >>= readEitherString
+ snode = liftM (head . tail) nodes >>= readEitherString
mem = getIntElement "memory" a
- running = Right "running" --getStringElement "status" a
+ running = Ok "running" --getStringElement "status" a
in
- concatEitherElems name $
- concatEitherElems (show `applyEither1` mem) $
- concatEitherElems (show `applyEither1` disk) $
- concatEitherElems running $
- concatEitherElems pnode snode
+ name |+ (show `liftM` mem) |+
+ (show `liftM` disk) |+ running |+ pnode |+ snode
-parseNode :: String -> JSObject JSValue -> Either String String
+parseNode :: String -> JSObject JSValue -> Result String
parseNode n a =
- let name = Right n
+ let name = Ok 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)
+ in name |+ (show `liftM` mtotal) |+
+ (show `liftM` mnode) |+
+ (show `liftM` mfree) |+
+ (show `liftM` dtotal) |+
+ (show `liftM` dfree)
-validateRequest :: String -> Either String RqType
+validateRequest :: String -> Result RqType
validateRequest rq =
case rq of
- "allocate" -> Right Allocate
- "relocate" -> Right Relocate
- _ -> Left ("Invalid request type '" ++ rq ++ "'")
+ "allocate" -> Ok Allocate
+ "relocate" -> Ok Relocate
+ _ -> Bad ("Invalid request type '" ++ rq ++ "'")
-parseData :: String -> Either String (String, String)
+parseData :: String -> Result Request
parseData body =
- let
- decoded = resultToEither $ decodeStrict body
- obj = decoded -- decoded `combineEithers` fromJSObject
+ do
+ decoded <- fromJResult $ decodeStrict body
+ let obj = decoded -- decoded `combineEithers` fromJSObject
-- request parser
- request = obj `combineEithers` getObjectElement "request"
- rname = request `combineEithers` getStringElement "name"
- rtype = request `combineEithers` getStringElement "type"
- `combineEithers` validateRequest
- -- existing intstance parsing
- ilist = obj `combineEithers` getObjectElement "instances"
- idata = applyEither1 fromJSObject ilist
- iobj = idata `combineEithers` (ensureEitherList .
- map (\(x,y) ->
- asJSObject y `combineEithers`
- parseInstance x))
- ilines = iobj `combineEithers` (Right . unlines)
- -- existing node parsing
- nlist = obj `combineEithers` getObjectElement "nodes"
- ndata = applyEither1 fromJSObject nlist
- nobj = ndata `combineEithers` (ensureEitherList .
- map (\(x,y) ->
- asJSObject y `combineEithers`
- parseNode x))
- nlines = nobj `combineEithers` (Right . unlines)
- in applyEither2 (,) nlines ilines
+ request <- getObjectElement "request" obj
+ rname <- getStringElement "name" request
+ rtype <- getStringElement "type" request >>= validateRequest
+ inew <- (\x -> if x == Allocate then parseInstance rname request
+ else Ok "") rtype
+ -- existing intstance parsing
+ ilist <- getObjectElement "instances" obj
+ let idata = fromJSObject ilist
+ iobj <- (sequence . map (\(x,y) -> asJSObject y >>= parseInstance x))
+ idata
+ let ilines = unlines iobj
+ -- existing node parsing
+ nlist <- getObjectElement "nodes" obj
+ let ndata = fromJSObject nlist
+ nobj <- (sequence . map (\(x,y) -> asJSObject y >>= parseNode x))
+ ndata
+ let nlines = unlines nobj
+ return $ (\ r nl il inew rnam ->
+ case r of
+ Allocate -> RqAlloc inew nl il
+ Relocate -> RqReloc rnam nl il)
+ rtype nlines ilines inew rname
+
formatResponse :: Bool -> String -> [String] -> String
formatResponse success info nodes =
diff --git a/Ganeti/HTools/Rapi.hs b/Ganeti/HTools/Rapi.hs
index 5373293dc1d611c7d9080ffb9b3831d79abc4c62..e504981d867537418f943d0f51fe04ce03caa8d7 100644
--- a/Ganeti/HTools/Rapi.hs
+++ b/Ganeti/HTools/Rapi.hs
@@ -14,7 +14,7 @@ import Network.Curl.Code
import Data.Either ()
import Data.Maybe
import Control.Monad
-import Text.JSON
+import Text.JSON (JSObject, JSValue)
import Text.Printf (printf)
import Ganeti.HTools.Utils
@@ -24,63 +24,60 @@ import Ganeti.HTools.Utils
-- | The fixed drbd overhead per disk (only used with 1.2's sdx_size)
drbdOverhead = 128
-getUrl :: String -> IO (Either String String)
+getUrl :: String -> IO (Result String)
getUrl url = do
(code, body) <- curlGetString url [CurlSSLVerifyPeer False,
CurlSSLVerifyHost 0]
return (case code of
- CurlOK -> Right body
- _ -> Left $ printf "Curl error for '%s', error %s"
+ CurlOK -> Ok body
+ _ -> Bad $ printf "Curl error for '%s', error %s"
url (show code))
-getInstances :: String -> IO (Either String String)
+getInstances :: String -> IO (Result String)
getInstances master = do
let url2 = printf "https://%s:5080/2/instances?bulk=1" master
body <- getUrl url2
- let inst = body `combineEithers`
- loadJSArray `combineEithers`
- (parseEitherList parseInstance)
- return inst
+ return $ (body >>= \x -> do
+ arr <- loadJSArray x
+ ilist <- mapM parseInstance arr
+ return $ unlines ilist)
-getNodes :: String -> IO (Either String String)
+getNodes :: String -> IO (Result String)
getNodes master = do
let url2 = printf "https://%s:5080/2/nodes?bulk=1" master
body <- getUrl url2
- let inst = body `combineEithers`
- loadJSArray `combineEithers`
- (parseEitherList parseNode)
- return inst
+ return $ (body >>= \x -> do
+ arr <- loadJSArray x
+ nlist <- mapM parseNode arr
+ return $ unlines nlist)
-parseInstance :: JSObject JSValue -> Either String String
+parseInstance :: JSObject JSValue -> Result String
parseInstance a =
let name = getStringElement "name" a
disk = case getIntElement "disk_usage" a of
- Left _ -> let log_sz = applyEither2 (+)
- (getIntElement "sda_size" a)
- (getIntElement "sdb_size" a)
- in applyEither2 (+) log_sz
- (Right $ drbdOverhead * 2)
- Right x -> Right x
+ Bad _ -> let log_sz = liftM2 (+)
+ (getIntElement "sda_size" a)
+ (getIntElement "sdb_size" a)
+ in liftM2 (+) log_sz (Ok $ drbdOverhead * 2)
+ x@(Ok _) -> x
bep = fromObj "beparams" a
pnode = getStringElement "pnode" a
- snode = (eitherListHead $ getListElement "snodes" a)
- `combineEithers` readEitherString
+ snode = (liftM head $ getListElement "snodes" a)
+ >>= readEitherString
mem = case bep of
- Left _ -> getIntElement "admin_ram" a
- Right o -> getIntElement "memory" o
+ Bad _ -> getIntElement "admin_ram" a
+ Ok o -> getIntElement "memory" o
running = getStringElement "status" a
in
- concatEitherElems name $
- concatEitherElems (show `applyEither1` mem) $
- concatEitherElems (show `applyEither1` disk) $
- concatEitherElems running $
- concatEitherElems pnode snode
+ name |+ (show `liftM` mem) |+
+ (show `liftM` disk) |+
+ running |+ pnode |+ snode
-boolToYN :: Bool -> Either String String
-boolToYN True = Right "Y"
-boolToYN _ = Right "N"
+boolToYN :: Bool -> Result String
+boolToYN True = Ok "Y"
+boolToYN _ = Ok "N"
-parseNode :: JSObject JSValue -> Either String String
+parseNode :: JSObject JSValue -> Result String
parseNode a =
let name = getStringElement "name" a
offline = getBoolElement "offline" a
@@ -90,14 +87,12 @@ parseNode a =
mfree = getIntElement "mfree" a
dtotal = getIntElement "dtotal" a
dfree = getIntElement "dfree" a
- in concatEitherElems name $
+ in name |+
(case offline of
- Right True -> Right "0|0|0|0|0|Y"
+ Ok True -> Ok "0|0|0|0|0|Y"
_ ->
- concatEitherElems (show `applyEither1` mtotal) $
- concatEitherElems (show `applyEither1` mnode) $
- concatEitherElems (show `applyEither1` mfree) $
- concatEitherElems (show `applyEither1` dtotal) $
- concatEitherElems (show `applyEither1` dfree)
- ((applyEither2 (||) offline drained) `combineEithers` boolToYN)
+ (show `liftM` mtotal) |+ (show `liftM` mnode) |+
+ (show `liftM` mfree) |+ (show `liftM` dtotal) |+
+ (show `liftM` dfree) |+
+ ((liftM2 (||) offline drained) >>= boolToYN)
)
diff --git a/Ganeti/HTools/Utils.hs b/Ganeti/HTools/Utils.hs
index c231a6fc35dd98bb8db6ef1170535138810ba2eb..fd2224c95c7a6c5a28b4446e5a7ce021dd931b3f 100644
--- a/Ganeti/HTools/Utils.hs
+++ b/Ganeti/HTools/Utils.hs
@@ -3,19 +3,12 @@
module Ganeti.HTools.Utils
(
debug
- , isLeft
- , fromLeft
- , fromRight
, sepSplit
, swapPairs
, varianceCoeff
, readData
, commaJoin
- , combineEithers
- , ensureEitherList
- , eitherListHead
, readEitherString
- , parseEitherList
, loadJSArray
, fromObj
, getStringElement
@@ -25,17 +18,17 @@ module Ganeti.HTools.Utils
, getObjectElement
, asJSObject
, asObjectList
- , concatEitherElems
- , applyEither1
- , applyEither2
+ , Result(Ok, Bad)
+ , fromJResult
+ , (|+)
) where
import Data.Either
import Data.List
-import Monad
+import Control.Monad
import System
import System.IO
-import Text.JSON
+import qualified Text.JSON as J
import Text.Printf (printf)
import Debug.Trace
@@ -44,18 +37,29 @@ import Debug.Trace
debug :: Show a => a -> a
debug x = trace (show x) x
--- | Check if the given argument is Left something
-isLeft :: Either a b -> Bool
-isLeft val =
- case val of
- Left _ -> True
- _ -> False
-fromLeft :: Either a b -> a
-fromLeft = either (\x -> x) (\_ -> undefined)
+{-
-fromRight :: Either a b -> b
-fromRight = either (\_ -> undefined) id
+This is similar to the JSON library Result type - *very* similar, but
+we want to use it in multiple places, so we abstract it into a
+mini-library here
+
+-}
+
+data Result a
+ = Bad String
+ | Ok a
+ deriving (Show)
+
+instance Monad Result where
+ (>>=) (Bad x) _ = Bad x
+ (>>=) (Ok x) fn = fn x
+ return = Ok
+ fail = Bad
+
+fromJResult :: J.Result a -> Result a
+fromJResult (J.Error x) = Bad x
+fromJResult (J.Ok x) = Ok x
-- | Comma-join a string list.
commaJoin :: [String] -> String
@@ -98,110 +102,53 @@ stdDev lst =
varianceCoeff :: Floating a => [a] -> a
varianceCoeff lst = (stdDev lst) / (fromIntegral $ length lst)
--- | Get a Right result or print the error and exit
-readData :: (String -> IO (Either String String)) -> String -> IO String
-readData fn host = do
- nd <- fn host
- when (isLeft nd) $
- do
- putStrLn $ fromLeft nd
+-- | Get an Ok result or print the error and exit
+readData :: Result a -> IO a
+readData nd =
+ (case nd of
+ Bad x -> do
+ putStrLn x
exitWith $ ExitFailure 1
- return $ fromRight nd
-
-{-- Our cheap monad-like stuff.
+ Ok x -> return x)
-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 :: J.JSValue -> Result 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)
+ J.JSString s -> Ok $ J.fromJSString s
+ _ -> Bad "Wrong JSON type"
-loadJSArray :: String -> Either String [JSObject JSValue]
-loadJSArray s = resultToEither $ decodeStrict s
+loadJSArray :: String -> Result [J.JSObject J.JSValue]
+loadJSArray s = fromJResult $ J.decodeStrict s
-fromObj :: JSON a => String -> JSObject JSValue -> Either String a
+fromObj :: J.JSON a => String -> J.JSObject J.JSValue -> Result a
fromObj k o =
- case lookup k (fromJSObject o) of
- Nothing -> Left $ printf "key '%s' not found" k
- Just val -> resultToEither $ readJSON val
+ case lookup k (J.fromJSObject o) of
+ Nothing -> Bad $ printf "key '%s' not found" k
+ Just val -> fromJResult $ J.readJSON val
-getStringElement :: String -> JSObject JSValue -> Either String String
+getStringElement :: String -> J.JSObject J.JSValue -> Result String
getStringElement = fromObj
-getIntElement :: String -> JSObject JSValue -> Either String Int
+getIntElement :: String -> J.JSObject J.JSValue -> Result Int
getIntElement = fromObj
-getBoolElement :: String -> JSObject JSValue -> Either String Bool
+getBoolElement :: String -> J.JSObject J.JSValue -> Result Bool
getBoolElement = fromObj
-getListElement :: String -> JSObject JSValue
- -> Either String [JSValue]
+getListElement :: String -> J.JSObject J.JSValue -> Result [J.JSValue]
getListElement = fromObj
-getObjectElement :: String -> JSObject JSValue
- -> Either String (JSObject JSValue)
+getObjectElement :: String -> J.JSObject J.JSValue
+ -> Result (J.JSObject J.JSValue)
getObjectElement = fromObj
-asJSObject :: JSValue -> Either String (JSObject JSValue)
-asJSObject (JSObject a) = Right a
-asJSObject _ = Left "not an object"
-
-asObjectList :: [JSValue] -> Either String [JSObject JSValue]
-asObjectList =
- ensureEitherList . map asJSObject
-
-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
+asJSObject :: J.JSValue -> Result (J.JSObject J.JSValue)
+asJSObject (J.JSObject a) = Ok a
+asJSObject _ = Bad "not an object"
+
+asObjectList :: [J.JSValue] -> Result [J.JSObject J.JSValue]
+asObjectList = sequence . map asJSObject
+
+-- | Function to concat two strings with a separator under a monad
+(|+) :: (Monad m) => m String -> m String -> m String
+(|+) = liftM2 (\x y -> x ++ "|" ++ y)
diff --git a/hbal.hs b/hbal.hs
index 325543a3b2fc66ece8689411eb5374ca34ff1f54..425a6d6d32d0ef1a7b58f1c706389df5b7b41bb7 100644
--- a/hbal.hs
+++ b/hbal.hs
@@ -183,8 +183,8 @@ main = do
case optMaster opts of
"" -> (readFile nodef,
readFile instf)
- host -> (readData getNodes host,
- readData getInstances host)
+ host -> (getNodes host >>= readData,
+ getInstances host >>= readData)
(loaded_nl, il, csf, ktn, kti) <- liftM2 Cluster.loadData node_data inst_data
let (fix_msgs, fixed_nl) = Cluster.checkData loaded_nl il ktn kti
diff --git a/hn1.hs b/hn1.hs
index e307bad4ae5cf5e9f7c7f1ad2b95883269eff4aa..133b4c96788ff32ad1fe576125b6f79d76963220 100644
--- a/hn1.hs
+++ b/hn1.hs
@@ -148,8 +148,8 @@ main = do
case optMaster opts of
"" -> (readFile nodef,
readFile instf)
- host -> (readData getNodes host,
- readData getInstances host)
+ host -> (getNodes host >>= readData,
+ getInstances host >>= readData)
(loaded_nl, il, csf, ktn, kti) <- liftM2 Cluster.loadData node_data inst_data
diff --git a/hscan.hs b/hscan.hs
index e859c9abb62c389ecc0360bd9fed4e2eec343de5..4ce9cc71031021d218f6ad3a67b811629346bb08 100644
--- a/hscan.hs
+++ b/hscan.hs
@@ -155,23 +155,23 @@ main = do
hFlush stdout
node_data <- getNodes name
inst_data <- getInstances name
- (if isLeft(node_data)
- then putStrLn $ fromLeft node_data
- else if isLeft(inst_data)
- then putStrLn $ fromLeft inst_data
- else do
- let ndata = fromRight node_data
- idata = fromRight inst_data
- (nl, il, csf, ktn, kti) =
- Cluster.loadData ndata idata
- (_, fix_nl) = Cluster.checkData nl il ktn kti
- putStrLn $ printCluster fix_nl il ktn kti
- when (optShowNodes opts) $ do
- putStr $ Cluster.printNodes ktn fix_nl
- let ndata = serializeNodes nl csf ktn
- idata = serializeInstances il csf ktn kti
- oname = odir </> name
- writeFile (oname <.> "nodes") ndata
- writeFile (oname <.> "instances") idata)
+ (case node_data of
+ Bad err -> putStrLn err
+ Ok ndata ->
+ case inst_data of
+ Bad err -> putStrLn err
+ Ok idata ->
+ do
+ let (nl, il, csf, ktn, kti) =
+ Cluster.loadData ndata idata
+ (_, fix_nl) = Cluster.checkData nl il ktn kti
+ putStrLn $ printCluster fix_nl il ktn kti
+ when (optShowNodes opts) $ do
+ putStr $ Cluster.printNodes ktn fix_nl
+ let ndata = serializeNodes nl csf ktn
+ idata = serializeInstances il csf ktn kti
+ oname = odir </> name
+ writeFile (oname <.> "nodes") ndata
+ writeFile (oname <.> "instances") idata)
) clusters
exitWith ExitSuccess