IAlloc.hs 5.24 KB
Newer Older
1
2
3
4
5
6
7
8
{-| Implementation of the iallocator interface.

-}

module Ganeti.HTools.IAlloc
    (
      parseData
    , formatResponse
9
10
    , RqType(..)
    , Request(..)
11
12
13
14
    ) where

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

Iustin Pop's avatar
Iustin Pop committed
25
-- | The request type.
26
data RqType
Iustin Pop's avatar
Iustin Pop committed
27
28
29
    = Allocate Instance.Instance Int -- ^ A new instance allocation
    | Relocate Idx Int [Ndx]         -- ^ Move an instance to a new
                                     -- secondary node
Iustin Pop's avatar
Iustin Pop committed
30
    deriving (Show)
31

Iustin Pop's avatar
Iustin Pop committed
32
-- | A complete request, as received from Ganeti.
33
data Request = Request RqType Node.List Instance.List String
Iustin Pop's avatar
Iustin Pop committed
34
    deriving (Show)
35

Iustin Pop's avatar
Iustin Pop committed
36
37
38
39
40
-- | 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
41
42
43
44
45
46
47
48
49
50
51
52
53
54
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
55
  return $ (n, Instance.create n mem disk running 0 0)
Iustin Pop's avatar
Iustin Pop committed
56

Iustin Pop's avatar
Iustin Pop committed
57
58
59
60
-- | 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
61
62
              -> Result (String, Instance.Instance)
parseInstance ktn n a = do
Iustin Pop's avatar
Iustin Pop committed
63
    base <- parseBaseInstance n a
Iustin Pop's avatar
Iustin Pop committed
64
65
66
    nodes <- fromObj "nodes" a
    pnode <- readEitherString $ head nodes
    pidx <- lookupNode ktn n pnode
67
68
69
    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
70
    return (n, Instance.setBoth (snd base) pidx sidx)
Iustin Pop's avatar
Iustin Pop committed
71

Iustin Pop's avatar
Iustin Pop committed
72
73
74
75
-- | 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
76
77
78
parseNode n a = do
    let name = n
    offline <- fromObj "offline" a
79
    drained <- fromObj "drained" a
80
81
82
83
84
85
86
87
88
89
90
    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)
91

Iustin Pop's avatar
Iustin Pop committed
92
93
94
-- | 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
95
96
97
98
99
100
101
102
103
104
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
105
  let (ktn, nl) = assignIndices nobj
Iustin Pop's avatar
Iustin Pop committed
106
107
108
109
  -- existing instance parsing
  ilist <- fromObj "instances" obj
  let idata = fromJSObject ilist
  iobj <- (mapM (\(x,y) -> asJSObject y >>= parseInstance ktn x)) idata
110
  let (kti, il) = assignIndices iobj
111
112
  (map_n, map_i, csf) <- mergeData (nl, il)
  req_nodes <- fromObj "required_nodes" request
Iustin Pop's avatar
Iustin Pop committed
113
114
115
116
117
118
  optype <- fromObj "type" request
  rqtype <-
      case optype of
        "allocate" ->
            do
              inew <- parseBaseInstance rname request
119
120
              let io = snd inew
              return $ Allocate io req_nodes
Iustin Pop's avatar
Iustin Pop committed
121
122
        "relocate" ->
            do
123
              ridx <- lookupInstance kti rname
124
125
              ex_nodes <- fromObj "relocate_from" request
              let ex_nodes' = map (stripSuffix $ length csf) ex_nodes
126
              ex_idex <- mapM (Container.findByName map_n) ex_nodes'
127
              return $ Relocate ridx req_nodes ex_idex
Iustin Pop's avatar
Iustin Pop committed
128
        other -> fail $ ("Invalid request type '" ++ other ++ "'")
129
  return $ Request rqtype map_n map_i csf
130

Iustin Pop's avatar
Iustin Pop committed
131
132
133
134
135
-- | 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
136
137
138
139
140
141
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]