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 <- readEitherString $ head nodes
  68   pidx <- lookupNode ktn n pnode
  69   let snodes = tail nodes
  70   sidx <- (if null snodes then return Node.noSecondary
  71            else readEitherString (head snodes) >>= lookupNode ktn n)
  72   return (n, Instance.setBoth (snd base) pidx sidx)
  73
  74 -- | Parses a node as found in the cluster node list.
  75 parseNode :: String           -- ^ The node's name
  76           -> [(String, JSValue)] -- ^ The JSON object
  77           -> Result (String, Node.Node)
  78 parseNode n a = do
  79   offline <- fromObj "offline" a
  80   drained <- fromObj "drained" a
  81   node <- (if offline || drained
  82            then return $ Node.create n 0 0 0 0 0 0 True
  83            else do
  84              mtotal <- fromObj "total_memory" a
  85              mnode  <- fromObj "reserved_memory" a
  86              mfree  <- fromObj "free_memory"  a
  87              dtotal <- fromObj "total_disk"   a
  88              dfree  <- fromObj "free_disk"    a
  89              ctotal <- fromObj "total_cpus"   a
  90              return $ Node.create n mtotal mnode mfree
  91                     dtotal dfree ctotal False)
  92   return (n, node)
  93
  94 -- | Top-level parser.
  95 parseData :: String         -- ^ The JSON message as received from Ganeti
  96           -> Result Request -- ^ A (possible valid) request
  97 parseData body = do
  98   decoded <- fromJResult $ decodeStrict body
  99   let obj = fromJSObject decoded
 100   -- request parser
 101   request <- liftM fromJSObject (fromObj "request" obj)
 102   -- existing node parsing
 103   nlist <- liftM fromJSObject (fromObj "nodes" obj)
 104   nobj <- mapM (\(x,y) -> asJSObject y >>= parseNode x . fromJSObject) nlist
 105   let (ktn, nl) = assignIndices nobj
 106   -- existing instance parsing
 107   ilist <- fromObj "instances" obj
 108   let idata = fromJSObject ilist
 109   iobj <- mapM (\(x,y) ->
 110                     asJSObject y >>= parseInstance ktn x . fromJSObject) idata
 111   let (kti, il) = assignIndices iobj
 112   -- cluster tags
 113   ctags <- fromObj "cluster_tags" obj
 114   (map_n, map_i, ptags, csf) <- mergeData [] [] (nl, il, ctags)
 115   optype <- fromObj "type" request
 116   rqtype <-
 117       case optype of
 118         "allocate" ->
 119             do
 120               rname <- fromObj "name" request
 121               req_nodes <- fromObj "required_nodes" request
 122               inew <- parseBaseInstance rname request
 123               let io = snd inew
 124               return $ Allocate io req_nodes
 125         "relocate" ->
 126             do
 127               rname <- fromObj "name" request
 128               ridx <- lookupInstance kti rname
 129               req_nodes <- fromObj "required_nodes" request
 130               ex_nodes <- fromObj "relocate_from" request
 131               let ex_nodes' = map (stripSuffix $ length csf) ex_nodes
 132               ex_idex <- mapM (Container.findByName map_n) ex_nodes'
 133               return $ Relocate ridx req_nodes (map Node.idx ex_idex)
 134         "multi-evacuate" ->
 135             do
 136               ex_names <- fromObj "evac_nodes" request
 137               let ex_names' = map (stripSuffix $ length csf) ex_names
 138               ex_nodes <- mapM (Container.findByName map_n) ex_names'
 139               let ex_ndx = map Node.idx ex_nodes
 140               return $ Evacuate ex_ndx
 141         other -> fail ("Invalid request type '" ++ other ++ "'")
 142   return $ Request rqtype map_n map_i ptags csf
 143
 144 formatRVal :: String -> RqType
 145            -> [Node.AllocElement] -> JSValue
 146 formatRVal csf (Evacuate _) elems =
 147     let sols = map (\(_, inst, nl) ->
 148                         let names = Instance.name inst : map Node.name nl
 149                         in map (++ csf) names) elems
 150         jsols = map (JSArray . map (JSString . toJSString)) sols
 151     in JSArray jsols
 152
 153 formatRVal csf _ elems =
 154     let (_, _, nodes) = head elems
 155         nodes' = map ((++ csf) . Node.name) nodes
 156     in JSArray $ map (JSString . toJSString) nodes'
 157
 158
 159 -- | Formats the response into a valid IAllocator response message.
 160 formatResponse :: Bool     -- ^ Whether the request was successful
 161                -> String   -- ^ Information text
 162                -> String   -- ^ Suffix for nodes/instances
 163                -> RqType   -- ^ Request type
 164                -> [Node.AllocElement] -- ^ The resulting allocations
 165                -> String   -- ^ The JSON-formatted message
 166 formatResponse success info csf rq elems =
 167     let
 168         e_success = ("success", JSBool success)
 169         e_info = ("info", JSString . toJSString $ info)
 170         e_nodes = ("nodes", formatRVal csf rq elems)
 171     in encodeStrict $ makeObj [e_success, e_info, e_nodes]