IAlloc.hs 7.3 KB
Newer Older
1 2 3 4
{-| Implementation of the iallocator interface.

-}

Iustin Pop's avatar
Iustin Pop committed
5 6
{-

7
Copyright (C) 2009, 2010, 2011 Google Inc.
Iustin Pop's avatar
Iustin Pop committed
8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.

-}

26
module Ganeti.HTools.IAlloc
27
    ( parseData
28 29 30 31 32
    , formatResponse
    ) where

import Data.Either ()
import Control.Monad
33 34 35
import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray),
                  makeObj, encodeStrict, decodeStrict,
                  fromJSObject, toJSString)
36
import qualified Ganeti.HTools.Container as Container
37
import qualified Ganeti.HTools.Group as Group
38 39
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Instance as Instance
Iustin Pop's avatar
Iustin Pop committed
40 41 42
import Ganeti.HTools.Loader
import Ganeti.HTools.Utils
import Ganeti.HTools.Types
43

Iustin Pop's avatar
Iustin Pop committed
44 45 46 47 48
-- | Parse the basic specifications of an instance.
--
-- Instances in the cluster instance list and the instance in an
-- 'Allocate' request share some common properties, which are read by
-- this function.
Iustin Pop's avatar
Iustin Pop committed
49
parseBaseInstance :: String
50
                  -> [(String, JSValue)]
Iustin Pop's avatar
Iustin Pop committed
51 52
                  -> Result (String, Instance.Instance)
parseBaseInstance n a = do
53 54 55 56 57
  let extract x = tryFromObj ("invalid data for instance '" ++ n ++ "'") a x
  disk  <- extract "disk_space_total"
  mem   <- extract "memory"
  vcpus <- extract "vcpus"
  tags  <- extract "tags"
Iustin Pop's avatar
Iustin Pop committed
58
  let running = "running"
Iustin Pop's avatar
Iustin Pop committed
59
  return (n, Instance.create n mem disk vcpus running tags 0 0)
Iustin Pop's avatar
Iustin Pop committed
60

61
-- | Parses an instance as found in the cluster instance listg.
Iustin Pop's avatar
Iustin Pop committed
62 63
parseInstance :: NameAssoc        -- ^ The node name-to-index association list
              -> String           -- ^ The name of the instance
64
              -> [(String, JSValue)] -- ^ The JSON object
Iustin Pop's avatar
Iustin Pop committed
65 66
              -> Result (String, Instance.Instance)
parseInstance ktn n a = do
67
  base <- parseBaseInstance n a
68
  nodes <- fromObj a "nodes"
69 70 71
  pnode <- if null nodes
           then Bad $ "empty node list for instance " ++ n
           else readEitherString $ head nodes
72 73 74 75 76
  pidx <- lookupNode ktn n pnode
  let snodes = tail nodes
  sidx <- (if null snodes then return Node.noSecondary
           else readEitherString (head snodes) >>= lookupNode ktn n)
  return (n, Instance.setBoth (snd base) pidx sidx)
Iustin Pop's avatar
Iustin Pop committed
77

Iustin Pop's avatar
Iustin Pop committed
78
-- | Parses a node as found in the cluster node list.
Iustin Pop's avatar
Iustin Pop committed
79 80
parseNode :: NameAssoc           -- ^ The group association
          -> String              -- ^ The node's name
81
          -> [(String, JSValue)] -- ^ The JSON object
Iustin Pop's avatar
Iustin Pop committed
82
          -> Result (String, Node.Node)
Iustin Pop's avatar
Iustin Pop committed
83
parseNode ktg n a = do
84 85 86 87
  let extract x = tryFromObj ("invalid data for node '" ++ n ++ "'") a x
  offline <- extract "offline"
  drained <- extract "drained"
  guuid   <- extract "group"
Iustin Pop's avatar
Iustin Pop committed
88
  gidx <- lookupGroup ktg n guuid
89
  node <- (if offline || drained
Iustin Pop's avatar
Iustin Pop committed
90
           then return $ Node.create n 0 0 0 0 0 0 True gidx
91
           else do
92 93 94 95 96 97
             mtotal <- extract "total_memory"
             mnode  <- extract "reserved_memory"
             mfree  <- extract "free_memory"
             dtotal <- extract "total_disk"
             dfree  <- extract "free_disk"
             ctotal <- extract "total_cpus"
98
             return $ Node.create n mtotal mnode mfree
Iustin Pop's avatar
Iustin Pop committed
99
                    dtotal dfree ctotal False gidx)
100
  return (n, node)
101

102 103 104 105 106
-- | Parses a group as found in the cluster group list.
parseGroup :: String              -- ^ The group UUID
           -> [(String, JSValue)] -- ^ The JSON object
           -> Result (String, Group.Group)
