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

-}

module Ganeti.HTools.IAlloc
    (
      parseData
    , formatResponse
    ) where

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

24
data RqType
Iustin Pop's avatar
Iustin Pop committed
25
26
27
    = Allocate String Instance.Instance
    | Relocate Int
    deriving (Show)
28

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

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

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

Iustin Pop's avatar
Iustin Pop committed
61
62
63
64
65
66
67
68
69
70
parseNode :: String -> JSObject JSValue -> Result (String, Node.Node)
parseNode n a = do
    let name = n
    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
    offline <- fromObj "offline" a
    drained <- fromObj "offline" a
Iustin Pop's avatar
Iustin Pop committed
71
    return $ (name, Node.create n mtotal mnode mfree dtotal dfree
Iustin Pop's avatar
Iustin Pop committed
72
                      (offline || drained))
73

74
parseData :: String -> Result Request
Iustin Pop's avatar
Iustin Pop committed
75
76
77
78
79
80
81
82
83
84
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
85
  let (ktn, nl) = assignIndices nobj
Iustin Pop's avatar
Iustin Pop committed
86
87
88
89
  -- existing instance parsing
  ilist <- fromObj "instances" obj
  let idata = fromJSObject ilist
  iobj <- (mapM (\(x,y) -> asJSObject y >>= parseInstance ktn x)) idata
90
  let (kti, il) = assignIndices iobj
Iustin Pop's avatar
Iustin Pop committed
91
92
93
94
95
96
97
98
99
100
101
102
103
  optype <- fromObj "type" request
  rqtype <-
      case optype of
        "allocate" ->
            do
              inew <- parseBaseInstance rname request
              let (iname, io) = inew
              return $ Allocate iname io
        "relocate" ->
            do
              ridx <- lookupNode kti rname rname
              return $ Relocate ridx
        other -> fail $ ("Invalid request type '" ++ other ++ "'")
104
  (map_n, map_i, csf) <- mergeData (nl, il)
105
  return $ Request rqtype map_n map_i csf
106

107
108
109
110
111
112
113
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]