Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / HTools / Rapi.hs @ 4cd79ca8

History | View | Annotate | Download (8.7 kB)

1
{-| Implementation of the RAPI client interface.
2

    
3
-}
4

    
5
{-
6

    
7
Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
8

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

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

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

    
24
-}
25

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

    
28
module Ganeti.HTools.Rapi
29
  ( loadData
30
  , parseData
31
  ) where
32

    
33
import Control.Exception
34
import Data.List (isPrefixOf)
35
import Data.Maybe (fromMaybe)
36
#ifndef NO_CURL
37
import Network.Curl
38
import Network.Curl.Types ()
39
#endif
40
import Control.Monad
41
import Prelude hiding (catch)
42
import Text.JSON (JSObject, fromJSObject, decodeStrict)
43
import Text.JSON.Types (JSValue(..))
44
import Text.Printf (printf)
45
import System.FilePath
46

    
47
import Ganeti.HTools.Loader
48
import Ganeti.HTools.Types
49
import Ganeti.JSON
50
import qualified Ganeti.HTools.Group as Group
51
import qualified Ganeti.HTools.Node as Node
52
import qualified Ganeti.HTools.Instance as Instance
53
import qualified Ganeti.Constants as C
54

    
55
{-# ANN module "HLint: ignore Eta reduce" #-}
56

    
57
-- | File method prefix.
58
filePrefix :: String
59
filePrefix = "file://"
60

    
61
-- | Read an URL via curl and return the body if successful.
62
getUrl :: (Monad m) => String -> IO (m String)
63

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

    
67
#else
68

    
69
-- | Connection timeout (when using non-file methods).
70
connTimeout :: Long
71
connTimeout = 15
72

    
73
-- | The default timeout for queries (when using non-file methods).
74
queryTimeout :: Long
75
queryTimeout = 60
76

    
77
-- | The curl options we use.
78
curlOpts :: [CurlOption]
79
curlOpts = [ CurlSSLVerifyPeer False
80
           , CurlSSLVerifyHost 0
81
           , CurlTimeout queryTimeout
82
           , CurlConnectTimeout connTimeout
83
           ]
84

    
85
getUrl url = do
86
  (code, !body) <- curlGetString url curlOpts
87
  return (case code of
88
            CurlOK -> return body
89
            _ -> fail $ printf "Curl error for '%s', error %s"
90
                 url (show code))
91
#endif
92

    
93
-- | Helper to convert I/O errors in 'Bad' values.
94
ioErrToResult :: IO a -> IO (Result a)
95
ioErrToResult ioaction =
96
  catch (liftM Ok ioaction)
97
        (\e -> return . Bad . show $ (e::IOException))
98

    
99
-- | Append the default port if not passed in.
100
formatHost :: String -> String
101
formatHost master =
102
  if ':' `elem` master
103
    then  master
104
    else "https://" ++ master ++ ":" ++ show C.defaultRapiPort
105

    
106
-- | Parse a instance list in JSON format.
107
getInstances :: NameAssoc
108
             -> String
109
             -> Result [(String, Instance.Instance)]
110
getInstances ktn body =
111
  loadJSArray "Parsing instance data" body >>=
112
  mapM (parseInstance ktn . fromJSObject)
113

    
114
-- | Parse a node list in JSON format.
115
getNodes :: NameAssoc -> String -> Result [(String, Node.Node)]
116
getNodes ktg body = loadJSArray "Parsing node data" body >>=
117
                    mapM (parseNode ktg . fromJSObject)
118

    
119
-- | Parse a group list in JSON format.
120
getGroups :: String -> Result [(String, Group.Group)]
121
getGroups body = loadJSArray "Parsing group data" body >>=
122
                 mapM (parseGroup . fromJSObject)
123

    
124
-- | Construct an instance from a JSON object.
125
parseInstance :: NameAssoc
126
              -> JSRecord
127
              -> Result (String, Instance.Instance)
128
parseInstance ktn a = do
129
  name <- tryFromObj "Parsing new instance" a "name"
130
  let owner_name = "Instance '" ++ name ++ "', error while parsing data"
131
  let extract s x = tryFromObj owner_name x s
132
  disk <- extract "disk_usage" a
133
  beparams <- liftM fromJSObject (extract "beparams" a)
134
  omem <- extract "oper_ram" a
135
  mem <- case omem of
136
           JSRational _ _ -> annotateResult owner_name (fromJVal omem)
137
           _ -> extract "memory" beparams `mplus` extract "maxmem" beparams
138
  vcpus <- extract "vcpus" beparams
139
  pnode <- extract "pnode" a >>= lookupNode ktn name
140
  snodes <- extract "snodes" a
141
  snode <- if null snodes
142
             then return Node.noSecondary
143
             else readEitherString (head snodes) >>= lookupNode ktn name
144
  running <- extract "status" a
145
  tags <- extract "tags" a
146
  auto_balance <- extract "auto_balance" beparams
147
  dt <- extract "disk_template" a
148
  su <- extract "spindle_use" beparams
149
  let inst = Instance.create name mem disk vcpus running tags
150
             auto_balance pnode snode dt su
151
  return (name, inst)
152

    
153
-- | Construct a node from a JSON object.
154
parseNode :: NameAssoc -> JSRecord -> Result (String, Node.Node)
155
parseNode ktg a = do
156
  name <- tryFromObj "Parsing new node" a "name"
157
  let desc = "Node '" ++ name ++ "', error while parsing data"
158
      extract s = tryFromObj desc a s
159
  offline <- extract "offline"
160
  drained <- extract "drained"
161
  vm_cap  <- annotateResult desc $ maybeFromObj a "vm_capable"
162
  let vm_cap' = fromMaybe True vm_cap
163
  ndparams <- extract "ndparams" >>= asJSObject
164
  spindles <- tryFromObj desc (fromJSObject ndparams) "spindle_count"
165
  guuid   <- annotateResult desc $ maybeFromObj a "group.uuid"
166
  guuid' <-  lookupGroup ktg name (fromMaybe defaultGroupID guuid)
167
  node <- if offline || drained || not vm_cap'
168
            then return $ Node.create name 0 0 0 0 0 0 True 0 guuid'
169
            else do
170
              mtotal  <- extract "mtotal"
171
              mnode   <- extract "mnode"
172
              mfree   <- extract "mfree"
173
              dtotal  <- extract "dtotal"
174
              dfree   <- extract "dfree"
175
              ctotal  <- extract "ctotal"
176
              return $ Node.create name mtotal mnode mfree
177
                     dtotal dfree ctotal False spindles guuid'
178
  return (name, node)
179

    
180
-- | Construct a group from a JSON object.
181
parseGroup :: JSRecord -> Result (String, Group.Group)
182
parseGroup a = do
183
  name <- tryFromObj "Parsing new group" a "name"
184
  let extract s = tryFromObj ("Group '" ++ name ++ "'") a s
185
  uuid <- extract "uuid"
186
  apol <- extract "alloc_policy"
187
  ipol <- extract "ipolicy"
188
  return (uuid, Group.create name uuid apol ipol)
189

    
190
-- | Parse cluster data from the info resource.
191
parseCluster :: JSObject JSValue -> Result ([String], IPolicy)
192
parseCluster obj = do
193
  let obj' = fromJSObject obj
194
      extract s = tryFromObj "Parsing cluster data" obj' s
195
  tags <- extract "tags"
196
  ipolicy <- extract "ipolicy"
197
  return (tags, ipolicy)
198

    
199
-- | Loads the raw cluster data from an URL.
200
readDataHttp :: String -- ^ Cluster or URL to use as source
201
             -> IO (Result String, Result String, Result String, Result String)
202
readDataHttp master = do
203
  let url = formatHost master
204
  group_body <- getUrl $ printf "%s/2/groups?bulk=1" url
205
  node_body <- getUrl $ printf "%s/2/nodes?bulk=1" url
206
  inst_body <- getUrl $ printf "%s/2/instances?bulk=1" url
207
  info_body <- getUrl $ printf "%s/2/info" url
208
  return (group_body, node_body, inst_body, info_body)
209

    
210
-- | Loads the raw cluster data from the filesystem.
211
readDataFile:: String -- ^ Path to the directory containing the files
212
             -> IO (Result String, Result String, Result String, Result String)
213
readDataFile path = do
214
  group_body <- ioErrToResult . readFile $ path </> "groups.json"
215
  node_body <- ioErrToResult . readFile $ path </> "nodes.json"
216
  inst_body <- ioErrToResult . readFile $ path </> "instances.json"
217
  info_body <- ioErrToResult . readFile $ path </> "info.json"
218
  return (group_body, node_body, inst_body, info_body)
219

    
220
-- | Loads data via either 'readDataFile' or 'readDataHttp'.
221
readData :: String -- ^ URL to use as source
222
         -> IO (Result String, Result String, Result String, Result String)
223
readData url =
224
  if filePrefix `isPrefixOf` url
225
    then readDataFile (drop (length filePrefix) url)
226
    else readDataHttp url
227

    
228
-- | Builds the cluster data from the raw Rapi content.
229
parseData :: (Result String, Result String, Result String, Result String)
230
          -> Result ClusterData
231
parseData (group_body, node_body, inst_body, info_body) = do
232
  group_data <- group_body >>= getGroups
233
  let (group_names, group_idx) = assignIndices group_data
234
  node_data <- node_body >>= getNodes group_names
235
  let (node_names, node_idx) = assignIndices node_data
236
  inst_data <- inst_body >>= getInstances node_names
237
  let (_, inst_idx) = assignIndices inst_data
238
  (tags, ipolicy) <- info_body >>=
239
                     (fromJResult "Parsing cluster info" . decodeStrict) >>=
240
                     parseCluster
241
  return (ClusterData group_idx node_idx inst_idx tags ipolicy)
242

    
243
-- | Top level function for data loading.
244
loadData :: String -- ^ Cluster or URL to use as source
245
         -> IO (Result ClusterData)
246
loadData = fmap parseData . readData