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 (JSObject, JSValue(JSBool, JSString, JSArray),
  15                   makeObj, encodeStrict, decodeStrict,
  16                   fromJSObject, toJSString)
  17 import Text.Printf (printf)
  18 import Ganeti.HTools.Utils
  19 import qualified Ganeti.HTools.Node as Node
  20 import qualified Ganeti.HTools.Instance as Instance
  21
  22 data RqType
  23     = Allocate
  24     | Relocate
  25     deriving (Eq, Show)
  26
  27 data Request
  28     = RqAlloc String String String
  29     | RqReloc String String String
  30
  31 parseInstance :: String -> JSObject JSValue -> Result String
  32 parseInstance n a =
  33     let name = Ok n
  34         disk = case getIntElement "disk_usage" a of
  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
  41                            in szf
  42                  x@(Ok _) -> x
  43         nodes = getListElement "nodes" a
  44         pnode = liftM head nodes >>= readEitherString
  45         snode = liftM (head . tail) nodes >>= readEitherString
  46         mem = getIntElement "memory" a
  47         running = Ok "running" --getStringElement "status" a
  48     in
  49       name |+ (show `liftM` mem) |+
  50               (show `liftM` disk) |+ running |+ pnode |+ snode
  51
  52 parseNode :: String -> JSObject JSValue -> Result String
  53 parseNode n a =
  54     let name = Ok n
  55         mtotal = getIntElement "total_memory" a
  56         mnode = getIntElement "reserved_memory" a
  57         mfree = getIntElement "free_memory" a
  58         dtotal = getIntElement "total_disk" a
  59         dfree = getIntElement "free_disk" a
  60     in name |+ (show `liftM` mtotal) |+
  61               (show `liftM` mnode) |+
  62               (show `liftM` mfree) |+
  63               (show `liftM` dtotal) |+
  64               (show `liftM` dfree)
  65
  66 validateRequest :: String -> Result RqType
  67 validateRequest rq =
  68     case rq of
  69       "allocate" -> Ok Allocate
  70       "relocate" -> Ok Relocate
  71       _ -> Bad ("Invalid request type '" ++ rq ++ "'")
  72
  73 parseData :: String -> Result Request
  74 parseData body =
  75     do
  76       decoded <- fromJResult $ decodeStrict body
  77       let obj = decoded -- decoded `combineEithers` fromJSObject
  78         -- request parser
  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
 102
 103 formatResponse :: Bool -> String -> [String] -> String
 104 formatResponse success info nodes =
 105     let
 106         e_success = ("success", JSBool success)
 107         e_info = ("info", JSString . toJSString $ info)
 108         e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes)
 109     in encodeStrict $ makeObj [e_success, e_info, e_nodes]