IAlloc.hs 6.99 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 78
-- | Parses a node as found in the cluster node list.
parseNode :: String           -- ^ The node's name
79
          -> [(String, JSValue)] -- ^ The JSON object
Iustin Pop's avatar
Iustin Pop committed
80
          -> Result (String, Node.Node)
Iustin Pop's avatar
Iustin Pop committed
81
parseNode n a = do
82 83
  offline <- fromObj "offline" a
  drained <- fromObj "drained" a
84
  guuid   <- fromObj "group" a
85
  node <- (if offline || drained
86
           then return $ Node.create n 0 0 0 0 0 0 True guuid
87 88 89 90 91 92 93 94
           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
95
                    dtotal dfree ctotal False guuid)
96
  return (n, node)
97

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

158
-- | Format the result
159 160
formatRVal :: RqType -> [Node.AllocElement] -> JSValue
formatRVal _ [] = JSArray []
161

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

168
formatRVal _ elems =
169
    let (_, _, nodes, _) = head elems
170
        nodes' = map Node.name nodes
171 172
    in JSArray $ map (JSString . toJSString) nodes'

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