Revision 942403e6 Ganeti/HTools/IAlloc.hs
| b/Ganeti/HTools/IAlloc.hs | ||
|---|---|---|
| 11 | 11 |
import Data.Either () |
| 12 | 12 |
import Data.Maybe |
| 13 | 13 |
import Control.Monad |
| 14 |
import Text.JSON |
|
| 14 |
import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray), |
|
| 15 |
makeObj, encodeStrict, decodeStrict, |
|
| 16 |
fromJSObject, toJSString) |
|
| 15 | 17 |
import Text.Printf (printf) |
| 16 | 18 |
import Ganeti.HTools.Utils |
| 19 |
import qualified Ganeti.HTools.Node as Node |
|
| 20 |
import qualified Ganeti.HTools.Instance as Instance |
|
| 17 | 21 |
|
| 18 | 22 |
data RqType |
| 19 | 23 |
= Allocate |
| 20 | 24 |
| Relocate |
| 21 |
deriving (Show) |
|
| 25 |
deriving (Eq, Show)
|
|
| 22 | 26 |
|
| 23 |
parseInstance :: String -> JSObject JSValue -> Either String String |
|
| 27 |
data Request |
|
| 28 |
= RqAlloc String String String |
|
| 29 |
| RqReloc String String String |
|
| 30 |
|
|
| 31 |
parseInstance :: String -> JSObject JSValue -> Result String |
|
| 24 | 32 |
parseInstance n a = |
| 25 |
let name = Right n
|
|
| 33 |
let name = Ok n
|
|
| 26 | 34 |
disk = case getIntElement "disk_usage" a of |
| 27 |
Left _ -> let all_d = getListElement "disks" a `combineEithers` |
|
| 28 |
asObjectList |
|
| 29 |
szd = all_d `combineEithers` |
|
| 30 |
(ensureEitherList . |
|
| 31 |
map (getIntElement "size")) |
|
| 32 |
sze = applyEither1 (map (+128)) szd |
|
| 33 |
szf = applyEither1 sum sze |
|
| 35 |
Bad _ -> let all_d = getListElement "disks" a >>= asObjectList |
|
| 36 |
szd = all_d >>= |
|
| 37 |
(sequence . |
|
| 38 |
map (getIntElement "size")) |
|
| 39 |
sze = liftM (map (+128)) szd |
|
| 40 |
szf = liftM sum sze |
|
| 34 | 41 |
in szf |
| 35 |
Right x -> Right x
|
|
| 42 |
x@(Ok _) -> x
|
|
| 36 | 43 |
nodes = getListElement "nodes" a |
| 37 |
pnode = eitherListHead nodes |
|
| 38 |
`combineEithers` readEitherString |
|
| 39 |
snode = applyEither1 (head . tail) nodes |
|
| 40 |
`combineEithers` readEitherString |
|
| 44 |
pnode = liftM head nodes >>= readEitherString |
|
| 45 |
snode = liftM (head . tail) nodes >>= readEitherString |
|
| 41 | 46 |
mem = getIntElement "memory" a |
| 42 |
running = Right "running" --getStringElement "status" a
|
|
| 47 |
running = Ok "running" --getStringElement "status" a
|
|
| 43 | 48 |
in |
| 44 |
concatEitherElems name $ |
|
| 45 |
concatEitherElems (show `applyEither1` mem) $ |
|
| 46 |
concatEitherElems (show `applyEither1` disk) $ |
|
| 47 |
concatEitherElems running $ |
|
| 48 |
concatEitherElems pnode snode |
|
| 49 |
name |+ (show `liftM` mem) |+ |
|
| 50 |
(show `liftM` disk) |+ running |+ pnode |+ snode |
|
| 49 | 51 |
|
| 50 |
parseNode :: String -> JSObject JSValue -> Either String String
|
|
| 52 |
parseNode :: String -> JSObject JSValue -> Result String
|
|
| 51 | 53 |
parseNode n a = |
| 52 |
let name = Right n
|
|
| 54 |
let name = Ok n
|
|
| 53 | 55 |
mtotal = getIntElement "total_memory" a |
| 54 | 56 |
mnode = getIntElement "reserved_memory" a |
| 55 | 57 |
mfree = getIntElement "free_memory" a |
| 56 | 58 |
dtotal = getIntElement "total_disk" a |
| 57 | 59 |
dfree = getIntElement "free_disk" a |
| 58 |
in concatEitherElems name $ |
|
| 59 |
concatEitherElems (show `applyEither1` mtotal) $ |
|
| 60 |
concatEitherElems (show `applyEither1` mnode) $ |
|
| 61 |
concatEitherElems (show `applyEither1` mfree) $ |
|
| 62 |
concatEitherElems (show `applyEither1` dtotal) |
|
| 63 |
(show `applyEither1` dfree) |
|
| 60 |
in name |+ (show `liftM` mtotal) |+ |
|
| 61 |
(show `liftM` mnode) |+ |
|
| 62 |
(show `liftM` mfree) |+ |
|
| 63 |
(show `liftM` dtotal) |+ |
|
| 64 |
(show `liftM` dfree) |
|
| 64 | 65 |
|
| 65 |
validateRequest :: String -> Either String RqType
|
|
| 66 |
validateRequest :: String -> Result RqType
|
|
| 66 | 67 |
validateRequest rq = |
| 67 | 68 |
case rq of |
| 68 |
"allocate" -> Right Allocate
|
|
| 69 |
"relocate" -> Right Relocate
|
|
| 70 |
_ -> Left ("Invalid request type '" ++ rq ++ "'")
|
|
| 69 |
"allocate" -> Ok Allocate
|
|
| 70 |
"relocate" -> Ok Relocate
|
|
| 71 |
_ -> Bad ("Invalid request type '" ++ rq ++ "'")
|
|
| 71 | 72 |
|
| 72 |
parseData :: String -> Either String (String, String)
|
|
| 73 |
parseData :: String -> Result Request
|
|
| 73 | 74 |
parseData body = |
| 74 |
let
|
|
| 75 |
decoded = resultToEither $ decodeStrict body
|
|
| 76 |
obj = decoded -- decoded `combineEithers` fromJSObject
|
|
| 75 |
do
|
|
| 76 |
decoded <- fromJResult $ decodeStrict body
|
|
| 77 |
let obj = decoded -- decoded `combineEithers` fromJSObject
|
|
| 77 | 78 |
-- request parser |
| 78 |
request = obj `combineEithers` getObjectElement "request" |
|
| 79 |
rname = request `combineEithers` getStringElement "name" |
|
| 80 |
rtype = request `combineEithers` getStringElement "type" |
|
| 81 |
`combineEithers` validateRequest |
|
| 82 |
-- existing intstance parsing |
|
| 83 |
ilist = obj `combineEithers` getObjectElement "instances" |
|
| 84 |
idata = applyEither1 fromJSObject ilist |
|
| 85 |
iobj = idata `combineEithers` (ensureEitherList . |
|
| 86 |
map (\(x,y) -> |
|
| 87 |
asJSObject y `combineEithers` |
|
| 88 |
parseInstance x)) |
|
| 89 |
ilines = iobj `combineEithers` (Right . unlines) |
|
| 90 |
-- existing node parsing |
|
| 91 |
nlist = obj `combineEithers` getObjectElement "nodes" |
|
| 92 |
ndata = applyEither1 fromJSObject nlist |
|
| 93 |
nobj = ndata `combineEithers` (ensureEitherList . |
|
| 94 |
map (\(x,y) -> |
|
| 95 |
asJSObject y `combineEithers` |
|
| 96 |
parseNode x)) |
|
| 97 |
nlines = nobj `combineEithers` (Right . unlines) |
|
| 98 |
in applyEither2 (,) nlines ilines |
|
| 79 |
request <- getObjectElement "request" obj |
|
| 80 |
rname <- getStringElement "name" request |
|
| 81 |
rtype <- getStringElement "type" request >>= validateRequest |
|
| 82 |
inew <- (\x -> if x == Allocate then parseInstance rname request |
|
| 83 |
else Ok "") rtype |
|
| 84 |
-- existing intstance parsing |
|
| 85 |
ilist <- getObjectElement "instances" obj |
|
| 86 |
let idata = fromJSObject ilist |
|
| 87 |
iobj <- (sequence . map (\(x,y) -> asJSObject y >>= parseInstance x)) |
|
| 88 |
idata |
|
| 89 |
let ilines = unlines iobj |
|
| 90 |
-- existing node parsing |
|
| 91 |
nlist <- getObjectElement "nodes" obj |
|
| 92 |
let ndata = fromJSObject nlist |
|
| 93 |
nobj <- (sequence . map (\(x,y) -> asJSObject y >>= parseNode x)) |
|
| 94 |
ndata |
|
| 95 |
let nlines = unlines nobj |
|
| 96 |
return $ (\ r nl il inew rnam -> |
|
| 97 |
case r of |
|
| 98 |
Allocate -> RqAlloc inew nl il |
|
| 99 |
Relocate -> RqReloc rnam nl il) |
|
| 100 |
rtype nlines ilines inew rname |
|
| 101 |
|
|
| 99 | 102 |
|
| 100 | 103 |
formatResponse :: Bool -> String -> [String] -> String |
| 101 | 104 |
formatResponse success info nodes = |
Also available in: Unified diff