Statistics
| Branch: | Tag: | Revision:

root / Ganeti / HTools / IAlloc.hs @ 608efcce

History | View | Annotate | Download (4.2 kB)

1
{-| Implementation of the iallocator interface.
2

    
3
-}
4

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

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

    
27
data RqType
28
    = Allocate Instance.Instance Int
29
    | Relocate Idx Int [Ndx]
30
    deriving (Show)
31

    
32
data Request = Request RqType Node.List Instance.List String
33
    deriving (Show)
34

    
35
parseBaseInstance :: String
36
                  -> JSObject JSValue
37
                  -> Result (String, Instance.Instance)
38
parseBaseInstance n a = do
39
  disk <- case fromObj "disk_usage" a of
40
            Bad _ -> do
41
                all_d <- fromObj "disks" a >>= asObjectList
42
                szd <- mapM (fromObj "size") all_d
43
                let sze = map (+128) szd
44
                    szf = (sum sze)::Int
45
                return szf
46
            x@(Ok _) -> x
47
  mem <- fromObj "memory" a
48
  let running = "running"
49
  return $ (n, Instance.create n mem disk running 0 0)
50

    
51
parseInstance :: NameAssoc
52
              -> String
53
              -> JSObject JSValue
54
              -> Result (String, Instance.Instance)
55
parseInstance ktn n a = do
56
    base <- parseBaseInstance n a
57
    nodes <- fromObj "nodes" a
58
    pnode <- readEitherString $ head nodes
59
    pidx <- lookupNode ktn n pnode
60
    let snodes = tail nodes
61
    sidx <- (if null snodes then return Node.noSecondary
62
             else (readEitherString $ head snodes) >>= lookupNode ktn n)
63
    return (n, Instance.setBoth (snd base) pidx sidx)
64

    
65
parseNode :: String -> JSObject JSValue -> Result (String, Node.Node)
66
parseNode n a = do
67
    let name = n
68
    offline <- fromObj "offline" a
69
    drained <- fromObj "drained" a
70
    node <- (case offline of
71
               True -> return $ Node.create name 0 0 0 0 0 True
72
               _ -> do
73
                 mtotal <- fromObj "total_memory" a
74
                 mnode <- fromObj "reserved_memory" a
75
                 mfree <- fromObj "free_memory" a
76
                 dtotal <- fromObj "total_disk" a
77
                 dfree <- fromObj "free_disk" a
78
                 return $ Node.create n mtotal mnode mfree
79
                        dtotal dfree (offline || drained))
80
    return (name, node)
81

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

    
119
formatResponse :: Bool -> String -> [String] -> String
120
formatResponse success info nodes =
121
    let
122
        e_success = ("success", JSBool success)
123
        e_info = ("info", JSString . toJSString $ info)
124
        e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes)
125
    in encodeStrict $ makeObj [e_success, e_info, e_nodes]