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