Statistics
| Branch: | Tag: | Revision:

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

History | View | Annotate | Download (3.7 kB)

1 43643696 Iustin Pop
{-| Implementation of the iallocator interface.
2 43643696 Iustin Pop
3 43643696 Iustin Pop
-}
4 43643696 Iustin Pop
5 43643696 Iustin Pop
module Ganeti.HTools.IAlloc
6 43643696 Iustin Pop
    (
7 43643696 Iustin Pop
      parseData
8 43643696 Iustin Pop
    , formatResponse
9 43643696 Iustin Pop
    ) where
10 43643696 Iustin Pop
11 43643696 Iustin Pop
import Data.Either ()
12 43643696 Iustin Pop
import Data.Maybe
13 43643696 Iustin Pop
import Control.Monad
14 942403e6 Iustin Pop
import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray),
15 942403e6 Iustin Pop
                  makeObj, encodeStrict, decodeStrict,
16 942403e6 Iustin Pop
                  fromJSObject, toJSString)
17 43643696 Iustin Pop
import Text.Printf (printf)
18 3f6af65c Iustin Pop
import Ganeti.HTools.Utils
19 942403e6 Iustin Pop
import qualified Ganeti.HTools.Node as Node
20 942403e6 Iustin Pop
import qualified Ganeti.HTools.Instance as Instance
21 43643696 Iustin Pop
22 144f190b Iustin Pop
data RqType
23 144f190b Iustin Pop
    = Allocate
24 144f190b Iustin Pop
    | Relocate
25 942403e6 Iustin Pop
    deriving (Eq, Show)
26 144f190b Iustin Pop
27 942403e6 Iustin Pop
data Request
28 942403e6 Iustin Pop
    = RqAlloc String String String
29 942403e6 Iustin Pop
    | RqReloc String String String
30 942403e6 Iustin Pop
31 942403e6 Iustin Pop
parseInstance :: String -> JSObject JSValue -> Result String
32 3f6af65c Iustin Pop
parseInstance n a =
33 942403e6 Iustin Pop
    let name = Ok n
34 43643696 Iustin Pop
        disk = case getIntElement "disk_usage" a of
35 942403e6 Iustin Pop
                 Bad _ -> let all_d = getListElement "disks" a >>= asObjectList
36 942403e6 Iustin Pop
                              szd = all_d >>=
37 942403e6 Iustin Pop
                                    (sequence .
38 942403e6 Iustin Pop
                                     map (getIntElement "size"))
39 942403e6 Iustin Pop
                              sze = liftM (map (+128)) szd
40 942403e6 Iustin Pop
                              szf = liftM sum sze
41 3f6af65c Iustin Pop
                           in szf
42 942403e6 Iustin Pop
                 x@(Ok _) -> x
43 3f6af65c Iustin Pop
        nodes = getListElement "nodes" a
44 942403e6 Iustin Pop
        pnode = liftM head nodes >>= readEitherString
45 942403e6 Iustin Pop
        snode = liftM (head . tail) nodes >>= readEitherString
46 3f6af65c Iustin Pop
        mem = getIntElement "memory" a
47 942403e6 Iustin Pop
        running = Ok "running" --getStringElement "status" a
48 43643696 Iustin Pop
    in
49 942403e6 Iustin Pop
      name |+ (show `liftM` mem) |+
50 942403e6 Iustin Pop
              (show `liftM` disk) |+ running |+ pnode |+ snode
51 43643696 Iustin Pop
52 942403e6 Iustin Pop
parseNode :: String -> JSObject JSValue -> Result String
53 3f6af65c Iustin Pop
parseNode n a =
54 942403e6 Iustin Pop
    let name = Ok n
55 3f6af65c Iustin Pop
        mtotal = getIntElement "total_memory" a
56 3f6af65c Iustin Pop
        mnode = getIntElement "reserved_memory" a
57 3f6af65c Iustin Pop
        mfree = getIntElement "free_memory" a
