Revision 5b11f8db
b/htest/Test/Ganeti/BasicTypes.hs | ||
---|---|---|
73 | 73 |
|
74 | 74 |
-- | Tests the applicative composition law (pure (.) <*> u <*> v <*> w |
75 | 75 |
-- = u <*> (v <*> w)). |
76 |
prop_applicative_composition :: (Result (Fun Int Int))
|
|
77 |
-> (Result (Fun Int Int))
|
|
76 |
prop_applicative_composition :: Result (Fun Int Int)
|
|
77 |
-> Result (Fun Int Int)
|
|
78 | 78 |
-> Result Int |
79 | 79 |
-> Property |
80 | 80 |
prop_applicative_composition u v w = |
... | ... | |
85 | 85 |
-- | Tests the applicative homomorphism law (pure f <*> pure x = pure (f x)). |
86 | 86 |
prop_applicative_homomorphism :: Fun Int Int -> Int -> Property |
87 | 87 |
prop_applicative_homomorphism (Fun _ f) x = |
88 |
((pure f <*> pure x)::Result Int) ==? |
|
89 |
(pure (f x)) |
|
88 |
((pure f <*> pure x)::Result Int) ==? pure (f x) |
|
90 | 89 |
|
91 | 90 |
-- | Tests the applicative interchange law (u <*> pure y = pure ($ y) <*> u). |
92 | 91 |
prop_applicative_interchange :: Result (Fun Int Int) |
b/htest/Test/Ganeti/Daemon.hs | ||
---|---|---|
38 | 38 |
import Ganeti.Common |
39 | 39 |
import Ganeti.Daemon as Daemon |
40 | 40 |
|
41 |
{-# ANN module "HLint: ignore Use camelCase" #-} |
|
42 |
|
|
41 | 43 |
-- | Test a few string arguments. |
42 | 44 |
prop_string_arg :: String -> Property |
43 | 45 |
prop_string_arg argument = |
... | ... | |
65 | 67 |
|
66 | 68 |
-- | Tests a few invalid arguments. |
67 | 69 |
case_wrong_arg :: Assertion |
68 |
case_wrong_arg = do
|
|
70 |
case_wrong_arg = |
|
69 | 71 |
mapM_ (passFailOpt defaultOptions assertFailure (return ())) |
70 | 72 |
[ (oSyslogUsage, "foo", "yes") |
71 | 73 |
, (oPort 0, "x", "10") |
b/htest/Test/Ganeti/HTools/CLI.hs | ||
---|---|---|
43 | 43 |
import qualified Ganeti.HTools.Program as Program |
44 | 44 |
import qualified Ganeti.HTools.Types as Types |
45 | 45 |
|
46 |
{-# ANN module "HLint: ignore Use camelCase" #-} |
|
47 |
|
|
46 | 48 |
-- | Test correct parsing. |
47 | 49 |
prop_parseISpec :: String -> Int -> Int -> Int -> Property |
48 | 50 |
prop_parseISpec descr dsk mem cpu = |
... | ... | |
52 | 54 |
-- | Test parsing failure due to wrong section count. |
53 | 55 |
prop_parseISpecFail :: String -> Property |
54 | 56 |
prop_parseISpecFail descr = |
55 |
forAll (choose (0,100) `suchThat` ((/=) 3)) $ \nelems ->
|
|
57 |
forAll (choose (0,100) `suchThat` (/= 3)) $ \nelems ->
|
|
56 | 58 |
forAll (replicateM nelems arbitrary) $ \values -> |
57 | 59 |
let str = intercalate "," $ map show (values::[Int]) |
58 | 60 |
in case parseISpecString descr str of |
... | ... | |
101 | 103 |
|
102 | 104 |
-- | Tests a few invalid arguments. |
103 | 105 |
case_wrong_arg :: Assertion |
104 |
case_wrong_arg = do
|
|
106 |
case_wrong_arg = |
|
105 | 107 |
mapM_ (passFailOpt defaultOptions assertFailure (return ())) |
106 | 108 |
[ (oSpindleUse, "-1", "1") |
107 | 109 |
, (oSpindleUse, "a", "1") |
b/htest/Test/Ganeti/HTools/Cluster.hs | ||
---|---|---|
47 | 47 |
import qualified Ganeti.HTools.Node as Node |
48 | 48 |
import qualified Ganeti.HTools.Types as Types |
49 | 49 |
|
50 |
{-# ANN module "HLint: ignore Use camelCase" #-} |
|
51 |
|
|
50 | 52 |
-- * Helpers |
51 | 53 |
|
52 | 54 |
-- | Make a small cluster, both nodes and instances. |
... | ... | |
148 | 150 |
prop_CanTieredAlloc :: Instance.Instance -> Property |
149 | 151 |
prop_CanTieredAlloc inst = |
150 | 152 |
forAll (choose (2, 5)) $ \count -> |
151 |
forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
|
|
153 |
forAll (genOnlineNode `suchThat` isNodeBig 4) $ \node ->
|
|
152 | 154 |
let nl = makeSmallCluster node count |
153 | 155 |
il = Container.empty |
154 | 156 |
rqnodes = Instance.requiredNodes $ Instance.diskTemplate inst |
... | ... | |
196 | 198 |
prop_AllocRelocate :: Property |
197 | 199 |
prop_AllocRelocate = |
198 | 200 |
forAll (choose (4, 8)) $ \count -> |
199 |
forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
|
|
201 |
forAll (genOnlineNode `suchThat` isNodeBig 4) $ \node ->
|
|
200 | 202 |
forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst -> |
201 | 203 |
case genClusterAlloc count node inst of |
202 | 204 |
Types.Bad msg -> failTest msg |
... | ... | |
230 | 232 |
(gdx == Group.idx grp) |
231 | 233 |
v -> failmsg ("invalid solution: " ++ show v) False |
232 | 234 |
where failmsg :: String -> Bool -> Property |
233 |
failmsg = \msg -> printTestCase ("Failed to evacuate: " ++ msg)
|
|
235 |
failmsg msg = printTestCase ("Failed to evacuate: " ++ msg)
|
|
234 | 236 |
idx = Instance.idx inst |
235 | 237 |
|
236 | 238 |
-- | Checks that on a 4-8 node cluster, once we allocate an instance, |
... | ... | |
238 | 240 |
prop_AllocEvacuate :: Property |
239 | 241 |
prop_AllocEvacuate = |
240 | 242 |
forAll (choose (4, 8)) $ \count -> |
241 |
forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
|
|
243 |
forAll (genOnlineNode `suchThat` isNodeBig 4) $ \node ->
|
|
242 | 244 |
forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst -> |
243 | 245 |
case genClusterAlloc count node inst of |
244 | 246 |
Types.Bad msg -> failTest msg |
... | ... | |
255 | 257 |
prop_AllocChangeGroup :: Property |
256 | 258 |
prop_AllocChangeGroup = |
257 | 259 |
forAll (choose (4, 8)) $ \count -> |
258 |
forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
|
|
260 |
forAll (genOnlineNode `suchThat` isNodeBig 4) $ \node ->
|
|
259 | 261 |
forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst -> |
260 | 262 |
case genClusterAlloc count node inst of |
261 | 263 |
Types.Bad msg -> failTest msg |
... | ... | |
327 | 329 |
canAllocOn :: Node.List -> Int -> Instance.Instance -> Bool |
328 | 330 |
canAllocOn nl reqnodes inst = |
329 | 331 |
case Cluster.genAllocNodes defGroupList nl reqnodes True >>= |
330 |
Cluster.tryAlloc nl (Container.empty) inst of
|
|
332 |
Cluster.tryAlloc nl Container.empty inst of
|
|
331 | 333 |
Types.Bad _ -> False |
332 | 334 |
Types.Ok as -> |
333 | 335 |
case Cluster.asSolution as of |
... | ... | |
344 | 346 |
-- rqn is the required nodes (1 or 2) |
345 | 347 |
forAll (choose (1, 2)) $ \rqn -> |
346 | 348 |
forAll (choose (5, 20)) $ \count -> |
347 |
forAll (arbitrary `suchThat` (canAllocOn (makeSmallCluster node count) rqn))
|
|
349 |
forAll (arbitrary `suchThat` canAllocOn (makeSmallCluster node count) rqn)
|
|
348 | 350 |
$ \inst -> |
349 | 351 |
forAll (arbitrary `suchThat` (isFailure . |
350 | 352 |
Instance.instMatchesPolicy inst)) $ \ipol -> |
b/htest/Test/Ganeti/HTools/Node.hs | ||
---|---|---|
85 | 85 |
|
86 | 86 |
-- | Helper function to generate a sane node. |
87 | 87 |
genOnlineNode :: Gen Node.Node |
88 |
genOnlineNode = do
|
|
88 |
genOnlineNode = |
|
89 | 89 |
arbitrary `suchThat` (\n -> not (Node.offline n) && |
90 | 90 |
not (Node.failN1 n) && |
91 | 91 |
Node.availDisk n > 0 && |
b/htest/Test/Ganeti/HTools/Text.hs | ||
---|---|---|
53 | 53 |
-- * Instance text loader tests |
54 | 54 |
|
55 | 55 |
prop_Load_Instance :: String -> Int -> Int -> Int -> Types.InstanceStatus |
56 |
-> NonEmptyList Char -> [Char]
|
|
56 |
-> NonEmptyList Char -> String
|
|
57 | 57 |
-> NonNegative Int -> NonNegative Int -> Bool |
58 | 58 |
-> Types.DiskTemplate -> Int -> Property |
59 | 59 |
prop_Load_Instance name mem dsk vcpus status |
b/htest/Test/Ganeti/HTools/Utils.hs | ||
---|---|---|
40 | 40 |
import qualified Ganeti.HTools.Utils as Utils |
41 | 41 |
|
42 | 42 |
-- | Helper to generate a small string that doesn't contain commas. |
43 |
genNonCommaString :: Gen [Char]
|
|
43 |
genNonCommaString :: Gen String
|
|
44 | 44 |
genNonCommaString = do |
45 | 45 |
size <- choose (0, 20) -- arbitrary max size |
46 |
vectorOf size (arbitrary `suchThat` ((/=) ','))
|
|
46 |
vectorOf size (arbitrary `suchThat` (/=) ',')
|
|
47 | 47 |
|
48 | 48 |
-- | If the list is not just an empty element, and if the elements do |
49 | 49 |
-- not contain commas, then join+split should be idempotent. |
50 | 50 |
prop_commaJoinSplit :: Property |
51 | 51 |
prop_commaJoinSplit = |
52 | 52 |
forAll (choose (0, 20)) $ \llen -> |
53 |
forAll (vectorOf llen genNonCommaString `suchThat` ((/=) [""])) $ \lst ->
|
|
53 |
forAll (vectorOf llen genNonCommaString `suchThat` (/=) [""]) $ \lst ->
|
|
54 | 54 |
Utils.sepSplit ',' (Utils.commaJoin lst) ==? lst |
55 | 55 |
|
56 | 56 |
-- | Split and join should always be idempotent. |
57 |
prop_commaSplitJoin :: [Char] -> Property
|
|
57 |
prop_commaSplitJoin :: String -> Property
|
|
58 | 58 |
prop_commaSplitJoin s = |
59 | 59 |
Utils.commaJoin (Utils.sepSplit ',' s) ==? s |
60 | 60 |
|
b/htest/Test/Ganeti/Luxi.hs | ||
---|---|---|
58 | 58 |
case lreq of |
59 | 59 |
Luxi.ReqQuery -> Luxi.Query <$> arbitrary <*> getFields <*> genFilter |
60 | 60 |
Luxi.ReqQueryFields -> Luxi.QueryFields <$> arbitrary <*> getFields |
61 |
Luxi.ReqQueryNodes -> Luxi.QueryNodes <$> (listOf getFQDN) <*>
|
|
61 |
Luxi.ReqQueryNodes -> Luxi.QueryNodes <$> listOf getFQDN <*>
|
|
62 | 62 |
getFields <*> arbitrary |
63 | 63 |
Luxi.ReqQueryGroups -> Luxi.QueryGroups <$> arbitrary <*> |
64 | 64 |
arbitrary <*> arbitrary |
65 |
Luxi.ReqQueryInstances -> Luxi.QueryInstances <$> (listOf getFQDN) <*>
|
|
65 |
Luxi.ReqQueryInstances -> Luxi.QueryInstances <$> listOf getFQDN <*>
|
|
66 | 66 |
getFields <*> arbitrary |
67 | 67 |
Luxi.ReqQueryJobs -> Luxi.QueryJobs <$> arbitrary <*> getFields |
68 | 68 |
Luxi.ReqQueryExports -> Luxi.QueryExports <$> |
69 |
(listOf getFQDN) <*> arbitrary
|
|
69 |
listOf getFQDN <*> arbitrary
|
|
70 | 70 |
Luxi.ReqQueryConfigValues -> Luxi.QueryConfigValues <$> getFields |
71 | 71 |
Luxi.ReqQueryClusterInfo -> pure Luxi.QueryClusterInfo |
72 | 72 |
Luxi.ReqQueryTags -> Luxi.QueryTags <$> arbitrary <*> getFQDN |
73 |
Luxi.ReqSubmitJob -> Luxi.SubmitJob <$> (resize maxOpCodes arbitrary)
|
|
73 |
Luxi.ReqSubmitJob -> Luxi.SubmitJob <$> resize maxOpCodes arbitrary
|
|
74 | 74 |
Luxi.ReqSubmitManyJobs -> Luxi.SubmitManyJobs <$> |
75 |
(resize maxOpCodes arbitrary)
|
|
75 |
resize maxOpCodes arbitrary
|
|
76 | 76 |
Luxi.ReqWaitForJobChange -> Luxi.WaitForJobChange <$> arbitrary <*> |
77 | 77 |
getFields <*> pure J.JSNull <*> |
78 | 78 |
pure J.JSNull <*> arbitrary |
... | ... | |
116 | 116 |
prop_ClientServer :: [[DNSChar]] -> Property |
117 | 117 |
prop_ClientServer dnschars = monadicIO $ do |
118 | 118 |
let msgs = map (map dnsGetChar) dnschars |
119 |
fpath <- run $ getTempFileName
|
|
119 |
fpath <- run getTempFileName |
|
120 | 120 |
-- we need to create the server first, otherwise (if we do it in the |
121 | 121 |
-- forked thread) the client could try to connect to it before it's |
122 | 122 |
-- ready |
... | ... | |
131 | 131 |
bracket |
132 | 132 |
(Luxi.getClient fpath) |
133 | 133 |
Luxi.closeClient |
134 |
(\c -> luxiClientPong c msgs)
|
|
134 |
(`luxiClientPong` msgs)
|
|
135 | 135 |
stop $ replies ==? msgs |
136 | 136 |
|
137 | 137 |
testSuite "Luxi" |
b/htest/Test/Ganeti/Objects.hs | ||
---|---|---|
47 | 47 |
import Ganeti.Objects as Objects |
48 | 48 |
import Ganeti.JSON |
49 | 49 |
|
50 |
{-# ANN module "HLint: ignore Use camelCase" #-} |
|
51 |
|
|
50 | 52 |
-- * Arbitrary instances |
51 | 53 |
|
52 | 54 |
$(genArbitrary ''Hypervisor) |
... | ... | |
79 | 81 |
-- properties, we only generate disks with no children (FIXME), as |
80 | 82 |
-- generating recursive datastructures is a bit more work. |
81 | 83 |
instance Arbitrary Disk where |
82 |
arbitrary = Disk <$> arbitrary <*> (pure []) <*> arbitrary
|
|
84 |
arbitrary = Disk <$> arbitrary <*> pure [] <*> arbitrary
|
|
83 | 85 |
<*> arbitrary <*> arbitrary |
84 | 86 |
|
85 | 87 |
-- FIXME: we should generate proper values, >=0, etc., but this is |
... | ... | |
102 | 104 |
<$> getFQDN <*> getFQDN <*> getFQDN -- OS name, but... |
103 | 105 |
<*> arbitrary |
104 | 106 |
-- FIXME: add non-empty hvparams when they're a proper type |
105 |
<*> (pure $ Container Map.empty) <*> arbitrary
|
|
107 |
<*> pure (Container Map.empty) <*> arbitrary
|
|
106 | 108 |
-- ... and for OSParams |
107 |
<*> (pure $ Container Map.empty) <*> arbitrary <*> arbitrary
|
|
109 |
<*> pure (Container Map.empty) <*> arbitrary <*> arbitrary
|
|
108 | 110 |
<*> arbitrary <*> arbitrary <*> arbitrary |
109 | 111 |
-- ts |
110 | 112 |
<*> arbitrary <*> arbitrary |
... | ... | |
127 | 129 |
-- validation rules. |
128 | 130 |
instance Arbitrary NodeGroup where |
129 | 131 |
arbitrary = NodeGroup <$> getFQDN <*> pure [] <*> arbitrary <*> arbitrary |
130 |
<*> arbitrary <*> (pure $ Container Map.empty)
|
|
132 |
<*> arbitrary <*> pure (Container Map.empty)
|
|
131 | 133 |
-- ts |
132 | 134 |
<*> arbitrary <*> arbitrary |
133 | 135 |
-- uuid |
... | ... | |
181 | 183 |
nodeName = nodeName n ++ show idx }) |
182 | 184 |
nodes [(1::Int)..] |
183 | 185 |
contnodes = Container . Map.fromList $ map (\n -> (nodeName n, n)) nodes' |
184 |
continsts = Container $ Map.empty
|
|
186 |
continsts = Container Map.empty |
|
185 | 187 |
grp <- arbitrary |
186 | 188 |
let contgroups = Container $ Map.singleton guuid grp |
187 | 189 |
serial <- arbitrary |
b/htest/Test/Ganeti/OpCodes.hs | ||
---|---|---|
44 | 44 |
import qualified Ganeti.Constants as C |
45 | 45 |
import qualified Ganeti.OpCodes as OpCodes |
46 | 46 |
|
47 |
{-# ANN module "HLint: ignore Use camelCase" #-} |
|
48 |
|
|
47 | 49 |
-- * Arbitrary instances |
48 | 50 |
|
49 | 51 |
$(genArbitrary ''OpCodes.ReplaceDisksMode) |
... | ... | |
125 | 127 |
\encoded = [op.__getstate__() for op in decoded]\n\ |
126 | 128 |
\print serializer.Dump(encoded)" serialized |
127 | 129 |
>>= checkPythonResult |
128 |
let deserialised = (J.decode py_stdout::J.Result [OpCodes.OpCode])
|
|
130 |
let deserialised = J.decode py_stdout::J.Result [OpCodes.OpCode]
|
|
129 | 131 |
decoded <- case deserialised of |
130 | 132 |
J.Ok ops -> return ops |
131 | 133 |
J.Error msg -> |
b/htest/Test/Ganeti/Query/Language.hs | ||
---|---|---|
65 | 65 |
where value = oneof [ QuotedString <$> getName |
66 | 66 |
, NumericValue <$> arbitrary |
67 | 67 |
] |
68 |
genFilter' n = do
|
|
68 |
genFilter' n = |
|
69 | 69 |
oneof [ AndFilter <$> vectorOf n'' (genFilter' n') |
70 | 70 |
, OrFilter <$> vectorOf n'' (genFilter' n') |
71 | 71 |
, NotFilter <$> genFilter' n' |
... | ... | |
92 | 92 |
-- recursive ones, and not 'JSNull', which we can't use in a |
93 | 93 |
-- 'RSNormal' 'ResultEntry'. |
94 | 94 |
genJSValue :: Gen JSValue |
95 |
genJSValue = do
|
|
95 |
genJSValue = |
|
96 | 96 |
oneof [ JSBool <$> arbitrary |
97 | 97 |
, JSRational <$> pure False <*> arbitrary |
98 | 98 |
, JSString <$> (toJSString <$> arbitrary) |
b/htest/Test/Ganeti/Query/Query.hs | ||
---|---|---|
47 | 47 |
import Ganeti.Query.Node |
48 | 48 |
import Ganeti.Query.Query |
49 | 49 |
|
50 |
{-# ANN module "HLint: ignore Use camelCase" #-} |
|
51 |
|
|
50 | 52 |
-- * Helpers |
51 | 53 |
|
52 | 54 |
-- | Checks if a list of field definitions contains unknown fields. |
... | ... | |
77 | 79 |
prop_queryNode_Unknown :: Property |
78 | 80 |
prop_queryNode_Unknown = |
79 | 81 |
forAll (choose (0, maxNodes) >>= genEmptyCluster) $ \cluster -> |
80 |
forAll (arbitrary `suchThat` (`notElem` (Map.keys nodeFieldsMap)))
|
|
82 |
forAll (arbitrary `suchThat` (`notElem` Map.keys nodeFieldsMap))
|
|
81 | 83 |
$ \field -> monadicIO $ do |
82 | 84 |
QueryResult fdefs fdata <- |
83 | 85 |
run (query cluster (Query QRNode [field] EmptyFilter)) >>= resultProp |
b/htest/Test/Ganeti/TestCommon.hs | ||
---|---|---|
149 | 149 |
|
150 | 150 |
-- | All valid tag chars. This doesn't need to match _exactly_ |
151 | 151 |
-- Ganeti's own tag regex, just enough for it to be close. |
152 |
tagChar :: [Char]
|
|
152 |
tagChar :: String
|
|
153 | 153 |
tagChar = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ".+*/:@-" |
154 | 154 |
|
155 | 155 |
instance Arbitrary TagChar where |
b/htest/Test/Ganeti/TestHelper.hs | ||
---|---|---|
95 | 95 |
mkConsArbitrary (name, types) = |
96 | 96 |
let infix_arb a = InfixE (Just a) (VarE '(<*>)) (Just (VarE 'arbitrary)) |
97 | 97 |
constr = AppE (VarE 'pure) (ConE name) |
98 |
in foldl (\a _ -> infix_arb a) (constr) types
|
|
98 |
in foldl (\a _ -> infix_arb a) constr types
|
|
99 | 99 |
|
100 | 100 |
-- | Extracts the name and the types from a constructor. |
101 | 101 |
conInfo :: Con -> (Name, [Type]) |
... | ... | |
108 | 108 |
mkRegularArbitrary :: Name -> [Con] -> Q [Dec] |
109 | 109 |
mkRegularArbitrary name cons = do |
110 | 110 |
expr <- case cons of |
111 |
[] -> fail $ "Can't make Arbitrary instance for an empty data type"
|
|
111 |
[] -> fail "Can't make Arbitrary instance for an empty data type" |
|
112 | 112 |
[x] -> return $ mkConsArbitrary (conInfo x) |
113 | 113 |
xs -> appE (varE 'oneof) $ |
114 | 114 |
listE (map (return . mkConsArbitrary . conInfo) xs) |
b/htools/Ganeti/Common.hs | ||
---|---|---|
99 | 99 |
-> (a -> b -> Result b) |
100 | 100 |
-> String |
101 | 101 |
-> ArgDescr (b -> Result b) |
102 |
reqWithConversion conversion_fn updater_fn metavar =
|
|
102 |
reqWithConversion conversion_fn updater_fn = |
|
103 | 103 |
ReqArg (\string_opt opts -> do |
104 | 104 |
parsed_value <- conversion_fn string_opt |
105 |
updater_fn parsed_value opts) metavar
|
|
105 |
updater_fn parsed_value opts) |
|
106 | 106 |
|
107 | 107 |
-- | Command line parser, using a generic 'Options' structure. |
108 | 108 |
parseOpts :: (StandardOptions a) => |
b/htools/Ganeti/Confd.hs | ||
---|---|---|
146 | 146 |
]) |
147 | 147 |
$(makeJSONInstance ''ConfdErrorType) |
148 | 148 |
|
149 |
$(buildObject "ConfdRequest" "confdRq" $
|
|
149 |
$(buildObject "ConfdRequest" "confdRq" |
|
150 | 150 |
[ simpleField "protocol" [t| Int |] |
151 | 151 |
, simpleField "type" [t| ConfdRequestType |] |
152 | 152 |
, defaultField [| EmptyQuery |] $ simpleField "query" [t| ConfdQuery |] |
b/htools/Ganeti/Confd/Server.hs | ||
---|---|---|
286 | 286 |
|
287 | 287 |
-- | Wrapper over 'updateConfig' that handles IO errors. |
288 | 288 |
safeUpdateConfig :: FilePath -> FStat -> CRef -> IO (FStat, ConfigReload) |
289 |
safeUpdateConfig path oldfstat cref = do
|
|
289 |
safeUpdateConfig path oldfstat cref = |
|
290 | 290 |
catch (do |
291 | 291 |
nt <- needsReload oldfstat path |
292 | 292 |
case nt of |
... | ... | |
410 | 410 |
-- This tries to setup the watch descriptor; in case of any IO errors, |
411 | 411 |
-- it will return False. |
412 | 412 |
addNotifier :: INotify -> FilePath -> CRef -> MVar ServerState -> IO Bool |
413 |
addNotifier inotify path cref mstate = do
|
|
413 |
addNotifier inotify path cref mstate = |
|
414 | 414 |
catch (addWatch inotify [CloseWrite] path |
415 | 415 |
(onInotify inotify path cref mstate) >> return True) |
416 | 416 |
(\e -> const (return False) (e::IOError)) |
... | ... | |
430 | 430 |
path cref mstate |
431 | 431 |
return state' { reloadModel = mode } |
432 | 432 |
|
433 |
onInotify inotify path cref mstate _ = do
|
|
433 |
onInotify inotify path cref mstate _ = |
|
434 | 434 |
modifyMVar_ mstate $ \state -> |
435 |
if (reloadModel state == ReloadNotify)
|
|
435 |
if reloadModel state == ReloadNotify
|
|
436 | 436 |
then do |
437 | 437 |
ctime <- getCurrentTime |
438 | 438 |
(newfstat, _) <- safeUpdateConfig path (reloadFStat state) cref |
... | ... | |
481 | 481 |
listener s hmac resp = do |
482 | 482 |
(msg, _, peer) <- S.recvFrom s 4096 |
483 | 483 |
if confdMagicFourcc `isPrefixOf` msg |
484 |
then (forkIO $ resp s hmac (drop 4 msg) peer) >> return ()
|
|
484 |
then forkIO (resp s hmac (drop 4 msg) peer) >> return ()
|
|
485 | 485 |
else logDebug "Invalid magic code!" >> return () |
486 | 486 |
return () |
487 | 487 |
|
b/htools/Ganeti/Confd/Utils.hs | ||
---|---|---|
63 | 63 |
parseMessage hmac msg curtime = do |
64 | 64 |
(salt, origmsg, request) <- parseRequest hmac msg |
65 | 65 |
ts <- tryRead "Parsing timestamp" salt::Result Integer |
66 |
if (abs (ts - curtime) > (fromIntegral C.confdMaxClockSkew))
|
|
66 |
if abs (ts - curtime) > fromIntegral C.confdMaxClockSkew
|
|
67 | 67 |
then fail "Too old/too new timestamp or clock skew" |
68 | 68 |
else return (origmsg, request) |
69 | 69 |
|
b/htools/Ganeti/Config.hs | ||
---|---|---|
111 | 111 |
-- | Computes the role of a node. |
112 | 112 |
getNodeRole :: ConfigData -> Node -> NodeRole |
113 | 113 |
getNodeRole cfg node |
114 |
| nodeName node == (clusterMasterNode $ configCluster cfg) = NRMaster
|
|
114 |
| nodeName node == clusterMasterNode (configCluster cfg) = NRMaster
|
|
115 | 115 |
| nodeMasterCandidate node = NRCandidate |
116 | 116 |
| nodeDrained node = NRDrained |
117 | 117 |
| nodeOffline node = NROffline |
... | ... | |
133 | 133 |
getItem :: String -> String -> M.Map String a -> Result a |
134 | 134 |
getItem kind name allitems = do |
135 | 135 |
let lresult = lookupName (M.keys allitems) name |
136 |
err = \details -> Bad $ kind ++ " name " ++ name ++ " " ++ details
|
|
136 |
err msg = Bad $ kind ++ " name " ++ name ++ " " ++ msg
|
|
137 | 137 |
fullname <- case lrMatchPriority lresult of |
138 | 138 |
PartialMatch -> Ok $ lrContent lresult |
139 | 139 |
ExactMatch -> Ok $ lrContent lresult |
... | ... | |
160 | 160 |
-- if not found by uuid, we need to look it up by name, slow |
161 | 161 |
Ok grp -> Ok grp |
162 | 162 |
Bad _ -> let by_name = M.mapKeys |
163 |
(\k -> groupName ((M.!) groups k )) groups
|
|
163 |
(groupName . (M.!) groups) groups
|
|
164 | 164 |
in getItem "NodeGroup" name by_name |
165 | 165 |
|
166 | 166 |
-- | Computes a node group's node params. |
... | ... | |
232 | 232 |
link = nicpLink fparams |
233 | 233 |
in case nicIp nic of |
234 | 234 |
Nothing -> accum |
235 |
Just ip -> let oldipmap = M.findWithDefault (M.empty)
|
|
235 |
Just ip -> let oldipmap = M.findWithDefault M.empty
|
|
236 | 236 |
link accum |
237 | 237 |
newipmap = M.insert ip iname oldipmap |
238 | 238 |
in M.insert link newipmap accum |
b/htools/Ganeti/Daemon.hs | ||
---|---|---|
105 | 105 |
instance StandardOptions DaemonOptions where |
106 | 106 |
helpRequested = optShowHelp |
107 | 107 |
verRequested = optShowVer |
108 |
requestHelp = \opts -> opts { optShowHelp = True }
|
|
109 |
requestVer = \opts -> opts { optShowVer = True }
|
|
108 |
requestHelp o = o { optShowHelp = True }
|
|
109 |
requestVer o = o { optShowVer = True }
|
|
110 | 110 |
|
111 | 111 |
-- | Abrreviation for the option type. |
112 | 112 |
type OptType = GenericOptType DaemonOptions |
... | ... | |
176 | 176 |
-- | Wrapper over '_writePidFile' that transforms IO exceptions into a |
177 | 177 |
-- 'Bad' value. |
178 | 178 |
writePidFile :: FilePath -> IO (Result Fd) |
179 |
writePidFile path = do
|
|
179 |
writePidFile path = |
|
180 | 180 |
catch (fmap Ok $ _writePidFile path) |
181 | 181 |
(return . Bad . formatIOError "Failure during writing of the pid file") |
182 | 182 |
|
183 | 183 |
-- | Helper function to ensure a socket doesn't exist. Should only be |
184 | 184 |
-- called once we have locked the pid file successfully. |
185 | 185 |
cleanupSocket :: FilePath -> IO () |
186 |
cleanupSocket socketPath = do
|
|
186 |
cleanupSocket socketPath = |
|
187 | 187 |
catchJust (guard . isDoesNotExistError) (removeLink socketPath) |
188 | 188 |
(const $ return ()) |
189 | 189 |
|
... | ... | |
217 | 217 |
-> Socket.Family -- ^ The cluster IP family |
218 | 218 |
-> Result (Socket.Family, Socket.SockAddr) |
219 | 219 |
defaultBindAddr port Socket.AF_INET = |
220 |
Ok $ (Socket.AF_INET,
|
|
221 |
Socket.SockAddrInet (fromIntegral port) Socket.iNADDR_ANY)
|
|
220 |
Ok (Socket.AF_INET, |
|
221 |
Socket.SockAddrInet (fromIntegral port) Socket.iNADDR_ANY) |
|
222 | 222 |
defaultBindAddr port Socket.AF_INET6 = |
223 |
Ok $ (Socket.AF_INET6,
|
|
224 |
Socket.SockAddrInet6 (fromIntegral port) 0 Socket.iN6ADDR_ANY 0)
|
|
223 |
Ok (Socket.AF_INET6, |
|
224 |
Socket.SockAddrInet6 (fromIntegral port) 0 Socket.iN6ADDR_ANY 0) |
|
225 | 225 |
defaultBindAddr _ fam = Bad $ "Unsupported address family: " ++ show fam |
226 | 226 |
|
227 | 227 |
-- | Default hints for the resolver |
... | ... | |
236 | 236 |
resolved <- Socket.getAddrInfo resolveAddrHints (Just str) (Just (show port)) |
237 | 237 |
return $ case resolved of |
238 | 238 |
[] -> Bad "Invalid results from lookup?" |
239 |
best:_ -> Ok $ (Socket.addrFamily best, Socket.addrAddress best)
|
|
239 |
best:_ -> Ok (Socket.addrFamily best, Socket.addrAddress best) |
|
240 | 240 |
|
241 | 241 |
-- | Based on the options, compute the socket address to use for the |
242 | 242 |
-- daemon. |
... | ... | |
246 | 246 |
parseAddress opts defport = do |
247 | 247 |
let port = maybe defport fromIntegral $ optPort opts |
248 | 248 |
def_family <- Ssconf.getPrimaryIPFamily Nothing |
249 |
ainfo <- case optBindAddress opts of |
|
250 |
Nothing -> return (def_family >>= defaultBindAddr port) |
|
251 |
Just saddr -> catch (resolveAddr port saddr) |
|
252 |
(annotateIOError $ "Invalid address " ++ saddr) |
|
253 |
return ainfo |
|
249 |
case optBindAddress opts of |
|
250 |
Nothing -> return (def_family >>= defaultBindAddr port) |
|
251 |
Just saddr -> catch (resolveAddr port saddr) |
|
252 |
(annotateIOError $ "Invalid address " ++ saddr) |
|
254 | 253 |
|
255 | 254 |
-- | Run an I/O action as a daemon. |
256 | 255 |
-- |
b/htools/Ganeti/HTools/CLI.hs | ||
---|---|---|
199 | 199 |
instance StandardOptions Options where |
200 | 200 |
helpRequested = optShowHelp |
201 | 201 |
verRequested = optShowVer |
202 |
requestHelp = \opts -> opts { optShowHelp = True }
|
|
203 |
requestVer = \opts -> opts { optShowVer = True }
|
|
202 |
requestHelp o = o { optShowHelp = True }
|
|
203 |
requestVer o = o { optShowVer = True }
|
|
204 | 204 |
|
205 | 205 |
-- * Helper functions |
206 | 206 |
|
... | ... | |
539 | 539 |
m_cpu = optMcpu opts |
540 | 540 |
m_dsk = optMdsk opts |
541 | 541 |
|
542 |
unless (null offline_wrong) $ do
|
|
542 |
unless (null offline_wrong) .
|
|
543 | 543 |
exitErr $ printf "wrong node name(s) set as offline: %s\n" |
544 | 544 |
(commaJoin (map lrContent offline_wrong)) |
545 | 545 |
let setMCpuFn = case m_cpu of |
b/htools/Ganeti/HTools/Instance.hs | ||
---|---|---|
276 | 276 |
instMatchesPolicy inst ipol = do |
277 | 277 |
instAboveISpec inst (T.iPolicyMinSpec ipol) |
278 | 278 |
instBelowISpec inst (T.iPolicyMaxSpec ipol) |
279 |
if (diskTemplate inst `elem` T.iPolicyDiskTemplates ipol)
|
|
279 |
if diskTemplate inst `elem` T.iPolicyDiskTemplates ipol
|
|
280 | 280 |
then T.OpGood () |
281 | 281 |
else T.OpFail T.FailDisk |
282 | 282 |
|
b/htools/Ganeti/HTools/Luxi.hs | ||
---|---|---|
212 | 212 |
cpol <- tryFromObj errmsg obj' "ipolicy" |
213 | 213 |
return (ctags, cpol) |
214 | 214 |
|
215 |
getClusterData _ = Bad $ "Cannot parse cluster info, not a JSON record"
|
|
215 |
getClusterData _ = Bad "Cannot parse cluster info, not a JSON record" |
|
216 | 216 |
|
217 | 217 |
-- | Parses the cluster groups. |
218 | 218 |
getGroups :: JSValue -> Result [(String, Group.Group)] |
b/htools/Ganeti/HTools/Program/Hcheck.hs | ||
---|---|---|
158 | 158 |
-- readable mode). |
159 | 159 |
printGroupsMappings :: Group.List -> IO () |
160 | 160 |
printGroupsMappings gl = do |
161 |
let extract_vals = \g -> (printf "GROUP_UUID_%d" $ Group.idx g :: String,
|
|
162 |
Group.uuid g)
|
|
161 |
let extract_vals g = (printf "GROUP_UUID_%d" $ Group.idx g :: String,
|
|
162 |
Group.uuid g) |
|
163 | 163 |
printpairs = map extract_vals (Container.elems gl) |
164 | 164 |
printKeysHTC printpairs |
165 | 165 |
|
b/htools/Ganeti/HTools/Program/Hinfo.hs | ||
---|---|---|
104 | 104 |
splitInstancesInfo :: Int -> Node.List -> Instance.List -> IO () |
105 | 105 |
splitInstancesInfo verbose nl il = do |
106 | 106 |
let split_insts = Cluster.findSplitInstances nl il |
107 |
if (null split_insts)
|
|
107 |
if null split_insts
|
|
108 | 108 |
then |
109 |
when (verbose > 1) $ do
|
|
109 |
when (verbose > 1) $ |
|
110 | 110 |
putStrLn "No split instances found"::IO () |
111 | 111 |
else do |
112 | 112 |
putStrLn "Found instances belonging to multiple node groups:" |
... | ... | |
115 | 115 |
-- | Print common (interesting) information. |
116 | 116 |
commonInfo :: Int -> Group.List -> Node.List -> Instance.List -> IO () |
117 | 117 |
commonInfo verbose gl nl il = do |
118 |
when (Container.null il && verbose > 1) $ do
|
|
119 |
printf "Cluster is empty.\n"::IO ()
|
|
118 |
when (Container.null il && verbose > 1) $ |
|
119 |
printf "Cluster is empty.\n"::IO () |
|
120 | 120 |
|
121 |
let nl_size = (Container.size nl)
|
|
122 |
il_size = (Container.size il)
|
|
123 |
gl_size = (Container.size gl)
|
|
121 |
let nl_size = Container.size nl
|
|
122 |
il_size = Container.size il
|
|
123 |
gl_size = Container.size gl
|
|
124 | 124 |
printf "Loaded %d %s, %d %s, %d %s\n" |
125 | 125 |
nl_size (plural nl_size "node" "nodes") |
126 | 126 |
il_size (plural il_size "instance" "instances") |
... | ... | |
145 | 145 |
|
146 | 146 |
putStrLn $ "Loaded cluster tags: " ++ intercalate "," ctags |
147 | 147 |
|
148 |
when (verbose > 2) $ do
|
|
148 |
when (verbose > 2) .
|
|
149 | 149 |
putStrLn $ "Loaded cluster ipolicy: " ++ show ipol |
150 | 150 |
|
151 | 151 |
nlf <- setNodeStatus opts fixed_nl |
b/htools/Ganeti/HTools/Program/Hspace.hs | ||
---|---|---|
372 | 372 |
|
373 | 373 |
-- | Create an instance from a given spec. |
374 | 374 |
instFromSpec :: RSpec -> DiskTemplate -> Int -> Instance.Instance |
375 |
instFromSpec spx disk_template su =
|
|
375 |
instFromSpec spx = |
|
376 | 376 |
Instance.create "new" (rspecMem spx) (rspecDsk spx) |
377 |
(rspecCpu spx) Running [] True (-1) (-1) disk_template su
|
|
377 |
(rspecCpu spx) Running [] True (-1) (-1) |
|
378 | 378 |
|
379 | 379 |
-- | Main function. |
380 | 380 |
main :: Options -> [String] -> IO () |
b/htools/Ganeti/HTools/Rapi.hs | ||
---|---|---|
212 | 212 |
-- | Loads data via either 'readDataFile' or 'readDataHttp'. |
213 | 213 |
readData :: String -- ^ URL to use as source |
214 | 214 |
-> IO (Result String, Result String, Result String, Result String) |
215 |
readData url = do
|
|
215 |
readData url = |
|
216 | 216 |
if filePrefix `isPrefixOf` url |
217 | 217 |
then readDataFile (drop (length filePrefix) url) |
218 | 218 |
else readDataHttp url |
b/htools/Ganeti/HTools/Text.hs | ||
---|---|---|
146 | 146 |
serializeAllIPolicies :: IPolicy -> Group.List -> String |
147 | 147 |
serializeAllIPolicies cpol gl = |
148 | 148 |
let groups = Container.elems gl |
149 |
allpolicies = [("", cpol)] ++
|
|
149 |
allpolicies = ("", cpol) :
|
|
150 | 150 |
map (\g -> (Group.name g, Group.iPolicy g)) groups |
151 | 151 |
strings = map (uncurry serializeIPolicy) allpolicies |
152 | 152 |
in unlines strings |
... | ... | |
259 | 259 |
xdts <- mapM diskTemplateFromRaw $ commaSplit dtemplates |
260 | 260 |
xvcpu_ratio <- tryRead (owner ++ "/vcpu_ratio") vcpu_ratio |
261 | 261 |
xspindle_ratio <- tryRead (owner ++ "/spindle_ratio") spindle_ratio |
262 |
return $ (owner, IPolicy xstdspec xminspec xmaxspec xdts
|
|
263 |
xvcpu_ratio xspindle_ratio)
|
|
262 |
return (owner,
|
|
263 |
IPolicy xstdspec xminspec xmaxspec xdts xvcpu_ratio xspindle_ratio)
|
|
264 | 264 |
loadIPolicy s = fail $ "Invalid ipolicy data: '" ++ show s ++ "'" |
265 | 265 |
|
266 | 266 |
loadOnePolicy :: (IPolicy, Group.List) -> String |
b/htools/Ganeti/Luxi.hs | ||
---|---|---|
342 | 342 |
ReqQueryGroups -> do |
343 | 343 |
(names, fields, locking) <- fromJVal args |
344 | 344 |
return $ QueryGroups names fields locking |
345 |
ReqQueryClusterInfo -> do
|
|
345 |
ReqQueryClusterInfo -> |
|
346 | 346 |
return QueryClusterInfo |
347 | 347 |
ReqQuery -> do |
348 | 348 |
(what, fields, qfilter) <- fromJVal args |
b/htools/Ganeti/Objects.hs | ||
---|---|---|
276 | 276 |
mB' <- readJSON mB |
277 | 277 |
k' <- readJSON k |
278 | 278 |
return $ LIDDrbd8 nA' nB' p' mA' mB' k' |
279 |
_ -> fail $ "Can't read logical_id for DRBD8 type"
|
|
279 |
_ -> fail "Can't read logical_id for DRBD8 type" |
|
280 | 280 |
LD_LV -> |
281 | 281 |
case lid of |
282 | 282 |
JSArray [vg, lv] -> do |
283 | 283 |
vg' <- readJSON vg |
284 | 284 |
lv' <- readJSON lv |
285 | 285 |
return $ LIDPlain vg' lv' |
286 |
_ -> fail $ "Can't read logical_id for plain type"
|
|
286 |
_ -> fail "Can't read logical_id for plain type" |
|
287 | 287 |
LD_FILE -> |
288 | 288 |
case lid of |
289 | 289 |
JSArray [driver, path] -> do |
290 | 290 |
driver' <- readJSON driver |
291 | 291 |
path' <- readJSON path |
292 | 292 |
return $ LIDFile driver' path' |
293 |
_ -> fail $ "Can't read logical_id for file type"
|
|
293 |
_ -> fail "Can't read logical_id for file type" |
|
294 | 294 |
LD_BLOCKDEV -> |
295 | 295 |
case lid of |
296 | 296 |
JSArray [driver, path] -> do |
297 | 297 |
driver' <- readJSON driver |
298 | 298 |
path' <- readJSON path |
299 | 299 |
return $ LIDBlockDev driver' path' |
300 |
_ -> fail $ "Can't read logical_id for blockdev type"
|
|
300 |
_ -> fail "Can't read logical_id for blockdev type" |
|
301 | 301 |
LD_RADOS -> |
302 | 302 |
case lid of |
303 | 303 |
JSArray [driver, path] -> do |
304 | 304 |
driver' <- readJSON driver |
305 | 305 |
path' <- readJSON path |
306 | 306 |
return $ LIDRados driver' path' |
307 |
_ -> fail $ "Can't read logical_id for rdb type"
|
|
307 |
_ -> fail "Can't read logical_id for rdb type" |
|
308 | 308 |
|
309 | 309 |
-- | Disk data structure. |
310 | 310 |
-- |
... | ... | |
363 | 363 |
]) |
364 | 364 |
$(makeJSONInstance ''AdminState) |
365 | 365 |
|
366 |
$(buildParam "Be" "bep" $
|
|
366 |
$(buildParam "Be" "bep" |
|
367 | 367 |
[ simpleField "minmem" [t| Int |] |
368 | 368 |
, simpleField "maxmem" [t| Int |] |
369 | 369 |
, simpleField "vcpus" [t| Int |] |
... | ... | |
404 | 404 |
|
405 | 405 |
-- * IPolicy definitions |
406 | 406 |
|
407 |
$(buildParam "ISpec" "ispec" $
|
|
407 |
$(buildParam "ISpec" "ispec" |
|
408 | 408 |
[ simpleField C.ispecMemSize [t| Int |] |
409 | 409 |
, simpleField C.ispecDiskSize [t| Int |] |
410 | 410 |
, simpleField C.ispecDiskCount [t| Int |] |
... | ... | |
414 | 414 |
|
415 | 415 |
-- | Custom partial ipolicy. This is not built via buildParam since it |
416 | 416 |
-- has a special 2-level inheritance mode. |
417 |
$(buildObject "PartialIPolicy" "ipolicy" $
|
|
417 |
$(buildObject "PartialIPolicy" "ipolicy" |
|
418 | 418 |
[ renameField "MinSpecP" $ simpleField "min" [t| PartialISpecParams |] |
419 | 419 |
, renameField "MaxSpecP" $ simpleField "max" [t| PartialISpecParams |] |
420 | 420 |
, renameField "StdSpecP" $ simpleField "std" [t| PartialISpecParams |] |
... | ... | |
428 | 428 |
|
429 | 429 |
-- | Custom filled ipolicy. This is not built via buildParam since it |
430 | 430 |
-- has a special 2-level inheritance mode. |
431 |
$(buildObject "FilledIPolicy" "ipolicy" $
|
|
431 |
$(buildObject "FilledIPolicy" "ipolicy" |
|
432 | 432 |
[ renameField "MinSpec" $ simpleField "min" [t| FilledISpecParams |] |
433 | 433 |
, renameField "MaxSpec" $ simpleField "max" [t| FilledISpecParams |] |
434 | 434 |
, renameField "StdSpec" $ simpleField "std" [t| FilledISpecParams |] |
... | ... | |
461 | 461 |
} |
462 | 462 |
-- * Node definitions |
463 | 463 |
|
464 |
$(buildParam "ND" "ndp" $
|
|
464 |
$(buildParam "ND" "ndp" |
|
465 | 465 |
[ simpleField "oob_program" [t| String |] |
466 | 466 |
, simpleField "spindle_count" [t| Int |] |
467 | 467 |
]) |
b/htools/Ganeti/Query/Language.hs | ||
---|---|---|
136 | 136 |
showFilter :: (JSON a) => Filter a -> JSValue |
137 | 137 |
showFilter (EmptyFilter) = JSNull |
138 | 138 |
showFilter (AndFilter exprs) = |
139 |
JSArray $ (showJSON C.qlangOpAnd):(map showJSON exprs)
|
|
139 |
JSArray $ showJSON C.qlangOpAnd : map showJSON exprs
|
|
140 | 140 |
showFilter (OrFilter exprs) = |
141 |
JSArray $ (showJSON C.qlangOpOr):(map showJSON exprs)
|
|
141 |
JSArray $ showJSON C.qlangOpOr : map showJSON exprs
|
|
142 | 142 |
showFilter (NotFilter flt) = |
143 | 143 |
JSArray [showJSON C.qlangOpNot, showJSON flt] |
144 | 144 |
showFilter (TrueFilter field) = |
... | ... | |
223 | 223 |
-- Traversable implementation for 'Filter'. |
224 | 224 |
traverseFlt :: (Applicative f) => (a -> f b) -> Filter a -> f (Filter b) |
225 | 225 |
traverseFlt _ EmptyFilter = pure EmptyFilter |
226 |
traverseFlt f (AndFilter flts) = AndFilter <$> (traverse (traverseFlt f) flts)
|
|
227 |
traverseFlt f (OrFilter flts) = OrFilter <$> (traverse (traverseFlt f) flts)
|
|
228 |
traverseFlt f (NotFilter flt) = NotFilter <$> (traverseFlt f flt)
|
|
226 |
traverseFlt f (AndFilter flts) = AndFilter <$> traverse (traverseFlt f) flts
|
|
227 |
traverseFlt f (OrFilter flts) = OrFilter <$> traverse (traverseFlt f) flts
|
|
228 |
traverseFlt f (NotFilter flt) = NotFilter <$> traverseFlt f flt
|
|
229 | 229 |
traverseFlt f (TrueFilter a) = TrueFilter <$> f a |
230 | 230 |
traverseFlt f (EQFilter a fval) = EQFilter <$> f a <*> pure fval |
231 | 231 |
traverseFlt f (LTFilter a fval) = LTFilter <$> f a <*> pure fval |
b/htools/Ganeti/Query/Node.hs | ||
---|---|---|
76 | 76 |
nodeRoleDoc :: String |
77 | 77 |
nodeRoleDoc = |
78 | 78 |
"Node role; " ++ |
79 |
(intercalate ", " $
|
|
80 |
map (\role -> |
|
79 |
intercalate ", "
|
|
80 |
(map (\role ->
|
|
81 | 81 |
"\"" ++ nodeRoleToRaw role ++ "\" for " ++ roleDescription role) |
82 | 82 |
(reverse [minBound..maxBound])) |
83 | 83 |
|
b/htools/Ganeti/Query/Server.hs | ||
---|---|---|
69 | 69 |
hypervisors = clusterEnabledHypervisors cluster |
70 | 70 |
bits = show (bitSize (0::Int)) ++ "bits" |
71 | 71 |
arch_tuple = [bits, arch] |
72 |
obj = [ ("software_version", showJSON $ C.releaseVersion)
|
|
73 |
, ("protocol_version", showJSON $ C.protocolVersion)
|
|
74 |
, ("config_version", showJSON $ C.configVersion)
|
|
72 |
obj = [ ("software_version", showJSON C.releaseVersion) |
|
73 |
, ("protocol_version", showJSON C.protocolVersion) |
|
74 |
, ("config_version", showJSON C.configVersion) |
|
75 | 75 |
, ("os_api_version", showJSON $ maximum C.osApiVersions) |
76 |
, ("export_version", showJSON $ C.exportVersion)
|
|
77 |
, ("architecture", showJSON $ arch_tuple)
|
|
76 |
, ("export_version", showJSON C.exportVersion) |
|
77 |
, ("architecture", showJSON arch_tuple) |
|
78 | 78 |
, ("name", showJSON $ clusterClusterName cluster) |
79 | 79 |
, ("master", showJSON $ clusterMasterNode cluster) |
80 | 80 |
, ("default_hypervisor", showJSON $ head hypervisors) |
81 |
, ("enabled_hypervisors", showJSON $ hypervisors)
|
|
81 |
, ("enabled_hypervisors", showJSON hypervisors) |
|
82 | 82 |
, ("hvparams", showJSON $ clusterHvparams cluster) |
83 | 83 |
, ("os_hvp", showJSON $ clusterOsHvp cluster) |
84 | 84 |
, ("beparams", showJSON $ clusterBeparams cluster) |
... | ... | |
93 | 93 |
, ("master_netmask", showJSON $ clusterMasterNetmask cluster) |
94 | 94 |
, ("use_external_mip_script", |
95 | 95 |
showJSON $ clusterUseExternalMipScript cluster) |
96 |
, ("volume_group_name", showJSON $clusterVolumeGroupName cluster) |
|
96 |
, ("volume_group_name", showJSON $ clusterVolumeGroupName cluster)
|
|
97 | 97 |
, ("drbd_usermode_helper", |
98 | 98 |
maybe JSNull showJSON (clusterDrbdUsermodeHelper cluster)) |
99 | 99 |
, ("file_storage_dir", showJSON $ clusterFileStorageDir cluster) |
b/htools/Ganeti/Rpc.hs | ||
---|---|---|
172 | 172 |
prepareUrl node call = |
173 | 173 |
let node_ip = nodePrimaryIp node |
174 | 174 |
port = snd C.daemonsPortsGanetiNoded |
175 |
path_prefix = "https://" ++ (node_ip) ++ ":" ++ (show port) in
|
|
176 |
path_prefix ++ "/" ++ rpcCallName call |
|
175 |
path_prefix = "https://" ++ node_ip ++ ":" ++ show port
|
|
176 |
in path_prefix ++ "/" ++ rpcCallName call
|
|
177 | 177 |
|
178 | 178 |
-- | Create HTTP request for a given node provided it is online, |
179 | 179 |
-- otherwise create empty response. |
180 | 180 |
prepareHttpRequest :: (RpcCall a) => Node -> a |
181 | 181 |
-> Either RpcError HttpClientRequest |
182 | 182 |
prepareHttpRequest node call |
183 |
| rpcCallAcceptOffline call || |
|
184 |
(not $ nodeOffline node) = |
|
185 |
Right $ HttpClientRequest { requestTimeout = rpcCallTimeout call |
|
186 |
, requestUrl = prepareUrl node call |
|
187 |
, requestPostData = rpcCallData node call |
|
188 |
} |
|
183 |
| rpcCallAcceptOffline call || not (nodeOffline node) = |
|
184 |
Right HttpClientRequest { requestTimeout = rpcCallTimeout call |
|
185 |
, requestUrl = prepareUrl node call |
|
186 |
, requestPostData = rpcCallData node call |
|
187 |
} |
|
189 | 188 |
| otherwise = Left $ OfflineNodeError node |
190 | 189 |
|
191 | 190 |
-- | Parse the response or propagate the error. |
... | ... | |
212 | 211 |
|
213 | 212 |
-- | AllInstancesInfo |
214 | 213 |
-- Returns information about all instances on the given nodes |
215 |
$(buildObject "RpcCallAllInstancesInfo" "rpcCallAllInstInfo" $
|
|
214 |
$(buildObject "RpcCallAllInstancesInfo" "rpcCallAllInstInfo" |
|
216 | 215 |
[ simpleField "hypervisors" [t| [Hypervisor] |] ]) |
217 | 216 |
|
218 |
$(buildObject "InstanceInfo" "instInfo" $
|
|
217 |
$(buildObject "InstanceInfo" "instInfo" |
|
219 | 218 |
[ simpleField "name" [t| String |] |
220 | 219 |
, simpleField "memory" [t| Int|] |
221 | 220 |
, simpleField "state" [t| AdminState |] |
... | ... | |
223 | 222 |
, simpleField "time" [t| Int |] |
224 | 223 |
]) |
225 | 224 |
|
226 |
$(buildObject "RpcResultAllInstancesInfo" "rpcResAllInstInfo" $
|
|
225 |
$(buildObject "RpcResultAllInstancesInfo" "rpcResAllInstInfo" |
|
227 | 226 |
[ simpleField "instances" [t| [InstanceInfo] |] ]) |
228 | 227 |
|
229 | 228 |
instance RpcCall RpcCallAllInstancesInfo where |
... | ... | |
237 | 236 |
|
238 | 237 |
-- | InstanceList |
239 | 238 |
-- Returns the list of running instances on the given nodes. |
240 |
$(buildObject "RpcCallInstanceList" "rpcCallInstList" $
|
|
239 |
$(buildObject "RpcCallInstanceList" "rpcCallInstList" |
|
241 | 240 |
[ simpleField "hypervisors" [t| [Hypervisor] |] ]) |
242 | 241 |
|
243 |
$(buildObject "RpcResultInstanceList" "rpcResInstList" $
|
|
242 |
$(buildObject "RpcResultInstanceList" "rpcResInstList" |
|
244 | 243 |
[ simpleField "node" [t| Node |] |
245 | 244 |
, simpleField "instances" [t| [String] |] |
246 | 245 |
]) |
... | ... | |
256 | 255 |
|
257 | 256 |
-- | NodeInfo |
258 | 257 |
-- Return node information. |
259 |
$(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo" $
|
|
258 |
$(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo" |
|
260 | 259 |
[ simpleField "hypervisors" [t| [Hypervisor] |] |
261 | 260 |
, simpleField "volume_groups" [t| [String] |] |
262 | 261 |
]) |
263 | 262 |
|
264 |
$(buildObject "VgInfo" "vgInfo" $
|
|
263 |
$(buildObject "VgInfo" "vgInfo" |
|
265 | 264 |
[ simpleField "name" [t| String |] |
266 | 265 |
, simpleField "free" [t| Int |] |
267 | 266 |
, simpleField "size" [t| Int |] |
268 | 267 |
]) |
269 | 268 |
|
270 | 269 |
-- | We only provide common fields as described in hv_base.py. |
271 |
$(buildObject "HvInfo" "hvInfo" $
|
|
270 |
$(buildObject "HvInfo" "hvInfo" |
|
272 | 271 |
[ simpleField "memory_total" [t| Int |] |
273 | 272 |
, simpleField "memory_free" [t| Int |] |
274 | 273 |
, simpleField "memory_dom0" [t| Int |] |
... | ... | |
277 | 276 |
, simpleField "cpu_sockets" [t| Int |] |
278 | 277 |
]) |
279 | 278 |
|
280 |
$(buildObject "RpcResultNodeInfo" "rpcResNodeInfo" $
|
|
279 |
$(buildObject "RpcResultNodeInfo" "rpcResNodeInfo" |
|
281 | 280 |
[ simpleField "boot_id" [t| String |] |
282 | 281 |
, simpleField "vg_info" [t| [VgInfo] |] |
283 | 282 |
, simpleField "hv_info" [t| [HvInfo] |] |
b/htools/lint-hints.hs | ||
---|---|---|
1 |
{- Custom hint lints for Ganeti. |
|
1 |
{-| Custom hint lints for Ganeti.
|
|
2 | 2 |
|
3 |
Since passing --hint to hlint will override, not extend the built-in hints, we need to import the existing hints so that we get full coverage. |
|
3 |
Since passing --hint to hlint will override, not extend the built-in |
|
4 |
hints, we need to import the existing hints so that we get full |
|
5 |
coverage. |
|
4 | 6 |
|
5 | 7 |
-} |
6 | 8 |
|
7 |
import "hint" HLint.Default
|
|
9 |
import "hint" HLint.HLint
|
|
8 | 10 |
import "hint" HLint.Dollar |
9 | 11 |
|
10 | 12 |
-- The following two hints warn to simplify e.g. "map (\v -> (v, |
Also available in: Unified diff