Commit 942403e6 authored by Iustin Pop's avatar Iustin Pop
Browse files

Switch from hand-written monads to a real one

This big patch converts from our home-grown monad-like constructs
(the Either stuff) to a real, Either-like-but-another-name monad.

We introduce a “Result a” monad, and this allows dropping many of the
extra constructs. Hopefully the code is also more clear.

Many of the functions could now be written in a generic-monad style,
instead of Result specifically, but that will come in future patches.

IAlloc.hs also has some unrelated patches.
parent 144f190b
......@@ -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 =
......
......@@ -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)
)
......@@ -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)
......@@ -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
......
......@@ -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
......
......@@ -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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment