IAlloc.hs 4.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
    ) 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
import qualified Ganeti.HTools.Container as Container
21
22
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Instance as Instance
Iustin Pop's avatar
Iustin Pop committed
23
24
25
import Ganeti.HTools.Loader
import Ganeti.HTools.Utils
import Ganeti.HTools.Types
26

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

32
data Request = Request RqType Node.List Instance.List String
Iustin Pop's avatar
Iustin Pop committed
33
    deriving (Show)
34

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

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

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

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

119
120
121
122
123
124
125
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]