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