Revision 83846468

b/.ghci
1
:set -isrc -ihtest
1
:set -isrc -itest/hs
b/.gitignore
87 87
/man/*.gen
88 88
/man/footer.man
89 89

  
90
# htest
91
/htest/hail
92
/htest/hbal
93
/htest/hcheck
94
/htest/hinfo
95
/htest/hroller
96
/htest/hscan
97
/htest/hspace
98
/htest/hpc-htools
99
/htest/hpc-mon-collector
100
/htest/test
90
# test/hs
91
/test/hs/hail
92
/test/hs/hbal
93
/test/hs/hcheck
94
/test/hs/hinfo
95
/test/hs/hroller
96
/test/hs/hscan
97
/test/hs/hspace
98
/test/hs/hpc-htools
99
/test/hs/hpc-mon-collector
100
/test/hs/test
101 101

  
102 102
# tools
103 103
/tools/kvm-ifup
......
129 129
# automatically-built Haskell files
130 130
/src/Ganeti/Constants.hs
131 131
/src/Ganeti/Version.hs
132
/htest/Test/Ganeti/TestImports.hs
132
/test/hs/Test/Ganeti/TestImports.hs
b/Makefile.am
65 65
	src/Ganeti/HTools/Backend \
66 66
	src/Ganeti/HTools/Program \
67 67
	src/Ganeti/Query \
68
	htest \
69
	htest/Test \
70
	htest/Test/Ganeti \
71
	htest/Test/Ganeti/Block \
72
	htest/Test/Ganeti/Block/Drbd \
73
	htest/Test/Ganeti/Confd \
74
	htest/Test/Ganeti/HTools \
75
	htest/Test/Ganeti/HTools/Backend \
76
	htest/Test/Ganeti/Query
68
	test/hs \
69
	test/hs/Test \
70
	test/hs/Test/Ganeti \
71
	test/hs/Test/Ganeti/Block \
72
	test/hs/Test/Ganeti/Block/Drbd \
73
	test/hs/Test/Ganeti/Confd \
74
	test/hs/Test/Ganeti/HTools \
75
	test/hs/Test/Ganeti/HTools/Backend \
76
	test/hs/Test/Ganeti/Query
77 77

  
78 78
DIRS = \
79 79
	$(HS_DIRS) \
......
84 84
	doc/examples \
85 85
	doc/examples/gnt-debug \
86 86
	doc/examples/hooks \
87
	htest/data \
88
	htest/data/rapi \
89
	htest/shelltests \
87
	test/data/htools \
88
	test/data/htools/rapi \
89
	test/hs/shelltests \
90 90
	lib \
91 91
	lib/build \
92 92
	lib/client \
......
184 184
	$(HS_ALL_PROGS) $(HS_BUILT_SRCS) \
185 185
	$(HS_BUILT_TEST_HELPERS) \
186 186
	src/ganeti-confd \
187
	.hpc/*.mix src/*.tix htest/*.tix \
187
	.hpc/*.mix src/*.tix test/hs/*.tix \
188 188
	doc/hs-lint.html
189 189

  
190 190
GENERATED_FILES = \
......
415 415

  
416 416
HS_ALL_PROGS = \
417 417
	$(HS_PROGS) \
418
	htest/hpc-htools \
419
	htest/hpc-mon-collector \
420
	htest/test \
418
	test/hs/hpc-htools \
419
	test/hs/hpc-mon-collector \
420
	test/hs/test \
421 421
	src/hconfd \
422 422
	src/rpc-test
423 423

  
424 424
HS_PROG_SRCS = $(patsubst %,%.hs,$(HS_ALL_PROGS))
425
HS_BUILT_TEST_HELPERS = $(HS_BIN_ROLES:%=htest/%) htest/hail
425
HS_BUILT_TEST_HELPERS = $(HS_BIN_ROLES:%=test/hs/%) test/hs/hail
426 426

  
427 427
HFLAGS = \
428 428
	-O -Wall -Werror -isrc \
......
432 432

  
433 433
# extra flags that can be overriden on the command line (e.g. -Wwarn, etc.)
434 434
HEXTRA =
435
# internal extra flags (used for htest/test mainly)
435
# internal extra flags (used for test/hs/test mainly)
436 436
HEXTRA_INT =
437 437
# exclude options for coverage reports
438 438
HPCEXCL = --exclude Main \
......
515 515
	src/Ganeti/Utils.hs
516 516

  
517 517
HS_TEST_SRCS = \
518
	htest/Test/Ganeti/Attoparsec.hs \
519
	htest/Test/Ganeti/BasicTypes.hs \
520
	htest/Test/Ganeti/Block/Drbd/Parser.hs \
521
	htest/Test/Ganeti/Block/Drbd/Types.hs \
522
	htest/Test/Ganeti/Common.hs \
523
	htest/Test/Ganeti/Confd/Types.hs \
524
	htest/Test/Ganeti/Confd/Utils.hs \
525
	htest/Test/Ganeti/Daemon.hs \
526
	htest/Test/Ganeti/Errors.hs \
527
	htest/Test/Ganeti/HTools/Backend/Simu.hs \
528
	htest/Test/Ganeti/HTools/Backend/Text.hs \
529
	htest/Test/Ganeti/HTools/CLI.hs \
530
	htest/Test/Ganeti/HTools/Cluster.hs \
531
	htest/Test/Ganeti/HTools/Container.hs \
532
	htest/Test/Ganeti/HTools/Graph.hs \
533
	htest/Test/Ganeti/HTools/Instance.hs \
534
	htest/Test/Ganeti/HTools/Loader.hs \
535
	htest/Test/Ganeti/HTools/Node.hs \
536
	htest/Test/Ganeti/HTools/PeerMap.hs \
537
	htest/Test/Ganeti/HTools/Types.hs \
538
	htest/Test/Ganeti/JSON.hs \
539
	htest/Test/Ganeti/Jobs.hs \
540
	htest/Test/Ganeti/JQueue.hs \
541
	htest/Test/Ganeti/Luxi.hs \
542
	htest/Test/Ganeti/Network.hs \
543
	htest/Test/Ganeti/Objects.hs \
544
	htest/Test/Ganeti/OpCodes.hs \
545
	htest/Test/Ganeti/Query/Filter.hs \
546
	htest/Test/Ganeti/Query/Language.hs \
547
	htest/Test/Ganeti/Query/Query.hs \
548
	htest/Test/Ganeti/Rpc.hs \
549
	htest/Test/Ganeti/Ssconf.hs \
550
	htest/Test/Ganeti/THH.hs \
551
	htest/Test/Ganeti/TestCommon.hs \
552
	htest/Test/Ganeti/TestHTools.hs \
553
	htest/Test/Ganeti/TestHelper.hs \
554
	htest/Test/Ganeti/Types.hs \
555
	htest/Test/Ganeti/Utils.hs
518
	test/hs/Test/Ganeti/Attoparsec.hs \
519
	test/hs/Test/Ganeti/BasicTypes.hs \
520
	test/hs/Test/Ganeti/Block/Drbd/Parser.hs \
521
	test/hs/Test/Ganeti/Block/Drbd/Types.hs \
522
	test/hs/Test/Ganeti/Common.hs \
523
	test/hs/Test/Ganeti/Confd/Types.hs \
524
	test/hs/Test/Ganeti/Confd/Utils.hs \
525
	test/hs/Test/Ganeti/Daemon.hs \
526
	test/hs/Test/Ganeti/Errors.hs \
527
	test/hs/Test/Ganeti/HTools/Backend/Simu.hs \
528
	test/hs/Test/Ganeti/HTools/Backend/Text.hs \
529
	test/hs/Test/Ganeti/HTools/CLI.hs \
530
	test/hs/Test/Ganeti/HTools/Cluster.hs \
531
	test/hs/Test/Ganeti/HTools/Container.hs \
532
	test/hs/Test/Ganeti/HTools/Graph.hs \
533
	test/hs/Test/Ganeti/HTools/Instance.hs \
534
	test/hs/Test/Ganeti/HTools/Loader.hs \
535
	test/hs/Test/Ganeti/HTools/Node.hs \
536
	test/hs/Test/Ganeti/HTools/PeerMap.hs \
537
	test/hs/Test/Ganeti/HTools/Types.hs \
538
	test/hs/Test/Ganeti/JSON.hs \
539
	test/hs/Test/Ganeti/Jobs.hs \
540
	test/hs/Test/Ganeti/JQueue.hs \
541
	test/hs/Test/Ganeti/Luxi.hs \
542
	test/hs/Test/Ganeti/Network.hs \
543
	test/hs/Test/Ganeti/Objects.hs \
544
	test/hs/Test/Ganeti/OpCodes.hs \
545
	test/hs/Test/Ganeti/Query/Filter.hs \
546
	test/hs/Test/Ganeti/Query/Language.hs \
547
	test/hs/Test/Ganeti/Query/Query.hs \
548
	test/hs/Test/Ganeti/Rpc.hs \
549
	test/hs/Test/Ganeti/Ssconf.hs \
550
	test/hs/Test/Ganeti/THH.hs \
551
	test/hs/Test/Ganeti/TestCommon.hs \
552
	test/hs/Test/Ganeti/TestHTools.hs \
553
	test/hs/Test/Ganeti/TestHelper.hs \
554
	test/hs/Test/Ganeti/Types.hs \
555
	test/hs/Test/Ganeti/Utils.hs
556 556

  
557 557
HS_LIBTEST_SRCS = $(HS_LIB_SRCS) $(HS_TEST_SRCS)
558 558

  
559 559
HS_BUILT_SRCS = \
560
	htest/Test/Ganeti/TestImports.hs \
560
	test/hs/Test/Ganeti/TestImports.hs \
561 561
	src/Ganeti/Constants.hs \
562 562
	src/Ganeti/Version.hs
563 563
HS_BUILT_SRCS_IN = $(patsubst %,%.in,$(HS_BUILT_SRCS))
......
684 684
	  $(HEXTRA) $(HEXTRA_INT) $@
685 685
	@touch "$@"
686 686

  
687
# for the htest/test binary, we need to enable profiling/coverage
688
htest/test: HEXTRA_INT=-fhpc -ihtest
687
# for the test/hs/test binary, we need to enable profiling/coverage
688
test/hs/test: HEXTRA_INT=-fhpc -itest/hs
689 689

  
690 690
# we compile the hpc-htools binary with the program coverage
691
htest/hpc-htools: HEXTRA_INT=-fhpc
691
test/hs/hpc-htools: HEXTRA_INT=-fhpc
692 692

  
693 693
# we compile the hpc-mon-collector binary with the program coverage
694
htest/hpc-mon-collector: HEXTRA_INT=-fhpc
694
test/hs/hpc-mon-collector: HEXTRA_INT=-fhpc
695 695

  
696 696
# test dependency
697
htest/offline-tests.sh: htest/hpc-htools htest/hpc-mon-collector
697
test/hs/offline-tests.sh: test/hs/hpc-htools test/hs/hpc-mon-collector
698 698

  
699 699
# rules for building profiling-enabled versions of the haskell
700 700
# programs: hs-prof does the full two-step build, whereas
......
828 828
	$(HS_LIBTEST_SRCS) $(HS_BUILT_SRCS_IN) \
829 829
	$(HS_PROG_SRCS) \
830 830
	src/lint-hints.hs \
831
	htest/cli-tests-defs.sh \
832
	htest/offline-test.sh \
831
	test/hs/cli-tests-defs.sh \
832
	test/hs/offline-test.sh \
833 833
	.ghci
834 834

  
835 835
man_MANS = \
......
872 872
	man/footer.man man/footer.html $(mangen)
873 873

  
874 874
TEST_FILES = \
875
	htest/data/clean-nonzero-score.data \
876
	htest/data/common-suffix.data \
877
	htest/data/empty-cluster.data \
878
	htest/data/hail-alloc-drbd.json \
879
	htest/data/hail-change-group.json \
880
	htest/data/hail-invalid-reloc.json \
881
	htest/data/hail-node-evac.json \
882
	htest/data/hail-reloc-drbd.json \
883
	htest/data/hbal-excl-tags.data \
884
	htest/data/hbal-split-insts.data \
885
	htest/data/invalid-node.data \
886
	htest/data/missing-resources.data \
887
	htest/data/n1-failure.data \
888
	htest/data/rapi/groups.json \
889
	htest/data/rapi/info.json \
890
	htest/data/rapi/instances.json \
891
	htest/data/rapi/nodes.json \
892
	htest/shelltests/htools-balancing.test \
893
	htest/shelltests/htools-basic.test \
894
	htest/shelltests/htools-dynutil.test \
895
	htest/shelltests/htools-excl.test \
896
	htest/shelltests/htools-hail.test \
897
	htest/shelltests/htools-hspace.test \
898
	htest/shelltests/htools-invalid.test \
899
	htest/shelltests/htools-multi-group.test \
900
	htest/shelltests/htools-no-backend.test \
901
	htest/shelltests/htools-rapi.test \
902
	htest/shelltests/htools-single-group.test \
903
	htest/shelltests/htools-text-backend.test \
904
	htest/shelltests/htools-mon-collector.test \
875
	test/data/htools/clean-nonzero-score.data \
876
	test/data/htools/common-suffix.data \
877
	test/data/htools/empty-cluster.data \
878
	test/data/htools/hail-alloc-drbd.json \
879
	test/data/htools/hail-change-group.json \
880
	test/data/htools/hail-invalid-reloc.json \
881
	test/data/htools/hail-node-evac.json \
882
	test/data/htools/hail-reloc-drbd.json \
883
	test/data/htools/hbal-excl-tags.data \
884
	test/data/htools/hbal-split-insts.data \
885
	test/data/htools/invalid-node.data \
886
	test/data/htools/missing-resources.data \
887
	test/data/htools/n1-failure.data \
888
	test/data/htools/rapi/groups.json \
889
	test/data/htools/rapi/info.json \
890
	test/data/htools/rapi/instances.json \
891
	test/data/htools/rapi/nodes.json \
892
	test/hs/shelltests/htools-balancing.test \
893
	test/hs/shelltests/htools-basic.test \
894
	test/hs/shelltests/htools-dynutil.test \
895
	test/hs/shelltests/htools-excl.test \
896
	test/hs/shelltests/htools-hail.test \
897
	test/hs/shelltests/htools-hspace.test \
898
	test/hs/shelltests/htools-invalid.test \
899
	test/hs/shelltests/htools-multi-group.test \
900
	test/hs/shelltests/htools-no-backend.test \
901
	test/hs/shelltests/htools-rapi.test \
902
	test/hs/shelltests/htools-single-group.test \
903
	test/hs/shelltests/htools-text-backend.test \
904
	test/hs/shelltests/htools-mon-collector.test \
905 905
	test/data/bdev-drbd-8.0.txt \
906 906
	test/data/bdev-drbd-8.3.txt \
907 907
	test/data/bdev-drbd-disk.txt \
......
1040 1040
	test/py/qa.qa_config_unittest.py \
1041 1041
	test/py/tempfile_fork_unittest.py
1042 1042

  
1043
haskell_tests = htest/test
1043
haskell_tests = test/hs/test
1044 1044

  
1045 1045
dist_TESTS = \
1046 1046
	test/py/check-cert-expired_unittest.bash \
......
1056 1056

  
1057 1057
if WANT_HSTESTS
1058 1058
nodist_TESTS += $(haskell_tests)
1059
dist_TESTS += htest/offline-test.sh
1059
dist_TESTS += test/hs/offline-test.sh
1060 1060
check_SCRIPTS += \
1061
	htest/hpc-htools \
1062
	htest/hpc-mon-collector \
1061
	test/hs/hpc-htools \
1062
	test/hs/hpc-mon-collector \
1063 1063
	$(HS_BUILT_TEST_HELPERS)
1064 1064
endif
1065 1065

  
......
1106 1106
	test/py/import-export_unittest.bash \
1107 1107
	test/py/cli-test.bash \
1108 1108
	test/py/bash_completion.bash \
1109
	htest/offline-test.sh \
1110
	htest/cli-tests-defs.sh \
1109
	test/hs/offline-test.sh \
1110
	test/hs/cli-tests-defs.sh \
1111 1111
	$(all_python_code) \
1112 1112
	$(HS_LIBTEST_SRCS) $(HS_PROG_SRCS)
1113 1113

  
......
1269 1269
	  PYTHONPATH=. $(RUN_IN_TEMPDIR) $(CURDIR)/$(CONVERT_CONSTANTS); \
1270 1270
	} > $@
1271 1271

  
1272
htest/Test/Ganeti/TestImports.hs: htest/Test/Ganeti/TestImports.hs.in \
1272
test/hs/Test/Ganeti/TestImports.hs: test/hs/Test/Ganeti/TestImports.hs.in \
1273 1273
	$(built_base_sources)
1274 1274
	set -e; \
1275 1275
	{ cat $< ; \
......
1433 1433
tools/node-daemon-setup: MODULE = ganeti.tools.node_daemon_setup
1434 1434
tools/prepare-node-join: MODULE = ganeti.tools.prepare_node_join
1435 1435
tools/node-cleanup: MODULE = ganeti.tools.node_cleanup
1436
$(HS_BUILT_TEST_HELPERS): TESTROLE = $(patsubst htest/%,%,$@)
1436
$(HS_BUILT_TEST_HELPERS): TESTROLE = $(patsubst test/hs/%,%,$@)
1437 1437

  
1438 1438
$(PYTHON_BOOTSTRAP): Makefile | stamp-directories
1439 1439
	test -n "$(MODULE)" || { echo Missing module; exit 1; }
......
1469 1469
	  echo '# This file is automatically generated, do not edit!'; \
1470 1470
	  echo "# Edit Makefile.am instead."; \
1471 1471
	  echo; \
1472
	  echo "HTOOLS=$(TESTROLE) exec ./htest/hpc-htools \"\$$@\""; \
1472
	  echo "HTOOLS=$(TESTROLE) exec ./test/hs/hpc-htools \"\$$@\""; \
1473 1473
	} > $@
1474 1474
	chmod u+x $@
1475 1475

  
......
1552 1552
	test -z "$$error"
1553 1553

  
1554 1554
.PHONY: hs-check
1555
hs-check: htest/test htest/hpc-htools htest/hpc-mon-collector $(HS_BUILT_TEST_HELPERS) \
1555
hs-check: test/hs/test test/hs/hpc-htools test/hs/hpc-mon-collector $(HS_BUILT_TEST_HELPERS) \
1556 1556
	| $(BUILT_PYTHON_SOURCES)
1557 1557
	@rm -f *.tix
1558
	./htest/test
1559
	HBINARY="./htest/hpc-htools" ./htest/offline-test.sh
1558
	./test/hs/test
1559
	HBINARY="./test/hs/hpc-htools" ./test/hs/offline-test.sh
1560 1560

  
1561 1561
# E111: indentation is not a multiple of four
1562 1562
# E121: continuation line indentation is not a multiple of four
......
1606 1606
	  --repeat $(pep8_python_code)
1607 1607

  
1608 1608
# FIXME: remove ignore "Use void" when GHC 6.x is deprecated
1609
HLINT_EXCLUDES = src/Ganeti/THH.hs htest/hpc-htools.hs
1609
HLINT_EXCLUDES = src/Ganeti/THH.hs test/hs/hpc-htools.hs
1610 1610
.PHONY: hlint
1611 1611
hlint: $(HS_BUILT_SRCS) src/lint-hints.hs
1612 1612
	@test -n "$(HLINT)" || { echo 'hlint' not found during configure; exit 1; }
......
1768 1768
	$(python_tests)
1769 1769

  
1770 1770
.PHONY: hs-coverage
1771
hs-coverage: $(haskell_tests) htest/hpc-htools htest/hpc-mon-collector
1771
hs-coverage: $(haskell_tests) test/hs/hpc-htools test/hs/hpc-mon-collector
1772 1772
	rm -f *.tix
1773 1773
	$(MAKE) $(AM_MAKEFLAGS) hs-check
1774 1774
	@mkdir_p@ $(COVERAGE_HS_DIR)
b/autotools/run-in-tempdir
8 8
tmpdir=$(mktemp -d -t gntbuild.XXXXXXXX)
9 9
trap "rm -rf $tmpdir" EXIT
10 10

  
11
mkdir $tmpdir/doc
11
# fully copy items
12
cp -r autotools daemons scripts lib tools qa $tmpdir
12 13

  
13
cp -r autotools daemons scripts lib tools test qa $tmpdir
14
mkdir $tmpdir/doc
14 15
ln -s $PWD/doc/examples $tmpdir/doc
15 16

  
17
mkdir $tmpdir/test/
18
cp -r test/py $tmpdir/test/py
19
ln -s $PWD/test/data $tmpdir/test
20
ln -s $PWD/test/hs $tmpdir/test
21

  
16 22
mv $tmpdir/lib $tmpdir/ganeti
17 23
ln -T -s $tmpdir/ganeti $tmpdir/lib
18 24

  
19
mkdir -p $tmpdir/src $tmpdir/htest
25
mkdir -p $tmpdir/src $tmpdir/test/hs
20 26
for hfile in htools ganeti-confd mon-collector; do
21 27
  if [ -e src/$hfile ]; then
22 28
    ln -s $PWD/src/$hfile $tmpdir/src/
23 29
  fi
24 30
done
25 31

  
26
for hfile in hpc-htools test offline-test.sh cli-tests-defs.sh \
27
  hbal hscan hspace hinfo hcheck hail hroller hpc-mon-collector; do
28
  if [ -e htest/$hfile ]; then
29
    ln -s $PWD/htest/$hfile $tmpdir/htest/
30
  fi
31
done
32

  
33 32
cd $tmpdir && GANETI_TEMP_DIR="$tmpdir" "$@"
b/doc/devnotes.rst
180 180

  
181 181
For Haskell tests::
182 182

  
183
  $ make htest/test && ./htest/test -t %pattern%
183
  $ make test/hs/test && ./test/hs/test -t %pattern%
184 184

  
185 185
Where ``pattern`` can be a simple test pattern (e.g. ``comma``,
186 186
matching any test whose name contains ``comma``), a test pattern
/dev/null
1
{-# LANGUAGE TemplateHaskell #-}
2

  
3
{-| Unittests for Attoparsec support for unicode -}
4

  
5
{-
6

  
7
Copyright (C) 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
module Test.Ganeti.Attoparsec (testAttoparsec) where
27

  
28
import Test.HUnit
29

  
30
import Test.Ganeti.TestHelper
31

  
32
import qualified Data.Attoparsec.Text as A
33
import Data.Attoparsec.Text (Parser)
34
import Data.Text (pack, unpack)
35

  
36
-- | Unicode test string, first part.
37
part1 :: String
38
part1 = "äßĉ"
39

  
40
-- | Unicode test string, second part.
41
part2 :: String
42
part2 = "ðèق"
43

  
44
-- | Simple parser able to split a string in two parts, name and
45
-- value, separated by a '=' sign.
46
simpleParser :: Parser (String, String)
47
simpleParser = do
48
  n <- A.takeTill (\c -> A.isHorizontalSpace c || c == '=')
49
  A.skipWhile A.isHorizontalSpace
50
  _ <- A.char '='
51
  A.skipWhile A.isHorizontalSpace
52
  v <- A.takeTill A.isEndOfLine
53
  return (unpack n, unpack v)
54

  
55
{-# ANN case_unicodeParsing "HLint: ignore Use camelCase" #-}
56
-- | Tests whether a Unicode string is still Unicode after being
57
-- parsed.
58
case_unicodeParsing :: Assertion
59
case_unicodeParsing =
60
  case A.parseOnly simpleParser text of
61
    Right (name, value) -> do
62
      assertEqual "name part" part1 name
63
      assertEqual "value part" part2 value
64
    Left msg -> assertFailure $ "Failed to parse: " ++ msg
65
  where text = Data.Text.pack $ part1 ++ "  = \t" ++ part2
66

  
67
testSuite "Attoparsec"
68
          [ 'case_unicodeParsing
69
          ]
/dev/null
1
{-# LANGUAGE TemplateHaskell, FlexibleInstances, TypeSynonymInstances #-}
2
{-# OPTIONS_GHC -fno-warn-orphans #-}
3

  
4
{-| Unittests for ganeti-htools.
5

  
6
-}
7

  
8
{-
9

  
10
Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
11

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

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

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

  
27
-}
28

  
29
module Test.Ganeti.BasicTypes (testBasicTypes) where
30

  
31
import Test.QuickCheck hiding (Result)
32
import Test.QuickCheck.Function
33

  
34
import Control.Applicative
35
import Control.Monad
36

  
37
import Test.Ganeti.TestHelper
38
import Test.Ganeti.TestCommon
39

  
40
import Ganeti.BasicTypes
41

  
42
-- Since we actually want to test these, don't tell us not to use them :)
43

  
44
{-# ANN module "HLint: ignore Functor law" #-}
45
{-# ANN module "HLint: ignore Monad law, left identity" #-}
46
{-# ANN module "HLint: ignore Monad law, right identity" #-}
47
{-# ANN module "HLint: ignore Use >=>" #-}
48
{-# ANN module "HLint: ignore Use ." #-}
49

  
50
-- * Arbitrary instances
51

  
52
instance (Arbitrary a) => Arbitrary (Result a) where
53
  arbitrary = oneof [ Bad <$> arbitrary
54
                    , Ok  <$> arbitrary
55
                    ]
56

  
57
-- * Test cases
58

  
59
-- | Tests the functor identity law (fmap id == id).
60
prop_functor_id :: Result Int -> Property
61
prop_functor_id ri =
62
  fmap id ri ==? ri
63

  
64
-- | Tests the functor composition law (fmap (f . g)  ==  fmap f . fmap g).
65
prop_functor_composition :: Result Int
66
                         -> Fun Int Int -> Fun Int Int -> Property
67
prop_functor_composition ri (Fun _ f) (Fun _ g) =
68
  fmap (f . g) ri ==? (fmap f . fmap g) ri
69

  
70
-- | Tests the applicative identity law (pure id <*> v = v).
71
prop_applicative_identity :: Result Int -> Property
72
prop_applicative_identity v =
73
  pure id <*> v ==? v
74

  
75
-- | Tests the applicative composition law (pure (.) <*> u <*> v <*> w
76
-- = u <*> (v <*> w)).
77
prop_applicative_composition :: Result (Fun Int Int)
78
                             -> Result (Fun Int Int)
79
                             -> Result Int
80
                             -> Property
81
prop_applicative_composition u v w =
82
  let u' = fmap apply u
83
      v' = fmap apply v
84
  in pure (.) <*> u' <*> v' <*> w ==? u' <*> (v' <*> w)
85

  
86
-- | Tests the applicative homomorphism law (pure f <*> pure x = pure (f x)).
87
prop_applicative_homomorphism :: Fun Int Int -> Int -> Property
88
prop_applicative_homomorphism (Fun _ f) x =
89
  ((pure f <*> pure x)::Result Int) ==? pure (f x)
90

  
91
-- | Tests the applicative interchange law (u <*> pure y = pure ($ y) <*> u).
92
prop_applicative_interchange :: Result (Fun Int Int)
93
                             -> Int -> Property
94
prop_applicative_interchange f y =
95
  let u = fmap apply f -- need to extract the actual function from Fun
96
  in u <*> pure y ==? pure ($ y) <*> u
97

  
98
-- | Tests the applicative\/functor correspondence (fmap f x = pure f <*> x).
99
prop_applicative_functor :: Fun Int Int -> Result Int -> Property
100
prop_applicative_functor (Fun _ f) x =
101
  fmap f x ==? pure f <*> x
102

  
103
-- | Tests the applicative\/monad correspondence (pure = return and
104
-- (<*>) = ap).
105
prop_applicative_monad :: Int -> Result (Fun Int Int) -> Property
106
prop_applicative_monad v f =
107
  let v' = pure v :: Result Int
108
      f' = fmap apply f -- need to extract the actual function from Fun
109
  in v' ==? return v .&&. (f' <*> v') ==? f' `ap` v'
110

  
111
-- | Tests the monad laws (return a >>= k == k a, m >>= return == m, m
112
-- >>= (\x -> k x >>= h) == (m >>= k) >>= h).
113
prop_monad_laws :: Int -> Result Int
114
                -> Fun Int (Result Int)
115
                -> Fun Int (Result Int)
116
                -> Property
117
prop_monad_laws a m (Fun _ k) (Fun _ h) =
118
  conjoin
119
  [ printTestCase "return a >>= k == k a" ((return a >>= k) ==? k a)
120
  , printTestCase "m >>= return == m" ((m >>= return) ==? m)
121
  , printTestCase "m >>= (\\x -> k x >>= h) == (m >>= k) >>= h)"
122
    ((m >>= (\x -> k x >>= h)) ==? ((m >>= k) >>= h))
123
  ]
124

  
125
-- | Tests the monad plus laws ( mzero >>= f = mzero, v >> mzero = mzero).
126
prop_monadplus_mzero :: Result Int -> Fun Int (Result Int) -> Property
127
prop_monadplus_mzero v (Fun _ f) =
128
  printTestCase "mzero >>= f = mzero" ((mzero >>= f) ==? mzero) .&&.
129
  -- FIXME: since we have "many" mzeros, we can't test for equality,
130
  -- just that we got back a 'Bad' value; I'm not sure if this means
131
  -- our MonadPlus instance is not sound or not...
132
  printTestCase "v >> mzero = mzero" (isBad (v >> mzero))
133

  
134
testSuite "BasicTypes"
135
  [ 'prop_functor_id
136
  , 'prop_functor_composition
137
  , 'prop_applicative_identity
138
  , 'prop_applicative_composition
139
  , 'prop_applicative_homomorphism
140
  , 'prop_applicative_interchange
141
  , 'prop_applicative_functor
142
  , 'prop_applicative_monad
143
  , 'prop_monad_laws
144
  , 'prop_monadplus_mzero
145
  ]
/dev/null
1
{-# LANGUAGE TemplateHaskell #-}
2

  
3
{-| Unittests for Attoparsec support for unicode -}
4

  
5
{-
6

  
7
Copyright (C) 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
module Test.Ganeti.Block.Drbd.Parser (testBlock_Drbd_Parser) where
27

  
28
import Test.QuickCheck as QuickCheck hiding (Result)
29
import Test.HUnit
30

  
31
import Test.Ganeti.TestHelper
32
import Test.Ganeti.TestCommon
33

  
34
import qualified Data.Attoparsec.Text as A
35
import Data.List (intercalate)
36
import Data.Text (pack)
37

  
38
import Ganeti.Block.Drbd.Parser (drbdStatusParser, commaIntParser)
39
import Ganeti.Block.Drbd.Types
40

  
41
{-# ANN module "HLint: ignore Use camelCase" #-}
42

  
43
-- | Function for testing whether a file is parsed correctly.
44
testFile :: String -> DRBDStatus -> Assertion
45
testFile fileName expectedContent = do
46
    fileContent <- readPythonTestData fileName
47
    case A.parseOnly drbdStatusParser $ pack fileContent of
48
        Left msg -> assertFailure $ "Parsing failed: " ++ msg
49
        Right obtained -> assertEqual fileName expectedContent obtained
50

  
51
-- | Test a DRBD 8.0 file with an empty line inside.
52
case_drbd80_emptyline :: Assertion
53
case_drbd80_emptyline = testFile "proc_drbd80-emptyline.txt" $
54
  DRBDStatus
55
    ( VersionInfo Nothing Nothing Nothing Nothing
56
        (Just "5c9f89594553e32adb87d9638dce591782f947e3")
57
        (Just "root@node1.example.com, 2009-05-22 12:47:52")
58
    )
59
    [ DeviceInfo 0 Connected (LocalRemote Primary Secondary)
60
        (LocalRemote UpToDate UpToDate) 'C' "r---"
61
        (PerfIndicators 78728316 0 77675644 1277039 254 270 0 0 0 0
62
          Nothing Nothing Nothing)
63
        Nothing
64
        (Just $ AdditionalInfo 0 61 65657 135 0 0 135)
65
        (Just $ AdditionalInfo 0 257 11378843 254 0 0 254),
66
      UnconfiguredDevice 1,
67
      UnconfiguredDevice 2,
68
      UnconfiguredDevice 5,
69
      UnconfiguredDevice 6
70
    ]
71

  
72
-- | Test a DRBD 8.3 file with a NULL caracter inside.
73
case_drbd83_sync_krnl2_6_39 :: Assertion
74
case_drbd83_sync_krnl2_6_39 = testFile "proc_drbd83_sync_krnl2.6.39.txt" $
75
  DRBDStatus
76
    ( VersionInfo (Just "8.3.1") (Just "88") (Just "86-89") Nothing
77
        (Just "fd40f4a8f9104941537d1afc8521e584a6d3003c")
78
        (Just "phil@fat-tyre, 2009-03-27 12:19:49")
79
    )
80
    [ DeviceInfo 0 Connected (LocalRemote Primary Secondary)
81
        (LocalRemote UpToDate UpToDate) 'C' "r----"
82
        (PerfIndicators 140978 0 9906 131533 27 8 0 0 0 0 (Just 1)
83
          (Just 'b') (Just 0))
84
        Nothing
85
        Nothing
86
        Nothing,
87
      DeviceInfo 1 Connected (LocalRemote Secondary Primary)
88
        (LocalRemote UpToDate UpToDate) 'C' "r---"
89
        (PerfIndicators 0 140980 140980 0 0 8 0 0 0 0 (Just 1) (Just 'f')
90
          (Just 0))
91
        Nothing
92
        Nothing
93
        Nothing,
94
      UnconfiguredDevice 2,
95
      DeviceInfo 3 SyncSource (LocalRemote Primary Secondary)
96
        (LocalRemote UpToDate Inconsistent) 'A' "r-----"
97
        (PerfIndicators 373888 0 0 374088 0 22 7 27 7 0 (Just 1)
98
          (Just 'f') (Just 15358208))
99
        (Just $ SyncStatus 2.4 14996 15360 MegaByte (Time 0 4 8) 61736 Nothing
100
          KiloByte Second)
101
        Nothing
102
        Nothing,
103
      DeviceInfo 4 WFConnection (LocalRemote Primary Unknown)
104
        (LocalRemote UpToDate DUnknown) 'C' "r----"
105
        (PerfIndicators 140978 0 9906 131534 27 8 0 0 0 0 (Just 1)
106
          (Just 'b') (Just 0))
107
        Nothing
108
        Nothing
109
        Nothing
110
    ]
111

  
112
-- | Test a DRBD 8.3 file with an ongoing synchronization.
113
case_drbd83_sync :: Assertion
114
case_drbd83_sync = testFile "proc_drbd83_sync.txt" $
115
  DRBDStatus
116
    ( VersionInfo (Just "8.3.1") (Just "88") (Just "86-89") Nothing
117
        (Just "fd40f4a8f9104941537d1afc8521e584a6d3003c")
118
        (Just "phil@fat-tyre, 2009-03-27 12:19:49")
119
    )
120
    [ DeviceInfo 0 Connected (LocalRemote Primary Secondary)
121
        (LocalRemote UpToDate UpToDate) 'C' "r----"
122
        (PerfIndicators 140978 0 9906 131533 27 8 0 0 0 0 (Just 1)
123
          (Just 'b') (Just 0))
124
        Nothing
125
        Nothing
126
        Nothing,
127
      DeviceInfo 1 Connected (LocalRemote Secondary Primary)
128
        (LocalRemote UpToDate UpToDate) 'C' "r---"
129
        (PerfIndicators 0 140980 140980 0 0 8 0 0 0 0 (Just 1) (Just 'f')
130
          (Just 0))
131
        Nothing
132
        Nothing
133
        Nothing,
134
      UnconfiguredDevice 2,
135
      DeviceInfo 3 SyncTarget (LocalRemote Primary Secondary)
136
        (LocalRemote Inconsistent UpToDate) 'C' "r----"
137
        (PerfIndicators 0 178176 178176 0 104 42 0 0 0 0 (Just 1)
138
          (Just 'b') (Just 346112))
139
        (Just $ SyncStatus 34.9 346112 524288 MegaByte (Time 0 0 5) 59392
140
          Nothing KiloByte Second)
141
        Nothing
142
        Nothing,
143
      DeviceInfo 4 WFConnection (LocalRemote Primary Unknown)
144
        (LocalRemote UpToDate DUnknown) 'C' "r----"
145
        (PerfIndicators 140978 0 9906 131534 27 8 0 0 0 0 (Just 1)
146
          (Just 'b') (Just 0))
147
        Nothing
148
        Nothing
149
        Nothing
150
    ]
151

  
152
-- | Test a DRBD 8.3 file not from git sources, with an ongoing synchronization
153
-- and the "want" field
154
case_drbd83_sync_want :: Assertion
155
case_drbd83_sync_want = testFile "proc_drbd83_sync_want.txt" $
156
  DRBDStatus
157
    ( VersionInfo (Just "8.3.11") (Just "88") (Just "86-96")
158
        (Just "2D876214BAAD53B31ADC1D6")
159
        Nothing Nothing
160
    )
161
    [ DeviceInfo 0 SyncTarget (LocalRemote Secondary Primary)
162
        (LocalRemote Inconsistent UpToDate) 'C' "r-----"
163
        (PerfIndicators 0 460288 460160 0 0 28 2 4 1 0 (Just 1)
164
          (Just 'f') (Just 588416))
165
        (Just $ SyncStatus 44.4 588416 1048576 KiloByte (Time 0 0 8) 65736
166
          (Just 61440) KiloByte Second)
167
        Nothing
168
        Nothing,
169
      UnconfiguredDevice 1,
170
      UnconfiguredDevice 2,
171
      UnconfiguredDevice 3
172
    ]
173

  
174
-- | Test a DRBD 8.3 file.
175
case_drbd83 :: Assertion
176
case_drbd83 = testFile "proc_drbd83.txt" $
177
  DRBDStatus
178
    ( VersionInfo (Just "8.3.1") (Just "88") (Just "86-89")
179
      Nothing
180
      (Just "fd40f4a8f9104941537d1afc8521e584a6d3003c")
181
      (Just "phil@fat-tyre, 2009-03-27 12:19:49")
182
    )
183
    [ DeviceInfo 0 Connected (LocalRemote Primary Secondary)
184
        (LocalRemote UpToDate UpToDate) 'C' "r----"
185
        (PerfIndicators 140978 0 9906 131533 27 8 0 0 0 0 (Just 1)
186
          (Just 'b') (Just 0))
187
        Nothing
188
        Nothing
189
        Nothing,
190
      DeviceInfo 1 Connected (LocalRemote Secondary Primary)
191
        (LocalRemote UpToDate UpToDate) 'C' "r---"
192
        (PerfIndicators 0 140980 140980 0 0 8 0 0 0 0 (Just 1) (Just 'f')
193
          (Just 0))
194
        Nothing
195
        Nothing
196
        Nothing,
197
      UnconfiguredDevice 2,
198
      DeviceInfo 4 WFConnection (LocalRemote Primary Unknown)
199
        (LocalRemote UpToDate DUnknown) 'C' "r----"
200
        (PerfIndicators 140978 0 9906 131534 27 8 0 0 0 0 (Just 1)
201
          (Just 'b') (Just 0))
202
        Nothing
203
        Nothing
204
        Nothing,
205
      DeviceInfo 5 Connected (LocalRemote Primary Secondary)
206
        (LocalRemote UpToDate Diskless) 'C' "r----"
207
        (PerfIndicators 140978 0 9906 131533 19 8 0 0 0 0 (Just 1)
208
          (Just 'b') (Just 0))
209
        Nothing
210
        Nothing
211
        Nothing,
212
      DeviceInfo 6 Connected (LocalRemote Secondary Primary)
213
        (LocalRemote Diskless UpToDate) 'C' "r---"
214
        (PerfIndicators 0 140978 140978 0 0 8 0 0 0 0 (Just 1) (Just 'f')
215
          (Just 0))
216
        Nothing
217
        Nothing
218
        Nothing,
219
      DeviceInfo 7 WFConnection (LocalRemote Secondary Unknown)
220
        (LocalRemote UpToDate DUnknown) 'C' "r---"
221
        (PerfIndicators 0 140978 140978 0 0 8 0 0 0 0 (Just 1) (Just 'f')
222
          (Just 0))
223
        Nothing
224
        Nothing
225
        Nothing,
226
      DeviceInfo 8 StandAlone (LocalRemote Secondary Unknown)
227
        (LocalRemote UpToDate DUnknown) ' ' "r---"
228
        (PerfIndicators 0 140978 140978 0 0 8 0 0 0 0 (Just 1)
229
          (Just 'f') (Just 0))
230
        Nothing
231
        Nothing
232
        Nothing
233
    ]
234

  
235
-- | Test a DRBD 8.0 file with a missing device.
236
case_drbd8 :: Assertion
237
case_drbd8 = testFile "proc_drbd8.txt" $
238
  DRBDStatus
239
    ( VersionInfo (Just "8.0.12") (Just "86") (Just "86") Nothing
240
        (Just "5c9f89594553e32adb87d9638dce591782f947e3")
241
        (Just "XXX")
242
    )
243
    [ DeviceInfo 0 Connected (LocalRemote Primary Secondary)
244
        (LocalRemote UpToDate UpToDate) 'C' "r---"
245
        (PerfIndicators 4375577 0 4446279 674 1067 69 0 0 0 0 Nothing
246
          Nothing Nothing)
247
        Nothing
248
        (Just $ AdditionalInfo 0 61 0 0 0 0 0)
249
        (Just $ AdditionalInfo 0 257 793749 1067 0 0 1067),
250
      DeviceInfo 1 Connected (LocalRemote Secondary Primary)
251
        (LocalRemote UpToDate UpToDate) 'C' "r---"
252
        (PerfIndicators 738320 0 738320 554400 67 0 0 0 0 0 Nothing
253
          Nothing Nothing)
254
        Nothing
255
        (Just $ AdditionalInfo 0 61 0 0 0 0 0)
256
        (Just $ AdditionalInfo 0 257 92464 67 0 0 67),
257
      UnconfiguredDevice 2,
258
      DeviceInfo 4 WFConnection (LocalRemote Primary Unknown)
259
        (LocalRemote UpToDate DUnknown) 'C' "r---"
260
        (PerfIndicators 738320 0 738320 554400 67 0 0 0 0 0 Nothing
261
          Nothing Nothing)
262
        Nothing
263
        (Just $ AdditionalInfo 0 61 0 0 0 0 0)
264
        (Just $ AdditionalInfo 0 257 92464 67 0 0 67),
265
      DeviceInfo 5 Connected (LocalRemote Primary Secondary)
266
        (LocalRemote UpToDate Diskless) 'C' "r---"
267
        (PerfIndicators 4375581 0 4446283 674 1069 69 0 0 0 0 Nothing
268
          Nothing Nothing)
269
        Nothing
270
        (Just $ AdditionalInfo 0 61 0 0 0 0 0)
271
        (Just $ AdditionalInfo 0 257 793750 1069 0 0 1069),
272
      DeviceInfo 6 Connected (LocalRemote Secondary Primary)
273
        (LocalRemote Diskless UpToDate) 'C'  "r---"
274
        (PerfIndicators 0 4375581 5186925 327 75 214 0 0 0 0 Nothing
275
          Nothing Nothing)
276
        Nothing
277
        Nothing
278
        Nothing,
279
      DeviceInfo 7 WFConnection (LocalRemote Secondary Unknown)
280
        (LocalRemote UpToDate DUnknown) 'C' "r---"
281
        (PerfIndicators 0 0 0 0 0 0 0 0 0 0 Nothing Nothing Nothing)
282
        Nothing
283
        (Just $ AdditionalInfo 0 61 0 0 0 0 0)
284
        (Just $ AdditionalInfo 0 257 0 0 0 0 0),
285
      DeviceInfo 8 StandAlone (LocalRemote Secondary Unknown)
286
        (LocalRemote UpToDate DUnknown) ' ' "r---"
287
        (PerfIndicators 0 0 0 0 0 0 0 0 0 0 Nothing Nothing Nothing)
288
        Nothing
289
        (Just $ AdditionalInfo 0 61 0 0 0 0 0)
290
        (Just $ AdditionalInfo 0 257 0 0 0 0 0)
291
    ]
292

  
293
-- | Function for splitting a list in chunks of a given size.
294
-- FIXME: an equivalent function exists in Data.List.Split, but it seems
295
-- pointless to add this package as a dependence just for this single
296
-- use. In case it is ever added, just remove this function definition
297
-- and use the one from the package.
298
splitEvery :: Int -> [e] -> [[e]]
299
splitEvery i l = map (take i) (splitter l (:) []) where
300
  splitter [] _ n = n
301
  splitter li c n  = li `c` splitter (drop i li) c n
302

  
303
-- | Function for testing whether a single comma-separated integer is
304
-- parsed correctly.
305
testCommaInt :: String -> Int -> Assertion
306
testCommaInt numString expectedResult =
307
  case A.parseOnly commaIntParser $ pack numString of
308
    Left msg -> assertFailure $ "Parsing failed: " ++ msg
309
    Right obtained -> assertEqual numString expectedResult obtained
310

  
311
-- | Generate a property test for CommaInt numbers in a given range.
312
gen_prop_CommaInt :: Int -> Int -> Property
313
gen_prop_CommaInt minVal maxVal =
314
  forAll (choose (minVal, maxVal)) $ \i ->
315
    case A.parseOnly commaIntParser $ pack (generateCommaInt i) of
316
      Left msg -> failTest $ "Parsing failed: " ++ msg
317
      Right obtained -> i ==? obtained
318
  where generateCommaInt x =
319
          ((reverse . intercalate ",") . splitEvery 3) . reverse $ show x
320

  
321
-- | Test if <4 digit integers are recognized correctly.
322
prop_commaInt_noCommas :: Property
323
prop_commaInt_noCommas = gen_prop_CommaInt 0 999
324

  
325
-- | Test if integers with 1 comma are recognized correctly.
326
prop_commaInt_1Comma :: Property
327
prop_commaInt_1Comma = gen_prop_CommaInt 1000 999999
328

  
329
-- | Test if integers with multiple commas are recognized correctly.
330
prop_commaInt_multipleCommas :: Property
331
prop_commaInt_multipleCommas = gen_prop_CommaInt 1000000 (maxBound ::
332
  Int)
333

  
334
-- | Test whether the parser is actually able to behave as intended with
335
-- numbers without commas. That is, if a number with more than 3 digits
336
-- is parsed, only up to the first 3 digits are considered (because they
337
-- are a valid commaInt), and the rest is ignored.
338
-- e.g.: parse "1234" = 123
339
prop_commaInt_max3WithoutComma :: Property
340
prop_commaInt_max3WithoutComma =
341
  forAll (choose (0, maxBound :: Int)) $ \i ->
342
    case A.parseOnly commaIntParser $ pack (show i) of
343
      Left msg -> failTest $ "Parsing failed: " ++ msg
344
      Right obtained ->
345
        obtained < 1000 .&&.
346
        getFirst3Digits i ==? obtained
347
  where getFirst3Digits x =
348
          if x >= 1000
349
            then getFirst3Digits $ x `div` 10
350
            else x
351

  
352
-- | Test if non-triplets are handled correctly (they are assumed NOT being part
353
-- of the number).
354
case_commaInt_non_triplet :: Assertion
355
case_commaInt_non_triplet = testCommaInt "61,736,12" 61736
356

  
357

  
358
testSuite "Block/Drbd/Parser"
359
          [ 'case_drbd80_emptyline,
360
            'case_drbd83_sync_krnl2_6_39,
361
            'case_drbd83_sync,
362
            'case_drbd83_sync_want,
363
            'case_drbd83,
364
            'case_drbd8,
365
            'case_commaInt_non_triplet,
366
            'prop_commaInt_noCommas,
367
            'prop_commaInt_1Comma,
368
            'prop_commaInt_multipleCommas,
369
            'prop_commaInt_max3WithoutComma
370
          ]
/dev/null
1
{-# LANGUAGE TemplateHaskell #-}
2
{-# OPTIONS_GHC -fno-warn-orphans #-}
3

  
4
{-| Unittests for the types representing DRBD status -}
5

  
6
{-
7

  
8
Copyright (C) 2012 Google Inc.
9

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

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

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

  
25
-}
26

  
27
module Test.Ganeti.Block.Drbd.Types (testBlock_Drbd_Types) where
28

  
29
import Test.QuickCheck
30

  
31
import Test.Ganeti.TestHelper
32
import Test.Ganeti.TestCommon
33

  
34
import Text.JSON
35
import Text.Printf
36

  
37
import Ganeti.JSON
38

  
39
import Ganeti.Block.Drbd.Types
40

  
41
{-# ANN module "HLint: ignore Use camelCase" #-}
42
{-# ANN module "HLint: ignore Use string literal" #-}
43

  
44
-- * Arbitrary instances
45

  
46
$(genArbitrary ''ConnState)
47
$(genArbitrary ''Role)
48
$(genArbitrary ''DiskState)
49
$(genArbitrary ''SizeUnit)
50
$(genArbitrary ''TimeUnit)
51

  
52
-- | Natural numbers generator.
53
natural :: Gen Int
54
natural = choose (0, maxBound :: Int)
55

  
56
-- | Generator of percentages.
57
percent :: Gen Double
58
percent = choose (0 :: Double, 100 :: Double)
59

  
60
-- | Generator of write order flags.
61
wOrderFlag :: Gen Char
62
wOrderFlag = elements ['b', 'f', 'd', 'n']
63

  
64
-- | Property for testing the JSON serialization of a DeviceInfo.
65
prop_DeviceInfo :: Property
66
prop_DeviceInfo = do
67
  minor <- natural
68
  state <- arbitrary
69
  locRole <- arbitrary
70
  remRole <- arbitrary
71
  locState <- arbitrary
72
  remState <- arbitrary
73
  alg <- choose ('A','C')
74
  ns <- natural
75
  nr <- natural
76
  dw <- natural
77
  dr <- natural
78
  al <- natural
79
  bm <- natural
80
  lc <- natural
81
  pe <- natural
82
  ua <- natural
83
  ap <- natural
84
  ep <- genMaybe natural
85
  wo <- genMaybe wOrderFlag
86
  oos <- genMaybe natural
87
  let obtained =
88
          showJSON $
89
            DeviceInfo minor state (LocalRemote locRole remRole)
90
              (LocalRemote locState remState) alg "r----" perfInd
91
              Nothing
92
              Nothing
93
              Nothing
94
      perfInd =
95
        PerfIndicators ns nr dw dr al bm lc pe ua ap ep wo oos
96
      expected =
97
        makeObj
98
          [ ("minor", showJSON minor)
99
          , ("connectionState", showJSON state)
100
          , ("localRole", showJSON locRole)
101
          , ("remoteRole", showJSON remRole)
102
          , ("localState", showJSON locState)
103
          , ("remoteState", showJSON remState)
104
          , ("replicationProtocol", showJSON alg)
105
          , ("ioFlags", showJSON "r----")
106
          , ("perfIndicators", showJSON perfInd)
107
          ]
108
  obtained ==? expected
109

  
110
-- | Property for testing the JSON serialization of a PerfIndicators.
111
prop_PerfIndicators :: Property
112
prop_PerfIndicators = do
113
  ns <- natural
114
  nr <- natural
115
  dw <- natural
116
  dr <- natural
117
  al <- natural
118
  bm <- natural
119
  lc <- natural
120
  pe <- natural
121
  ua <- natural
122
  ap <- natural
123
  ep <- genMaybe natural
124
  wo <- genMaybe wOrderFlag
125
  oos <- genMaybe natural
126
  let expected =
127
        showJSON $
128
          PerfIndicators ns nr dw dr al bm lc pe ua ap ep wo oos
129
      obtained =
130
        optFieldsToObj
131
          [ Just ("networkSend", showJSON ns)
132
          , Just ("networkReceive", showJSON nr)
133
          , Just ("diskWrite", showJSON dw)
134
          , Just ("diskRead", showJSON dr)
135
          , Just ("activityLog", showJSON al)
136
          , Just ("bitMap", showJSON bm)
137
          , Just ("localCount", showJSON lc)
138
          , Just ("pending", showJSON pe)
139
          , Just ("unacknowledged", showJSON ua)
140
          , Just ("applicationPending", showJSON ap)
141
          , optionalJSField "epochs" ep
142
          , optionalJSField "writeOrder" wo
143
          , optionalJSField "outOfSync" oos
144
          ]
145
  obtained ==? expected
146

  
147
-- | Function for testing the JSON serialization of a SyncStatus.
148
prop_SyncStatus :: Property
149
prop_SyncStatus = do
150
  perc <- percent
151
  numer <- natural
152
  denom <- natural
153
  sizeU1 <- arbitrary
154
  h <- choose (0, 23)
155
  m <- choose (0, 59)
156
  s <- choose (0, 59)
157
  sp <- natural
158
  wa <- genMaybe natural
159
  sizeU2 <- arbitrary
160
  timeU <- arbitrary
161
  let obtained = showJSON $
162
        SyncStatus perc numer denom sizeU1 (Time h m s) sp wa sizeU2 timeU
163
      expected = optFieldsToObj
164
        [ Just ("percentage", showJSON perc)
165
        , Just ("progress", showJSON $ show numer ++ "/" ++ show denom)
166
        , Just ("progressUnit", showJSON sizeU1)
167
        , Just ("timeToFinish", showJSON
168
            (printf "%02d:%02d:%02d" h m s :: String))
169
        , Just ("speed", showJSON sp)
170
        , optionalJSField "want" wa
171
        , Just ("speedUnit", showJSON $ show sizeU2 ++ "/" ++ show timeU)
172
        ]
173
  obtained ==? expected
174

  
175
testSuite "Block/Drbd/Types"
176
          [ 'prop_DeviceInfo
177
          , 'prop_PerfIndicators
178
          , 'prop_SyncStatus
179
          ]
/dev/null
1
{-# LANGUAGE TemplateHaskell #-}
2
{-# OPTIONS_GHC -fno-warn-orphans #-}
3

  
4
{-| Unittests for the 'Ganeti.Common' module.
5

  
6
-}
7

  
8
{-
9

  
10
Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
11

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

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

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

  
27
-}
28

  
29
module Test.Ganeti.Common
30
  ( testCommon
31
  , checkOpt
32
  , passFailOpt
33
  , checkEarlyExit
34
  ) where
35

  
36
import Test.QuickCheck hiding (Result)
37
import Test.HUnit
38

  
39
import qualified System.Console.GetOpt as GetOpt
40
import System.Exit
41

  
42
import Test.Ganeti.TestHelper
43
import Test.Ganeti.TestCommon
44

  
45
import Ganeti.BasicTypes
46
import Ganeti.Common
47

  
48
-- | Helper to check for correct parsing of an option.
49
checkOpt :: (StandardOptions b) =>
50
            (a -> Maybe String) -- ^ Converts the value into a cmdline form
51
         -> b                   -- ^ The default options
52
         -> (String -> c)       -- ^ Fail test function
53
         -> (String -> d -> d -> c) -- ^ Check for equality function
54
         -> (a -> d)            -- ^ Transforms the value to a compare val
55
         -> (a, GenericOptType b, b -> d) -- ^ Triple of value, the
56
                                          -- option, function to
57
                                          -- extract the set value
58
                                          -- from the options
59
         -> c
60
checkOpt repr defaults failfn eqcheck valfn
61
         (val, opt@(GetOpt.Option _ longs _ _, _), fn) =
62
  case longs of
63
    [] -> failfn "no long options?"
64
    cmdarg:_ ->
65
      case parseOptsInner defaults
66
             ["--" ++ cmdarg ++ maybe "" ("=" ++) (repr val)]
67
             "prog" [opt] [] of
68
        Left e -> failfn $ "Failed to parse option '" ++ cmdarg ++ ": " ++
69
                  show e
70
        Right (options, _) -> eqcheck ("Wrong value in option " ++
71
                                       cmdarg ++ "?") (valfn val) (fn options)
72

  
73
-- | Helper to check for correct and incorrect parsing of an option.
74
passFailOpt :: (StandardOptions b) =>
75
               b                 -- ^ The default options
76
            -> (String -> c)     -- ^ Fail test function
77
            -> c                 -- ^ Pass function
78
            -> (GenericOptType b, String, String)
79
            -- ^ The list of enabled options, fail value and pass value
80
            -> c
81
passFailOpt defaults failfn passfn
82
              (opt@(GetOpt.Option _ longs _ _, _), bad, good) =
83
  let prefix = "--" ++ head longs ++ "="
84
      good_cmd = prefix ++ good
85
      bad_cmd = prefix ++ bad in
86
  case (parseOptsInner defaults [bad_cmd]  "prog" [opt] [],
87
        parseOptsInner defaults [good_cmd] "prog" [opt] []) of
88
    (Left _,  Right _) -> passfn
89
    (Right _, Right _) -> failfn $ "Command line '" ++ bad_cmd ++
90
                          "' succeeded when it shouldn't"
91
    (Left  _, Left  _) -> failfn $ "Command line '" ++ good_cmd ++
92
                          "' failed when it shouldn't"
93
    (Right _, Left  _) ->
94
      failfn $ "Command line '" ++ bad_cmd ++
95
               "' succeeded when it shouldn't, while command line '" ++
96
               good_cmd ++ "' failed when it shouldn't"
97

  
98
-- | Helper to test that a given option is accepted OK with quick exit.
99
checkEarlyExit :: (StandardOptions a) =>
100
                  a -> String -> [GenericOptType a] -> [ArgCompletion]
101
               -> Assertion
102
checkEarlyExit defaults name options arguments =
103
  mapM_ (\param ->
104
           case parseOptsInner defaults [param] name options arguments of
105
             Left (code, _) ->
106
               assertEqual ("Program " ++ name ++
107
                            " returns invalid code " ++ show code ++
108
                            " for option " ++ param) ExitSuccess code
109
             _ -> assertFailure $ "Program " ++ name ++
110
                  " doesn't consider option " ++
111
                  param ++ " as early exit one"
112
        ) ["-h", "--help", "-V", "--version"]
113

  
114
-- | Test parseYesNo.
115
prop_parse_yes_no :: Bool -> Bool -> String -> Property
116
prop_parse_yes_no def testval val =
117
  forAll (elements [val, "yes", "no"]) $ \actual_val ->
118
  if testval
119
    then parseYesNo def Nothing ==? Ok def
120
    else let result = parseYesNo def (Just actual_val)
121
         in if actual_val `elem` ["yes", "no"]
122
              then result ==? Ok (actual_val == "yes")
123
              else property $ isBad result
124

  
125

  
126
testSuite "Common"
127
          [ 'prop_parse_yes_no
128
          ]
/dev/null
1
{-# LANGUAGE TemplateHaskell #-}
2
{-# OPTIONS_GHC -fno-warn-orphans #-}
3

  
4
{-| Unittests for ganeti-htools.
5

  
6
-}
7

  
8
{-
9

  
10
Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
11

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

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

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

  
27
-}
28

  
29
module Test.Ganeti.Confd.Types
30
  ( testConfd_Types
31
  , ConfdRequestType(..)
32
  , ConfdReqField(..)
33
  , ConfdReqQ(..)
34
  ) where
35

  
36
import Control.Applicative
37
import Test.QuickCheck
38
import Test.HUnit
39
import qualified Text.JSON as J
40

  
41
import Test.Ganeti.TestHelper
42
import Test.Ganeti.TestCommon
43

  
44
import Ganeti.Confd.Types as Confd
45

  
46
{-# ANN module "HLint: ignore Use camelCase" #-}
47

  
48
-- * Arbitrary instances
49

  
50
$(genArbitrary ''ConfdRequestType)
51

  
52
$(genArbitrary ''ConfdReqField)
53

  
54
$(genArbitrary ''ConfdReqQ)
55

  
56
instance Arbitrary ConfdQuery where
57
  arbitrary = oneof [ pure EmptyQuery
58
                    , PlainQuery <$> genName
59
                    , DictQuery <$> arbitrary
60
                    ]
61

  
62
$(genArbitrary ''ConfdRequest)
63

  
64
$(genArbitrary ''ConfdReplyStatus)
65

  
66
instance Arbitrary ConfdReply where
67
  arbitrary = ConfdReply <$> arbitrary <*> arbitrary <*>
68
                pure J.JSNull <*> arbitrary
69

  
70
$(genArbitrary ''ConfdErrorType)
71

  
72
$(genArbitrary ''ConfdNodeRole)
73

  
74
-- * Test cases
75

  
76
-- | Test 'ConfdQuery' serialisation.
77
prop_ConfdQuery_serialisation :: ConfdQuery -> Property
78
prop_ConfdQuery_serialisation = testSerialisation
79

  
80
-- | Test bad types deserialisation for 'ConfdQuery'.
81
case_ConfdQuery_BadTypes :: Assertion
82
case_ConfdQuery_BadTypes = do
83
  let helper jsval = case J.readJSON jsval of
84
                       J.Error _ -> return ()
85
                       J.Ok cq -> assertFailure $ "Parsed " ++ show jsval
86
                                   ++ " as query " ++ show (cq::ConfdQuery)
87
  helper $ J.showJSON (1::Int)
88
  helper $ J.JSBool True
89
  helper $ J.JSBool False
... This diff was truncated because it exceeds the maximum size that can be displayed.

Also available in: Unified diff