Revision dce9bbb3 htools/Ganeti/HTools/QC.hs
b/htools/Ganeti/HTools/QC.hs | ||
---|---|---|
146 | 146 |
, Instance.vcpus = Node.availCpu node `div` 2 |
147 | 147 |
} |
148 | 148 |
|
149 |
-- | Check if an instance is smaller than a node. |
|
150 |
isInstanceSmallerThanNode node inst = |
|
151 |
Instance.mem inst <= Node.availMem node `div` 2 && |
|
152 |
Instance.dsk inst <= Node.availDisk node `div` 2 && |
|
153 |
Instance.vcpus inst <= Node.availCpu node `div` 2 |
|
154 |
|
|
149 | 155 |
-- | Create an instance given its spec. |
150 | 156 |
createInstance mem dsk vcpus = |
151 | 157 |
Instance.create "inst-unnamed" mem dsk vcpus Types.Running [] True (-1) (-1) |
... | ... | |
223 | 229 |
let frest' = map (map dnsGetChar) frest |
224 | 230 |
return (felem ++ "." ++ intercalate "." frest') |
225 | 231 |
|
232 |
-- | Defines a tag type. |
|
233 |
newtype TagChar = TagChar { tagGetChar :: Char } |
|
234 |
|
|
235 |
-- | All valid tag chars. This doesn't need to match _exactly_ |
|
236 |
-- Ganeti's own tag regex, just enough for it to be close. |
|
237 |
tagChar :: [Char] |
|
238 |
tagChar = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ".+*/:@-" |
|
239 |
|
|
240 |
instance Arbitrary TagChar where |
|
241 |
arbitrary = do |
|
242 |
c <- elements tagChar |
|
243 |
return (TagChar c) |
|
244 |
|
|
245 |
-- | Generates a tag |
|
246 |
genTag :: Gen [TagChar] |
|
247 |
genTag = do |
|
248 |
-- the correct value would be C.maxTagLen, but that's way too |
|
249 |
-- verbose in unittests, and at the moment I don't see any possible |
|
250 |
-- bugs with longer tags and the way we use tags in htools |
|
251 |
n <- choose (1, 10) |
|
252 |
vector n |
|
253 |
|
|
254 |
-- | Generates a list of tags (correctly upper bounded). |
|
255 |
genTags :: Gen [String] |
|
256 |
genTags = do |
|
257 |
-- the correct value would be C.maxTagsPerObj, but per the comment |
|
258 |
-- in genTag, we don't use tags enough in htools to warrant testing |
|
259 |
-- such big values |
|
260 |
n <- choose (0, 10::Int) |
|
261 |
tags <- mapM (const genTag) [1..n] |
|
262 |
return $ map (map tagGetChar) tags |
|
263 |
|
|
226 | 264 |
instance Arbitrary Types.InstanceStatus where |
227 | 265 |
arbitrary = elements [minBound..maxBound] |
228 | 266 |
|
... | ... | |
732 | 770 |
where n = node { Node.failN1 = True, Node.offline = False |
733 | 771 |
, Node.iPolicy = Types.defIPolicy } |
734 | 772 |
|
773 |
-- | This property, while being in the text tests, does more than just |
|
774 |
-- test end-to-end the serialisation and loading back workflow; it |
|
775 |
-- also tests the Loader.mergeData and the actuall |
|
776 |
-- Cluster.iterateAlloc (for well-behaving w.r.t. instance |
|
777 |
-- allocations, not for the business logic). As such, it's a quite |
|
778 |
-- complex and slow test, and that's the reason we restrict it to |
|
779 |
-- small cluster sizes. |
|
780 |
prop_Text_CreateSerialise = |
|
781 |
forAll genTags $ \ctags -> |
|
782 |
forAll (choose (1, 2)) $ \reqnodes -> |
|
783 |
forAll (choose (1, 20)) $ \maxiter -> |
|
784 |
forAll (choose (2, 10)) $ \count -> |
|
785 |
forAll genOnlineNode $ \node -> |
|
786 |
forAll (arbitrary `suchThat` isInstanceSmallerThanNode node) $ \inst -> |
|
787 |
let inst' = Instance.setMovable inst $ Utils.if' (reqnodes == 2) True False |
|
788 |
nl = makeSmallCluster node count |
|
789 |
in case Cluster.genAllocNodes defGroupList nl reqnodes True >>= \allocn -> |
|
790 |
Cluster.iterateAlloc nl Container.empty (Just maxiter) inst' allocn [] [] |
|
791 |
of |
|
792 |
Types.Bad msg -> printTestCase ("Failed to allocate: " ++ msg) False |
|
793 |
Types.Ok (_, _, _, [], _) -> printTestCase |
|
794 |
"Failed to allocate: no allocations" False |
|
795 |
Types.Ok (_, nl', il', _, _) -> |
|
796 |
let cdata = Loader.ClusterData defGroupList nl' il' ctags |
|
797 |
Types.defIPolicy |
|
798 |
saved = Text.serializeCluster cdata |
|
799 |
in case Text.parseData saved >>= Loader.mergeData [] [] [] [] of |
|
800 |
Types.Bad msg -> printTestCase ("Failed to load/merge: " ++ |
|
801 |
msg) False |
|
802 |
Types.Ok (Loader.ClusterData gl2 nl2 il2 ctags2 cpol2) -> |
|
803 |
ctags ==? ctags2 .&&. |
|
804 |
Types.defIPolicy ==? cpol2 .&&. |
|
805 |
il' ==? il2 .&&. |
|
806 |
-- we need to override the policy manually for now for |
|
807 |
-- nodes and groups |
|
808 |
defGroupList ==? (Container.map (\g -> g { Group.iPolicy = |
|
809 |
nullIPolicy } ) |
|
810 |
gl2) .&&. |
|
811 |
nl' ==? Container.map (Node.setPolicy nullIPolicy) nl2 |
|
812 |
|
|
735 | 813 |
testSuite "Text" |
736 | 814 |
[ 'prop_Text_Load_Instance |
737 | 815 |
, 'prop_Text_Load_InstanceFail |
738 | 816 |
, 'prop_Text_Load_Node |
739 | 817 |
, 'prop_Text_Load_NodeFail |
740 | 818 |
, 'prop_Text_NodeLSIdempotent |
819 |
, 'prop_Text_CreateSerialise |
|
741 | 820 |
] |
742 | 821 |
|
743 | 822 |
-- ** Node tests |
Also available in: Unified diff