code.grnet.gr Git - ganeti-local/blob - Ganeti/HTools/IAlloc.hs

   1 {-| Implementation of the iallocator interface.
   2
   3 -}
   4
   5 module Ganeti.HTools.IAlloc
   6     (
   7       parseData
   8     , formatResponse
   9     ) where
  10
  11 import Data.Either ()
  12 import Data.Maybe
  13 import Control.Monad
  14 import Text.JSON
  15 import Text.Printf (printf)
  16 import Ganeti.HTools.Utils ()
  17
  18
  19 -- Some constants
  20
  21 {-- Our cheap monad-like stuff.
  22
  23 Thi is needed since Either e a is already a monad instance somewhere
  24 in the standard libraries (Control.Monad.Error) and we don't need that
  25 entire thing.
  26
  27 -}
  28 combine :: (Either String a) -> (a -> Either String b)  -> (Either String b)
  29 combine (Left s) _ = Left s
  30 combine (Right s) f = f s
  31
  32 ensureList :: [Either String a] -> Either String [a]
  33 ensureList lst =
  34     foldr (\elem accu ->
  35                case (elem, accu) of
  36                  (Left x, _) -> Left x
  37                  (_, Left x) -> Left x -- should never happen
  38                  (Right e, Right a) -> Right (e:a)
  39           )
  40     (Right []) lst
  41
  42 listHead :: Either String [a] -> Either String a
  43 listHead lst =
  44     case lst of
  45       Left x -> Left x
  46       Right (x:_) -> Right x
  47       Right [] -> Left "List empty"
  48
  49 loadJSArray :: String -> Either String [JSObject JSValue]
  50 loadJSArray s = resultToEither $ decodeStrict s
  51
  52 fromObj :: JSON a => String -> JSObject JSValue -> Either String a
  53 fromObj k o =
  54     case lookup k (fromJSObject o) of
  55       Nothing -> Left $ printf "key '%s' not found" k
  56       Just val -> resultToEither $ readJSON val
  57
  58 getStringElement :: String -> JSObject JSValue -> Either String String
  59 getStringElement = fromObj
  60
  61 getIntElement :: String -> JSObject JSValue -> Either String Int
  62 getIntElement = fromObj
  63
  64 getListElement :: String -> JSObject JSValue
  65                -> Either String [JSValue]
  66 getListElement = fromObj
  67
  68 readString :: JSValue -> Either String String
  69 readString v =
  70     case v of
  71       JSString s -> Right $ fromJSString s
  72       _ -> Left "Wrong JSON type"
  73
  74 concatElems :: Either String String
  75             -> Either String String
  76             -> Either String String
  77 concatElems = apply2 (\x y -> x ++ "|" ++ y)
  78
  79 apply1 :: (a -> b) -> Either String a -> Either String b
  80 apply1 fn a =
  81     case a of
  82       Left x -> Left x
  83       Right y -> Right $ fn y
  84
  85 apply2 :: (a -> b -> c)
  86        -> Either String a
  87        -> Either String b
  88        -> Either String c
  89 apply2 fn a b =
  90     case (a, b) of
  91       (Right x, Right y) -> Right $ fn x y
  92       (Left x, _) -> Left x
  93       (_, Left y) -> Left y
  94
  95 parseList :: (JSObject JSValue -> Either String String)
  96           -> [JSObject JSValue]
  97           ->Either String String
  98 parseList fn idata =
  99     let ml = ensureList $ map fn idata
 100     in ml `combine` (Right . unlines)
 101
 102 parseInstance :: JSObject JSValue -> Either String String
 103 parseInstance a =
 104     let name = getStringElement "name" a
 105         disk = case getIntElement "disk_usage" a of
 106                  Left _ -> let log_sz = apply2 (+)
 107                                         (getIntElement "sda_size" a)
 108                                         (getIntElement "sdb_size" a)
 109                            in apply2 (+) log_sz (Right $ 128 * 2)
 110                  Right x -> Right x
 111         bep = fromObj "beparams" a
 112         pnode = getStringElement "pnode" a
 113         snode = (listHead $ getListElement "snodes" a) `combine` readString
 114         mem = case bep of
 115                 Left _ -> getIntElement "admin_ram" a
 116                 Right o -> getIntElement "memory" o
 117         running = getStringElement "status" a
 118     in
 119       concatElems name $
 120                   concatElems (show `apply1` mem) $
 121                   concatElems (show `apply1` disk) $
 122                   concatElems running $
 123                   concatElems pnode snode
 124
 125 parseNode :: JSObject JSValue -> Either String String
 126 parseNode a =
 127     let name = getStringElement "name" a
 128         mtotal = getIntElement "mtotal" a
 129         mnode = getIntElement "mnode" a
 130         mfree = getIntElement "mfree" a
 131         dtotal = getIntElement "dtotal" a
 132         dfree = getIntElement "dfree" a
 133     in concatElems name $
 134        concatElems (show `apply1` mtotal) $
 135        concatElems (show `apply1` mnode) $
 136        concatElems (show `apply1` mfree) $
 137        concatElems (show `apply1` dtotal) (show `apply1` dfree)
 138
 139 parseData :: String -> Maybe String
 140
 141 parseData x = Just x
 142
 143 formatResponse :: Bool -> String -> [String] -> String
 144 formatResponse success info nodes =
 145     let
 146         e_success = ("success", JSBool success)
 147         e_info = ("info", JSString . toJSString $ info)
 148         e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes)
 149     in encodeStrict $ makeObj [e_success, e_info, e_nodes]