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

-}

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

import Data.Either ()
import Data.Maybe
import Control.Monad
14
15
16
import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray),
                  makeObj, encodeStrict, decodeStrict,
                  fromJSObject, toJSString)
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
30
31
data Request
    = RqAlloc String String String
    | RqReloc String String String

parseInstance :: String -> JSObject JSValue -> Result String
Iustin Pop's avatar
Iustin Pop committed
32
parseInstance n a =
33
    let name = Ok n
34
        disk = case getIntElement "disk_usage" a of
35
36
37
38
39
40
                 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
41
                           in szf
42
                 x@(Ok _) -> x
Iustin Pop's avatar
Iustin Pop committed
43
        nodes = getListElement "nodes" a
44
45
        pnode = liftM head nodes >>= readEitherString
        snode = liftM (head . tail) nodes >>= readEitherString
Iustin Pop's avatar
Iustin Pop committed
46
        mem = getIntElement "memory" a
47
        running = Ok "running" --getStringElement "status" a
48
    in
49
50
      name |+ (show `liftM` mem) |+
              (show `liftM` disk) |+ running |+ pnode |+ snode
51

52
parseNode :: String -> JSObject JSValue -> Result String
Iustin Pop's avatar
Iustin Pop committed
53
parseNode n a =
54
    let name = Ok n
Iustin Pop's avatar
Iustin Pop committed
55
56
57
58
59
        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
60
61
62
63
64
    in name |+ (show `liftM` mtotal) |+
              (show `liftM` mnode) |+
              (show `liftM` mfree) |+
              (show `liftM` dtotal) |+
              (show `liftM` dfree)
65

66
validateRequest :: String -> Result RqType
67
68
validateRequest rq =
    case rq of
69
70
71
      "allocate" -> Ok Allocate
      "relocate" -> Ok Relocate
      _ -> Bad ("Invalid request type '" ++ rq ++ "'")
72

73
parseData :: String -> Result Request
Iustin Pop's avatar
Iustin Pop committed
74
parseData body =
75
76
77
    do
      decoded <- fromJResult $ decodeStrict body
      let obj = decoded -- decoded `combineEithers` fromJSObject
78
        -- request parser
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
      request <- getObjectElement "request" obj
      rname <- getStringElement "name" request
      rtype <-  getStringElement "type" request >>= validateRequest
      inew <- (\x -> if x == Allocate then parseInstance rname request
                     else Ok "") rtype
      -- existing intstance parsing
      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

102
103
104
105
106
107
108
109

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]