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; |
71217e42 |
6 | use DX::Action::FromCode; |
734376d9 |
7 | use Test::Exception; |
9a4942da |
8 | |
9 | { |
10 | package My::PathStatus; |
11 | |
12 | use Moo; |
13 | |
14 | has path => (is => 'ro', required => 1); |
859049a3 |
15 | has info => (is => 'ro', predicate => 1); |
9a4942da |
16 | |
17 | package My::PathStatusInfo; |
18 | |
19 | use Moo; |
20 | |
21 | has is_directory => (is => 'ro', default => 0); |
22 | has is_file => (is => 'ro', default => 0); |
23 | has mode => (is => 'ro', required => 1); |
24 | } |
25 | |
26 | @INC{qw(My/PathStatus.pm My/PathStatusInfo.pm)} = (__FILE__,__FILE__); |
27 | |
28 | my %protos = ( |
29 | '.ssh' => My::PathStatus->new( |
30 | path => '.ssh', |
31 | info => My::PathStatusInfo->new(is_directory => 1, mode => '0755') |
32 | ), |
33 | '.ssh/authorized_keys' => My::PathStatus->new( |
34 | path => '.ssh/authorized_keys', |
35 | info => My::PathStatusInfo->new(is_file => 1, mode => '0644') |
36 | ), |
37 | ); |
38 | |
71217e42 |
39 | my %empty = ( |
40 | '.ssh' => My::PathStatus->new( |
41 | path => '.ssh' |
42 | ) |
43 | ); |
44 | |
9a4942da |
45 | my %path_status; |
46 | |
47 | my $solver = DX::Solver->new( |
48 | facts => { path_status => DX::SetOver->new( |
49 | over => 'path', |
50 | values => \%path_status, |
51 | ) }, |
52 | ); |
53 | |
734376d9 |
54 | $solver->add_rule(@$_) for ( |
9a4942da |
55 | [ path_status => [ qw(PS) ], |
56 | [ member_of => 'PS', [ value => 'path_status' ] ] ], |
57 | [ path => [ qw(PS P) ], |
896fd92e |
58 | [ prop => 'PS', [ value => 'path' ], 'P' ] ], |
9a4942da |
59 | [ mode => [ qw(PS M) ], |
859049a3 |
60 | [ exists => [ qw(PSI) ], |
61 | [ prop => 'PS', [ value => 'info' ], 'PSI' ], |
62 | [ prop => 'PSI', [ value => 'mode' ], 'M' ] ] ], |
71217e42 |
63 | [ exists_path => [ qw(PS) ], |
859049a3 |
64 | [ exists => [ qw(PSI) ], |
65 | [ prop => 'PS', [ value => 'info' ], 'PSI' ], |
66 | [ prop => 'PSI', [ value => 'is_directory' ], [ value => 1 ] ] ] ], |
67 | [ exists_path => [ qw(PS) ], |
68 | [ exists => [ qw(PSI) ], |
69 | [ prop => 'PS', [ value => 'info' ], 'PSI' ], |
70 | [ prop => 'PSI', [ value => 'is_file' ], [ value => 1 ] ] ] ], |
9a4942da |
71 | [ is_directory => [ qw(PS) ], |
859049a3 |
72 | [ exists => [ qw(PSI) ], |
73 | [ prop => 'PS', [ value => 'info' ], 'PSI' ], |
74 | [ prop => 'PSI', [ value => 'is_directory' ], [ value => 1 ] ] ] ], |
9a4942da |
75 | [ is_file => [ qw(PS) ], |
859049a3 |
76 | [ exists => [ qw(PSI) ], |
77 | [ prop => 'PS', [ value => 'info' ], 'PSI' ], |
78 | [ prop => 'PSI', [ value => 'is_file' ], [ value => 1 ] ] ] ], |
9a4942da |
79 | ); |
80 | |
9a4942da |
81 | %path_status = %protos; |
82 | |
5ef4d923 |
83 | sub paths_for_simple { |
71217e42 |
84 | join ' ', map $_->{PS}->bound_value->path, $solver->query( |
734376d9 |
85 | [ qw(PS) ], [ path_status => 'PS' ], @_ |
9a4942da |
86 | )->results; |
87 | } |
88 | |
5ef4d923 |
89 | is(paths_for_simple(), '.ssh .ssh/authorized_keys'); |
9a4942da |
90 | |
5ef4d923 |
91 | is(paths_for_simple([ is_directory => 'PS' ]), '.ssh'); |
9a4942da |
92 | |
5ef4d923 |
93 | is(paths_for_simple([ is_file => 'PS' ]), '.ssh/authorized_keys'); |
9a4942da |
94 | |
5ef4d923 |
95 | is(paths_for_simple([ mode => 'PS', [ value => '0755' ] ]), '.ssh'); |
734376d9 |
96 | |
97 | $solver->add_rule( |
98 | path_status_at => [ 'PS', 'P' ], |
99 | [ path_status => 'PS' ], |
100 | [ path => qw(PS P) ], |
101 | ); |
102 | $solver->add_rule( |
103 | path_status_at => [ 'PS', 'P' ], |
104 | [ constrain => [] => sub { die "ARGH" } ] |
105 | ); |
106 | |
107 | throws_ok { |
108 | $solver->query( |
109 | [ qw(PS) ], |
110 | [ path_status_at => 'PS', [ value => '.ssh' ] ] |
111 | )->results |
112 | } qr/ARGH/; |
113 | |
114 | delete $solver->rule_set->rules->{'path_status_at/2'}; |
115 | |
116 | $solver->add_rule( |
117 | path_status_at => [ 'PS', 'P' ], |
118 | [ path_status => 'PS' ], |
119 | [ path => qw(PS P) ], |
120 | [ 'cut' ], |
121 | ); |
122 | $solver->add_rule( |
123 | path_status_at => [ 'PS', 'P' ], |
124 | [ constrain => [] => sub { die "ARGH" } ] |
125 | ); |
126 | |
127 | my @res; |
128 | |
129 | lives_ok { |
130 | @res = $solver->query( |
131 | [ qw(PS) ], |
132 | [ path_status_at => 'PS', [ value => '.ssh' ] ] |
133 | )->results |
134 | }; |
135 | |
71217e42 |
136 | is(join(' ', map $_->{PS}->bound_value->path, @res), '.ssh'); |
734376d9 |
137 | |
5ef4d923 |
138 | delete $solver->rule_set->rules->{'path_status_at/2'}; |
139 | |
140 | $solver->add_rule( |
141 | path_status_at => [ 'PS', 'P' ], |
142 | [ path_status => 'PS' ], |
143 | [ path => qw(PS P) ], |
144 | [ 'cut' ], |
145 | ); |
146 | |
147 | my %ob_res; |
148 | |
149 | $solver->add_rule( |
150 | path_status_at => [ 'PS', 'P' ], |
151 | [ observe => [ 'P' ], |
152 | sub { |
153 | my ($path) = $_[0]; |
154 | DX::Observer::FromCode->new( |
155 | code => sub { (path_status => $ob_res{$path}) } |
156 | ) |
157 | } |
158 | ], |
159 | [ path_status => 'PS' ], |
160 | [ path => qw(PS P) ], |
161 | ); |
162 | |
71217e42 |
163 | %path_status = (); |
5ef4d923 |
164 | |
165 | $ob_res{'.ssh'} = $protos{'.ssh'}; |
166 | |
167 | sub paths_for { |
71217e42 |
168 | join ' ', map $_->{PS}->bound_value->path, $solver->query([ 'PS' ], @_)->results; |
5ef4d923 |
169 | } |
170 | |
171 | is( |
172 | paths_for([ path_status => 'PS' ], [ path => 'PS', [ value => '.ssh' ] ]), |
173 | '', |
174 | 'no .ssh entry' |
175 | ); |
176 | |
177 | throws_ok { paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]) } |
178 | qr/refused/; |
179 | |
180 | $solver->{observation_policy} = sub { 1 }; |
181 | |
182 | is( |
183 | paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]), |
184 | '.ssh', |
185 | 'observation' |
186 | ); |
187 | |
188 | is($path_status{'.ssh'}, $ob_res{'.ssh'}); |
189 | |
190 | delete $solver->{observation_policy}; |
191 | |
192 | lives_ok { paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]) } |
193 | 'No observation required anymore'; |
734376d9 |
194 | |
71217e42 |
195 | $path_status{'.ssh/authorized_keys'} = $protos{'.ssh/authorized_keys'}; |
196 | |
197 | is( |
198 | paths_for([ path_status => 'PS' ], [ not => [ is_directory => 'PS' ] ]), |
199 | '.ssh/authorized_keys', |
200 | 'Negation' |
201 | ); |
202 | |
203 | $solver->add_rule(@$_) for ( |
204 | [ directory_at => [ qw(PS P) ], |
205 | [ path_status_at => qw(PS P) ], |
206 | [ is_directory => 'PS' ] ], |
207 | ); |
208 | |
209 | %path_status = (); |
210 | |
211 | $ob_res{'.ssh'} = $empty{'.ssh'}; |
212 | |
213 | #%path_status = %protos; |
214 | |
215 | $solver->{observation_policy} = sub { 1 }; |
216 | |
217 | sub dot_ssh_query { |
218 | $solver->query([ 'PS' ], [ directory_at => 'PS' => [ value => '.ssh' ] ]); |
219 | } |
220 | |
221 | is_deeply( |
222 | [ dot_ssh_query()->results ], |
223 | [] |
224 | ); |
225 | |
226 | #::Dwarn(paths_for([ directory_at => 'PS', [ value => '.ssh' ] ])); |
227 | |
228 | $solver->add_rule(@$_) for ( |
229 | [ is_directory => [ qw(PS) ], |
230 | [ not => [ exists_path => 'PS' ] ], |
231 | [ act => [ 'PS' ], |
232 | sub { |
233 | my ($ps_var) = @_; |
234 | my ($id, $value) = ($ps_var->id, $ps_var->bound_value); |
235 | DX::Action::FromCode->new( |
236 | expect => sub { |
237 | ($id => My::PathStatus->new( |
238 | path => $value->path, |
239 | info => My::PathStatusInfo->new( |
240 | is_directory => 1, mode => '' |
241 | ) |
242 | )) |
243 | }, |
244 | perform => sub { |
245 | $ob_res{$value->path} = $protos{$value->path}; |
246 | (path_status => $value); |
247 | } |
248 | ) |
249 | } ] ] |
250 | ); |
251 | |
252 | %path_status = (); |
253 | |
254 | @res = dot_ssh_query()->results; |
255 | |
256 | is(scalar(@res),1,'Single result'); |
257 | |
258 | is($path_status{'.ssh'}, $empty{'.ssh'}, 'Empty observed'); |
259 | |
260 | ok(my $action = $res[0]->{PS}->action); |
261 | |
262 | my ($type, $value) = $action->run; |
263 | |
264 | $solver->facts->{$type}->remove_value($value); |
265 | |
266 | ok(!$path_status{'.ssh'}, 'Empty retracted'); |
267 | |
268 | @res = dot_ssh_query()->results; |
269 | |
270 | is(scalar(@res),1,'Single result'); |
271 | |
272 | is($path_status{'.ssh'}, $protos{'.ssh'}, 'Created observed'); |
273 | |
274 | ok(!$res[0]->{PS}->action, 'No action'); |
275 | |
734376d9 |
276 | done_testing; |