root / src / Ganeti / Hypervisor / Xen.hs @ eebc8ab2
History | View | Annotate | Download (3.5 kB)
1 |
{-| Module to access the information provided by the Xen hypervisor. |
---|---|
2 |
|
3 |
-} |
4 |
{- |
5 |
|
6 |
Copyright (C) 2013 Google Inc. |
7 |
|
8 |
This program is free software; you can redistribute it and/or modify |
9 |
it under the terms of the GNU General Public License as published by |
10 |
the Free Software Foundation; either version 2 of the License, or |
11 |
(at your option) any later version. |
12 |
|
13 |
This program is distributed in the hope that it will be useful, but |
14 |
WITHOUT ANY WARRANTY; without even the implied warranty of |
15 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
16 |
General Public License for more details. |
17 |
|
18 |
You should have received a copy of the GNU General Public License |
19 |
along with this program; if not, write to the Free Software |
20 |
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
21 |
02110-1301, USA. |
22 |
|
23 |
-} |
24 |
module Ganeti.Hypervisor.Xen |
25 |
( getDomainsInfo |
26 |
, getInferredDomInfo |
27 |
, getUptimeInfo |
28 |
--Data types to be re-exported from here |
29 |
, Domain(..) |
30 |
, UptimeInfo(..) |
31 |
) where |
32 |
|
33 |
import qualified Control.Exception as E |
34 |
import Data.Attoparsec.Text as A |
35 |
import qualified Data.Map as Map |
36 |
import Data.Text (pack) |
37 |
import System.Process |
38 |
|
39 |
import qualified Ganeti.BasicTypes as BT |
40 |
import qualified Ganeti.Constants as C |
41 |
import Ganeti.Hypervisor.Xen.Types |
42 |
import Ganeti.Hypervisor.Xen.XmParser |
43 |
import Ganeti.Logging |
44 |
import Ganeti.Utils |
45 |
|
46 |
|
47 |
-- | Get information about the current Xen domains as a map where the domain |
48 |
-- name is the key. This only includes the information made available by Xen |
49 |
-- itself. |
50 |
getDomainsInfo :: IO (BT.Result (Map.Map String Domain)) |
51 |
getDomainsInfo = do |
52 |
contents <- |
53 |
(E.try $ readProcess C.xenCmdXm ["list", "--long"] "") |
54 |
:: IO (Either IOError String) |
55 |
return $ |
56 |
either (BT.Bad . show) ( |
57 |
\c -> |
58 |
case A.parseOnly xmListParser $ pack c of |
59 |
Left msg -> BT.Bad msg |
60 |
Right dom -> BT.Ok dom |
61 |
) contents |
62 |
|
63 |
-- | Given a domain and a map containing information about multiple domains, |
64 |
-- infer additional information about that domain (specifically, whether it is |
65 |
-- hung). |
66 |
inferDomInfos :: Map.Map String Domain -> Domain -> Domain |
67 |
inferDomInfos domMap dom1 = |
68 |
case Map.lookup (domName dom1) domMap of |
69 |
Just dom2 -> |
70 |
dom1 { domIsHung = Just $ domCpuTime dom1 == domCpuTime dom2 } |
71 |
Nothing -> dom1 { domIsHung = Nothing } |
72 |
|
73 |
-- | Get information about the current Xen domains as a map where the domain |
74 |
-- name is the key. This includes information made available by Xen itself as |
75 |
-- well as further information that can be inferred by querying Xen multiple |
76 |
-- times and comparing the results. |
77 |
getInferredDomInfo :: IO (BT.Result (Map.Map String Domain)) |
78 |
getInferredDomInfo = do |
79 |
domMap1 <- getDomainsInfo |
80 |
domMap2 <- getDomainsInfo |
81 |
case (domMap1, domMap2) of |
82 |
(BT.Bad m1, BT.Bad m2) -> return . BT.Bad $ m1 ++ "\n" ++ m2 |
83 |
(BT.Bad m, BT.Ok d) -> do |
84 |
logWarning $ "Unable to retrieve domains info the first time" ++ m |
85 |
return $ BT.Ok d |
86 |
(BT.Ok d, BT.Bad m) -> do |
87 |
logWarning $ "Unable to retrieve domains info the second time" ++ m |
88 |
return $ BT.Ok d |
89 |
(BT.Ok d1, BT.Ok d2) -> return . BT.Ok $ fmap (inferDomInfos d2) d1 |
90 |
|
91 |
-- | Get information about the uptime of domains, as a map where the domain ID |
92 |
-- is the key. |
93 |
getUptimeInfo :: IO (Map.Map Int UptimeInfo) |
94 |
getUptimeInfo = do |
95 |
contents <- |
96 |
((E.try $ readProcess C.xenCmdXm ["uptime"] "") |
97 |
:: IO (Either IOError String)) >>= |
98 |
exitIfBad "running command" . either (BT.Bad . show) BT.Ok |
99 |
case A.parseOnly xmUptimeParser $ pack contents of |
100 |
Left msg -> exitErr msg |
101 |
Right uInfo -> return uInfo |