Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / HTools / Backend / Rapi.hs @ 3daaab6c

History | View | Annotate | Download (9.2 kB)

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

    
3
-}
4

    
5
{-
6

    
7
Copyright (C) 2009, 2010, 2011, 2012, 2013 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.Backend.Rapi
29
  ( loadData
30
  , parseData
31
  ) where
32

    
33
import Control.Exception
34
import Data.List (isPrefixOf)
35
import Data.Maybe (fromMaybe)
36
import Network.Curl
37
import Network.Curl.Types ()
38
import Control.Monad
39
import Text.JSON (JSObject, fromJSObject, decodeStrict)
40
import Text.JSON.Types (JSValue(..))
41
import Text.Printf (printf)
42
import System.FilePath
43

    
44
import Ganeti.BasicTypes
45
import Ganeti.HTools.Loader
46
import Ganeti.HTools.Types
47
import Ganeti.JSON
48
import qualified Ganeti.HTools.Group as Group
49
import qualified Ganeti.HTools.Node as Node
50
import qualified Ganeti.HTools.Instance as Instance
51
import qualified Ganeti.Constants as C
52

    
53
{-# ANN module "HLint: ignore Eta reduce" #-}
54

    
55
-- | File method prefix.
56
filePrefix :: String
57
filePrefix = "file://"
58

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

    
62
-- | Connection timeout (when using non-file methods).
63
connTimeout :: Long
64
connTimeout = 15
65

    
66
-- | The default timeout for queries (when using non-file methods).
67
queryTimeout :: Long
68
queryTimeout = 60
69

    
70
-- | The curl options we use.
71
curlOpts :: [CurlOption]
72
curlOpts = [ CurlSSLVerifyPeer False
73
           , CurlSSLVerifyHost 0
74
           , CurlTimeout queryTimeout
75
           , CurlConnectTimeout connTimeout
76
           ]
77

    
78
getUrl url = do
79
  (code, !body) <- curlGetString url curlOpts
80
  return (case code of
81
            CurlOK -> return body
82
            _ -> fail $ printf "Curl error for '%s', error %s"
83
                 url (show code))
84

    
85
-- | Helper to convert I/O errors in 'Bad' values.
86
ioErrToResult :: IO a -> IO (Result a)
87
ioErrToResult ioaction =
88
  Control.Exception.catch (liftM Ok ioaction)
89
    (\e -> return . Bad . show $ (e::IOException))
90

    
91
-- | Append the default port if not passed in.
92
formatHost :: String -> String
93
formatHost master =
94
  if ':' `elem` master
95
    then  master
96
    else "https://" ++ master ++ ":" ++ show C.defaultRapiPort
97

    
98
-- | Parse a instance list in JSON format.
99
getInstances :: NameAssoc
100
             -> String
101
             -> Result [(String, Instance.Instance)]
102
getInstances ktn body =
103
  loadJSArray "Parsing instance data" body >>=
104
  mapM (parseInstance ktn . fromJSObject)
105

    
106
-- | Parse a node list in JSON format.
107
getNodes :: NameAssoc -> String -> Result [(String, Node.Node)]
108
getNodes ktg body = loadJSArray "Parsing node data" body >>=
109
                    mapM (parseNode ktg . fromJSObject)
110

    
111
-- | Parse a group list in JSON format.
112
getGroups :: String -> Result [(String, Group.Group)]
113
getGroups body = loadJSArray "Parsing group data" body >>=
114
                 mapM (parseGroup . fromJSObject)
115

    
116
-- | Construct an instance from a JSON object.
117
parseInstance :: NameAssoc
118
              -> JSRecord
119
              -> Result (String, Instance.Instance)
120
parseInstance ktn a = do
121
  name <- tryFromObj "Parsing new instance" a "name"
122
  let owner_name = "Instance '" ++ name ++ "', error while parsing data"
123
  let extract s x = tryFromObj owner_name x s
124
  disk <- extract "disk_usage" a
125
  dsizes <- extract "disk.sizes" a
126
  dspindles <- tryArrayMaybeFromObj owner_name a "disk.spindles"
127
  beparams <- liftM fromJSObject (extract "beparams" a)
128
  omem <- extract "oper_ram" a
129
  mem <- case omem of
130
           JSRational _ _ -> annotateResult owner_name (fromJVal omem)
131
           _ -> extract "memory" beparams `mplus` extract "maxmem" beparams
132
  vcpus <- extract "vcpus" beparams
133
  pnode <- extract "pnode" a >>= lookupNode ktn name
134
  snodes <- extract "snodes" a
135
  snode <- case snodes of
136
             [] -> return Node.noSecondary
137
             x:_ -> readEitherString x >>= lookupNode ktn name
138
  running <- extract "status" a
139
  tags <- extract "tags" a
140
  auto_balance <- extract "auto_balance" beparams
141
  dt <- extract "disk_template" a
142
  su <- extract "spindle_use" beparams
143
  let disks = zipWith Instance.Disk dsizes dspindles
144
  let inst = Instance.create name mem disk disks vcpus running tags
145
             auto_balance pnode snode dt su []
146
  return (name, inst)
147

    
148
-- | Construct a node from a JSON object.
149
parseNode :: NameAssoc -> JSRecord -> Result (String, Node.Node)
150
parseNode ktg a = do
151
  name <- tryFromObj "Parsing new node" a "name"
152
  let desc = "Node '" ++ name ++ "', error while parsing data"
153
      extract key = tryFromObj desc a key
154
      extractDef def key = fromObjWithDefault a key def
155
  offline <- extract "offline"
156
  drained <- extract "drained"
157
  vm_cap  <- annotateResult desc $ maybeFromObj a "vm_capable"
158
  let vm_cap' = fromMaybe True vm_cap
159
  ndparams <- extract "ndparams" >>= asJSObject
160
  excl_stor <- tryFromObj desc (fromJSObject ndparams) "exclusive_storage"
161
  guuid   <- annotateResult desc $ maybeFromObj a "group.uuid"
162
  guuid' <-  lookupGroup ktg name (fromMaybe defaultGroupID guuid)
163
  let live = not offline && vm_cap'
164
      lvextract def = eitherLive live def . extract
165
      lvextractDef def = eitherLive live def . extractDef def
166
  sptotal <- if excl_stor
167
             then lvextract 0 "sptotal"
168
             else tryFromObj desc (fromJSObject ndparams) "spindle_count"
169
  spfree <- lvextractDef 0 "spfree"
170
  mtotal <- lvextract 0.0 "mtotal"
171
  mnode <- lvextract 0 "mnode"
172
  mfree <- lvextract 0 "mfree"
173
  dtotal <- lvextractDef 0.0 "dtotal"
174
  dfree <- lvextractDef 0 "dfree"
175
  ctotal <- lvextract 0.0 "ctotal"
176
  cnos <- lvextract 0 "cnos"
177
  tags <- extract "tags"
178
  let node = flip Node.setNodeTags tags $
179
             Node.create name mtotal mnode mfree dtotal dfree ctotal cnos
180
             (not live || drained) sptotal spfree guuid' excl_stor
181
  return (name, node)
182

    
183
-- | Construct a group from a JSON object.
184
parseGroup :: JSRecord -> Result (String, Group.Group)
185
parseGroup a = do
186
  name <- tryFromObj "Parsing new group" a "name"
187
  let extract s = tryFromObj ("Group '" ++ name ++ "'") a s
188
  uuid <- extract "uuid"
189
  apol <- extract "alloc_policy"
190
  ipol <- extract "ipolicy"
191
  tags <- extract "tags"
192
  -- TODO: parse networks to which this group is connected
193
  return (uuid, Group.create name uuid apol [] ipol tags)
194

    
195
-- | Parse cluster data from the info resource.
196
parseCluster :: JSObject JSValue -> Result ([String], IPolicy, String)
197
parseCluster obj = do
198
  let obj' = fromJSObject obj
199
      extract s = tryFromObj "Parsing cluster data" obj' s
200
  master <- extract "master"
201
  tags <- extract "tags"
202
  ipolicy <- extract "ipolicy"
203
  return (tags, ipolicy, master)
204

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

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

    
226
-- | Loads data via either 'readDataFile' or 'readDataHttp'.
227
readData :: String -- ^ URL to use as source
228
         -> IO (Result String, Result String, Result String, Result String)
229
readData url =
230
  if filePrefix `isPrefixOf` url
231
    then readDataFile (drop (length filePrefix) url)
232
    else readDataHttp url
233

    
234
-- | Builds the cluster data from the raw Rapi content.
235
parseData :: (Result String, Result String, Result String, Result String)
236
          -> Result ClusterData
237
parseData (group_body, node_body, inst_body, info_body) = do
238
  group_data <- group_body >>= getGroups
239
  let (group_names, group_idx) = assignIndices group_data
240
  node_data <- node_body >>= getNodes group_names
241
  let (node_names, node_idx) = assignIndices node_data
242
  inst_data <- inst_body >>= getInstances node_names
243
  let (_, inst_idx) = assignIndices inst_data
244
  (tags, ipolicy, master) <-
245
    info_body >>=
246
    (fromJResult "Parsing cluster info" . decodeStrict) >>=
247
    parseCluster
248
  node_idx' <- setMaster node_names node_idx master
249
  return (ClusterData group_idx node_idx' inst_idx tags ipolicy)
250

    
251
-- | Top level function for data loading.
252
loadData :: String -- ^ Cluster or URL to use as source
253
         -> IO (Result ClusterData)
254
loadData = fmap parseData . readData