Rapi.hs 6.65 KB
Newer Older
1
2
3
4
{-| Implementation of the RAPI client interface.

-}

Iustin Pop's avatar
Iustin Pop committed
5
6
{-

7
Copyright (C) 2009, 2010, 2011 Google Inc.
Iustin Pop's avatar
Iustin Pop committed
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.

-}

26
{-# LANGUAGE BangPatterns, CPP #-}
27

28
module Ganeti.HTools.Rapi
Iustin Pop's avatar
Iustin Pop committed
29
    (
Iustin Pop's avatar
Iustin Pop committed
30
      loadData
31
    , parseData
Iustin Pop's avatar
Iustin Pop committed
32
    ) where
33

34
import Data.Maybe (fromMaybe)
35
#ifndef NO_CURL
36
import Network.Curl
37
import Network.Curl.Types ()
38
#endif
39
import Control.Monad
40
import Text.JSON (JSObject, fromJSObject, decodeStrict)
41
import Text.JSON.Types (JSValue(..))
42
import Text.Printf (printf)
Iustin Pop's avatar
Iustin Pop committed
43

44
import Ganeti.HTools.Utils
Iustin Pop's avatar
Iustin Pop committed
45
import Ganeti.HTools.Loader
Iustin Pop's avatar
Iustin Pop committed
46
import Ganeti.HTools.Types
47
import qualified Ganeti.HTools.Group as Group
Iustin Pop's avatar
Iustin Pop committed
48
49
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Instance as Instance
Iustin Pop's avatar
Iustin Pop committed
50
import qualified Ganeti.Constants as C
51

52
53
54
55
56
57
58
59
-- | Read an URL via curl and return the body if successful.
getUrl :: (Monad m) => String -> IO (m String)

#ifdef NO_CURL
getUrl _ = return $ fail "RAPI/curl backend disabled at compile time"

#else

60
-- | The curl options we use.
61
62
63
64
65
66
67
curlOpts :: [CurlOption]
curlOpts = [ CurlSSLVerifyPeer False
           , CurlSSLVerifyHost 0
           , CurlTimeout (fromIntegral queryTimeout)
           , CurlConnectTimeout (fromIntegral connTimeout)
           ]

68
getUrl url = do
69
  (code, !body) <- curlGetString url curlOpts
70
  return (case code of
Iustin Pop's avatar
Iustin Pop committed
71
72
            CurlOK -> return body
            _ -> fail $ printf "Curl error for '%s', error %s"
Iustin Pop's avatar
Iustin Pop committed
73
                 url (show code))
74
#endif
Iustin Pop's avatar
Iustin Pop committed
75

Iustin Pop's avatar
Iustin Pop committed
76
-- | Append the default port if not passed in.
77
78
formatHost :: String -> String
formatHost master =
79
    if ':' `elem` master then  master
Iustin Pop's avatar
Iustin Pop committed
80
    else "https://" ++ master ++ ":" ++ show C.defaultRapiPort
81

Iustin Pop's avatar
Iustin Pop committed
82
-- | Parse a instance list in JSON format.
Iustin Pop's avatar
Iustin Pop committed
83
84
85
getInstances :: NameAssoc
             -> String
             -> Result [(String, Instance.Instance)]
86
getInstances ktn body =
Iustin Pop's avatar
Iustin Pop committed
87
88
    loadJSArray "Parsing instance data" body >>=
    mapM (parseInstance ktn . fromJSObject)
89

Iustin Pop's avatar
Iustin Pop committed
90
-- | Parse a node list in JSON format.
Iustin Pop's avatar
Iustin Pop committed
91
92
93
getNodes :: NameAssoc -> String -> Result [(String, Node.Node)]
getNodes ktg body = loadJSArray "Parsing node data" body >>=
                mapM (parseNode ktg . fromJSObject)
94

95
96
97
98
99
-- | Parse a group list in JSON format.
getGroups :: String -> Result [(String, Group.Group)]
getGroups body = loadJSArray "Parsing group data" body >>=
                mapM (parseGroup . fromJSObject)

Iustin Pop's avatar
Iustin Pop committed
100
-- | Construct an instance from a JSON object.
101
parseInstance :: NameAssoc
102
              -> JSRecord
Iustin Pop's avatar
Iustin Pop committed
103
104
              -> Result (String, Instance.Instance)
parseInstance ktn a = do
105
  name <- tryFromObj "Parsing new instance" a "name"
106
  let owner_name = "Instance '" ++ name ++ "', error while parsing data"
107
  let extract s x = tryFromObj owner_name x s
108
109
  disk <- extract "disk_usage" a
  beparams <- liftM fromJSObject (extract "beparams" a)
110
111
112
113
  omem <- extract "oper_ram" a
  mem <- (case omem of
            JSRational _ _ -> annotateResult owner_name (fromJVal omem)
            _ -> extract "memory" beparams)
114
115
116
  vcpus <- extract "vcpus" beparams
  pnode <- extract "pnode" a >>= lookupNode ktn name
  snodes <- extract "snodes" a
Iustin Pop's avatar
Iustin Pop committed
117
118
  snode <- (if null snodes then return Node.noSecondary
            else readEitherString (head snodes) >>= lookupNode ktn name)
119
  running <- extract "status" a
Iustin Pop's avatar
Iustin Pop committed
120
  tags <- extract "tags" a
Iustin Pop's avatar
Iustin Pop committed
121
122
123
  auto_balance <- extract "auto_balance" beparams
  let inst = Instance.create name mem disk vcpus running tags
             auto_balance pnode snode
Iustin Pop's avatar
Iustin Pop committed
124
  return (name, inst)
125

Iustin Pop's avatar
Iustin Pop committed
126
-- | Construct a node from a JSON object.
127
parseNode :: NameAssoc -> JSRecord -> Result (String, Node.Node)
Iustin Pop's avatar
Iustin Pop committed
128
parseNode ktg a = do
129
  name <- tryFromObj "Parsing new node" a "name"
130
  let desc = "Node '" ++ name ++ "', error while parsing data"
131
      extract s = tryFromObj desc a s
132
  offline <- extract "offline"
133
  drained <- extract "drained"
134
135
136
137
138
139
  vm_cap  <- annotateResult desc $ maybeFromObj a "vm_capable"
  let vm_cap' = fromMaybe True vm_cap
  guuid   <- annotateResult desc $ maybeFromObj a "group.uuid"
  guuid' <-  lookupGroup ktg name (fromMaybe defaultGroupID guuid)
  node <- (if offline || drained || not vm_cap'
           then return $ Node.create name 0 0 0 0 0 0 True guuid'
140
           else do
141
142
143
144
145
146
             mtotal  <- extract "mtotal"
             mnode   <- extract "mnode"
             mfree   <- extract "mfree"
             dtotal  <- extract "dtotal"
             dfree   <- extract "dfree"
             ctotal  <- extract "ctotal"
147
             return $ Node.create name mtotal mnode mfree
148
                    dtotal dfree ctotal False guuid')
149
  return (name, node)
Iustin Pop's avatar
Iustin Pop committed
150

151
-- | Construct a group from a JSON object.
152
parseGroup :: JSRecord -> Result (String, Group.Group)
153
154
155
156
parseGroup a = do
  name <- tryFromObj "Parsing new group" a "name"
  let extract s = tryFromObj ("Group '" ++ name ++ "'") a s
  uuid <- extract "uuid"
157
158
  apol <- extract "alloc_policy"
  return (uuid, Group.create name uuid apol)
159

160
161
-- | Loads the raw cluster data from an URL.
readData :: String -- ^ Cluster or URL to use as source
162
         -> IO (Result String, Result String, Result String, Result String)
163
readData master = do
Iustin Pop's avatar
Iustin Pop committed
164
  let url = formatHost master
165
  group_body <- getUrl $ printf "%s/2/groups?bulk=1" url
Iustin Pop's avatar
Iustin Pop committed
166
167
  node_body <- getUrl $ printf "%s/2/nodes?bulk=1" url
  inst_body <- getUrl $ printf "%s/2/instances?bulk=1" url
168
  tags_body <- getUrl $ printf "%s/2/tags" url
169
  return (group_body, node_body, inst_body, tags_body)
170

171
-- | Builds the cluster data from the raw Rapi content.
172
parseData :: (Result String, Result String, Result String, Result String)
173
          -> Result ClusterData
174
parseData (group_body, node_body, inst_body, tags_body) = do
175
  group_data <- group_body >>= getGroups
Iustin Pop's avatar
Iustin Pop committed
176
177
  let (group_names, group_idx) = assignIndices group_data
  node_data <- node_body >>= getNodes group_names
178
179
180
181
  let (node_names, node_idx) = assignIndices node_data
  inst_data <- inst_body >>= getInstances node_names
  let (_, inst_idx) = assignIndices inst_data
  tags_data <- tags_body >>= (fromJResult "Parsing tags data" . decodeStrict)
182
  return (ClusterData group_idx node_idx inst_idx tags_data)
183

184
-- | Top level function for data loading.
185
loadData :: String -- ^ Cluster or URL to use as source
186
         -> IO (Result ClusterData)
187
loadData = fmap parseData . readData