Reduce the warnings during the unittests
[ganeti-local] / Ganeti / HTools / IAlloc.hs
1 {-| Implementation of the iallocator interface.
2
3 -}
4
5 {-
6
7 Copyright (C) 2009 Google Inc.
8
9 This program is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 2 of the License, or
12 (at your option) any later version.
13
14 This program is distributed in the hope that it will be useful, but
15 WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
17 General Public License for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with this program; if not, write to the Free Software
21 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
22 02110-1301, USA.
23
24 -}
25
26 module Ganeti.HTools.IAlloc
27     ( parseData
28     , formatResponse
29     ) where
30
31 import Data.Either ()
32 import Control.Monad
33 import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray),
34                   makeObj, encodeStrict, decodeStrict,
35                   fromJSObject, toJSString)
36 import qualified Ganeti.HTools.Container as Container
37 import qualified Ganeti.HTools.Node as Node
38 import qualified Ganeti.HTools.Instance as Instance
39 import Ganeti.HTools.Loader
40 import Ganeti.HTools.Utils
41 import Ganeti.HTools.Types
42
43 -- | Parse the basic specifications of an instance.
44 --
45 -- Instances in the cluster instance list and the instance in an
46 -- 'Allocate' request share some common properties, which are read by
47 -- this function.
48 parseBaseInstance :: String
49                   -> [(String, JSValue)]
50                   -> Result (String, Instance.Instance)
51 parseBaseInstance n a = do
52   disk <- fromObj "disk_space_total" a
53   mem <- fromObj "memory" a
54   vcpus <- fromObj "vcpus" a
55   tags <- fromObj "tags" a
56   let running = "running"
57   return (n, Instance.create n mem disk vcpus running tags 0 0)
58
59 -- | Parses an instance as found in the cluster instance listg.
60 parseInstance :: NameAssoc        -- ^ The node name-to-index association list
61               -> String           -- ^ The name of the instance
62               -> [(String, JSValue)] -- ^ The JSON object
63               -> Result (String, Instance.Instance)
64 parseInstance ktn n a = do
65   base <- parseBaseInstance n a
66   nodes <- fromObj "nodes" a
67   pnode <- if null nodes
68            then Bad $ "empty node list for instance " ++ n
69            else readEitherString $ head nodes
70   pidx <- lookupNode ktn n pnode
71   let snodes = tail nodes
72   sidx <- (if null snodes then return Node.noSecondary
73            else readEitherString (head snodes) >>= lookupNode ktn n)
74   return (n, Instance.setBoth (snd base) pidx sidx)
75
76 -- | Parses a node as found in the cluster node list.
77 parseNode :: String           -- ^ The node's name
78           -> [(String, JSValue)] -- ^ The JSON object
79           -> Result (String, Node.Node)
80 parseNode n a = do
81   offline <- fromObj "offline" a
82   drained <- fromObj "drained" a
83   node <- (if offline || drained
84            then return $ Node.create n 0 0 0 0 0 0 True
85            else do
86              mtotal <- fromObj "total_memory" a
87              mnode  <- fromObj "reserved_memory" a
88              mfree  <- fromObj "free_memory"  a
89              dtotal <- fromObj "total_disk"   a
90              dfree  <- fromObj "free_disk"    a
91              ctotal <- fromObj "total_cpus"   a
92              return $ Node.create n mtotal mnode mfree
93                     dtotal dfree ctotal False)
94   return (n, node)
95
96 -- | Top-level parser.
97 parseData :: String         -- ^ The JSON message as received from Ganeti
98           -> Result Request -- ^ A (possible valid) request
99 parseData body = do
100   decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body)
101   let obj = fromJSObject decoded
102   -- request parser
103   request <- liftM fromJSObject (fromObj "request" obj)
104   -- existing node parsing
105   nlist <- liftM fromJSObject (fromObj "nodes" obj)
106   nobj <- mapM (\(x,y) -> asJSObject y >>= parseNode x . fromJSObject) nlist
107   let (ktn, nl) = assignIndices nobj
108   -- existing instance parsing
109   ilist <- fromObj "instances" obj
110   let idata = fromJSObject ilist
111   iobj <- mapM (\(x,y) ->
112                     asJSObject y >>= parseInstance ktn x . fromJSObject) idata
113   let (kti, il) = assignIndices iobj
114   -- cluster tags
115   ctags <- fromObj "cluster_tags" obj
116   (map_n, map_i, ptags) <- mergeData [] [] [] (nl, il, ctags)
117   optype <- fromObj "type" request
118   rqtype <-
119       case optype of
120         "allocate" ->
121             do
122               rname <- fromObj "name" request
123               req_nodes <- fromObj "required_nodes" request
124               inew <- parseBaseInstance rname request
125               let io = snd inew
126               return $ Allocate io req_nodes
127         "relocate" ->
128             do
129               rname <- fromObj "name" request
130               ridx <- lookupInstance kti rname
131               req_nodes <- fromObj "required_nodes" request
132               ex_nodes <- fromObj "relocate_from" request
133               ex_idex <- mapM (Container.findByName map_n) ex_nodes
134               return $ Relocate ridx req_nodes (map Node.idx ex_idex)
135         "multi-evacuate" ->
136             do
137               ex_names <- fromObj "evac_nodes" request
138               ex_nodes <- mapM (Container.findByName map_n) ex_names
139               let ex_ndx = map Node.idx ex_nodes
140               return $ Evacuate ex_ndx
141         other -> fail ("Invalid request type '" ++ other ++ "'")
142   return $ Request rqtype map_n map_i ptags
143
144 -- | Format the result
145 formatRVal :: RqType -> [Node.AllocElement] -> JSValue
146 formatRVal _ [] = JSArray []
147
148 formatRVal (Evacuate _) elems =
149     let sols = map (\(_, inst, nl) -> Instance.name inst : map Node.name nl)
150                elems
151         jsols = map (JSArray . map (JSString . toJSString)) sols
152     in JSArray jsols
153
154 formatRVal _ elems =
155     let (_, _, nodes) = head elems
156         nodes' = map Node.name nodes
157     in JSArray $ map (JSString . toJSString) nodes'
158
159 -- | Formats the response into a valid IAllocator response message.
160 formatResponse :: Bool     -- ^ Whether the request was successful
161                -> String   -- ^ Information text
162                -> RqType   -- ^ Request type
163                -> [Node.AllocElement] -- ^ The resulting allocations
164                -> String   -- ^ The JSON-formatted message
165 formatResponse success info rq elems =
166     let
167         e_success = ("success", JSBool success)
168         e_info = ("info", JSString . toJSString $ info)
169         e_nodes = ("nodes", formatRVal rq elems)
170     in encodeStrict $ makeObj [e_success, e_info, e_nodes]