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

   1 {-| Implementation of the iallocator interface.
   2
   3 -}
   4
   5 {-
   6
   7 Copyright (C) 2009 Google Inc.
   8
   9 This program is free software; you can redistribute it and/or modify
  10 it under the terms of the GNU General Public License as published by
  11 the Free Software Foundation; either version 2 of the License, or
  12 (at your option) any later version.
  13
  14 This program is distributed in the hope that it will be useful, but
  15 WITHOUT ANY WARRANTY; without even the implied warranty of
  16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 General Public License for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with this program; if not, write to the Free Software
  21 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  22 02110-1301, USA.
  23
  24 -}
  25
  26 module Ganeti.HTools.IAlloc
  27     ( parseData
  28     , formatResponse
  29     ) where
  30
  31 import Data.Either ()
  32 import Control.Monad
  33 import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray),
  34                   makeObj, encodeStrict, decodeStrict,
  35                   fromJSObject, toJSString)
  36 import qualified Ganeti.HTools.Container as Container
  37 import qualified Ganeti.HTools.Node as Node
  38 import qualified Ganeti.HTools.Instance as Instance
  39 import Ganeti.HTools.Loader
  40 import Ganeti.HTools.Utils
  41 import Ganeti.HTools.Types
  42
  43 -- | Parse the basic specifications of an instance.
  44 --
  45 -- Instances in the cluster instance list and the instance in an
  46 -- 'Allocate' request share some common properties, which are read by
  47 -- this function.
  48 parseBaseInstance :: String
  49                   -> [(String, JSValue)]
  50                   -> Result (String, Instance.Instance)
  51 parseBaseInstance n a = do
  52   disk <- fromObj "disk_space_total" a
  53   mem <- fromObj "memory" a
  54   vcpus <- fromObj "vcpus" a
  55   tags <- fromObj "tags" a
  56   let running = "running"
  57   return (n, Instance.create n mem disk vcpus running tags 0 0)
  58
  59 -- | Parses an instance as found in the cluster instance listg.
  60 parseInstance :: NameAssoc        -- ^ The node name-to-index association list
  61               -> String           -- ^ The name of the instance
  62               -> [(String, JSValue)] -- ^ The JSON object
  63               -> Result (String, Instance.Instance)
  64 parseInstance ktn n a = do
  65   base <- parseBaseInstance n a
  66   nodes <- fromObj "nodes" a
  67   pnode <- if null nodes
  68            then Bad $ "empty node list for instance " ++ n
  69            else readEitherString $ head nodes
  70   pidx <- lookupNode ktn n pnode
  71   let snodes = tail nodes
  72   sidx <- (if null snodes then return Node.noSecondary
  73            else readEitherString (head snodes) >>= lookupNode ktn n)
  74   return (n, Instance.setBoth (snd base) pidx sidx)
  75
  76 -- | Parses a node as found in the cluster node list.
  77 parseNode :: String           -- ^ The node's name
  78           -> [(String, JSValue)] -- ^ The JSON object
  79           -> Result (String, Node.Node)
  80 parseNode n a = do
  81   offline <- fromObj "offline" a
  82   drained <- fromObj "drained" a
  83   guuid   <- fromObj "group" a
  84   node <- (if offline || drained
  85            then return $ Node.create n 0 0 0 0 0 0 True guuid
  86            else do
  87              mtotal <- fromObj "total_memory" a
  88              mnode  <- fromObj "reserved_memory" a
  89              mfree  <- fromObj "free_memory"  a
  90              dtotal <- fromObj "total_disk"   a
  91              dfree  <- fromObj "free_disk"    a
  92              ctotal <- fromObj "total_cpus"   a
  93              return $ Node.create n mtotal mnode mfree
  94                     dtotal dfree ctotal False guuid)
  95   return (n, node)
  96
  97 -- | Top-level parser.
  98 parseData :: String         -- ^ The JSON message as received from Ganeti
  99           -> Result Request -- ^ A (possible valid) request
 100 parseData body = do
 101   decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body)
 102   let obj = fromJSObject decoded
 103   -- request parser
 104   request <- liftM fromJSObject (fromObj "request" obj)
 105   -- existing node parsing
 106   nlist <- liftM fromJSObject (fromObj "nodes" obj)
 107   nobj <- mapM (\(x,y) -> asJSObject y >>= parseNode x . fromJSObject) nlist
 108   let (ktn, nl) = assignIndices nobj
 109   -- existing instance parsing
 110   ilist <- fromObj "instances" obj
 111   let idata = fromJSObject ilist
 112   iobj <- mapM (\(x,y) ->
 113                     asJSObject y >>= parseInstance ktn x . fromJSObject) idata
 114   let (kti, il) = assignIndices iobj
 115   -- cluster tags
 116   ctags <- fromObj "cluster_tags" obj
 117   (map_n, map_i, ptags) <- mergeData [] [] [] (nl, il, ctags)
 118   optype <- fromObj "type" request
 119   rqtype <-
 120       case optype of
 121         "allocate" ->
 122             do
 123               rname <- fromObj "name" request
 124               req_nodes <- fromObj "required_nodes" request
 125               inew <- parseBaseInstance rname request
 126               let io = snd inew
 127               return $ Allocate io req_nodes
 128         "relocate" ->
 129             do
 130               rname <- fromObj "name" request
 131               ridx <- lookupInstance kti rname
 132               req_nodes <- fromObj "required_nodes" request
 133               ex_nodes <- fromObj "relocate_from" request
 134               ex_idex <- mapM (Container.findByName map_n) ex_nodes
 135               return $ Relocate ridx req_nodes (map Node.idx ex_idex)
 136         "multi-evacuate" ->
 137             do
 138               ex_names <- fromObj "evac_nodes" request
 139               ex_nodes <- mapM (Container.findByName map_n) ex_names
 140               let ex_ndx = map Node.idx ex_nodes
 141               return $ Evacuate ex_ndx
 142         other -> fail ("Invalid request type '" ++ other ++ "'")
 143   return $ Request rqtype map_n map_i ptags
 144
 145 -- | Format the result
 146 formatRVal :: RqType -> [Node.AllocElement] -> JSValue
 147 formatRVal _ [] = JSArray []
 148
 149 formatRVal (Evacuate _) elems =
 150     let sols = map (\(_, inst, nl) -> Instance.name inst : map Node.name nl)
 151                elems
 152         jsols = map (JSArray . map (JSString . toJSString)) sols
 153     in JSArray jsols
 154
 155 formatRVal _ elems =
 156     let (_, _, nodes) = head elems
 157         nodes' = map Node.name nodes
 158     in JSArray $ map (JSString . toJSString) nodes'
 159
 160 -- | Formats the response into a valid IAllocator response message.
 161 formatResponse :: Bool     -- ^ Whether the request was successful
 162                -> String   -- ^ Information text
 163                -> RqType   -- ^ Request type
 164                -> [Node.AllocElement] -- ^ The resulting allocations
 165                -> String   -- ^ The JSON-formatted message
 166 formatResponse success info rq elems =
 167     let
 168         e_success = ("success", JSBool success)
 169         e_info = ("info", JSString . toJSString $ info)
 170         e_nodes = ("nodes", formatRVal rq elems)
 171     in encodeStrict $ makeObj [e_success, e_info, e_nodes]