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               ex_nodes <- mapM (Container.findByName map_n) ex_names
 138               let ex_ndx = map Node.idx ex_nodes
 139               return $ Evacuate ex_ndx
 140         other -> fail ("Invalid request type '" ++ other ++ "'")
 141   return $ Request rqtype map_n map_i ptags csf
 142
 143 formatRVal :: String -> RqType
 144            -> [Node.AllocElement] -> JSValue
 145 formatRVal csf (Evacuate _) elems =
 146     let sols = map (\(_, inst, nl) ->
 147                         let names = Instance.name inst : map Node.name nl
 148                         in map (++ csf) names) elems
 149         jsols = map (JSArray . map (JSString . toJSString)) sols
 150     in JSArray jsols
 151
 152 formatRVal csf _ elems =
 153     let (_, _, nodes) = head elems
 154         nodes' = map ((++ csf) . Node.name) nodes
 155     in JSArray $ map (JSString . toJSString) nodes'
 156
 157
 158 -- | Formats the response into a valid IAllocator response message.
 159 formatResponse :: Bool     -- ^ Whether the request was successful
 160                -> String   -- ^ Information text
 161                -> String   -- ^ Suffix for nodes/instances
 162                -> RqType   -- ^ Request type
 163                -> [Node.AllocElement] -- ^ The resulting allocations
 164                -> String   -- ^ The JSON-formatted message
 165 formatResponse success info csf rq elems =
 166     let
 167         e_success = ("success", JSBool success)
 168         e_info = ("info", JSString . toJSString $ info)
 169         e_nodes = ("nodes", formatRVal csf rq elems)
 170     in encodeStrict $ makeObj [e_success, e_info, e_nodes]