parseGroup u a = do
107
  name <- fromObj a "name"
108 109
  return (u, Group.create name u AllocPreferred)

Iustin Pop's avatar
Iustin Pop committed
110 111 112
-- | Top-level parser.
parseData :: String         -- ^ The JSON message as received from Ganeti
          -> Result Request -- ^ A (possible valid) request
Iustin Pop's avatar
Iustin Pop committed
113
parseData body = do
114
  decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body)
115
  let obj = fromJSObject decoded
116
      extrObj x = tryFromObj "invalid iallocator message" obj x
Iustin Pop's avatar
Iustin Pop committed
117
  -- request parser
118 119
  request <- liftM fromJSObject (extrObj "request")
  let extrReq x = tryFromObj "invalid request dict" request x
120
  -- existing group parsing
121
  glist <- liftM fromJSObject (extrObj "nodegroups")
122
  gobj <- mapM (\(x, y) -> asJSObject y >>= parseGroup x . fromJSObject) glist
Iustin Pop's avatar
Iustin Pop committed
123
  let (ktg, gl) = assignIndices gobj
Iustin Pop's avatar
Iustin Pop committed
124
  -- existing node parsing
125
  nlist <- liftM fromJSObject (extrObj "nodes")
Iustin Pop's avatar
Iustin Pop committed
126 127
  nobj <- mapM (\(x,y) ->
                    asJSObject y >>= parseNode ktg x . fromJSObject) nlist
128
  let (ktn, nl) = assignIndices nobj
Iustin Pop's avatar
Iustin Pop committed
129
  -- existing instance parsing
130
  ilist <- extrObj "instances"
Iustin Pop's avatar
Iustin Pop committed
131
  let idata = fromJSObject ilist
132 133
  iobj <- mapM (\(x,y) ->
                    asJSObject y >>= parseInstance ktn x . fromJSObject) idata
134
  let (kti, il) = assignIndices iobj
135
  -- cluster tags
136
  ctags <- extrObj "cluster_tags"
137
  cdata <- mergeData [] [] [] (ClusterData gl nl il ctags)
138
  let map_n = cdNodes cdata
139
  optype <- extrReq "type"
Iustin Pop's avatar
Iustin Pop committed
140 141 142 143
  rqtype <-
      case optype of
        "allocate" ->
            do
144 145 146
              rname     <- extrReq "name"
              req_nodes <- extrReq "required_nodes"
              inew      <- parseBaseInstance rname request
147 148
              let io = snd inew
              return $ Allocate io req_nodes
Iustin Pop's avatar
Iustin Pop committed
149 150
        "relocate" ->
            do
151 152 153 154 155
              rname     <- extrReq "name"
              ridx      <- lookupInstance kti rname
              req_nodes <- extrReq "required_nodes"
              ex_nodes  <- extrReq "relocate_from"
              ex_idex   <- mapM (Container.findByName map_n) ex_nodes
156
              return $ Relocate ridx req_nodes (map Node.idx ex_idex)
157 158
        "multi-evacuate" ->
            do
159
              ex_names <- extrReq "evac_nodes"
160
              ex_nodes <- mapM (Container.findByName map_n) ex_names
161 162
              let ex_ndx = map Node.idx ex_nodes
              return $ Evacuate ex_ndx
Iustin Pop's avatar
Iustin Pop committed
163
        other -> fail ("Invalid request type '" ++ other ++ "'")
164
  return $ Request rqtype cdata
165

166
-- | Format the result
167 168
formatRVal :: RqType -> [Node.AllocElement] -> JSValue
formatRVal _ [] = JSArray []
169

170
formatRVal (Evacuate _) elems =
171
    let sols = map (\(_, inst, nl, _) -> Instance.name inst : map Node.name nl)
172
               elems
173 174 175
        jsols = map (JSArray . map (JSString . toJSString)) sols
    in JSArray jsols

176
formatRVal _ elems =
177
    let (_, _, nodes, _) = head elems
178
        nodes' = map Node.name nodes
179 180
    in JSArray $ map (JSString . toJSString) nodes'

Iustin Pop's avatar
Iustin Pop committed
181 182 183
-- | Formats the response into a valid IAllocator response message.
formatResponse :: Bool     -- ^ Whether the request was successful
               -> String   -- ^ Information text
184 185
               -> RqType   -- ^ Request type
               -> [Node.AllocElement] -- ^ The resulting allocations
Iustin Pop's avatar
Iustin Pop committed
186
               -> String   -- ^ The JSON-formatted message
187
formatResponse success info rq elems =
188 189 190
    let
        e_success = ("success", JSBool success)
        e_info = ("info", JSString . toJSString $ info)
191
        e_nodes = ("nodes", formatRVal rq elems)
192
    in encodeStrict $ makeObj [e_success, e_info, e_nodes]