IAlloc.hs 3.88 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)
Iustin Pop's avatar
Iustin Pop committed
18
import Ganeti.HTools.Utils
19
20
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Instance as Instance
21

22
23
24
data RqType
    = Allocate
    | Relocate
25
    deriving (Eq, Show)
26

27
28
29
data Request
    = RqAlloc String String String
    | RqReloc String String String
Iustin Pop's avatar
Iustin Pop committed
30
    deriving (Show)
31

Iustin Pop's avatar
Iustin Pop committed
32
33
parseBaseInstance :: String -> JSObject JSValue -> Result String
parseBaseInstance n a =
34
    let name = Ok n
35
        disk = case getIntElement "disk_usage" a of
36
37
38
39
40
41
                 Bad _ -> let all_d = getListElement "disks" a >>= asObjectList
                              szd = all_d >>=
                                    (sequence .
                                     map (getIntElement "size"))
                              sze = liftM (map (+128)) szd
                              szf = liftM sum sze
Iustin Pop's avatar
Iustin Pop committed
42
                           in szf
43
                 x@(Ok _) -> x
Iustin Pop's avatar
Iustin Pop committed
44
        mem = getIntElement "memory" a
45
        running = Ok "running" --getStringElement "status" a
46
    in
47
      name |+ (show `liftM` mem) |+
Iustin Pop's avatar
Iustin Pop committed
48
49
50
51
52
53
54
55
56
57
58
              (show `liftM` disk) |+ running

parseInstance :: String -> JSObject JSValue -> Result String
parseInstance n a = do
    base <- parseBaseInstance n a
    let
        nodes = getListElement "nodes" a
        pnode = liftM head nodes >>= readEitherString
        snode = liftM (head . tail) nodes >>= readEitherString
    return base |+ pnode |+ snode

59

60
parseNode :: String -> JSObject JSValue -> Result String
Iustin Pop's avatar
Iustin Pop committed
61
parseNode n a =
62
    let name = Ok n
Iustin Pop's avatar
Iustin Pop committed
63
64
65
66
67
        mtotal = getIntElement "total_memory" a
        mnode = getIntElement "reserved_memory" a
        mfree = getIntElement "free_memory" a
        dtotal = getIntElement "total_disk" a
        dfree = getIntElement "free_disk" a
68
69
70
71
72
    in name |+ (show `liftM` mtotal) |+
              (show `liftM` mnode) |+
              (show `liftM` mfree) |+
              (show `liftM` dtotal) |+
              (show `liftM` dfree)
73

74
validateRequest :: String -> Result RqType
75
76
validateRequest rq =
    case rq of
77
78
79
      "allocate" -> Ok Allocate
      "relocate" -> Ok Relocate
      _ -> Bad ("Invalid request type '" ++ rq ++ "'")
80

81
parseData :: String -> Result Request
Iustin Pop's avatar
Iustin Pop committed
82
parseData body =
83
84
    do
      decoded <- fromJResult $ decodeStrict body
Iustin Pop's avatar
Iustin Pop committed
85
86
      let obj = decoded
      -- request parser
87
88
89
      request <- getObjectElement "request" obj
      rname <- getStringElement "name" request
      rtype <-  getStringElement "type" request >>= validateRequest
Iustin Pop's avatar
Iustin Pop committed
90
      inew <- (\x -> if x == Allocate then parseBaseInstance rname request
91
                     else Ok "") rtype
Iustin Pop's avatar
Iustin Pop committed
92
      -- existing instance parsing
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
      ilist <- getObjectElement "instances" obj
      let idata = fromJSObject ilist
      iobj <- (sequence . map (\(x,y) -> asJSObject y >>= parseInstance x))
              idata
      let ilines = unlines iobj
      -- existing node parsing
      nlist <- getObjectElement "nodes" obj
      let ndata = fromJSObject nlist
      nobj <- (sequence . map (\(x,y) -> asJSObject y >>= parseNode x))
              ndata
      let nlines = unlines nobj
      return $ (\ r nl il inew rnam ->
                    case r of
                      Allocate -> RqAlloc inew nl il
                      Relocate -> RqReloc rnam nl il)
                 rtype nlines ilines inew rname

110
111
112
113
114
115
116
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]