IAlloc.hs 7.11 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
  cdata <- mergeData [] [] [] (ClusterData gl nl il ctags)
134
  let map_n = cdNodes cdata
Iustin Pop's avatar
Iustin Pop committed
135 136 137 138 139
  optype <- fromObj "type" request
  rqtype <-
      case optype of
        "allocate" ->
            do
140 141
              rname <- fromObj "name" request
              req_nodes <- fromObj "required_nodes" request
Iustin Pop's avatar
Iustin Pop committed
142
              inew <- parseBaseInstance rname request
143 144
              let io = snd inew
              return $ Allocate io req_nodes
Iustin Pop's avatar
Iustin Pop committed
145 146
        "relocate" ->
            do
147
              rname <- fromObj "name" request
148
              ridx <- lookupInstance kti rname
149
              req_nodes <- fromObj "required_nodes" request
150
              ex_nodes <- fromObj "relocate_from" request
151
              ex_idex <- mapM (Container.findByName map_n) ex_nodes
152
              return $ Relocate ridx req_nodes (map Node.idx ex_idex)
153 154 155
        "multi-evacuate" ->
            do
              ex_names <- fromObj "evac_nodes" request
156
              ex_nodes <- mapM (Container.findByName map_n) ex_names
157 158
              let ex_ndx = map Node.idx ex_nodes
              return $ Evacuate ex_ndx
Iustin Pop's avatar
Iustin Pop committed
159
        other -> fail ("Invalid request type '" ++ other ++ "'")
160
  return $ Request rqtype cdata
161

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

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

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

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