Commit | Line | Data |
9a4942da |
1 | use strictures 1; |
2 | use Test::More; |
3 | use DX::Solver; |
4 | use DX::SetOver; |
5ef4d923 |
5 | use DX::Observer::FromCode; |
734376d9 |
6 | use Test::Exception; |
9a4942da |
7 | |
8 | { |
9 | package My::PathStatus; |
10 | |
11 | use Moo; |
12 | |
13 | has path => (is => 'ro', required => 1); |
14 | has info => (is => 'ro', required => 1); |
15 | |
16 | package My::PathStatusInfo; |
17 | |
18 | use Moo; |
19 | |
20 | has is_directory => (is => 'ro', default => 0); |
21 | has is_file => (is => 'ro', default => 0); |
22 | has mode => (is => 'ro', required => 1); |
23 | } |
24 | |
25 | @INC{qw(My/PathStatus.pm My/PathStatusInfo.pm)} = (__FILE__,__FILE__); |
26 | |
27 | my %protos = ( |
28 | '.ssh' => My::PathStatus->new( |
29 | path => '.ssh', |
30 | info => My::PathStatusInfo->new(is_directory => 1, mode => '0755') |
31 | ), |
32 | '.ssh/authorized_keys' => My::PathStatus->new( |
33 | path => '.ssh/authorized_keys', |
34 | info => My::PathStatusInfo->new(is_file => 1, mode => '0644') |
35 | ), |
36 | ); |
37 | |
38 | my %path_status; |
39 | |
40 | my $solver = DX::Solver->new( |
41 | facts => { path_status => DX::SetOver->new( |
42 | over => 'path', |
43 | values => \%path_status, |
44 | ) }, |
45 | ); |
46 | |
734376d9 |
47 | $solver->add_rule(@$_) for ( |
9a4942da |
48 | [ path_status => [ qw(PS) ], |
49 | [ member_of => 'PS', [ value => 'path_status' ] ] ], |
50 | [ path => [ qw(PS P) ], |
51 | [ constrain => [ qw(PS P) ], sub { $_[0]->path eq $_[1] } ] ], |
52 | [ mode => [ qw(PS M) ], |
53 | [ constrain => [ qw(PS M) ], |
54 | sub { $_[0]->info and $_[0]->info->mode eq $_[1] } ] ], |
55 | [ is_directory => [ qw(PS) ], |
56 | [ constrain => [ qw(PS) ], |
57 | sub { $_[0]->info and $_[0]->info->is_directory } ] ], |
58 | [ is_file => [ qw(PS) ], |
59 | [ constrain => [ qw(PS) ], |
60 | sub { $_[0]->info and $_[0]->info->is_file } ] ], |
61 | ); |
62 | |
9a4942da |
63 | %path_status = %protos; |
64 | |
5ef4d923 |
65 | sub paths_for_simple { |
734376d9 |
66 | join ' ', map $_->{PS}->path, $solver->query( |
67 | [ qw(PS) ], [ path_status => 'PS' ], @_ |
9a4942da |
68 | )->results; |
69 | } |
70 | |
5ef4d923 |
71 | is(paths_for_simple(), '.ssh .ssh/authorized_keys'); |
9a4942da |
72 | |
5ef4d923 |
73 | is(paths_for_simple([ is_directory => 'PS' ]), '.ssh'); |
9a4942da |
74 | |
5ef4d923 |
75 | is(paths_for_simple([ is_file => 'PS' ]), '.ssh/authorized_keys'); |
9a4942da |
76 | |
5ef4d923 |
77 | is(paths_for_simple([ mode => 'PS', [ value => '0755' ] ]), '.ssh'); |
734376d9 |
78 | |
79 | $solver->add_rule( |
80 | path_status_at => [ 'PS', 'P' ], |
81 | [ path_status => 'PS' ], |
82 | [ path => qw(PS P) ], |
83 | ); |
84 | $solver->add_rule( |
85 | path_status_at => [ 'PS', 'P' ], |
86 | [ constrain => [] => sub { die "ARGH" } ] |
87 | ); |
88 | |
89 | throws_ok { |
90 | $solver->query( |
91 | [ qw(PS) ], |
92 | [ path_status_at => 'PS', [ value => '.ssh' ] ] |
93 | )->results |
94 | } qr/ARGH/; |
95 | |
96 | delete $solver->rule_set->rules->{'path_status_at/2'}; |
97 | |
98 | $solver->add_rule( |
99 | path_status_at => [ 'PS', 'P' ], |
100 | [ path_status => 'PS' ], |
101 | [ path => qw(PS P) ], |
102 | [ 'cut' ], |
103 | ); |
104 | $solver->add_rule( |
105 | path_status_at => [ 'PS', 'P' ], |
106 | [ constrain => [] => sub { die "ARGH" } ] |
107 | ); |
108 | |
109 | my @res; |
110 | |
111 | lives_ok { |
112 | @res = $solver->query( |
113 | [ qw(PS) ], |
114 | [ path_status_at => 'PS', [ value => '.ssh' ] ] |
115 | )->results |
116 | }; |
117 | |
118 | is(join(' ', map $_->{PS}->path, @res), '.ssh'); |
119 | |
5ef4d923 |
120 | delete $solver->rule_set->rules->{'path_status_at/2'}; |
121 | |
122 | $solver->add_rule( |
123 | path_status_at => [ 'PS', 'P' ], |
124 | [ path_status => 'PS' ], |
125 | [ path => qw(PS P) ], |
126 | [ 'cut' ], |
127 | ); |
128 | |
129 | my %ob_res; |
130 | |
131 | $solver->add_rule( |
132 | path_status_at => [ 'PS', 'P' ], |
133 | [ observe => [ 'P' ], |
134 | sub { |
135 | my ($path) = $_[0]; |
136 | DX::Observer::FromCode->new( |
137 | code => sub { (path_status => $ob_res{$path}) } |
138 | ) |
139 | } |
140 | ], |
141 | [ path_status => 'PS' ], |
142 | [ path => qw(PS P) ], |
143 | ); |
144 | |
145 | %path_status = ('.ssh/authorized_keys' => $protos{'.ssh/authorized_keys'}); |
146 | |
147 | $ob_res{'.ssh'} = $protos{'.ssh'}; |
148 | |
149 | sub paths_for { |
150 | join ' ', map $_->{PS}->path, $solver->query([ 'PS' ], @_)->results; |
151 | } |
152 | |
153 | is( |
154 | paths_for([ path_status => 'PS' ], [ path => 'PS', [ value => '.ssh' ] ]), |
155 | '', |
156 | 'no .ssh entry' |
157 | ); |
158 | |
159 | throws_ok { paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]) } |
160 | qr/refused/; |
161 | |
162 | $solver->{observation_policy} = sub { 1 }; |
163 | |
164 | is( |
165 | paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]), |
166 | '.ssh', |
167 | 'observation' |
168 | ); |
169 | |
170 | is($path_status{'.ssh'}, $ob_res{'.ssh'}); |
171 | |
172 | delete $solver->{observation_policy}; |
173 | |
174 | lives_ok { paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]) } |
175 | 'No observation required anymore'; |
734376d9 |
176 | |
177 | done_testing; |