IAlloc.hs 7.4 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 108 109 110
  let extract x = tryFromObj ("invalid data for group '" ++ u ++ "'") a x
  name <- extract "name"
  apol <- extract "alloc_policy"
  return (u, Group.create name u apol)
111

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

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

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

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

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