IAlloc.hs 4.83 KB
Newer Older
1
2
3
4
5
{-| Implementation of the iallocator interface.

-}

module Ganeti.HTools.IAlloc
6
    ( parseData
7
8
9
10
11
    , formatResponse
    ) where

import Data.Either ()
import Control.Monad
12
13
14
import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray),
                  makeObj, encodeStrict, decodeStrict,
                  fromJSObject, toJSString)
15
import qualified Ganeti.HTools.Container as Container
16
17
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Instance as Instance
Iustin Pop's avatar
Iustin Pop committed
18
19
20
import Ganeti.HTools.Loader
import Ganeti.HTools.Utils
import Ganeti.HTools.Types
21

Iustin Pop's avatar
Iustin Pop committed
22
23
24
25
26
-- | 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
27
28
29
30
31
32
33
34
35
36
37
38
39
40
parseBaseInstance :: String
                  -> JSObject JSValue
                  -> Result (String, Instance.Instance)
parseBaseInstance n a = do
  disk <- case fromObj "disk_usage" a of
            Bad _ -> do
                all_d <- fromObj "disks" a >>= asObjectList
                szd <- mapM (fromObj "size") all_d
                let sze = map (+128) szd
                    szf = (sum sze)::Int
                return szf
            x@(Ok _) -> x
  mem <- fromObj "memory" a
  let running = "running"
Iustin Pop's avatar
Iustin Pop committed
41
  return $ (n, Instance.create n mem disk running 0 0)
Iustin Pop's avatar
Iustin Pop committed
42

Iustin Pop's avatar
Iustin Pop committed
43
44
45
46
-- | Parses an instance as found in the cluster instance list.
parseInstance :: NameAssoc        -- ^ The node name-to-index association list
              -> String           -- ^ The name of the instance
              -> JSObject JSValue -- ^ The JSON object
Iustin Pop's avatar
Iustin Pop committed
47
48
              -> Result (String, Instance.Instance)
parseInstance ktn n a = do
Iustin Pop's avatar
Iustin Pop committed
49
    base <- parseBaseInstance n a
Iustin Pop's avatar
Iustin Pop committed
50
51
52
    nodes <- fromObj "nodes" a
    pnode <- readEitherString $ head nodes
    pidx <- lookupNode ktn n pnode
53
54
55
    let snodes = tail nodes
    sidx <- (if null snodes then return Node.noSecondary
             else (readEitherString $ head snodes) >>= lookupNode ktn n)
Iustin Pop's avatar
Iustin Pop committed
56
    return (n, Instance.setBoth (snd base) pidx sidx)
Iustin Pop's avatar
Iustin Pop committed
57

Iustin Pop's avatar
Iustin Pop committed
58
59
60
61
-- | Parses a node as found in the cluster node list.
parseNode :: String           -- ^ The node's name
          -> JSObject JSValue -- ^ The JSON object
          -> Result (String, Node.Node)
Iustin Pop's avatar
Iustin Pop committed
62
63
64
parseNode n a = do
    let name = n
    offline <- fromObj "offline" a
65
    drained <- fromObj "drained" a
66
67
68
69
70
71
72
73
74
75
76
    node <- (case offline of
               True -> return $ Node.create name 0 0 0 0 0 True
               _ -> 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
                 return $ Node.create n mtotal mnode mfree
                        dtotal dfree (offline || drained))
    return (name, node)
77

Iustin Pop's avatar
Iustin Pop committed
78
79
80
-- | 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
81
82
83
84
85
86
87
88
89
90
parseData body = do
  decoded <- fromJResult $ decodeStrict body
  let obj = decoded
  -- request parser
  request <- fromObj "request" obj
  rname <- fromObj "name" request
  -- existing node parsing
  nlist <- fromObj "nodes" obj
  let ndata = fromJSObject nlist
  nobj <- (mapM (\(x,y) -> asJSObject y >>= parseNode x)) ndata
91
  let (ktn, nl) = assignIndices nobj
Iustin Pop's avatar
Iustin Pop committed
92
93
94
95
  -- existing instance parsing
  ilist <- fromObj "instances" obj
  let idata = fromJSObject ilist
  iobj <- (mapM (\(x,y) -> asJSObject y >>= parseInstance ktn x)) idata
96
  let (kti, il) = assignIndices iobj
97
98
  (map_n, map_i, csf) <- mergeData (nl, il)
  req_nodes <- fromObj "required_nodes" request
Iustin Pop's avatar
Iustin Pop committed
99
100
101
102
103
104
  optype <- fromObj "type" request
  rqtype <-
      case optype of
        "allocate" ->
            do
              inew <- parseBaseInstance rname request
105
106
              let io = snd inew
              return $ Allocate io req_nodes
Iustin Pop's avatar
Iustin Pop committed
107
108
        "relocate" ->
            do
109
              ridx <- lookupInstance kti rname
110
111
              ex_nodes <- fromObj "relocate_from" request
              let ex_nodes' = map (stripSuffix $ length csf) ex_nodes
112
              ex_idex <- mapM (Container.findByName map_n) ex_nodes'
113
              return $ Relocate ridx req_nodes ex_idex
Iustin Pop's avatar
Iustin Pop committed
114
        other -> fail $ ("Invalid request type '" ++ other ++ "'")
115
  return $ Request rqtype map_n map_i csf
116

Iustin Pop's avatar
Iustin Pop committed
117
118
119
120
121
-- | Formats the response into a valid IAllocator response message.
formatResponse :: Bool     -- ^ Whether the request was successful
               -> String   -- ^ Information text
               -> [String] -- ^ The list of chosen nodes
               -> String   -- ^ The JSON-formatted message
122
123
124
125
126
127
formatResponse success info nodes =
    let
        e_success = ("success", JSBool success)
        e_info = ("info", JSString . toJSString $ info)
        e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes)
    in encodeStrict $ makeObj [e_success, e_info, e_nodes]