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                   -> JSObject JSValue
  50                   -> Result (String, Instance.Instance)
  51 parseBaseInstance n a = do
  52   disk <- case fromObj "disk_usage" a of
  53             Bad _ -> do
  54                 all_d <- fromObj "disks" a >>= asObjectList
  55                 szd <- mapM (fromObj "size") all_d
  56                 let sze = map (+128) szd
  57                     szf = (sum sze)::Int
  58                 return szf
  59             x@(Ok _) -> x
  60   mem <- fromObj "memory" a
  61   let running = "running"
  62   return $ (n, Instance.create n mem disk running 0 0)
  63
  64 -- | Parses an instance as found in the cluster instance list.
  65 parseInstance :: NameAssoc        -- ^ The node name-to-index association list
  66               -> String           -- ^ The name of the instance
  67               -> JSObject JSValue -- ^ The JSON object
  68               -> Result (String, Instance.Instance)
  69 parseInstance ktn n a = do
  70     base <- parseBaseInstance n a
  71     nodes <- fromObj "nodes" a
  72     pnode <- readEitherString $ head nodes
  73     pidx <- lookupNode ktn n pnode
  74     let snodes = tail nodes
  75     sidx <- (if null snodes then return Node.noSecondary
  76              else (readEitherString $ head snodes) >>= lookupNode ktn n)
  77     return (n, Instance.setBoth (snd base) pidx sidx)
  78
  79 -- | Parses a node as found in the cluster node list.
  80 parseNode :: String           -- ^ The node's name
  81           -> JSObject JSValue -- ^ The JSON object
  82           -> Result (String, Node.Node)
  83 parseNode n a = do
  84     let name = n
  85     offline <- fromObj "offline" a
  86     drained <- fromObj "drained" a
  87     node <- (case offline of
  88                True -> return $ Node.create name 0 0 0 0 0 True
  89                _ -> do
  90                  mtotal <- fromObj "total_memory" a
  91                  mnode <- fromObj "reserved_memory" a
  92                  mfree <- fromObj "free_memory" a
  93                  dtotal <- fromObj "total_disk" a
  94                  dfree <- fromObj "free_disk" a
  95                  return $ Node.create n mtotal mnode mfree
  96                         dtotal dfree (offline || drained))
  97     return (name, node)
  98
  99 -- | Top-level parser.
 100 parseData :: String         -- ^ The JSON message as received from Ganeti
 101           -> Result Request -- ^ A (possible valid) request
 102 parseData body = do
 103   decoded <- fromJResult $ decodeStrict body
 104   let obj = decoded
 105   -- request parser
 106   request <- fromObj "request" obj
 107   rname <- fromObj "name" request
 108   -- existing node parsing
 109   nlist <- fromObj "nodes" obj
 110   let ndata = fromJSObject nlist
 111   nobj <- (mapM (\(x,y) -> asJSObject y >>= parseNode x)) ndata
 112   let (ktn, nl) = assignIndices nobj
 113   -- existing instance parsing
 114   ilist <- fromObj "instances" obj
 115   let idata = fromJSObject ilist
 116   iobj <- (mapM (\(x,y) -> asJSObject y >>= parseInstance ktn x)) idata
 117   let (kti, il) = assignIndices iobj
 118   (map_n, map_i, csf) <- mergeData (nl, il)
 119   req_nodes <- fromObj "required_nodes" request
 120   optype <- fromObj "type" request
 121   rqtype <-
 122       case optype of
 123         "allocate" ->
 124             do
 125               inew <- parseBaseInstance rname request
 126               let io = snd inew
 127               return $ Allocate io req_nodes
 128         "relocate" ->
 129             do
 130               ridx <- lookupInstance kti rname
 131               ex_nodes <- fromObj "relocate_from" request
 132               let ex_nodes' = map (stripSuffix $ length csf) ex_nodes
 133               ex_idex <- mapM (Container.findByName map_n) ex_nodes'
 134               return $ Relocate ridx req_nodes ex_idex
 135         other -> fail $ ("Invalid request type '" ++ other ++ "'")
 136   return $ Request rqtype map_n map_i csf
 137
 138 -- | Formats the response into a valid IAllocator response message.
 139 formatResponse :: Bool     -- ^ Whether the request was successful
 140                -> String   -- ^ Information text
 141                -> [String] -- ^ The list of chosen nodes
 142                -> String   -- ^ The JSON-formatted message
 143 formatResponse success info nodes =
 144     let
 145         e_success = ("success", JSBool success)
 146         e_info = ("info", JSString . toJSString $ info)
 147         e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes)
 148     in encodeStrict $ makeObj [e_success, e_info, e_nodes]