58 3f6af65c Iustin Pop
        dtotal = getIntElement "total_disk" a
59 3f6af65c Iustin Pop
        dfree = getIntElement "free_disk" a
60 942403e6 Iustin Pop
    in name |+ (show `liftM` mtotal) |+
61 942403e6 Iustin Pop
              (show `liftM` mnode) |+
62 942403e6 Iustin Pop
              (show `liftM` mfree) |+
63 942403e6 Iustin Pop
              (show `liftM` dtotal) |+
64 942403e6 Iustin Pop
              (show `liftM` dfree)
65 43643696 Iustin Pop
66 942403e6 Iustin Pop
validateRequest :: String -> Result RqType
67 144f190b Iustin Pop
validateRequest rq =
68 144f190b Iustin Pop
    case rq of
69 942403e6 Iustin Pop
      "allocate" -> Ok Allocate
70 942403e6 Iustin Pop
      "relocate" -> Ok Relocate
71 942403e6 Iustin Pop
      _ -> Bad ("Invalid request type '" ++ rq ++ "'")
72 144f190b Iustin Pop
73 942403e6 Iustin Pop
parseData :: String -> Result Request
74 3f6af65c Iustin Pop
parseData body =
75 942403e6 Iustin Pop
    do
76 942403e6 Iustin Pop
      decoded <- fromJResult $ decodeStrict body
77 942403e6 Iustin Pop
      let obj = decoded -- decoded `combineEithers` fromJSObject
78 144f190b Iustin Pop
        -- request parser
79 942403e6 Iustin Pop
      request <- getObjectElement "request" obj
80 942403e6 Iustin Pop
      rname <- getStringElement "name" request
81 942403e6 Iustin Pop
      rtype <-  getStringElement "type" request >>= validateRequest
82 942403e6 Iustin Pop
      inew <- (\x -> if x == Allocate then parseInstance rname request
83 942403e6 Iustin Pop
                     else Ok "") rtype
84 942403e6 Iustin Pop
      -- existing intstance parsing
85 942403e6 Iustin Pop
      ilist <- getObjectElement "instances" obj
86 942403e6 Iustin Pop
      let idata = fromJSObject ilist
87 942403e6 Iustin Pop
      iobj <- (sequence . map (\(x,y) -> asJSObject y >>= parseInstance x))
88 942403e6 Iustin Pop
              idata
89 942403e6 Iustin Pop
      let ilines = unlines iobj
90 942403e6 Iustin Pop
      -- existing node parsing
91 942403e6 Iustin Pop
      nlist <- getObjectElement "nodes" obj
92 942403e6 Iustin Pop
      let ndata = fromJSObject nlist
93 942403e6 Iustin Pop
      nobj <- (sequence . map (\(x,y) -> asJSObject y >>= parseNode x))
94 942403e6 Iustin Pop
              ndata
95 942403e6 Iustin Pop
      let nlines = unlines nobj
96 942403e6 Iustin Pop
      return $ (\ r nl il inew rnam ->
97 942403e6 Iustin Pop
                    case r of
98 942403e6 Iustin Pop
                      Allocate -> RqAlloc inew nl il
99 942403e6 Iustin Pop
                      Relocate -> RqReloc rnam nl il)
100 942403e6 Iustin Pop
                 rtype nlines ilines inew rname
101 942403e6 Iustin Pop
102 43643696 Iustin Pop
103 43643696 Iustin Pop
formatResponse :: Bool -> String -> [String] -> String
104 43643696 Iustin Pop
formatResponse success info nodes =
105 43643696 Iustin Pop
    let
106 43643696 Iustin Pop
        e_success = ("success", JSBool success)
107 43643696 Iustin Pop
        e_info = ("info", JSString . toJSString $ info)
108 43643696 Iustin Pop
        e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes)
109 43643696 Iustin Pop
    in encodeStrict $ makeObj [e_success, e_info, e_nodes]