IAlloc.hs 4.18 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
    ) where

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

26
data RqType
27
28
    = Allocate Instance.Instance Int
    | Relocate Int Int [Int]
Iustin Pop's avatar
Iustin Pop committed
29
    deriving (Show)
30

31
data Request = Request RqType NodeList InstanceList String
Iustin Pop's avatar
Iustin Pop committed
32
    deriving (Show)
33

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

Iustin Pop's avatar
Iustin Pop committed
50
51
52
53
54
parseInstance :: NameAssoc
              -> String
              -> JSObject JSValue
              -> Result (String, Instance.Instance)
parseInstance ktn n a = do
Iustin Pop's avatar
Iustin Pop committed
55
    base <- parseBaseInstance n a
Iustin Pop's avatar
Iustin Pop committed
56
57
58
    nodes <- fromObj "nodes" a
    pnode <- readEitherString $ head nodes
    pidx <- lookupNode ktn n pnode
59
60
61
    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
62
    return (n, Instance.setBoth (snd base) pidx sidx)
Iustin Pop's avatar
Iustin Pop committed
63

Iustin Pop's avatar
Iustin Pop committed
64
65
66
67
parseNode :: String -> JSObject JSValue -> Result (String, Node.Node)
parseNode n a = do
    let name = n
    offline <- fromObj "offline" a
68
    drained <- fromObj "drained" a
69
70
71
72
73
74
75
76
77
78
79
    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)
80

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

118
119
120
121
122
123
124
formatResponse :: Bool -> String -> [String] -> String
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]