IAlloc.hs 7.13 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 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
  disk <- fromObj "disk_space_total" a
Iustin Pop's avatar
Iustin Pop committed
54
  mem <- fromObj "memory" a
55
  vcpus <- fromObj "vcpus" a
Iustin Pop's avatar
Iustin Pop committed
56
  tags <- fromObj "tags" a
Iustin Pop's avatar
Iustin Pop committed
57
  let running = "running"
Iustin Pop's avatar
Iustin Pop committed
58
  return (n, Instance.create n mem disk vcpus running tags 0 0)
Iustin Pop's avatar
Iustin Pop committed
59

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

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

100 101 102 103 104 105 106 107
-- | 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
  name <- fromObj "name" a
  return (u, Group.create name u AllocPreferred)

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

161
-- | Format the result
162 163
formatRVal :: RqType -> [Node.AllocElement] -> JSValue
formatRVal _ [] = JSArray []
164

165
formatRVal (Evacuate _) elems =
166
    let sols = map (\(_, inst, nl, _) -> Instance.name inst : map Node.name nl)
167
               elems
168 169 170
        jsols = map (JSArray . map (JSString . toJSString)) sols
    in JSArray jsols

171
formatRVal _ elems =
172
    let (_, _, nodes, _) = head elems
173
        nodes' = map Node.name nodes
174 175
    in JSArray $ map (JSString . toJSString) nodes'

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