Statistics
| Branch: | Tag: | Revision:

root / Ganeti / HTools / IAlloc.hs @ 5aa48dbe

History | View | Annotate | Download (3.7 kB)

1
{-| Implementation of the iallocator interface.
2

    
3
-}
4

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

    
11
import Data.Either ()
12
import Data.Maybe
13
import Control.Monad
14
import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray),
15
                  makeObj, encodeStrict, decodeStrict,
16
                  fromJSObject, toJSString)
17
import Text.Printf (printf)
18
import Ganeti.HTools.Utils
19
import qualified Ganeti.HTools.Node as Node
20
import qualified Ganeti.HTools.Instance as Instance
21

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

    
27
data Request
28
    = RqAlloc String String String
29
    | RqReloc String String String
30

    
31
parseInstance :: String -> JSObject JSValue -> Result String
32
parseInstance n a =
33
    let name = Ok n
34
        disk = case getIntElement "disk_usage" a of
35
                 Bad _ -> let all_d = getListElement "disks" a >>= asObjectList
36
                              szd = all_d >>=
37
                                    (sequence .
38
                                     map (getIntElement "size"))
39
                              sze = liftM (map (+128)) szd
40
                              szf = liftM sum sze
41
                           in szf
42
                 x@(Ok _) -> x
43
        nodes = getListElement "nodes" a
44
        pnode = liftM head nodes >>= readEitherString
45
        snode = liftM (head . tail) nodes >>= readEitherString
46
        mem = getIntElement "memory" a
47
        running = Ok "running" --getStringElement "status" a
48
    in
49
      name |+ (show `liftM` mem) |+
50
              (show `liftM` disk) |+ running |+ pnode |+ snode
51

    
52
parseNode :: String -> JSObject JSValue -> Result String
53
parseNode n a =
54
    let name = Ok n
55
        mtotal = getIntElement "total_memory" a
56
        mnode = getIntElement "reserved_memory" a
57
        mfree = getIntElement "free_memory" a
58
        dtotal = getIntElement "total_disk" a
59
        dfree = getIntElement "free_disk" a
60
    in name |+ (show `liftM` mtotal) |+
61
              (show `liftM` mnode) |+
62
              (show `liftM` mfree) |+
63
              (show `liftM` dtotal) |+
64
              (show `liftM` dfree)
65

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

    
73
parseData :: String -> Result Request
74
parseData body =
75
    do
76
      decoded <- fromJResult $ decodeStrict body
77
      let obj = decoded -- decoded `combineEithers` fromJSObject
78
        -- request parser
79
      request <- getObjectElement "request" obj
80
      rname <- getStringElement "name" request
81
      rtype <-  getStringElement "type" request >>= validateRequest
82
      inew <- (\x -> if x == Allocate then parseInstance rname request
83
                     else Ok "") rtype
84
      -- existing intstance parsing
85
      ilist <- getObjectElement "instances" obj
86
      let idata = fromJSObject ilist
87
      iobj <- (sequence . map (\(x,y) -> asJSObject y >>= parseInstance x))
88
              idata
89
      let ilines = unlines iobj
90
      -- existing node parsing
91
      nlist <- getObjectElement "nodes" obj
92
      let ndata = fromJSObject nlist
93
      nobj <- (sequence . map (\(x,y) -> asJSObject y >>= parseNode x))
94
              ndata
95
      let nlines = unlines nobj
96
      return $ (\ r nl il inew rnam ->
97
                    case r of
98
                      Allocate -> RqAlloc inew nl il
99
                      Relocate -> RqReloc rnam nl il)
100
                 rtype nlines ilines inew rname
101

    
102

    
103
formatResponse :: Bool -> String -> [String] -> String
104
formatResponse success info nodes =
105
    let
106
        e_success = ("success", JSBool success)
107
        e_info = ("info", JSString . toJSString $ info)
108
        e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes)
109
    in encodeStrict $ makeObj [e_success, e_info, e_nodes]