File Coverage

blib/lib/CDS.pm
Criterion Covered Total %
statement 119 10901 1.0
branch 3 3116 0.1
condition 1 2174 0.0
subroutine 39 1526 2.5
pod 0 36 0.0
total 162 17753 0.9


line stmt bran cond sub pod time code
1             # This is part of the Condensation Perl Module 0.26 (cli) built on 2022-02-08.
2             # See https://condensation.io for information about the Condensation Data System.
3              
4 1     1   54398 use strict;
  1         2  
  1         29  
5 1     1   4 use warnings;
  1         1  
  1         24  
6 1     1   20 use 5.010000;
  1         2  
7 1     1   600 use CDS::C;
  1         3  
  1         51  
8              
9 1     1   5 use Cwd;
  1         2  
  1         40  
10 1     1   955 use Digest::SHA;
  1         2702  
  1         101  
11 1     1   467 use Encode;
  1         13106  
  1         87  
12 1     1   7 use Fcntl;
  1         2  
  1         169  
13 1     1   432 use HTTP::Date;
  1         3317  
  1         68  
14 1     1   446 use HTTP::Headers;
  1         3201  
  1         33  
15 1     1   422 use HTTP::Request;
  1         13275  
  1         28  
16 1     1   445 use HTTP::Server::Simple;
  1         16891  
  1         36  
17 1     1   658 use LWP::UserAgent;
  1         22580  
  1         30  
18 1     1   8 use Time::Local;
  1         2  
  1         70  
19 1     1   514 use utf8;
  1         13  
  1         7  
20             package CDS;
21              
22             our $VERSION = '0.26';
23             our $edition = 'cli';
24             our $releaseDate = '2022-02-08';
25              
26 0     0 0 0 sub now { time * 1000 }
27              
28 0     0 0 0 sub SECOND { 1000 }
29 0     0 0 0 sub MINUTE { 60 * 1000 }
30 0     0 0 0 sub HOUR { 60 * 60 * 1000 }
31 0     0 0 0 sub DAY { 24 * 60 * 60 * 1000 }
32 0     0 0 0 sub WEEK { 7 * 24 * 60 * 60 * 1000 }
33 0     0 0 0 sub MONTH { 30 * 24 * 60 * 60 * 1000 }
34 0     0 0 0 sub YEAR { 365 * 24 * 60 * 60 * 1000 }
35              
36             # File system utility functions.
37              
38             sub readBytesFromFile {
39 0     0 0 0 my $class = shift;
40 0         0 my $filename = shift;
41              
42 0 0       0 open(my $fh, '<:bytes', $filename) || return;
43 0         0 local $/;
44 0         0 my $content = <$fh>;
45 0         0 close $fh;
46 0         0 return $content;
47             }
48              
49             sub writeBytesToFile {
50 0     0 0 0 my $class = shift;
51 0         0 my $filename = shift;
52              
53 0 0       0 open(my $fh, '>:bytes', $filename) || return;
54 0         0 print $fh @_;
55 0         0 close $fh;
56 0         0 return 1;
57             }
58              
59             sub readTextFromFile {
60 0     0 0 0 my $class = shift;
61 0         0 my $filename = shift;
62              
63 0 0       0 open(my $fh, '<:utf8', $filename) || return;
64 0         0 local $/;
65 0         0 my $content = <$fh>;
66 0         0 close $fh;
67 0         0 return $content;
68             }
69              
70             sub writeTextToFile {
71 0     0 0 0 my $class = shift;
72 0         0 my $filename = shift;
73              
74 0 0       0 open(my $fh, '>:utf8', $filename) || return;
75 0         0 print $fh @_;
76 0         0 close $fh;
77 0         0 return 1;
78             }
79              
80             sub listFolder {
81 0     0 0 0 my $class = shift;
82 0         0 my $folder = shift;
83              
84 0 0       0 opendir(my $dh, $folder) || return;
85 0         0 my @files = readdir $dh;
86 0         0 closedir $dh;
87 0         0 return @files;
88             }
89              
90             sub intermediateFolders {
91 0     0 0 0 my $class = shift;
92 0         0 my $path = shift;
93              
94 0         0 my @paths = ($path);
95 0         0 while (1) {
96 0 0       0 $path =~ /^(.+)\/(.*?)$/ || last;
97 0         0 $path = $1;
98 0 0       0 next if ! length $2;
99 0         0 unshift @paths, $path;
100             }
101 0         0 return @paths;
102             }
103              
104             # This is for debugging purposes only.
105             sub log {
106 0     0 0 0 my $class = shift;
107              
108 0         0 print STDERR @_, "\n";
109             }
110              
111             sub min {
112 0     0 0 0 my $class = shift;
113              
114 0         0 my $min = shift;
115 0         0 for my $number (@_) {
116 0 0       0 $min = $min < $number ? $min : $number;
117             }
118              
119 0         0 return $min;
120             }
121              
122             sub max {
123 0     0 0 0 my $class = shift;
124              
125 0         0 my $max = shift;
126 0         0 for my $number (@_) {
127 0 0       0 $max = $max > $number ? $max : $number;
128             }
129              
130 0         0 return $max;
131             }
132              
133             sub booleanCompare {
134 0     0 0 0 my $class = shift;
135 0         0 my $a = shift;
136 0         0 my $b = shift;
137 0 0 0     0 $a && $b ? 0 : $a ? 1 : $b ? -1 : 0 }
    0          
    0          
138              
139             # Utility functions for random sequences
140              
141             srand(time);
142             our @hexDigits = ('0'..'9', 'a'..'f');
143              
144             sub randomHex {
145 0     0 0 0 my $class = shift;
146 0         0 my $length = shift;
147              
148 0         0 return substr(unpack('H*', CDS::C::randomBytes(int(($length + 1) / 2))), 0, $length);
149             }
150              
151             sub randomBytes {
152 0     0 0 0 my $class = shift;
153 0         0 my $length = shift;
154              
155 0         0 return CDS::C::randomBytes($length);
156             }
157              
158             sub randomKey {
159 0     0 0 0 my $class = shift;
160              
161 0         0 return CDS::C::randomBytes(32);
162             }
163              
164 0     0 0 0 sub version { 'Condensation, Perl, '.$CDS::VERSION }
165              
166             # Conversion of numbers and booleans to and from bytes.
167             # To convert text, use Encode::encode_utf8($text) and Encode::decode_utf8($bytes).
168             # To convert hex sequences, use pack('H*', $hex) and unpack('H*', $bytes).
169              
170             sub bytesFromBoolean {
171 0     0 0 0 my $class = shift;
172 0         0 my $value = shift;
173 0 0       0 $value ? 'y' : '' }
174              
175             sub bytesFromInteger {
176 0     0 0 0 my $class = shift;
177 0         0 my $value = shift;
178              
179 0 0 0     0 return '' if $value >= 0 && $value < 1;
180 0 0 0     0 return pack 'c', $value if $value >= -0x80 && $value < 0x80;
181 0 0 0     0 return pack 's>', $value if $value >= -0x8000 && $value < 0x8000;
182              
183             # This works up to 63 bits, plus 1 sign bit
184 0         0 my $bytes = pack 'q>', $value;
185              
186 0         0 my $pos = 0;
187 0         0 my $first = ord(substr($bytes, 0, 1));
188 0 0       0 if ($value > 0) {
    0          
189             # Perl internally uses an unsigned 64-bit integer if the value is positive
190 0 0       0 return "\x7f\xff\xff\xff\xff\xff\xff\xff" if $first >= 128;
191 0         0 while ($first == 0) {
192 0         0 my $next = ord(substr($bytes, $pos + 1, 1));
193 0 0       0 last if $next >= 128;
194 0         0 $first = $next;
195 0         0 $pos += 1;
196             }
197             } elsif ($first == 255) {
198 0         0 while ($first == 255) {
199 0         0 my $next = ord(substr($bytes, $pos + 1, 1));
200 0 0       0 last if $next < 128;
201 0         0 $first = $next;
202 0         0 $pos += 1;
203             }
204             }
205              
206 0         0 return substr($bytes, $pos);
207             }
208              
209             sub bytesFromUnsigned {
210 0     0 0 0 my $class = shift;
211 0         0 my $value = shift;
212              
213 0 0       0 return '' if $value < 1;
214 0 0       0 return pack 'C', $value if $value < 0x100;
215 0 0       0 return pack 'S>', $value if $value < 0x10000;
216              
217             # This works up to 64 bits
218 0         0 my $bytes = pack 'Q>', $value;
219 0         0 my $pos = 0;
220 0         0 $pos += 1 while substr($bytes, $pos, 1) eq "\0";
221 0         0 return substr($bytes, $pos);
222             }
223              
224             sub bytesFromFloat32 {
225 0     0 0 0 my $class = shift;
226 0         0 my $value = shift;
227 0         0 pack('f', $value) }
228             sub bytesFromFloat64 {
229 0     0 0 0 my $class = shift;
230 0         0 my $value = shift;
231 0         0 pack('d', $value) }
232              
233             sub booleanFromBytes {
234 0     0 0 0 my $class = shift;
235 0         0 my $bytes = shift;
236              
237 0         0 return length $bytes > 0;
238             }
239              
240             sub integerFromBytes {
241 0     0 0 0 my $class = shift;
242 0         0 my $bytes = shift;
243              
244 0 0       0 return 0 if ! length $bytes;
245 0         0 my $value = unpack('C', substr($bytes, 0, 1));
246 0 0       0 $value -= 0x100 if $value & 0x80;
247 0         0 for my $i (1 .. length($bytes) - 1) {
248 0         0 $value *= 256;
249 0         0 $value += unpack('C', substr($bytes, $i, 1));
250             }
251 0         0 return $value;
252             }
253              
254             sub unsignedFromBytes {
255 0     0 0 0 my $class = shift;
256 0         0 my $bytes = shift;
257              
258 0         0 my $value = 0;
259 0         0 for my $i (0 .. length($bytes) - 1) {
260 0         0 $value *= 256;
261 0         0 $value += unpack('C', substr($bytes, $i, 1));
262             }
263 0         0 return $value;
264             }
265              
266             sub floatFromBytes {
267 0     0 0 0 my $class = shift;
268 0         0 my $bytes = shift;
269              
270 0 0       0 return unpack('f', $bytes) if length $bytes == 4;
271 0 0       0 return unpack('d', $bytes) if length $bytes == 8;
272 0         0 return undef;
273             }
274              
275             # Initial counter value for AES in CTR mode
276 0     0 0 0 sub zeroCTR { "\0" x 16 }
277              
278             my $emptyBytesHash = CDS::Hash->fromHex('e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855');
279 0     0 0 0 sub emptyBytesHash { $emptyBytesHash }
280              
281             # Checks if a box label is valid.
282             sub isValidBoxLabel {
283 0     0 0 0 my $class = shift;
284 0         0 my $label = shift;
285 0 0 0     0 $label eq 'messages' || $label eq 'private' || $label eq 'public' }
286              
287             # Groups box additions or removals by account hash and box label.
288             sub groupedBoxOperations {
289 0     0 0 0 my $class = shift;
290 0         0 my $operations = shift;
291              
292 0         0 my %byAccountHash;
293 0         0 for my $operation (@$operations) {
294 0         0 my $accountHashBytes = $operation->{accountHash}->bytes;
295 0 0       0 $byAccountHash{$accountHashBytes} = {accountHash => $operation->{accountHash}, byBoxLabel => {}} if ! exists $byAccountHash{$accountHashBytes};
296 0         0 my $byBoxLabel = $byAccountHash{$accountHashBytes}->{byBoxLabel};
297 0         0 my $boxLabel = $operation->{boxLabel};
298 0 0       0 $byBoxLabel->{$boxLabel} = [] if ! exists $byBoxLabel->{$boxLabel};
299 0         0 push @{$byBoxLabel->{$boxLabel}}, $operation;
  0         0  
300             }
301              
302 0         0 return values %byAccountHash;
303             }
304              
305             ### Open envelopes ###
306              
307             sub verifyEnvelopeSignature {
308 0     0 0 0 my $class = shift;
309 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
310 0 0 0     0 my $publicKey = shift; die 'wrong type '.ref($publicKey).' for $publicKey' if defined $publicKey && ref $publicKey ne 'CDS::PublicKey';
  0         0  
311 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
312              
313             # Read the signature
314 0         0 my $signature = $envelope->child('signature')->bytesValue;
315 0 0       0 return if length $signature < 1;
316              
317             # Verify the signature
318 0 0       0 return if ! $publicKey->verifyHash($hash, $signature);
319 0         0 return 1;
320             }
321              
322             # The result of parsing an ACCOUNT token (see Token.pm).
323             package CDS::AccountToken;
324              
325             sub new {
326 0     0   0 my $class = shift;
327 0         0 my $cliStore = shift;
328 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
329              
330 0         0 return bless {
331             cliStore => $cliStore,
332             actorHash => $actorHash,
333             };
334             }
335              
336 0     0   0 sub cliStore { shift->{cliStore} }
337 0     0   0 sub actorHash { shift->{actorHash} }
338             sub url {
339 0     0   0 my $o = shift;
340 0         0 $o->{cliStore}->url.'/accounts/'.$o->{actorHash}->hex }
341              
342             package CDS::ActorGroup;
343              
344             # Members must be sorted in descending revision order, such that the member with the most recent revision is first. Members must not include any revoked actors.
345             sub new {
346 0     0   0 my $class = shift;
347 0         0 my $members = shift;
348 0         0 my $entrustedActorsRevision = shift;
349 0         0 my $entrustedActors = shift;
350              
351             # Create the cache for the "contains" method
352 0         0 my $containCache = {};
353 0         0 for my $member (@$members) {
354 0         0 $containCache->{$member->actorOnStore->publicKey->hash->bytes} = 1;
355             }
356              
357 0         0 return bless {
358             members => $members,
359             entrustedActorsRevision => $entrustedActorsRevision,
360             entrustedActors => $entrustedActors,
361             containsCache => $containCache,
362             };
363             }
364              
365             sub members {
366 0     0   0 my $o = shift;
367 0         0 @{$o->{members}} }
  0         0  
368 0     0   0 sub entrustedActorsRevision { shift->{entrustedActorsRevision} }
369             sub entrustedActors {
370 0     0   0 my $o = shift;
371 0         0 @{$o->{entrustedActors}} }
  0         0  
372              
373             # Checks whether the actor group contains at least one active member.
374             sub isActive {
375 0     0   0 my $o = shift;
376              
377 0         0 for my $member (@{$o->{members}}) {
  0         0  
378 0 0       0 return 1 if $member->isActive;
379             }
380 0         0 return;
381             }
382              
383             # Returns the most recent active member, the most recent idle member, or undef if the group is empty.
384             sub leader {
385 0     0   0 my $o = shift;
386              
387 0         0 for my $member (@{$o->{members}}) {
  0         0  
388 0 0       0 return $member if $member->isActive;
389             }
390 0         0 return $o->{members}->[0];
391             }
392              
393             # Returns true if the account belongs to this actor group.
394             # Note that multiple (different) actor groups may claim that the account belongs to them. In practice, an account usually belongs to one actor group.
395             sub contains {
396 0     0   0 my $o = shift;
397 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
398              
399 0         0 return exists $o->{containsCache}->{$actorHash->bytes};
400             }
401              
402             # Returns true if the account is entrusted by this actor group.
403             sub entrusts {
404 0     0   0 my $o = shift;
405 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
406              
407 0         0 for my $actor (@{$o->{entrustedActors}}) {
  0         0  
408 0 0       0 return 1 if $actorHash->equals($actor->publicKey->hash);
409             }
410 0         0 return;
411             }
412              
413             # Returns all public keys.
414             sub publicKeys {
415 0     0   0 my $o = shift;
416              
417 0         0 my @publicKeys;
418 0         0 for my $member (@{$o->{members}}) {
  0         0  
419 0         0 push @publicKeys, $member->actorOnStore->publicKey;
420             }
421 0         0 for my $actor (@{$o->{entrustedActors}}) {
  0         0  
422 0         0 push @publicKeys, $actor->actorOnStore->publicKey;
423             }
424 0         0 return @publicKeys;
425             }
426              
427             # Returns an ActorGroupBuilder with all members and entrusted keys of this ActorGroup.
428             sub toBuilder {
429 0     0   0 my $o = shift;
430              
431 0         0 my $builder = CDS::ActorGroupBuilder->new;
432 0         0 $builder->mergeEntrustedActors($o->{entrustedActorsRevision});
433 0         0 for my $member (@{$o->{members}}) {
  0         0  
434 0         0 my $publicKey = $member->actorOnStore->publicKey;
435 0         0 $builder->addKnownPublicKey($publicKey);
436 0 0       0 $builder->addMember($publicKey->hash, $member->storeUrl, $member->revision, $member->isActive ? 'active' : 'idle');
437             }
438 0         0 for my $actor (@{$o->{entrustedActors}}) {
  0         0  
439 0         0 my $publicKey = $actor->actorOnStore->publicKey;
440 0         0 $builder->addKnownPublicKey($publicKey);
441 0         0 $builder->addEntrustedActor($publicKey->hash, $actor->storeUrl);
442             }
443 0         0 return $builder;
444             }
445              
446             package CDS::ActorGroup::EntrustedActor;
447              
448             sub new {
449 0     0   0 my $class = shift;
450 0 0 0     0 my $actorOnStore = shift; die 'wrong type '.ref($actorOnStore).' for $actorOnStore' if defined $actorOnStore && ref $actorOnStore ne 'CDS::ActorOnStore';
  0         0  
451 0         0 my $storeUrl = shift;
452              
453 0         0 return bless {
454             actorOnStore => $actorOnStore,
455             storeUrl => $storeUrl,
456             };
457             }
458              
459 0     0   0 sub actorOnStore { shift->{actorOnStore} }
460 0     0   0 sub storeUrl { shift->{storeUrl} }
461              
462             package CDS::ActorGroup::Member;
463              
464             sub new {
465 0     0   0 my $class = shift;
466 0 0 0     0 my $actorOnStore = shift; die 'wrong type '.ref($actorOnStore).' for $actorOnStore' if defined $actorOnStore && ref $actorOnStore ne 'CDS::ActorOnStore';
  0         0  
467 0         0 my $storeUrl = shift;
468 0         0 my $revision = shift;
469 0         0 my $isActive = shift;
470              
471 0         0 return bless {
472             actorOnStore => $actorOnStore,
473             storeUrl => $storeUrl,
474             revision => $revision,
475             isActive => $isActive,
476             };
477             }
478              
479 0     0   0 sub actorOnStore { shift->{actorOnStore} }
480 0     0   0 sub storeUrl { shift->{storeUrl} }
481 0     0   0 sub revision { shift->{revision} }
482 0     0   0 sub isActive { shift->{isActive} }
483              
484             package CDS::ActorGroupBuilder;
485              
486             sub new {
487 0     0   0 my $class = shift;
488              
489 0         0 return bless {
490             knownPublicKeys => {}, # A hashref of known public keys (e.g. from the existing actor group)
491             members => {}, # Members by URL
492             entrustedActorsRevision => 0, # Revision of the list of entrusted actors
493             entrustedActors => {}, # Entrusted actors by hash
494             };
495             }
496              
497             sub members {
498 0     0   0 my $o = shift;
499 0         0 values %{$o->{members}} }
  0         0  
500 0     0   0 sub entrustedActorsRevision { shift->{entrustedActorsRevision} }
501             sub entrustedActors {
502 0     0   0 my $o = shift;
503 0         0 values %{$o->{entrustedActors}} }
  0         0  
504 0     0   0 sub knownPublicKeys { shift->{knownPublicKeys} }
505              
506             sub addKnownPublicKey {
507 0     0   0 my $o = shift;
508 0 0 0     0 my $publicKey = shift; die 'wrong type '.ref($publicKey).' for $publicKey' if defined $publicKey && ref $publicKey ne 'CDS::PublicKey';
  0         0  
509              
510 0         0 $o->{publicKeys}->{$publicKey->hash->bytes} = $publicKey;
511             }
512              
513             sub addMember {
514 0     0   0 my $o = shift;
515 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
516 0         0 my $storeUrl = shift;
517 0   0     0 my $revision = shift // 0;
518 0   0     0 my $status = shift // 'active';
519              
520 0         0 my $url = $storeUrl.'/accounts/'.$hash->hex;
521 0         0 my $member = $o->{members}->{$url};
522 0 0 0     0 return if $member && $revision <= $member->revision;
523 0         0 $o->{members}->{$url} = CDS::ActorGroupBuilder::Member->new($hash, $storeUrl, $revision, $status);
524 0         0 return 1;
525             }
526              
527             sub removeMember {
528 0     0   0 my $o = shift;
529 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
530 0         0 my $storeUrl = shift;
531              
532 0         0 my $url = $storeUrl.'/accounts/'.$hash->hex;
533 0         0 delete $o->{members}->{$url};
534             }
535              
536             sub parseMembers {
537 0     0   0 my $o = shift;
538 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
539 0         0 my $linkedPublicKeys = shift;
540              
541 0 0       0 die 'linked public keys?' if ! defined $linkedPublicKeys;
542 0         0 for my $storeRecord ($record->children) {
543 0         0 my $accountStoreUrl = $storeRecord->asText;
544              
545 0         0 for my $statusRecord ($storeRecord->children) {
546 0         0 my $status = $statusRecord->bytes;
547              
548 0         0 for my $child ($statusRecord->children) {
549 0 0       0 my $hash = $linkedPublicKeys ? $child->hash : CDS::Hash->fromBytes($child->bytes);
550 0   0     0 $o->addMember($hash // next, $accountStoreUrl, $child->integerValue, $status);
551             }
552             }
553             }
554             }
555              
556             sub mergeEntrustedActors {
557 0     0   0 my $o = shift;
558 0         0 my $revision = shift;
559              
560 0 0       0 return if $revision <= $o->{entrustedActorsRevision};
561 0         0 $o->{entrustedActorsRevision} = $revision;
562 0         0 $o->{entrustedActors} = {};
563 0         0 return 1;
564             }
565              
566             sub addEntrustedActor {
567 0     0   0 my $o = shift;
568 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
569 0         0 my $storeUrl = shift;
570              
571 0         0 my $actor = CDS::ActorGroupBuilder::EntrustedActor->new($hash, $storeUrl);
572 0         0 $o->{entrustedActors}->{$hash->bytes} = $actor;
573             }
574              
575             sub removeEntrustedActor {
576 0     0   0 my $o = shift;
577 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
578              
579 0         0 delete $o->{entrustedActors}->{$hash->bytes};
580             }
581              
582             sub parseEntrustedActors {
583 0     0   0 my $o = shift;
584 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
585 0         0 my $linkedPublicKeys = shift;
586              
587 0         0 for my $revisionRecord ($record->children) {
588 0 0       0 next if ! $o->mergeEntrustedActors($revisionRecord->asInteger);
589 0         0 $o->parseEntrustedActorList($revisionRecord, $linkedPublicKeys);
590             }
591             }
592              
593             sub parseEntrustedActorList {
594 0     0   0 my $o = shift;
595 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
596 0         0 my $linkedPublicKeys = shift;
597              
598 0 0       0 die 'linked public keys?' if ! defined $linkedPublicKeys;
599 0         0 for my $storeRecord ($record->children) {
600 0         0 my $storeUrl = $storeRecord->asText;
601              
602 0         0 for my $child ($storeRecord->children) {
603 0 0       0 my $hash = $linkedPublicKeys ? $child->hash : CDS::Hash->fromBytes($child->bytes);
604 0   0     0 $o->addEntrustedActor($hash // next, $storeUrl);
605             }
606             }
607             }
608              
609             sub parse {
610 0     0   0 my $o = shift;
611 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
612 0         0 my $linkedPublicKeys = shift;
613              
614 0         0 $o->parseMembers($record->child('actor group'), $linkedPublicKeys);
615 0         0 $o->parseEntrustedActors($record->child('entrusted actors'), $linkedPublicKeys);
616             }
617              
618             sub load {
619 0     0   0 my $o = shift;
620 0         0 my $store = shift;
621 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
622 0         0 my $delegate = shift;
623              
624 0         0 return CDS::LoadActorGroup->load($o, $store, $keyPair, $delegate);
625             }
626              
627             sub discover {
628 0     0   0 my $o = shift;
629 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
630 0         0 my $delegate = shift;
631              
632 0         0 return CDS::DiscoverActorGroup->discover($o, $keyPair, $delegate);
633             }
634              
635             # Serializes the actor group to a record that can be passed to parse.
636             sub addToRecord {
637 0     0   0 my $o = shift;
638 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
639 0         0 my $linkedPublicKeys = shift;
640              
641 0 0       0 die 'linked public keys?' if ! defined $linkedPublicKeys;
642              
643 0         0 my $actorGroupRecord = $record->add('actor group');
644 0         0 my $currentStoreUrl = undef;
645 0         0 my $currentStoreRecord = undef;
646 0         0 my $currentStatus = undef;
647 0         0 my $currentStatusRecord = undef;
648 0 0       0 for my $member (sort { $a->storeUrl cmp $b->storeUrl || CDS->booleanCompare($b->status, $a->status) } $o->members) {
  0         0  
649 0 0       0 next if ! $member->revision;
650              
651 0 0 0     0 if (! defined $currentStoreUrl || $currentStoreUrl ne $member->storeUrl) {
652 0         0 $currentStoreUrl = $member->storeUrl;
653 0         0 $currentStoreRecord = $actorGroupRecord->addText($currentStoreUrl);
654 0         0 $currentStatus = undef;
655 0         0 $currentStatusRecord = undef;
656             }
657              
658 0 0 0     0 if (! defined $currentStatus || $currentStatus ne $member->status) {
659 0         0 $currentStatus = $member->status;
660 0         0 $currentStatusRecord = $currentStoreRecord->add($currentStatus);
661             }
662              
663 0 0       0 my $hashRecord = $linkedPublicKeys ? $currentStatusRecord->addHash($member->hash) : $currentStatusRecord->add($member->hash->bytes);
664 0         0 $hashRecord->addInteger($member->revision);
665             }
666              
667 0 0       0 if ($o->{entrustedActorsRevision}) {
668 0         0 my $listRecord = $o->entrustedActorListToRecord($linkedPublicKeys);
669 0         0 $record->add('entrusted actors')->addInteger($o->{entrustedActorsRevision})->addRecord($listRecord->children);
670             }
671             }
672              
673             sub toRecord {
674 0     0   0 my $o = shift;
675 0         0 my $linkedPublicKeys = shift;
676              
677 0         0 my $record = CDS::Record->new;
678 0         0 $o->addToRecord($record, $linkedPublicKeys);
679 0         0 return $record;
680             }
681              
682             sub entrustedActorListToRecord {
683 0     0   0 my $o = shift;
684 0         0 my $linkedPublicKeys = shift;
685              
686 0         0 my $record = CDS::Record->new;
687 0         0 my $currentStoreUrl = undef;
688 0         0 my $currentStoreRecord = undef;
689 0         0 for my $actor ($o->entrustedActors) {
690 0 0 0     0 if (! defined $currentStoreUrl || $currentStoreUrl ne $actor->storeUrl) {
691 0         0 $currentStoreUrl = $actor->storeUrl;
692 0         0 $currentStoreRecord = $record->addText($currentStoreUrl);
693             }
694              
695 0 0       0 $linkedPublicKeys ? $currentStoreRecord->addHash($actor->hash) : $currentStoreRecord->add($actor->hash->bytes);
696             }
697              
698 0         0 return $record;
699             }
700              
701             package CDS::ActorGroupBuilder::EntrustedActor;
702              
703             sub new {
704 0     0   0 my $class = shift;
705 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
706 0         0 my $storeUrl = shift;
707              
708 0         0 return bless {
709             hash => $hash,
710             storeUrl => $storeUrl,
711             };
712             }
713              
714 0     0   0 sub hash { shift->{hash} }
715 0     0   0 sub storeUrl { shift->{storeUrl} }
716              
717             package CDS::ActorGroupBuilder::Member;
718              
719             sub new {
720 0     0   0 my $class = shift;
721 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
722 0         0 my $storeUrl = shift;
723 0         0 my $revision = shift;
724 0         0 my $status = shift;
725              
726 0         0 return bless {
727             hash => $hash,
728             storeUrl => $storeUrl,
729             revision => $revision,
730             status => $status,
731             };
732             }
733              
734 0     0   0 sub hash { shift->{hash} }
735 0     0   0 sub storeUrl { shift->{storeUrl} }
736 0     0   0 sub revision { shift->{revision} }
737 0     0   0 sub status { shift->{status} }
738              
739             # The result of parsing an ACTORGROUP token (see Token.pm).
740             package CDS::ActorGroupToken;
741              
742             sub new {
743 0     0   0 my $class = shift;
744 0         0 my $label = shift;
745 0 0 0     0 my $actorGroup = shift; die 'wrong type '.ref($actorGroup).' for $actorGroup' if defined $actorGroup && ref $actorGroup ne 'CDS::ActorGroup';
  0         0  
746              
747 0         0 return bless {
748             label => $label,
749             actorGroup => $actorGroup,
750             };
751             }
752              
753 0     0   0 sub label { shift->{label} }
754 0     0   0 sub actorGroup { shift->{actorGroup} }
755              
756             # A public key and a store.
757             package CDS::ActorOnStore;
758              
759             sub new {
760 0     0   0 my $class = shift;
761 0 0 0     0 my $publicKey = shift; die 'wrong type '.ref($publicKey).' for $publicKey' if defined $publicKey && ref $publicKey ne 'CDS::PublicKey';
  0         0  
762 0         0 my $store = shift;
763              
764 0         0 return bless {
765             publicKey => $publicKey,
766             store => $store
767             };
768             }
769              
770 0     0   0 sub publicKey { shift->{publicKey} }
771 0     0   0 sub store { shift->{store} }
772              
773             sub equals {
774 0     0   0 my $this = shift;
775 0         0 my $that = shift;
776              
777 0 0 0     0 return 1 if ! defined $this && ! defined $that;
778 0 0 0     0 return if ! defined $this || ! defined $that;
779 0   0     0 return $this->{store}->id eq $that->{store}->id && $this->{publicKey}->{hash}->equals($that->{publicKey}->{hash});
780             }
781              
782             package CDS::ActorWithDocument;
783              
784             sub new {
785 0     0   0 my $class = shift;
786 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
787 0         0 my $storageStore = shift;
788 0         0 my $messagingStore = shift;
789 0         0 my $messagingStoreUrl = shift;
790 0         0 my $publicKeyCache = shift;
791              
792 0         0 my $o = bless {
793             keyPair => $keyPair,
794             storageStore => $storageStore,
795             messagingStore => $messagingStore,
796             messagingStoreUrl => $messagingStoreUrl,
797             groupDataHandlers => [],
798             }, $class;
799              
800             # Private data on the storage store
801 0         0 $o->{storagePrivateRoot} = CDS::PrivateRoot->new($keyPair, $storageStore, $o);
802 0         0 $o->{groupDocument} = CDS::RootDocument->new($o->{storagePrivateRoot}, 'group data');
803 0         0 $o->{localDocument} = CDS::RootDocument->new($o->{storagePrivateRoot}, 'local data');
804              
805             # Private data on the messaging store
806 0 0       0 $o->{messagingPrivateRoot} = $storageStore->id eq $messagingStore->id ? $o->{storagePrivateRoot} : CDS::PrivateRoot->new($keyPair, $messagingStore, $o);
807 0         0 $o->{sentList} = CDS::SentList->new($o->{messagingPrivateRoot});
808 0         0 $o->{sentListReady} = 0;
809              
810             # Group data sharing
811 0         0 $o->{groupDataSharer} = CDS::GroupDataSharer->new($o);
812 0         0 $o->{groupDataSharer}->addDataHandler($o->{groupDocument}->label, $o->{groupDocument});
813              
814             # Selectors
815 0         0 $o->{groupRoot} = $o->{groupDocument}->root;
816 0         0 $o->{localRoot} = $o->{localDocument}->root;
817 0         0 $o->{publicDataSelector} = $o->{groupRoot}->child('public data');
818 0         0 $o->{actorGroupSelector} = $o->{groupRoot}->child('actor group');
819 0         0 $o->{actorSelector} = $o->{actorGroupSelector}->child(substr($keyPair->publicKey->hash->bytes, 0, 16));
820 0         0 $o->{entrustedActorsSelector} = $o->{groupRoot}->child('entrusted actors');
821              
822             # Message reader
823 0         0 my $pool = CDS::MessageBoxReaderPool->new($keyPair, $publicKeyCache, $o);
824 0         0 $o->{messageBoxReader} = CDS::MessageBoxReader->new($pool, CDS::ActorOnStore->new($keyPair->publicKey, $messagingStore), CDS->HOUR);
825              
826             # Active actor group members and entrusted keys
827 0         0 $o->{cachedGroupDataMembers} = {};
828 0         0 $o->{cachedEntrustedKeys} = {};
829 0         0 return $o;
830             }
831              
832 0     0   0 sub keyPair { shift->{keyPair} }
833 0     0   0 sub storageStore { shift->{storageStore} }
834 0     0   0 sub messagingStore { shift->{messagingStore} }
835 0     0   0 sub messagingStoreUrl { shift->{messagingStoreUrl} }
836              
837 0     0   0 sub storagePrivateRoot { shift->{storagePrivateRoot} }
838 0     0   0 sub groupDocument { shift->{groupDocument} }
839 0     0   0 sub localDocument { shift->{localDocument} }
840              
841 0     0   0 sub messagingPrivateRoot { shift->{messagingPrivateRoot} }
842 0     0   0 sub sentList { shift->{sentList} }
843 0     0   0 sub sentListReady { shift->{sentListReady} }
844              
845 0     0   0 sub groupDataSharer { shift->{groupDataSharer} }
846              
847 0     0   0 sub groupRoot { shift->{groupRoot} }
848 0     0   0 sub localRoot { shift->{localRoot} }
849 0     0   0 sub publicDataSelector { shift->{publicDataSelector} }
850 0     0   0 sub actorGroupSelector { shift->{actorGroupSelector} }
851 0     0   0 sub actorSelector { shift->{actorSelector} }
852 0     0   0 sub entrustedActorsSelector { shift->{entrustedActorsSelector} }
853              
854             ### Our own actor ###
855              
856             sub isMe {
857 0     0   0 my $o = shift;
858 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
859              
860 0         0 return $o->{keyPair}->publicKey->hash->equals($actorHash);
861             }
862              
863             sub setName {
864 0     0   0 my $o = shift;
865 0         0 my $name = shift;
866              
867 0         0 $o->{actorSelector}->child('name')->set($name);
868             }
869              
870             sub getName {
871 0     0   0 my $o = shift;
872              
873 0         0 return $o->{actorSelector}->child('name')->textValue;
874             }
875              
876             sub updateMyRegistration {
877 0     0   0 my $o = shift;
878              
879 0         0 $o->{actorSelector}->addObject($o->{keyPair}->publicKey->hash, $o->{keyPair}->publicKey->object);
880 0         0 my $record = CDS::Record->new;
881 0         0 $record->add('hash')->addHash($o->{keyPair}->publicKey->hash);
882 0         0 $record->add('store')->addText($o->{messagingStoreUrl});
883 0         0 $o->{actorSelector}->set($record);
884             }
885              
886             sub setMyActiveFlag {
887 0     0   0 my $o = shift;
888 0         0 my $flag = shift;
889              
890 0         0 $o->{actorSelector}->child('active')->setBoolean($flag);
891             }
892              
893             sub setMyGroupDataFlag {
894 0     0   0 my $o = shift;
895 0         0 my $flag = shift;
896              
897 0         0 $o->{actorSelector}->child('group data')->setBoolean($flag);
898             }
899              
900             ### Actor group
901              
902             sub isGroupMember {
903 0     0   0 my $o = shift;
904 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
905              
906 0 0       0 return 1 if $actorHash->equals($o->{keyPair}->publicKey->hash);
907 0   0     0 my $memberSelector = $o->findMember($actorHash) // return;
908 0         0 return ! $memberSelector->child('revoked')->isSet;
909             }
910              
911             sub findMember {
912 0     0   0 my $o = shift;
913 0 0 0     0 my $memberHash = shift; die 'wrong type '.ref($memberHash).' for $memberHash' if defined $memberHash && ref $memberHash ne 'CDS::Hash';
  0         0  
914              
915 0         0 for my $child ($o->{actorGroupSelector}->children) {
916 0         0 my $record = $child->record;
917 0   0     0 my $hash = $record->child('hash')->hashValue // next;
918 0 0       0 next if ! $hash->equals($memberHash);
919 0         0 return $child;
920             }
921              
922 0         0 return;
923             }
924              
925             sub forgetOldIdleActors {
926 0     0   0 my $o = shift;
927 0         0 my $limit = shift;
928              
929 0         0 for my $child ($o->{actorGroupSelector}->children) {
930 0 0       0 next if $child->child('active')->booleanValue;
931 0 0       0 next if $child->child('group data')->booleanValue;
932 0 0       0 next if $child->revision > $limit;
933 0         0 $child->forgetBranch;
934             }
935             }
936              
937             ### Group data members
938              
939             sub getGroupDataMembers {
940 0     0   0 my $o = shift;
941              
942             # Update the cached list
943 0         0 for my $child ($o->{actorGroupSelector}->children) {
944 0         0 my $record = $child->record;
945 0         0 my $hash = $record->child('hash')->hashValue;
946 0 0       0 $hash = undef if $hash->equals($o->{keyPair}->publicKey->hash);
947 0 0       0 $hash = undef if $child->child('revoked')->isSet;
948 0 0       0 $hash = undef if ! $child->child('group data')->isSet;
949              
950             # Remove
951 0 0       0 if (! $hash) {
952 0         0 delete $o->{cachedGroupDataMembers}->{$child->label};
953 0         0 next;
954             }
955              
956             # Keep
957 0         0 my $member = $o->{cachedGroupDataMembers}->{$child->label};
958 0         0 my $storeUrl = $record->child('store')->textValue;
959 0 0 0     0 next if $member && $member->storeUrl eq $storeUrl && $member->actorOnStore->publicKey->hash->equals($hash);
      0        
960              
961             # Verify the store
962 0         0 my $store = $o->onVerifyMemberStore($storeUrl, $child);
963 0 0       0 if (! $store) {
964 0         0 delete $o->{cachedGroupDataMembers}->{$child->label};
965 0         0 next;
966             }
967              
968             # Reuse the public key and add
969 0 0 0     0 if ($member && $member->actorOnStore->publicKey->hash->equals($hash)) {
970 0         0 my $actorOnStore = CDS::ActorOnStore->new($member->actorOnStore->publicKey, $store);
971 0         0 $o->{cachedEntrustedKeys}->{$child->label} = {storeUrl => $storeUrl, actorOnStore => $actorOnStore};
972             }
973              
974             # Get the public key and add
975 0         0 my ($publicKey, $invalidReason, $storeError) = $o->{keyPair}->getPublicKey($hash, $o->{groupDocument}->unsaved);
976 0 0       0 return if defined $storeError;
977 0 0       0 if (defined $invalidReason) {
978 0         0 delete $o->{cachedGroupDataMembers}->{$child->label};
979 0         0 next;
980             }
981              
982 0         0 my $actorOnStore = CDS::ActorOnStore->new($publicKey, $store);
983 0         0 $o->{cachedGroupDataMembers}->{$child->label} = {storeUrl => $storeUrl, actorOnStore => $actorOnStore};
984             }
985              
986             # Return the current list
987 0         0 return [map { $_->{actorOnStore} } values %{$o->{cachedGroupDataMembers}}];
  0         0  
  0         0  
988             }
989              
990             ### Entrusted actors
991              
992             sub entrust {
993 0     0   0 my $o = shift;
994 0         0 my $storeUrl = shift;
995 0 0 0     0 my $publicKey = shift; die 'wrong type '.ref($publicKey).' for $publicKey' if defined $publicKey && ref $publicKey ne 'CDS::PublicKey';
  0         0  
996              
997             # TODO: this is not compatible with the Java implementation (which uses a record with "hash" and "store")
998 0         0 my $selector = $o->{entrustedActorsSelector};
999 0         0 my $builder = CDS::ActorGroupBuilder->new;
1000 0         0 $builder->parseEntrustedActorList($selector->record, 1);
1001 0         0 $builder->removeEntrustedActor($publicKey->hash);
1002 0         0 $builder->addEntrustedActor($storeUrl, $publicKey->hash);
1003 0         0 $selector->addObject($publicKey->hash, $publicKey->object);
1004 0         0 $selector->set($builder->entrustedActorListToRecord(1));
1005 0         0 $o->{cachedEntrustedKeys}->{$publicKey->hash->bytes} = $publicKey;
1006             }
1007              
1008             sub doNotEntrust {
1009 0     0   0 my $o = shift;
1010 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
1011              
1012 0         0 my $selector = $o->{entrustedActorsSelector};
1013 0         0 my $builder = CDS::ActorGroupBuilder->new;
1014 0         0 $builder->parseEntrustedActorList($selector->record, 1);
1015 0         0 $builder->removeEntrustedActor($hash);
1016 0         0 $selector->set($builder->entrustedActorListToRecord(1));
1017 0         0 delete $o->{cachedEntrustedKeys}->{$hash->bytes};
1018             }
1019              
1020             sub getEntrustedKeys {
1021 0     0   0 my $o = shift;
1022              
1023 0         0 my $entrustedKeys = [];
1024 0         0 for my $storeRecord ($o->{entrustedActorsSelector}->record->children) {
1025 0         0 for my $child ($storeRecord->children) {
1026 0   0     0 my $hash = $child->hash // next;
1027 0   0     0 push @$entrustedKeys, $o->getEntrustedKey($hash) // next;
1028             }
1029             }
1030              
1031             # We could remove unused keys from $o->{cachedEntrustedKeys} here, but since this is
1032             # such a rare event, and doesn't consume a lot of memory, this would be overkill.
1033              
1034 0         0 return $entrustedKeys;
1035             }
1036              
1037             sub getEntrustedKey {
1038 0     0   0 my $o = shift;
1039 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
1040              
1041 0         0 my $entrustedKey = $o->{cachedEntrustedKeys}->{$hash->bytes};
1042 0 0       0 return $entrustedKey if $entrustedKey;
1043              
1044 0         0 my ($publicKey, $invalidReason, $storeError) = $o->{keyPair}->getPublicKey($hash, $o->{groupDocument}->unsaved);
1045 0 0       0 return if defined $storeError;
1046 0 0       0 return if defined $invalidReason;
1047 0         0 $o->{cachedEntrustedKeys}->{$hash->bytes} = $publicKey;
1048 0         0 return $publicKey;
1049             }
1050              
1051             ### Private data
1052              
1053             sub procurePrivateData {
1054 0     0   0 my $o = shift;
1055 0   0     0 my $interval = shift // CDS->DAY;
1056              
1057 0   0     0 $o->{storagePrivateRoot}->procure($interval) // return;
1058 0   0     0 $o->{groupDocument}->read // return;
1059 0   0     0 $o->{localDocument}->read // return;
1060 0         0 return 1;
1061             }
1062              
1063             sub savePrivateDataAndShareGroupData {
1064 0     0   0 my $o = shift;
1065              
1066 0         0 $o->{localDocument}->save;
1067 0         0 $o->{groupDocument}->save;
1068 0         0 $o->groupDataSharer->share;
1069 0   0     0 my $entrustedKeys = $o->getEntrustedKeys // return;
1070 0         0 my ($ok, $missingHash) = $o->{storagePrivateRoot}->save($entrustedKeys);
1071 0 0       0 return 1 if $ok;
1072 0 0       0 $o->onMissingObject($missingHash) if $missingHash;
1073 0         0 return;
1074             }
1075              
1076             # abstract sub onVerifyMemberStore($storeUrl, $selector)
1077             # abstract sub onPrivateRootReadingInvalidEntry($o, $source, $reason)
1078             # abstract sub onMissingObject($missingHash)
1079              
1080             ### Sending messages
1081              
1082             sub procureSentList {
1083 0     0   0 my $o = shift;
1084 0   0     0 my $interval = shift // CDS->DAY;
1085              
1086 0   0     0 $o->{messagingPrivateRoot}->procure($interval) // return;
1087 0   0     0 $o->{sentList}->read // return;
1088 0         0 $o->{sentListReady} = 1;
1089 0         0 return 1;
1090             }
1091              
1092             sub openMessageChannel {
1093 0     0   0 my $o = shift;
1094 0         0 my $label = shift;
1095 0         0 my $validity = shift;
1096              
1097 0         0 return CDS::MessageChannel->new($o, $label, $validity);
1098             }
1099              
1100             sub sendMessages {
1101 0     0   0 my $o = shift;
1102              
1103 0 0       0 return 1 if ! $o->{sentList}->hasChanges;
1104 0         0 $o->{sentList}->save;
1105 0   0     0 my $entrustedKeys = $o->getEntrustedKeys // return;
1106 0         0 my ($ok, $missingHash) = $o->{messagingPrivateRoot}->save($entrustedKeys);
1107 0 0       0 return 1 if $ok;
1108 0 0       0 $o->onMissingObject($missingHash) if $missingHash;
1109 0         0 return;
1110             }
1111              
1112             ### Receiving messages
1113              
1114             # abstract sub onMessageBoxVerifyStore($o, $senderStoreUrl, $hash, $envelope, $senderHash)
1115             # abstract sub onMessage($o, $message)
1116             # abstract sub onInvalidMessage($o, $source, $reason)
1117             # abstract sub onMessageBoxEntry($o, $message)
1118             # abstract sub onMessageBoxInvalidEntry($o, $source, $reason)
1119              
1120             ### Announcing ###
1121              
1122             sub announceOnAllStores {
1123 0     0   0 my $o = shift;
1124              
1125 0         0 $o->announce($o->{storageStore});
1126 0 0       0 $o->announce($o->{messagingStore}) if $o->{messagingStore}->id ne $o->{storageStore}->id;
1127             }
1128              
1129             sub announce {
1130 0     0   0 my $o = shift;
1131 0         0 my $store = shift;
1132              
1133 0 0       0 die 'probably calling old announce, which should now be announceOnAllStores' if ! defined $store;
1134              
1135             # Prepare the actor group
1136 0         0 my $builder = CDS::ActorGroupBuilder->new;
1137              
1138 0         0 my $me = $o->keyPair->publicKey->hash;
1139 0         0 $builder->addMember($me, $o->messagingStoreUrl, CDS->now, 'active');
1140 0         0 for my $child ($o->actorGroupSelector->children) {
1141 0         0 my $record = $child->record;
1142 0   0     0 my $hash = $record->child('hash')->hashValue // next;
1143 0 0       0 next if $hash->equals($me);
1144 0         0 my $storeUrl = $record->child('store')->textValue;
1145 0         0 my $revokedSelector = $child->child('revoked');
1146 0         0 my $activeSelector = $child->child('active');
1147 0         0 my $revision = CDS->max($child->revision, $revokedSelector->revision, $activeSelector->revision);
1148 0 0       0 my $actorStatus = $revokedSelector->booleanValue ? 'revoked' : $activeSelector->booleanValue ? 'active' : 'idle';
    0          
1149 0         0 $builder->addMember($hash, $storeUrl, $revision, $actorStatus);
1150             }
1151              
1152 0 0       0 $builder->parseEntrustedActorList($o->entrustedActorsSelector->record, 1) if $builder->mergeEntrustedActors($o->entrustedActorsSelector->revision);
1153              
1154             # Create the card
1155 0         0 my $card = $builder->toRecord(0);
1156 0         0 $card->add('public key')->addHash($o->{keyPair}->publicKey->hash);
1157              
1158             # Add the public data
1159 0         0 for my $child ($o->publicDataSelector->children) {
1160 0         0 my $childRecord = $child->record;
1161 0         0 $card->addRecord($childRecord->children);
1162             }
1163              
1164             # Create an unsaved state
1165 0         0 my $unsaved = CDS::Unsaved->new($o->publicDataSelector->document->unsaved);
1166              
1167             # Add the public card and the public key
1168 0         0 my $cardObject = $card->toObject;
1169 0         0 my $cardHash = $cardObject->calculateHash;
1170 0         0 $unsaved->state->addObject($cardHash, $cardObject);
1171 0         0 $unsaved->state->addObject($me, $o->keyPair->publicKey->object);
1172              
1173             # Prepare the public envelope
1174 0         0 my $envelopeObject = $o->keyPair->createPublicEnvelope($cardHash)->toObject;
1175 0         0 my $envelopeHash = $envelopeObject->calculateHash;
1176              
1177             # Upload the objects
1178 0         0 my ($missingObject, $transferStore, $transferError) = $o->keyPair->transfer([$cardHash], $unsaved, $store);
1179 0 0       0 return if defined $transferError;
1180 0 0       0 if ($missingObject) {
1181 0         0 $missingObject->{context} = 'announce on '.$store->id;
1182 0         0 $o->onMissingObject($missingObject);
1183 0         0 return;
1184             }
1185              
1186             # Prepare to modify
1187 0         0 my $modifications = CDS::StoreModifications->new;
1188 0         0 $modifications->add($me, 'public', $envelopeHash, $envelopeObject);
1189              
1190             # List the current cards to remove them
1191             # Ignore errors, in the worst case, we are going to have multiple entries in the public box
1192 0         0 my ($hashes, $error) = $store->list($me, 'public', 0, $o->keyPair);
1193 0 0       0 if ($hashes) {
1194 0         0 for my $hash (@$hashes) {
1195 0         0 $modifications->remove($me, 'public', $hash);
1196             }
1197             }
1198              
1199             # Modify the public box
1200 0         0 my $modifyError = $store->modify($modifications, $o->keyPair);
1201 0 0       0 return if defined $modifyError;
1202 0         0 return $envelopeHash, $cardHash;
1203             }
1204              
1205             # The result of parsing a BOX token (see Token.pm).
1206             package CDS::BoxToken;
1207              
1208             sub new {
1209 0     0   0 my $class = shift;
1210 0         0 my $accountToken = shift;
1211 0         0 my $boxLabel = shift;
1212              
1213 0         0 return bless {
1214             accountToken => $accountToken,
1215             boxLabel => $boxLabel
1216             };
1217             }
1218              
1219 0     0   0 sub accountToken { shift->{accountToken} }
1220 0     0   0 sub boxLabel { shift->{boxLabel} }
1221             sub url {
1222 0     0   0 my $o = shift;
1223 0         0 $o->{accountToken}->url.'/'.$o->{boxLabel} }
1224              
1225             package CDS::CLIActor;
1226              
1227 1     1   7150 use parent -norequire, 'CDS::ActorWithDocument';
  1         2  
  1         7  
1228              
1229             sub openOrCreateDefault {
1230 0     0   0 my $class = shift;
1231 0         0 my $ui = shift;
1232              
1233 0         0 $class->open(CDS::Configuration->getOrCreateDefault($ui));
1234             }
1235              
1236             sub open {
1237 0     0   0 my $class = shift;
1238 0         0 my $configuration = shift;
1239              
1240             # Read the store configuration
1241 0         0 my $ui = $configuration->ui;
1242 0         0 my $storeManager = CDS::CLIStoreManager->new($ui);
1243              
1244 0         0 my $storageStoreUrl = $configuration->storageStoreUrl;
1245 0   0     0 my $storageStore = $storeManager->storeForUrl($storageStoreUrl) // return $ui->error('Your storage store "', $storageStoreUrl, '" cannot be accessed. You can set this store in "', $configuration->file('store'), '".');
1246              
1247 0         0 my $messagingStoreUrl = $configuration->messagingStoreUrl;
1248 0   0     0 my $messagingStore = $storeManager->storeForUrl($messagingStoreUrl) // return $ui->error('Your messaging store "', $messagingStoreUrl, '" cannot be accessed. You can set this store in "', $configuration->file('messaging-store'), '".');
1249              
1250             # Read the key pair
1251 0   0     0 my $keyPair = $configuration->keyPair // return $ui->error('Your key pair (', $configuration->file('key-pair'), ') is missing.');
1252              
1253             # Create the actor
1254 0         0 my $publicKeyCache = CDS::PublicKeyCache->new(128);
1255 0         0 my $o = $class->SUPER::new($keyPair, $storageStore, $messagingStore, $messagingStoreUrl, $publicKeyCache);
1256 0         0 $o->{ui} = $ui;
1257 0         0 $o->{storeManager} = $storeManager;
1258 0         0 $o->{configuration} = $configuration;
1259 0         0 $o->{sessionRoot} = $o->localRoot->child('sessions')->child(''.getppid);
1260 0         0 $o->{keyPairToken} = CDS::KeyPairToken->new($configuration->file('key-pair'), $keyPair);
1261              
1262             # Message handlers
1263 0         0 $o->{messageHandlers} = {};
1264 0         0 $o->setMessageHandler('sender', \&onIgnoreMessage);
1265 0         0 $o->setMessageHandler('store', \&onIgnoreMessage);
1266 0         0 $o->setMessageHandler('group data', \&onGroupDataMessage);
1267              
1268             # Read the private data
1269 0 0       0 if (! $o->procurePrivateData) {
1270 0         0 $o->{ui}->space;
1271 0         0 $ui->pRed('Failed to read the local private data.');
1272 0         0 $o->{ui}->space;
1273 0         0 return;
1274             }
1275              
1276 0         0 return $o;
1277             }
1278              
1279 0     0   0 sub ui { shift->{ui} }
1280 0     0   0 sub storeManager { shift->{storeManager} }
1281 0     0   0 sub configuration { shift->{configuration} }
1282 0     0   0 sub sessionRoot { shift->{sessionRoot} }
1283 0     0   0 sub keyPairToken { shift->{keyPairToken} }
1284              
1285             ### Saving
1286              
1287             sub saveOrShowError {
1288 0     0   0 my $o = shift;
1289              
1290 0         0 $o->forgetOldSessions;
1291 0         0 my ($ok, $missingHash) = $o->savePrivateDataAndShareGroupData;
1292 0 0       0 return if ! $ok;
1293 0 0       0 return $o->onMissingObject($missingHash) if $missingHash;
1294 0         0 $o->sendMessages;
1295 0         0 return 1;
1296             }
1297              
1298             sub onMissingObject {
1299 0     0   0 my $o = shift;
1300 0 0 0     0 my $missingObject = shift; die 'wrong type '.ref($missingObject).' for $missingObject' if defined $missingObject && ref $missingObject ne 'CDS::Object';
  0         0  
1301              
1302 0         0 $o->{ui}->space;
1303 0         0 $o->{ui}->pRed('The object ', $missingObject->hash->hex, ' was missing while saving data.');
1304 0         0 $o->{ui}->space;
1305 0         0 $o->{ui}->p('This is a fatal error with two possible sources:');
1306 0         0 $o->{ui}->p('- A store may have lost objects, e.g. due to an error with the underlying storage, misconfiguration, or too aggressive garbage collection.');
1307 0         0 $o->{ui}->p('- The application is linking objects without properly storing them. This is an error in the application, that must be fixed by a developer.');
1308 0         0 $o->{ui}->space;
1309             }
1310              
1311             sub onGroupDataSharingStoreError {
1312 0     0   0 my $o = shift;
1313 0 0 0     0 my $recipientActorOnStore = shift; die 'wrong type '.ref($recipientActorOnStore).' for $recipientActorOnStore' if defined $recipientActorOnStore && ref $recipientActorOnStore ne 'CDS::ActorOnStore';
  0         0  
1314 0         0 my $storeError = shift;
1315              
1316 0         0 $o->{ui}->space;
1317 0         0 $o->{ui}->pRed('Unable to share the group data with ', $recipientActorOnStore->publicKey->hash->hex, '.');
1318 0         0 $o->{ui}->space;
1319             }
1320              
1321             ### Reading
1322              
1323             sub onPrivateRootReadingInvalidEntry {
1324 0     0   0 my $o = shift;
1325 0 0 0     0 my $source = shift; die 'wrong type '.ref($source).' for $source' if defined $source && ref $source ne 'CDS::Source';
  0         0  
1326 0         0 my $reason = shift;
1327              
1328 0         0 $o->{ui}->space;
1329 0         0 $o->{ui}->pRed('The envelope ', $source->hash->shortHex, ' points to invalid private data (', $reason, ').');
1330 0         0 $o->{ui}->p('This could be due to a storage system failure, a malicious attempt to delete or modify your data, or simply an application error. To investigate what is going on, the following commands may be helpful:');
1331 0         0 $o->{ui}->line(' cds open envelope ', $source->hash->hex, ' from ', $source->actorOnStore->publicKey->hash->hex, ' on ', $source->actorOnStore->store->url);
1332 0         0 $o->{ui}->line(' cds show record ', $source->hash->hex, ' on ', $source->actorOnStore->store->url);
1333 0         0 $o->{ui}->line(' cds list private box of ', $source->actorOnStore->publicKey->hash->hex, ' on ', $source->actorOnStore->store->url);
1334 0         0 $o->{ui}->p('To remove the invalid entry, type:');
1335 0         0 $o->{ui}->line(' cds remove ', $source->hash->hex, ' from private box of ', $source->actorOnStore->publicKey->hash->hex, ' on ', $source->actorOnStore->store->url);
1336 0         0 $o->{ui}->space;
1337             }
1338              
1339             sub onVerifyMemberStore {
1340 0     0   0 my $o = shift;
1341 0         0 my $storeUrl = shift;
1342 0 0 0     0 my $actorSelector = shift; die 'wrong type '.ref($actorSelector).' for $actorSelector' if defined $actorSelector && ref $actorSelector ne 'CDS::Selector';
  0         0  
1343 0         0 $o->storeForUrl($storeUrl) }
1344              
1345             ### Announcing
1346              
1347             sub registerIfNecessary {
1348 0     0   0 my $o = shift;
1349              
1350 0         0 my $now = CDS->now;
1351 0 0       0 return if $o->{actorSelector}->revision > $now - CDS->DAY;
1352 0         0 $o->updateMyRegistration;
1353 0         0 $o->setMyActiveFlag(1);
1354 0         0 $o->setMyGroupDataFlag(1);
1355             }
1356              
1357             sub announceIfNecessary {
1358 0     0   0 my $o = shift;
1359              
1360 0         0 my $state = join('', map { CDS->bytesFromUnsigned($_->revision) } sort { $a->label cmp $b->label } $o->{actorGroupSelector}->children);
  0         0  
  0         0  
1361 0         0 $o->announceOnStoreIfNecessary($o->{storageStore}, $state);
1362 0 0       0 $o->announceOnStoreIfNecessary($o->{messagingStore}, $state) if $o->{messagingStore}->id ne $o->{storageStore}->id;
1363             }
1364              
1365             sub announceOnStoreIfNecessary {
1366 0     0   0 my $o = shift;
1367 0         0 my $store = shift;
1368 0         0 my $state = shift;
1369              
1370 0         0 my $stateSelector = $o->{localRoot}->child('announced')->childWithText($store->id);
1371 0 0       0 return if $stateSelector->bytesValue eq $state;
1372 0         0 my ($envelopeHash, $cardHash) = $o->announce($store);
1373 0 0       0 return $o->{ui}->pRed('Updating the card on ', $store->url, ' failed.') if ! $envelopeHash;
1374 0         0 $stateSelector->setBytes($state);
1375 0         0 $o->{ui}->pGreen('The card on ', $store->url, ' has been updated.');
1376 0         0 return 1;
1377             }
1378              
1379             ### Store resolving
1380              
1381             sub storeForUrl {
1382 0     0   0 my $o = shift;
1383 0         0 my $url = shift;
1384              
1385 0         0 $o->{storeManager}->setCacheStoreUrl($o->{sessionRoot}->child('use cache')->textValue);
1386 0         0 return $o->{storeManager}->storeForUrl($url);
1387             }
1388              
1389             ### Processing messages
1390              
1391             sub setMessageHandler {
1392 0     0   0 my $o = shift;
1393 0         0 my $type = shift;
1394 0         0 my $handler = shift;
1395              
1396 0         0 $o->{messageHandlers}->{$type} = $handler;
1397             }
1398              
1399             sub readMessages {
1400 0     0   0 my $o = shift;
1401              
1402 0         0 $o->{ui}->title('Messages');
1403 0         0 $o->{countMessages} = 0;
1404 0         0 $o->{messageBoxReader}->read;
1405 0 0       0 $o->{ui}->line($o->{ui}->gray('none')) if ! $o->{countMessages};
1406             }
1407              
1408             sub onMessageBoxVerifyStore {
1409 0     0   0 my $o = shift;
1410 0         0 my $senderStoreUrl = shift;
1411 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
1412 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
1413 0 0 0     0 my $senderHash = shift; die 'wrong type '.ref($senderHash).' for $senderHash' if defined $senderHash && ref $senderHash ne 'CDS::Hash';
  0         0  
1414              
1415 0         0 return $o->storeForUrl($senderStoreUrl);
1416             }
1417              
1418             sub onMessageBoxEntry {
1419 0     0   0 my $o = shift;
1420 0         0 my $message = shift;
1421              
1422 0         0 $o->{countMessages} += 1;
1423              
1424 0         0 for my $section ($message->content->children) {
1425 0         0 my $type = $section->bytes;
1426 0   0     0 my $handler = $o->{messageHandlers}->{$type} // \&onUnknownMessage;
1427 0         0 &$handler($o, $message, $section);
1428             }
1429              
1430             # 1. message processed
1431             # -> source can be deleted immediately (e.g. invalid)
1432             # source.discard()
1433             # -> source has been merged, and will be deleted when changes have been saved
1434             # document.addMergedSource(source)
1435             # 2. wait for sender store
1436             # -> set entry.waitForStore = senderStore
1437             # 3. skip
1438             # -> set entry.processed = false
1439              
1440 0         0 my $source = $message->source;
1441 0         0 $message->source->discard;
1442             }
1443              
1444             sub onGroupDataMessage {
1445 0     0   0 my $o = shift;
1446 0         0 my $message = shift;
1447 0         0 my $section = shift;
1448              
1449 0         0 my $ok = $o->{groupDataSharer}->processGroupDataMessage($message, $section);
1450 0         0 $o->{groupDocument}->read;
1451 0 0       0 return $o->{ui}->line('Group data from ', $message->sender->publicKey->hash->hex) if $ok;
1452 0         0 $o->{ui}->line($o->{ui}->red('Group data from foreign actor ', $message->sender->publicKey->hash->hex, ' (ignored)'));
1453             }
1454              
1455             sub onIgnoreMessage {
1456 0     0   0 my $o = shift;
1457 0         0 my $message = shift;
1458 0         0 my $section = shift;
1459             }
1460              
1461             sub onUnknownMessage {
1462 0     0   0 my $o = shift;
1463 0         0 my $message = shift;
1464 0         0 my $section = shift;
1465              
1466 0         0 $o->{ui}->line($o->{ui}->orange('Unknown message of type "', $section->asText, '" from ', $message->sender->publicKey->hash->hex));
1467             }
1468              
1469             sub onMessageBoxInvalidEntry {
1470 0     0   0 my $o = shift;
1471 0 0 0     0 my $source = shift; die 'wrong type '.ref($source).' for $source' if defined $source && ref $source ne 'CDS::Source';
  0         0  
1472 0         0 my $reason = shift;
1473              
1474 0         0 $o->{ui}->warning('Discarding invalid message ', $source->hash->hex, ' (', $reason, ').');
1475 0         0 $source->discard;
1476             }
1477              
1478             ### Remembered values
1479              
1480             sub labelSelector {
1481 0     0   0 my $o = shift;
1482 0         0 my $label = shift;
1483              
1484 0         0 my $bytes = Encode::encode_utf8($label);
1485 0         0 return $o->groupRoot->child('labels')->child($bytes);
1486             }
1487              
1488             sub remembered {
1489 0     0   0 my $o = shift;
1490 0         0 my $label = shift;
1491              
1492 0         0 return $o->labelSelector($label)->record;
1493             }
1494              
1495             sub remember {
1496 0     0   0 my $o = shift;
1497 0         0 my $label = shift;
1498 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
1499              
1500 0         0 $o->labelSelector($label)->set($record);
1501             }
1502              
1503             sub rememberedRecords {
1504 0     0   0 my $o = shift;
1505              
1506 0         0 my $records = {};
1507 0         0 for my $child ($o->{groupRoot}->child('labels')->children) {
1508 0 0       0 next if ! $child->isSet;
1509 0         0 my $label = Encode::decode_utf8($child->label);
1510 0         0 $records->{$label} = $child->record;
1511             }
1512              
1513 0         0 return $records;
1514             }
1515              
1516             sub storeLabel {
1517 0     0   0 my $o = shift;
1518 0         0 my $storeUrl = shift;
1519              
1520 0         0 my $records = $o->rememberedRecords;
1521 0         0 for my $label (keys %$records) {
1522 0         0 my $record = $records->{$label};
1523 0 0       0 next if length $record->child('actor')->bytesValue;
1524 0 0       0 next if $storeUrl ne $record->child('store')->textValue;
1525 0         0 return $label;
1526             }
1527              
1528 0         0 return;
1529             }
1530              
1531             sub actorLabel {
1532 0     0   0 my $o = shift;
1533 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
1534              
1535 0         0 my $records = $o->rememberedRecords;
1536 0         0 for my $label (keys %$records) {
1537 0         0 my $record = $records->{$label};
1538 0 0       0 next if $actorHash->bytes ne $record->child('actor')->bytesValue;
1539 0         0 return $label;
1540             }
1541              
1542 0         0 return;
1543             }
1544              
1545             sub actorLabelByHashStartBytes {
1546 0     0   0 my $o = shift;
1547 0         0 my $actorHashStartBytes = shift;
1548              
1549 0         0 my $length = length $actorHashStartBytes;
1550 0         0 my $records = $o->rememberedRecords;
1551 0         0 for my $label (keys %$records) {
1552 0         0 my $record = $records->{$label};
1553 0 0       0 next if $actorHashStartBytes ne substr($record->child('actor')->bytesValue, 0, $length);
1554 0         0 return $label;
1555             }
1556              
1557 0         0 return;
1558             }
1559              
1560             sub accountLabel {
1561 0     0   0 my $o = shift;
1562 0         0 my $storeUrl = shift;
1563 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
1564              
1565 0         0 my $storeLabel;
1566             my $actorLabel;
1567              
1568 0         0 my $records = $o->rememberedRecords;
1569 0         0 for my $label (keys %$records) {
1570 0         0 my $record = $records->{$label};
1571 0         0 my $actorBytes = $record->child('actor')->bytesValue;
1572              
1573 0         0 my $correctActor = $actorHash->bytes eq $actorBytes;
1574 0 0       0 $actorLabel = $label if $correctActor;
1575              
1576 0 0       0 if ($storeUrl eq $record->child('store')->textValue) {
1577 0 0       0 return $label if $correctActor;
1578 0 0       0 $storeLabel = $label if ! length $actorBytes;
1579             }
1580             }
1581              
1582 0         0 return (undef, $storeLabel, $actorLabel);
1583             }
1584              
1585             sub keyPairLabel {
1586 0     0   0 my $o = shift;
1587 0         0 my $file = shift;
1588              
1589 0         0 my $records = $o->rememberedRecords;
1590 0         0 for my $label (keys %$records) {
1591 0         0 my $record = $records->{$label};
1592 0 0       0 next if $file ne $record->child('key pair')->textValue;
1593 0         0 return $label;
1594             }
1595              
1596 0         0 return;
1597             }
1598              
1599             ### References that can be used in commands
1600              
1601             sub actorReference {
1602 0     0   0 my $o = shift;
1603 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
1604              
1605 0   0     0 return $o->actorLabel($actorHash) // $actorHash->hex;
1606             }
1607              
1608             sub storeReference {
1609 0     0   0 my $o = shift;
1610 0         0 my $store = shift;
1611 0         0 $o->storeUrlReference($store->url); }
1612              
1613             sub storeUrlReference {
1614 0     0   0 my $o = shift;
1615 0         0 my $storeUrl = shift;
1616              
1617 0   0     0 return $o->storeLabel($storeUrl) // $storeUrl;
1618             }
1619              
1620             sub accountReference {
1621 0     0   0 my $o = shift;
1622 0         0 my $accountToken = shift;
1623              
1624 0         0 my ($accountLabel, $storeLabel, $actorLabel) = $o->accountLabel($accountToken->{cliStore}->url, $accountToken->{actorHash});
1625 0 0       0 return $accountLabel if defined $accountLabel;
1626 0 0       0 return defined $actorLabel ? $actorLabel : $accountToken->{actorHash}->hex, ' on ', defined $storeLabel ? $storeLabel : $accountToken->{cliStore}->url;
    0          
1627             }
1628              
1629             sub boxReference {
1630 0     0   0 my $o = shift;
1631 0         0 my $boxToken = shift;
1632              
1633 0         0 return $o->boxName($boxToken->{boxLabel}), ' of ', $o->accountReference($boxToken->{accountToken});
1634             }
1635              
1636             sub keyPairReference {
1637 0     0   0 my $o = shift;
1638 0         0 my $keyPairToken = shift;
1639              
1640 0   0     0 return $o->keyPairLabel($keyPairToken->file) // $keyPairToken->file;
1641             }
1642              
1643             sub blueActorReference {
1644 0     0   0 my $o = shift;
1645 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
1646              
1647 0         0 my $label = $o->actorLabel($actorHash);
1648 0 0       0 return defined $label ? $o->{ui}->blue($label) : $actorHash->hex;
1649             }
1650              
1651             sub blueStoreReference {
1652 0     0   0 my $o = shift;
1653 0         0 my $store = shift;
1654 0         0 $o->blueStoreUrlReference($store->url); }
1655              
1656             sub blueStoreUrlReference {
1657 0     0   0 my $o = shift;
1658 0         0 my $storeUrl = shift;
1659              
1660 0         0 my $label = $o->storeLabel($storeUrl);
1661 0 0       0 return defined $label ? $o->{ui}->blue($label) : $storeUrl;
1662             }
1663              
1664             sub blueAccountReference {
1665 0     0   0 my $o = shift;
1666 0         0 my $accountToken = shift;
1667              
1668 0         0 my ($accountLabel, $storeLabel, $actorLabel) = $o->accountLabel($accountToken->{cliStore}->url, $accountToken->{actorHash});
1669 0 0       0 return $o->{ui}->blue($accountLabel) if defined $accountLabel;
1670 0 0       0 return defined $actorLabel ? $o->{ui}->blue($actorLabel) : $accountToken->{actorHash}->hex, ' on ', defined $storeLabel ? $o->{ui}->blue($storeLabel) : $accountToken->{cliStore}->url;
    0          
1671             }
1672              
1673             sub blueBoxReference {
1674 0     0   0 my $o = shift;
1675 0         0 my $boxToken = shift;
1676              
1677 0         0 return $o->boxName($boxToken->{boxLabel}), ' of ', $o->blueAccountReference($boxToken->{accountToken});
1678             }
1679              
1680             sub blueKeyPairReference {
1681 0     0   0 my $o = shift;
1682 0         0 my $keyPairToken = shift;
1683              
1684 0         0 my $label = $o->keyPairLabel($keyPairToken->file);
1685 0 0       0 return defined $label ? $o->{ui}->blue($label) : $keyPairToken->file;
1686             }
1687              
1688             sub boxName {
1689 0     0   0 my $o = shift;
1690 0         0 my $boxLabel = shift;
1691              
1692 0 0       0 return 'private box' if $boxLabel eq 'private';
1693 0 0       0 return 'public box' if $boxLabel eq 'public';
1694 0 0       0 return 'message box' if $boxLabel eq 'messages';
1695 0         0 return $boxLabel;
1696             }
1697              
1698             ### Session
1699              
1700             sub forgetOldSessions {
1701 0     0   0 my $o = shift;
1702              
1703 0         0 for my $child ($o->{sessionRoot}->parent->children) {
1704 0         0 my $pid = $child->label;
1705 0 0       0 next if -e '/proc/'.$pid;
1706 0         0 $child->forgetBranch;
1707             }
1708             }
1709              
1710             sub selectedKeyPairToken {
1711 0     0   0 my $o = shift;
1712              
1713 0         0 my $file = $o->{sessionRoot}->child('selected key pair')->textValue;
1714 0 0       0 return if ! length $file;
1715 0   0     0 my $keyPair = CDS::KeyPair->fromFile($file) // return;
1716 0         0 return CDS::KeyPairToken->new($file, $keyPair);
1717             }
1718              
1719             sub selectedStoreUrl {
1720 0     0   0 my $o = shift;
1721              
1722 0         0 my $storeUrl = $o->{sessionRoot}->child('selected store')->textValue;
1723 0 0       0 return if ! length $storeUrl;
1724 0         0 return $storeUrl;
1725             }
1726              
1727             sub selectedStore {
1728 0     0   0 my $o = shift;
1729              
1730 0   0     0 my $storeUrl = $o->selectedStoreUrl // return;
1731 0         0 return $o->storeForUrl($storeUrl);
1732             }
1733              
1734             sub selectedActorHash {
1735 0     0   0 my $o = shift;
1736              
1737 0         0 return CDS::Hash->fromBytes($o->{sessionRoot}->child('selected actor')->bytesValue);
1738             }
1739              
1740             sub preferredKeyPairToken {
1741 0     0   0 my $o = shift;
1742 0   0     0 $o->selectedKeyPairToken // $o->keyPairToken }
1743             sub preferredStore {
1744 0     0   0 my $o = shift;
1745 0   0     0 $o->selectedStore // $o->storageStore }
1746             sub preferredStores {
1747 0     0   0 my $o = shift;
1748 0   0     0 $o->selectedStore // ($o->storageStore, $o->messagingStore) }
1749             sub preferredActorHash {
1750 0     0   0 my $o = shift;
1751 0   0     0 $o->selectedActorHash // $o->keyPair->publicKey->hash }
1752              
1753             ### Common functions
1754              
1755             sub uiGetObject {
1756 0     0   0 my $o = shift;
1757 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
1758 0         0 my $store = shift;
1759 0         0 my $keyPairToken = shift;
1760              
1761 0         0 my ($object, $storeError) = $store->get($hash, $keyPairToken->keyPair);
1762 0 0       0 return if defined $storeError;
1763 0 0       0 return $o->{ui}->error('The object ', $hash->hex, ' does not exist on "', $store->url, '".') if ! $object;
1764 0         0 return $object;
1765             }
1766              
1767             sub uiGetRecord {
1768 0     0   0 my $o = shift;
1769 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
1770 0         0 my $store = shift;
1771 0         0 my $keyPairToken = shift;
1772              
1773 0   0     0 my $object = $o->uiGetObject($hash, $store, $keyPairToken) // return;
1774 0   0     0 return CDS::Record->fromObject($object) // return $o->{ui}->error('The object ', $hash->hex, ' is not a record.');
1775             }
1776              
1777             sub uiGetPublicKey {
1778 0     0   0 my $o = shift;
1779 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
1780 0         0 my $store = shift;
1781 0         0 my $keyPairToken = shift;
1782              
1783 0   0     0 my $object = $o->uiGetObject($hash, $store, $keyPairToken) // return;
1784 0   0     0 return CDS::PublicKey->fromObject($object) // return $o->{ui}->error('The object ', $hash->hex, ' is not a public key.');
1785             }
1786              
1787             sub isEnvelope {
1788 0     0   0 my $o = shift;
1789 0 0 0     0 my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0         0  
1790              
1791 0   0     0 my $record = CDS::Record->fromObject($object) // return;
1792 0 0       0 return if ! $record->contains('signed');
1793 0         0 my $signatureRecord = $record->child('signature')->firstChild;
1794 0 0       0 return if ! $signatureRecord->hash;
1795 0 0       0 return if ! length $signatureRecord->bytes;
1796 0         0 return 1;
1797             }
1798              
1799             package CDS::CLIStoreManager;
1800              
1801             sub new {
1802 0     0   0 my $class = shift;
1803 0         0 my $ui = shift;
1804              
1805 0         0 return bless {ui => $ui, failedStores => {}};
1806             }
1807              
1808 0     0   0 sub ui { shift->{ui} }
1809              
1810             sub rawStoreForUrl {
1811 0     0   0 my $o = shift;
1812 0         0 my $url = shift;
1813              
1814 0 0       0 return if ! $url;
1815             return
1816 0   0     0 CDS::FolderStore->forUrl($url) //
      0        
1817             CDS::HTTPStore->forUrl($url) //
1818             undef;
1819             }
1820              
1821             sub storeForUrl {
1822 0     0   0 my $o = shift;
1823 0         0 my $url = shift;
1824              
1825 0         0 my $store = $o->rawStoreForUrl($url);
1826 0         0 my $progressStore = CDS::UI::ProgressStore->new($store, $url, $o->{ui});
1827 0 0       0 my $cachedStore = defined $o->{cacheStore} ? CDS::ObjectCache->new($progressStore, $o->{cacheStore}) : $progressStore;
1828 0         0 return CDS::ErrorHandlingStore->new($cachedStore, $url, $o);
1829             }
1830              
1831             sub onStoreSuccess {
1832 0     0   0 my $o = shift;
1833 0         0 my $store = shift;
1834 0         0 my $function = shift;
1835              
1836 0         0 delete $o->{failedStores}->{$store->store->id};
1837             }
1838              
1839             sub onStoreError {
1840 0     0   0 my $o = shift;
1841 0         0 my $store = shift;
1842 0         0 my $function = shift;
1843 0         0 my $error = shift;
1844              
1845 0         0 $o->{failedStores}->{$store->store->id} = 1;
1846 0         0 $o->{ui}->error('The store "', $store->{url}, '" reports: ', $error);
1847             }
1848              
1849             sub hasStoreError {
1850 0     0   0 my $o = shift;
1851 0         0 my $store = shift;
1852 0         0 my $function = shift;
1853              
1854 0 0       0 return if ! $o->{failedStores}->{$store->store->id};
1855 0         0 $o->{ui}->error('Ignoring store "', $store->{url}, '", because it previously reported errors.');
1856 0         0 return 1;
1857             }
1858              
1859             sub setCacheStoreUrl {
1860 0     0   0 my $o = shift;
1861 0         0 my $storeUrl = shift;
1862              
1863 0 0 0     0 return if ($storeUrl // '') eq ($o->{cacheStoreUrl} // '');
      0        
1864 0         0 $o->{cacheStoreUrl} = $storeUrl;
1865 0         0 $o->{cacheStore} = $o->rawStoreForUrl($storeUrl);
1866             }
1867              
1868             package CDS::CheckSignatureStore;
1869              
1870             sub new {
1871 0     0   0 my $o = shift;
1872 0         0 my $store = shift;
1873 0         0 my $objects = shift;
1874              
1875 0   0     0 return bless {
1876             store => $store,
1877             id => "Check signature store\n".$store->id,
1878             objects => $objects // {},
1879             };
1880             }
1881              
1882 0     0   0 sub id { shift->{id} }
1883              
1884             sub get {
1885 0     0   0 my $o = shift;
1886 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
1887 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
1888              
1889 0   0     0 my $entry = $o->{objects}->{$hash->bytes} // return $o->{store}->get($hash);
1890 0         0 return $entry->{object};
1891             }
1892              
1893             sub book {
1894 0     0   0 my $o = shift;
1895 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
1896 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
1897              
1898 0         0 return exists $o->{objects}->{$hash->bytes};
1899             }
1900              
1901             sub put {
1902 0     0   0 my $o = shift;
1903 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
1904 0 0 0     0 my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0         0  
1905 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
1906              
1907 0         0 $o->{objects}->{$hash->bytes} = {hash => $hash, object => $object};
1908 0         0 return;
1909             }
1910              
1911             sub list {
1912 0     0   0 my $o = shift;
1913 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
1914 0         0 my $boxLabel = shift;
1915 0         0 my $timeout = shift;
1916 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
1917              
1918 0         0 return 'This store only handles objects.';
1919             }
1920              
1921             sub add {
1922 0     0   0 my $o = shift;
1923 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
1924 0         0 my $boxLabel = shift;
1925 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
1926 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
1927              
1928 0         0 return 'This store only handles objects.';
1929             }
1930              
1931             sub remove {
1932 0     0   0 my $o = shift;
1933 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
1934 0         0 my $boxLabel = shift;
1935 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
1936 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
1937              
1938 0         0 return 'This store only handles objects.';
1939             }
1940              
1941             sub modify {
1942 0     0   0 my $o = shift;
1943 0         0 my $modifications = shift;
1944 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
1945              
1946 0         0 return $modifications->executeIndividually($o, $keyPair);
1947             }
1948              
1949             # BEGIN AUTOGENERATED
1950             package CDS::Commands::ActorGroup;
1951              
1952             sub register {
1953 0     0   0 my $class = shift;
1954 0         0 my $cds = shift;
1955 0         0 my $help = shift;
1956              
1957 0         0 my $node000 = CDS::Parser::Node->new(0);
1958 0         0 my $node001 = CDS::Parser::Node->new(0);
1959 0         0 my $node002 = CDS::Parser::Node->new(0);
1960 0         0 my $node003 = CDS::Parser::Node->new(0);
1961 0         0 my $node004 = CDS::Parser::Node->new(0);
1962 0         0 my $node005 = CDS::Parser::Node->new(0);
1963 0         0 my $node006 = CDS::Parser::Node->new(0);
1964 0         0 my $node007 = CDS::Parser::Node->new(0);
1965 0         0 my $node008 = CDS::Parser::Node->new(0);
1966 0         0 my $node009 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
1967 0         0 my $node010 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&show});
1968 0         0 my $node011 = CDS::Parser::Node->new(0);
1969 0         0 my $node012 = CDS::Parser::Node->new(0);
1970 0         0 my $node013 = CDS::Parser::Node->new(0);
1971 0         0 my $node014 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&joinMember});
1972 0         0 my $node015 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&setMember});
1973 0         0 my $node016 = CDS::Parser::Node->new(0);
1974 0         0 $cds->addArrow($node001, 1, 0, 'show');
1975 0         0 $cds->addArrow($node003, 1, 0, 'join');
1976 0         0 $cds->addArrow($node004, 1, 0, 'set');
1977 0         0 $help->addArrow($node000, 1, 0, 'actor');
1978 0         0 $node000->addArrow($node009, 1, 0, 'group');
1979 0         0 $node001->addArrow($node002, 1, 0, 'actor');
1980 0         0 $node002->addArrow($node010, 1, 0, 'group');
1981 0         0 $node003->addArrow($node005, 1, 0, 'member');
1982 0         0 $node004->addArrow($node007, 1, 0, 'member');
1983 0         0 $node005->addDefault($node006);
1984 0         0 $node005->addArrow($node011, 1, 0, 'ACTOR', \&collectActor);
1985 0         0 $node006->addArrow($node006, 1, 0, 'ACCOUNT', \&collectAccount);
1986 0         0 $node006->addArrow($node014, 1, 1, 'ACCOUNT', \&collectAccount);
1987 0         0 $node007->addDefault($node008);
1988 0         0 $node008->addArrow($node008, 1, 0, 'ACTOR', \&collectActor1);
1989 0         0 $node008->addArrow($node013, 1, 0, 'ACTOR', \&collectActor1);
1990 0         0 $node011->addArrow($node012, 1, 0, 'on');
1991 0         0 $node012->addArrow($node014, 1, 0, 'STORE', \&collectStore);
1992 0         0 $node013->addArrow($node015, 1, 0, 'active', \&collectActive);
1993 0         0 $node013->addArrow($node015, 1, 0, 'backup', \&collectBackup);
1994 0         0 $node013->addArrow($node015, 1, 0, 'idle', \&collectIdle);
1995 0         0 $node013->addArrow($node015, 1, 0, 'revoked', \&collectRevoked);
1996 0         0 $node014->addArrow($node016, 1, 0, 'and');
1997 0         0 $node016->addDefault($node005);
1998             }
1999              
2000             sub collectAccount {
2001 0     0   0 my $o = shift;
2002 0         0 my $label = shift;
2003 0         0 my $value = shift;
2004              
2005 0         0 push @{$o->{accountTokens}}, $value;
  0         0  
2006             }
2007              
2008             sub collectActive {
2009 0     0   0 my $o = shift;
2010 0         0 my $label = shift;
2011 0         0 my $value = shift;
2012              
2013 0         0 $o->{status} = 'active';
2014             }
2015              
2016             sub collectActor {
2017 0     0   0 my $o = shift;
2018 0         0 my $label = shift;
2019 0         0 my $value = shift;
2020              
2021 0         0 $o->{actorHash} = $value;
2022             }
2023              
2024             sub collectActor1 {
2025 0     0   0 my $o = shift;
2026 0         0 my $label = shift;
2027 0         0 my $value = shift;
2028              
2029 0         0 push @{$o->{actorHashes}}, $value;
  0         0  
2030             }
2031              
2032             sub collectBackup {
2033 0     0   0 my $o = shift;
2034 0         0 my $label = shift;
2035 0         0 my $value = shift;
2036              
2037 0         0 $o->{status} = 'backup';
2038             }
2039              
2040             sub collectIdle {
2041 0     0   0 my $o = shift;
2042 0         0 my $label = shift;
2043 0         0 my $value = shift;
2044              
2045 0         0 $o->{status} = 'idle';
2046             }
2047              
2048             sub collectRevoked {
2049 0     0   0 my $o = shift;
2050 0         0 my $label = shift;
2051 0         0 my $value = shift;
2052              
2053 0         0 $o->{status} = 'revoked';
2054             }
2055              
2056             sub collectStore {
2057 0     0   0 my $o = shift;
2058 0         0 my $label = shift;
2059 0         0 my $value = shift;
2060              
2061 0         0 push @{$o->{accountTokens}}, CDS::AccountToken->new($value, $o->{actorHash});
  0         0  
2062 0         0 delete $o->{actorHash};
2063             }
2064              
2065             sub new {
2066 0     0   0 my $class = shift;
2067 0         0 my $actor = shift;
2068 0         0 bless {actor => $actor, ui => $actor->ui} }
2069              
2070             # END AUTOGENERATED
2071              
2072             # HTML FOLDER NAME actor-group
2073             # HTML TITLE Actor group
2074             sub help {
2075 0     0   0 my $o = shift;
2076 0         0 my $cmd = shift;
2077              
2078 0         0 my $ui = $o->{ui};
2079 0         0 $ui->space;
2080 0         0 $ui->command('cds show actor group');
2081 0         0 $ui->p('Shows all members of our actor group and the entrusted keys.');
2082 0         0 $ui->space;
2083 0         0 $ui->command('cds join ACCOUNT*');
2084 0         0 $ui->command('cds join ACTOR on STORE');
2085 0         0 $ui->p('Adds a member to our actor group. To complete the association, the new member must join us, too.');
2086 0         0 $ui->space;
2087 0         0 $ui->command('cds set member ACTOR* active');
2088 0         0 $ui->command('cds set member ACTOR* backup');
2089 0         0 $ui->command('cds set member ACTOR* idle');
2090 0         0 $ui->command('cds set member ACTOR* revoked');
2091 0         0 $ui->p('Changes the status of a member to one of the following:');
2092 0         0 $ui->p($ui->bold('Active members'), ' share the group data among themselves, and are advertised to receive messages.');
2093 0         0 $ui->p($ui->bold('Backup members'), ' share the group data (like active members), but are publicly advertised as not processing messages (like idle members). This is suitable for backup actors.');
2094 0         0 $ui->p($ui->bold('Idle members'), ' are part of the group, but advertised as not processing messages. They generally do not have the latest group data, and may have no group data at all. Idle members may reactivate themselves, or get reactivated by any active member of the group.');
2095 0         0 $ui->p($ui->bold('Revoked members'), ' have explicitly been removed from the group, e.g. because their private key (or device) got lost. Revoked members can be reactivated by any active member of the group.');
2096 0         0 $ui->p('Note that changing the status does not start or stop the corresponding actor, but just change how it is regarded by others. The status of each member should reflect its actual behavior.');
2097 0         0 $ui->space;
2098 0         0 $ui->p('After modifying the actor group members, you should "cds announce" yourself to publish the changes.');
2099 0         0 $ui->space;
2100             }
2101              
2102             sub show {
2103 0     0   0 my $o = shift;
2104 0         0 my $cmd = shift;
2105              
2106 0         0 my $hasMembers = 0;
2107 0         0 for my $actorSelector ($o->{actor}->actorGroupSelector->children) {
2108 0         0 my $record = $actorSelector->record;
2109 0   0     0 my $hash = $record->child('hash')->hashValue // next;
2110 0 0       0 next if substr($hash->bytes, 0, length $actorSelector->label) ne $actorSelector->label;
2111 0         0 my $storeUrl = $record->child('store')->textValue;
2112 0         0 my $revisionText = $o->{ui}->niceDateTimeLocal($actorSelector->revision);
2113 0         0 $o->{ui}->line($o->{ui}->gray($revisionText), ' ', $o->coloredType7($actorSelector), ' ', $hash->hex, ' on ', $storeUrl);
2114 0         0 $hasMembers = 1;
2115             }
2116              
2117 0 0       0 return if $hasMembers;
2118 0         0 $o->{ui}->line($o->{ui}->blue('(just you)'));
2119             }
2120              
2121             sub type {
2122 0     0   0 my $o = shift;
2123 0 0 0     0 my $actorSelector = shift; die 'wrong type '.ref($actorSelector).' for $actorSelector' if defined $actorSelector && ref $actorSelector ne 'CDS::Selector';
  0         0  
2124              
2125 0         0 my $groupData = $actorSelector->child('group data')->isSet;
2126 0         0 my $active = $actorSelector->child('active')->isSet;
2127 0         0 my $revoked = $actorSelector->child('revoked')->isSet;
2128             return
2129 0 0 0     0 $revoked ? 'revoked' :
    0          
    0          
    0          
2130             $active && $groupData ? 'active' :
2131             $groupData ? 'backup' :
2132             $active ? 'weird' :
2133             'idle';
2134             }
2135              
2136             sub coloredType7 {
2137 0     0   0 my $o = shift;
2138 0 0 0     0 my $actorSelector = shift; die 'wrong type '.ref($actorSelector).' for $actorSelector' if defined $actorSelector && ref $actorSelector ne 'CDS::Selector';
  0         0  
2139              
2140 0         0 my $groupData = $actorSelector->child('group data')->isSet;
2141 0         0 my $active = $actorSelector->child('active')->isSet;
2142 0         0 my $revoked = $actorSelector->child('revoked')->isSet;
2143             return
2144             $revoked ? $o->{ui}->red('revoked') :
2145             $active && $groupData ? $o->{ui}->green('active ') :
2146             $groupData ? $o->{ui}->blue('backup ') :
2147             $active ? $o->{ui}->orange('weird ') :
2148 0 0 0     0 $o->{ui}->gray('idle ');
    0          
    0          
    0          
2149             }
2150              
2151             sub joinMember {
2152 0     0   0 my $o = shift;
2153 0         0 my $cmd = shift;
2154              
2155 0         0 $o->{accountTokens} = [];
2156 0         0 $cmd->collect($o);
2157              
2158 0         0 my $selector = $o->{actor}->actorGroupSelector;
2159 0         0 for my $accountToken (@{$o->{accountTokens}}) {
  0         0  
2160 0         0 my $actorHash = $accountToken->actorHash;
2161              
2162             # Get the public key
2163 0         0 my ($publicKey, $invalidReason, $storeError) = $o->{actor}->keyPair->getPublicKey($actorHash, $accountToken->cliStore);
2164 0 0       0 if (defined $storeError) {
2165 0         0 $o->{ui}->pRed('Unable to get the public key of ', $actorHash->hex, ' from ', $accountToken->cliStore->url, ': ', $storeError);
2166 0         0 next;
2167             }
2168              
2169 0 0       0 if (defined $invalidReason) {
2170 0         0 $o->{ui}->pRed('Unable to get the public key of ', $actorHash->hex, ' from ', $accountToken->cliStore->url, ': ', $invalidReason);
2171 0         0 next;
2172             }
2173              
2174             # Add or update this member
2175 0         0 my $label = substr($actorHash->bytes, 0, 16);
2176 0         0 my $actorSelector = $selector->child($label);
2177 0         0 my $wasMember = $actorSelector->isSet;
2178              
2179 0         0 my $record = CDS::Record->new;
2180 0         0 $record->add('hash')->addHash($actorHash);
2181 0         0 $record->add('store')->addText($accountToken->cliStore->url);
2182 0         0 $actorSelector->set($record);
2183 0         0 $actorSelector->addObject($publicKey->hash, $publicKey->object);
2184              
2185 0 0       0 $o->{ui}->pGreen('Updated ', $o->type($actorSelector), ' member ', $actorHash->hex, '.') if $wasMember;
2186 0 0       0 $o->{ui}->pGreen('Added ', $actorHash->hex, ' as ', $o->type($actorSelector), ' member of the actor group.') if ! $wasMember;
2187             }
2188              
2189             # Save
2190 0         0 $o->{actor}->saveOrShowError;
2191             }
2192              
2193             sub setFlag {
2194 0     0   0 my $o = shift;
2195 0 0 0     0 my $actorSelector = shift; die 'wrong type '.ref($actorSelector).' for $actorSelector' if defined $actorSelector && ref $actorSelector ne 'CDS::Selector';
  0         0  
2196 0         0 my $label = shift;
2197 0         0 my $value = shift;
2198              
2199 0         0 my $child = $actorSelector->child($label);
2200 0 0       0 if ($value) {
2201 0         0 $child->setBoolean(1);
2202             } else {
2203 0         0 $child->clear;
2204             }
2205             }
2206              
2207             sub setMember {
2208 0     0   0 my $o = shift;
2209 0         0 my $cmd = shift;
2210              
2211 0         0 $o->{actorHashes} = [];
2212 0         0 $cmd->collect($o);
2213              
2214 0         0 my $selector = $o->{actor}->actorGroupSelector;
2215 0         0 for my $actorHash (@{$o->{actorHashes}}) {
  0         0  
2216 0         0 my $label = substr($actorHash->bytes, 0, 16);
2217 0         0 my $actorSelector = $selector->child($label);
2218              
2219 0         0 my $record = $actorSelector->record;
2220 0         0 my $hash = $record->child('hash')->hashValue;
2221 0 0       0 if (! $hash) {
2222 0         0 $o->{ui}->pRed($actorHash->hex, ' is not a member of our actor group.');
2223 0         0 next;
2224             }
2225              
2226 0   0     0 $o->setFlag($actorSelector, 'group data', $o->{status} eq 'active' || $o->{status} eq 'backup');
2227 0         0 $o->setFlag($actorSelector, 'active', $o->{status} eq 'active');
2228 0         0 $o->setFlag($actorSelector, 'revoked', $o->{status} eq 'revoked');
2229 0         0 $o->{ui}->pGreen($actorHash->hex, ' is now ', $o->type($actorSelector), '.');
2230             }
2231              
2232             # Save
2233 0         0 $o->{actor}->saveOrShowError;
2234             }
2235              
2236             # BEGIN AUTOGENERATED
2237             package CDS::Commands::Announce;
2238              
2239             sub register {
2240 0     0   0 my $class = shift;
2241 0         0 my $cds = shift;
2242 0         0 my $help = shift;
2243              
2244 0         0 my $node000 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
2245 0         0 my $node001 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&announceMe});
2246 0         0 my $node002 = CDS::Parser::Node->new(1);
2247 0         0 my $node003 = CDS::Parser::Node->new(0);
2248 0         0 my $node004 = CDS::Parser::Node->new(0);
2249 0         0 my $node005 = CDS::Parser::Node->new(0);
2250 0         0 my $node006 = CDS::Parser::Node->new(0);
2251 0         0 my $node007 = CDS::Parser::Node->new(0);
2252 0         0 my $node008 = CDS::Parser::Node->new(0);
2253 0         0 my $node009 = CDS::Parser::Node->new(0);
2254 0         0 my $node010 = CDS::Parser::Node->new(0);
2255 0         0 my $node011 = CDS::Parser::Node->new(0);
2256 0         0 my $node012 = CDS::Parser::Node->new(0);
2257 0         0 my $node013 = CDS::Parser::Node->new(1);
2258 0         0 my $node014 = CDS::Parser::Node->new(0);
2259 0         0 my $node015 = CDS::Parser::Node->new(0);
2260 0         0 my $node016 = CDS::Parser::Node->new(0);
2261 0         0 my $node017 = CDS::Parser::Node->new(0, {constructor => \&new, function => \&announceKeyPair});
2262 0         0 $cds->addArrow($node001, 1, 0, 'announce');
2263 0         0 $cds->addArrow($node002, 1, 0, 'announce');
2264 0         0 $help->addArrow($node000, 1, 0, 'announce');
2265 0         0 $node002->addArrow($node003, 1, 0, 'KEYPAIR', \&collectKeypair);
2266 0         0 $node003->addArrow($node004, 1, 0, 'on');
2267 0         0 $node004->addArrow($node005, 1, 0, 'STORE', \&collectStore);
2268 0         0 $node005->addArrow($node006, 1, 0, 'without');
2269 0         0 $node005->addArrow($node007, 1, 0, 'with');
2270 0         0 $node005->addDefault($node017);
2271 0         0 $node006->addArrow($node006, 1, 0, 'ACTOR', \&collectActor);
2272 0         0 $node006->addArrow($node017, 1, 0, 'ACTOR', \&collectActor);
2273 0         0 $node007->addArrow($node008, 1, 0, 'active', \&collectActive);
2274 0         0 $node007->addArrow($node008, 1, 0, 'entrusted', \&collectEntrusted);
2275 0         0 $node007->addArrow($node008, 1, 0, 'idle', \&collectIdle);
2276 0         0 $node007->addArrow($node008, 1, 0, 'revoked', \&collectRevoked);
2277 0         0 $node008->addDefault($node009);
2278 0         0 $node008->addDefault($node010);
2279 0         0 $node009->addArrow($node009, 1, 0, 'ACCOUNT', \&collectAccount);
2280 0         0 $node009->addArrow($node013, 1, 1, 'ACCOUNT', \&collectAccount);
2281 0         0 $node010->addArrow($node010, 1, 0, 'ACTOR', \&collectActor1);
2282 0         0 $node010->addArrow($node011, 1, 0, 'ACTOR', \&collectActor1);
2283 0         0 $node011->addArrow($node012, 1, 0, 'on');
2284 0         0 $node012->addArrow($node013, 1, 0, 'STORE', \&collectStore1);
2285 0         0 $node013->addArrow($node014, 1, 0, 'but');
2286 0         0 $node013->addArrow($node016, 1, 0, 'and');
2287 0         0 $node013->addDefault($node017);
2288 0         0 $node014->addArrow($node015, 1, 0, 'without');
2289 0         0 $node015->addArrow($node015, 1, 0, 'ACTOR', \&collectActor);
2290 0         0 $node015->addArrow($node017, 1, 0, 'ACTOR', \&collectActor);
2291 0         0 $node016->addDefault($node007);
2292             }
2293              
2294             sub collectAccount {
2295 0     0   0 my $o = shift;
2296 0         0 my $label = shift;
2297 0         0 my $value = shift;
2298              
2299 0         0 push @{$o->{with}}, {status => $o->{status}, accountToken => $value};
  0         0  
2300             }
2301              
2302             sub collectActive {
2303 0     0   0 my $o = shift;
2304 0         0 my $label = shift;
2305 0         0 my $value = shift;
2306              
2307 0         0 $o->{status} = 'active';
2308             }
2309              
2310             sub collectActor {
2311 0     0   0 my $o = shift;
2312 0         0 my $label = shift;
2313 0         0 my $value = shift;
2314              
2315 0         0 $o->{without}->{$value->bytes} = $value;
2316             }
2317              
2318             sub collectActor1 {
2319 0     0   0 my $o = shift;
2320 0         0 my $label = shift;
2321 0         0 my $value = shift;
2322              
2323 0         0 push @{$o->{actorHashes}}, $value;
  0         0  
2324             }
2325              
2326             sub collectEntrusted {
2327 0     0   0 my $o = shift;
2328 0         0 my $label = shift;
2329 0         0 my $value = shift;
2330              
2331 0         0 $o->{status} = 'entrusted';
2332             }
2333              
2334             sub collectIdle {
2335 0     0   0 my $o = shift;
2336 0         0 my $label = shift;
2337 0         0 my $value = shift;
2338              
2339 0         0 $o->{status} = 'idle';
2340             }
2341              
2342             sub collectKeypair {
2343 0     0   0 my $o = shift;
2344 0         0 my $label = shift;
2345 0         0 my $value = shift;
2346              
2347 0         0 $o->{keyPairToken} = $value;
2348             }
2349              
2350             sub collectRevoked {
2351 0     0   0 my $o = shift;
2352 0         0 my $label = shift;
2353 0         0 my $value = shift;
2354              
2355 0         0 $o->{status} = 'revoked';
2356             }
2357              
2358             sub collectStore {
2359 0     0   0 my $o = shift;
2360 0         0 my $label = shift;
2361 0         0 my $value = shift;
2362              
2363 0         0 $o->{store} = $value;
2364             }
2365              
2366             sub collectStore1 {
2367 0     0   0 my $o = shift;
2368 0         0 my $label = shift;
2369 0         0 my $value = shift;
2370              
2371 0         0 for my $actorHash (@{$o->{actorHashes}}) {
  0         0  
2372 0         0 my $accountToken = CDS::AccountToken->new($value, $actorHash);
2373 0         0 push @{$o->{with}}, {status => $o->{status}, accountToken => $accountToken};
  0         0  
2374             }
2375              
2376 0         0 $o->{actorHashes} = [];
2377             }
2378              
2379             sub new {
2380 0     0   0 my $class = shift;
2381 0         0 my $actor = shift;
2382 0         0 bless {actor => $actor, ui => $actor->ui} }
2383              
2384             # END AUTOGENERATED
2385              
2386             # HTML FOLDER NAME announce
2387             # HTML TITLE Announce
2388             sub help {
2389 0     0   0 my $o = shift;
2390 0         0 my $cmd = shift;
2391              
2392 0         0 my $ui = $o->{ui};
2393 0         0 $ui->space;
2394 0         0 $ui->command('cds announce');
2395 0         0 $ui->p('Announces yourself on your accounts.');
2396 0         0 $ui->space;
2397 0         0 $ui->command('cds announce KEYPAIR on STORE');
2398 0         0 $ui->command('… with (active|idle|revoked|entrusted) ACCOUNT*');
2399 0         0 $ui->command('… with (active|idle|revoked|entrusted) ACTOR* on STORE');
2400 0         0 $ui->command('… without ACTOR*');
2401 0         0 $ui->command('… with … and … and … but without …');
2402 0         0 $ui->p('Updates the public card of the indicated key pair on the indicated store. The indicated accounts are added or removed from the actor group on the card.');
2403 0         0 $ui->p('If no card exists, a minimalistic card is created.');
2404 0         0 $ui->p('Use this with care, as the generated card may not be compliant with the card produced by the actor.');
2405 0         0 $ui->space;
2406             }
2407              
2408             sub announceMe {
2409 0     0   0 my $o = shift;
2410 0         0 my $cmd = shift;
2411              
2412 0         0 $o->announceOnStore($o->{actor}->storageStore);
2413 0 0       0 $o->announceOnStore($o->{actor}->messagingStore) if $o->{actor}->messagingStore->id ne $o->{actor}->storageStore->id;
2414 0         0 $o->{ui}->space;
2415             }
2416              
2417             sub announceOnStore {
2418 0     0   0 my $o = shift;
2419 0         0 my $store = shift;
2420              
2421 0         0 $o->{ui}->space;
2422 0         0 $o->{ui}->title($store->url);
2423 0         0 my ($envelopeHash, $cardHash, $invalidReason, $storeError) = $o->{actor}->announce($store);
2424 0 0       0 return if defined $storeError;
2425 0 0       0 return $o->{ui}->pRed($invalidReason) if defined $invalidReason;
2426 0         0 $o->{ui}->pGreen('Announced');
2427             }
2428              
2429             sub announceKeyPair {
2430 0     0   0 my $o = shift;
2431 0         0 my $cmd = shift;
2432              
2433 0         0 $o->{actors} = [];
2434 0         0 $o->{with} = [];
2435 0         0 $o->{without} = {};
2436 0         0 $o->{now} = CDS->now;
2437 0         0 $cmd->collect($o);
2438              
2439             # List
2440 0         0 $o->{keyPair} = $o->{keyPairToken}->keyPair;
2441 0         0 my ($hashes, $listError) = $o->{store}->list($o->{keyPair}->publicKey->hash, 'public', 0, $o->{keyPair});
2442 0 0       0 return if defined $listError;
2443              
2444             # Check if there are more than one cards
2445 0 0       0 if (scalar @$hashes > 1) {
2446 0         0 $o->{ui}->space;
2447 0         0 $o->{ui}->p('This account contains more than one public card:');
2448 0         0 $o->{ui}->pushIndent;
2449 0         0 for my $hash (@$hashes) {
2450 0         0 $o->{ui}->line($o->{ui}->gold('cds show card ', $hash->hex, ' on ', $o->{storeUrl}));
2451             }
2452 0         0 $o->{ui}->popIndent;
2453 0         0 $o->{ui}->p('Remove all but the most recent card. Cards can be removed as follows:');
2454 0         0 my $keyPairReference = $o->{actor}->blueKeyPairReference($o->{keyPairToken});
2455 0         0 $o->{ui}->line($o->{ui}->gold('cds remove ', 'HASH', ' on ', $o->{storeUrl}, ' using ', $keyPairReference));
2456 0         0 $o->{ui}->space;
2457 0         0 return;
2458             }
2459              
2460             # Read the card
2461 0 0       0 my $cardRecord = scalar @$hashes ? $o->readCard($hashes->[0]) : CDS::Record->new;
2462 0 0       0 return if ! $cardRecord;
2463              
2464             # Parse
2465 0         0 my $builder = CDS::ActorGroupBuilder->new;
2466 0         0 $builder->parse($cardRecord, 0);
2467              
2468             # Apply the changes
2469 0         0 for my $change (@{$o->{with}}) {
  0         0  
2470 0 0       0 if ($change->{status} eq 'entrusted') {
2471 0         0 $builder->addEntrustedActor($change->{accountToken}->cliStore->url, $change->{accountToken}->actorHash);
2472 0         0 $builder->{entrustedActorsRevision} = $o->{now};
2473             } else {
2474 0         0 $builder->addMember($change->{accountToken}->cliStore->url, $change->{accountToken}->actorHash, $o->{now}, $change->{status});
2475             }
2476             }
2477              
2478 0         0 for my $hash (values %{$o->{without}}) {
  0         0  
2479 0         0 $builder->removeEntrustedActor($hash)
2480             }
2481              
2482 0         0 for my $member ($builder->members) {
2483 0 0       0 next if ! $o->{without}->{$member->hash->bytes};
2484 0         0 $builder->removeMember($member->storeUrl, $member->hash);
2485             }
2486              
2487             # Write the new card
2488 0         0 my $newCard = $builder->toRecord(0);
2489 0         0 $newCard->add('public key')->addHash($o->{keyPair}->publicKey->hash);
2490              
2491 0         0 for my $child ($cardRecord->children) {
2492 0 0       0 if ($child->bytes eq 'actor group') {
    0          
    0          
2493             } elsif ($child->bytes eq 'entrusted actors') {
2494             } elsif ($child->bytes eq 'public key') {
2495             } else {
2496 0         0 $newCard->addRecord($child);
2497             }
2498             }
2499              
2500 0         0 $o->announce($newCard, $hashes);
2501             }
2502              
2503             sub readCard {
2504 0     0   0 my $o = shift;
2505 0 0 0     0 my $envelopeHash = shift; die 'wrong type '.ref($envelopeHash).' for $envelopeHash' if defined $envelopeHash && ref $envelopeHash ne 'CDS::Hash';
  0         0  
2506              
2507             # Open the envelope
2508 0         0 my ($object, $storeError) = $o->{store}->get($envelopeHash, $o->{keyPair});
2509 0 0       0 return if defined $storeError;
2510 0 0       0 return $o->{ui}->error('Envelope object ', $envelopeHash->hex, ' not found.') if ! $object;
2511              
2512 0   0     0 my $envelope = CDS::Record->fromObject($object) // return $o->{ui}->error($envelopeHash->hex, ' is not a record.');
2513 0   0     0 my $cardHash = $envelope->child('content')->hashValue // return $o->{ui}->error($envelopeHash->hex, ' is not a valid envelope, because it has no content hash.');
2514 0 0       0 return $o->{ui}->error($envelopeHash->hex, ' has an invalid signature.') if ! CDS->verifyEnvelopeSignature($envelope, $o->{keyPair}->publicKey, $cardHash);
2515              
2516             # Read the card
2517 0         0 my ($cardObject, $storeError1) = $o->{store}->get($cardHash, $o->{keyPair});
2518 0 0       0 return if defined $storeError1;
2519 0 0       0 return $o->{ui}->error('Card object ', $cardHash->hex, ' not found.') if ! $cardObject;
2520              
2521 0   0     0 return CDS::Record->fromObject($cardObject) // return $o->{ui}->error($cardHash->hex, ' is not a record.');
2522             }
2523              
2524             sub applyChanges {
2525 0     0   0 my $o = shift;
2526 0 0 0     0 my $actorGroup = shift; die 'wrong type '.ref($actorGroup).' for $actorGroup' if defined $actorGroup && ref $actorGroup ne 'CDS::ActorGroup';
  0         0  
2527 0         0 my $status = shift;
2528 0         0 my $accounts = shift;
2529              
2530 0         0 for my $account (@$accounts) {
2531 0         0 $actorGroup->{$account->url} = {storeUrl => $account->cliStore->url, actorHash => $account->actorHash, revision => $o->{now}, status => $status};
2532             }
2533             }
2534              
2535             sub announce {
2536 0     0   0 my $o = shift;
2537 0         0 my $card = shift;
2538 0         0 my $sourceHashes = shift;
2539              
2540 0         0 my $inMemoryStore = CDS::InMemoryStore->create;
2541              
2542             # Serialize the card
2543 0         0 my $cardObject = $card->toObject;
2544 0         0 my $cardHash = $cardObject->calculateHash;
2545 0         0 $inMemoryStore->put($cardHash, $cardObject);
2546 0         0 $inMemoryStore->put($o->{keyPair}->publicKey->hash, $o->{keyPair}->publicKey->object);
2547              
2548             # Prepare the public envelope
2549 0         0 my $envelopeObject = $o->{keyPair}->createPublicEnvelope($cardHash)->toObject;
2550 0         0 my $envelopeHash = $envelopeObject->calculateHash;
2551 0         0 $inMemoryStore->put($envelopeHash, $envelopeObject);
2552              
2553             # Transfer
2554 0         0 my ($missingHash, $failedStore, $storeError) = $o->{keyPair}->transfer([$envelopeHash], $inMemoryStore, $o->{store});
2555 0 0       0 return if $storeError;
2556 0 0       0 return $o->{ui}->pRed('Object ', $missingHash, ' is missing.') if $missingHash;
2557              
2558             # Modify
2559 0         0 my $modifications = CDS::StoreModifications->new;
2560 0         0 $modifications->add($o->{keyPair}->publicKey->hash, 'public', $envelopeHash);
2561 0         0 for my $hash (@$sourceHashes) {
2562 0         0 $modifications->remove($o->{keyPair}->publicKey->hash, 'public', $hash);
2563             }
2564              
2565 0         0 my $modifyError = $o->{store}->modify($modifications, $o->{keyPair});
2566 0 0       0 return if $modifyError;
2567              
2568 0         0 $o->{ui}->pGreen('Announced on ', $o->{store}->url, '.');
2569             }
2570              
2571             # BEGIN AUTOGENERATED
2572             package CDS::Commands::Book;
2573              
2574             sub register {
2575 0     0   0 my $class = shift;
2576 0         0 my $cds = shift;
2577 0         0 my $help = shift;
2578              
2579 0         0 my $node000 = CDS::Parser::Node->new(0);
2580 0         0 my $node001 = CDS::Parser::Node->new(0);
2581 0         0 my $node002 = CDS::Parser::Node->new(0);
2582 0         0 my $node003 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
2583 0         0 my $node004 = CDS::Parser::Node->new(0);
2584 0         0 my $node005 = CDS::Parser::Node->new(0);
2585 0         0 my $node006 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&book});
2586 0         0 $cds->addArrow($node000, 1, 0, 'book');
2587 0         0 $cds->addArrow($node001, 1, 0, 'book');
2588 0         0 $cds->addArrow($node002, 1, 0, 'book');
2589 0         0 $help->addArrow($node003, 1, 0, 'book');
2590 0         0 $node000->addArrow($node000, 1, 0, 'HASH', \&collectHash);
2591 0         0 $node000->addArrow($node004, 1, 0, 'HASH', \&collectHash);
2592 0         0 $node001->addArrow($node001, 1, 0, 'OBJECT', \&collectObject);
2593 0         0 $node001->addArrow($node006, 1, 0, 'OBJECT', \&collectObject);
2594 0         0 $node002->addArrow($node002, 1, 0, 'HASH', \&collectHash);
2595 0         0 $node002->addArrow($node006, 1, 0, 'HASH', \&collectHash);
2596 0         0 $node004->addArrow($node005, 1, 0, 'on');
2597 0         0 $node005->addArrow($node005, 1, 0, 'STORE', \&collectStore);
2598 0         0 $node005->addArrow($node006, 1, 0, 'STORE', \&collectStore);
2599             }
2600              
2601             sub collectHash {
2602 0     0   0 my $o = shift;
2603 0         0 my $label = shift;
2604 0         0 my $value = shift;
2605              
2606 0         0 push @{$o->{hashes}}, $value;
  0         0  
2607             }
2608              
2609             sub collectObject {
2610 0     0   0 my $o = shift;
2611 0         0 my $label = shift;
2612 0         0 my $value = shift;
2613              
2614 0         0 push @{$o->{objectTokens}}, $value;
  0         0  
2615             }
2616              
2617             sub collectStore {
2618 0     0   0 my $o = shift;
2619 0         0 my $label = shift;
2620 0         0 my $value = shift;
2621              
2622 0         0 push @{$o->{stores}}, $value;
  0         0  
2623             }
2624              
2625             sub new {
2626 0     0   0 my $class = shift;
2627 0         0 my $actor = shift;
2628 0         0 bless {actor => $actor, ui => $actor->ui} }
2629              
2630             # END AUTOGENERATED
2631              
2632             # HTML FOLDER NAME store-book
2633             # HTML TITLE Book
2634             sub help {
2635 0     0   0 my $o = shift;
2636 0         0 my $cmd = shift;
2637              
2638 0         0 my $ui = $o->{ui};
2639 0         0 $ui->space;
2640 0         0 $ui->command('cds book OBJECT*');
2641 0         0 $ui->command('cds book HASH* on STORE*');
2642 0         0 $ui->p('Books all indicated objects and reports whether booking as successful.');
2643 0         0 $ui->space;
2644 0         0 $ui->command('cds book HASH*');
2645 0         0 $ui->p('As above, but uses the selected store.');
2646 0         0 $ui->space;
2647             }
2648              
2649             sub book {
2650 0     0   0 my $o = shift;
2651 0         0 my $cmd = shift;
2652              
2653 0         0 $o->{keyPair} = $o->{actor}->preferredKeyPairToken->keyPair;
2654 0         0 $o->{hashes} = [];
2655 0         0 $o->{stores} = [];
2656 0         0 $o->{objectTokens} = [];
2657 0         0 $cmd->collect($o);
2658              
2659             # Use the selected store
2660 0 0       0 push @{$o->{stores}}, $o->{actor}->preferredStore if ! scalar @{$o->{stores}};
  0         0  
  0         0  
2661              
2662             # Book all hashes on all stores
2663 0         0 my %triedStores;
2664 0         0 for my $store (@{$o->{stores}}) {
  0         0  
2665 0 0       0 next if $triedStores{$store->url};
2666 0         0 $triedStores{$store->url} = 1;
2667 0         0 for my $hash (@{$o->{hashes}}) {
  0         0  
2668 0         0 $o->process($store, $hash);
2669             }
2670             }
2671              
2672             # Book the direct object references
2673 0         0 for my $objectToken (@{$o->{objectTokens}}) {
  0         0  
2674 0         0 $o->process($objectToken->cliStore, $objectToken->hash);
2675             }
2676              
2677             # Warn the user if no key pair is selected
2678 0 0       0 return if ! $o->{hasErrors};
2679 0 0       0 return if $o->{keyPair};
2680 0         0 $o->{ui}->space;
2681 0         0 $o->{ui}->warning('Since no key pair is selected, the bookings were requested without signature. Stores are more likely to accept signed bookings. To add a signature, select a key pair using "cds use …", or create your key pair using "cds create my key pair".');
2682             }
2683              
2684             sub process {
2685 0     0   0 my $o = shift;
2686 0         0 my $store = shift;
2687 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
2688              
2689             # Upload the object
2690 0         0 my $success = $store->book($hash, $o->{keyPair});
2691 0 0       0 if ($success) {
2692 0         0 $o->{ui}->line($o->{ui}->green('OK '), $hash->hex, ' on ', $store->url);
2693             } else {
2694 0         0 $o->{ui}->line($o->{ui}->red('not found '), $hash->hex, ' on ', $store->url);
2695 0         0 $o->{hasErrors} = 1;
2696             }
2697             }
2698              
2699             # BEGIN AUTOGENERATED
2700             package CDS::Commands::CheckKeyPair;
2701              
2702             sub register {
2703 0     0   0 my $class = shift;
2704 0         0 my $cds = shift;
2705 0         0 my $help = shift;
2706              
2707 0         0 my $node000 = CDS::Parser::Node->new(0);
2708 0         0 my $node001 = CDS::Parser::Node->new(0);
2709 0         0 my $node002 = CDS::Parser::Node->new(0);
2710 0         0 my $node003 = CDS::Parser::Node->new(0);
2711 0         0 my $node004 = CDS::Parser::Node->new(0);
2712 0         0 my $node005 = CDS::Parser::Node->new(0);
2713 0         0 my $node006 = CDS::Parser::Node->new(0);
2714 0         0 my $node007 = CDS::Parser::Node->new(0);
2715 0         0 my $node008 = CDS::Parser::Node->new(0);
2716 0         0 my $node009 = CDS::Parser::Node->new(0);
2717 0         0 my $node010 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
2718 0         0 my $node011 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&checkKeyPair});
2719 0         0 $cds->addArrow($node004, 1, 0, 'check');
2720 0         0 $cds->addArrow($node005, 1, 0, 'fix');
2721 0         0 $help->addArrow($node000, 1, 0, 'check');
2722 0         0 $help->addArrow($node001, 1, 0, 'fix');
2723 0         0 $node000->addArrow($node002, 1, 0, 'key');
2724 0         0 $node001->addArrow($node003, 1, 0, 'key');
2725 0         0 $node002->addArrow($node010, 1, 0, 'pair');
2726 0         0 $node003->addArrow($node010, 1, 0, 'pair');
2727 0         0 $node004->addArrow($node006, 1, 0, 'key');
2728 0         0 $node005->addArrow($node007, 1, 0, 'key');
2729 0         0 $node006->addArrow($node008, 1, 0, 'pair');
2730 0         0 $node007->addArrow($node009, 1, 0, 'pair');
2731 0         0 $node008->addArrow($node011, 1, 0, 'FILE', \&collectFile);
2732 0         0 $node009->addArrow($node011, 1, 0, 'FILE', \&collectFile1);
2733             }
2734              
2735             sub collectFile {
2736 0     0   0 my $o = shift;
2737 0         0 my $label = shift;
2738 0         0 my $value = shift;
2739              
2740 0         0 $o->{file} = $value;
2741             }
2742              
2743             sub collectFile1 {
2744 0     0   0 my $o = shift;
2745 0         0 my $label = shift;
2746 0         0 my $value = shift;
2747              
2748 0         0 $o->{file} = $value;
2749 0         0 $o->{fix} = 1;
2750             }
2751              
2752             sub new {
2753 0     0   0 my $class = shift;
2754 0         0 my $actor = shift;
2755 0         0 bless {actor => $actor, ui => $actor->ui} }
2756              
2757             # END AUTOGENERATED
2758              
2759             # HTML FOLDER NAME check-key-pair
2760             # HTML TITLE Check key pair
2761             sub help {
2762 0     0   0 my $o = shift;
2763 0         0 my $cmd = shift;
2764              
2765 0         0 my $ui = $o->{ui};
2766 0         0 $ui->space;
2767 0         0 $ui->command('cds check key pair FILE');
2768 0         0 $ui->p('Checks if the key pair FILE is complete, i.e. that a valid private key and a matching public key exists.');
2769 0         0 $ui->space;
2770             }
2771              
2772             sub checkKeyPair {
2773 0     0   0 my $o = shift;
2774 0         0 my $cmd = shift;
2775              
2776 0         0 $cmd->collect($o);
2777              
2778             # Check if we have a complete private key
2779 0   0     0 my $bytes = CDS->readBytesFromFile($o->{file}) // return $o->{ui}->error('The file "', $o->{file}, '" cannot be read.');
2780 0         0 my $record = CDS::Record->fromObject(CDS::Object->fromBytes($bytes));
2781              
2782 0         0 my $rsaKey = $record->child('rsa key');
2783 0         0 my $e = $rsaKey->child('e')->bytesValue;
2784 0 0       0 return $o->{ui}->error('The exponent "e" of the private key is missing.') if ! length $e;
2785 0         0 my $p = $rsaKey->child('p')->bytesValue;
2786 0 0       0 return $o->{ui}->error('The prime "p" of the private key is missing.') if ! length $p;
2787 0         0 my $q = $rsaKey->child('q')->bytesValue;
2788 0 0       0 return $o->{ui}->error('The prime "q" of the private key is missing.') if ! length $q;
2789 0         0 $o->{ui}->pGreen('The private key is complete.');
2790              
2791             # Derive the public key
2792 0         0 my $privateKey = CDS::C::privateKeyNew($e, $p, $q);
2793 0         0 my $publicKey = CDS::C::publicKeyFromPrivateKey($privateKey);
2794 0         0 my $n = CDS::C::publicKeyN($publicKey);
2795              
2796             # Check if we have a matching public key
2797 0         0 my $publicKeyObjectBytes = $record->child('public key object')->bytesValue;
2798 0 0       0 return $o->{ui}->error('The public key is missing.') if ! length $publicKeyObjectBytes;
2799 0   0     0 $o->{publicKeyObject} = CDS::Object->fromBytes($publicKeyObjectBytes) // return $o->{ui}->error('The public key is is not a valid Condensation object.');
2800 0         0 $o->{publicKeyHash} = $o->{publicKeyObject}->calculateHash;
2801 0         0 my $publicKeyRecord = CDS::Record->fromObject($o->{publicKeyObject});
2802 0 0       0 return $o->{ui}->error('The public key is not a valid record.') if ! $publicKeyRecord;
2803 0         0 my $publicN = $publicKeyRecord->child('n')->bytesValue;
2804 0 0       0 return $o->{ui}->error('The modulus "n" of the public key is missing.') if ! length $publicN;
2805 0   0     0 my $publicE = $publicKeyRecord->child('e')->bytesValue // $o->{ui}->error('The public key is incomplete.');
2806 0 0       0 return $o->{ui}->error('The exponent "e" of the public key is missing.') if ! length $publicE;
2807 0 0       0 return $o->{ui}->error('The exponent "e" of the public key does not match the exponent "e" of the private key.') if $publicE ne $e;
2808 0 0       0 return $o->{ui}->error('The modulus "n" of the public key does not correspond to the primes "p" and "q" of the private key.') if $publicN ne $n;
2809 0         0 $o->{ui}->pGreen('The public key ', $o->{publicKeyHash}->hex, ' is complete.');
2810              
2811             # At this point, the configuration looks good, and we can load the key pair
2812 0   0     0 CDS::KeyPair->fromRecord($record) // $o->{ui}->error('Your key pair looks complete, but could not be loaded.');
2813             }
2814              
2815             # BEGIN AUTOGENERATED
2816             package CDS::Commands::CollectGarbage;
2817              
2818             sub register {
2819 0     0   0 my $class = shift;
2820 0         0 my $cds = shift;
2821 0         0 my $help = shift;
2822              
2823 0         0 my $node000 = CDS::Parser::Node->new(0);
2824 0         0 my $node001 = CDS::Parser::Node->new(0);
2825 0         0 my $node002 = CDS::Parser::Node->new(0);
2826 0         0 my $node003 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
2827 0         0 my $node004 = CDS::Parser::Node->new(0, {constructor => \&new, function => \&collectGarbage});
2828 0         0 my $node005 = CDS::Parser::Node->new(0);
2829 0         0 my $node006 = CDS::Parser::Node->new(0, {constructor => \&new, function => \&reportGarbage});
2830 0         0 my $node007 = CDS::Parser::Node->new(0);
2831 0         0 my $node008 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&collectGarbage});
2832 0         0 my $node009 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&reportGarbage});
2833 0         0 $cds->addArrow($node001, 1, 0, 'report');
2834 0         0 $cds->addArrow($node002, 1, 0, 'collect');
2835 0         0 $help->addArrow($node000, 1, 0, 'collect');
2836 0         0 $node000->addArrow($node003, 1, 0, 'garbage');
2837 0         0 $node001->addArrow($node006, 1, 0, 'garbage');
2838 0         0 $node002->addArrow($node004, 1, 0, 'garbage');
2839 0         0 $node004->addArrow($node005, 1, 0, 'of');
2840 0         0 $node004->addDefault($node008);
2841 0         0 $node005->addArrow($node008, 1, 0, 'STORE', \&collectStore);
2842 0         0 $node006->addArrow($node007, 1, 0, 'of');
2843 0         0 $node006->addDefault($node009);
2844 0         0 $node007->addArrow($node009, 1, 0, 'STORE', \&collectStore);
2845             }
2846              
2847             sub collectStore {
2848 0     0   0 my $o = shift;
2849 0         0 my $label = shift;
2850 0         0 my $value = shift;
2851              
2852 0         0 $o->{store} = $value;
2853             }
2854              
2855             sub new {
2856 0     0   0 my $class = shift;
2857 0         0 my $actor = shift;
2858 0         0 bless {actor => $actor, ui => $actor->ui} }
2859              
2860             # END AUTOGENERATED
2861              
2862             # HTML FOLDER NAME collect-garbage
2863             # HTML TITLE Garbage collection
2864             sub help {
2865 0     0   0 my $o = shift;
2866 0         0 my $cmd = shift;
2867              
2868 0         0 my $ui = $o->{ui};
2869 0         0 $ui->space;
2870 0         0 $ui->command('cds collect garbage [of STORE]');
2871 0         0 $ui->p('Runs garbage collection. STORE must be a folder store. Objects not in use, and older than 1 day are removed from the store.');
2872 0         0 $ui->p('If no store is provided, garbage collection is run on the selected store, or the actor\'s storage store.');
2873 0         0 $ui->space;
2874 0         0 $ui->p('The store must not be written to while garbage collection is running. Objects booked during garbage collection may get deleted, and leave the store in a corrupt state. Reading from the store is fine.');
2875 0         0 $ui->space;
2876 0         0 $ui->command('cds report garbage [of STORE]');
2877 0         0 $ui->p('As above, but reports obsolete objects rather than deleting them. A protocol (shell script) is written to ".garbage" in the store folder.');
2878 0         0 $ui->space;
2879             }
2880              
2881             sub collectGarbage {
2882 0     0   0 my $o = shift;
2883 0         0 my $cmd = shift;
2884              
2885 0         0 $cmd->collect($o);
2886 0         0 $o->run(CDS::Commands::CollectGarbage::Delete->new($o->{ui}));
2887             }
2888              
2889             sub wrapUpDeletion {
2890 0     0   0 my $o = shift;
2891             }
2892              
2893             sub reportGarbage {
2894 0     0   0 my $o = shift;
2895 0         0 my $cmd = shift;
2896              
2897 0         0 $cmd->collect($o);
2898 0         0 $o->run(CDS::Commands::CollectGarbage::Report->new($o->{ui}));
2899 0         0 $o->{ui}->space;
2900             }
2901              
2902             # Creates a folder with the selected permissions.
2903             sub run {
2904 0     0   0 my $o = shift;
2905 0         0 my $handler = shift;
2906              
2907             # Prepare
2908 0   0     0 my $store = $o->{store} // $o->{actor}->selectedStore // $o->{actor}->storageStore;
      0        
2909 0   0     0 my $folderStore = CDS::FolderStore->forUrl($store->url) // return $o->{ui}->error('"', $store->url, '" is not a folder store.');
2910 0   0     0 $handler->initialize($folderStore) // return;
2911              
2912 0         0 $o->{storeFolder} = $folderStore->folder;
2913 0         0 $o->{accountsFolder} = $folderStore->folder.'/accounts';
2914 0         0 $o->{objectsFolder} = $folderStore->folder.'/objects';
2915 0         0 my $dateLimit = time - 86400;
2916 0         0 my $envelopeExpirationLimit = time * 1000;
2917              
2918             # Read the tree index
2919 0         0 $o->readIndex;
2920              
2921             # Process all accounts
2922 0         0 $o->{ui}->space;
2923 0         0 $o->{ui}->title($o->{ui}->left(64, 'Accounts'), ' ', $o->{ui}->right(10, 'messages'), ' ', $o->{ui}->right(10, 'private'), ' ', $o->{ui}->right(10, 'public'), ' ', 'last modification');
2924 0         0 $o->startProgress('accounts');
2925 0         0 $o->{usedHashes} = {};
2926 0         0 $o->{missingObjects} = {};
2927 0         0 $o->{brokenOrigins} = {};
2928 0         0 my $countAccounts = 0;
2929 0         0 my $countKeptEnvelopes = 0;
2930 0         0 my $countDeletedEnvelopes = 0;
2931 0         0 for my $accountHash (sort { $$a cmp $$b } $folderStore->accounts) {
  0         0  
2932             # This would be the private key, but we don't use it right now
2933 0         0 $o->{usedHashes}->{$accountHash->hex} = 1;
2934              
2935 0         0 my $newestDate = 0;
2936 0         0 my %sizeByBox;
2937 0         0 my $accountFolder = $o->{accountsFolder}.'/'.$accountHash->hex;
2938 0         0 foreach my $boxLabel (CDS->listFolder($accountFolder)) {
2939 0 0       0 next if $boxLabel =~ /^\./;
2940 0         0 my $boxFolder = $accountFolder.'/'.$boxLabel;
2941 0         0 my $date = &lastModified($boxFolder);
2942 0 0       0 $newestDate = $date if $newestDate < $date;
2943 0         0 my $size = 0;
2944 0         0 foreach my $filename (CDS->listFolder($boxFolder)) {
2945 0 0       0 next if $filename =~ /^\./;
2946 0         0 my $hash = pack('H*', $filename);
2947 0         0 my $file = $boxFolder.'/'.$filename;
2948              
2949 0         0 my $timestamp = $o->envelopeExpiration($hash, $boxFolder);
2950 0 0 0     0 if ($timestamp > 0 && $timestamp < $envelopeExpirationLimit) {
2951 0         0 $countDeletedEnvelopes += 1;
2952 0   0     0 $handler->deleteEnvelope($file) // return;
2953 0         0 next;
2954             }
2955              
2956 0         0 $countKeptEnvelopes += 1;
2957 0         0 my $date = &lastModified($file);
2958 0 0       0 $newestDate = $date if $newestDate < $date;
2959 0         0 $size += $o->traverse($hash, $boxFolder);
2960             }
2961 0         0 $sizeByBox{$boxLabel} = $size;
2962             }
2963              
2964             $o->{ui}->line($accountHash->hex, ' ',
2965             $o->{ui}->right(10, $o->{ui}->niceFileSize($sizeByBox{'messages'} || 0)), ' ',
2966             $o->{ui}->right(10, $o->{ui}->niceFileSize($sizeByBox{'private'} || 0)), ' ',
2967             $o->{ui}->right(10, $o->{ui}->niceFileSize($sizeByBox{'public'} || 0)), ' ',
2968 0 0 0     0 $newestDate == 0 ? 'never' : $o->{ui}->niceDateTime($newestDate * 1000));
      0        
      0        
2969              
2970 0         0 $countAccounts += 1;
2971             }
2972              
2973 0         0 $o->{ui}->line($countAccounts, ' accounts traversed');
2974 0         0 $o->{ui}->space;
2975              
2976             # Mark all objects that are younger than 1 day (so that objects being uploaded right now but not linked yet remain)
2977 0         0 $o->{ui}->title('Objects');
2978 0         0 $o->startProgress('objects');
2979              
2980 0         0 my %objects;
2981 0         0 my @topFolders = sort grep {$_ !~ /^\./} CDS->listFolder($o->{objectsFolder});
  0         0  
2982 0         0 foreach my $topFolder (@topFolders) {
2983 0         0 my @files = sort grep {$_ !~ /^\./} CDS->listFolder($o->{objectsFolder}.'/'.$topFolder);
  0         0  
2984 0         0 foreach my $filename (@files) {
2985 0         0 $o->incrementProgress;
2986 0         0 my $hash = pack 'H*', $topFolder.$filename;
2987 0         0 my @s = stat $o->{objectsFolder}.'/'.$topFolder.'/'.$filename;
2988 0         0 $objects{$hash} = $s[7];
2989 0 0       0 next if $s[9] < $dateLimit;
2990 0         0 $o->traverse($hash, 'recent object');
2991             }
2992             }
2993              
2994 0         0 $o->{ui}->line(scalar keys %objects, ' objects traversed');
2995 0         0 $o->{ui}->space;
2996              
2997             # Delete all unmarked objects, and add the marked objects to the new tree index
2998 0         0 my $index = CDS::Record->new;
2999 0         0 my $countKeptObjects = 0;
3000 0         0 my $sizeKeptObjects = 0;
3001 0         0 my $countDeletedObjects = 0;
3002 0         0 my $sizeDeletedObjects = 0;
3003              
3004 0         0 $handler->startDeletion;
3005 0         0 $o->startProgress('delete-objects');
3006 0         0 for my $hash (keys %objects) {
3007 0         0 my $size = $objects{$hash};
3008 0 0       0 if (exists $o->{usedHashes}->{$hash}) {
3009 0         0 $countKeptObjects += 1;
3010 0         0 $sizeKeptObjects += $size;
3011 0         0 my $entry = $o->{index}->{$hash};
3012 0 0       0 $index->addRecord($entry) if $entry;
3013             } else {
3014 0         0 $o->incrementProgress;
3015 0         0 $countDeletedObjects += 1;
3016 0         0 $sizeDeletedObjects += $size;
3017 0         0 my $hashHex = unpack 'H*', $hash;
3018 0         0 my $file = $o->{objectsFolder}.'/'.substr($hashHex, 0, 2).'/'.substr($hashHex, 2);
3019 0   0     0 $handler->deleteObject($file) // return;
3020             }
3021             }
3022              
3023             # Write the new tree index
3024 0         0 CDS->writeBytesToFile($o->{storeFolder}.'/.index-new', $index->toObject->bytes);
3025 0         0 rename $o->{storeFolder}.'/.index-new', $o->{storeFolder}.'/.index';
3026              
3027             # Show what has been done
3028 0         0 $o->{ui}->space;
3029 0         0 $o->{ui}->line($countDeletedEnvelopes, ' ', $handler->{deletedEnvelopesText});
3030 0         0 $o->{ui}->line($countKeptEnvelopes, ' ', $handler->{keptEnvelopesText});
3031 0         0 my $line1 = $countDeletedObjects.' '.$handler->{deletedObjectsText};
3032 0         0 my $line2 = $countKeptObjects.' '.$handler->{keptObjectsText};
3033 0         0 my $maxLength = CDS->max(length $line1, length $line2);
3034 0         0 $o->{ui}->line($o->{ui}->left($maxLength, $line1), ' ', $o->{ui}->gray($o->{ui}->niceFileSize($sizeDeletedObjects)));
3035 0         0 $o->{ui}->line($o->{ui}->left($maxLength, $line2), ' ', $o->{ui}->gray($o->{ui}->niceFileSize($sizeKeptObjects)));
3036 0         0 $o->{ui}->space;
3037 0         0 $handler->wrapUp;
3038              
3039 0         0 my $missing = scalar keys %{$o->{missingObjects}};
  0         0  
3040 0 0       0 if ($missing) {
3041 0         0 $o->{ui}->warning($missing, ' objects are referenced from other objects, but missing:');
3042              
3043 0         0 my $count = 0;
3044 0         0 for my $hashBytes (sort keys %{$o->{missingObjects}}) {
  0         0  
3045 0         0 $o->{ui}->warning(' ', unpack('H*', $hashBytes));
3046              
3047 0         0 $count += 1;
3048 0 0 0     0 if ($missing > 10 && $count > 5) {
3049 0         0 $o->{ui}->warning(' …');
3050 0         0 last;
3051             }
3052             }
3053              
3054 0         0 $o->{ui}->space;
3055 0         0 $o->{ui}->warning('The missing objects are from the following origins:');
3056 0         0 for my $origin (sort keys %{$o->{brokenOrigins}}) {
  0         0  
3057 0         0 $o->{ui}->line(' ', $o->{ui}->orange($origin));
3058             }
3059              
3060 0         0 $o->{ui}->space;
3061             }
3062             }
3063              
3064             sub traverse {
3065 0     0   0 my $o = shift;
3066 0         0 my $hashBytes = shift;
3067 0         0 my $origin = shift;
3068              
3069 0 0       0 return $o->{usedHashes}->{$hashBytes} if exists $o->{usedHashes}->{$hashBytes};
3070              
3071             # Get index information about the object
3072 0   0     0 my $record = $o->index($hashBytes, $origin) // return 0;
3073 0         0 my $size = $record->nthChild(0)->asInteger;
3074              
3075             # Process children
3076 0         0 my $pos = 0;
3077 0         0 my $hashes = $record->nthChild(1)->bytes;
3078 0         0 while ($pos < length $hashes) {
3079 0         0 $size += $o->traverse(substr($hashes, $pos, 32), $origin);
3080 0         0 $pos += 32;
3081             }
3082              
3083             # Keep the size for future use
3084 0         0 $o->{usedHashes}->{$hashBytes} = $size;
3085 0         0 return $size;
3086             }
3087              
3088             sub readIndex {
3089 0     0   0 my $o = shift;
3090              
3091 0         0 $o->{index} = {};
3092 0         0 my $file = $o->{storeFolder}.'/.index';
3093 0   0     0 my $record = CDS::Record->fromObject(CDS::Object->fromBytes(CDS->readBytesFromFile($file))) // return;
3094 0         0 for my $child ($record->children) {
3095 0         0 $o->{index}->{$child->bytes} = $child;
3096             }
3097             }
3098              
3099             sub index {
3100 0     0   0 my $o = shift;
3101 0         0 my $hashBytes = shift;
3102 0         0 my $origin = shift;
3103              
3104 0         0 $o->incrementProgress;
3105              
3106             # Report a known result
3107 0 0       0 if ($o->{missingObjects}->{$hashBytes}) {
3108 0         0 $o->{brokenOrigins}->{$origin} = 1;
3109 0         0 return;
3110             }
3111              
3112 0 0       0 return $o->{index}->{$hashBytes} if exists $o->{index}->{$hashBytes};
3113              
3114             # Object file
3115 0         0 my $hashHex = unpack 'H*', $hashBytes;
3116 0         0 my $file = $o->{objectsFolder}.'/'.substr($hashHex, 0, 2).'/'.substr($hashHex, 2);
3117              
3118             # Size and existence
3119 0         0 my @s = stat $file;
3120 0 0       0 if (! scalar @s) {
3121 0         0 $o->{missingObjects}->{$hashBytes} = 1;
3122 0         0 $o->{brokenOrigins}->{$origin} = 1;
3123 0         0 return;
3124             }
3125 0         0 my $size = $s[7];
3126 0 0       0 return $o->{ui}->error('Unexpected: object ', $hashHex, ' has ', $size, ' bytes') if $size < 4;
3127              
3128             # Read header
3129 0         0 open O, '<', $file;
3130 0         0 read O, my $buffer, 4;
3131 0         0 my $links = unpack 'L>', $buffer;
3132 0 0       0 return $o->{ui}->error('Unexpected: object ', $hashHex, ' has ', $links, ' references') if $links > 160000;
3133 0 0       0 return $o->{ui}->error('Unexpected: object ', $hashHex, ' is too small for ', $links, ' references') if 4 + $links * 32 > $s[7];
3134 0         0 my $hashes = '';
3135 0 0       0 read O, $hashes, $links * 32 if $links > 0;
3136 0         0 close O;
3137              
3138 0 0       0 return $o->{ui}->error('Incomplete read: ', length $hashes, ' out of ', $links * 32, ' bytes received.') if length $hashes != $links * 32;
3139              
3140 0         0 my $record = CDS::Record->new($hashBytes);
3141 0         0 $record->addInteger($size);
3142 0         0 $record->add($hashes);
3143 0         0 return $o->{index}->{$hashBytes} = $record;
3144             }
3145              
3146             sub envelopeExpiration {
3147 0     0   0 my $o = shift;
3148 0         0 my $hashBytes = shift;
3149 0         0 my $origin = shift;
3150              
3151 0   0     0 my $entry = $o->index($hashBytes, $origin) // return 0;
3152 0 0       0 return $entry->nthChild(2)->asInteger if scalar $entry->children > 2;
3153              
3154             # Object file
3155 0         0 my $hashHex = unpack 'H*', $hashBytes;
3156 0         0 my $file = $o->{objectsFolder}.'/'.substr($hashHex, 0, 2).'/'.substr($hashHex, 2);
3157 0         0 my $record = CDS::Record->fromObject(CDS::Object->fromBytes(CDS->readBytesFromFile($file)));
3158 0         0 my $expires = $record->child('expires')->integerValue;
3159 0         0 $entry->addInteger($expires);
3160 0         0 return $expires;
3161             }
3162              
3163             sub startProgress {
3164 0     0   0 my $o = shift;
3165 0         0 my $title = shift;
3166              
3167 0         0 $o->{progress} = 0;
3168 0         0 $o->{progressTitle} = $title;
3169 0         0 $o->{ui}->progress($o->{progress}, ' ', $o->{progressTitle});
3170             }
3171              
3172             sub incrementProgress {
3173 0     0   0 my $o = shift;
3174              
3175 0         0 $o->{progress} += 1;
3176 0 0       0 return if $o->{progress} % 100;
3177 0         0 $o->{ui}->progress($o->{progress}, ' ', $o->{progressTitle});
3178             }
3179              
3180             sub lastModified {
3181 0     0   0 my $file = shift;
3182              
3183 0         0 my @s = stat $file;
3184 0 0       0 return scalar @s ? $s[9] : 0;
3185             }
3186              
3187             package CDS::Commands::CollectGarbage::Delete;
3188              
3189             sub new {
3190 0     0   0 my $class = shift;
3191 0         0 my $ui = shift;
3192              
3193 0         0 return bless {
3194             ui => $ui,
3195             deletedEnvelopesText => 'expired envelopes deleted',
3196             keptEnvelopesText => 'envelopes kept',
3197             deletedObjectsText => 'objects deleted',
3198             keptObjectsText => 'objects kept',
3199             };
3200             }
3201              
3202             sub initialize {
3203 0     0   0 my $o = shift;
3204 0         0 my $folder = shift;
3205 0         0 1 }
3206              
3207             sub startDeletion {
3208 0     0   0 my $o = shift;
3209              
3210 0         0 $o->{ui}->title('Deleting obsolete objects');
3211             }
3212              
3213             sub deleteEnvelope {
3214 0     0   0 my $o = shift;
3215 0         0 my $file = shift;
3216 0         0 $o->deleteObject($file) }
3217              
3218             sub deleteObject {
3219 0     0   0 my $o = shift;
3220 0         0 my $file = shift;
3221              
3222 0   0     0 unlink $file // return $o->{ui}->error('Unable to delete "', $file, '". Giving up …');
3223 0         0 return 1;
3224             }
3225              
3226             sub wrapUp {
3227 0     0   0 my $o = shift;
3228             }
3229              
3230             package CDS::Commands::CollectGarbage::Report;
3231              
3232             sub new {
3233 0     0   0 my $class = shift;
3234 0         0 my $ui = shift;
3235              
3236 0         0 return bless {
3237             ui => $ui,
3238             countReported => 0,
3239             deletedEnvelopesText => 'envelopes have expired',
3240             keptEnvelopesText => 'envelopes are in use',
3241             deletedObjectsText => 'objects can be deleted',
3242             keptObjectsText => 'objects are in use',
3243             };
3244             }
3245              
3246             sub initialize {
3247 0     0   0 my $o = shift;
3248 0         0 my $folderStore = shift;
3249              
3250 0         0 $o->{file} = $folderStore->folder.'/.garbage';
3251 0 0       0 open($o->{fh}, '>', $o->{file}) || return $o->{ui}->error('Failed to open ', $o->{file}, ' for writing.');
3252 0         0 return 1;
3253             }
3254              
3255             sub startDeletion {
3256 0     0   0 my $o = shift;
3257              
3258 0         0 $o->{ui}->title('Deleting obsolete objects');
3259             }
3260              
3261             sub deleteEnvelope {
3262 0     0   0 my $o = shift;
3263 0         0 my $file = shift;
3264 0         0 $o->deleteObject($file) }
3265              
3266             sub deleteObject {
3267 0     0   0 my $o = shift;
3268 0         0 my $file = shift;
3269              
3270 0         0 my $fh = $o->{fh};
3271 0         0 print $fh 'rm ', $file, "\n";
3272 0         0 $o->{countReported} += 1;
3273 0 0       0 print $fh 'echo ', $o->{countReported}, ' files deleted', "\n" if $o->{countReported} % 100 == 0;
3274 0         0 return 1;
3275             }
3276              
3277             sub wrapUp {
3278 0     0   0 my $o = shift;
3279              
3280 0         0 close $o->{fh};
3281 0 0       0 if ($o->{countReported} == 0) {
3282 0         0 unlink $o->{file};
3283             } else {
3284 0         0 $o->{ui}->space;
3285 0         0 $o->{ui}->p('The report was written to ', $o->{file}, '.');
3286 0         0 $o->{ui}->space;
3287             }
3288             }
3289              
3290             # BEGIN AUTOGENERATED
3291             package CDS::Commands::CreateKeyPair;
3292              
3293             sub register {
3294 0     0   0 my $class = shift;
3295 0         0 my $cds = shift;
3296 0         0 my $help = shift;
3297              
3298 0         0 my $node000 = CDS::Parser::Node->new(0);
3299 0         0 my $node001 = CDS::Parser::Node->new(0);
3300 0         0 my $node002 = CDS::Parser::Node->new(0);
3301 0         0 my $node003 = CDS::Parser::Node->new(0);
3302 0         0 my $node004 = CDS::Parser::Node->new(0);
3303 0         0 my $node005 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
3304 0         0 my $node006 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&createKeyPair});
3305 0         0 $cds->addArrow($node002, 1, 0, 'create');
3306 0         0 $help->addArrow($node000, 1, 0, 'create');
3307 0         0 $node000->addArrow($node001, 1, 0, 'key');
3308 0         0 $node001->addArrow($node005, 1, 0, 'pair');
3309 0         0 $node002->addArrow($node003, 1, 0, 'key');
3310 0         0 $node003->addArrow($node004, 1, 0, 'pair');
3311 0         0 $node004->addArrow($node006, 1, 0, 'FILENAME', \&collectFilename);
3312             }
3313              
3314             sub collectFilename {
3315 0     0   0 my $o = shift;
3316 0         0 my $label = shift;
3317 0         0 my $value = shift;
3318              
3319 0         0 $o->{filename} = $value;
3320             }
3321              
3322             sub new {
3323 0     0   0 my $class = shift;
3324 0         0 my $actor = shift;
3325 0         0 bless {actor => $actor, ui => $actor->ui} }
3326              
3327             # END AUTOGENERATED
3328              
3329             # HTML FOLDER NAME create-key-pair
3330             # HTML TITLE Create key pair
3331             sub help {
3332 0     0   0 my $o = shift;
3333 0         0 my $cmd = shift;
3334              
3335 0         0 my $ui = $o->{ui};
3336 0         0 $ui->space;
3337 0         0 $ui->command('cds create key pair FILENAME');
3338 0         0 $ui->p('Generates a key pair, and writes it to FILENAME.');
3339 0         0 $ui->space;
3340 0         0 $ui->title('Related commands');
3341 0         0 $ui->line(' cds select …');
3342 0         0 $ui->line(' cds use …');
3343 0         0 $ui->line(' cds entrust …');
3344 0         0 $ui->line(' cds drop …');
3345 0         0 $ui->space;
3346             }
3347              
3348             sub createKeyPair {
3349 0     0   0 my $o = shift;
3350 0         0 my $cmd = shift;
3351              
3352 0         0 $cmd->collect($o);
3353 0 0       0 return $o->{ui}->error('The file "', $o->{filename}, '" exists.') if -e $o->{filename};
3354 0         0 my $keyPair = CDS::KeyPair->generate;
3355 0   0     0 $keyPair->writeToFile($o->{filename}) // return $o->{ui}->error('Failed to write the key pair file "', $o->{filename}, '".');
3356 0         0 $o->{ui}->pGreen('Key pair "', $o->{filename}, '" created.');
3357             }
3358              
3359             # BEGIN AUTOGENERATED
3360             package CDS::Commands::Curl;
3361              
3362             sub register {
3363 0     0   0 my $class = shift;
3364 0         0 my $cds = shift;
3365 0         0 my $help = shift;
3366              
3367 0         0 my $node000 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
3368 0         0 my $node001 = CDS::Parser::Node->new(1);
3369 0         0 my $node002 = CDS::Parser::Node->new(0);
3370 0         0 my $node003 = CDS::Parser::Node->new(0);
3371 0         0 my $node004 = CDS::Parser::Node->new(0);
3372 0         0 my $node005 = CDS::Parser::Node->new(0);
3373 0         0 my $node006 = CDS::Parser::Node->new(0);
3374 0         0 my $node007 = CDS::Parser::Node->new(0);
3375 0         0 my $node008 = CDS::Parser::Node->new(0);
3376 0         0 my $node009 = CDS::Parser::Node->new(0);
3377 0         0 my $node010 = CDS::Parser::Node->new(0);
3378 0         0 my $node011 = CDS::Parser::Node->new(0);
3379 0         0 my $node012 = CDS::Parser::Node->new(0);
3380 0         0 my $node013 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlGet});
3381 0         0 my $node014 = CDS::Parser::Node->new(0);
3382 0         0 my $node015 = CDS::Parser::Node->new(0);
3383 0         0 my $node016 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlPut});
3384 0         0 my $node017 = CDS::Parser::Node->new(0);
3385 0         0 my $node018 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlBook});
3386 0         0 my $node019 = CDS::Parser::Node->new(0);
3387 0         0 my $node020 = CDS::Parser::Node->new(0);
3388 0         0 my $node021 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlList});
3389 0         0 my $node022 = CDS::Parser::Node->new(0);
3390 0         0 my $node023 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlGet});
3391 0         0 my $node024 = CDS::Parser::Node->new(0);
3392 0         0 my $node025 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlPut});
3393 0         0 my $node026 = CDS::Parser::Node->new(0);
3394 0         0 my $node027 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlBook});
3395 0         0 my $node028 = CDS::Parser::Node->new(0);
3396 0         0 my $node029 = CDS::Parser::Node->new(1);
3397 0         0 my $node030 = CDS::Parser::Node->new(0);
3398 0         0 my $node031 = CDS::Parser::Node->new(0);
3399 0         0 my $node032 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlList});
3400 0         0 my $node033 = CDS::Parser::Node->new(0);
3401 0         0 my $node034 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlGet});
3402 0         0 my $node035 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlPut});
3403 0         0 my $node036 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlBook});
3404 0         0 my $node037 = CDS::Parser::Node->new(1);
3405 0         0 my $node038 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlList});
3406 0         0 my $node039 = CDS::Parser::Node->new(0);
3407 0         0 my $node040 = CDS::Parser::Node->new(0);
3408 0         0 my $node041 = CDS::Parser::Node->new(0);
3409 0         0 my $node042 = CDS::Parser::Node->new(0);
3410 0         0 my $node043 = CDS::Parser::Node->new(0);
3411 0         0 my $node044 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlList});
3412 0         0 my $node045 = CDS::Parser::Node->new(1);
3413 0         0 my $node046 = CDS::Parser::Node->new(0);
3414 0         0 my $node047 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlModify});
3415 0         0 my $node048 = CDS::Parser::Node->new(0);
3416 0         0 my $node049 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlModify});
3417 0         0 my $node050 = CDS::Parser::Node->new(0);
3418 0         0 my $node051 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlModify});
3419 0         0 $cds->addArrow($node001, 1, 0, 'curl');
3420 0         0 $help->addArrow($node000, 1, 0, 'curl');
3421 0         0 $node001->addArrow($node002, 1, 0, 'get');
3422 0         0 $node001->addArrow($node003, 1, 0, 'put');
3423 0         0 $node001->addArrow($node004, 1, 0, 'book');
3424 0         0 $node001->addArrow($node005, 1, 0, 'get');
3425 0         0 $node001->addArrow($node006, 1, 0, 'book');
3426 0         0 $node001->addArrow($node007, 1, 0, 'list');
3427 0         0 $node001->addArrow($node007, 1, 0, 'watch', \&collectWatch);
3428 0         0 $node001->addDefault($node011);
3429 0         0 $node002->addArrow($node013, 1, 0, 'HASH', \&collectHash);
3430 0         0 $node003->addArrow($node016, 1, 0, 'FILE', \&collectFile);
3431 0         0 $node004->addArrow($node018, 1, 0, 'HASH', \&collectHash);
3432 0         0 $node005->addArrow($node023, 1, 0, 'OBJECT', \&collectObject);
3433 0         0 $node006->addArrow($node027, 1, 0, 'OBJECT', \&collectObject);
3434 0         0 $node007->addArrow($node008, 1, 0, 'message');
3435 0         0 $node007->addArrow($node009, 1, 0, 'private');
3436 0         0 $node007->addArrow($node010, 1, 0, 'public');
3437 0         0 $node007->addArrow($node021, 0, 0, 'messages', \&collectMessages);
3438 0         0 $node007->addArrow($node021, 0, 0, 'private', \&collectPrivate);
3439 0         0 $node007->addArrow($node021, 0, 0, 'public', \&collectPublic);
3440 0         0 $node008->addArrow($node021, 1, 0, 'box', \&collectMessages);
3441 0         0 $node009->addArrow($node021, 1, 0, 'box', \&collectPrivate);
3442 0         0 $node010->addArrow($node021, 1, 0, 'box', \&collectPublic);
3443 0         0 $node011->addArrow($node012, 1, 0, 'remove');
3444 0         0 $node011->addArrow($node020, 1, 0, 'add');
3445 0         0 $node012->addArrow($node012, 1, 0, 'HASH', \&collectHash1);
3446 0         0 $node012->addArrow($node037, 1, 0, 'HASH', \&collectHash1);
3447 0         0 $node013->addArrow($node014, 1, 0, 'from');
3448 0         0 $node013->addArrow($node015, 0, 0, 'on');
3449 0         0 $node013->addDefault($node023);
3450 0         0 $node014->addArrow($node023, 1, 0, 'STORE', \&collectStore);
3451 0         0 $node015->addArrow($node023, 0, 0, 'STORE', \&collectStore);
3452 0         0 $node016->addArrow($node017, 1, 0, 'onto');
3453 0         0 $node016->addDefault($node025);
3454 0         0 $node017->addArrow($node025, 1, 0, 'STORE', \&collectStore);
3455 0         0 $node018->addArrow($node019, 1, 0, 'on');
3456 0         0 $node018->addDefault($node027);
3457 0         0 $node019->addArrow($node027, 1, 0, 'STORE', \&collectStore);
3458 0         0 $node020->addArrow($node029, 1, 0, 'FILE', \&collectFile1);
3459 0         0 $node020->addArrow($node029, 1, 0, 'HASH', \&collectHash2);
3460 0         0 $node021->addArrow($node022, 1, 0, 'of');
3461 0         0 $node022->addArrow($node032, 1, 0, 'ACTOR', \&collectActor);
3462 0         0 $node023->addArrow($node024, 1, 0, 'using');
3463 0         0 $node024->addArrow($node034, 1, 0, 'KEYPAIR', \&collectKeypair);
3464 0         0 $node025->addArrow($node026, 1, 0, 'using');
3465 0         0 $node026->addArrow($node035, 1, 0, 'KEYPAIR', \&collectKeypair);
3466 0         0 $node027->addArrow($node028, 1, 0, 'using');
3467 0         0 $node028->addArrow($node036, 1, 0, 'KEYPAIR', \&collectKeypair);
3468 0         0 $node029->addDefault($node020);
3469 0         0 $node029->addArrow($node030, 1, 0, 'and');
3470 0         0 $node029->addArrow($node040, 1, 0, 'to');
3471 0         0 $node030->addArrow($node031, 1, 0, 'remove');
3472 0         0 $node031->addArrow($node031, 1, 0, 'HASH', \&collectHash1);
3473 0         0 $node031->addArrow($node037, 1, 0, 'HASH', \&collectHash1);
3474 0         0 $node032->addArrow($node033, 1, 0, 'on');
3475 0         0 $node033->addArrow($node038, 1, 0, 'STORE', \&collectStore);
3476 0         0 $node037->addArrow($node040, 1, 0, 'from');
3477 0         0 $node038->addArrow($node039, 1, 0, 'using');
3478 0         0 $node039->addArrow($node044, 1, 0, 'KEYPAIR', \&collectKeypair);
3479 0         0 $node040->addArrow($node041, 1, 0, 'message');
3480 0         0 $node040->addArrow($node042, 1, 0, 'private');
3481 0         0 $node040->addArrow($node043, 1, 0, 'public');
3482 0         0 $node040->addArrow($node045, 0, 0, 'messages', \&collectMessages1);
3483 0         0 $node040->addArrow($node045, 0, 0, 'private', \&collectPrivate1);
3484 0         0 $node040->addArrow($node045, 0, 0, 'public', \&collectPublic1);
3485 0         0 $node041->addArrow($node045, 1, 0, 'box', \&collectMessages1);
3486 0         0 $node042->addArrow($node045, 1, 0, 'box', \&collectPrivate1);
3487 0         0 $node043->addArrow($node045, 1, 0, 'box', \&collectPublic1);
3488 0         0 $node045->addArrow($node046, 1, 0, 'of');
3489 0         0 $node045->addDefault($node047);
3490 0         0 $node046->addArrow($node047, 1, 0, 'ACTOR', \&collectActor1);
3491 0         0 $node047->addArrow($node011, 1, 0, 'and', \&collectAnd);
3492 0         0 $node047->addArrow($node048, 1, 0, 'on');
3493 0         0 $node048->addArrow($node049, 1, 0, 'STORE', \&collectStore);
3494 0         0 $node049->addArrow($node050, 1, 0, 'using');
3495 0         0 $node050->addArrow($node051, 1, 0, 'KEYPAIR', \&collectKeypair);
3496             }
3497              
3498             sub collectActor {
3499 0     0   0 my $o = shift;
3500 0         0 my $label = shift;
3501 0         0 my $value = shift;
3502              
3503 0         0 $o->{actorHash} = $value;
3504             }
3505              
3506             sub collectActor1 {
3507 0     0   0 my $o = shift;
3508 0         0 my $label = shift;
3509 0         0 my $value = shift;
3510              
3511 0         0 $o->{currentBatch}->{actorHash} = $value;
3512             }
3513              
3514             sub collectAnd {
3515 0     0   0 my $o = shift;
3516 0         0 my $label = shift;
3517 0         0 my $value = shift;
3518              
3519 0         0 push @{$o->{batches}}, $o->{currentBatch};
  0         0  
3520             $o->{currentBatch} = {
3521 0         0 addHashes => [],
3522             addEnvelopes => [],
3523             removeHashes => []
3524             };
3525             }
3526              
3527             sub collectFile {
3528 0     0   0 my $o = shift;
3529 0         0 my $label = shift;
3530 0         0 my $value = shift;
3531              
3532 0         0 $o->{file} = $value;
3533             }
3534              
3535             sub collectFile1 {
3536 0     0   0 my $o = shift;
3537 0         0 my $label = shift;
3538 0         0 my $value = shift;
3539              
3540 0         0 push @{$o->{currentBatch}->{addFiles}}, $value;
  0         0  
3541             }
3542              
3543             sub collectHash {
3544 0     0   0 my $o = shift;
3545 0         0 my $label = shift;
3546 0         0 my $value = shift;
3547              
3548 0         0 $o->{hash} = $value;
3549             }
3550              
3551             sub collectHash1 {
3552 0     0   0 my $o = shift;
3553 0         0 my $label = shift;
3554 0         0 my $value = shift;
3555              
3556 0         0 push @{$o->{currentBatch}->{removeHashes}}, $value;
  0         0  
3557             }
3558              
3559             sub collectHash2 {
3560 0     0   0 my $o = shift;
3561 0         0 my $label = shift;
3562 0         0 my $value = shift;
3563              
3564 0         0 push @{$o->{currentBatch}->{addHashes}}, $value;
  0         0  
3565             }
3566              
3567             sub collectKeypair {
3568 0     0   0 my $o = shift;
3569 0         0 my $label = shift;
3570 0         0 my $value = shift;
3571              
3572 0         0 $o->{keyPairToken} = $value;
3573             }
3574              
3575             sub collectMessages {
3576 0     0   0 my $o = shift;
3577 0         0 my $label = shift;
3578 0         0 my $value = shift;
3579              
3580 0         0 $o->{boxLabel} = 'messages';
3581             }
3582              
3583             sub collectMessages1 {
3584 0     0   0 my $o = shift;
3585 0         0 my $label = shift;
3586 0         0 my $value = shift;
3587              
3588 0         0 $o->{currentBatch}->{boxLabel} = 'messages';
3589             }
3590              
3591             sub collectObject {
3592 0     0   0 my $o = shift;
3593 0         0 my $label = shift;
3594 0         0 my $value = shift;
3595              
3596 0         0 $o->{hash} = $value->hash;
3597 0         0 $o->{store} = $value->cliStore;
3598             }
3599              
3600             sub collectPrivate {
3601 0     0   0 my $o = shift;
3602 0         0 my $label = shift;
3603 0         0 my $value = shift;
3604              
3605 0         0 $o->{boxLabel} = 'private';
3606             }
3607              
3608             sub collectPrivate1 {
3609 0     0   0 my $o = shift;
3610 0         0 my $label = shift;
3611 0         0 my $value = shift;
3612              
3613 0         0 $o->{currentBatch}->{boxLabel} = 'private';
3614             }
3615              
3616             sub collectPublic {
3617 0     0   0 my $o = shift;
3618 0         0 my $label = shift;
3619 0         0 my $value = shift;
3620              
3621 0         0 $o->{boxLabel} = 'public';
3622             }
3623              
3624             sub collectPublic1 {
3625 0     0   0 my $o = shift;
3626 0         0 my $label = shift;
3627 0         0 my $value = shift;
3628              
3629 0         0 $o->{currentBatch}->{boxLabel} = 'public';
3630             }
3631              
3632             sub collectStore {
3633 0     0   0 my $o = shift;
3634 0         0 my $label = shift;
3635 0         0 my $value = shift;
3636              
3637 0         0 $o->{store} = $value;
3638             }
3639              
3640             sub collectWatch {
3641 0     0   0 my $o = shift;
3642 0         0 my $label = shift;
3643 0         0 my $value = shift;
3644              
3645 0         0 $o->{watchTimeout} = 60000;
3646             }
3647              
3648             sub new {
3649 0     0   0 my $class = shift;
3650 0         0 my $actor = shift;
3651 0         0 bless {actor => $actor, ui => $actor->ui} }
3652              
3653             # END AUTOGENERATED
3654              
3655             # HTML FOLDER NAME curl
3656             # HTML TITLE Curl
3657             sub help {
3658 0     0   0 my $o = shift;
3659 0         0 my $cmd = shift;
3660              
3661 0         0 my $ui = $o->{ui};
3662 0         0 $ui->space;
3663 0         0 $ui->p($ui->blue('cds curl'), ' prepares and executes a CURL command line for a HTTP store request. This is helpful for debugging a HTTP store implementation. Outside of low-level debugging, it is more convenient to use the "cds get|put|list|add|remove …" commands, which are richer in functionality, and work on all stores.');
3664 0         0 $ui->space;
3665 0         0 $ui->command('cds curl get OBJECT');
3666 0         0 $ui->command('cds curl get HASH [from|on STORE]');
3667 0         0 $ui->p('Downloads an object with a GET request on an object store.');
3668 0         0 $ui->space;
3669 0         0 $ui->command('cds curl put FILE [onto STORE]');
3670 0         0 $ui->p('Uploads an object with a PUT request on an object store.');
3671 0         0 $ui->space;
3672 0         0 $ui->command('cds curl book OBJECT');
3673 0         0 $ui->command('cds curl book HASH [on STORE]');
3674 0         0 $ui->p('Books an object with a POST request on an object store.');
3675 0         0 $ui->space;
3676 0         0 $ui->command('cds curl list message box of ACTOR [on STORE]');
3677 0         0 $ui->command('cds curl list private box of ACTOR [on STORE]');
3678 0         0 $ui->command('cds curl list public box of ACTOR [on STORE]');
3679 0         0 $ui->p('Lists the indicated box with a GET request on an account store.');
3680 0         0 $ui->space;
3681 0         0 $ui->command('cds curl watch message box of ACTOR [on STORE]');
3682 0         0 $ui->command('cds curl watch private box of ACTOR [on STORE]');
3683 0         0 $ui->command('cds curl watch public box of ACTOR [on STORE]');
3684 0         0 $ui->p('As above, but with a watch timeout of 60 second.');
3685 0         0 $ui->space;
3686 0         0 $ui->command('cds curl add (FILE|HASH)* to (message|private|public) box of ACTOR [and …] [on STORE]');
3687 0         0 $ui->command('cds curl remove HASH* from (message|private|public) box of ACTOR [and …] [on STORE]');
3688 0         0 $ui->p('Modifies the indicated boxes with a POST request on an account store. Multiple modifications to different boxes may be chained using "and". All modifications are submitted using a single request, which is optionally signed (see below).');
3689 0         0 $ui->space;
3690 0         0 $ui->command('… using KEYPAIR');
3691 0         0 $ui->p('Signs the request using KEYPAIR instead of the actor\'s key pair. The store may or may not verify the signature.');
3692 0         0 $ui->p('For debugging purposes, information about the signature is stored as ".cds-curl-bytes-to-sign", ".cds-curl-hash-to-sign", and ".cds-curl-signature" in the current folder. Note that signatures are valid for 1-2 minutes only. After that, servers will reject them to guard against replay attacks.');
3693 0         0 $ui->space;
3694             }
3695              
3696             sub curlGet {
3697 0     0   0 my $o = shift;
3698 0         0 my $cmd = shift;
3699              
3700 0         0 $cmd->collect($o);
3701 0 0       0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken if ! $o->{keyPairToken};
3702 0 0       0 $o->{store} = $o->{actor}->preferredStore if ! $o->{store};
3703              
3704 0         0 my $objectToken = CDS::ObjectToken->new($o->{store}, $o->{hash});
3705 0         0 $o->curlRequest('GET', $objectToken->url, ['--output', $o->{hash}->hex]);
3706             }
3707              
3708             sub curlPut {
3709 0     0   0 my $o = shift;
3710 0         0 my $cmd = shift;
3711              
3712 0         0 $cmd->collect($o);
3713 0 0       0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken if ! $o->{keyPairToken};
3714 0 0       0 $o->{store} = $o->{actor}->preferredStore if ! $o->{store};
3715              
3716 0   0     0 my $bytes = CDS->readBytesFromFile($o->{file}) // return $o->{ui}->error('Unable to read "', $o->{file}, '".');
3717 0         0 my $hash = CDS::Hash->calculateFor($bytes);
3718 0         0 my $objectToken = CDS::ObjectToken->new($o->{store}, $hash);
3719 0         0 $o->curlRequest('PUT', $objectToken->url, ['--data-binary', '@'.$o->{file}, '-H', 'Content-Type: application/condensation-object']);
3720             }
3721              
3722             sub curlBook {
3723 0     0   0 my $o = shift;
3724 0         0 my $cmd = shift;
3725              
3726 0         0 $cmd->collect($o);
3727 0 0       0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken if ! $o->{keyPairToken};
3728 0 0       0 $o->{store} = $o->{actor}->preferredStore if ! $o->{store};
3729              
3730 0         0 my $objectToken = CDS::ObjectToken->new($o->{store}, $o->{hash});
3731 0         0 $o->curlRequest('POST', $objectToken->url, []);
3732             }
3733              
3734             sub curlList {
3735 0     0   0 my $o = shift;
3736 0         0 my $cmd = shift;
3737              
3738 0         0 $cmd->collect($o);
3739 0 0       0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken if ! $o->{keyPairToken};
3740 0 0       0 $o->{store} = $o->{actor}->preferredStore if ! $o->{store};
3741 0 0       0 $o->{actorHash} = $o->{actor}->preferredActorHash if ! $o->{actorHash};
3742              
3743 0         0 my $boxToken = CDS::BoxToken->new(CDS::AccountToken->new($o->{store}, $o->{actorHash}), $o->{boxLabel});
3744 0         0 my $args = ['--output', '.cds-curl-list'];
3745 0 0       0 push @$args, '-H', 'Condensation-Watch: '.$o->{watchTimeout}.' ms' if $o->{watchTimeout};
3746 0         0 $o->curlRequest('GET', $boxToken->url, $args);
3747             }
3748              
3749             sub curlModify {
3750 0     0   0 my $o = shift;
3751 0         0 my $cmd = shift;
3752              
3753             $o->{currentBatch} = {
3754 0         0 addHashes => [],
3755             addEnvelopes => [],
3756             removeHashes => [],
3757             };
3758 0         0 $o->{batches} = [];
3759 0         0 $cmd->collect($o);
3760 0 0       0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken if ! $o->{keyPairToken};
3761 0 0       0 $o->{store} = $o->{actor}->preferredStore if ! $o->{store};
3762              
3763             # Prepare the modifications
3764 0         0 my $modifications = CDS::StoreModifications->new;
3765              
3766 0         0 for my $batch (@{$o->{batches}}, $o->{currentBatch}) {
  0         0  
3767 0 0       0 $batch->{actorHash} = $o->{actor}->preferredActorHash if ! $batch->{actorHash};
3768              
3769 0         0 for my $hash (@{$batch->{addHashes}}) {
  0         0  
3770 0         0 $modifications->add($batch->{actorHash}, $batch->{boxLabel}, $hash);
3771             }
3772              
3773 0         0 for my $file (@{$batch->{addFiles}}) {
  0         0  
3774 0   0     0 my $bytes = CDS->readBytesFromFile($file) // return $o->{ui}->error('Unable to read "', $file, '".');
3775 0   0     0 my $object = CDS::Object->fromBytes($bytes) // return $o->{ui}->error('"', $file, '" is not a Condensation object.');
3776 0         0 my $hash = $object->calculateHash;
3777 0 0       0 $o->{ui}->warning('"', $file, '" is not a valid envelope. The server may reject it.') if ! $o->{actor}->isEnvelope($object);
3778 0         0 $modifications->add($batch->{actorHash}, $batch->{boxLabel}, $hash, $object);
3779             }
3780              
3781 0         0 for my $hash (@{$batch->{removeHashes}}) {
  0         0  
3782 0         0 $modifications->remove($batch->{actorHash}, $batch->{boxLabel}, $hash);
3783             }
3784             }
3785              
3786 0 0       0 $o->{ui}->warning('You didn\'t specify any changes. The server should accept, but ignore this.') if $modifications->isEmpty;
3787              
3788             # Write a new file
3789 0         0 my $modificationsObject = $modifications->toRecord->toObject;
3790 0         0 my $modificationsHash = $modificationsObject->calculateHash;
3791 0         0 my $file = '.cds-curl-modifications-'.substr($modificationsHash->hex, 0, 8);
3792 0   0     0 CDS->writeBytesToFile($file, $modificationsObject->header, $modificationsObject->data) // return $o->{ui}->error('Unable to write modifications to "', $file, '".');
3793 0         0 $o->{ui}->line(scalar @{$modifications->additions}, ' addition(s) and ', scalar @{$modifications->removals}, ' removal(s) written to "', $file, '".');
  0         0  
  0         0  
3794              
3795             # Submit
3796 0         0 $o->curlRequest('POST', $o->{store}->url.'/accounts', ['--data-binary', '@'.$file, '-H', 'Content-Type: application/condensation-modifications'], $modificationsObject);
3797             }
3798              
3799             sub curlRequest {
3800 0     0   0 my $o = shift;
3801 0         0 my $method = shift;
3802 0         0 my $url = shift;
3803 0         0 my $curlArgs = shift;
3804 0         0 my $contentObjectToSign = shift;
3805              
3806             # Parse the URL
3807 0 0       0 $url =~ /^(https?):\/\/([^\/]+)(\/.*|)$/i || return $o->{ui}->error('"', $url, '" does not look like a valid and complete http://… or https://… URL.');
3808 0         0 my $protocol = lc($1);
3809 0         0 my $host = $2;
3810 0         0 my $path = $3;
3811              
3812             # Strip off user and password, if any
3813 0         0 my $credentials;
3814 0 0       0 if ($host =~ /^(.*)\@([^\@]*)$/) {
3815 0         0 $credentials = $1;
3816 0         0 $host = lc($2);
3817             } else {
3818 0         0 $host = lc($host);
3819             }
3820              
3821             # Remove default port
3822 0 0       0 if ($host =~ /^(.*):(\d+)$/) {
3823 0 0 0     0 $host = $1 if $protocol eq 'http' && $2 == 80;
3824 0 0 0     0 $host = $1 if $protocol eq 'https' && $2 == 443;
3825             }
3826              
3827             # Checks the path and warn the user if obvious things are likely to go wrong
3828 0 0       0 $o->{ui}->warning('Warning: "//" in URL may not work') if $path =~ /\/\//;
3829 0 0       0 $o->{ui}->warning('Warning: /./ or /../ in URL may not work') if $path =~ /\/\.+\//;
3830 0 0       0 $o->{ui}->warning('Warning: /. or /.. at the end of the URL may not work') if $path =~ /\/\.+$/;
3831              
3832             # Signature
3833              
3834             # Date
3835 0         0 my $dateString = CDS::ISODate->millisecondString(CDS->now);
3836              
3837             # Text to sign
3838 0         0 my $bytesToSign = $dateString."\0".uc($method)."\0".$host.$path;
3839 0 0       0 $bytesToSign .= "\0".$contentObjectToSign->header.$contentObjectToSign->data if defined $contentObjectToSign;
3840              
3841             # Signature
3842 0         0 my $keyPair = $o->{keyPairToken}->keyPair;
3843 0         0 my $hashToSign = CDS::Hash->calculateFor($bytesToSign);
3844 0         0 my $signature = $keyPair->signHash($hashToSign);
3845 0         0 push @$curlArgs, '-H', 'Condensation-Date: '.$dateString;
3846 0         0 push @$curlArgs, '-H', 'Condensation-Actor: '.$keyPair->publicKey->hash->hex;
3847 0         0 push @$curlArgs, '-H', 'Condensation-Signature: '.unpack('H*', $signature);
3848              
3849             # Write signature information to files
3850 0 0       0 CDS->writeBytesToFile('.cds-curl-bytesToSign', $bytesToSign) || $o->{ui}->warning('Unable to write the bytes to sign to ".cds-curl-bytesToSign".');
3851 0 0       0 CDS->writeBytesToFile('.cds-curl-hashToSign', $hashToSign->bytes) || $o->{ui}->warning('Unable to write the hash to sign to ".cds-curl-hashToSign".');
3852 0 0       0 CDS->writeBytesToFile('.cds-curl-signature', $signature) || $o->{ui}->warning('Unable to write signature to ".cds-curl-signature".');
3853              
3854             # Method
3855 0 0       0 unshift @$curlArgs, '-X', $method if $method ne 'GET';
3856 0         0 unshift @$curlArgs, '-#', '--dump-header', '-';
3857              
3858             # Print
3859 0 0 0     0 $o->{ui}->line($o->{ui}->gold('curl', join('', map { ($_ ne '-X' && $_ ne '-' && $_ ne '--dump-header' && $_ ne '-#' && substr($_, 0, 1) eq '-' ? " \\\n " : ' ').&withQuotesIfNecessary($_) } @$curlArgs), scalar @$curlArgs ? " \\\n " : ' ', &withQuotesIfNecessary($url)));
  0 0       0  
3860              
3861             # Execute
3862 0         0 system('curl', @$curlArgs, $url);
3863             }
3864              
3865             sub withQuotesIfNecessary {
3866 0     0   0 my $text = shift;
3867              
3868 0 0       0 return $text =~ /[^a-zA-Z0-9\.\/\@:,_-]/ ? '\''.$text.'\'' : $text;
3869             }
3870              
3871             # BEGIN AUTOGENERATED
3872             package CDS::Commands::DiscoverActorGroup;
3873              
3874             sub register {
3875 0     0   0 my $class = shift;
3876 0         0 my $cds = shift;
3877 0         0 my $help = shift;
3878              
3879 0         0 my $node000 = CDS::Parser::Node->new(0);
3880 0         0 my $node001 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
3881 0         0 my $node002 = CDS::Parser::Node->new(1);
3882 0         0 my $node003 = CDS::Parser::Node->new(0);
3883 0         0 my $node004 = CDS::Parser::Node->new(0);
3884 0         0 my $node005 = CDS::Parser::Node->new(0);
3885 0         0 my $node006 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showActorGroupCmd});
3886 0         0 my $node007 = CDS::Parser::Node->new(0);
3887 0         0 my $node008 = CDS::Parser::Node->new(0);
3888 0         0 my $node009 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&discover});
3889 0         0 my $node010 = CDS::Parser::Node->new(0);
3890 0         0 my $node011 = CDS::Parser::Node->new(0);
3891 0         0 my $node012 = CDS::Parser::Node->new(0);
3892 0         0 my $node013 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&discover});
3893 0         0 $cds->addArrow($node000, 1, 0, 'show');
3894 0         0 $cds->addArrow($node002, 1, 0, 'discover');
3895 0         0 $help->addArrow($node001, 1, 0, 'discover');
3896 0         0 $help->addArrow($node001, 1, 0, 'rediscover');
3897 0         0 $node000->addArrow($node006, 1, 0, 'ACTORGROUP', \&collectActorgroup);
3898 0         0 $node002->addDefault($node003);
3899 0         0 $node002->addDefault($node004);
3900 0         0 $node002->addDefault($node005);
3901 0         0 $node002->addArrow($node009, 1, 0, 'me', \&collectMe);
3902 0         0 $node002->addArrow($node013, 1, 0, 'ACTORGROUP', \&collectActorgroup1);
3903 0         0 $node003->addArrow($node003, 1, 0, 'ACCOUNT', \&collectAccount);
3904 0         0 $node003->addArrow($node009, 1, 1, 'ACCOUNT', \&collectAccount);
3905 0         0 $node004->addArrow($node004, 1, 0, 'KEYPAIR', \&collectKeypair);
3906 0         0 $node004->addArrow($node007, 1, 0, 'KEYPAIR', \&collectKeypair);
3907 0         0 $node005->addArrow($node005, 1, 0, 'ACTOR', \&collectActor);
3908 0         0 $node005->addArrow($node007, 1, 0, 'ACTOR', \&collectActor);
3909 0         0 $node007->addArrow($node008, 1, 0, 'on');
3910 0         0 $node007->addDefault($node009);
3911 0         0 $node008->addArrow($node009, 1, 0, 'STORE', \&collectStore);
3912 0         0 $node009->addArrow($node010, 1, 0, 'and');
3913 0         0 $node010->addArrow($node011, 1, 0, 'remember');
3914 0         0 $node011->addArrow($node012, 1, 0, 'as');
3915 0         0 $node012->addArrow($node013, 1, 0, 'TEXT', \&collectText);
3916             }
3917              
3918             sub collectAccount {
3919 0     0   0 my $o = shift;
3920 0         0 my $label = shift;
3921 0         0 my $value = shift;
3922              
3923 0         0 push @{$o->{accounts}}, $value;
  0         0  
3924             }
3925              
3926             sub collectActor {
3927 0     0   0 my $o = shift;
3928 0         0 my $label = shift;
3929 0         0 my $value = shift;
3930              
3931 0         0 push @{$o->{actorHashes}}, $value;
  0         0  
3932             }
3933              
3934             sub collectActorgroup {
3935 0     0   0 my $o = shift;
3936 0         0 my $label = shift;
3937 0         0 my $value = shift;
3938              
3939 0         0 $o->{actorGroupToken} = $value;
3940             }
3941              
3942             sub collectActorgroup1 {
3943 0     0   0 my $o = shift;
3944 0         0 my $label = shift;
3945 0         0 my $value = shift;
3946              
3947 0         0 $o->{actorGroupToken} = $value;
3948 0         0 $o->{label} = $value->label;
3949             }
3950              
3951             sub collectKeypair {
3952 0     0   0 my $o = shift;
3953 0         0 my $label = shift;
3954 0         0 my $value = shift;
3955              
3956 0         0 push @{$o->{actorHashes}}, $value->keyPair->publicKey->hash;
  0         0  
3957             }
3958              
3959             sub collectMe {
3960 0     0   0 my $o = shift;
3961 0         0 my $label = shift;
3962 0         0 my $value = shift;
3963              
3964 0         0 $o->{me} = 1;
3965             }
3966              
3967             sub collectStore {
3968 0     0   0 my $o = shift;
3969 0         0 my $label = shift;
3970 0         0 my $value = shift;
3971              
3972 0         0 $o->{store} = $value;
3973             }
3974              
3975             sub collectText {
3976 0     0   0 my $o = shift;
3977 0         0 my $label = shift;
3978 0         0 my $value = shift;
3979              
3980 0         0 $o->{label} = $value;
3981             }
3982              
3983             sub new {
3984 0     0   0 my $class = shift;
3985 0         0 my $actor = shift;
3986 0         0 bless {actor => $actor, ui => $actor->ui} }
3987              
3988             # END AUTOGENERATED
3989              
3990             # HTML FOLDER NAME discover
3991             # HTML TITLE Discover actor groups
3992             sub help {
3993 0     0   0 my $o = shift;
3994 0         0 my $cmd = shift;
3995              
3996 0         0 my $ui = $o->{ui};
3997 0         0 $ui->space;
3998 0         0 $ui->command('cds discover ACCOUNT');
3999 0         0 $ui->command('cds discover ACTOR [on STORE]');
4000 0         0 $ui->p('Discovers the actor group the given account belongs to. Only active group members are discovered.');
4001 0         0 $ui->space;
4002 0         0 $ui->command('cds discover ACCOUNT*');
4003 0         0 $ui->command('cds discover ACTOR* on STORE');
4004 0         0 $ui->p('Same as above, but starts discovery with multiple accounts. All accounts must belong to the same actor group.');
4005 0         0 $ui->p('Note that this rarely makes sense. The actor group discovery algorithm reliably discovers an actor group from a single account.');
4006 0         0 $ui->space;
4007 0         0 $ui->command('cds discover me');
4008 0         0 $ui->p('Discovers your own actor group.');
4009 0         0 $ui->space;
4010 0         0 $ui->command('… and remember as TEXT');
4011 0         0 $ui->p('The discovered actor group is remembered as TEXT. See "cds help remember" for details.');
4012 0         0 $ui->space;
4013 0         0 $ui->command('cds discover ACTORGROUP');
4014 0         0 $ui->p('Updates a previously remembered actor group.');
4015 0         0 $ui->space;
4016 0         0 $ui->command('cds show ACTORGROUP');
4017 0         0 $ui->p('Shows a previously discovered and remembered actor group.');
4018 0         0 $ui->space;
4019             }
4020              
4021             sub discover {
4022 0     0   0 my $o = shift;
4023 0         0 my $cmd = shift;
4024              
4025 0         0 $o->{accounts} = [];
4026 0         0 $o->{actorHashes} = [];
4027 0         0 $cmd->collect($o);
4028              
4029             # Discover
4030 0         0 my $builder = $o->prepareBuilder;
4031 0         0 my ($actorGroup, $cards, $nodes) = $builder->discover($o->{actor}->keyPair, $o);
4032              
4033             # Show the graph
4034 0         0 $o->{ui}->space;
4035 0         0 $o->{ui}->title('Graph');
4036 0         0 for my $node (@$nodes) {
4037 0 0       0 my $status = $node->status eq 'active' ? $o->{ui}->green('active ') : $o->{ui}->gray('idle ');
4038 0         0 $o->{ui}->line($o->{ui}->blue($node->actorHash->hex), ' on ', $node->storeUrl, ' ', $status, $o->{ui}->gray($o->{ui}->niceDateTime($node->revision)));
4039 0         0 $o->{ui}->pushIndent;
4040 0         0 for my $link ($node->links) {
4041 0         0 my $isMostRecentInformation = $link->revision == $link->node->revision;
4042 0 0       0 my $color = $isMostRecentInformation ? 246 : 250;
4043 0         0 $o->{ui}->line($link->node->actorHash->shortHex, ' on ', $link->node->storeUrl, ' ', $o->{ui}->foreground($color, $o->{ui}->left(8, $link->status), $o->{ui}->niceDateTime($link->revision)));
4044             }
4045 0         0 $o->{ui}->popIndent;
4046             }
4047              
4048             # Show all accounts
4049 0         0 $o->showActorGroup($actorGroup);
4050              
4051             # Show all cards
4052 0         0 $o->{ui}->space;
4053 0         0 $o->{ui}->title('Cards');
4054 0         0 for my $card (@$cards) {
4055 0         0 $o->{ui}->line($o->{ui}->gold('cds show record ', $card->cardHash->hex, ' on ', $card->storeUrl));
4056             }
4057              
4058             # Remember the actor group if desired
4059 0 0       0 if ($o->{label}) {
4060 0         0 my $selector = $o->{actor}->labelSelector($o->{label});
4061              
4062 0         0 my $record = CDS::Record->new;
4063 0         0 my $actorGroupRecord = $record->add('actor group');
4064 0         0 $actorGroupRecord->add('discovered')->addInteger(CDS->now);
4065 0         0 $actorGroupRecord->addRecord($actorGroup->toBuilder->toRecord(1)->children);
4066 0         0 $selector->set($record);
4067              
4068 0         0 for my $publicKey ($actorGroup->publicKeys) {
4069 0         0 $selector->addObject($publicKey->hash, $publicKey->object);
4070             }
4071              
4072 0   0     0 $o->{actor}->saveOrShowError // return;
4073             }
4074              
4075 0         0 $o->{ui}->space;
4076             }
4077              
4078             sub prepareBuilder {
4079 0     0   0 my $o = shift;
4080              
4081             # Actor group
4082 0 0       0 return $o->{actorGroupToken}->actorGroup->toBuilder if $o->{actorGroupToken};
4083              
4084             # Other than actor group
4085 0         0 my $builder = CDS::ActorGroupBuilder->new;
4086 0         0 $builder->addKnownPublicKey($o->{actor}->keyPair->publicKey);
4087              
4088             # Me
4089 0 0       0 $builder->addMember($o->{actor}->messagingStoreUrl, $o->{actor}->keyPair->publicKey->hash) if $o->{me};
4090              
4091             # Accounts
4092 0         0 for my $account (@{$o->{accounts}}) {
  0         0  
4093 0         0 $builder->addMember($account->cliStore->url, $account->actorHash);
4094             }
4095              
4096             # Actors on store
4097 0 0       0 if (scalar @{$o->{actorHashes}}) {
  0         0  
4098 0   0     0 my $store = $o->{store} // $o->{actor}->preferredStore;
4099 0         0 for my $actorHash (@{$o->{actorHashes}}) {
  0         0  
4100 0         0 $builder->addMember($actorHash, $store->url);
4101             }
4102             }
4103              
4104 0         0 return $builder;
4105             }
4106              
4107             sub showActorGroupCmd {
4108 0     0   0 my $o = shift;
4109 0         0 my $cmd = shift;
4110              
4111 0         0 $cmd->collect($o);
4112 0         0 $o->showActorGroup($o->{actorGroupToken}->actorGroup);
4113 0         0 $o->{ui}->space;
4114             }
4115              
4116             sub showActorGroup {
4117 0     0   0 my $o = shift;
4118 0 0 0     0 my $actorGroup = shift; die 'wrong type '.ref($actorGroup).' for $actorGroup' if defined $actorGroup && ref $actorGroup ne 'CDS::ActorGroup';
  0         0  
4119              
4120 0         0 $o->{ui}->space;
4121 0 0       0 $o->{ui}->title(length $o->{label} ? 'Actors of '.$o->{label} : 'Actor group');
4122 0         0 for my $member ($actorGroup->members) {
4123 0 0       0 my $date = $member->revision ? $o->{ui}->niceDateTimeLocal($member->revision) : ' ';
4124 0 0       0 my $status = $member->isActive ? $o->{ui}->green('active ') : $o->{ui}->gray('idle ');
4125 0         0 my $storeReference = $o->{actor}->blueStoreUrlReference($member->storeUrl);
4126 0         0 $o->{ui}->line($o->{ui}->gray($date), ' ', $status, ' ', $member->actorOnStore->publicKey->hash->hex, ' on ', $storeReference);
4127             }
4128              
4129 0 0       0 if ($actorGroup->entrustedActorsRevision) {
4130 0         0 $o->{ui}->space;
4131 0 0       0 $o->{ui}->title(length $o->{label} ? 'Actors entrusted by '.$o->{label} : 'Entrusted actors');
4132 0         0 $o->{ui}->line($o->{ui}->gray($o->{ui}->niceDateTimeLocal($actorGroup->entrustedActorsRevision)));
4133 0         0 for my $actor ($actorGroup->entrustedActors) {
4134 0         0 my $storeReference = $o->{actor}->storeUrlReference($actor->storeUrl);
4135 0         0 $o->{ui}->line($actor->actorOnStore->publicKey->hash->hex, $o->{ui}->gray(' on ', $storeReference));
4136             }
4137              
4138 0 0       0 $o->{ui}->line($o->{ui}->gray('(none)')) if ! scalar $actorGroup->entrustedActors;
4139             }
4140             }
4141              
4142             sub onDiscoverActorGroupVerifyStore {
4143 0     0   0 my $o = shift;
4144 0         0 my $storeUrl = shift;
4145 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
4146              
4147 0         0 return $o->{actor}->storeForUrl($storeUrl);
4148             }
4149              
4150             sub onDiscoverActorGroupInvalidPublicKey {
4151 0     0   0 my $o = shift;
4152 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
4153 0         0 my $store = shift;
4154 0         0 my $reason = shift;
4155              
4156 0         0 $o->{ui}->warning('Public key ', $actorHash->hex, ' on ', $store->url, ' is invalid: ', $reason);
4157             }
4158              
4159             sub onDiscoverActorGroupInvalidCard {
4160 0     0   0 my $o = shift;
4161 0 0 0     0 my $actorOnStore = shift; die 'wrong type '.ref($actorOnStore).' for $actorOnStore' if defined $actorOnStore && ref $actorOnStore ne 'CDS::ActorOnStore';
  0         0  
4162 0 0 0     0 my $envelopeHash = shift; die 'wrong type '.ref($envelopeHash).' for $envelopeHash' if defined $envelopeHash && ref $envelopeHash ne 'CDS::Hash';
  0         0  
4163 0         0 my $reason = shift;
4164              
4165 0         0 $o->{ui}->warning('Card ', $envelopeHash->hex, ' on ', $actorOnStore->store->url, ' is invalid: ', $reason);
4166             }
4167              
4168             sub onDiscoverActorGroupStoreError {
4169 0     0   0 my $o = shift;
4170 0         0 my $store = shift;
4171 0         0 my $error = shift;
4172              
4173             }
4174              
4175             # BEGIN AUTOGENERATED
4176             package CDS::Commands::EntrustedActors;
4177              
4178             sub register {
4179 0     0   0 my $class = shift;
4180 0         0 my $cds = shift;
4181 0         0 my $help = shift;
4182              
4183 0         0 my $node000 = CDS::Parser::Node->new(0);
4184 0         0 my $node001 = CDS::Parser::Node->new(0);
4185 0         0 my $node002 = CDS::Parser::Node->new(0);
4186 0         0 my $node003 = CDS::Parser::Node->new(0);
4187 0         0 my $node004 = CDS::Parser::Node->new(0);
4188 0         0 my $node005 = CDS::Parser::Node->new(0);
4189 0         0 my $node006 = CDS::Parser::Node->new(0);
4190 0         0 my $node007 = CDS::Parser::Node->new(0);
4191 0         0 my $node008 = CDS::Parser::Node->new(0);
4192 0         0 my $node009 = CDS::Parser::Node->new(0);
4193 0         0 my $node010 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
4194 0         0 my $node011 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&show});
4195 0         0 my $node012 = CDS::Parser::Node->new(0);
4196 0         0 my $node013 = CDS::Parser::Node->new(0);
4197 0         0 my $node014 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&doNotEntrust});
4198 0         0 my $node015 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&entrust});
4199 0         0 my $node016 = CDS::Parser::Node->new(0);
4200 0         0 $cds->addArrow($node001, 1, 0, 'show');
4201 0         0 $cds->addArrow($node003, 1, 0, 'do');
4202 0         0 $cds->addArrow($node005, 1, 0, 'entrust');
4203 0         0 $help->addArrow($node000, 1, 0, 'entrusted');
4204 0         0 $node000->addArrow($node010, 1, 0, 'actors');
4205 0         0 $node001->addArrow($node002, 1, 0, 'entrusted');
4206 0         0 $node002->addArrow($node011, 1, 0, 'actors');
4207 0         0 $node003->addArrow($node004, 1, 0, 'not');
4208 0         0 $node004->addArrow($node008, 1, 0, 'entrust');
4209 0         0 $node005->addDefault($node006);
4210 0         0 $node005->addDefault($node007);
4211 0         0 $node005->addArrow($node012, 1, 0, 'ACTOR', \&collectActor);
4212 0         0 $node006->addArrow($node006, 1, 0, 'ACCOUNT', \&collectAccount);
4213 0         0 $node006->addArrow($node015, 1, 1, 'ACCOUNT', \&collectAccount);
4214 0         0 $node007->addArrow($node007, 1, 0, 'ACTOR', \&collectActor1);
4215 0         0 $node007->addArrow($node015, 1, 0, 'ACTOR', \&collectActor1);
4216 0         0 $node008->addDefault($node009);
4217 0         0 $node009->addArrow($node009, 1, 0, 'ACTOR', \&collectActor2);
4218 0         0 $node009->addArrow($node014, 1, 0, 'ACTOR', \&collectActor2);
4219 0         0 $node012->addArrow($node013, 1, 0, 'on');
4220 0         0 $node013->addArrow($node015, 1, 0, 'STORE', \&collectStore);
4221 0         0 $node015->addArrow($node016, 1, 0, 'and');
4222 0         0 $node016->addDefault($node005);
4223             }
4224              
4225             sub collectAccount {
4226 0     0   0 my $o = shift;
4227 0         0 my $label = shift;
4228 0         0 my $value = shift;
4229              
4230 0         0 push @{$o->{accountTokens}}, $value;
  0         0  
4231             }
4232              
4233             sub collectActor {
4234 0     0   0 my $o = shift;
4235 0         0 my $label = shift;
4236 0         0 my $value = shift;
4237              
4238 0         0 $o->{actorHash} = $value;
4239             }
4240              
4241             sub collectActor1 {
4242 0     0   0 my $o = shift;
4243 0         0 my $label = shift;
4244 0         0 my $value = shift;
4245              
4246 0         0 push @{$o->{accountTokens}}, CDS::AccountToken->new($o->{actor}->preferredStore, $value);
  0         0  
4247             }
4248              
4249             sub collectActor2 {
4250 0     0   0 my $o = shift;
4251 0         0 my $label = shift;
4252 0         0 my $value = shift;
4253              
4254 0         0 push @{$o->{actorHashes}}, $value;
  0         0  
4255             }
4256              
4257             sub collectStore {
4258 0     0   0 my $o = shift;
4259 0         0 my $label = shift;
4260 0         0 my $value = shift;
4261              
4262 0         0 push @{$o->{accountTokens}}, CDS::AccountToken->new($value, $o->{actorHash});
  0         0  
4263 0         0 delete $o->{actorHash};
4264             }
4265              
4266             sub new {
4267 0     0   0 my $class = shift;
4268 0         0 my $actor = shift;
4269 0         0 bless {actor => $actor, ui => $actor->ui} }
4270              
4271             # END AUTOGENERATED
4272              
4273             # HTML FOLDER NAME entrusted-actors
4274             # HTML TITLE Entrusted actors
4275             sub help {
4276 0     0   0 my $o = shift;
4277 0         0 my $cmd = shift;
4278              
4279 0         0 my $ui = $o->{ui};
4280 0         0 $ui->space;
4281 0         0 $ui->command('cds show entrusted actors');
4282 0         0 $ui->p('Shows all entrusted actors.');
4283 0         0 $ui->space;
4284 0         0 $ui->command('cds entrust ACCOUNT*');
4285 0         0 $ui->command('cds entrust ACTOR on STORE');
4286 0         0 $ui->p('Adds the indicated entrusted actors. Entrusted actors can read our private data and messages. The public key of the entrusted actor must be available on the store.');
4287 0         0 $ui->space;
4288 0         0 $ui->command('cds do not entrust ACTOR*');
4289 0         0 $ui->p('Removes the indicated entrusted actors.');
4290 0         0 $ui->space;
4291 0         0 $ui->p('After modifying the entrusted actors, you should "cds announce" yourself to publish the changes.');
4292 0         0 $ui->space;
4293             }
4294              
4295             sub show {
4296 0     0   0 my $o = shift;
4297 0         0 my $cmd = shift;
4298              
4299 0         0 my $builder = CDS::ActorGroupBuilder->new;
4300 0         0 $builder->parseEntrustedActorList($o->{actor}->entrustedActorsSelector->record, 1);
4301              
4302 0         0 my @actors = $builder->entrustedActors;
4303 0         0 for my $actor (@actors) {
4304 0         0 my $storeReference = $o->{actor}->storeUrlReference($actor->storeUrl);
4305 0         0 $o->{ui}->line($actor->hash->hex, $o->{ui}->gray(' on ', $storeReference));
4306             }
4307              
4308 0 0       0 return if scalar @actors;
4309 0         0 $o->{ui}->line($o->{ui}->gray('none'));
4310             }
4311              
4312             sub entrust {
4313 0     0   0 my $o = shift;
4314 0         0 my $cmd = shift;
4315              
4316 0         0 $o->{accountTokens} = [];
4317 0         0 $cmd->collect($o);
4318              
4319             # Get the list of currently entrusted actors
4320 0         0 my $entrusted = $o->createEntrustedActorsIndex;
4321              
4322             # Add new actors
4323 0         0 for my $accountToken (@{$o->{accountTokens}}) {
  0         0  
4324 0         0 my $actorHash = $accountToken->actorHash;
4325              
4326             # Check if the key is already entrusted
4327 0 0       0 if ($entrusted->{$accountToken->url}) {
4328 0         0 $o->{ui}->pOrange($accountToken->url, ' is already entrusted.');
4329 0         0 next;
4330             }
4331              
4332             # Get the public key
4333 0         0 my ($publicKey, $invalidReason, $storeError) = $o->{actor}->keyPair->getPublicKey($actorHash, $accountToken->cliStore);
4334 0 0       0 if (defined $storeError) {
4335 0         0 $o->{ui}->pRed('Unable to get the public key ', $actorHash->hex, ' from ', $accountToken->cliStore->url, ': ', $storeError);
4336 0         0 next;
4337             }
4338              
4339 0 0       0 if (defined $invalidReason) {
4340 0         0 $o->{ui}->pRed('Unable to get the public key ', $actorHash->hex, ' from ', $accountToken->cliStore->url, ': ', $invalidReason);
4341 0         0 next;
4342             }
4343              
4344             # Add it
4345 0         0 $o->{actor}->entrust($accountToken->cliStore->url, $publicKey);
4346 0 0       0 $o->{ui}->pGreen($entrusted->{$actorHash->hex} ? 'Updated ' : 'Added ', $actorHash->hex, ' as entrusted actor.');
4347             }
4348              
4349             # Save
4350 0         0 $o->{actor}->saveOrShowError;
4351             }
4352              
4353             sub doNotEntrust {
4354 0     0   0 my $o = shift;
4355 0         0 my $cmd = shift;
4356              
4357 0         0 $o->{actorHashes} = [];
4358 0         0 $cmd->collect($o);
4359              
4360             # Get the list of currently entrusted actors
4361 0         0 my $entrusted = $o->createEntrustedActorsIndex;
4362              
4363             # Remove entrusted actors
4364 0         0 for my $actorHash (@{$o->{actorHashes}}) {
  0         0  
4365 0 0       0 if ($entrusted->{$actorHash->hex}) {
4366 0         0 $o->{actor}->doNotEntrust($actorHash);
4367 0         0 $o->{ui}->pGreen('Removed ', $actorHash->hex, ' from the list of entrusted actors.');
4368             } else {
4369 0         0 $o->{ui}->pOrange($actorHash->hex, ' is not entrusted.');
4370             }
4371             }
4372              
4373             # Save
4374 0         0 $o->{actor}->saveOrShowError;
4375             }
4376              
4377             sub createEntrustedActorsIndex {
4378 0     0   0 my $o = shift;
4379              
4380 0         0 my $builder = CDS::ActorGroupBuilder->new;
4381 0         0 $builder->parseEntrustedActorList($o->{actor}->entrustedActorsSelector->record, 1);
4382              
4383 0         0 my $index = {};
4384 0         0 for my $actor ($builder->entrustedActors) {
4385 0         0 my $url = $actor->storeUrl.'/accounts/'.$actor->hash->hex;
4386 0         0 $index->{$actor->hash->hex} = 1;
4387 0         0 $index->{$url} = 1;
4388             }
4389              
4390 0         0 return $index;
4391             }
4392              
4393             package CDS::Commands::FolderStore;
4394              
4395             # BEGIN AUTOGENERATED
4396              
4397             sub register {
4398 0     0   0 my $class = shift;
4399 0         0 my $cds = shift;
4400 0         0 my $help = shift;
4401              
4402 0         0 my $node000 = CDS::Parser::Node->new(0);
4403 0         0 my $node001 = CDS::Parser::Node->new(0);
4404 0         0 my $node002 = CDS::Parser::Node->new(0);
4405 0         0 my $node003 = CDS::Parser::Node->new(0);
4406 0         0 my $node004 = CDS::Parser::Node->new(0);
4407 0         0 my $node005 = CDS::Parser::Node->new(0);
4408 0         0 my $node006 = CDS::Parser::Node->new(0);
4409 0         0 my $node007 = CDS::Parser::Node->new(0);
4410 0         0 my $node008 = CDS::Parser::Node->new(0);
4411 0         0 my $node009 = CDS::Parser::Node->new(0);
4412 0         0 my $node010 = CDS::Parser::Node->new(0);
4413 0         0 my $node011 = CDS::Parser::Node->new(0);
4414 0         0 my $node012 = CDS::Parser::Node->new(0);
4415 0         0 my $node013 = CDS::Parser::Node->new(0);
4416 0         0 my $node014 = CDS::Parser::Node->new(0);
4417 0         0 my $node015 = CDS::Parser::Node->new(0);
4418 0         0 my $node016 = CDS::Parser::Node->new(0);
4419 0         0 my $node017 = CDS::Parser::Node->new(0);
4420 0         0 my $node018 = CDS::Parser::Node->new(0);
4421 0         0 my $node019 = CDS::Parser::Node->new(0);
4422 0         0 my $node020 = CDS::Parser::Node->new(0);
4423 0         0 my $node021 = CDS::Parser::Node->new(0);
4424 0         0 my $node022 = CDS::Parser::Node->new(0);
4425 0         0 my $node023 = CDS::Parser::Node->new(0);
4426 0         0 my $node024 = CDS::Parser::Node->new(0);
4427 0         0 my $node025 = CDS::Parser::Node->new(1);
4428 0         0 my $node026 = CDS::Parser::Node->new(0);
4429 0         0 my $node027 = CDS::Parser::Node->new(0);
4430 0         0 my $node028 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
4431 0         0 my $node029 = CDS::Parser::Node->new(1);
4432 0         0 my $node030 = CDS::Parser::Node->new(0);
4433 0         0 my $node031 = CDS::Parser::Node->new(0);
4434 0         0 my $node032 = CDS::Parser::Node->new(0);
4435 0         0 my $node033 = CDS::Parser::Node->new(0);
4436 0         0 my $node034 = CDS::Parser::Node->new(0);
4437 0         0 my $node035 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&checkPermissions});
4438 0         0 my $node036 = CDS::Parser::Node->new(0);
4439 0         0 my $node037 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&fixPermissions});
4440 0         0 my $node038 = CDS::Parser::Node->new(0);
4441 0         0 my $node039 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showPermissions});
4442 0         0 my $node040 = CDS::Parser::Node->new(0);
4443 0         0 my $node041 = CDS::Parser::Node->new(1);
4444 0         0 my $node042 = CDS::Parser::Node->new(0);
4445 0         0 my $node043 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&addAccount});
4446 0         0 my $node044 = CDS::Parser::Node->new(0);
4447 0         0 my $node045 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&removeAccount});
4448 0         0 my $node046 = CDS::Parser::Node->new(0);
4449 0         0 my $node047 = CDS::Parser::Node->new(1);
4450 0         0 my $node048 = CDS::Parser::Node->new(0);
4451 0         0 my $node049 = CDS::Parser::Node->new(0);
4452 0         0 my $node050 = CDS::Parser::Node->new(0);
4453 0         0 my $node051 = CDS::Parser::Node->new(0);
4454 0         0 my $node052 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&checkPermissions});
4455 0         0 my $node053 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&fixPermissions});
4456 0         0 my $node054 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showPermissions});
4457 0         0 my $node055 = CDS::Parser::Node->new(1);
4458 0         0 my $node056 = CDS::Parser::Node->new(0);
4459 0         0 my $node057 = CDS::Parser::Node->new(0);
4460 0         0 my $node058 = CDS::Parser::Node->new(0);
4461 0         0 my $node059 = CDS::Parser::Node->new(0);
4462 0         0 my $node060 = CDS::Parser::Node->new(0);
4463 0         0 my $node061 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&addAccount});
4464 0         0 my $node062 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&removeAccount});
4465 0         0 my $node063 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&setPermissions});
4466 0         0 my $node064 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&createStore});
4467 0         0 $cds->addArrow($node001, 1, 0, 'create');
4468 0         0 $cds->addArrow($node003, 1, 0, 'check');
4469 0         0 $cds->addArrow($node004, 1, 0, 'fix');
4470 0         0 $cds->addArrow($node005, 1, 0, 'show');
4471 0         0 $cds->addArrow($node007, 1, 0, 'set');
4472 0         0 $cds->addArrow($node009, 1, 0, 'add');
4473 0         0 $cds->addArrow($node010, 1, 0, 'add');
4474 0         0 $cds->addArrow($node011, 1, 0, 'add');
4475 0         0 $cds->addArrow($node012, 1, 0, 'add');
4476 0         0 $cds->addArrow($node013, 1, 0, 'add');
4477 0         0 $cds->addArrow($node023, 1, 0, 'remove');
4478 0         0 $help->addArrow($node000, 1, 0, 'create');
4479 0         0 $node000->addArrow($node028, 1, 0, 'store');
4480 0         0 $node001->addArrow($node002, 1, 0, 'store');
4481 0         0 $node002->addArrow($node029, 1, 0, 'FOLDERNAME', \&collectFoldername);
4482 0         0 $node003->addArrow($node035, 1, 0, 'permissions');
4483 0         0 $node004->addArrow($node037, 1, 0, 'permissions');
4484 0         0 $node005->addArrow($node006, 1, 0, 'permission');
4485 0         0 $node006->addArrow($node039, 1, 0, 'scheme');
4486 0         0 $node007->addArrow($node008, 1, 0, 'permission');
4487 0         0 $node008->addArrow($node041, 1, 0, 'scheme');
4488 0         0 $node009->addArrow($node014, 1, 0, 'account');
4489 0         0 $node010->addArrow($node015, 1, 0, 'account');
4490 0         0 $node011->addArrow($node016, 1, 0, 'account');
4491 0         0 $node012->addArrow($node017, 1, 0, 'account');
4492 0         0 $node013->addArrow($node018, 1, 0, 'account');
4493 0         0 $node014->addArrow($node019, 1, 0, 'for');
4494 0         0 $node015->addArrow($node020, 1, 0, 'for');
4495 0         0 $node016->addArrow($node021, 1, 0, 'for');
4496 0         0 $node017->addArrow($node043, 1, 1, 'ACCOUNT', \&collectAccount);
4497 0         0 $node018->addArrow($node022, 1, 0, 'for');
4498 0         0 $node019->addArrow($node043, 1, 0, 'OBJECTFILE', \&collectObjectfile);
4499 0         0 $node020->addArrow($node043, 1, 0, 'KEYPAIR', \&collectKeypair);
4500 0         0 $node021->addArrow($node025, 1, 0, 'ACTOR', \&collectActor);
4501 0         0 $node022->addArrow($node043, 1, 0, 'OBJECT', \&collectObject);
4502 0         0 $node023->addArrow($node024, 1, 0, 'account');
4503 0         0 $node024->addArrow($node045, 1, 0, 'HASH', \&collectHash);
4504 0         0 $node025->addArrow($node026, 1, 0, 'on');
4505 0         0 $node025->addArrow($node027, 0, 0, 'from');
4506 0         0 $node026->addArrow($node043, 1, 0, 'STORE', \&collectStore);
4507 0         0 $node027->addArrow($node043, 0, 0, 'STORE', \&collectStore);
4508 0         0 $node029->addArrow($node030, 1, 0, 'for');
4509 0         0 $node029->addArrow($node031, 1, 0, 'for');
4510 0         0 $node029->addArrow($node032, 1, 0, 'for');
4511 0         0 $node029->addDefault($node047);
4512 0         0 $node030->addArrow($node033, 1, 0, 'user');
4513 0         0 $node031->addArrow($node034, 1, 0, 'group');
4514 0         0 $node032->addArrow($node047, 1, 0, 'everybody', \&collectEverybody);
4515 0         0 $node033->addArrow($node047, 1, 0, 'USER', \&collectUser);
4516 0         0 $node034->addArrow($node047, 1, 0, 'GROUP', \&collectGroup);
4517 0         0 $node035->addArrow($node036, 1, 0, 'of');
4518 0         0 $node036->addArrow($node052, 1, 0, 'STORE', \&collectStore1);
4519 0         0 $node037->addArrow($node038, 1, 0, 'of');
4520 0         0 $node038->addArrow($node053, 1, 0, 'STORE', \&collectStore1);
4521 0         0 $node039->addArrow($node040, 1, 0, 'of');
4522 0         0 $node040->addArrow($node054, 1, 0, 'STORE', \&collectStore1);
4523 0         0 $node041->addArrow($node042, 1, 0, 'of');
4524 0         0 $node041->addDefault($node055);
4525 0         0 $node042->addArrow($node055, 1, 0, 'STORE', \&collectStore1);
4526 0         0 $node043->addArrow($node044, 1, 0, 'to');
4527 0         0 $node044->addArrow($node061, 1, 0, 'STORE', \&collectStore1);
4528 0         0 $node045->addArrow($node046, 1, 0, 'from');
4529 0         0 $node046->addArrow($node062, 1, 0, 'STORE', \&collectStore1);
4530 0         0 $node047->addArrow($node048, 1, 0, 'and');
4531 0         0 $node047->addDefault($node064);
4532 0         0 $node048->addArrow($node049, 1, 0, 'remember');
4533 0         0 $node049->addArrow($node050, 1, 0, 'it');
4534 0         0 $node050->addArrow($node051, 1, 0, 'as');
4535 0         0 $node051->addArrow($node064, 1, 0, 'TEXT', \&collectText);
4536 0         0 $node055->addArrow($node056, 1, 0, 'to');
4537 0         0 $node055->addArrow($node057, 1, 0, 'to');
4538 0         0 $node055->addArrow($node058, 1, 0, 'to');
4539 0         0 $node056->addArrow($node059, 1, 0, 'user');
4540 0         0 $node057->addArrow($node060, 1, 0, 'group');
4541 0         0 $node058->addArrow($node063, 1, 0, 'everybody', \&collectEverybody);
4542 0         0 $node059->addArrow($node063, 1, 0, 'USER', \&collectUser);
4543 0         0 $node060->addArrow($node063, 1, 0, 'GROUP', \&collectGroup);
4544             }
4545              
4546             sub collectAccount {
4547 0     0   0 my $o = shift;
4548 0         0 my $label = shift;
4549 0         0 my $value = shift;
4550              
4551 0         0 $o->{accountToken} = $value;
4552             }
4553              
4554             sub collectActor {
4555 0     0   0 my $o = shift;
4556 0         0 my $label = shift;
4557 0         0 my $value = shift;
4558              
4559 0         0 $o->{actorHash} = $value;
4560             }
4561              
4562             sub collectEverybody {
4563 0     0   0 my $o = shift;
4564 0         0 my $label = shift;
4565 0         0 my $value = shift;
4566              
4567 0         0 $o->{permissions} = CDS::FolderStore::PosixPermissions::World->new;
4568             }
4569              
4570             sub collectFoldername {
4571 0     0   0 my $o = shift;
4572 0         0 my $label = shift;
4573 0         0 my $value = shift;
4574              
4575 0         0 $o->{foldername} = $value;
4576             }
4577              
4578             sub collectGroup {
4579 0     0   0 my $o = shift;
4580 0         0 my $label = shift;
4581 0         0 my $value = shift;
4582              
4583 0         0 $o->{permissions} = CDS::FolderStore::PosixPermissions::Group->new($o->{group});
4584             }
4585              
4586             sub collectHash {
4587 0     0   0 my $o = shift;
4588 0         0 my $label = shift;
4589 0         0 my $value = shift;
4590              
4591 0         0 $o->{hash} = $value;
4592             }
4593              
4594             sub collectKeypair {
4595 0     0   0 my $o = shift;
4596 0         0 my $label = shift;
4597 0         0 my $value = shift;
4598              
4599 0         0 $o->{keyPairToken} = $value;
4600             }
4601              
4602             sub collectObject {
4603 0     0   0 my $o = shift;
4604 0         0 my $label = shift;
4605 0         0 my $value = shift;
4606              
4607 0         0 $o->{accountToken} = CDS::AccountToken->new($value->cliStore, $value->hash);
4608             }
4609              
4610             sub collectObjectfile {
4611 0     0   0 my $o = shift;
4612 0         0 my $label = shift;
4613 0         0 my $value = shift;
4614              
4615 0         0 $o->{file} = $value;
4616             }
4617              
4618             sub collectStore {
4619 0     0   0 my $o = shift;
4620 0         0 my $label = shift;
4621 0         0 my $value = shift;
4622              
4623 0         0 $o->{accountToken} = CDS::AccountToken->new($value, $o->{actorHash});
4624             }
4625              
4626             sub collectStore1 {
4627 0     0   0 my $o = shift;
4628 0         0 my $label = shift;
4629 0         0 my $value = shift;
4630              
4631 0         0 $o->{store} = $value;
4632             }
4633              
4634             sub collectText {
4635 0     0   0 my $o = shift;
4636 0         0 my $label = shift;
4637 0         0 my $value = shift;
4638              
4639 0         0 $o->{label} = $value;
4640             }
4641              
4642             sub collectUser {
4643 0     0   0 my $o = shift;
4644 0         0 my $label = shift;
4645 0         0 my $value = shift;
4646              
4647 0         0 $o->{permissions} = CDS::FolderStore::PosixPermissions::User->new($value);
4648             }
4649              
4650             sub new {
4651 0     0   0 my $class = shift;
4652 0         0 my $actor = shift;
4653 0         0 bless {actor => $actor, ui => $actor->ui} }
4654              
4655             # END AUTOGENERATED
4656              
4657             # HTML FOLDER NAME folder-store
4658             # HTML TITLE Folder store management
4659             sub help {
4660 0     0   0 my $o = shift;
4661 0         0 my $cmd = shift;
4662              
4663 0         0 my $ui = $o->{ui};
4664 0         0 $ui->space;
4665 0         0 $ui->command('cds create store FOLDERNAME');
4666 0         0 $ui->p('Creates a new store in FOLDERNAME, and adds it to the list of known stores. If the folder does not exist, it is created. If it does exist, it must be empty.');
4667 0         0 $ui->space;
4668 0         0 $ui->p('By default, the filesystem permissions of the store are set such that only the current user can post objects and modify boxes. Other users on the system can post to the message box, list boxes, and read objects.');
4669 0         0 $ui->space;
4670 0         0 $ui->command('… for user USER');
4671 0         0 $ui->p('Makes the store accessible to the user USER.');
4672 0         0 $ui->space;
4673 0         0 $ui->command('… for group GROUP');
4674 0         0 $ui->p('Makes the store accessible to the group GROUP.');
4675 0         0 $ui->space;
4676 0         0 $ui->command('… for everybody');
4677 0         0 $ui->p('Makes the store accessible to everybody.');
4678 0         0 $ui->space;
4679 0         0 $ui->p('Note that the permissions only affect direct filesystem access. If your store is exposed by a server (e.g. a web server), it may be accessible to others.');
4680 0         0 $ui->space;
4681 0         0 $ui->command('… and remember it as TEXT');
4682 0         0 $ui->p('Remembers the store under the label TEXT. See "cds help remember" for details.');
4683 0         0 $ui->space;
4684 0         0 $ui->command('cds check permissions [of STORE]');
4685 0         0 $ui->p('Checks the permissions (owner, mode) of all accounts, boxes, box entries, and objects of the store, and reports any error. The permission scheme (user, group, or everybody) is derived from the "accounts" and "objects" folders.');
4686 0         0 $ui->p('If the store is omitted, the selected store is used.');
4687 0         0 $ui->space;
4688 0         0 $ui->command('cds fix permissions [of STORE]');
4689 0         0 $ui->p('Same as above, but tries to fix the permissions (chown, chmod) instead of just reporting them.');
4690 0         0 $ui->space;
4691 0         0 $ui->command('cds show permission scheme [of STORE]');
4692 0         0 $ui->p('Reports the permission scheme of the store.');
4693 0         0 $ui->space;
4694 0         0 $ui->command('cds set permission scheme [of STORE] to (user USER|group GROUP|everybody)');
4695 0         0 $ui->p('Sets the permission scheme of the stores, and changes all permissions accordingly.');
4696 0         0 $ui->space;
4697 0         0 $ui->command('cds add account ACCOUNT [to STORE]');
4698 0         0 $ui->command('cds add account for FILE [to STORE]');
4699 0         0 $ui->command('cds add account for KEYPAIR [to STORE]');
4700 0         0 $ui->command('cds add account for OBJECT [to STORE]');
4701 0         0 $ui->command('cds add account for ACTOR on STORE [to STORE]');
4702 0         0 $ui->p('Uploads the public key (FILE, KEYPAIR, OBJECT, ACCOUNT, or ACTOR on STORE) onto the store, and adds the corresponding account. This grants the user the right to access this account.');
4703 0         0 $ui->space;
4704 0         0 $ui->command('cds remove account HASH [from STORE]');
4705 0         0 $ui->p('Removes the indicated account from the store. This immediately destroys the user\'s data.');
4706 0         0 $ui->space;
4707             }
4708              
4709             sub createStore {
4710 0     0   0 my $o = shift;
4711 0         0 my $cmd = shift;
4712              
4713 0         0 $o->{permissions} = CDS::FolderStore::PosixPermissions::User->new;
4714 0         0 $cmd->collect($o);
4715              
4716             # Give up if the folder is non-empty (but we accept hidden files)
4717 0         0 for my $file (CDS->listFolder($o->{foldername})) {
4718 0 0       0 next if $file =~ /^\./;
4719 0         0 $o->{ui}->pRed('The folder ', $o->{foldername}, ' is not empty. Giving up …');
4720 0         0 return;
4721             }
4722              
4723             # Create the object store
4724 0   0     0 $o->create($o->{foldername}.'/objects') // return;
4725 0         0 $o->{ui}->pGreen('Object store created for ', $o->{permissions}->target, '.');
4726              
4727             # Create the account store
4728 0   0     0 $o->create($o->{foldername}.'/accounts') // return;
4729 0         0 $o->{ui}->pGreen('Account store created for ', $o->{permissions}->target, '.');
4730              
4731             # Return if the user does not want us to add the store
4732 0 0       0 return if ! defined $o->{label};
4733              
4734             # Remember the store
4735 0         0 my $record = CDS::Record->new;
4736 0         0 $record->addText('store')->addText('file://'.$o->{foldername});
4737 0         0 $o->{actor}->remember($o->{label}, $record);
4738 0         0 $o->{actor}->saveOrShowError;
4739             }
4740              
4741             # Creates a folder with the selected permissions.
4742             sub create {
4743 0     0   0 my $o = shift;
4744 0         0 my $folder = shift;
4745              
4746             # Create the folders to here if necessary
4747 0         0 for my $intermediateFolder (CDS->intermediateFolders($folder)) {
4748 0         0 mkdir $intermediateFolder, 0755;
4749             }
4750              
4751             # mkdir (if it does not exist yet) and chmod (if it does exist already)
4752 0         0 mkdir $folder, $o->{permissions}->baseFolderMode;
4753 0         0 chmod $o->{permissions}->baseFolderMode, $folder;
4754 0   0     0 chown $o->{permissions}->uid // -1, $o->{permissions}->gid // -1, $folder;
      0        
4755              
4756             # Check if the result is correct
4757 0         0 my @s = stat $folder;
4758 0 0       0 return $o->{ui}->error('Unable to create ', $o->{foldername}, '.') if ! scalar @s;
4759 0         0 my $mode = $s[2];
4760 0 0       0 return $o->{ui}->error($folder, ' exists, but is not a folder') if ! Fcntl::S_ISDIR($mode);
4761 0 0 0     0 return $o->{ui}->error('Unable to set the owning user ', $o->{permissions}->user, ' for ', $folder, '.') if defined $o->{permissions}->uid && $s[4] != $o->{permissions}->uid;
4762 0 0 0     0 return $o->{ui}->error('Unable to set the owning group ', $o->{permissions}->group, ' for ', $folder, '.') if defined $o->{permissions}->gid && $s[5] != $o->{permissions}->gid;
4763 0 0       0 return $o->{ui}->error('Unable to set the mode on ', $folder, '.') if ($mode & 0777) != $o->{permissions}->baseFolderMode;
4764 0         0 return 1;
4765             }
4766              
4767             sub existingFolderStoreOrShowError {
4768 0     0   0 my $o = shift;
4769              
4770 0   0     0 my $store = $o->{store} // $o->{actor}->preferredStore;
4771              
4772 0         0 my $folderStore = CDS::FolderStore->forUrl($store->url);
4773 0 0       0 if (! $folderStore) {
4774 0         0 $o->{ui}->error('"', $store->url, '" is not a folder store.');
4775 0         0 $o->{ui}->space;
4776 0         0 $o->{ui}->p('Account management and file system permission checks only apply to stores on the local file system. Such stores are referred to by file://… URLs, or file system paths.');
4777 0         0 $o->{ui}->p('To fix the permissions on a remote store, log onto that server and fix the permissions there. Note that permissions are not part of the Condensation protocol, but a property of some underlying storage systems, such as file systems.');
4778 0         0 $o->{ui}->space;
4779 0         0 return;
4780             }
4781              
4782 0 0       0 if (! $folderStore->exists) {
4783 0         0 $o->{ui}->error('"', $folderStore->folder, '" does not exist.');
4784 0         0 $o->{ui}->space;
4785 0         0 $o->{ui}->p('The folder either does not exist, or is not a folder store. You can create this store using:');
4786 0         0 $o->{ui}->line($o->{ui}->gold(' cds create store ', $folderStore->folder));
4787 0         0 $o->{ui}->space;
4788 0         0 return;
4789             }
4790              
4791 0         0 return $folderStore;
4792             }
4793              
4794             sub showPermissions {
4795 0     0   0 my $o = shift;
4796 0         0 my $cmd = shift;
4797              
4798 0         0 $cmd->collect($o);
4799 0   0     0 my $folderStore = $o->existingFolderStoreOrShowError // return;
4800 0         0 $o->showStore($folderStore);
4801 0         0 $o->{ui}->space;
4802             }
4803              
4804             sub showStore {
4805 0     0   0 my $o = shift;
4806 0         0 my $folderStore = shift;
4807              
4808 0         0 $o->{ui}->space;
4809 0         0 $o->{ui}->title('Store');
4810 0         0 $o->{ui}->line($folderStore->folder);
4811 0         0 $o->{ui}->line('Accessible to ', $folderStore->permissions->target, '.');
4812             }
4813              
4814             sub setPermissions {
4815 0     0   0 my $o = shift;
4816 0         0 my $cmd = shift;
4817              
4818 0         0 $cmd->collect($o);
4819              
4820 0   0     0 my $folderStore = $o->existingFolderStoreOrShowError // return;
4821 0         0 $o->showStore($folderStore);
4822              
4823 0         0 $folderStore->setPermissions($o->{permissions});
4824 0         0 $o->{ui}->line('Changing permissions …');
4825 0         0 my $logger = CDS::Commands::FolderStore::SetLogger->new($o, $folderStore->folder);
4826 0 0       0 $folderStore->checkPermissions($logger) || $o->traversalFailed($folderStore);
4827 0         0 $logger->summary;
4828              
4829 0         0 $o->{ui}->space;
4830             }
4831              
4832             sub checkPermissions {
4833 0     0   0 my $o = shift;
4834 0         0 my $cmd = shift;
4835              
4836 0         0 $cmd->collect($o);
4837              
4838 0   0     0 my $folderStore = $o->existingFolderStoreOrShowError // return;
4839 0         0 $o->showStore($folderStore);
4840              
4841 0         0 $o->{ui}->line('Checking permissions …');
4842 0         0 my $logger = CDS::Commands::FolderStore::CheckLogger->new($o, $folderStore->folder);
4843 0 0       0 $folderStore->checkPermissions($logger) || $o->traversalFailed($folderStore);
4844 0         0 $logger->summary;
4845              
4846 0         0 $o->{ui}->space;
4847             }
4848              
4849             sub fixPermissions {
4850 0     0   0 my $o = shift;
4851 0         0 my $cmd = shift;
4852              
4853 0         0 $cmd->collect($o);
4854              
4855 0   0     0 my $folderStore = $o->existingFolderStoreOrShowError // return;
4856 0         0 $o->showStore($folderStore);
4857              
4858 0         0 $o->{ui}->line('Fixing permissions …');
4859 0         0 my $logger = CDS::Commands::FolderStore::FixLogger->new($o, $folderStore->folder);
4860 0 0       0 $folderStore->checkPermissions($logger) || $o->traversalFailed($folderStore);
4861 0         0 $logger->summary;
4862              
4863 0         0 $o->{ui}->space;
4864             }
4865              
4866             sub traversalFailed {
4867 0     0   0 my $o = shift;
4868 0         0 my $folderStore = shift;
4869              
4870 0         0 $o->{ui}->space;
4871 0         0 $o->{ui}->p('Traversal failed because a file or folder could not be accessed. You may have to fix the permissions manually, or run this command with other privileges.');
4872 0         0 $o->{ui}->p('If you have root privileges, you can take over this store using:');
4873 0         0 my $userName = getpwuid($<);
4874 0         0 my $groupName = getgrgid($();
4875 0         0 $o->{ui}->line($o->{ui}->gold(' sudo chown -R ', $userName, ':', $groupName, ' ', $folderStore->folder));
4876 0         0 $o->{ui}->p('and then set the desired permission scheme:');
4877 0         0 $o->{ui}->line($o->{ui}->gold(' cds set permissions of ', $folderStore->folder, ' to …'));
4878 0         0 $o->{ui}->space;
4879 0         0 exit(1);
4880             }
4881              
4882             sub addAccount {
4883 0     0   0 my $o = shift;
4884 0         0 my $cmd = shift;
4885              
4886 0         0 $cmd->collect($o);
4887              
4888             # Prepare
4889 0   0     0 my $folderStore = $o->existingFolderStoreOrShowError // return;
4890 0   0     0 my $publicKey = $o->publicKey // return;
4891              
4892             # Upload the public key onto the store
4893 0         0 my $error = $folderStore->put($publicKey->hash, $publicKey->object);
4894 0 0       0 return $o->{ui}->error('Unable to upload the public key: ', $error) if $error;
4895              
4896             # Create the account folder
4897 0         0 my $folder = $folderStore->folder.'/accounts/'.$publicKey->hash->hex;
4898 0         0 my $permissions = $folderStore->permissions;
4899 0         0 $permissions->mkdir($folder, $permissions->accountFolderMode);
4900 0 0       0 return $o->{ui}->error('Unable to create folder "', $folder, '".') if ! -d $folder;
4901 0         0 $o->{ui}->pGreen('Account ', $publicKey->hash->hex, ' added.');
4902 0         0 return 1;
4903             }
4904              
4905             sub publicKey {
4906 0     0   0 my $o = shift;
4907              
4908 0 0       0 return $o->{keyPairToken}->keyPair->publicKey if $o->{keyPairToken};
4909              
4910 0 0       0 if ($o->{file}) {
4911 0   0     0 my $bytes = CDS->readBytesFromFile($o->{file}) // return $o->{ui}->error('Cannot read "', $o->{file}, '".');
4912 0   0     0 my $object = CDS::Object->fromBytes($bytes) // return $o->{ui}->error('"', $o->{file}, '" is not a public key.');
4913 0   0     0 return CDS::PublicKey->fromObject($object) // return $o->{ui}->error('"', $o->{file}, '" is not a public key.');
4914             }
4915              
4916 0         0 return $o->{actor}->uiGetPublicKey($o->{accountToken}->actorHash, $o->{accountToken}->cliStore, $o->{actor}->preferredKeyPairToken);
4917             }
4918              
4919             sub removeAccount {
4920 0     0   0 my $o = shift;
4921 0         0 my $cmd = shift;
4922              
4923 0         0 $cmd->collect($o);
4924              
4925             # Prepare the folder
4926 0   0     0 my $folderStore = $o->existingFolderStoreOrShowError // return;
4927 0         0 my $folder = $folderStore->folder.'/accounts/'.$o->{hash}->hex;
4928 0         0 my $deletedFolder = $folderStore->folder.'/accounts/deleted-'.$o->{hash}->hex;
4929              
4930             # Rename, so that it is not visible any more
4931 0 0       0 $o->recursivelyDelete($deletedFolder) if -e $deletedFolder;
4932 0 0       0 return $o->{ui}->line('The account ', $o->{hash}->hex, ' does not exist.') if ! -e $folder;
4933 0 0       0 rename($folder, $deletedFolder) || return $o->{ui}->error('Unable to rename the folder "', $folder, '".');
4934              
4935             # Try to delete it entirely
4936 0         0 $o->recursivelyDelete($deletedFolder);
4937 0         0 $o->{ui}->pGreen('Account ', $o->{hash}->hex, ' removed.');
4938 0         0 return 1;
4939             }
4940              
4941             sub recursivelyDelete {
4942 0     0   0 my $o = shift;
4943 0         0 my $folder = shift;
4944              
4945 0         0 for my $filename (CDS->listFolder($folder)) {
4946 0 0       0 next if $filename =~ /^\./;
4947 0         0 my $file = $folder.'/'.$filename;
4948 0 0       0 if (-f $file) {
    0          
4949 0   0     0 unlink $file || $o->{ui}->pOrange('Unable to remove the file "', $file, '".');
4950             } elsif (-d $file) {
4951 0         0 $o->recursivelyDelete($file);
4952             }
4953             }
4954              
4955 0 0       0 rmdir($folder) || $o->{ui}->pOrange('Unable to remove the folder "', $folder, '".');
4956             }
4957              
4958             package CDS::Commands::FolderStore::CheckLogger;
4959              
4960 1     1   21880 use parent -norequire, 'CDS::Commands::FolderStore::Logger';
  1         2  
  1         7  
4961              
4962             sub finalizeWrong {
4963 0     0   0 my $o = shift;
4964              
4965 0         0 $o->{ui}->pRed(@_);
4966 0         0 return 0;
4967             }
4968              
4969             sub summary {
4970 0     0   0 my $o = shift;
4971              
4972 0         0 $o->{ui}->p(($o->{correct} + $o->{wrong}).' files and folders traversed.');
4973 0 0       0 if ($o->{wrong} > 0) {
4974 0         0 $o->{ui}->p($o->{wrong}, ' files and folders have wrong permissions. To fix them, run');
4975 0         0 $o->{ui}->line($o->{ui}->gold(' cds fix permissions of ', $o->{store}->url));
4976             } else {
4977 0         0 $o->{ui}->pGreen('All permissions are OK.');
4978             }
4979             }
4980              
4981             package CDS::Commands::FolderStore::FixLogger;
4982              
4983 1     1   193 use parent -norequire, 'CDS::Commands::FolderStore::Logger';
  1         2  
  1         10  
4984              
4985             sub finalizeWrong {
4986 0     0   0 my $o = shift;
4987              
4988 0         0 $o->{ui}->line(@_);
4989 0         0 return 1;
4990             }
4991              
4992             sub summary {
4993 0     0   0 my $o = shift;
4994              
4995 0         0 $o->{ui}->p(($o->{correct} + $o->{wrong}).' files and folders traversed.');
4996 0 0       0 $o->{ui}->p('The permissions of ', $o->{wrong}, ' files and folders have been fixed.') if $o->{wrong} > 0;
4997 0         0 $o->{ui}->pGreen('All permissions are OK.');
4998             }
4999              
5000             package CDS::Commands::FolderStore::Logger;
5001              
5002             sub new {
5003 0     0   0 my $class = shift;
5004 0         0 my $parent = shift;
5005 0         0 my $baseFolder = shift;
5006              
5007             return bless {
5008             ui => $parent->{ui},
5009             store => $parent->{store},
5010 0         0 baseFolder => $baseFolder,
5011             correct => 0,
5012             wrong => 0,
5013             }, $class;
5014             }
5015              
5016             sub correct {
5017 0     0   0 my $o = shift;
5018              
5019 0         0 $o->{correct} += 1;
5020             }
5021              
5022             sub wrong {
5023 0     0   0 my $o = shift;
5024 0         0 my $item = shift;
5025 0         0 my $uid = shift;
5026 0         0 my $gid = shift;
5027 0         0 my $mode = shift;
5028 0         0 my $expectedUid = shift;
5029 0         0 my $expectedGid = shift;
5030 0         0 my $expectedMode = shift;
5031              
5032 0         0 my $len = length $o->{baseFolder};
5033 0         0 $o->{wrong} += 1;
5034 0 0 0     0 $item = '…'.substr($item, $len) if length $item > $len && substr($item, 0, $len) eq $o->{baseFolder};
5035 0         0 my @changes;
5036 0 0 0     0 push @changes, 'user '.&username($uid).' -> '.&username($expectedUid) if defined $expectedUid && $uid != $expectedUid;
5037 0 0 0     0 push @changes, 'group '.&groupname($gid).' -> '.&groupname($expectedGid) if defined $expectedGid && $gid != $expectedGid;
5038 0 0       0 push @changes, 'mode '.sprintf('%04o -> %04o', $mode, $expectedMode) if $mode != $expectedMode;
5039 0         0 return $o->finalizeWrong(join(', ', @changes), "\t", $item);
5040             }
5041              
5042             sub username {
5043 0     0   0 my $uid = shift;
5044              
5045 0   0     0 return getpwuid($uid) // $uid;
5046             }
5047              
5048             sub groupname {
5049 0     0   0 my $gid = shift;
5050              
5051 0   0     0 return getgrgid($gid) // $gid;
5052             }
5053              
5054             sub accessError {
5055 0     0   0 my $o = shift;
5056 0         0 my $item = shift;
5057              
5058 0         0 $o->{ui}->error('Error accessing ', $item, '.');
5059 0         0 return 0;
5060             }
5061              
5062             sub setError {
5063 0     0   0 my $o = shift;
5064 0         0 my $item = shift;
5065              
5066 0         0 $o->{ui}->error('Error setting permissions of ', $item, '.');
5067 0         0 return 0;
5068             }
5069              
5070             package CDS::Commands::FolderStore::SetLogger;
5071              
5072 1     1   474 use parent -norequire, 'CDS::Commands::FolderStore::Logger';
  1         8  
  1         4  
5073              
5074             sub finalizeWrong {
5075 0     0   0 my $o = shift;
5076              
5077 0         0 return 1;
5078             }
5079              
5080             sub summary {
5081 0     0   0 my $o = shift;
5082              
5083 0         0 $o->{ui}->p(($o->{correct} + $o->{wrong}).' files and folders traversed.');
5084 0 0       0 $o->{ui}->p('The permissions of ', $o->{wrong}, ' files and folders have been adjusted.') if $o->{wrong} > 0;
5085 0         0 $o->{ui}->pGreen('All permissions are OK.');
5086             }
5087              
5088             # BEGIN AUTOGENERATED
5089             package CDS::Commands::Get;
5090              
5091             sub register {
5092 0     0   0 my $class = shift;
5093 0         0 my $cds = shift;
5094 0         0 my $help = shift;
5095              
5096 0         0 my $node000 = CDS::Parser::Node->new(0);
5097 0         0 my $node001 = CDS::Parser::Node->new(0);
5098 0         0 my $node002 = CDS::Parser::Node->new(0);
5099 0         0 my $node003 = CDS::Parser::Node->new(0);
5100 0         0 my $node004 = CDS::Parser::Node->new(0);
5101 0         0 my $node005 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
5102 0         0 my $node006 = CDS::Parser::Node->new(0);
5103 0         0 my $node007 = CDS::Parser::Node->new(0);
5104 0         0 my $node008 = CDS::Parser::Node->new(0);
5105 0         0 my $node009 = CDS::Parser::Node->new(0);
5106 0         0 my $node010 = CDS::Parser::Node->new(1);
5107 0         0 my $node011 = CDS::Parser::Node->new(0);
5108 0         0 my $node012 = CDS::Parser::Node->new(0);
5109 0         0 my $node013 = CDS::Parser::Node->new(0);
5110 0         0 my $node014 = CDS::Parser::Node->new(0);
5111 0         0 my $node015 = CDS::Parser::Node->new(0);
5112 0         0 my $node016 = CDS::Parser::Node->new(1);
5113 0         0 my $node017 = CDS::Parser::Node->new(0);
5114 0         0 my $node018 = CDS::Parser::Node->new(0);
5115 0         0 my $node019 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&get});
5116 0         0 my $node020 = CDS::Parser::Node->new(1);
5117 0         0 my $node021 = CDS::Parser::Node->new(0);
5118 0         0 my $node022 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&get});
5119 0         0 $cds->addArrow($node000, 1, 0, 'get');
5120 0         0 $cds->addArrow($node001, 1, 0, 'save');
5121 0         0 $cds->addArrow($node002, 1, 0, 'get');
5122 0         0 $cds->addArrow($node003, 1, 0, 'get');
5123 0         0 $cds->addArrow($node009, 1, 0, 'save', \&collectSave);
5124 0         0 $help->addArrow($node005, 1, 0, 'get');
5125 0         0 $help->addArrow($node005, 1, 0, 'save');
5126 0         0 $node000->addArrow($node010, 1, 0, 'HASH', \&collectHash);
5127 0         0 $node001->addArrow($node004, 1, 0, 'data');
5128 0         0 $node002->addArrow($node006, 1, 0, 'HASH', \&collectHash1);
5129 0         0 $node003->addArrow($node010, 1, 0, 'OBJECT', \&collectObject);
5130 0         0 $node004->addArrow($node009, 1, 0, 'of', \&collectOf);
5131 0         0 $node006->addArrow($node007, 1, 0, 'on');
5132 0         0 $node006->addArrow($node008, 0, 0, 'from');
5133 0         0 $node007->addArrow($node010, 1, 0, 'STORE', \&collectStore);
5134 0         0 $node008->addArrow($node010, 0, 0, 'STORE', \&collectStore);
5135 0         0 $node009->addArrow($node013, 1, 0, 'HASH', \&collectHash1);
5136 0         0 $node009->addArrow($node016, 1, 0, 'HASH', \&collectHash);
5137 0         0 $node009->addArrow($node016, 1, 0, 'OBJECT', \&collectObject1);
5138 0         0 $node010->addArrow($node011, 1, 0, 'decrypted');
5139 0         0 $node010->addDefault($node019);
5140 0         0 $node011->addArrow($node012, 1, 0, 'with');
5141 0         0 $node012->addArrow($node019, 1, 0, 'AESKEY', \&collectAeskey);
5142 0         0 $node013->addArrow($node014, 1, 0, 'on');
5143 0         0 $node013->addArrow($node015, 0, 0, 'from');
5144 0         0 $node014->addArrow($node016, 1, 0, 'STORE', \&collectStore);
5145 0         0 $node015->addArrow($node016, 0, 0, 'STORE', \&collectStore);
5146 0         0 $node016->addArrow($node017, 1, 0, 'decrypted');
5147 0         0 $node016->addDefault($node020);
5148 0         0 $node017->addArrow($node018, 1, 0, 'with');
5149 0         0 $node018->addArrow($node020, 1, 0, 'AESKEY', \&collectAeskey);
5150 0         0 $node020->addArrow($node021, 1, 0, 'as');
5151 0         0 $node021->addArrow($node022, 1, 0, 'FILENAME', \&collectFilename);
5152             }
5153              
5154             sub collectAeskey {
5155 0     0   0 my $o = shift;
5156 0         0 my $label = shift;
5157 0         0 my $value = shift;
5158              
5159 0         0 $o->{aesKey} = $value;
5160             }
5161              
5162             sub collectFilename {
5163 0     0   0 my $o = shift;
5164 0         0 my $label = shift;
5165 0         0 my $value = shift;
5166              
5167 0         0 $o->{filename} = $value;
5168             }
5169              
5170             sub collectHash {
5171 0     0   0 my $o = shift;
5172 0         0 my $label = shift;
5173 0         0 my $value = shift;
5174              
5175 0         0 $o->{hash} = $value;
5176 0         0 $o->{store} = $o->{actor}->preferredStore;
5177             }
5178              
5179             sub collectHash1 {
5180 0     0   0 my $o = shift;
5181 0         0 my $label = shift;
5182 0         0 my $value = shift;
5183              
5184 0         0 $o->{hash} = $value;
5185             }
5186              
5187             sub collectObject {
5188 0     0   0 my $o = shift;
5189 0         0 my $label = shift;
5190 0         0 my $value = shift;
5191              
5192 0         0 $o->{hash} = $value->hash;
5193 0         0 $o->{store} = $value->cliStore;
5194             }
5195              
5196             sub collectObject1 {
5197 0     0   0 my $o = shift;
5198 0         0 my $label = shift;
5199 0         0 my $value = shift;
5200              
5201 0         0 $o->{hash} = $value->hash;
5202 0         0 push @{$o->{stores}}, $value->store;
  0         0  
5203             }
5204              
5205             sub collectOf {
5206 0     0   0 my $o = shift;
5207 0         0 my $label = shift;
5208 0         0 my $value = shift;
5209              
5210 0         0 $o->{saveData} = 1;
5211             }
5212              
5213             sub collectSave {
5214 0     0   0 my $o = shift;
5215 0         0 my $label = shift;
5216 0         0 my $value = shift;
5217              
5218 0         0 $o->{saveObject} = 1;
5219             }
5220              
5221             sub collectStore {
5222 0     0   0 my $o = shift;
5223 0         0 my $label = shift;
5224 0         0 my $value = shift;
5225              
5226 0         0 $o->{store} = $value;
5227             }
5228              
5229             sub new {
5230 0     0   0 my $class = shift;
5231 0         0 my $actor = shift;
5232 0         0 bless {actor => $actor, ui => $actor->ui} }
5233              
5234             # END AUTOGENERATED
5235              
5236             # HTML FOLDER NAME store-get
5237             # HTML TITLE Get
5238             sub help {
5239 0     0   0 my $o = shift;
5240 0         0 my $cmd = shift;
5241              
5242 0         0 my $ui = $o->{ui};
5243 0         0 $ui->space;
5244 0         0 $ui->command('cds get OBJECT');
5245 0         0 $ui->command('cds get HASH on STORE');
5246 0         0 $ui->p('Downloads an object and writes it to STDOUT. If the object is not found, the program quits with exit code 1.');
5247 0         0 $ui->space;
5248 0         0 $ui->command('cds get HASH');
5249 0         0 $ui->p('As above, but uses the selected store.');
5250 0         0 $ui->space;
5251 0         0 $ui->command('… decrypted with AESKEY');
5252 0         0 $ui->p('Decrypts the object after retrieval.');
5253 0         0 $ui->space;
5254 0         0 $ui->command('cds save … as FILENAME');
5255 0         0 $ui->p('Saves the object to FILENAME instead of writing it to STDOUT.');
5256 0         0 $ui->space;
5257 0         0 $ui->command('cds save data of … as FILENAME');
5258 0         0 $ui->p('Saves the object\'s data to FILENAME.');
5259 0         0 $ui->space;
5260 0         0 $ui->title('Related commands');
5261 0         0 $ui->line('cds open envelope OBJECT');
5262 0         0 $ui->line('cds show record OBJECT [decrypted with AESKEY]');
5263 0         0 $ui->line('cds show hashes of OBJECT');
5264 0         0 $ui->space;
5265             }
5266              
5267             sub get {
5268 0     0   0 my $o = shift;
5269 0         0 my $cmd = shift;
5270              
5271 0         0 $cmd->collect($o);
5272              
5273             # Retrieve the object
5274 0   0     0 my $object = $o->{actor}->uiGetObject($o->{hash}, $o->{store}, $o->{actor}->preferredKeyPairToken) // return;
5275              
5276             # Decrypt
5277 0 0       0 $object = $object->crypt($o->{aesKey}) if defined $o->{aesKey};
5278              
5279             # Output
5280 0 0       0 if ($o->{saveData}) {
    0          
5281 0   0     0 CDS->writeBytesToFile($o->{filename}, $object->data) // return $o->{ui}->error('Failed to write data to "', $o->{filename}, '".');
5282 0         0 $o->{ui}->pGreen(length $object->data, ' bytes written to ', $o->{filename}, '.');
5283             } elsif ($o->{saveObject}) {
5284 0   0     0 CDS->writeBytesToFile($o->{filename}, $object->bytes) // return $o->{ui}->error('Failed to write object to "', $o->{filename}, '".');
5285 0         0 $o->{ui}->pGreen(length $object->bytes, ' bytes written to ', $o->{filename}, '.');
5286             } else {
5287 0         0 $o->{ui}->raw($object->bytes);
5288             }
5289             }
5290              
5291             # BEGIN AUTOGENERATED
5292             package CDS::Commands::Help;
5293              
5294             sub register {
5295 0     0   0 my $class = shift;
5296 0         0 my $cds = shift;
5297 0         0 my $help = shift;
5298              
5299 0         0 my $node000 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
5300 0         0 my $node001 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&version});
5301 0         0 $cds->addArrow($node000, 0, 0, '--h');
5302 0         0 $cds->addArrow($node000, 0, 0, '--help');
5303 0         0 $cds->addArrow($node000, 0, 0, '-?');
5304 0         0 $cds->addArrow($node000, 0, 0, '-h');
5305 0         0 $cds->addArrow($node000, 0, 0, '-help');
5306 0         0 $cds->addArrow($node000, 0, 0, '/?');
5307 0         0 $cds->addArrow($node000, 0, 0, '/h');
5308 0         0 $cds->addArrow($node000, 0, 0, '/help');
5309 0         0 $cds->addArrow($node001, 0, 0, '--version');
5310 0         0 $cds->addArrow($node001, 0, 0, '-version');
5311 0         0 $cds->addArrow($node001, 1, 0, 'version');
5312             }
5313              
5314             sub new {
5315 0     0   0 my $class = shift;
5316 0         0 my $actor = shift;
5317 0         0 bless {actor => $actor, ui => $actor->ui} }
5318              
5319             # END AUTOGENERATED
5320              
5321             # HTML IGNORE
5322             sub help {
5323 0     0   0 my $o = shift;
5324 0         0 my $cmd = shift;
5325              
5326 0         0 my $ui = $o->{ui};
5327 0         0 $ui->space;
5328 0         0 $ui->title('Condensation CLI');
5329 0         0 $ui->line('Version ', $CDS::VERSION, ', ', $CDS::releaseDate, ', implementing the Condensation 1 protocol');
5330 0         0 $ui->space;
5331 0         0 $ui->p('Condensation is a distributed data system with conflict-free forward merging and end-to-end security. More information is available on ', $ui->a('https://condensation.io'), '.');
5332 0         0 $ui->space;
5333 0         0 $ui->p('The command line interface (CLI) understands english-like queries like these:');
5334 0         0 $ui->pushIndent;
5335 0         0 $ui->line($ui->blue('cds show key pair'));
5336 0         0 $ui->line($ui->blue('cds create key pair thomas'));
5337 0         0 $ui->line($ui->blue('cds get 45db86549d6d2af3a45be834f2cb0e08cdbbd7699624e7bfd947a3505e6b03e5 \\'));
5338 0         0 $ui->line($ui->blue(' and decrypt with 8b8b091bbe577d5e8d38eae9cd327aa8123fe402a41ea9dd16d86f42fb70cf7e'));
5339 0         0 $ui->popIndent;
5340 0         0 $ui->space;
5341 0         0 $ui->p('If you don\'t know how to continue a command, simply put a ? to see all valid options:');
5342 0         0 $ui->pushIndent;
5343 0         0 $ui->line($ui->blue('cds ?'));
5344 0         0 $ui->line($ui->blue('cds show ?'));
5345 0         0 $ui->popIndent;
5346 0         0 $ui->space;
5347 0         0 $ui->p('To see a list of help topics, type');
5348 0         0 $ui->pushIndent;
5349 0         0 $ui->line($ui->blue('cds help ?'));
5350 0         0 $ui->popIndent;
5351 0         0 $ui->space;
5352             }
5353              
5354             sub version {
5355 0     0   0 my $o = shift;
5356 0         0 my $cmd = shift;
5357              
5358 0         0 my $ui = $o->{ui};
5359 0         0 $ui->line('Condensation CLI ', $CDS::VERSION, ', ', $CDS::releaseDate);
5360 0         0 $ui->line('implementing the Condensation 1 protocol');
5361             }
5362              
5363             # BEGIN AUTOGENERATED
5364             package CDS::Commands::List;
5365              
5366             sub register {
5367 0     0   0 my $class = shift;
5368 0         0 my $cds = shift;
5369 0         0 my $help = shift;
5370              
5371 0         0 my $node000 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
5372 0         0 my $node001 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&list});
5373 0         0 my $node002 = CDS::Parser::Node->new(0);
5374 0         0 my $node003 = CDS::Parser::Node->new(0);
5375 0         0 my $node004 = CDS::Parser::Node->new(0);
5376 0         0 my $node005 = CDS::Parser::Node->new(0);
5377 0         0 my $node006 = CDS::Parser::Node->new(0);
5378 0         0 my $node007 = CDS::Parser::Node->new(0);
5379 0         0 my $node008 = CDS::Parser::Node->new(0);
5380 0         0 my $node009 = CDS::Parser::Node->new(0);
5381 0         0 my $node010 = CDS::Parser::Node->new(0);
5382 0         0 my $node011 = CDS::Parser::Node->new(0);
5383 0         0 my $node012 = CDS::Parser::Node->new(0);
5384 0         0 my $node013 = CDS::Parser::Node->new(0);
5385 0         0 my $node014 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&listBoxes});
5386 0         0 my $node015 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&list});
5387 0         0 $cds->addArrow($node001, 1, 0, 'list');
5388 0         0 $cds->addArrow($node001, 1, 0, 'watch', \&collectWatch);
5389 0         0 $help->addArrow($node000, 1, 0, 'list');
5390 0         0 $node001->addDefault($node002);
5391 0         0 $node001->addArrow($node003, 1, 0, 'message');
5392 0         0 $node001->addArrow($node004, 1, 0, 'private');
5393 0         0 $node001->addArrow($node005, 1, 0, 'public');
5394 0         0 $node001->addArrow($node006, 0, 0, 'messages', \&collectMessages);
5395 0         0 $node001->addArrow($node006, 0, 0, 'private', \&collectPrivate);
5396 0         0 $node001->addArrow($node006, 0, 0, 'public', \&collectPublic);
5397 0         0 $node001->addArrow($node007, 1, 0, 'my', \&collectMy);
5398 0         0 $node001->addDefault($node011);
5399 0         0 $node002->addArrow($node002, 1, 0, 'BOX', \&collectBox);
5400 0         0 $node002->addArrow($node014, 1, 0, 'BOX', \&collectBox);
5401 0         0 $node003->addArrow($node006, 1, 0, 'box', \&collectMessages);
5402 0         0 $node004->addArrow($node006, 1, 0, 'box', \&collectPrivate);
5403 0         0 $node005->addArrow($node006, 1, 0, 'box', \&collectPublic);
5404 0         0 $node006->addArrow($node011, 1, 0, 'of');
5405 0         0 $node006->addDefault($node012);
5406 0         0 $node007->addArrow($node008, 1, 0, 'message');
5407 0         0 $node007->addArrow($node009, 1, 0, 'private');
5408 0         0 $node007->addArrow($node010, 1, 0, 'public');
5409 0         0 $node007->addArrow($node015, 1, 0, 'boxes');
5410 0         0 $node007->addArrow($node015, 0, 0, 'messages', \&collectMessages);
5411 0         0 $node007->addArrow($node015, 0, 0, 'private', \&collectPrivate);
5412 0         0 $node007->addArrow($node015, 0, 0, 'public', \&collectPublic);
5413 0         0 $node008->addArrow($node015, 1, 0, 'box', \&collectMessages);
5414 0         0 $node009->addArrow($node015, 1, 0, 'box', \&collectPrivate);
5415 0         0 $node010->addArrow($node015, 1, 0, 'box', \&collectPublic);
5416 0         0 $node011->addArrow($node012, 1, 0, 'ACTOR', \&collectActor);
5417 0         0 $node011->addArrow($node012, 1, 0, 'KEYPAIR', \&collectKeypair);
5418 0         0 $node011->addArrow($node015, 1, 1, 'ACCOUNT', \&collectAccount);
5419 0         0 $node011->addArrow($node015, 1, 0, 'ACTORGROUP', \&collectActorgroup);
5420 0         0 $node012->addArrow($node013, 1, 0, 'on');
5421 0         0 $node012->addDefault($node015);
5422 0         0 $node013->addArrow($node015, 1, 0, 'STORE', \&collectStore);
5423             }
5424              
5425             sub collectAccount {
5426 0     0   0 my $o = shift;
5427 0         0 my $label = shift;
5428 0         0 my $value = shift;
5429              
5430 0         0 $o->{actorHash} = $value->actorHash;
5431 0         0 $o->{store} = $value->cliStore;
5432             }
5433              
5434             sub collectActor {
5435 0     0   0 my $o = shift;
5436 0         0 my $label = shift;
5437 0         0 my $value = shift;
5438              
5439 0         0 $o->{actorHash} = $value;
5440             }
5441              
5442             sub collectActorgroup {
5443 0     0   0 my $o = shift;
5444 0         0 my $label = shift;
5445 0         0 my $value = shift;
5446              
5447 0         0 $o->{actorGroup} = $value;
5448             }
5449              
5450             sub collectBox {
5451 0     0   0 my $o = shift;
5452 0         0 my $label = shift;
5453 0         0 my $value = shift;
5454              
5455 0         0 push @{$o->{boxTokens}}, $value;
  0         0  
5456             }
5457              
5458             sub collectKeypair {
5459 0     0   0 my $o = shift;
5460 0         0 my $label = shift;
5461 0         0 my $value = shift;
5462              
5463 0         0 $o->{actorHash} = $value->keyPair->publicKey->hash;
5464 0         0 $o->{keyPairToken} = $value;
5465             }
5466              
5467             sub collectMessages {
5468 0     0   0 my $o = shift;
5469 0         0 my $label = shift;
5470 0         0 my $value = shift;
5471              
5472 0         0 $o->{boxLabels} = ['messages'];
5473             }
5474              
5475             sub collectMy {
5476 0     0   0 my $o = shift;
5477 0         0 my $label = shift;
5478 0         0 my $value = shift;
5479              
5480 0         0 $o->{my} = 1;
5481             }
5482              
5483             sub collectPrivate {
5484 0     0   0 my $o = shift;
5485 0         0 my $label = shift;
5486 0         0 my $value = shift;
5487              
5488 0         0 $o->{boxLabels} = ['private'];
5489             }
5490              
5491             sub collectPublic {
5492 0     0   0 my $o = shift;
5493 0         0 my $label = shift;
5494 0         0 my $value = shift;
5495              
5496 0         0 $o->{boxLabels} = ['public'];
5497             }
5498              
5499             sub collectStore {
5500 0     0   0 my $o = shift;
5501 0         0 my $label = shift;
5502 0         0 my $value = shift;
5503              
5504 0         0 $o->{store} = $value;
5505             }
5506              
5507             sub collectWatch {
5508 0     0   0 my $o = shift;
5509 0         0 my $label = shift;
5510 0         0 my $value = shift;
5511              
5512 0         0 $o->{watchTimeout} = 60000;
5513             }
5514              
5515             sub new {
5516 0     0   0 my $class = shift;
5517 0         0 my $actor = shift;
5518 0         0 bless {actor => $actor, ui => $actor->ui} }
5519              
5520             # END AUTOGENERATED
5521              
5522             # HTML FOLDER NAME store-list
5523             # HTML TITLE List
5524             sub help {
5525 0     0   0 my $o = shift;
5526 0         0 my $cmd = shift;
5527              
5528 0         0 my $ui = $o->{ui};
5529 0         0 $ui->space;
5530 0         0 $ui->command('cds list BOX');
5531 0         0 $ui->p('Lists the indicated box. The object references are shown as "cds open envelope …" command, which can be executed to display the corresponding envelope. Change the command to "cds get …" to download the raw object, or "cds show record …" to show it as record.');
5532 0         0 $ui->space;
5533 0         0 $ui->command('cds list');
5534 0         0 $ui->p('Lists all boxes of the selected key pair.');
5535 0         0 $ui->space;
5536 0         0 $ui->command('cds list BOXLABEL');
5537 0         0 $ui->p('Lists only the indicated box of the selected key pair. BOXLABEL may be:');
5538 0         0 $ui->line(' message box');
5539 0         0 $ui->line(' public box');
5540 0         0 $ui->line(' private box');
5541 0         0 $ui->space;
5542 0         0 $ui->command('cds list my boxes');
5543 0         0 $ui->command('cds list my BOXLABEL');
5544 0         0 $ui->p('Lists your own boxes.');
5545 0         0 $ui->space;
5546 0         0 $ui->command('cds list [BOXLABEL of] ACTORGROUP|ACCOUNT');
5547 0         0 $ui->p('Lists boxes of an actor group, or account.');
5548 0         0 $ui->space;
5549 0         0 $ui->command('cds list [BOXLABEL of] KEYPAIR|ACTOR [on STORE]');
5550 0         0 $ui->p('Lists boxes of an actor on the specified or selected store.');
5551 0         0 $ui->space;
5552             }
5553              
5554             sub listBoxes {
5555 0     0   0 my $o = shift;
5556 0         0 my $cmd = shift;
5557              
5558 0         0 $o->{boxTokens} = [];
5559 0         0 $o->{boxLabels} = ['messages', 'private', 'public'];
5560 0         0 $cmd->collect($o);
5561              
5562             # Use the selected key pair to sign requests
5563 0 0       0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken if ! $o->{keyPairToken};
5564              
5565 0         0 for my $boxToken (@{$o->{boxTokens}}) {
  0         0  
5566 0         0 $o->listBox($boxToken);
5567             }
5568              
5569 0         0 $o->{ui}->space;
5570             }
5571              
5572             sub list {
5573 0     0   0 my $o = shift;
5574 0         0 my $cmd = shift;
5575              
5576 0         0 $o->{boxLabels} = ['messages', 'private', 'public'];
5577 0         0 $cmd->collect($o);
5578              
5579             # Actor hashes
5580 0         0 my @actorHashes;
5581             my @stores;
5582 0 0       0 if ($o->{my}) {
    0          
    0          
5583 0         0 $o->{keyPairToken} = $o->{actor}->keyPairToken;
5584 0         0 push @actorHashes, $o->{keyPairToken}->keyPair->publicKey->hash;
5585 0         0 push @stores, $o->{actor}->storageStore, $o->{actor}->messagingStore;
5586             } elsif ($o->{actorHash}) {
5587 0         0 push @actorHashes, $o->{actorHash};
5588             } elsif ($o->{actorGroup}) {
5589             # TODO
5590             } else {
5591 0         0 push @actorHashes, $o->{actor}->preferredActorHash;
5592             }
5593              
5594             # Stores
5595 0 0       0 push @stores, $o->{store} if $o->{store};
5596 0 0       0 push @stores, $o->{actor}->preferredStore if ! scalar @stores;
5597              
5598             # Use the selected key pair to sign requests
5599 0         0 my $preferredKeyPairToken = $o->{actor}->preferredKeyPairToken;
5600 0 0       0 $o->{keyPairToken} = $preferredKeyPairToken if ! $o->{keyPairToken};
5601 0 0       0 $o->{keyPairContext} = $preferredKeyPairToken->keyPair->equals($o->{keyPairToken}->keyPair) ? '' : $o->{ui}->gray(' using ', $o->{actor}->keyPairReference($o->{keyPairToken}));
5602              
5603             # List boxes
5604 0         0 for my $store (@stores) {
5605 0         0 for my $actorHash (@actorHashes) {
5606 0         0 for my $boxLabel (@{$o->{boxLabels}}) {
  0         0  
5607 0         0 $o->listBox(CDS::BoxToken->new(CDS::AccountToken->new($store, $actorHash), $boxLabel));
5608             }
5609             }
5610             }
5611              
5612 0         0 $o->{ui}->space;
5613             }
5614              
5615             sub listBox {
5616 0     0   0 my $o = shift;
5617 0         0 my $boxToken = shift;
5618              
5619 0         0 $o->{ui}->space;
5620 0         0 $o->{ui}->title($o->{actor}->blueBoxReference($boxToken));
5621              
5622             # Query the store
5623 0         0 my $store = $boxToken->accountToken->cliStore;
5624 0   0     0 my ($hashes, $storeError) = $store->list($boxToken->accountToken->actorHash, $boxToken->boxLabel, $o->{watchTimeout} // 0, $o->{keyPairToken}->keyPair);
5625 0 0       0 return if defined $storeError;
5626              
5627             # Print the result
5628 0         0 my $count = scalar @$hashes;
5629 0 0       0 return if ! $count;
5630              
5631 0 0       0 my $context = $boxToken->boxLabel eq 'messages' ? $o->{ui}->gray(' on ', $o->{actor}->storeReference($store)) : $o->{ui}->gray(' from ', $o->{actor}->accountReference($boxToken->accountToken));
5632 0 0 0     0 my $keyPairContext = $boxToken->boxLabel eq 'public' ? '' : $o->{keyPairContext} // '';
5633 0         0 foreach my $hash (sort { $a->bytes cmp $b->bytes } @$hashes) {
  0         0  
5634 0         0 $o->{ui}->line($o->{ui}->gold('cds open envelope ', $hash->hex), $context, $keyPairContext);
5635             }
5636 0 0       0 $o->{ui}->line($count.' entries') if $count > 5;
5637             }
5638              
5639             # BEGIN AUTOGENERATED
5640             package CDS::Commands::Modify;
5641              
5642             sub register {
5643 0     0   0 my $class = shift;
5644 0         0 my $cds = shift;
5645 0         0 my $help = shift;
5646              
5647 0         0 my $node000 = CDS::Parser::Node->new(0);
5648 0         0 my $node001 = CDS::Parser::Node->new(0);
5649 0         0 my $node002 = CDS::Parser::Node->new(0);
5650 0         0 my $node003 = CDS::Parser::Node->new(0);
5651 0         0 my $node004 = CDS::Parser::Node->new(0);
5652 0         0 my $node005 = CDS::Parser::Node->new(0);
5653 0         0 my $node006 = CDS::Parser::Node->new(0);
5654 0         0 my $node007 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
5655 0         0 my $node008 = CDS::Parser::Node->new(1);
5656 0         0 my $node009 = CDS::Parser::Node->new(0);
5657 0         0 my $node010 = CDS::Parser::Node->new(0);
5658 0         0 my $node011 = CDS::Parser::Node->new(0);
5659 0         0 my $node012 = CDS::Parser::Node->new(0);
5660 0         0 my $node013 = CDS::Parser::Node->new(0);
5661 0         0 my $node014 = CDS::Parser::Node->new(0);
5662 0         0 my $node015 = CDS::Parser::Node->new(0);
5663 0         0 my $node016 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&modify});
5664 0         0 $cds->addDefault($node000);
5665 0         0 $help->addArrow($node007, 1, 0, 'add');
5666 0         0 $help->addArrow($node007, 1, 0, 'purge');
5667 0         0 $help->addArrow($node007, 1, 0, 'remove');
5668 0         0 $node000->addArrow($node001, 1, 0, 'add');
5669 0         0 $node000->addArrow($node002, 1, 0, 'remove');
5670 0         0 $node000->addArrow($node003, 1, 0, 'add');
5671 0         0 $node000->addArrow($node008, 1, 0, 'purge', \&collectPurge);
5672 0         0 $node001->addArrow($node001, 1, 0, 'HASH', \&collectHash);
5673 0         0 $node001->addArrow($node004, 1, 0, 'HASH', \&collectHash);
5674 0         0 $node002->addArrow($node002, 1, 0, 'HASH', \&collectHash1);
5675 0         0 $node002->addArrow($node005, 1, 0, 'HASH', \&collectHash1);
5676 0         0 $node003->addArrow($node003, 1, 0, 'FILE', \&collectFile);
5677 0         0 $node003->addArrow($node006, 1, 0, 'FILE', \&collectFile);
5678 0         0 $node004->addArrow($node008, 1, 0, 'to');
5679 0         0 $node005->addArrow($node008, 1, 0, 'from');
5680 0         0 $node006->addArrow($node008, 1, 0, 'to');
5681 0         0 $node008->addArrow($node000, 1, 0, 'and');
5682 0         0 $node008->addArrow($node009, 1, 0, 'message');
5683 0         0 $node008->addArrow($node010, 1, 0, 'private');
5684 0         0 $node008->addArrow($node011, 1, 0, 'public');
5685 0         0 $node008->addArrow($node012, 0, 0, 'messages', \&collectMessages);
5686 0         0 $node008->addArrow($node012, 0, 0, 'private', \&collectPrivate);
5687 0         0 $node008->addArrow($node012, 0, 0, 'public', \&collectPublic);
5688 0         0 $node008->addArrow($node016, 1, 0, 'BOX', \&collectBox);
5689 0         0 $node009->addArrow($node012, 1, 0, 'box', \&collectMessages);
5690 0         0 $node010->addArrow($node012, 1, 0, 'box', \&collectPrivate);
5691 0         0 $node011->addArrow($node012, 1, 0, 'box', \&collectPublic);
5692 0         0 $node012->addArrow($node013, 1, 0, 'of');
5693 0         0 $node013->addArrow($node014, 1, 0, 'ACTOR', \&collectActor);
5694 0         0 $node013->addArrow($node014, 1, 0, 'KEYPAIR', \&collectKeypair);
5695 0         0 $node013->addArrow($node016, 1, 1, 'ACCOUNT', \&collectAccount);
5696 0         0 $node014->addArrow($node015, 1, 0, 'on');
5697 0         0 $node014->addDefault($node016);
5698 0         0 $node015->addArrow($node016, 1, 0, 'STORE', \&collectStore);
5699             }
5700              
5701             sub collectAccount {
5702 0     0   0 my $o = shift;
5703 0         0 my $label = shift;
5704 0         0 my $value = shift;
5705              
5706 0         0 $o->{boxToken} = CDS::BoxToken->new($value, $o->{boxLabel});
5707 0         0 delete $o->{boxLabel};
5708             }
5709              
5710             sub collectActor {
5711 0     0   0 my $o = shift;
5712 0         0 my $label = shift;
5713 0         0 my $value = shift;
5714              
5715 0         0 $o->{actorHash} = $value;
5716             }
5717              
5718             sub collectBox {
5719 0     0   0 my $o = shift;
5720 0         0 my $label = shift;
5721 0         0 my $value = shift;
5722              
5723 0         0 $o->{boxToken} = $value;
5724             }
5725              
5726             sub collectFile {
5727 0     0   0 my $o = shift;
5728 0         0 my $label = shift;
5729 0         0 my $value = shift;
5730              
5731 0         0 push @{$o->{fileAdditions}}, $value;
  0         0  
5732             }
5733              
5734             sub collectHash {
5735 0     0   0 my $o = shift;
5736 0         0 my $label = shift;
5737 0         0 my $value = shift;
5738              
5739 0         0 push @{$o->{additions}}, $value;
  0         0  
5740             }
5741              
5742             sub collectHash1 {
5743 0     0   0 my $o = shift;
5744 0         0 my $label = shift;
5745 0         0 my $value = shift;
5746              
5747 0         0 push @{$o->{removals}}, $value;
  0         0  
5748             }
5749              
5750             sub collectKeypair {
5751 0     0   0 my $o = shift;
5752 0         0 my $label = shift;
5753 0         0 my $value = shift;
5754              
5755 0         0 $o->{actorHash} = $value->publicKey->hash;
5756 0         0 $o->{keyPairToken} = $value;
5757             }
5758              
5759             sub collectMessages {
5760 0     0   0 my $o = shift;
5761 0         0 my $label = shift;
5762 0         0 my $value = shift;
5763              
5764 0         0 $o->{boxLabel} = 'messages';
5765             }
5766              
5767             sub collectPrivate {
5768 0     0   0 my $o = shift;
5769 0         0 my $label = shift;
5770 0         0 my $value = shift;
5771              
5772 0         0 $o->{boxLabel} = 'private';
5773             }
5774              
5775             sub collectPublic {
5776 0     0   0 my $o = shift;
5777 0         0 my $label = shift;
5778 0         0 my $value = shift;
5779              
5780 0         0 $o->{boxLabel} = 'public';
5781             }
5782              
5783             sub collectPurge {
5784 0     0   0 my $o = shift;
5785 0         0 my $label = shift;
5786 0         0 my $value = shift;
5787              
5788 0         0 $o->{purge} = 1;
5789             }
5790              
5791             sub collectStore {
5792 0     0   0 my $o = shift;
5793 0         0 my $label = shift;
5794 0         0 my $value = shift;
5795              
5796 0         0 $o->{boxToken} = CDS::BoxToken->new(CDS::AccountToken->new($value, $o->{actorHash}), $o->{boxLabel});
5797 0         0 delete $o->{boxLabel};
5798 0         0 delete $o->{actorHash};
5799             }
5800              
5801             sub new {
5802 0     0   0 my $class = shift;
5803 0         0 my $actor = shift;
5804 0         0 bless {actor => $actor, ui => $actor->ui} }
5805              
5806             # END AUTOGENERATED
5807              
5808             # HTML FOLDER NAME store-modify
5809             # HTML TITLE Modify
5810             sub help {
5811 0     0   0 my $o = shift;
5812 0         0 my $cmd = shift;
5813              
5814 0         0 my $ui = $o->{ui};
5815 0         0 $ui->space;
5816 0         0 $ui->command('cds add HASH* to BOX');
5817 0         0 $ui->p('Adds HASH to BOX.');
5818 0         0 $ui->space;
5819 0         0 $ui->command('cds add FILE* to BOX');
5820 0         0 $ui->p('Adds the envelope FILE to BOX.');
5821 0         0 $ui->space;
5822 0         0 $ui->command('cds remove HASH* from BOX');
5823 0         0 $ui->p('Removes HASH from BOX.');
5824 0         0 $ui->p('Note that the store may just mark the hash for removal, and defer its actual removal, or even cancel it. Such removals will still be reported as success.');
5825 0         0 $ui->space;
5826 0         0 $ui->command('cds purge BOX');
5827 0         0 $ui->p('Empties BOX, i.e., removes all its hashes.');
5828 0         0 $ui->space;
5829 0         0 $ui->command('… BOXLABEL of ACCOUNT');
5830 0         0 $ui->p('Modifies a box of an actor group, or account.');
5831 0         0 $ui->space;
5832 0         0 $ui->command('… BOXLABEL of KEYPAIR on STORE');
5833 0         0 $ui->command('… BOXLABEL of ACTOR on STORE');
5834 0         0 $ui->p('Modifies a box of a key pair or an actor on a specific store.');
5835 0         0 $ui->space;
5836             }
5837              
5838             sub modify {
5839 0     0   0 my $o = shift;
5840 0         0 my $cmd = shift;
5841              
5842 0         0 $o->{additions} = [];
5843 0         0 $o->{removals} = [];
5844 0         0 $cmd->collect($o);
5845              
5846             # Add a box using the selected store
5847 0 0 0     0 if ($o->{actorHash} && $o->{boxLabel}) {
5848 0         0 $o->{boxToken} = CDS::BoxToken->new(CDS::AccountToken->new($o->{actor}->preferredStore, $o->{actorHash}), $o->{boxLabel});
5849 0         0 delete $o->{actorHash};
5850 0         0 delete $o->{boxLabel};
5851             }
5852              
5853 0         0 my $store = $o->{boxToken}->accountToken->cliStore;
5854              
5855             # Prepare additions
5856 0         0 my $modifications = CDS::StoreModifications->new;
5857 0         0 for my $hash (@{$o->{additions}}) {
  0         0  
5858 0         0 $modifications->add($o->{boxToken}->accountToken->actorHash, $o->{boxToken}->boxLabel, $hash);
5859             }
5860              
5861 0         0 for my $file (@{$o->{fileAdditions}}) {
  0         0  
5862 0   0     0 my $bytes = CDS->readBytesFromFile($file) // return $o->{ui}->error('Unable to read "', $file, '".');
5863 0   0     0 my $object = CDS::Object->fromBytes($bytes) // return $o->{ui}->error('"', $file, '" is not a Condensation object.');
5864 0         0 my $hash = $object->calculateHash;
5865 0 0       0 $o->{ui}->warning('"', $file, '" is not a valid envelope. The server may reject it.') if ! $o->{actor}->isEnvelope($object);
5866 0         0 $modifications->add($o->{boxToken}->accountToken->actorHash, $o->{boxToken}->boxLabel, $hash, $object);
5867             }
5868              
5869             # Prepare removals
5870 0         0 my $boxRemovals = [];
5871 0         0 for my $hash (@{$o->{removals}}) {
  0         0  
5872 0         0 $modifications->remove($o->{boxToken}->accountToken->actorHash, $o->{boxToken}->boxLabel, $hash);
5873             }
5874              
5875             # If purging is requested, list the box
5876 0 0       0 if ($o->{purge}) {
5877 0         0 my ($hashes, $error) = $store->list($o->{boxToken}->accountToken->actorHash, $o->{boxToken}->boxLabel, 0);
5878 0 0       0 return if defined $error;
5879 0 0       0 $o->{ui}->warning('The box is empty.') if ! scalar @$hashes;
5880              
5881 0         0 for my $hash (@$hashes) {
5882 0         0 $modifications->remove($o->{boxToken}->accountToken->actorHash, $o->{boxToken}->boxLabel, $hash);
5883             }
5884             }
5885              
5886             # Cancel if there is nothing to do
5887 0 0       0 return if $modifications->isEmpty;
5888              
5889             # Modify the box
5890 0   0     0 my $keyPairToken = $o->{keyPairToken} // $o->{actor}->preferredKeyPairToken;
5891 0         0 my $error = $store->modify($modifications, $keyPairToken->keyPair);
5892 0 0       0 $o->{ui}->pGreen('Box modified.') if ! defined $error;
5893              
5894             # Print undo information
5895 0 0 0     0 if ($o->{purge} && scalar @$boxRemovals) {
5896 0         0 $o->{ui}->space;
5897 0         0 $o->{ui}->line($o->{ui}->gray('To undo purging, type:'));
5898 0         0 $o->{ui}->line($o->{ui}->gray(' cds add ', join(" \\\n ", map { $_->{hash}->hex } @$boxRemovals), " \\\n to ", $o->{actor}->boxReference($o->{boxToken})));
  0         0  
5899 0         0 $o->{ui}->space;
5900             }
5901             }
5902              
5903             # BEGIN AUTOGENERATED
5904             package CDS::Commands::OpenEnvelope;
5905              
5906             sub register {
5907 0     0   0 my $class = shift;
5908 0         0 my $cds = shift;
5909 0         0 my $help = shift;
5910              
5911 0         0 my $node000 = CDS::Parser::Node->new(0);
5912 0         0 my $node001 = CDS::Parser::Node->new(0);
5913 0         0 my $node002 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
5914 0         0 my $node003 = CDS::Parser::Node->new(1);
5915 0         0 my $node004 = CDS::Parser::Node->new(1);
5916 0         0 my $node005 = CDS::Parser::Node->new(0);
5917 0         0 my $node006 = CDS::Parser::Node->new(0);
5918 0         0 my $node007 = CDS::Parser::Node->new(1);
5919 0         0 my $node008 = CDS::Parser::Node->new(0);
5920 0         0 my $node009 = CDS::Parser::Node->new(0);
5921 0         0 my $node010 = CDS::Parser::Node->new(0);
5922 0         0 my $node011 = CDS::Parser::Node->new(1);
5923 0         0 my $node012 = CDS::Parser::Node->new(0);
5924 0         0 my $node013 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&openEnvelope});
5925 0         0 $cds->addArrow($node001, 1, 0, 'open');
5926 0         0 $help->addArrow($node000, 1, 0, 'open');
5927 0         0 $node000->addArrow($node002, 1, 0, 'envelope');
5928 0         0 $node001->addArrow($node003, 1, 0, 'envelope');
5929 0         0 $node003->addArrow($node004, 1, 0, 'HASH', \&collectHash);
5930 0         0 $node003->addArrow($node007, 1, 0, 'OBJECT', \&collectObject);
5931 0         0 $node004->addArrow($node005, 1, 0, 'from');
5932 0         0 $node004->addArrow($node006, 1, 0, 'from');
5933 0         0 $node004->addDefault($node009);
5934 0         0 $node005->addArrow($node009, 1, 0, 'ACTOR', \&collectActor);
5935 0         0 $node006->addArrow($node011, 1, 1, 'ACCOUNT', \&collectAccount);
5936 0         0 $node007->addArrow($node008, 1, 0, 'from');
5937 0         0 $node007->addDefault($node011);
5938 0         0 $node008->addArrow($node011, 1, 0, 'ACTOR', \&collectActor);
5939 0         0 $node009->addArrow($node010, 1, 0, 'on');
5940 0         0 $node009->addDefault($node011);
5941 0         0 $node010->addArrow($node011, 1, 0, 'STORE', \&collectStore);
5942 0         0 $node011->addArrow($node012, 1, 0, 'using');
5943 0         0 $node011->addDefault($node013);
5944 0         0 $node012->addArrow($node013, 1, 0, 'KEYPAIR', \&collectKeypair);
5945             }
5946              
5947             sub collectAccount {
5948 0     0   0 my $o = shift;
5949 0         0 my $label = shift;
5950 0         0 my $value = shift;
5951              
5952 0         0 $o->{senderHash} = $value->actorHash;
5953 0         0 $o->{store} = $value->cliStore;
5954             }
5955              
5956             sub collectActor {
5957 0     0   0 my $o = shift;
5958 0         0 my $label = shift;
5959 0         0 my $value = shift;
5960              
5961 0         0 $o->{senderHash} = $value;
5962             }
5963              
5964             sub collectHash {
5965 0     0   0 my $o = shift;
5966 0         0 my $label = shift;
5967 0         0 my $value = shift;
5968              
5969 0         0 $o->{hash} = $value;
5970 0         0 $o->{store} = $o->{actor}->preferredStore;
5971             }
5972              
5973             sub collectKeypair {
5974 0     0   0 my $o = shift;
5975 0         0 my $label = shift;
5976 0         0 my $value = shift;
5977              
5978 0         0 $o->{keyPairToken} = $value;
5979             }
5980              
5981             sub collectObject {
5982 0     0   0 my $o = shift;
5983 0         0 my $label = shift;
5984 0         0 my $value = shift;
5985              
5986 0         0 $o->{hash} = $value->hash;
5987 0         0 $o->{store} = $value->cliStore;
5988             }
5989              
5990             sub collectStore {
5991 0     0   0 my $o = shift;
5992 0         0 my $label = shift;
5993 0         0 my $value = shift;
5994              
5995 0         0 $o->{store} = $value;
5996             }
5997              
5998             sub new {
5999 0     0   0 my $class = shift;
6000 0         0 my $actor = shift;
6001 0         0 bless {actor => $actor, ui => $actor->ui} }
6002              
6003             # END AUTOGENERATED
6004              
6005             # HTML FOLDER NAME open-envelope
6006             # HTML TITLE Open envelope
6007             sub help {
6008 0     0   0 my $o = shift;
6009 0         0 my $cmd = shift;
6010              
6011 0         0 my $ui = $o->{ui};
6012 0         0 $ui->space;
6013 0         0 $ui->command('cds open envelope OBJECT');
6014 0         0 $ui->command('cds open envelope HASH on STORE');
6015 0         0 $ui->p('Downloads an envelope, verifies its signatures, and tries to decrypt the AES key using the selected key pair and your own key pair.');
6016 0         0 $ui->p('In addition to displaying the envelope details, this command also displays the necessary "cds show record …" command to retrieve the content.');
6017 0         0 $ui->space;
6018 0         0 $ui->command('cds open envelope HASH');
6019 0         0 $ui->p('As above, but uses the selected store.');
6020 0         0 $ui->space;
6021 0         0 $ui->command('… from ACTOR');
6022 0         0 $ui->p('Assumes that the envelope was signed by ACTOR, and downloads the corresponding public key. The sender store is assumed to be the envelope\'s store. This is useful to verify public and private envelopes.');
6023 0         0 $ui->space;
6024 0         0 $ui->command('… using KEYPAIR');
6025 0         0 $ui->p('Tries to decrypt the AES key using this key pair, instead of the selected key pair.');
6026 0         0 $ui->space;
6027             }
6028              
6029             sub openEnvelope {
6030 0     0   0 my $o = shift;
6031 0         0 my $cmd = shift;
6032              
6033 0         0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken;
6034 0         0 $cmd->collect($o);
6035              
6036             # Get the envelope
6037 0   0     0 my $envelope = $o->{actor}->uiGetRecord($o->{hash}, $o->{store}, $o->{keyPairToken}) // return;
6038              
6039             # Continue by envelope type
6040 0         0 my $contentRecord = $envelope->child('content');
6041 0 0       0 if ($contentRecord->hashValue) {
    0          
6042 0 0       0 if ($envelope->contains('encrypted for')) {
6043 0         0 $o->processPrivateEnvelope($envelope);
6044             } else {
6045 0         0 $o->processPublicEnvelope($envelope);
6046             }
6047             } elsif (length $contentRecord->bytesValue) {
6048 0 0 0     0 if ($envelope->contains('head') && $envelope->contains('mac')) {
6049 0         0 $o->processStreamEnvelope($envelope);
6050             } else {
6051 0         0 $o->processMessageEnvelope($envelope);
6052             }
6053             } else {
6054 0         0 $o->processOther($envelope);
6055             }
6056             }
6057              
6058             sub processOther {
6059 0     0   0 my $o = shift;
6060 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
6061              
6062 0         0 $o->{ui}->space;
6063 0         0 $o->{ui}->pOrange('This is not an envelope. Envelopes always have a "content" section. The raw record is shown below.');
6064 0         0 $o->{ui}->space;
6065 0         0 $o->{ui}->title('Record');
6066 0         0 $o->{ui}->recordChildren($envelope, $o->{actor}->storeReference($o->{store}));
6067 0         0 $o->{ui}->space;
6068             }
6069              
6070             sub processPublicEnvelope {
6071 0     0   0 my $o = shift;
6072 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
6073              
6074 0         0 $o->{ui}->space;
6075 0         0 $o->{ui}->title('Public envelope');
6076 0         0 $o->{ui}->line($o->{ui}->gold('cds show record ', $o->{hash}->hex, ' on ', $o->{actor}->storeReference($o->{store})));
6077              
6078 0         0 my $contentHash = $envelope->child('content')->hashValue;
6079 0         0 $o->showPublicPrivateSignature($envelope, $contentHash);
6080              
6081 0         0 $o->{ui}->space;
6082 0         0 $o->{ui}->title('Content');
6083 0         0 $o->{ui}->line($o->{ui}->gold('cds show record ', $contentHash->hex, ' on ', $o->{actor}->storeReference($o->{store})));
6084              
6085 0         0 $o->{ui}->space;
6086             }
6087              
6088             sub processPrivateEnvelope {
6089 0     0   0 my $o = shift;
6090 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
6091              
6092 0         0 $o->{ui}->space;
6093 0         0 $o->{ui}->title('Private envelope');
6094 0         0 $o->{ui}->line($o->{ui}->gold('cds show record ', $o->{hash}->hex, ' on ', $o->{actor}->storeReference($o->{store})));
6095              
6096 0         0 my $aesKey = $o->decryptAesKey($envelope);
6097 0         0 my $contentHash = $envelope->child('content')->hashValue;
6098 0         0 $o->showPublicPrivateSignature($envelope, $contentHash);
6099 0         0 $o->showEncryptedFor($envelope);
6100              
6101 0         0 $o->{ui}->space;
6102 0 0       0 if ($aesKey) {
6103 0         0 $o->{ui}->title('Content');
6104 0         0 $o->{ui}->line($o->{ui}->gold('cds show record ', $contentHash->hex, ' on ', $o->{actor}->storeReference($o->{store}), ' decrypted with ', unpack('H*', $aesKey)));
6105             } else {
6106 0         0 $o->{ui}->title('Encrypted content');
6107 0         0 $o->{ui}->line($o->{ui}->gold('cds get ', $contentHash->hex, ' on ', $o->{actor}->storeReference($o->{store})));
6108             }
6109              
6110 0         0 $o->{ui}->space;
6111             }
6112              
6113             sub showPublicPrivateSignature {
6114 0     0   0 my $o = shift;
6115 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
6116 0 0 0     0 my $contentHash = shift; die 'wrong type '.ref($contentHash).' for $contentHash' if defined $contentHash && ref $contentHash ne 'CDS::Hash';
  0         0  
6117              
6118 0         0 $o->{ui}->space;
6119 0         0 $o->{ui}->title('Signed by');
6120 0 0       0 if ($o->{senderHash}) {
6121 0         0 my $accountToken = CDS::AccountToken->new($o->{store}, $o->{senderHash});
6122 0         0 $o->{ui}->line($o->{actor}->blueAccountReference($accountToken));
6123 0         0 $o->showSignature($envelope, $o->{senderHash}, $o->{store}, $contentHash);
6124             } else {
6125 0         0 $o->{ui}->p('The signer is not known. To verify the signature of a public or private envelope, you need to indicate the account on which it was found:');
6126 0         0 $o->{ui}->line($o->{ui}->gold(' cds show envelope ', $o->{hash}->hex, ' from ', $o->{ui}->underlined('ACTOR'), ' on ', $o->{actor}->storeReference($o->{store})));
6127             }
6128             }
6129              
6130             sub processMessageEnvelope {
6131 0     0   0 my $o = shift;
6132 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
6133              
6134 0         0 $o->{ui}->space;
6135 0         0 $o->{ui}->title('Message envelope');
6136 0         0 $o->{ui}->line($o->{ui}->gold('cds show record ', $o->{hash}->hex, ' on ', $o->{actor}->storeReference($o->{store})));
6137              
6138             # Decrypt
6139 0         0 my $encryptedContentBytes = $envelope->child('content')->bytesValue;
6140 0         0 my $aesKey = $o->decryptAesKey($envelope);
6141 0 0       0 if (! $aesKey) {
6142 0         0 $o->{ui}->space;
6143 0         0 $o->{ui}->title('Encrypted content');
6144 0         0 $o->{ui}->line(length $encryptedContentBytes, ' bytes');
6145 0         0 return $o->processMessageEnvelope2($envelope);
6146             }
6147              
6148 0         0 my $contentObject = CDS::Object->fromBytes(CDS::C::aesCrypt($encryptedContentBytes, $aesKey, CDS->zeroCTR));
6149 0 0       0 if (! $contentObject) {
6150 0         0 $o->{ui}->pRed('The embedded content object is invalid, or the AES key (', unpack('H*', $aesKey), ') is wrong.');
6151 0         0 return $o->processMessageEnvelope2($envelope);
6152             }
6153              
6154             #my $signedHash = $contentObject->calculateHash; # before 2020-05-05
6155 0         0 my $signedHash = CDS::Hash->calculateFor($encryptedContentBytes);
6156 0         0 my $content = CDS::Record->fromObject($contentObject);
6157 0 0       0 if (! $content) {
6158 0         0 $o->{ui}->pRed('The embedded content object does not contain a record, or the AES key (', unpack('H*', $aesKey), ') is wrong.');
6159 0         0 return $o->processMessageEnvelope2($envelope);
6160             }
6161              
6162             # Sender hash
6163 0         0 my $senderHash = $content->child('sender')->hashValue;
6164 0 0       0 $o->{ui}->pRed('The content object is missing the sender.') if ! $senderHash;
6165              
6166             # Sender store
6167 0         0 my $senderStoreRecord = $content->child('store');
6168 0         0 my $senderStoreBytes = $senderStoreRecord->bytesValue;
6169 0         0 my $mentionsSenderStore = length $senderStoreBytes;
6170 0 0       0 $o->{ui}->pRed('The content object is missing the sender\'s store.') if ! $mentionsSenderStore;
6171 0 0       0 my $senderStore = scalar $mentionsSenderStore ? $o->{actor}->storeForUrl($senderStoreRecord->textValue) : undef;
6172              
6173             # Sender
6174 0         0 $o->{ui}->space;
6175 0         0 $o->{ui}->title('Signed by');
6176 0 0 0     0 if ($senderHash && $senderStore) {
    0          
    0          
    0          
6177 0         0 my $senderToken = CDS::AccountToken->new($senderStore, $senderHash);
6178 0         0 $o->{ui}->line($o->{actor}->blueAccountReference($senderToken));
6179 0         0 $o->showSignature($envelope, $senderHash, $senderStore, $signedHash);
6180             } elsif ($senderHash) {
6181 0   0     0 my $actorLabel = $o->{actor}->actorLabel($senderHash) // $senderHash->hex;
6182 0 0       0 if ($mentionsSenderStore) {
6183 0         0 $o->{ui}->line($actorLabel, ' on ', $o->{ui}->red($o->{ui}->niceBytes($senderStoreBytes, 64)));
6184             } else {
6185 0         0 $o->{ui}->line($actorLabel);
6186             }
6187 0         0 $o->{ui}->pOrange('The signature cannot be verified, because the signer\'s store is not known.');
6188             } elsif ($senderStore) {
6189 0         0 $o->{ui}->line($o->{ui}->red('?'), ' on ', $o->{actor}->storeReference($senderStore));
6190 0         0 $o->{ui}->pOrange('The signature cannot be verified, because the signer is not known.');
6191             } elsif ($mentionsSenderStore) {
6192 0         0 $o->{ui}->line($o->{ui}->red('?'), ' on ', $o->{ui}->red($o->{ui}->niceBytes($senderStoreBytes, 64)));
6193 0         0 $o->{ui}->pOrange('The signature cannot be verified, because the signer is not known.');
6194             } else {
6195 0         0 $o->{ui}->pOrange('The signature cannot be verified, because the signer is not known.');
6196             }
6197              
6198             # Content
6199 0         0 $o->{ui}->space;
6200 0         0 $o->{ui}->title('Content');
6201 0 0       0 $o->{ui}->recordChildren($content, $senderStore ? $o->{actor}->storeReference($senderStore) : undef);
6202              
6203 0         0 return $o->processMessageEnvelope2($envelope);
6204             }
6205              
6206             sub processMessageEnvelope2 {
6207 0     0   0 my $o = shift;
6208 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
6209              
6210             # Encrypted for
6211 0         0 $o->showEncryptedFor($envelope);
6212              
6213             # Updated by
6214 0         0 $o->{ui}->space;
6215 0         0 $o->{ui}->title('May be removed or updated by');
6216              
6217 0         0 for my $child ($envelope->child('updated by')->children) {
6218 0         0 $o->showActorHash24($child->bytes);
6219             }
6220              
6221             # Expires
6222 0         0 $o->{ui}->space;
6223 0         0 $o->{ui}->title('Expires');
6224 0         0 my $expires = $envelope->child('expires')->integerValue;
6225 0 0       0 $o->{ui}->line($expires ? $o->{ui}->niceDateTime($expires) : $o->{ui}->gray('never'));
6226 0         0 $o->{ui}->space;
6227             }
6228              
6229             sub processStreamHead {
6230 0     0   0 my $o = shift;
6231 0         0 my $head = shift;
6232              
6233 0         0 $o->{ui}->space;
6234 0         0 $o->{ui}->title('Stream head');
6235 0 0       0 return $o->{ui}->pRed('The envelope does not mention a stream head.') if ! $head;
6236 0         0 $o->{ui}->line($o->{ui}->gold('cds open envelope ', $head->hex, ' on ', $o->{actor}->storeReference($o->{store})));
6237              
6238             # Get the envelope
6239 0   0     0 my $envelope = $o->{actor}->uiGetRecord($head, $o->{store}, $o->{keyPairToken}) // return;
6240              
6241             # Decrypt the content
6242 0         0 my $encryptedContentBytes = $envelope->child('content')->bytesValue;
6243 0   0     0 my $aesKey = $o->decryptAesKey($envelope) // return;
6244 0   0     0 my $contentObject = CDS::Object->fromBytes(CDS::C::aesCrypt($encryptedContentBytes, $aesKey, CDS->zeroCTR)) // return {aesKey => $aesKey};
6245 0         0 my $signedHash = CDS::Hash->calculateFor($encryptedContentBytes);
6246 0   0     0 my $content = CDS::Record->fromObject($contentObject) // return {aesKey => $aesKey};
6247              
6248             # Sender
6249 0         0 my $senderHash = $content->child('sender')->hashValue;
6250 0         0 my $senderStoreRecord = $content->child('store');
6251 0         0 my $senderStore = $o->{actor}->storeForUrl($senderStoreRecord->textValue);
6252 0 0 0     0 return {aesKey => $aesKey, senderHash => $senderHash, senderStore => $senderStore} if ! $senderHash || ! $senderStore;
6253              
6254 0         0 $o->{ui}->pushIndent;
6255 0         0 $o->{ui}->space;
6256 0         0 $o->{ui}->title('Signed by');
6257 0         0 my $senderToken = CDS::AccountToken->new($senderStore, $senderHash);
6258 0         0 $o->{ui}->line($o->{actor}->blueAccountReference($senderToken));
6259 0         0 $o->showSignature($envelope, $senderHash, $senderStore, $signedHash);
6260              
6261             # Recipients
6262 0         0 $o->{ui}->space;
6263 0         0 $o->{ui}->title('Encrypted for');
6264 0         0 for my $child ($envelope->child('encrypted for')->children) {
6265 0         0 $o->showActorHash24($child->bytes);
6266             }
6267              
6268 0         0 $o->{ui}->popIndent;
6269 0         0 return {aesKey => $aesKey, senderHash => $senderHash, senderStore => $senderStore, isValid => 1};
6270             }
6271              
6272             sub processStreamEnvelope {
6273 0     0   0 my $o = shift;
6274 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
6275              
6276 0         0 $o->{ui}->space;
6277 0         0 $o->{ui}->title('Stream envelope');
6278 0         0 $o->{ui}->line($o->{ui}->gold('cds show record ', $o->{hash}->hex, ' on ', $o->{actor}->storeReference($o->{store})));
6279              
6280             # Get the head
6281 0         0 my $streamHead = $o->processStreamHead($envelope->child('head')->hashValue);
6282 0 0 0     0 $o->{ui}->pRed('The stream head cannot be opened. Open the stream head envelope for details.') if ! $streamHead || ! $streamHead->{isValid};
6283              
6284             # Get the content
6285 0         0 my $encryptedBytes = $envelope->child('content')->bytesValue;
6286              
6287             # Get the CTR
6288 0         0 $o->{ui}->space;
6289 0         0 $o->{ui}->title('CTR');
6290 0         0 my $ctr = $envelope->child('ctr')->bytesValue;
6291 0 0       0 if (length $ctr == 16) {
6292 0         0 $o->{ui}->line(unpack('H*', $ctr));
6293             } else {
6294 0         0 $o->{ui}->pRed('The CTR value is invalid.');
6295             }
6296              
6297 0 0       0 return $o->{ui}->space if ! $streamHead;
6298 0 0       0 return $o->{ui}->space if ! $streamHead->{aesKey};
6299              
6300             # Get and verify the MAC
6301 0         0 $o->{ui}->space;
6302 0         0 $o->{ui}->title('Message authentication (MAC)');
6303 0         0 my $mac = $envelope->child('mac')->bytesValue;
6304 0         0 my $signedHash = CDS::Hash->calculateFor($encryptedBytes);
6305 0         0 my $expectedMac = CDS::C::aesCrypt($signedHash->bytes, $streamHead->{aesKey}, $ctr);
6306 0 0       0 if ($mac eq $expectedMac) {
6307 0         0 $o->{ui}->pGreen('The MAC valid.');
6308             } else {
6309 0         0 $o->{ui}->pRed('The MAC is invalid.');
6310             }
6311              
6312             # Decrypt the content
6313 0         0 $o->{ui}->space;
6314 0         0 $o->{ui}->title('Content');
6315 0         0 my $contentObject = CDS::Object->fromBytes(CDS::C::aesCrypt($encryptedBytes, $streamHead->{aesKey}, CDS::C::counterPlusInt($ctr, 2)));
6316 0 0       0 if (! $contentObject) {
6317 0         0 $o->{ui}->pRed('The embedded content object is invalid, or the provided AES key (', unpack('H*', $streamHead->{aesKey}), ') is wrong.') ;
6318 0         0 $o->{ui}->space;
6319 0         0 return;
6320             }
6321              
6322 0         0 my $content = CDS::Record->fromObject($contentObject);
6323 0 0       0 return $o->{ui}->pRed('The content is not a record.') if ! $content;
6324 0 0       0 $o->{ui}->recordChildren($content, $streamHead->{senderStore} ? $o->{actor}->storeReference($streamHead->{senderStore}) : undef);
6325 0         0 $o->{ui}->space;
6326              
6327             # The envelope is valid
6328             #my $source = CDS::Source->new($o->{pool}->{keyPair}, $o->{actorOnStore}, 'messages', $entry->{hash});
6329             #return CDS::ReceivedMessage->new($o, $entry, $source, $envelope, $streamHead->senderStoreUrl, $streamHead->sender, $content, $streamHead);
6330              
6331             }
6332              
6333             sub showActorHash24 {
6334 0     0   0 my $o = shift;
6335 0         0 my $actorHashBytes = shift;
6336              
6337 0         0 my $actorHashHex = unpack('H*', $actorHashBytes);
6338 0 0       0 return $o->{ui}->line($o->{ui}->red($actorHashHex, ' (', length $actorHashBytes, ' instead of 24 bytes)')) if length $actorHashBytes != 24;
6339              
6340 0         0 my $actorName = $o->{actor}->actorLabelByHashStartBytes($actorHashBytes);
6341 0         0 $actorHashHex .= '·' x 16;
6342              
6343 0         0 my $keyPairHashBytes = $o->{keyPairToken}->keyPair->publicKey->hash->bytes;
6344 0         0 my $isMe = substr($keyPairHashBytes, 0, 24) eq $actorHashBytes;
6345 0 0       0 $o->{ui}->line($isMe ? $o->{ui}->violet($actorHashHex) : $actorHashHex, (defined $actorName ? $o->{ui}->blue(' '.$actorName) : ''));
    0          
6346 0         0 return $isMe;
6347             }
6348              
6349             sub showSignature {
6350 0     0   0 my $o = shift;
6351 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
6352 0 0 0     0 my $senderHash = shift; die 'wrong type '.ref($senderHash).' for $senderHash' if defined $senderHash && ref $senderHash ne 'CDS::Hash';
  0         0  
6353 0         0 my $senderStore = shift;
6354 0 0 0     0 my $signedHash = shift; die 'wrong type '.ref($signedHash).' for $signedHash' if defined $signedHash && ref $signedHash ne 'CDS::Hash';
  0         0  
6355              
6356             # Get the public key
6357 0         0 my $publicKey = $o->getPublicKey($senderHash, $senderStore);
6358 0 0       0 return $o->{ui}->line($o->{ui}->orange('The signature cannot be verified, because the signer\'s public key is not available.')) if ! $publicKey;
6359              
6360             # Verify the signature
6361 0 0       0 if (CDS->verifyEnvelopeSignature($envelope, $publicKey, $signedHash)) {
6362 0         0 $o->{ui}->pGreen('The signature is valid.');
6363             } else {
6364 0         0 $o->{ui}->pRed('The signature is not valid.');
6365             }
6366             }
6367              
6368             sub getPublicKey {
6369 0     0   0 my $o = shift;
6370 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
6371 0         0 my $store = shift;
6372              
6373 0 0       0 return $o->{keyPairToken}->keyPair->publicKey if $hash->equals($o->{keyPairToken}->keyPair->publicKey->hash);
6374 0         0 return $o->{actor}->uiGetPublicKey($hash, $store, $o->{keyPairToken});
6375             }
6376              
6377             sub showEncryptedFor {
6378 0     0   0 my $o = shift;
6379 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
6380              
6381 0         0 $o->{ui}->space;
6382 0         0 $o->{ui}->title('Encrypted for');
6383              
6384 0         0 my $canDecrypt = 0;
6385 0         0 for my $child ($envelope->child('encrypted for')->children) {
6386 0 0       0 $canDecrypt = 1 if $o->showActorHash24($child->bytes);
6387             }
6388              
6389 0 0       0 return if $canDecrypt;
6390 0         0 $o->{ui}->space;
6391 0         0 my $keyPairHash = $o->{keyPairToken}->keyPair->publicKey->hash;
6392 0         0 $o->{ui}->pOrange('This envelope is not encrypted for you (', $keyPairHash->shortHex, '). If you possess one of the keypairs mentioned above, add "… using KEYPAIR" to open this envelope.');
6393             }
6394              
6395             sub decryptAesKey {
6396 0     0   0 my $o = shift;
6397 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
6398              
6399 0         0 my $keyPair = $o->{keyPairToken}->keyPair;
6400 0         0 my $hashBytes24 = substr($keyPair->publicKey->hash->bytes, 0, 24);
6401 0         0 my $child = $envelope->child('encrypted for')->child($hashBytes24);
6402              
6403 0         0 my $encryptedAesKey = $child->bytesValue;
6404 0 0       0 return if ! length $encryptedAesKey;
6405              
6406 0         0 my $aesKey = $keyPair->decrypt($encryptedAesKey);
6407 0 0 0     0 return $aesKey if defined $aesKey && length $aesKey == 32;
6408              
6409 0         0 $o->{ui}->pRed('The AES key failed to decrypt. It either wasn\'t encrypted properly, or the encryption was performed with the wrong public key.');
6410 0         0 return;
6411             }
6412              
6413             # BEGIN AUTOGENERATED
6414             package CDS::Commands::Put;
6415              
6416             sub register {
6417 0     0   0 my $class = shift;
6418 0         0 my $cds = shift;
6419 0         0 my $help = shift;
6420              
6421 0         0 my $node000 = CDS::Parser::Node->new(0);
6422 0         0 my $node001 = CDS::Parser::Node->new(0);
6423 0         0 my $node002 = CDS::Parser::Node->new(0);
6424 0         0 my $node003 = CDS::Parser::Node->new(0);
6425 0         0 my $node004 = CDS::Parser::Node->new(0);
6426 0         0 my $node005 = CDS::Parser::Node->new(0);
6427 0         0 my $node006 = CDS::Parser::Node->new(0);
6428 0         0 my $node007 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
6429 0         0 my $node008 = CDS::Parser::Node->new(0);
6430 0         0 my $node009 = CDS::Parser::Node->new(0);
6431 0         0 my $node010 = CDS::Parser::Node->new(0);
6432 0         0 my $node011 = CDS::Parser::Node->new(0);
6433 0         0 my $node012 = CDS::Parser::Node->new(1);
6434 0         0 my $node013 = CDS::Parser::Node->new(0);
6435 0         0 my $node014 = CDS::Parser::Node->new(0);
6436 0         0 my $node015 = CDS::Parser::Node->new(0);
6437 0         0 my $node016 = CDS::Parser::Node->new(0);
6438 0         0 my $node017 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&put});
6439 0         0 $cds->addArrow($node000, 1, 0, 'put');
6440 0         0 $cds->addArrow($node001, 1, 0, 'put');
6441 0         0 $cds->addArrow($node002, 1, 0, 'put');
6442 0         0 $help->addArrow($node007, 1, 0, 'put');
6443 0         0 $node000->addArrow($node012, 1, 0, 'OBJECTFILE', \&collectObjectfile);
6444 0         0 $node001->addArrow($node003, 1, 0, 'object');
6445 0         0 $node002->addArrow($node004, 1, 0, 'public');
6446 0         0 $node003->addArrow($node008, 1, 0, 'with');
6447 0         0 $node004->addArrow($node005, 1, 0, 'key');
6448 0         0 $node005->addArrow($node006, 1, 0, 'of');
6449 0         0 $node006->addArrow($node012, 1, 0, 'KEYPAIR', \&collectKeypair);
6450 0         0 $node008->addDefault($node009);
6451 0         0 $node008->addDefault($node011);
6452 0         0 $node009->addArrow($node009, 1, 0, 'HASH', \&collectHash);
6453 0         0 $node009->addArrow($node010, 1, 0, 'HASH', \&collectHash);
6454 0         0 $node010->addArrow($node011, 1, 0, 'and');
6455 0         0 $node011->addArrow($node012, 1, 0, 'FILE', \&collectFile);
6456 0         0 $node012->addArrow($node013, 1, 0, 'encrypted');
6457 0         0 $node012->addDefault($node015);
6458 0         0 $node013->addArrow($node014, 1, 0, 'with');
6459 0         0 $node014->addArrow($node015, 1, 0, 'AESKEY', \&collectAeskey);
6460 0         0 $node015->addArrow($node016, 1, 0, 'onto');
6461 0         0 $node015->addDefault($node017);
6462 0         0 $node016->addArrow($node016, 1, 0, 'STORE', \&collectStore);
6463 0         0 $node016->addArrow($node017, 1, 0, 'STORE', \&collectStore);
6464             }
6465              
6466             sub collectAeskey {
6467 0     0   0 my $o = shift;
6468 0         0 my $label = shift;
6469 0         0 my $value = shift;
6470              
6471 0         0 $o->{aesKey} = $value;
6472             }
6473              
6474             sub collectFile {
6475 0     0   0 my $o = shift;
6476 0         0 my $label = shift;
6477 0         0 my $value = shift;
6478              
6479 0         0 $o->{dataFile} = $value;
6480             }
6481              
6482             sub collectHash {
6483 0     0   0 my $o = shift;
6484 0         0 my $label = shift;
6485 0         0 my $value = shift;
6486              
6487 0         0 push @{$o->{hashes}}, $value;
  0         0  
6488             }
6489              
6490             sub collectKeypair {
6491 0     0   0 my $o = shift;
6492 0         0 my $label = shift;
6493 0         0 my $value = shift;
6494              
6495 0         0 $o->{object} = $value->keyPair->publicKey->object;
6496             }
6497              
6498             sub collectObjectfile {
6499 0     0   0 my $o = shift;
6500 0         0 my $label = shift;
6501 0         0 my $value = shift;
6502              
6503 0         0 $o->{objectFile} = $value;
6504             }
6505              
6506             sub collectStore {
6507 0     0   0 my $o = shift;
6508 0         0 my $label = shift;
6509 0         0 my $value = shift;
6510              
6511 0         0 push @{$o->{stores}}, $value;
  0         0  
6512             }
6513              
6514             sub new {
6515 0     0   0 my $class = shift;
6516 0         0 my $actor = shift;
6517 0         0 bless {actor => $actor, ui => $actor->ui} }
6518              
6519             # END AUTOGENERATED
6520              
6521             # HTML FOLDER NAME store-put
6522             # HTML TITLE Put
6523             sub help {
6524 0     0   0 my $o = shift;
6525 0         0 my $cmd = shift;
6526              
6527 0         0 my $ui = $o->{ui};
6528 0         0 $ui->space;
6529 0         0 $ui->command('cds put FILE* [onto STORE*]');
6530 0         0 $ui->p('Uploads object files onto object stores. If no stores are provided, the selected store is used. If an upload fails, the program immediately quits with exit code 1.');
6531 0         0 $ui->space;
6532 0         0 $ui->command('cds put FILE encrypted with AESKEY [onto STORE*]');
6533 0         0 $ui->p('Encrypts the object before the upload.');
6534 0         0 $ui->space;
6535 0         0 $ui->command('cds put object with [HASH* and] FILE …');
6536 0         0 $ui->p('Creates an object with the HASHes as hash list and FILE as data.');
6537 0         0 $ui->space;
6538 0         0 $ui->command('cds put public key of KEYPAIR …');
6539 0         0 $ui->p('Uploads the public key of the indicated key pair onto the store.');
6540 0         0 $ui->space;
6541             }
6542              
6543             sub put {
6544 0     0   0 my $o = shift;
6545 0         0 my $cmd = shift;
6546              
6547 0         0 $o->{hashes} = [];
6548 0         0 $o->{stores} = [];
6549 0         0 $cmd->collect($o);
6550              
6551             # Stores
6552 0 0       0 push @{$o->{stores}}, $o->{actor}->preferredStore if ! scalar @{$o->{stores}};
  0         0  
  0         0  
6553              
6554 0         0 $o->{get} = [];
6555 0 0       0 return $o->putObject($o->{object}) if $o->{object};
6556 0 0       0 return $o->putObjectFile if $o->{objectFile};
6557 0         0 $o->putConstructedFile;
6558             }
6559              
6560             sub putObjectFile {
6561 0     0   0 my $o = shift;
6562              
6563 0         0 my $object = $o->{objectFile}->object;
6564              
6565             # Display object information
6566 0         0 $o->{ui}->space;
6567 0         0 $o->{ui}->title('Uploading ', $o->{objectFile}->file, ' ', $o->{ui}->gray($o->{ui}->niceFileSize($object->byteLength)));
6568 0 0       0 $o->{ui}->line($object->hashesCount == 1 ? '1 hash' : $object->hashesCount.' hashes');
6569 0         0 $o->{ui}->line($o->{ui}->niceFileSize(length $object->data).' data');
6570 0         0 $o->{ui}->space;
6571              
6572             # Upload
6573 0         0 $o->putObject($object);
6574             }
6575              
6576             sub putConstructedFile {
6577 0     0   0 my $o = shift;
6578              
6579             # Create the object
6580 0   0     0 my $data = CDS->readBytesFromFile($o->{dataFile}) // return $o->{ui}->error('Unable to read "', $o->{dataFile}, '".');
6581 0         0 my $header = pack('L>', scalar @{$o->{hashes}}) . join('', map { $_->bytes } @{$o->{hashes}});
  0         0  
  0         0  
  0         0  
6582 0         0 my $object = CDS::Object->create($header, $data);
6583              
6584             # Display object information
6585 0         0 $o->{ui}->space;
6586 0         0 $o->{ui}->title('Uploading new object ', $o->{ui}->gray($o->{ui}->niceFileSize(length $object->bytes)));
6587 0 0       0 $o->{ui}->line($object->hashesCount == 1 ? '1 hash' : $object->hashesCount.' hashes');
6588 0         0 $o->{ui}->line($o->{ui}->niceFileSize(length $object->data).' data from ', $o->{dataFile});
6589 0         0 $o->{ui}->space;
6590              
6591             # Upload
6592 0         0 $o->putObject($object);
6593             }
6594              
6595             sub putObject {
6596 0     0   0 my $o = shift;
6597 0 0 0     0 my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0         0  
6598              
6599 0         0 my $keyPair = $o->{actor}->preferredKeyPairToken->keyPair;
6600              
6601             # Encrypt it if desired
6602 0         0 my $objectBytes;
6603 0 0       0 if (defined $o->{aesKey}) {
6604 0         0 $object = $object->crypt($o->{aesKey});
6605 0         0 unshift @{$o->{get}}, ' decrypted with ', unpack('H*', $o->{aesKey}), ' ';
  0         0  
6606             }
6607              
6608             # Calculate the hash
6609 0         0 my $hash = $object->calculateHash;
6610              
6611             # Upload the object
6612 0         0 my $successfulStore;
6613 0         0 for my $store (@{$o->{stores}}) {
  0         0  
6614 0         0 my $error = $store->put($hash, $object, $keyPair);
6615 0 0       0 next if $error;
6616 0         0 $o->{ui}->pGreen('The object was uploaded onto ', $store->url, '.');
6617 0         0 $successfulStore = $store;
6618             }
6619              
6620             # Show the corresponding download line
6621 0 0       0 return if ! $successfulStore;
6622 0         0 $o->{ui}->space;
6623 0         0 $o->{ui}->line('To download the object, type:');
6624 0         0 $o->{ui}->line($o->{ui}->gold('cds get ', $hash->hex), $o->{ui}->gray(' on ', $successfulStore->url, @{$o->{get}}));
  0         0  
6625 0         0 $o->{ui}->space;
6626             }
6627              
6628             package CDS::Commands::Remember;
6629              
6630             # BEGIN AUTOGENERATED
6631              
6632             sub register {
6633 0     0   0 my $class = shift;
6634 0         0 my $cds = shift;
6635 0         0 my $help = shift;
6636              
6637 0         0 my $node000 = CDS::Parser::Node->new(0, {constructor => \&new, function => \&showLabels});
6638 0         0 my $node001 = CDS::Parser::Node->new(0);
6639 0         0 my $node002 = CDS::Parser::Node->new(0);
6640 0         0 my $node003 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
6641 0         0 my $node004 = CDS::Parser::Node->new(0);
6642 0         0 my $node005 = CDS::Parser::Node->new(0);
6643 0         0 my $node006 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&forget});
6644 0         0 my $node007 = CDS::Parser::Node->new(1);
6645 0         0 my $node008 = CDS::Parser::Node->new(0);
6646 0         0 my $node009 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&remember});
6647 0         0 $cds->addArrow($node000, 1, 0, 'remember');
6648 0         0 $cds->addArrow($node001, 1, 0, 'forget');
6649 0         0 $help->addArrow($node003, 1, 0, 'forget');
6650 0         0 $help->addArrow($node003, 1, 0, 'remember');
6651 0         0 $node000->addArrow($node004, 1, 0, 'ACTOR', \&collectActor);
6652 0         0 $node000->addArrow($node007, 1, 1, 'ACCOUNT', \&collectAccount);
6653 0         0 $node000->addArrow($node007, 1, 0, 'ACTOR', \&collectActor);
6654 0         0 $node000->addArrow($node007, 1, 0, 'KEYPAIR', \&collectKeypair);
6655 0         0 $node000->addArrow($node007, 1, 0, 'STORE', \&collectStore);
6656 0         0 $node001->addDefault($node002);
6657 0         0 $node002->addArrow($node002, 1, 0, 'LABEL', \&collectLabel);
6658 0         0 $node002->addArrow($node006, 1, 0, 'LABEL', \&collectLabel);
6659 0         0 $node004->addArrow($node005, 1, 0, 'on');
6660 0         0 $node005->addArrow($node007, 1, 0, 'STORE', \&collectStore);
6661 0         0 $node007->addArrow($node008, 1, 0, 'as');
6662 0         0 $node008->addArrow($node009, 1, 0, 'TEXT', \&collectText);
6663             }
6664              
6665             sub collectAccount {
6666 0     0   0 my $o = shift;
6667 0         0 my $label = shift;
6668 0         0 my $value = shift;
6669              
6670 0         0 $o->{store} = $value->cliStore;
6671 0         0 $o->{actorHash} = $value->actorHash;
6672             }
6673              
6674             sub collectActor {
6675 0     0   0 my $o = shift;
6676 0         0 my $label = shift;
6677 0         0 my $value = shift;
6678              
6679 0         0 $o->{actorHash} = $value;
6680             }
6681              
6682             sub collectKeypair {
6683 0     0   0 my $o = shift;
6684 0         0 my $label = shift;
6685 0         0 my $value = shift;
6686              
6687 0         0 $o->{keyPairToken} = $value;
6688             }
6689              
6690             sub collectLabel {
6691 0     0   0 my $o = shift;
6692 0         0 my $label = shift;
6693 0         0 my $value = shift;
6694              
6695 0         0 push @{$o->{forget}}, $value;
  0         0  
6696             }
6697              
6698             sub collectStore {
6699 0     0   0 my $o = shift;
6700 0         0 my $label = shift;
6701 0         0 my $value = shift;
6702              
6703 0         0 $o->{store} = $value;
6704             }
6705              
6706             sub collectText {
6707 0     0   0 my $o = shift;
6708 0         0 my $label = shift;
6709 0         0 my $value = shift;
6710              
6711 0         0 $o->{label} = $value;
6712             }
6713              
6714             sub new {
6715 0     0   0 my $class = shift;
6716 0         0 my $actor = shift;
6717 0         0 bless {actor => $actor, ui => $actor->ui} }
6718              
6719             # END AUTOGENERATED
6720              
6721             # HTML FOLDER NAME remember
6722             # HTML TITLE Remember
6723             sub help {
6724 0     0   0 my $o = shift;
6725 0         0 my $cmd = shift;
6726              
6727 0         0 my $ui = $o->{ui};
6728 0         0 $ui->space;
6729 0         0 $ui->command('cds remember');
6730 0         0 $ui->p('Shows all remembered values.');
6731 0         0 $ui->space;
6732 0         0 $ui->command('cds remember ACCOUNT|ACTOR|STORE|KEYPAIR as TEXT');
6733 0         0 $ui->command('cds remember ACTOR on STORE as TEXT');
6734 0         0 $ui->p('Remembers the indicated actor hash, account, store, or key pair as TEXT. This information is stored in the global state, and therefore persists until the name is deleted (cds forget …) or redefined (cds remember …).');
6735 0         0 $ui->space;
6736 0         0 $ui->p('Key pairs are stored as link (absolute path) to the key pair file, and specific to the device.');
6737 0         0 $ui->space;
6738 0         0 $ui->command('cds forget LABEL');
6739 0         0 $ui->p('Forgets the corresponding item.');
6740 0         0 $ui->space;
6741             }
6742              
6743             sub remember {
6744 0     0   0 my $o = shift;
6745 0         0 my $cmd = shift;
6746              
6747 0         0 $cmd->collect($o);
6748              
6749 0         0 my $record = CDS::Record->new;
6750 0 0       0 $record->add('store')->addText($o->{store}->url) if defined $o->{store};
6751 0 0       0 $record->add('actor')->add($o->{actorHash}->bytes) if defined $o->{actorHash};
6752 0 0       0 $record->add('key pair')->addText($o->{keyPairToken}->file) if defined $o->{keyPairToken};
6753 0         0 $o->{actor}->remember($o->{label}, $record);
6754 0         0 $o->{actor}->saveOrShowError;
6755             }
6756              
6757             sub forget {
6758 0     0   0 my $o = shift;
6759 0         0 my $cmd = shift;
6760              
6761 0         0 $o->{forget} = [];
6762 0         0 $cmd->collect($o);
6763              
6764 0         0 for my $label (@{$o->{forget}}) {
  0         0  
6765 0         0 $o->{actor}->groupRoot->child('labels')->child($label)->clear;
6766             }
6767              
6768 0         0 $o->{actor}->saveOrShowError;
6769             }
6770              
6771             sub showLabels {
6772 0     0   0 my $o = shift;
6773 0         0 my $cmd = shift;
6774              
6775 0         0 $o->{ui}->space;
6776 0         0 $o->showRememberedValues;
6777 0         0 $o->{ui}->space;
6778             }
6779              
6780             sub showRememberedValues {
6781 0     0   0 my $o = shift;
6782              
6783 0         0 my $hasLabel = 0;
6784 0         0 for my $child (sort { $a->{id} cmp $b->{id} } $o->{actor}->groupRoot->child('labels')->children) {
  0         0  
6785 0         0 my $record = $child->record;
6786 0         0 my $label = $o->{ui}->blue($o->{ui}->left(15, Encode::decode_utf8($child->label)));
6787              
6788 0         0 my $actorHash = CDS::Hash->fromBytes($record->child('actor')->bytesValue);
6789 0         0 my $storeUrl = $record->child('store')->textValue;
6790 0         0 my $keyPairFile = $record->child('key pair')->textValue;
6791              
6792 0 0       0 if (length $keyPairFile) {
6793 0         0 $o->{ui}->line($label, ' ', $o->{ui}->gray('key pair'), ' ', $keyPairFile);
6794 0         0 $hasLabel = 1;
6795             }
6796              
6797 0 0 0     0 if ($actorHash && length $storeUrl) {
    0          
    0          
6798 0         0 my $storeReference = $o->{actor}->blueStoreUrlReference($storeUrl);
6799 0         0 $o->{ui}->line($label, ' ', $o->{ui}->gray('account'), ' ', $actorHash->hex, ' on ', $storeReference);
6800 0         0 $hasLabel = 1;
6801             } elsif ($actorHash) {
6802 0         0 $o->{ui}->line($label, ' ', $o->{ui}->gray('actor'), ' ', $actorHash->hex);
6803 0         0 $hasLabel = 1;
6804             } elsif (length $storeUrl) {
6805 0         0 $o->{ui}->line($label, ' ', $o->{ui}->gray('store'), ' ', $storeUrl);
6806 0         0 $hasLabel = 1;
6807             }
6808              
6809 0         0 $o->showActorGroupLabel($label, $record->child('actor group'));
6810             }
6811              
6812 0 0       0 return if $hasLabel;
6813 0         0 $o->{ui}->line($o->{ui}->gray('none'));
6814             }
6815              
6816             sub showActorGroupLabel {
6817 0     0   0 my $o = shift;
6818 0         0 my $label = shift;
6819 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
6820              
6821 0 0       0 return if ! $record->contains('actor group');
6822              
6823 0         0 my $builder = CDS::ActorGroupBuilder->new;
6824 0         0 $builder->parse($record, 1);
6825              
6826 0         0 my $countActive = 0;
6827 0         0 my $countIdle = 0;
6828 0         0 my $newestActive = undef;
6829              
6830 0         0 for my $member ($builder->members) {
6831 0         0 my $isActive = $member->status eq 'active';
6832 0 0       0 $countActive += 1 if $isActive;
6833 0 0       0 $countIdle += 1 if $member->status eq 'idle';
6834              
6835 0 0       0 next if ! $isActive;
6836 0 0 0     0 next if $newestActive && $member->revision <= $newestActive->revision;
6837 0         0 $newestActive = $member;
6838             }
6839              
6840 0         0 my @line;
6841 0         0 push @line, $label, ' ', $o->{ui}->gray('actor group'), ' ';
6842 0 0       0 push @line, $newestActive->hash->hex, ' on ', $o->{actor}->blueStoreUrlReference($newestActive->storeUrl) if $newestActive;
6843 0 0       0 push @line, $o->{ui}->gray('(no active actor)') if ! $newestActive;
6844 0         0 push @line, $o->{ui}->green(' ', $countActive, ' active');
6845 0         0 my $discovered = $record->child('discovered')->integerValue;
6846 0 0       0 push @line, $o->{ui}->gray(' ', $o->{ui}->niceDateTimeLocal($discovered)) if $discovered;
6847 0         0 $o->{ui}->line(@line);
6848             }
6849              
6850             # BEGIN AUTOGENERATED
6851             package CDS::Commands::Select;
6852              
6853             sub register {
6854 0     0   0 my $class = shift;
6855 0         0 my $cds = shift;
6856 0         0 my $help = shift;
6857              
6858 0         0 my $node000 = CDS::Parser::Node->new(0);
6859 0         0 my $node001 = CDS::Parser::Node->new(0);
6860 0         0 my $node002 = CDS::Parser::Node->new(0);
6861 0         0 my $node003 = CDS::Parser::Node->new(0);
6862 0         0 my $node004 = CDS::Parser::Node->new(0);
6863 0         0 my $node005 = CDS::Parser::Node->new(0);
6864 0         0 my $node006 = CDS::Parser::Node->new(0);
6865 0         0 my $node007 = CDS::Parser::Node->new(0);
6866 0         0 my $node008 = CDS::Parser::Node->new(0);
6867 0         0 my $node009 = CDS::Parser::Node->new(0);
6868 0         0 my $node010 = CDS::Parser::Node->new(0);
6869 0         0 my $node011 = CDS::Parser::Node->new(0);
6870 0         0 my $node012 = CDS::Parser::Node->new(0);
6871 0         0 my $node013 = CDS::Parser::Node->new(0);
6872 0         0 my $node014 = CDS::Parser::Node->new(0);
6873 0         0 my $node015 = CDS::Parser::Node->new(0);
6874 0         0 my $node016 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
6875 0         0 my $node017 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showSelectionCmd});
6876 0         0 my $node018 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&unselectKeyPair});
6877 0         0 my $node019 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&unselectStore});
6878 0         0 my $node020 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&unselectActor});
6879 0         0 my $node021 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&unselectAll});
6880 0         0 my $node022 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&select});
6881 0         0 $cds->addArrow($node000, 1, 0, 'select');
6882 0         0 $cds->addArrow($node001, 1, 0, 'select');
6883 0         0 $cds->addArrow($node002, 1, 0, 'select');
6884 0         0 $cds->addArrow($node003, 1, 0, 'select');
6885 0         0 $cds->addArrow($node004, 1, 0, 'select');
6886 0         0 $cds->addArrow($node005, 1, 0, 'select');
6887 0         0 $cds->addArrow($node006, 1, 0, 'select');
6888 0         0 $cds->addArrow($node009, 1, 0, 'unselect');
6889 0         0 $cds->addArrow($node010, 1, 0, 'unselect');
6890 0         0 $cds->addArrow($node011, 1, 0, 'unselect');
6891 0         0 $cds->addArrow($node012, 1, 0, 'unselect');
6892 0         0 $cds->addArrow($node017, 1, 0, 'select');
6893 0         0 $help->addArrow($node016, 1, 0, 'select');
6894 0         0 $node000->addArrow($node022, 1, 0, 'KEYPAIR', \&collectKeypair);
6895 0         0 $node001->addArrow($node022, 1, 0, 'STORE', \&collectStore);
6896 0         0 $node002->addArrow($node014, 1, 0, 'ACTOR', \&collectActor);
6897 0         0 $node003->addArrow($node007, 1, 0, 'storage');
6898 0         0 $node004->addArrow($node008, 1, 0, 'messaging');
6899 0         0 $node005->addArrow($node022, 1, 0, 'ACTOR', \&collectActor);
6900 0         0 $node006->addArrow($node022, 1, 1, 'ACCOUNT', \&collectAccount);
6901 0         0 $node007->addArrow($node022, 1, 0, 'store', \&collectStore1);
6902 0         0 $node008->addArrow($node022, 1, 0, 'store', \&collectStore2);
6903 0         0 $node009->addArrow($node013, 1, 0, 'key');
6904 0         0 $node010->addArrow($node019, 1, 0, 'store');
6905 0         0 $node011->addArrow($node020, 1, 0, 'actor');
6906 0         0 $node012->addArrow($node021, 1, 0, 'all');
6907 0         0 $node013->addArrow($node018, 1, 0, 'pair');
6908 0         0 $node014->addArrow($node015, 1, 0, 'on');
6909 0         0 $node015->addArrow($node022, 1, 0, 'STORE', \&collectStore);
6910             }
6911              
6912             sub collectAccount {
6913 0     0   0 my $o = shift;
6914 0         0 my $label = shift;
6915 0         0 my $value = shift;
6916              
6917 0         0 $o->{store} = $value->cliStore;
6918 0         0 $o->{actorHash} = $value->actorHash;
6919             }
6920              
6921             sub collectActor {
6922 0     0   0 my $o = shift;
6923 0         0 my $label = shift;
6924 0         0 my $value = shift;
6925              
6926 0         0 $o->{actorHash} = $value;
6927             }
6928              
6929             sub collectKeypair {
6930 0     0   0 my $o = shift;
6931 0         0 my $label = shift;
6932 0         0 my $value = shift;
6933              
6934 0         0 $o->{keyPairToken} = $value;
6935 0         0 $o->{actorHash} = $value->keyPair->publicKey->hash;
6936             }
6937              
6938             sub collectStore {
6939 0     0   0 my $o = shift;
6940 0         0 my $label = shift;
6941 0         0 my $value = shift;
6942              
6943 0         0 $o->{store} = $value;
6944             }
6945              
6946             sub collectStore1 {
6947 0     0   0 my $o = shift;
6948 0         0 my $label = shift;
6949 0         0 my $value = shift;
6950              
6951 0         0 $o->{store} = $o->{actor}->storageStore;
6952             }
6953              
6954             sub collectStore2 {
6955 0     0   0 my $o = shift;
6956 0         0 my $label = shift;
6957 0         0 my $value = shift;
6958              
6959 0         0 $o->{store} = $o->{actor}->messagingStore;
6960             }
6961              
6962             sub new {
6963 0     0   0 my $class = shift;
6964 0         0 my $actor = shift;
6965 0         0 bless {actor => $actor, ui => $actor->ui} }
6966              
6967             # END AUTOGENERATED
6968              
6969             # HTML FOLDER NAME select
6970             # HTML TITLE Select
6971             sub help {
6972 0     0   0 my $o = shift;
6973 0         0 my $cmd = shift;
6974              
6975 0         0 my $ui = $o->{ui};
6976 0         0 $ui->space;
6977 0         0 $ui->command('cds select');
6978 0         0 $ui->p('Shows the current selection.');
6979 0         0 $ui->space;
6980 0         0 $ui->command('cds select KEYPAIR');
6981 0         0 $ui->p('Selects KEYPAIR on this terminal. Some commands will use this key pair by default.');
6982 0         0 $ui->space;
6983 0         0 $ui->command('cds unselect key pair');
6984 0         0 $ui->p('Removes the key pair selection.');
6985 0         0 $ui->space;
6986 0         0 $ui->command('cds select STORE');
6987 0         0 $ui->p('Selects STORE on this terminal. Some commands will use this store by default.');
6988 0         0 $ui->space;
6989 0         0 $ui->command('cds unselect store');
6990 0         0 $ui->p('Removes the store selection.');
6991 0         0 $ui->space;
6992 0         0 $ui->command('cds select ACTOR');
6993 0         0 $ui->p('Selects ACTOR on this terminal. Some commands will use this store by default.');
6994 0         0 $ui->space;
6995 0         0 $ui->command('cds unselect actor');
6996 0         0 $ui->p('Removes the actor selection.');
6997 0         0 $ui->space;
6998 0         0 $ui->command('cds unselect');
6999 0         0 $ui->p('Removes any selection.');
7000 0         0 $ui->space;
7001             }
7002              
7003             sub select {
7004 0     0   0 my $o = shift;
7005 0         0 my $cmd = shift;
7006              
7007 0         0 $cmd->collect($o);
7008              
7009 0 0       0 if ($o->{keyPairToken}) {
7010 0         0 $o->{actor}->sessionRoot->child('selected key pair')->setText($o->{keyPairToken}->file);
7011 0         0 $o->{ui}->pGreen('Key pair ', $o->{keyPairToken}->file, ' selected.');
7012             }
7013              
7014 0 0       0 if ($o->{store}) {
7015 0         0 $o->{actor}->sessionRoot->child('selected store')->setText($o->{store}->url);
7016 0         0 $o->{ui}->pGreen('Store ', $o->{store}->url, ' selected.');
7017             }
7018              
7019 0 0       0 if ($o->{actorHash}) {
7020 0         0 $o->{actor}->sessionRoot->child('selected actor')->setBytes($o->{actorHash}->bytes);
7021 0         0 $o->{ui}->pGreen('Actor ', $o->{actorHash}->hex, ' selected.');
7022             }
7023              
7024 0         0 $o->{actor}->saveOrShowError;
7025             }
7026              
7027             sub unselectKeyPair {
7028 0     0   0 my $o = shift;
7029 0         0 my $cmd = shift;
7030              
7031 0         0 $o->{actor}->sessionRoot->child('selected key pair')->clear;
7032 0         0 $o->{ui}->pGreen('Key pair selection cleared.');
7033 0         0 $o->{actor}->saveOrShowError;
7034             }
7035              
7036             sub unselectStore {
7037 0     0   0 my $o = shift;
7038 0         0 my $cmd = shift;
7039              
7040 0         0 $o->{actor}->sessionRoot->child('selected store')->clear;
7041 0         0 $o->{ui}->pGreen('Store selection cleared.');
7042 0         0 $o->{actor}->saveOrShowError;
7043             }
7044              
7045             sub unselectActor {
7046 0     0   0 my $o = shift;
7047 0         0 my $cmd = shift;
7048              
7049 0         0 $o->{actor}->sessionRoot->child('selected actor')->clear;
7050 0         0 $o->{ui}->pGreen('Actor selection cleared.');
7051 0         0 $o->{actor}->saveOrShowError;
7052             }
7053              
7054             sub unselectAll {
7055 0     0   0 my $o = shift;
7056 0         0 my $cmd = shift;
7057              
7058 0         0 $o->{actor}->sessionRoot->child('selected key pair')->clear;
7059 0         0 $o->{actor}->sessionRoot->child('selected store')->clear;
7060 0         0 $o->{actor}->sessionRoot->child('selected actor')->clear;
7061 0   0     0 $o->{actor}->saveOrShowError // return;
7062 0         0 $o->showSelection;
7063             }
7064              
7065             sub showSelectionCmd {
7066 0     0   0 my $o = shift;
7067 0         0 my $cmd = shift;
7068              
7069 0         0 $o->{ui}->space;
7070 0         0 $o->showSelection;
7071 0         0 $o->{ui}->space;
7072             }
7073              
7074             sub showSelection {
7075 0     0   0 my $o = shift;
7076              
7077 0         0 my $keyPairFile = $o->{actor}->sessionRoot->child('selected key pair')->textValue;
7078 0         0 my $storeUrl = $o->{actor}->sessionRoot->child('selected store')->textValue;
7079 0         0 my $actorBytes = $o->{actor}->sessionRoot->child('selected actor')->bytesValue;
7080              
7081 0 0       0 $o->{ui}->line($o->{ui}->darkBold('Selected key pair '), length $keyPairFile ? $keyPairFile : $o->{ui}->gray('none'));
7082 0 0       0 $o->{ui}->line($o->{ui}->darkBold('Selected store '), length $storeUrl ? $storeUrl : $o->{ui}->gray('none'));
7083 0 0       0 $o->{ui}->line($o->{ui}->darkBold('Selected actor '), length $actorBytes == 32 ? unpack('H*', $actorBytes) : $o->{ui}->gray('none'));
7084             }
7085              
7086             # BEGIN AUTOGENERATED
7087             package CDS::Commands::ShowCard;
7088              
7089             sub register {
7090 0     0   0 my $class = shift;
7091 0         0 my $cds = shift;
7092 0         0 my $help = shift;
7093              
7094 0         0 my $node000 = CDS::Parser::Node->new(0);
7095 0         0 my $node001 = CDS::Parser::Node->new(0);
7096 0         0 my $node002 = CDS::Parser::Node->new(0);
7097 0         0 my $node003 = CDS::Parser::Node->new(0);
7098 0         0 my $node004 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
7099 0         0 my $node005 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showMyCard});
7100 0         0 my $node006 = CDS::Parser::Node->new(1);
7101 0         0 my $node007 = CDS::Parser::Node->new(0);
7102 0         0 my $node008 = CDS::Parser::Node->new(0);
7103 0         0 my $node009 = CDS::Parser::Node->new(0);
7104 0         0 my $node010 = CDS::Parser::Node->new(0);
7105 0         0 my $node011 = CDS::Parser::Node->new(0);
7106 0         0 my $node012 = CDS::Parser::Node->new(0);
7107 0         0 my $node013 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showCard});
7108 0         0 $cds->addArrow($node001, 1, 0, 'show');
7109 0         0 $cds->addArrow($node002, 1, 0, 'show');
7110 0         0 $help->addArrow($node000, 1, 0, 'show');
7111 0         0 $node000->addArrow($node004, 1, 0, 'card');
7112 0         0 $node001->addArrow($node006, 1, 0, 'card');
7113 0         0 $node002->addArrow($node003, 1, 0, 'my');
7114 0         0 $node003->addArrow($node005, 1, 0, 'card');
7115 0         0 $node006->addArrow($node007, 1, 0, 'of');
7116 0         0 $node006->addArrow($node008, 1, 0, 'of');
7117 0         0 $node006->addArrow($node009, 1, 0, 'of');
7118 0         0 $node006->addArrow($node010, 1, 0, 'of');
7119 0         0 $node006->addDefault($node011);
7120 0         0 $node007->addArrow($node007, 1, 0, 'ACCOUNT', \&collectAccount);
7121 0         0 $node007->addArrow($node013, 1, 1, 'ACCOUNT', \&collectAccount);
7122 0         0 $node008->addArrow($node013, 1, 0, 'ACTORGROUP', \&collectActorgroup);
7123 0         0 $node009->addArrow($node011, 1, 0, 'KEYPAIR', \&collectKeypair);
7124 0         0 $node010->addArrow($node011, 1, 0, 'ACTOR', \&collectActor);
7125 0         0 $node011->addArrow($node012, 1, 0, 'on');
7126 0         0 $node011->addDefault($node013);
7127 0         0 $node012->addArrow($node012, 1, 0, 'STORE', \&collectStore);
7128 0         0 $node012->addArrow($node013, 1, 0, 'STORE', \&collectStore);
7129             }
7130              
7131             sub collectAccount {
7132 0     0   0 my $o = shift;
7133 0         0 my $label = shift;
7134 0         0 my $value = shift;
7135              
7136 0         0 push @{$o->{accountTokens}}, $value;
  0         0  
7137             }
7138              
7139             sub collectActor {
7140 0     0   0 my $o = shift;
7141 0         0 my $label = shift;
7142 0         0 my $value = shift;
7143              
7144 0         0 $o->{actorHash} = $value;
7145             }
7146              
7147             sub collectActorgroup {
7148 0     0   0 my $o = shift;
7149 0         0 my $label = shift;
7150 0         0 my $value = shift;
7151              
7152 0         0 for my $member ($value->actorGroup->members) {
7153 0         0 my $actorOnStore = $member->actorOnStore;
7154 0         0 $o->addKnownPublicKey($actorOnStore->publicKey);
7155 0         0 push @{$o->{accountTokens}}, CDS::AccountToken->new($actorOnStore->store, $actorOnStore->publicKey->hash);
  0         0  
7156             }
7157             }
7158              
7159             sub collectKeypair {
7160 0     0   0 my $o = shift;
7161 0         0 my $label = shift;
7162 0         0 my $value = shift;
7163              
7164 0         0 $o->{keyPairToken} = $value;
7165 0         0 $o->{actorHash} = $value->keyPair->publicKey->hash;
7166             }
7167              
7168             sub collectStore {
7169 0     0   0 my $o = shift;
7170 0         0 my $label = shift;
7171 0         0 my $value = shift;
7172              
7173 0         0 push @{$o->{stores}}, $value;
  0         0  
7174             }
7175              
7176             sub new {
7177 0     0   0 my $class = shift;
7178 0         0 my $actor = shift;
7179 0         0 bless {actor => $actor, ui => $actor->ui} }
7180              
7181             # END AUTOGENERATED
7182              
7183             # HTML FOLDER NAME show-card
7184             # HTML TITLE Show an actor's public card
7185             sub help {
7186 0     0   0 my $o = shift;
7187 0         0 my $cmd = shift;
7188              
7189 0         0 my $ui = $o->{ui};
7190 0         0 $ui->space;
7191 0         0 $ui->command('cds show card of ACCOUNT');
7192 0         0 $ui->command('cds show card of ACTOR [on STORE]');
7193 0         0 $ui->command('cds show card of KEYPAIR [on STORE]');
7194 0         0 $ui->p('Shows the card(s) of an actor.');
7195 0         0 $ui->space;
7196 0         0 $ui->command('cds show card of ACTORGROUP');
7197 0         0 $ui->p('Shows all cards of an actor group.');
7198 0         0 $ui->space;
7199 0         0 $ui->command('cds show card');
7200 0         0 $ui->p('Shows the card of the selected actor on the selected store.');
7201 0         0 $ui->space;
7202 0         0 $ui->command('cds show my card');
7203 0         0 $ui->p('Shows your own card.');
7204 0         0 $ui->space;
7205 0         0 $ui->p('An actor usually has one card. If no cards are shown, the corresponding actor does not exist, is not using that store, or has not properly announced itself. Two cards may exist while the actor is updating its card. Such a state is temporary, but may exist for hours or days if the actor has intermittent network access. Three or more cards may point to an error in the way the actor updates his card, an error in the synchronization code (if the account is synchronized). Two or more cards may also occur naturally when stores are merged.');
7206 0         0 $ui->space;
7207 0         0 $ui->p('A peer consists of one or more actors, which all publish their own card. The cards are usually different, but should contain consistent information.');
7208 0         0 $ui->space;
7209 0         0 $ui->p('You can publish your own card (i.e. the card of your main key pair) using');
7210 0         0 $ui->p(' cds announce');
7211 0         0 $ui->space;
7212             }
7213              
7214             sub showCard {
7215 0     0   0 my $o = shift;
7216 0         0 my $cmd = shift;
7217              
7218 0         0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken;
7219 0         0 $o->{stores} = [];
7220 0         0 $o->{accountTokens} = [];
7221 0         0 $o->{knownPublicKeys} = {};
7222 0         0 $cmd->collect($o);
7223              
7224             # Use actorHash/store
7225 0 0       0 if (! scalar @{$o->{accountTokens}}) {
  0         0  
7226 0 0       0 $o->{actorHash} = $o->{actor}->preferredActorHash if ! $o->{actorHash};
7227 0 0       0 push @{$o->{stores}}, $o->{actor}->preferredStores if ! scalar @{$o->{stores}};
  0         0  
  0         0  
7228 0         0 for my $store (@{$o->{stores}}) {
  0         0  
7229 0         0 push @{$o->{accountTokens}}, CDS::AccountToken->new($store, $o->{actorHash});
  0         0  
7230             }
7231             }
7232              
7233             # Show the cards
7234 0         0 $o->addKnownPublicKey($o->{keyPairToken}->keyPair->publicKey);
7235 0         0 $o->addKnownPublicKey($o->{actor}->keyPair->publicKey);
7236 0         0 for my $accountToken (@{$o->{accountTokens}}) {
  0         0  
7237 0         0 $o->processAccount($accountToken);
7238             }
7239              
7240 0         0 $o->{ui}->space;
7241             }
7242              
7243             sub showMyCard {
7244 0     0   0 my $o = shift;
7245 0         0 my $cmd = shift;
7246              
7247 0         0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken;
7248 0         0 $o->processAccount(CDS::AccountToken->new($o->{actor}->messagingStore, $o->{actor}->keyPair->publicKey->hash));
7249 0 0       0 $o->processAccount(CDS::AccountToken->new($o->{actor}->storageStore, $o->{actor}->keyPair->publicKey->hash)) if $o->{actor}->storageStore->url ne $o->{actor}->messagingStore->url;
7250 0         0 $o->{ui}->space;
7251             }
7252              
7253             sub processAccount {
7254 0     0   0 my $o = shift;
7255 0         0 my $accountToken = shift;
7256              
7257 0         0 $o->{ui}->space;
7258              
7259             # Query the store
7260 0         0 my $store = $accountToken->cliStore;
7261 0         0 my ($hashes, $storeError) = $store->list($accountToken->actorHash, 'public', 0);
7262 0 0       0 if (defined $storeError) {
7263 0         0 $o->{ui}->title('public box of ', $o->{actor}->blueAccountReference($accountToken));
7264 0         0 return;
7265             }
7266              
7267             # Print the result
7268 0         0 my $count = scalar @$hashes;
7269 0 0       0 $o->{ui}->title('public box of ', $o->{actor}->blueAccountReference($accountToken), ' ', $o->{ui}->blue($count == 0 ? 'no cards' : $count == 1 ? '1 card' : $count.' cards'));
    0          
7270 0 0       0 return if ! $count;
7271              
7272 0         0 foreach my $hash (sort { $a->bytes cmp $b->bytes } @$hashes) {
  0         0  
7273 0         0 $o->processEntry($accountToken, $hash);
7274             }
7275             }
7276              
7277             sub processEntry {
7278 0     0   0 my $o = shift;
7279 0         0 my $accountToken = shift;
7280 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
7281              
7282 0         0 my $keyPair = $o->{keyPairToken}->keyPair;
7283 0         0 my $store = $accountToken->cliStore;
7284 0         0 my $storeReference = $o->{actor}->storeReference($store);
7285              
7286             # Open the envelope
7287 0         0 $o->{ui}->line($o->{ui}->gold('cds open envelope ', $hash->hex), $o->{ui}->gray(' from ', $accountToken->actorHash->hex, ' on ', $storeReference));
7288              
7289 0   0     0 my $envelope = $o->{actor}->uiGetRecord($hash, $accountToken->cliStore, $o->{keyPairToken}) // return;
7290 0   0     0 my $publicKey = $o->getPublicKey($accountToken) // $o->{ui}->pRed('The owner\'s public key is missing. Skipping signature verification.');
7291 0   0     0 my $cardHash = $envelope->child('content')->hashValue // $o->{ui}->pRed('Missing content hash.');
7292 0 0 0     0 return $o->{ui}->pRed('Invalid signature.') if $publicKey && $cardHash && ! CDS->verifyEnvelopeSignature($envelope, $publicKey, $cardHash);
      0        
7293              
7294             # Read and show the card
7295 0 0       0 return if ! $cardHash;
7296 0         0 $o->{ui}->line($o->{ui}->gold('cds show record ', $cardHash->hex), $o->{ui}->gray(' on ', $storeReference));
7297 0   0     0 my $card = $o->{actor}->uiGetRecord($cardHash, $accountToken->cliStore, $o->{keyPairToken}) // return;
7298              
7299 0         0 $o->{ui}->pushIndent;
7300 0         0 $o->{ui}->recordChildren($card, $storeReference);
7301 0         0 $o->{ui}->popIndent;
7302 0         0 return;
7303             }
7304              
7305             sub getPublicKey {
7306 0     0   0 my $o = shift;
7307 0         0 my $accountToken = shift;
7308              
7309 0         0 my $hash = $accountToken->actorHash;
7310 0         0 my $knownPublicKey = $o->{knownPublicKeys}->{$hash->bytes};
7311 0 0       0 return $knownPublicKey if $knownPublicKey;
7312 0   0     0 my $publicKey = $o->{actor}->uiGetPublicKey($hash, $accountToken->cliStore, $o->{keyPairToken}) // return;
7313 0         0 $o->addKnownPublicKey($publicKey);
7314 0         0 return $publicKey;
7315             }
7316              
7317             sub addKnownPublicKey {
7318 0     0   0 my $o = shift;
7319 0 0 0     0 my $publicKey = shift; die 'wrong type '.ref($publicKey).' for $publicKey' if defined $publicKey && ref $publicKey ne 'CDS::PublicKey';
  0         0  
7320              
7321 0         0 $o->{knownPublicKeys}->{$publicKey->hash->bytes} = $publicKey;
7322             }
7323              
7324             # BEGIN AUTOGENERATED
7325             package CDS::Commands::ShowKeyPair;
7326              
7327             sub register {
7328 0     0   0 my $class = shift;
7329 0         0 my $cds = shift;
7330 0         0 my $help = shift;
7331              
7332 0         0 my $node000 = CDS::Parser::Node->new(0);
7333 0         0 my $node001 = CDS::Parser::Node->new(0);
7334 0         0 my $node002 = CDS::Parser::Node->new(0);
7335 0         0 my $node003 = CDS::Parser::Node->new(0);
7336 0         0 my $node004 = CDS::Parser::Node->new(0);
7337 0         0 my $node005 = CDS::Parser::Node->new(0);
7338 0         0 my $node006 = CDS::Parser::Node->new(0);
7339 0         0 my $node007 = CDS::Parser::Node->new(0);
7340 0         0 my $node008 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
7341 0         0 my $node009 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showKeyPair});
7342 0         0 my $node010 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showMyKeyPair});
7343 0         0 my $node011 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showSelectedKeyPair});
7344 0         0 $cds->addArrow($node002, 1, 0, 'show');
7345 0         0 $cds->addArrow($node003, 1, 0, 'show');
7346 0         0 $cds->addArrow($node004, 1, 0, 'show');
7347 0         0 $help->addArrow($node000, 1, 0, 'show');
7348 0         0 $node000->addArrow($node001, 1, 0, 'key');
7349 0         0 $node001->addArrow($node008, 1, 0, 'pair');
7350 0         0 $node002->addArrow($node009, 1, 0, 'KEYPAIR', \&collectKeypair);
7351 0         0 $node003->addArrow($node005, 1, 0, 'my');
7352 0         0 $node004->addArrow($node006, 1, 0, 'key');
7353 0         0 $node005->addArrow($node007, 1, 0, 'key');
7354 0         0 $node006->addArrow($node011, 1, 0, 'pair');
7355 0         0 $node007->addArrow($node010, 1, 0, 'pair');
7356             }
7357              
7358             sub collectKeypair {
7359 0     0   0 my $o = shift;
7360 0         0 my $label = shift;
7361 0         0 my $value = shift;
7362              
7363 0         0 $o->{keyPairToken} = $value;
7364             }
7365              
7366             sub new {
7367 0     0   0 my $class = shift;
7368 0         0 my $actor = shift;
7369 0         0 bless {actor => $actor, ui => $actor->ui} }
7370              
7371             # END AUTOGENERATED
7372              
7373             # HTML FOLDER NAME show-key-pair
7374             # HTML TITLE Show key pair
7375             sub help {
7376 0     0   0 my $o = shift;
7377 0         0 my $cmd = shift;
7378              
7379 0         0 my $ui = $o->{ui};
7380 0         0 $ui->space;
7381 0         0 $ui->command('cds show KEYPAIR');
7382 0         0 $ui->command('cds show my key pair');
7383 0         0 $ui->command('cds show key pair');
7384 0         0 $ui->p('Shows information about KEYPAIR, your key pair, or the currently selected key pair (see "cds use …").');
7385 0         0 $ui->space;
7386             }
7387              
7388             sub showKeyPair {
7389 0     0   0 my $o = shift;
7390 0         0 my $cmd = shift;
7391              
7392 0         0 $cmd->collect($o);
7393 0         0 $o->showAll($o->{keyPairToken});
7394             }
7395              
7396             sub showMyKeyPair {
7397 0     0   0 my $o = shift;
7398 0         0 my $cmd = shift;
7399              
7400 0         0 $cmd->collect($o);
7401 0         0 $o->showAll($o->{actor}->keyPairToken);
7402             }
7403              
7404             sub showSelectedKeyPair {
7405 0     0   0 my $o = shift;
7406 0         0 my $cmd = shift;
7407              
7408 0         0 $cmd->collect($o);
7409 0         0 $o->showAll($o->{actor}->preferredKeyPairToken);
7410             }
7411              
7412             sub show {
7413 0     0   0 my $o = shift;
7414 0         0 my $keyPairToken = shift;
7415              
7416 0 0       0 $o->{ui}->line($o->{ui}->darkBold('File '), $keyPairToken->file) if defined $keyPairToken->file;
7417 0         0 $o->{ui}->line($o->{ui}->darkBold('Hash '), $keyPairToken->keyPair->publicKey->hash->hex);
7418             }
7419              
7420             sub showAll {
7421 0     0   0 my $o = shift;
7422 0         0 my $keyPairToken = shift;
7423              
7424 0         0 $o->{ui}->space;
7425 0         0 $o->{ui}->title('Key pair');
7426 0         0 $o->show($keyPairToken);
7427 0         0 $o->showPublicKeyObject($keyPairToken);
7428 0         0 $o->showPublicKey($keyPairToken);
7429 0         0 $o->showPrivateKey($keyPairToken);
7430 0         0 $o->{ui}->space;
7431             }
7432              
7433             sub showPublicKeyObject {
7434 0     0   0 my $o = shift;
7435 0         0 my $keyPairToken = shift;
7436              
7437 0         0 my $object = $keyPairToken->keyPair->publicKey->object;
7438 0         0 $o->{ui}->space;
7439 0         0 $o->{ui}->title('Public key object');
7440 0         0 $o->byteData(' ', $object->bytes);
7441             }
7442              
7443             sub showPublicKey {
7444 0     0   0 my $o = shift;
7445 0         0 my $keyPairToken = shift;
7446              
7447 0         0 my $rsaPublicKey = $keyPairToken->keyPair->publicKey->{rsaPublicKey};
7448 0         0 $o->{ui}->space;
7449 0         0 $o->{ui}->title('Public key');
7450 0         0 $o->byteData('e ', CDS::C::publicKeyE($rsaPublicKey));
7451 0         0 $o->byteData('n ', CDS::C::publicKeyN($rsaPublicKey));
7452             }
7453              
7454             sub showPrivateKey {
7455 0     0   0 my $o = shift;
7456 0         0 my $keyPairToken = shift;
7457              
7458 0         0 my $rsaPrivateKey = $keyPairToken->keyPair->{rsaPrivateKey};
7459 0         0 $o->{ui}->space;
7460 0         0 $o->{ui}->title('Private key');
7461 0         0 $o->byteData('e ', CDS::C::privateKeyE($rsaPrivateKey));
7462 0         0 $o->byteData('p ', CDS::C::privateKeyP($rsaPrivateKey));
7463 0         0 $o->byteData('q ', CDS::C::privateKeyQ($rsaPrivateKey));
7464             }
7465              
7466             sub byteData {
7467 0     0   0 my $o = shift;
7468 0         0 my $label = shift;
7469 0         0 my $bytes = shift;
7470              
7471 0         0 my $hex = unpack('H*', $bytes);
7472 0         0 $o->{ui}->line($o->{ui}->darkBold($label), substr($hex, 0, 64));
7473              
7474 0         0 my $start = 64;
7475 0         0 my $spaces = ' ' x length $label;
7476 0         0 while ($start < length $hex) {
7477 0         0 $o->{ui}->line($spaces, substr($hex, $start, 64));
7478 0         0 $start += 64;
7479             }
7480             }
7481              
7482             # BEGIN AUTOGENERATED
7483             package CDS::Commands::ShowMessages;
7484              
7485             sub register {
7486 0     0   0 my $class = shift;
7487 0         0 my $cds = shift;
7488 0         0 my $help = shift;
7489              
7490 0         0 my $node000 = CDS::Parser::Node->new(0);
7491 0         0 my $node001 = CDS::Parser::Node->new(0);
7492 0         0 my $node002 = CDS::Parser::Node->new(0);
7493 0         0 my $node003 = CDS::Parser::Node->new(0);
7494 0         0 my $node004 = CDS::Parser::Node->new(0);
7495 0         0 my $node005 = CDS::Parser::Node->new(0);
7496 0         0 my $node006 = CDS::Parser::Node->new(0);
7497 0         0 my $node007 = CDS::Parser::Node->new(0);
7498 0         0 my $node008 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
7499 0         0 my $node009 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showMessagesOfSelected});
7500 0         0 my $node010 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showMyMessages});
7501 0         0 my $node011 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showOurMessages});
7502 0         0 my $node012 = CDS::Parser::Node->new(1);
7503 0         0 my $node013 = CDS::Parser::Node->new(0);
7504 0         0 my $node014 = CDS::Parser::Node->new(0);
7505 0         0 my $node015 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showMessages});
7506 0         0 $cds->addArrow($node001, 1, 0, 'show');
7507 0         0 $cds->addArrow($node002, 1, 0, 'show');
7508 0         0 $cds->addArrow($node003, 1, 0, 'show');
7509 0         0 $cds->addArrow($node004, 1, 0, 'show');
7510 0         0 $help->addArrow($node000, 1, 0, 'show');
7511 0         0 $node000->addArrow($node008, 1, 0, 'messages');
7512 0         0 $node001->addArrow($node005, 1, 0, 'messages');
7513 0         0 $node002->addArrow($node006, 1, 0, 'my');
7514 0         0 $node003->addArrow($node009, 1, 0, 'messages');
7515 0         0 $node004->addArrow($node007, 1, 0, 'our');
7516 0         0 $node005->addArrow($node012, 1, 0, 'of');
7517 0         0 $node006->addArrow($node010, 1, 0, 'messages');
7518 0         0 $node007->addArrow($node011, 1, 0, 'messages');
7519 0         0 $node012->addArrow($node013, 1, 0, 'ACTOR', \&collectActor);
7520 0         0 $node012->addArrow($node013, 1, 0, 'KEYPAIR', \&collectKeypair);
7521 0         0 $node012->addArrow($node015, 1, 1, 'ACCOUNT', \&collectAccount);
7522 0         0 $node012->addArrow($node015, 1, 0, 'ACTOR', \&collectActor1);
7523 0         0 $node012->addArrow($node015, 1, 0, 'ACTORGROUP', \&collectActorgroup);
7524 0         0 $node012->addArrow($node015, 1, 0, 'KEYPAIR', \&collectKeypair1);
7525 0         0 $node013->addArrow($node014, 1, 0, 'on');
7526 0         0 $node014->addArrow($node015, 1, 0, 'STORE', \&collectStore);
7527             }
7528              
7529             sub collectAccount {
7530 0     0   0 my $o = shift;
7531 0         0 my $label = shift;
7532 0         0 my $value = shift;
7533              
7534 0         0 push @{$o->{accountTokens}}, $value;
  0         0  
7535             }
7536              
7537             sub collectActor {
7538 0     0   0 my $o = shift;
7539 0         0 my $label = shift;
7540 0         0 my $value = shift;
7541              
7542 0         0 $o->{actorHash} = $value;
7543             }
7544              
7545             sub collectActor1 {
7546 0     0   0 my $o = shift;
7547 0         0 my $label = shift;
7548 0         0 my $value = shift;
7549              
7550 0         0 push @{$o->{accountTokens}}, CDS::AccountToken->new($o->{actor}->preferredStore, $value);
  0         0  
7551             }
7552              
7553             sub collectActorgroup {
7554 0     0   0 my $o = shift;
7555 0         0 my $label = shift;
7556 0         0 my $value = shift;
7557              
7558 0         0 for my $member ($value->actorGroup->members) {
7559 0         0 push @{$o->{accountTokens}}, CDS::AccountToken->new($member->actorOnStore->store, $member->actorOnStore->publicKey->hash);
  0         0  
7560             }
7561             }
7562              
7563             sub collectKeypair {
7564 0     0   0 my $o = shift;
7565 0         0 my $label = shift;
7566 0         0 my $value = shift;
7567              
7568 0         0 $o->{keyPairToken} = $value;
7569 0         0 $o->{actorHash} = $value->keyPair->publicKey->hash;
7570             }
7571              
7572             sub collectKeypair1 {
7573 0     0   0 my $o = shift;
7574 0         0 my $label = shift;
7575 0         0 my $value = shift;
7576              
7577 0         0 $o->{keyPairToken} = $value;
7578 0         0 push @{$o->{accountTokens}}, CDS::AccountToken->new($o->{actor}->preferredStore, $value->publicKey->hash);
  0         0  
7579             }
7580              
7581             sub collectStore {
7582 0     0   0 my $o = shift;
7583 0         0 my $label = shift;
7584 0         0 my $value = shift;
7585              
7586 0         0 push @{$o->{accountTokens}}, CDS::AccountToken->new($value, $o->{actorHash});
  0         0  
7587 0         0 delete $o->{actorHash};
7588             }
7589              
7590             sub new {
7591 0     0   0 my $class = shift;
7592 0         0 my $actor = shift;
7593 0         0 bless {actor => $actor, ui => $actor->ui} }
7594              
7595             # END AUTOGENERATED
7596              
7597             # HTML FOLDER NAME show-messages
7598             # HTML TITLE Show messages
7599             sub help {
7600 0     0   0 my $o = shift;
7601 0         0 my $cmd = shift;
7602              
7603 0         0 my $ui = $o->{ui};
7604 0         0 $ui->space;
7605 0         0 $ui->command('cds show messages of ACCOUNT');
7606 0         0 $ui->command('cds show messages of ACTOR|KEYPAIR [on STORE]');
7607 0         0 $ui->p('Shows all (unprocessed) messages of an actor ordered by their envelope hash. If store is omitted, the selected store is used.');
7608 0         0 $ui->space;
7609 0         0 $ui->command('cds show messages of ACTORGROUP');
7610 0         0 $ui->p('Shows all messages of all actors of that group.');
7611 0         0 $ui->space;
7612 0         0 $ui->command('cds show messages');
7613 0         0 $ui->p('Shows the messages of the selected key pair on the selected store.');
7614 0         0 $ui->space;
7615 0         0 $ui->command('cds show my messages');
7616 0         0 $ui->p('Shows your messages.');
7617 0         0 $ui->space;
7618 0         0 $ui->command('cds show our messages');
7619 0         0 $ui->p('Shows all messages of your actor group.');
7620 0         0 $ui->space;
7621 0         0 $ui->p('Unprocessed messages are stored in the message box of an actor. Each entry points to an envelope, which in turn points to a record object. The envelope is signed by the sender, but does not hold any date. If the application relies on dates, it must include this date in the message.');
7622 0         0 $ui->space;
7623 0         0 $ui->p('While the envelope hash is stored on the actor\'s store, the envelope and the message are stored on the sender\'s store, and are downloaded from there. Depending on the reachability and responsiveness of that store, messages may not always be accessible.');
7624 0         0 $ui->space;
7625 0         0 $ui->p('Senders typically keep sent messages for about 10 days on their store. After that, the envelope hash may still be in the message box, but the actual message may have vanished.');
7626 0         0 $ui->space;
7627             }
7628              
7629             sub showMessagesOfSelected {
7630 0     0   0 my $o = shift;
7631 0         0 my $cmd = shift;
7632              
7633 0         0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken;
7634 0         0 $o->processAccounts(CDS::AccountToken->new($o->{actor}->preferredStore, $o->{actor}->preferredActorHash));
7635             }
7636              
7637             sub showMyMessages {
7638 0     0   0 my $o = shift;
7639 0         0 my $cmd = shift;
7640              
7641 0         0 $o->{keyPairToken} = $o->{actor}->keyPairToken;
7642 0         0 my $actorHash = $o->{actor}->keyPair->publicKey->hash;
7643 0         0 my $store = $o->{actor}->messagingStore;
7644 0         0 $o->processAccounts(CDS::AccountToken->new($store, $actorHash));
7645             }
7646              
7647             sub showOurMessages {
7648 0     0   0 my $o = shift;
7649 0         0 my $cmd = shift;
7650              
7651 0         0 $o->{keyPairToken} = $o->{actor}->keyPairToken;
7652              
7653 0         0 my @accountTokens;
7654 0         0 for my $child ($o->{actor}->actorGroupSelector->children) {
7655 0 0       0 next if $child->child('revoked')->isSet;
7656 0 0       0 next if ! $child->child('active')->isSet;
7657              
7658 0         0 my $record = $child->record;
7659 0   0     0 my $actorHash = $record->child('hash')->hashValue // next;
7660 0         0 my $storeUrl = $record->child('store')->textValue;
7661 0   0     0 my $store = $o->{actor}->storeForUrl($storeUrl) // next;
7662 0         0 push @accountTokens, CDS::AccountToken->new($store, $actorHash);
7663             }
7664              
7665 0         0 $o->processAccounts(@accountTokens);
7666             }
7667              
7668             sub showMessages {
7669 0     0   0 my $o = shift;
7670 0         0 my $cmd = shift;
7671              
7672 0         0 $o->{accountTokens} = [];
7673 0         0 $cmd->collect($o);
7674              
7675             # Unless a key pair was provided, use the selected key pair
7676 0 0       0 $o->{keyPairToken} = $o->{actor}->keyPairToken if ! $o->{keyPairToken};
7677              
7678 0         0 $o->processAccounts(@{$o->{accountTokens}});
  0         0  
7679             }
7680              
7681             sub processAccounts {
7682 0     0   0 my $o = shift;
7683              
7684             # Initialize the statistics
7685 0         0 $o->{countValid} = 0;
7686 0         0 $o->{countInvalid} = 0;
7687              
7688             # Show the messages of all selected accounts
7689 0         0 for my $accountToken (@_) {
7690 0         0 CDS::Commands::ShowMessages::ProcessAccount->new($o, $accountToken);
7691             }
7692              
7693             # Show the statistics
7694 0         0 $o->{ui}->space;
7695 0         0 $o->{ui}->title('Total');
7696 0 0       0 $o->{ui}->line(scalar @_, ' account', scalar @_ == 1 ? '' : 's');
7697 0 0       0 $o->{ui}->line($o->{countValid}, ' message', $o->{countValid} == 1 ? '' : 's');
7698 0 0       0 $o->{ui}->line($o->{countInvalid}, ' invalid message', $o->{countInvalid} == 1 ? '' : 's') if $o->{countInvalid};
    0          
7699 0         0 $o->{ui}->space;
7700             }
7701              
7702             package CDS::Commands::ShowMessages::ProcessAccount;
7703              
7704             sub new {
7705 0     0   0 my $class = shift;
7706 0         0 my $cmd = shift;
7707 0         0 my $accountToken = shift;
7708              
7709 0         0 my $o = bless {
7710             cmd => $cmd,
7711             accountToken => $accountToken,
7712             countValid => 0,
7713             countInvalid => 0,
7714             };
7715              
7716 0         0 $cmd->{ui}->space;
7717 0         0 $cmd->{ui}->title('Messages of ', $cmd->{actor}->blueAccountReference($accountToken));
7718              
7719             # Get the public key
7720 0   0     0 my $publicKey = $o->getPublicKey // return;
7721              
7722             # Read all messages
7723 0         0 my $publicKeyCache = CDS::PublicKeyCache->new(128);
7724 0         0 my $pool = CDS::MessageBoxReaderPool->new($cmd->{keyPairToken}->keyPair, $publicKeyCache, $o);
7725 0         0 my $reader = CDS::MessageBoxReader->new($pool, CDS::ActorOnStore->new($publicKey, $accountToken->cliStore));
7726 0         0 $reader->read;
7727              
7728 0 0       0 $cmd->{ui}->line($cmd->{ui}->gray('No messages.')) if $o->{countValid} + $o->{countInvalid} == 0;
7729             }
7730              
7731             sub getPublicKey {
7732 0     0   0 my $o = shift;
7733              
7734             # Use the keypair's public key if possible
7735 0 0       0 return $o->{cmd}->{keyPairToken}->keyPair->publicKey if $o->{accountToken}->actorHash->equals($o->{cmd}->{keyPairToken}->keyPair->publicKey->hash);
7736              
7737             # Retrieve the public key
7738 0         0 return $o->{cmd}->{actor}->uiGetPublicKey($o->{accountToken}->actorHash, $o->{accountToken}->cliStore, $o->{cmd}->{keyPairToken});
7739             }
7740              
7741             sub onMessageBoxVerifyStore {
7742 0     0   0 my $o = shift;
7743 0         0 my $senderStoreUrl = shift;
7744 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
7745 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
7746 0 0 0     0 my $senderHash = shift; die 'wrong type '.ref($senderHash).' for $senderHash' if defined $senderHash && ref $senderHash ne 'CDS::Hash';
  0         0  
7747              
7748 0         0 return $o->{cmd}->{actor}->storeForUrl($senderStoreUrl);
7749             }
7750              
7751             sub onMessageBoxEntry {
7752 0     0   0 my $o = shift;
7753 0         0 my $message = shift;
7754              
7755 0         0 $o->{countValid} += 1;
7756 0         0 $o->{cmd}->{countValid} += 1;
7757              
7758 0         0 my $ui = $o->{cmd}->{ui};
7759 0         0 my $sender = CDS::AccountToken->new($message->sender->store, $message->sender->publicKey->hash);
7760              
7761 0         0 $ui->space;
7762 0         0 $ui->title($message->source->hash->hex);
7763 0         0 $ui->line('from ', $o->{cmd}->{actor}->blueAccountReference($sender));
7764 0         0 $ui->line('for ', $o->{cmd}->{actor}->blueAccountReference($o->{accountToken}));
7765 0         0 $ui->space;
7766 0         0 $ui->recordChildren($message->content);
7767             }
7768              
7769             sub onMessageBoxInvalidEntry {
7770 0     0   0 my $o = shift;
7771 0 0 0     0 my $source = shift; die 'wrong type '.ref($source).' for $source' if defined $source && ref $source ne 'CDS::Source';
  0         0  
7772 0         0 my $reason = shift;
7773              
7774 0         0 $o->{countInvalid} += 1;
7775 0         0 $o->{cmd}->{countInvalid} += 1;
7776              
7777 0         0 my $ui = $o->{cmd}->{ui};
7778 0         0 my $hashHex = $source->hash->hex;
7779 0         0 my $storeReference = $o->{cmd}->{actor}->storeReference($o->{accountToken}->cliStore);
7780              
7781 0         0 $ui->space;
7782 0         0 $ui->title($hashHex);
7783 0         0 $ui->pOrange($reason);
7784 0         0 $ui->space;
7785 0         0 $ui->p('You may use the following commands to check out the envelope:');
7786 0         0 $ui->line($ui->gold(' cds open envelope ', $hashHex, ' on ', $storeReference));
7787 0         0 $ui->line($ui->gold(' cds show record ', $hashHex, ' on ', $storeReference));
7788 0         0 $ui->line($ui->gold(' cds show hashes and data of ', $hashHex, ' on ', $storeReference));
7789             }
7790              
7791             # BEGIN AUTOGENERATED
7792             package CDS::Commands::ShowObject;
7793              
7794             sub register {
7795 0     0   0 my $class = shift;
7796 0         0 my $cds = shift;
7797 0         0 my $help = shift;
7798              
7799 0         0 my $node000 = CDS::Parser::Node->new(0);
7800 0         0 my $node001 = CDS::Parser::Node->new(0);
7801 0         0 my $node002 = CDS::Parser::Node->new(0);
7802 0         0 my $node003 = CDS::Parser::Node->new(0);
7803 0         0 my $node004 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
7804 0         0 my $node005 = CDS::Parser::Node->new(1);
7805 0         0 my $node006 = CDS::Parser::Node->new(0);
7806 0         0 my $node007 = CDS::Parser::Node->new(0);
7807 0         0 my $node008 = CDS::Parser::Node->new(0);
7808 0         0 my $node009 = CDS::Parser::Node->new(0);
7809 0         0 my $node010 = CDS::Parser::Node->new(1);
7810 0         0 my $node011 = CDS::Parser::Node->new(0);
7811 0         0 my $node012 = CDS::Parser::Node->new(0);
7812 0         0 my $node013 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&show});
7813 0         0 $cds->addArrow($node000, 1, 0, 'show');
7814 0         0 $cds->addArrow($node001, 1, 0, 'show');
7815 0         0 $cds->addArrow($node003, 1, 0, 'show');
7816 0         0 $help->addArrow($node002, 1, 0, 'show');
7817 0         0 $node000->addArrow($node006, 1, 0, 'object', \&collectObject);
7818 0         0 $node001->addArrow($node006, 1, 0, 'record', \&collectRecord);
7819 0         0 $node002->addArrow($node004, 1, 0, 'bytes');
7820 0         0 $node002->addArrow($node004, 1, 0, 'data');
7821 0         0 $node002->addArrow($node004, 1, 0, 'hash');
7822 0         0 $node002->addArrow($node004, 1, 0, 'hashes');
7823 0         0 $node002->addArrow($node004, 1, 0, 'object');
7824 0         0 $node002->addArrow($node004, 1, 0, 'record');
7825 0         0 $node002->addArrow($node004, 1, 0, 'size');
7826 0         0 $node003->addArrow($node005, 1, 0, 'bytes', \&collectBytes);
7827 0         0 $node003->addArrow($node005, 1, 0, 'data', \&collectData);
7828 0         0 $node003->addArrow($node005, 1, 0, 'hash', \&collectHash);
7829 0         0 $node003->addArrow($node005, 1, 0, 'hashes', \&collectHashes);
7830 0         0 $node003->addArrow($node005, 1, 0, 'record', \&collectRecord);
7831 0         0 $node003->addArrow($node005, 1, 0, 'size', \&collectSize);
7832 0         0 $node005->addArrow($node003, 1, 0, 'and');
7833 0         0 $node005->addArrow($node006, 1, 0, 'of');
7834 0         0 $node006->addArrow($node007, 1, 0, 'HASH', \&collectHash1);
7835 0         0 $node006->addArrow($node010, 1, 1, 'FILE', \&collectFile);
7836 0         0 $node006->addArrow($node010, 1, 0, 'HASH', \&collectHash2);
7837 0         0 $node006->addArrow($node010, 1, 0, 'OBJECT', \&collectObject1);
7838 0         0 $node007->addArrow($node008, 1, 0, 'on');
7839 0         0 $node007->addArrow($node009, 0, 0, 'from');
7840 0         0 $node008->addArrow($node010, 1, 0, 'STORE', \&collectStore);
7841 0         0 $node009->addArrow($node010, 0, 0, 'STORE', \&collectStore);
7842 0         0 $node010->addArrow($node011, 1, 0, 'decrypted');
7843 0         0 $node010->addDefault($node013);
7844 0         0 $node011->addArrow($node012, 1, 0, 'with');
7845 0         0 $node012->addArrow($node013, 1, 0, 'AESKEY', \&collectAeskey);
7846             }
7847              
7848             sub collectAeskey {
7849 0     0   0 my $o = shift;
7850 0         0 my $label = shift;
7851 0         0 my $value = shift;
7852              
7853 0         0 $o->{aesKey} = $value;
7854             }
7855              
7856             sub collectBytes {
7857 0     0   0 my $o = shift;
7858 0         0 my $label = shift;
7859 0         0 my $value = shift;
7860              
7861 0         0 $o->{showBytes} = 1;
7862             }
7863              
7864             sub collectData {
7865 0     0   0 my $o = shift;
7866 0         0 my $label = shift;
7867 0         0 my $value = shift;
7868              
7869 0         0 $o->{showData} = 1;
7870             }
7871              
7872             sub collectFile {
7873 0     0   0 my $o = shift;
7874 0         0 my $label = shift;
7875 0         0 my $value = shift;
7876              
7877 0         0 $o->{file} = $value;
7878             }
7879              
7880             sub collectHash {
7881 0     0   0 my $o = shift;
7882 0         0 my $label = shift;
7883 0         0 my $value = shift;
7884              
7885 0         0 $o->{showHash} = 1;
7886             }
7887              
7888             sub collectHash1 {
7889 0     0   0 my $o = shift;
7890 0         0 my $label = shift;
7891 0         0 my $value = shift;
7892              
7893 0         0 $o->{hash} = $value;
7894             }
7895              
7896             sub collectHash2 {
7897 0     0   0 my $o = shift;
7898 0         0 my $label = shift;
7899 0         0 my $value = shift;
7900              
7901 0         0 $o->{hash} = $value;
7902 0         0 $o->{store} = $o->{actor}->preferredStore;
7903             }
7904              
7905             sub collectHashes {
7906 0     0   0 my $o = shift;
7907 0         0 my $label = shift;
7908 0         0 my $value = shift;
7909              
7910 0         0 $o->{showHashes} = 1;
7911             }
7912              
7913             sub collectObject {
7914 0     0   0 my $o = shift;
7915 0         0 my $label = shift;
7916 0         0 my $value = shift;
7917              
7918 0         0 $o->{showHashes} = 1;
7919 0         0 $o->{showData} = 1;
7920             }
7921              
7922             sub collectObject1 {
7923 0     0   0 my $o = shift;
7924 0         0 my $label = shift;
7925 0         0 my $value = shift;
7926              
7927 0         0 $o->{hash} = $value->hash;
7928 0         0 $o->{store} = $value->cliStore;
7929             }
7930              
7931             sub collectRecord {
7932 0     0   0 my $o = shift;
7933 0         0 my $label = shift;
7934 0         0 my $value = shift;
7935              
7936 0         0 $o->{showRecord} = 1;
7937             }
7938              
7939             sub collectSize {
7940 0     0   0 my $o = shift;
7941 0         0 my $label = shift;
7942 0         0 my $value = shift;
7943              
7944 0         0 $o->{showSize} = 1;
7945             }
7946              
7947             sub collectStore {
7948 0     0   0 my $o = shift;
7949 0         0 my $label = shift;
7950 0         0 my $value = shift;
7951              
7952 0         0 $o->{store} = $value;
7953             }
7954              
7955             sub new {
7956 0     0   0 my $class = shift;
7957 0         0 my $actor = shift;
7958 0         0 bless {actor => $actor, ui => $actor->ui} }
7959              
7960             # END AUTOGENERATED
7961              
7962             # HTML FOLDER NAME show-object
7963             # HTML TITLE Show objects
7964             sub help {
7965 0     0   0 my $o = shift;
7966 0         0 my $cmd = shift;
7967              
7968 0         0 my $ui = $o->{ui};
7969 0         0 $ui->space;
7970 0         0 $ui->command('cds show record OBJECT');
7971 0         0 $ui->command('cds show record HASH on STORE');
7972 0         0 $ui->p('Downloads an object, and shows the containing record. The stores are tried in the order they are indicated, until one succeeds. If the object is not found, or not a valid Condensation object, the program quits with exit code 1.');
7973 0         0 $ui->space;
7974 0         0 $ui->line('The following object properties can be displayed:');
7975 0         0 $ui->line(' cds show hash of …');
7976 0         0 $ui->line(' cds show size of …');
7977 0         0 $ui->line(' cds show bytes of …');
7978 0         0 $ui->line(' cds show hashes of …');
7979 0         0 $ui->line(' cds show data of …');
7980 0         0 $ui->line(' cds show record …');
7981 0         0 $ui->space;
7982 0         0 $ui->p('Multiple properties may be combined with "and", e.g.:');
7983 0         0 $ui->line(' cds show size and hashes and record of …');
7984 0         0 $ui->space;
7985 0         0 $ui->command('cds show record HASH');
7986 0         0 $ui->p('As above, but uses the selected store.');
7987 0         0 $ui->space;
7988 0         0 $ui->command('cds show record FILE');
7989 0         0 $ui->p('As above, but loads the object from FILE rather than from an object store.');
7990 0         0 $ui->space;
7991 0         0 $ui->command('… decrypted with AESKEY');
7992 0         0 $ui->p('Decrypts the object after retrieval.');
7993 0         0 $ui->space;
7994 0         0 $ui->command('cds show object …');
7995 0         0 $ui->p('A shortcut for "cds show hashes and data of …".');
7996 0         0 $ui->space;
7997 0         0 $ui->title('Related commands');
7998 0         0 $ui->line('cds get OBJECT [decrypted with AESKEY]');
7999 0         0 $ui->line('cds save [data of] OBJECT [decrypted with AESKEY] as FILE');
8000 0         0 $ui->line('cds open envelope OBJECT [on STORE] [using KEYPAIR]');
8001 0         0 $ui->line('cds show document OBJECT [on STORE]');
8002 0         0 $ui->space;
8003             }
8004              
8005             sub show {
8006 0     0   0 my $o = shift;
8007 0         0 my $cmd = shift;
8008              
8009 0         0 $cmd->collect($o);
8010              
8011             # Get and decrypt the object
8012 0 0       0 $o->{object} = defined $o->{file} ? $o->loadObjectFromFile : $o->loadObjectFromStore;
8013 0 0       0 return if ! $o->{object};
8014 0 0       0 $o->{object} = $o->{object}->crypt($o->{aesKey}) if defined $o->{aesKey};
8015              
8016             # Show the desired information
8017 0 0       0 $o->showHash if $o->{showHash};
8018 0 0       0 $o->showSize if $o->{showSize};
8019 0 0       0 $o->showBytes if $o->{showBytes};
8020 0 0       0 $o->showHashes if $o->{showHashes};
8021 0 0       0 $o->showData if $o->{showData};
8022 0 0       0 $o->showRecord if $o->{showRecord};
8023 0         0 $o->{ui}->space;
8024             }
8025              
8026             sub loadObjectFromFile {
8027 0     0   0 my $o = shift;
8028              
8029 0   0     0 my $bytes = CDS->readBytesFromFile($o->{file}) // return $o->{ui}->error('Unable to read "', $o->{file}, '".');
8030 0   0     0 return CDS::Object->fromBytes($bytes) // return $o->{ui}->error('"', $o->{file}, '" does not contain a valid Condensation object.');
8031             }
8032              
8033             sub loadObjectFromStore {
8034 0     0   0 my $o = shift;
8035              
8036 0         0 return $o->{actor}->uiGetObject($o->{hash}, $o->{store}, $o->{actor}->preferredKeyPairToken);
8037             }
8038              
8039             sub loadCommand {
8040 0     0   0 my $o = shift;
8041              
8042 0 0       0 my $decryption = defined $o->{aesKey} ? ' decrypted with '.unpack('H*', $o->{aesKey}) : '';
8043 0 0       0 return $o->{file}.$decryption if defined $o->{file};
8044 0         0 return $o->{hash}->hex.' on '.$o->{actor}->storeReference($o->{store}).$decryption;
8045             }
8046              
8047             sub showHash {
8048 0     0   0 my $o = shift;
8049              
8050 0         0 $o->{ui}->space;
8051 0         0 $o->{ui}->title('Object hash');
8052 0         0 $o->{ui}->line($o->{object}->calculateHash->hex);
8053             }
8054              
8055             sub showSize {
8056 0     0   0 my $o = shift;
8057              
8058 0         0 $o->{ui}->space;
8059 0         0 $o->{ui}->title('Object size');
8060 0         0 $o->{ui}->line($o->{ui}->niceFileSize(length $o->{object}->bytes), ' total (', length $o->{object}->bytes, ' bytes)');
8061 0         0 $o->{ui}->line($o->{object}->hashesCount, ' hashes (', length $o->{object}->header, ' bytes)');
8062 0         0 $o->{ui}->line($o->{ui}->niceFileSize(length $o->{object}->data), ' data (', length $o->{object}->data, ' bytes)');
8063             }
8064              
8065             sub showBytes {
8066 0     0   0 my $o = shift;
8067              
8068 0         0 $o->{ui}->space;
8069 0         0 my $bytes = $o->{object}->bytes;
8070 0         0 $o->{ui}->title('Object bytes (', $o->{ui}->niceFileSize(length $bytes), ')');
8071 0 0       0 return if ! length $bytes;
8072              
8073 0         0 my $hexDump = $o->{ui}->hexDump($bytes);
8074 0         0 my $dataStart = $hexDump->styleHashList(0);
8075 0 0       0 my $end = $dataStart ? $hexDump->styleRecord($dataStart) : 0;
8076 0         0 $hexDump->changeStyle({at => $end, style => $hexDump->reset});
8077 0         0 $hexDump->display;
8078             }
8079              
8080             sub showHashes {
8081 0     0   0 my $o = shift;
8082              
8083 0         0 $o->{ui}->space;
8084 0         0 my $hashesCount = $o->{object}->hashesCount;
8085 0 0       0 $o->{ui}->title($hashesCount == 1 ? '1 hash' : $hashesCount.' hashes');
8086 0         0 my $count = 0;
8087 0         0 for my $hash ($o->{object}->hashes) {
8088 0         0 $o->{ui}->line($o->{ui}->violet(unpack('H4', pack('S>', $count))), ' ', $hash->hex);
8089 0         0 $count += 1;
8090             }
8091             }
8092              
8093             sub showData {
8094 0     0   0 my $o = shift;
8095              
8096 0         0 $o->{ui}->space;
8097 0         0 my $data = $o->{object}->data;
8098 0         0 $o->{ui}->title('Data (', $o->{ui}->niceFileSize(length $data), ')');
8099 0 0       0 return if ! length $data;
8100              
8101 0         0 my $hexDump = $o->{ui}->hexDump($data);
8102 0         0 my $end = $hexDump->styleRecord(0);
8103 0         0 $hexDump->changeStyle({at => $end, style => $hexDump->reset});
8104 0         0 $hexDump->display;
8105             }
8106              
8107             sub showRecord {
8108 0     0   0 my $o = shift;
8109              
8110             # Title
8111 0         0 $o->{ui}->space;
8112 0         0 $o->{ui}->title('Data interpreted as record');
8113              
8114             # Empty object (empty record)
8115 0 0       0 return $o->{ui}->line($o->{ui}->gray('(empty record)')) if ! length $o->{object}->data;
8116              
8117             # Record
8118 0         0 my $record = CDS::Record->new;
8119 0         0 my $reader = CDS::RecordReader->new($o->{object});
8120 0         0 $reader->readChildren($record);
8121 0 0       0 if ($reader->hasError) {
8122 0         0 $o->{ui}->pRed('This is not a record.');
8123 0         0 $o->{ui}->space;
8124 0         0 $o->{ui}->p('You may use one of the following commands to check out the content:');
8125 0         0 $o->{ui}->line($o->{ui}->gold(' cds show object ', $o->loadCommand));
8126 0         0 $o->{ui}->line($o->{ui}->gold(' cds show data of ', $o->loadCommand));
8127 0         0 $o->{ui}->line($o->{ui}->gold(' cds save data of ', $o->loadCommand, ' as FILENAME'));
8128 0         0 return;
8129             }
8130              
8131 0 0       0 $o->{ui}->recordChildren($record, $o->{store} ? $o->{actor}->blueStoreReference($o->{store}) : '');
8132              
8133             # Trailer
8134 0         0 my $trailer = $reader->trailer;
8135 0 0       0 if (length $trailer) {
8136 0         0 $o->{ui}->space;
8137 0         0 $o->{ui}->pRed('This is probably not a record, because ', length $trailer, ' bytes remain behind the record. Use "cds show data of …" to investigate the raw object content. If this object is encrypted, provide the decryption key using "… and decrypted with KEY".');
8138 0         0 $o->{ui}->space;
8139             }
8140             }
8141              
8142             # BEGIN AUTOGENERATED
8143             package CDS::Commands::ShowPrivateData;
8144              
8145             sub register {
8146 0     0   0 my $class = shift;
8147 0         0 my $cds = shift;
8148 0         0 my $help = shift;
8149              
8150 0         0 my $node000 = CDS::Parser::Node->new(0);
8151 0         0 my $node001 = CDS::Parser::Node->new(0);
8152 0         0 my $node002 = CDS::Parser::Node->new(0);
8153 0         0 my $node003 = CDS::Parser::Node->new(0);
8154 0         0 my $node004 = CDS::Parser::Node->new(0);
8155 0         0 my $node005 = CDS::Parser::Node->new(0);
8156 0         0 my $node006 = CDS::Parser::Node->new(0);
8157 0         0 my $node007 = CDS::Parser::Node->new(0);
8158 0         0 my $node008 = CDS::Parser::Node->new(0);
8159 0         0 my $node009 = CDS::Parser::Node->new(0);
8160 0         0 my $node010 = CDS::Parser::Node->new(0);
8161 0         0 my $node011 = CDS::Parser::Node->new(0);
8162 0         0 my $node012 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
8163 0         0 my $node013 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showGroupData});
8164 0         0 my $node014 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showLocalData});
8165 0         0 my $node015 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showSentList});
8166 0         0 my $node016 = CDS::Parser::Node->new(0);
8167 0         0 my $node017 = CDS::Parser::Node->new(0);
8168 0         0 my $node018 = CDS::Parser::Node->new(0);
8169 0         0 my $node019 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showSentList});
8170 0         0 $cds->addArrow($node006, 1, 0, 'show');
8171 0         0 $cds->addArrow($node007, 1, 0, 'show');
8172 0         0 $cds->addArrow($node008, 1, 0, 'show');
8173 0         0 $help->addArrow($node000, 1, 0, 'show');
8174 0         0 $help->addArrow($node001, 1, 0, 'show');
8175 0         0 $help->addArrow($node002, 1, 0, 'show');
8176 0         0 $node000->addArrow($node003, 1, 0, 'group');
8177 0         0 $node001->addArrow($node004, 1, 0, 'local');
8178 0         0 $node002->addArrow($node005, 1, 0, 'sent');
8179 0         0 $node003->addArrow($node012, 1, 0, 'data');
8180 0         0 $node004->addArrow($node012, 1, 0, 'data');
8181 0         0 $node005->addArrow($node012, 1, 0, 'list');
8182 0         0 $node006->addArrow($node009, 1, 0, 'group');
8183 0         0 $node007->addArrow($node010, 1, 0, 'local');
8184 0         0 $node008->addArrow($node011, 1, 0, 'sent');
8185 0         0 $node009->addArrow($node013, 1, 0, 'data');
8186 0         0 $node010->addArrow($node014, 1, 0, 'data');
8187 0         0 $node011->addArrow($node015, 1, 0, 'list');
8188 0         0 $node015->addArrow($node016, 1, 0, 'ordered');
8189 0         0 $node016->addArrow($node017, 1, 0, 'by');
8190 0         0 $node017->addArrow($node018, 1, 0, 'envelope');
8191 0         0 $node017->addArrow($node019, 1, 0, 'date', \&collectDate);
8192 0         0 $node017->addArrow($node019, 1, 0, 'id', \&collectId);
8193 0         0 $node018->addArrow($node019, 1, 0, 'hash', \&collectHash);
8194             }
8195              
8196             sub collectDate {
8197 0     0   0 my $o = shift;
8198 0         0 my $label = shift;
8199 0         0 my $value = shift;
8200              
8201 0         0 $o->{orderedBy} = 'date';
8202             }
8203              
8204             sub collectHash {
8205 0     0   0 my $o = shift;
8206 0         0 my $label = shift;
8207 0         0 my $value = shift;
8208              
8209 0         0 $o->{orderedBy} = 'envelope hash';
8210             }
8211              
8212             sub collectId {
8213 0     0   0 my $o = shift;
8214 0         0 my $label = shift;
8215 0         0 my $value = shift;
8216              
8217 0         0 $o->{orderedBy} = 'id';
8218             }
8219              
8220             sub new {
8221 0     0   0 my $class = shift;
8222 0         0 my $actor = shift;
8223 0         0 bless {actor => $actor, ui => $actor->ui} }
8224              
8225             # END AUTOGENERATED
8226              
8227             # HTML FOLDER NAME show-private-data
8228             # HTML TITLE Show the private data
8229             sub help {
8230 0     0   0 my $o = shift;
8231 0         0 my $cmd = shift;
8232              
8233 0         0 my $ui = $o->{ui};
8234 0         0 $ui->space;
8235 0         0 $ui->command('cds show group data');
8236 0         0 $ui->p('Shows the group document. This document is shared among all group members.');
8237 0         0 $ui->space;
8238 0         0 $ui->command('cds show local data');
8239 0         0 $ui->p('Shows the local document. This document is stored locally, and private to this actor.');
8240 0         0 $ui->space;
8241 0         0 $ui->command('cds show sent list');
8242 0         0 $ui->p('Shows the list of sent messages with their expiry date, envelope hash, and content hash.');
8243 0         0 $ui->space;
8244 0         0 $ui->command('… ordered by id');
8245 0         0 $ui->command('… ordered by date');
8246 0         0 $ui->command('… ordered by envelope hash');
8247 0         0 $ui->p('Sorts the list accordingly. By default, the list is sorted by id.');
8248 0         0 $ui->space;
8249             }
8250              
8251             sub showGroupData {
8252 0     0   0 my $o = shift;
8253 0         0 my $cmd = shift;
8254              
8255 0         0 $o->{ui}->space;
8256 0         0 $o->{ui}->selector($o->{actor}->groupRoot, 'Group data');
8257 0         0 $o->{ui}->space;
8258             }
8259              
8260             sub showLocalData {
8261 0     0   0 my $o = shift;
8262 0         0 my $cmd = shift;
8263              
8264 0         0 $o->{ui}->space;
8265 0         0 $o->{ui}->selector($o->{actor}->localRoot, 'Local data');
8266 0         0 $o->{ui}->space;
8267             }
8268              
8269             sub showSentList {
8270 0     0   0 my $o = shift;
8271 0         0 my $cmd = shift;
8272              
8273 0         0 $o->{orderedBy} = 'id';
8274 0         0 $cmd->collect($o);
8275              
8276 0         0 $o->{ui}->space;
8277 0         0 $o->{ui}->title('Sent list');
8278              
8279 0   0     0 $o->{actor}->procureSentList // return;
8280 0         0 my $sentList = $o->{actor}->sentList;
8281 0         0 my @items = sort { $a->id cmp $b->id } values %{$sentList->{items}};
  0         0  
  0         0  
8282 0 0       0 @items = sort { $a->envelopeHashBytes cmp $b->envelopeHashBytes } @items if $o->{orderedBy} eq 'envelope hash';
  0         0  
8283 0 0       0 @items = sort { $a->validUntil <=> $b->validUntil } @items if $o->{orderedBy} eq 'date';
  0         0  
8284 0         0 my $noHash = '-' x 64;
8285 0         0 for my $item (@items) {
8286 0         0 my $id = $item->id;
8287 0         0 my $envelopeHash = $item->envelopeHash;
8288 0         0 my $message = $item->message;
8289 0         0 my $label = $o->{ui}->niceBytes($id, 32);
8290 0 0       0 $o->{ui}->line($o->{ui}->gray($o->{ui}->niceDateTimeLocal($item->validUntil)), ' ', $envelopeHash ? $envelopeHash->hex : $noHash, ' ', $o->{ui}->blue($label));
8291 0         0 $o->{ui}->recordChildren($message);
8292             }
8293              
8294 0         0 $o->{ui}->space;
8295             }
8296              
8297             # BEGIN AUTOGENERATED
8298             package CDS::Commands::ShowTree;
8299              
8300             sub register {
8301 0     0   0 my $class = shift;
8302 0         0 my $cds = shift;
8303 0         0 my $help = shift;
8304              
8305 0         0 my $node000 = CDS::Parser::Node->new(0);
8306 0         0 my $node001 = CDS::Parser::Node->new(0);
8307 0         0 my $node002 = CDS::Parser::Node->new(0);
8308 0         0 my $node003 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
8309 0         0 my $node004 = CDS::Parser::Node->new(0);
8310 0         0 my $node005 = CDS::Parser::Node->new(0);
8311 0         0 my $node006 = CDS::Parser::Node->new(0);
8312 0         0 my $node007 = CDS::Parser::Node->new(0);
8313 0         0 my $node008 = CDS::Parser::Node->new(0);
8314 0         0 my $node009 = CDS::Parser::Node->new(0);
8315 0         0 my $node010 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showTree});
8316 0         0 $cds->addArrow($node001, 1, 0, 'show');
8317 0         0 $cds->addArrow($node002, 0, 0, 'show');
8318 0         0 $help->addArrow($node000, 1, 0, 'show');
8319 0         0 $node000->addArrow($node003, 1, 0, 'tree');
8320 0         0 $node001->addArrow($node004, 1, 0, 'tree');
8321 0         0 $node002->addArrow($node004, 0, 0, 'trees');
8322 0         0 $node004->addDefault($node005);
8323 0         0 $node004->addDefault($node006);
8324 0         0 $node004->addDefault($node007);
8325 0         0 $node005->addArrow($node005, 1, 0, 'HASH', \&collectHash);
8326 0         0 $node005->addArrow($node010, 1, 0, 'HASH', \&collectHash);
8327 0         0 $node006->addArrow($node006, 1, 0, 'HASH', \&collectHash);
8328 0         0 $node006->addArrow($node008, 1, 0, 'HASH', \&collectHash);
8329 0         0 $node007->addArrow($node007, 1, 0, 'OBJECT', \&collectObject);
8330 0         0 $node007->addArrow($node010, 1, 0, 'OBJECT', \&collectObject);
8331 0         0 $node008->addArrow($node009, 1, 0, 'on');
8332 0         0 $node009->addArrow($node010, 1, 0, 'STORE', \&collectStore);
8333             }
8334              
8335             sub collectHash {
8336 0     0   0 my $o = shift;
8337 0         0 my $label = shift;
8338 0         0 my $value = shift;
8339              
8340 0         0 push @{$o->{hashes}}, $value;
  0         0  
8341             }
8342              
8343             sub collectObject {
8344 0     0   0 my $o = shift;
8345 0         0 my $label = shift;
8346 0         0 my $value = shift;
8347              
8348 0         0 push @{$o->{objectTokens}}, $value;
  0         0  
8349             }
8350              
8351             sub collectStore {
8352 0     0   0 my $o = shift;
8353 0         0 my $label = shift;
8354 0         0 my $value = shift;
8355              
8356 0         0 $o->{store} = $value;
8357             }
8358              
8359             sub new {
8360 0     0   0 my $class = shift;
8361 0         0 my $actor = shift;
8362 0         0 bless {actor => $actor, ui => $actor->ui} }
8363              
8364             # END AUTOGENERATED
8365              
8366             # HTML FOLDER NAME show-tree
8367             # HTML TITLE Show trees
8368             sub help {
8369 0     0   0 my $o = shift;
8370 0         0 my $cmd = shift;
8371              
8372 0         0 my $ui = $o->{ui};
8373 0         0 $ui->space;
8374 0         0 $ui->command('cds show tree OBJECT*');
8375 0         0 $ui->command('cds show tree HASH* on STORE');
8376 0         0 $ui->p('Downloads a tree, and shows the tree hierarchy. If an object has been traversed before, it is listed as "reported above".');
8377 0         0 $ui->space;
8378 0         0 $ui->command('cds show tree HASH*');
8379 0         0 $ui->p('As above, but uses the selected store.');
8380 0         0 $ui->space;
8381             }
8382              
8383             sub showTree {
8384 0     0   0 my $o = shift;
8385 0         0 my $cmd = shift;
8386              
8387 0         0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken;
8388 0         0 $o->{objectTokens} = [];
8389 0         0 $o->{hashes} = [];
8390 0         0 $cmd->collect($o);
8391              
8392             # Process all trees
8393 0         0 for my $objectToken (@{$o->{objectTokens}}) {
  0         0  
8394 0         0 $o->{ui}->space;
8395 0         0 $o->process($objectToken->hash, $objectToken->cliStore);
8396             }
8397              
8398 0 0       0 if (scalar @{$o->{hashes}}) {
  0         0  
8399 0   0     0 my $store = $o->{store} // $o->{actor}->preferredStore;
8400 0         0 for my $hash (@{$o->{hashes}}) {
  0         0  
8401 0         0 $o->{ui}->space;
8402 0         0 $o->process($hash, $store);
8403             }
8404             }
8405              
8406             # Report the total size
8407 0         0 my $totalSize = 0;
8408 0         0 my $totalDataSize = 0;
8409 0         0 map { $totalSize += $_->{size} ; $totalDataSize += $_->{dataSize} } values %{$o->{objects}};
  0         0  
  0         0  
  0         0  
8410 0         0 $o->{ui}->space;
8411 0         0 $o->{ui}->p(scalar keys %{$o->{objects}}, ' unique objects ', $o->{ui}->bold($o->{ui}->niceFileSize($totalSize)), $o->{ui}->gray(' (', $o->{ui}->niceFileSize($totalSize - $totalDataSize), ' header and ', $o->{ui}->niceFileSize($totalDataSize), ' data)'));
  0         0  
8412 0 0       0 $o->{ui}->pRed(scalar keys %{$o->{missingObjects}}, ' or more objects are missing') if scalar keys %{$o->{missingObjects}};
  0         0  
  0         0  
8413 0         0 $o->{ui}->space;
8414             }
8415              
8416             sub process {
8417 0     0   0 my $o = shift;
8418 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
8419 0         0 my $store = shift;
8420              
8421 0         0 my $hashHex = $hash->hex;
8422              
8423             # Check if we retrieved this object before
8424 0 0       0 if (exists $o->{objects}->{$hashHex}) {
8425 0         0 $o->{ui}->line($hash->hex, ' reported above') ;
8426 0         0 return 1;
8427             }
8428              
8429             # Retrieve the object
8430 0         0 my ($object, $storeError) = $store->get($hash, $o->{keyPairToken}->keyPair);
8431 0 0       0 return if defined $storeError;
8432              
8433 0 0       0 if (! $object) {
8434 0         0 $o->{missingObjects}->{$hashHex} = 1;
8435 0         0 return $o->{ui}->line($hashHex, ' ', $o->{ui}->red('is missing'));
8436             }
8437              
8438             # Display
8439 0         0 my $size = $object->byteLength;
8440 0         0 $o->{objects}->{$hashHex} = {size => $size, dataSize => length $object->data};
8441 0         0 $o->{ui}->line($hashHex, ' ', $o->{ui}->bold($o->{ui}->niceFileSize($size)), ' ', $o->{ui}->gray($object->hashesCount, ' hashes'));
8442              
8443             # Process all children
8444 0         0 $o->{ui}->pushIndent;
8445 0         0 foreach my $hash ($object->hashes) {
8446 0   0     0 $o->process($hash, $store) // return;
8447             }
8448 0         0 $o->{ui}->popIndent;
8449 0         0 return 1;
8450             }
8451              
8452             # BEGIN AUTOGENERATED
8453             package CDS::Commands::StartHTTPServer;
8454              
8455             sub register {
8456 0     0   0 my $class = shift;
8457 0         0 my $cds = shift;
8458 0         0 my $help = shift;
8459              
8460 0         0 my $node000 = CDS::Parser::Node->new(0);
8461 0         0 my $node001 = CDS::Parser::Node->new(0);
8462 0         0 my $node002 = CDS::Parser::Node->new(0);
8463 0         0 my $node003 = CDS::Parser::Node->new(0);
8464 0         0 my $node004 = CDS::Parser::Node->new(0);
8465 0         0 my $node005 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
8466 0         0 my $node006 = CDS::Parser::Node->new(0);
8467 0         0 my $node007 = CDS::Parser::Node->new(0);
8468 0         0 my $node008 = CDS::Parser::Node->new(0);
8469 0         0 my $node009 = CDS::Parser::Node->new(1);
8470 0         0 my $node010 = CDS::Parser::Node->new(0);
8471 0         0 my $node011 = CDS::Parser::Node->new(1);
8472 0         0 my $node012 = CDS::Parser::Node->new(0);
8473 0         0 my $node013 = CDS::Parser::Node->new(0);
8474 0         0 my $node014 = CDS::Parser::Node->new(0);
8475 0         0 my $node015 = CDS::Parser::Node->new(0);
8476 0         0 my $node016 = CDS::Parser::Node->new(1);
8477 0         0 my $node017 = CDS::Parser::Node->new(0);
8478 0         0 my $node018 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&startHttpServer});
8479 0         0 $cds->addArrow($node001, 1, 0, 'start');
8480 0         0 $help->addArrow($node000, 1, 0, 'http');
8481 0         0 $node000->addArrow($node005, 1, 0, 'server');
8482 0         0 $node001->addArrow($node002, 1, 0, 'http');
8483 0         0 $node002->addArrow($node003, 1, 0, 'server');
8484 0         0 $node003->addArrow($node004, 1, 0, 'for');
8485 0         0 $node004->addArrow($node006, 1, 0, 'STORE', \&collectStore);
8486 0         0 $node006->addArrow($node007, 1, 0, 'on');
8487 0         0 $node007->addArrow($node008, 1, 0, 'port');
8488 0         0 $node008->addArrow($node009, 1, 0, 'PORT', \&collectPort);
8489 0         0 $node009->addArrow($node010, 1, 0, 'at');
8490 0         0 $node009->addDefault($node011);
8491 0         0 $node010->addArrow($node011, 1, 0, 'TEXT', \&collectText);
8492 0         0 $node011->addArrow($node012, 1, 0, 'with');
8493 0         0 $node011->addDefault($node016);
8494 0         0 $node012->addArrow($node013, 1, 0, 'static');
8495 0         0 $node013->addArrow($node014, 1, 0, 'files');
8496 0         0 $node014->addArrow($node015, 1, 0, 'from');
8497 0         0 $node015->addArrow($node016, 1, 0, 'FOLDER', \&collectFolder);
8498 0         0 $node016->addArrow($node017, 1, 0, 'for');
8499 0         0 $node016->addDefault($node018);
8500 0         0 $node017->addArrow($node018, 1, 0, 'everybody', \&collectEverybody);
8501             }
8502              
8503             sub collectEverybody {
8504 0     0   0 my $o = shift;
8505 0         0 my $label = shift;
8506 0         0 my $value = shift;
8507              
8508 0         0 $o->{corsAllowEverybody} = 1;
8509             }
8510              
8511             sub collectFolder {
8512 0     0   0 my $o = shift;
8513 0         0 my $label = shift;
8514 0         0 my $value = shift;
8515              
8516 0         0 $o->{staticFolder} = $value;
8517             }
8518              
8519             sub collectPort {
8520 0     0   0 my $o = shift;
8521 0         0 my $label = shift;
8522 0         0 my $value = shift;
8523              
8524 0         0 $o->{port} = $value;
8525             }
8526              
8527             sub collectStore {
8528 0     0   0 my $o = shift;
8529 0         0 my $label = shift;
8530 0         0 my $value = shift;
8531              
8532 0         0 $o->{store} = $value;
8533             }
8534              
8535             sub collectText {
8536 0     0   0 my $o = shift;
8537 0         0 my $label = shift;
8538 0         0 my $value = shift;
8539              
8540 0         0 $o->{root} = $value;
8541             }
8542              
8543             sub new {
8544 0     0   0 my $class = shift;
8545 0         0 my $actor = shift;
8546 0         0 bless {actor => $actor, ui => $actor->ui} }
8547              
8548             # END AUTOGENERATED
8549              
8550             # HTML FOLDER NAME start-http-server
8551             # HTML TITLE HTTP store server
8552             sub help {
8553 0     0   0 my $o = shift;
8554 0         0 my $cmd = shift;
8555              
8556 0         0 my $ui = $o->{ui};
8557 0         0 $ui->space;
8558 0         0 $ui->command('cds start http server for STORE on port PORT');
8559 0         0 $ui->p('Starts a simple HTTP server listening on port PORT. The server handles requests within /objects and /accounts, and uses STORE as backend. Requests on the root URL (/) deliver a short message.');
8560 0         0 $ui->p('You may need superuser (root) privileges to use the default HTTP port 80.');
8561 0         0 $ui->p('This server is very useful for small to medium-size projects, but not particularly efficient for large-scale applications. It makes no effort to use DMA or similar features to speed up delivery, and handles only one request at a time (single-threaded). However, when using a front-end web server with load-balancing capabilities, multiple HTTP servers for the same store may be started to handle multiple requests in parallel.');
8562 0         0 $ui->space;
8563 0         0 $ui->command('… at TEXT');
8564 0         0 $ui->p('As above, but makes the store accessible at /TEXT/objects and /TEXT/accounts.');
8565 0         0 $ui->space;
8566 0         0 $ui->command('… with static files from FOLDER');
8567 0         0 $ui->p('Delivers static files from FOLDER for URLs outside of /objects and /accounts. This is useful for self-contained web apps.');
8568 0         0 $ui->space;
8569 0         0 $ui->command('… for everybody');
8570 0         0 $ui->p('Sets CORS headers to allow everybody to access the store from within a web browser.');
8571 0         0 $ui->space;
8572 0         0 $ui->p('For more options, write a Perl script instantiating and configuring a CDS::HTTPServer.');
8573 0         0 $ui->space;
8574             }
8575              
8576             sub startHttpServer {
8577 0     0   0 my $o = shift;
8578 0         0 my $cmd = shift;
8579              
8580 0         0 $cmd->collect($o);
8581              
8582 0         0 my $httpServer = CDS::HTTPServer->new($o->{port});
8583 0         0 $httpServer->setLogger(CDS::Commands::StartHTTPServer::Logger->new($o->{ui}));
8584 0         0 $httpServer->setCorsAllowEverybody($o->{corsAllowEverybody});
8585 0   0     0 $httpServer->addHandler(CDS::HTTPServer::StoreHandler->new($o->{root} // '/', $o->{store}));
8586 0 0 0     0 $httpServer->addHandler(CDS::HTTPServer::IdentificationHandler->new($o->{root} // '/')) if ! defined $o->{staticFolder};
8587 0 0       0 $httpServer->addHandler(CDS::HTTPServer::StaticFilesHandler->new('/', $o->{staticFolder}, 'index.html')) if defined $o->{staticFolder};
8588 0         0 eval { $httpServer->run; };
  0         0  
8589 0 0       0 if ($@) {
8590 0         0 my $error = $@;
8591 0 0       0 $error = $1 if $error =~ /^(.*?)( at |\n)/;
8592 0         0 $o->{ui}->space;
8593 0         0 $o->{ui}->p('Failed to run server on port '.$o->{port}.': '.$error);
8594 0         0 $o->{ui}->space;
8595             }
8596             }
8597              
8598             package CDS::Commands::StartHTTPServer::Logger;
8599              
8600             sub new {
8601 0     0   0 my $class = shift;
8602 0         0 my $ui = shift;
8603              
8604 0         0 return bless {ui => $ui};
8605             }
8606              
8607             sub onServerStarts {
8608 0     0   0 my $o = shift;
8609 0         0 my $port = shift;
8610              
8611 0         0 my $ui = $o->{ui};
8612 0         0 $ui->space;
8613 0         0 $ui->line($o->{ui}->gray($ui->niceDateTimeLocal), ' ', $ui->green('Server ready at http://localhost:', $port));
8614             }
8615              
8616             sub onRequestStarts {
8617 0     0   0 my $o = shift;
8618 0         0 my $request = shift;
8619             }
8620              
8621             sub onRequestError {
8622 0     0   0 my $o = shift;
8623 0         0 my $request = shift;
8624              
8625 0         0 my $ui = $o->{ui};
8626 0         0 $ui->line($o->{ui}->gray($ui->niceDateTimeLocal), ' ', $ui->blue($ui->left(15, $request->peerAddress)), ' ', $request->method, ' ', $request->path, ' ', $ui->red(@_));
8627             }
8628              
8629             sub onRequestDone {
8630 0     0   0 my $o = shift;
8631 0         0 my $request = shift;
8632 0         0 my $responseCode = shift;
8633              
8634 0         0 my $ui = $o->{ui};
8635 0         0 $ui->line($o->{ui}->gray($ui->niceDateTimeLocal), ' ', $ui->blue($ui->left(15, $request->peerAddress)), ' ', $request->method, ' ', $request->path, ' ', $ui->bold($responseCode));
8636             }
8637              
8638             # BEGIN AUTOGENERATED
8639             package CDS::Commands::Transfer;
8640              
8641             sub register {
8642 0     0   0 my $class = shift;
8643 0         0 my $cds = shift;
8644 0         0 my $help = shift;
8645              
8646 0         0 my $node000 = CDS::Parser::Node->new(0);
8647 0         0 my $node001 = CDS::Parser::Node->new(0);
8648 0         0 my $node002 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
8649 0         0 my $node003 = CDS::Parser::Node->new(0);
8650 0         0 my $node004 = CDS::Parser::Node->new(0);
8651 0         0 my $node005 = CDS::Parser::Node->new(0);
8652 0         0 my $node006 = CDS::Parser::Node->new(0);
8653 0         0 my $node007 = CDS::Parser::Node->new(0);
8654 0         0 my $node008 = CDS::Parser::Node->new(0);
8655 0         0 my $node009 = CDS::Parser::Node->new(0);
8656 0         0 my $node010 = CDS::Parser::Node->new(1);
8657 0         0 my $node011 = CDS::Parser::Node->new(0);
8658 0         0 my $node012 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&transfer});
8659 0         0 $cds->addArrow($node000, 1, 0, 'thoroughly');
8660 0         0 $cds->addArrow($node001, 0, 0, 'leniently');
8661 0         0 $cds->addDefault($node003);
8662 0         0 $cds->addArrow($node003, 1, 0, 'leniently', \&collectLeniently);
8663 0         0 $cds->addArrow($node003, 1, 0, 'thoroughly', \&collectThoroughly);
8664 0         0 $help->addArrow($node002, 1, 0, 'transfer');
8665 0         0 $node000->addArrow($node003, 1, 0, 'leniently', \&collectLeniently1);
8666 0         0 $node001->addArrow($node003, 0, 0, 'thoroughly', \&collectLeniently1);
8667 0         0 $node003->addArrow($node004, 1, 0, 'transfer');
8668 0         0 $node004->addDefault($node005);
8669 0         0 $node004->addDefault($node006);
8670 0         0 $node004->addDefault($node007);
8671 0         0 $node005->addArrow($node005, 1, 0, 'HASH', \&collectHash);
8672 0         0 $node005->addArrow($node010, 1, 0, 'HASH', \&collectHash);
8673 0         0 $node006->addArrow($node006, 1, 0, 'OBJECT', \&collectObject);
8674 0         0 $node006->addArrow($node010, 1, 0, 'OBJECT', \&collectObject);
8675 0         0 $node007->addArrow($node007, 1, 0, 'HASH', \&collectHash);
8676 0         0 $node007->addArrow($node008, 1, 0, 'HASH', \&collectHash);
8677 0         0 $node008->addArrow($node009, 1, 0, 'from');
8678 0         0 $node009->addArrow($node010, 1, 0, 'STORE', \&collectStore);
8679 0         0 $node010->addArrow($node011, 1, 0, 'to');
8680 0         0 $node011->addArrow($node011, 1, 0, 'STORE', \&collectStore1);
8681 0         0 $node011->addArrow($node012, 1, 0, 'STORE', \&collectStore1);
8682             }
8683              
8684             sub collectHash {
8685 0     0   0 my $o = shift;
8686 0         0 my $label = shift;
8687 0         0 my $value = shift;
8688              
8689 0         0 push @{$o->{hashes}}, $value;
  0         0  
8690             }
8691              
8692             sub collectLeniently {
8693 0     0   0 my $o = shift;
8694 0         0 my $label = shift;
8695 0         0 my $value = shift;
8696              
8697 0         0 $o->{leniently} = 1;
8698             }
8699              
8700             sub collectLeniently1 {
8701 0     0   0 my $o = shift;
8702 0         0 my $label = shift;
8703 0         0 my $value = shift;
8704              
8705 0         0 $o->{leniently} = 1;
8706 0         0 $o->{thoroughly} = 1;
8707             }
8708              
8709             sub collectObject {
8710 0     0   0 my $o = shift;
8711 0         0 my $label = shift;
8712 0         0 my $value = shift;
8713              
8714 0         0 push @{$o->{objectTokens}}, $value;
  0         0  
8715             }
8716              
8717             sub collectStore {
8718 0     0   0 my $o = shift;
8719 0         0 my $label = shift;
8720 0         0 my $value = shift;
8721              
8722 0         0 $o->{fromStore} = $value;
8723             }
8724              
8725             sub collectStore1 {
8726 0     0   0 my $o = shift;
8727 0         0 my $label = shift;
8728 0         0 my $value = shift;
8729              
8730 0         0 push @{$o->{toStores}}, $value;
  0         0  
8731             }
8732              
8733             sub collectThoroughly {
8734 0     0   0 my $o = shift;
8735 0         0 my $label = shift;
8736 0         0 my $value = shift;
8737              
8738 0         0 $o->{thoroughly} = 1;
8739             }
8740              
8741             sub new {
8742 0     0   0 my $class = shift;
8743 0         0 my $actor = shift;
8744 0         0 bless {actor => $actor, ui => $actor->ui} }
8745              
8746             # END AUTOGENERATED
8747              
8748             # HTML FOLDER NAME transfer
8749             # HTML TITLE Transfer
8750             sub help {
8751 0     0   0 my $o = shift;
8752 0         0 my $cmd = shift;
8753              
8754 0         0 my $ui = $o->{ui};
8755 0         0 $ui->space;
8756 0         0 $ui->command('cds transfer OBJECT* to STORE*');
8757 0         0 $ui->command('cds transfer HASH* from STORE to STORE*');
8758 0         0 $ui->p('Copies a tree from one store to another.');
8759 0         0 $ui->space;
8760 0         0 $ui->command('cds transfer HASH* to STORE*');
8761 0         0 $ui->p('As above, but uses the selected store as source store.');
8762 0         0 $ui->space;
8763 0         0 $ui->command('cds ', $ui->underlined('leniently'), ' transfer …');
8764 0         0 $ui->p('Warns about missing objects, but ignores them and proceeds with the rest.');
8765 0         0 $ui->space;
8766 0         0 $ui->command('cds ', $ui->underlined('thoroughly'), ' transfer …');
8767 0         0 $ui->p('Check subtrees of objects existing at the destination. This may be used to fix missing objects on the destination store.');
8768 0         0 $ui->space;
8769             }
8770              
8771             sub transfer {
8772 0     0   0 my $o = shift;
8773 0         0 my $cmd = shift;
8774              
8775 0         0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken;
8776 0         0 $o->{objectTokens} = [];
8777 0         0 $o->{hashes} = [];
8778 0         0 $o->{toStores} = [];
8779 0         0 $cmd->collect($o);
8780              
8781             # Use the selected store
8782 0 0 0     0 $o->{fromStore} = $o->{actor}->preferredStore if scalar @{$o->{hashes}} && ! $o->{fromStore};
  0         0  
8783              
8784             # Prepare the destination stores
8785 0         0 my $toStores = [];
8786 0         0 for my $toStore (@{$o->{toStores}}) {
  0         0  
8787 0         0 push @$toStores, {store => $toStore, storeError => undef, needed => [1]};
8788             }
8789              
8790             # Print the stores
8791 0         0 $o->{ui}->space;
8792 0         0 my $n = scalar @$toStores;
8793 0         0 for my $i (0 .. $n - 1) {
8794 0         0 my $toStore = $toStores->[$i];
8795 0         0 $o->{ui}->line($o->{ui}->gray(' │' x $i, ' ┌', '──' x ($n - $i), ' ', $toStore->{store}->url));
8796             }
8797              
8798             # Process all trees
8799 0         0 $o->{objects} = {};
8800 0         0 $o->{missingObjects} = {};
8801 0         0 for my $objectToken (@{$o->{objectTokens}}) {
  0         0  
8802 0         0 $o->{ui}->line($o->{ui}->gray(' │' x $n));
8803 0         0 $o->process($objectToken->hash, $objectToken->cliStore, $toStores, 1);
8804             }
8805 0         0 for my $hash (@{$o->{hashes}}) {
  0         0  
8806 0         0 $o->{ui}->line($o->{ui}->gray(' │' x $n));
8807 0         0 $o->process($hash, $o->{fromStore}, $toStores, 1);
8808             }
8809              
8810             # Print the stores again, with their errors
8811 0         0 $o->{ui}->line($o->{ui}->gray(' │' x $n));
8812 0         0 for my $i (reverse 0 .. $n - 1) {
8813 0         0 my $toStore = $toStores->[$i];
8814 0 0       0 $o->{ui}->line($o->{ui}->gray(' │' x $i, ' â””', '──' x ($n - $i), ' ', $toStore->{store}->url), ' ', defined $toStore->{storeError} ? $o->{ui}->red($toStore->{storeError}) : '');
8815             }
8816              
8817             # Report the total size
8818 0         0 my $totalSize = 0;
8819 0         0 my $totalDataSize = 0;
8820 0         0 map { $totalSize += $_->{size} ; $totalDataSize += $_->{dataSize} } values %{$o->{objects}};
  0         0  
  0         0  
  0         0  
8821 0         0 $o->{ui}->space;
8822 0         0 $o->{ui}->p(scalar keys %{$o->{objects}}, ' unique objects ', $o->{ui}->bold($o->{ui}->niceFileSize($totalSize)), ' ', $o->{ui}->gray($o->{ui}->niceFileSize($totalDataSize), ' data'));
  0         0  
8823 0 0       0 $o->{ui}->pOrange(scalar keys %{$o->{missingObjects}}, ' or more objects are missing') if scalar keys %{$o->{missingObjects}};
  0         0  
  0         0  
8824 0         0 $o->{ui}->space;
8825             }
8826              
8827             sub process {
8828 0     0   0 my $o = shift;
8829 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
8830 0         0 my $fromStore = shift;
8831 0         0 my $toStores = shift;
8832 0         0 my $depth = shift;
8833              
8834 0         0 my $hashHex = $hash->hex;
8835 0         0 my $keyPair = $o->{keyPairToken}->keyPair;
8836              
8837             # Check if we retrieved this object before
8838 0 0       0 if (exists $o->{objects}->{$hashHex}) {
8839 0         0 $o->report($hash->hex, $toStores, $depth, $o->{ui}->green('copied before'));
8840 0         0 return 1;
8841             }
8842              
8843             # Try to book the object on all active stores
8844 0         0 my $countNeeded = 0;
8845 0         0 my $hasActiveStore = 0;
8846 0         0 for my $toStore (@$toStores) {
8847 0 0       0 next if defined $toStore->{storeError};
8848 0         0 $hasActiveStore = 1;
8849 0 0 0     0 next if ! $o->{thoroughly} && ! $toStore->{needed}->[$depth - 1];
8850              
8851 0         0 my ($found, $bookError) = $toStore->{store}->book($hash);
8852 0 0       0 if (defined $bookError) {
8853 0         0 $toStore->{storeError} = $bookError;
8854 0         0 next;
8855             }
8856              
8857 0 0       0 next if $found;
8858 0         0 $toStore->{needed}->[$depth] = 1;
8859 0         0 $countNeeded += 1;
8860             }
8861              
8862             # Return if all stores reported an error
8863 0 0       0 return if ! $hasActiveStore;
8864              
8865             # Ignore existing subtrees at the destination unless "thoroughly" is set
8866 0 0 0     0 if (! $o->{thoroughly} && ! $countNeeded) {
8867 0         0 $o->report($hashHex, $toStores, $depth, $o->{ui}->gray('skipping subtree'));
8868 0         0 return 1;
8869             }
8870              
8871             # Retrieve the object
8872 0         0 my ($object, $getError) = $fromStore->get($hash, $keyPair);
8873 0 0       0 return if defined $getError;
8874              
8875 0 0       0 if (! defined $object) {
8876 0         0 $o->{missingObjects}->{$hashHex} = 1;
8877 0         0 $o->report($hashHex, $toStores, $depth, $o->{ui}->orange('is missing'));
8878 0 0       0 return if ! $o->{leniently};
8879             }
8880              
8881             # Display
8882 0         0 my $size = $object->byteLength;
8883 0         0 $o->{objects}->{$hashHex} = {needed => $countNeeded, size => $size, dataSize => length $object->data};
8884 0         0 $o->report($hashHex, $toStores, $depth, $o->{ui}->bold($o->{ui}->niceFileSize($size)), ' ', $o->{ui}->gray($object->hashesCount, ' hashes'));
8885              
8886             # Process all children
8887 0         0 foreach my $hash ($object->hashes) {
8888 0   0     0 $o->process($hash, $fromStore, $toStores, $depth + 1) // return;
8889             }
8890              
8891             # Write the object to all active stores
8892 0         0 for my $toStore (@$toStores) {
8893 0 0       0 next if defined $toStore->{storeError};
8894 0 0       0 next if ! $toStore->{needed}->[$depth];
8895 0         0 my $putError = $toStore->{store}->put($hash, $object, $keyPair);
8896 0 0       0 $toStore->{storeError} = $putError if $putError;
8897             }
8898              
8899 0         0 return 1;
8900             }
8901              
8902             sub report {
8903 0     0   0 my $o = shift;
8904 0         0 my $hashHex = shift;
8905 0         0 my $toStores = shift;
8906 0         0 my $depth = shift;
8907              
8908 0         0 my @text;
8909 0         0 for my $toStore (@$toStores) {
8910 0 0       0 if ($toStore->{storeError}) {
    0          
8911 0         0 push @text, $o->{ui}->red(' ⨯');
8912             } elsif ($toStore->{needed}->[$depth]) {
8913 0         0 push @text, $o->{ui}->green(' +');
8914             } else {
8915 0         0 push @text, $o->{ui}->green(' ‒');
8916             }
8917             }
8918              
8919 0         0 push @text, ' ', ' ' x ($depth - 1), $hashHex;
8920 0         0 push @text, ' ', @_;
8921 0         0 $o->{ui}->line(@text);
8922             }
8923              
8924             # BEGIN AUTOGENERATED
8925             package CDS::Commands::UseCache;
8926              
8927             sub register {
8928 0     0   0 my $class = shift;
8929 0         0 my $cds = shift;
8930 0         0 my $help = shift;
8931              
8932 0         0 my $node000 = CDS::Parser::Node->new(0);
8933 0         0 my $node001 = CDS::Parser::Node->new(0);
8934 0         0 my $node002 = CDS::Parser::Node->new(0);
8935 0         0 my $node003 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
8936 0         0 my $node004 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&useCache});
8937 0         0 my $node005 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&dropCache});
8938 0         0 my $node006 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&cache});
8939 0         0 $cds->addArrow($node000, 1, 0, 'use');
8940 0         0 $cds->addArrow($node002, 1, 0, 'drop');
8941 0         0 $cds->addArrow($node006, 1, 0, 'cache');
8942 0         0 $help->addArrow($node003, 1, 0, 'cache');
8943 0         0 $node000->addArrow($node001, 1, 0, 'cache');
8944 0         0 $node001->addArrow($node004, 1, 0, 'STORE', \&collectStore);
8945 0         0 $node002->addArrow($node005, 1, 0, 'cache');
8946             }
8947              
8948             sub collectStore {
8949 0     0   0 my $o = shift;
8950 0         0 my $label = shift;
8951 0         0 my $value = shift;
8952              
8953 0         0 $o->{store} = $value;
8954             }
8955              
8956             sub new {
8957 0     0   0 my $class = shift;
8958 0         0 my $actor = shift;
8959 0         0 bless {actor => $actor, ui => $actor->ui} }
8960              
8961             # END AUTOGENERATED
8962              
8963             # HTML FOLDER NAME use-cache
8964             # HTML TITLE Using a cache store
8965             sub help {
8966 0     0   0 my $o = shift;
8967 0         0 my $cmd = shift;
8968              
8969 0         0 my $ui = $o->{ui};
8970 0         0 $ui->space;
8971 0         0 $ui->command('cds use cache STORE');
8972 0         0 $ui->p('Uses STORE to cache objects, and speed up subsequent requests of the same object. This is particularly useful when working with (slow) remote stores. The cache store should be a fast store, such as a local folder store or an in-memory store.');
8973 0         0 $ui->p('Cached objects are not linked to any account, and may disappear with the next garbage collection. Most stores however keep objects for a least a few hours after their last use.');
8974 0         0 $ui->space;
8975 0         0 $ui->command('cds drop cache');
8976 0         0 $ui->p('Stops using the cache.');
8977 0         0 $ui->space;
8978 0         0 $ui->command('cds cache');
8979 0         0 $ui->p('Shows which cache store is used (if any).');
8980 0         0 $ui->space;
8981             }
8982              
8983             sub useCache {
8984 0     0   0 my $o = shift;
8985 0         0 my $cmd = shift;
8986              
8987 0         0 $cmd->collect($o);
8988              
8989 0         0 $o->{actor}->sessionRoot->child('use cache')->setText($o->{store}->url);
8990 0   0     0 $o->{actor}->saveOrShowError // return;
8991 0         0 $o->{ui}->pGreen('Using store "', $o->{store}->url, '" to cache objects.');
8992             }
8993              
8994             sub dropCache {
8995 0     0   0 my $o = shift;
8996 0         0 my $cmd = shift;
8997              
8998 0         0 $o->{actor}->sessionRoot->child('use cache')->clear;
8999 0   0     0 $o->{actor}->saveOrShowError // return;
9000 0         0 $o->{ui}->pGreen('Not using any cache any more.');
9001             }
9002              
9003             sub cache {
9004 0     0   0 my $o = shift;
9005 0         0 my $cmd = shift;
9006              
9007 0         0 my $storeUrl = $o->{actor}->sessionRoot->child('use cache')->textValue;
9008 0 0       0 return $o->{ui}->line('Not using any cache.') if ! length $storeUrl;
9009 0         0 return $o->{ui}->line('Using store "', $storeUrl, '" to cache objects.');
9010             }
9011              
9012             # BEGIN AUTOGENERATED
9013             package CDS::Commands::UseStore;
9014              
9015             sub register {
9016 0     0   0 my $class = shift;
9017 0         0 my $cds = shift;
9018 0         0 my $help = shift;
9019              
9020 0         0 my $node000 = CDS::Parser::Node->new(0);
9021 0         0 my $node001 = CDS::Parser::Node->new(0);
9022 0         0 my $node002 = CDS::Parser::Node->new(0);
9023 0         0 my $node003 = CDS::Parser::Node->new(0);
9024 0         0 my $node004 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
9025 0         0 my $node005 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&useStoreForMessaging});
9026 0         0 $cds->addArrow($node001, 1, 0, 'use');
9027 0         0 $help->addArrow($node000, 1, 0, 'messaging');
9028 0         0 $node000->addArrow($node004, 1, 0, 'store');
9029 0         0 $node001->addArrow($node002, 1, 0, 'STORE', \&collectStore);
9030 0         0 $node002->addArrow($node003, 1, 0, 'for');
9031 0         0 $node003->addArrow($node005, 1, 0, 'messaging');
9032             }
9033              
9034             sub collectStore {
9035 0     0   0 my $o = shift;
9036 0         0 my $label = shift;
9037 0         0 my $value = shift;
9038              
9039 0         0 $o->{store} = $value;
9040             }
9041              
9042             sub new {
9043 0     0   0 my $class = shift;
9044 0         0 my $actor = shift;
9045 0         0 bless {actor => $actor, ui => $actor->ui} }
9046              
9047             # END AUTOGENERATED
9048              
9049             # HTML FOLDER NAME use-store
9050             # HTML TITLE Set the messaging store
9051             sub help {
9052 0     0   0 my $o = shift;
9053 0         0 my $cmd = shift;
9054              
9055 0         0 my $ui = $o->{ui};
9056 0         0 $ui->space;
9057 0         0 $ui->command('cds use STORE for messaging');
9058 0         0 $ui->p('Uses STORE to send and receive messages.');
9059 0         0 $ui->space;
9060             }
9061              
9062             sub useStoreForMessaging {
9063 0     0   0 my $o = shift;
9064 0         0 my $cmd = shift;
9065              
9066 0         0 $cmd->collect($o);
9067              
9068 0         0 $o->{actor}->{configuration}->setMessagingStoreUrl($o->{store}->url);
9069 0         0 $o->{ui}->pGreen('The messaging store is now ', $o->{store}->url);
9070             }
9071              
9072             # BEGIN AUTOGENERATED
9073             package CDS::Commands::Welcome;
9074              
9075             sub register {
9076 0     0   0 my $class = shift;
9077 0         0 my $cds = shift;
9078 0         0 my $help = shift;
9079              
9080 0         0 my $node000 = CDS::Parser::Node->new(0);
9081 0         0 my $node001 = CDS::Parser::Node->new(0);
9082 0         0 my $node002 = CDS::Parser::Node->new(0);
9083 0         0 my $node003 = CDS::Parser::Node->new(0);
9084 0         0 my $node004 = CDS::Parser::Node->new(0);
9085 0         0 my $node005 = CDS::Parser::Node->new(0);
9086 0         0 my $node006 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
9087 0         0 my $node007 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&suppress});
9088 0         0 my $node008 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&enable});
9089 0         0 my $node009 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&show});
9090 0         0 $cds->addArrow($node000, 1, 0, 'suppress');
9091 0         0 $cds->addArrow($node002, 1, 0, 'enable');
9092 0         0 $cds->addArrow($node004, 1, 0, 'show');
9093 0         0 $help->addArrow($node006, 1, 0, 'welcome');
9094 0         0 $node000->addArrow($node001, 1, 0, 'welcome');
9095 0         0 $node001->addArrow($node007, 1, 0, 'message');
9096 0         0 $node002->addArrow($node003, 1, 0, 'welcome');
9097 0         0 $node003->addArrow($node008, 1, 0, 'message');
9098 0         0 $node004->addArrow($node005, 1, 0, 'welcome');
9099 0         0 $node005->addArrow($node009, 1, 0, 'message');
9100             }
9101              
9102             sub new {
9103 0     0   0 my $class = shift;
9104 0         0 my $actor = shift;
9105 0         0 bless {actor => $actor, ui => $actor->ui} }
9106              
9107             # END AUTOGENERATED
9108              
9109             # HTML FOLDER NAME welcome
9110             # HTML TITLE Welcome message
9111             sub help {
9112 0     0   0 my $o = shift;
9113 0         0 my $cmd = shift;
9114              
9115 0         0 my $ui = $o->{ui};
9116 0         0 $ui->space;
9117 0         0 $ui->command('cds suppress welcome message');
9118 0         0 $ui->p('Suppresses the welcome message when typing "cds".');
9119 0         0 $ui->space;
9120 0         0 $ui->command('cds enable welcome message');
9121 0         0 $ui->p('Enables the welcome message when typing "cds".');
9122 0         0 $ui->space;
9123 0         0 $ui->command('cds show welcome message');
9124 0         0 $ui->p('Shows the welcome message.');
9125 0         0 $ui->space;
9126             }
9127              
9128             sub suppress {
9129 0     0   0 my $o = shift;
9130 0         0 my $cmd = shift;
9131              
9132 0         0 $o->{actor}->localRoot->child('suppress welcome message')->setBoolean(1);
9133 0   0     0 $o->{actor}->saveOrShowError // return;
9134              
9135 0         0 $o->{ui}->space;
9136 0         0 $o->{ui}->p('The welcome message will not be shown any more.');
9137 0         0 $o->{ui}->space;
9138 0         0 $o->{ui}->line('You can manually display the message by typing:');
9139 0         0 $o->{ui}->line($o->{ui}->blue(' cds show welcome message'));
9140 0         0 $o->{ui}->line('or re-enable it using:');
9141 0         0 $o->{ui}->line($o->{ui}->blue(' cds enable welcome message'));
9142 0         0 $o->{ui}->space;
9143             }
9144              
9145             sub enable {
9146 0     0   0 my $o = shift;
9147 0         0 my $cmd = shift;
9148              
9149 0         0 $o->{actor}->localRoot->child('suppress welcome message')->clear;
9150 0   0     0 $o->{actor}->saveOrShowError // return;
9151              
9152 0         0 $o->{ui}->space;
9153 0         0 $o->{ui}->p('The welcome message will be shown when you type "cds".');
9154 0         0 $o->{ui}->space;
9155             }
9156              
9157             sub isEnabled {
9158 0     0   0 my $o = shift;
9159 0         0 ! $o->{actor}->localRoot->child('suppress welcome message')->isSet }
9160              
9161             sub show {
9162 0     0   0 my $o = shift;
9163 0         0 my $cmd = shift;
9164              
9165 0         0 my $ui = $o->{ui};
9166 0         0 $ui->space;
9167 0         0 $ui->title('Hi there!');
9168 0         0 $ui->p('This is the command line interface (CLI) of Condensation ', $CDS::VERSION, ', ', $CDS::releaseDate, '. Condensation is a distributed data system with conflict-free forward merging and end-to-end security. More information is available on https://condensation.io.');
9169 0         0 $ui->space;
9170 0         0 $ui->p('Commands resemble short english sentences. For example, the following "sentence" will show the record of an object:');
9171 0         0 $ui->line($ui->blue(' cds show record e5cbfc282e1f3e6fd0f3e5fffd41964c645f44d7fae8ef5cb350c2dfd2196c9f \\'));
9172 0         0 $ui->line($ui->blue(' from http://examples.condensation.io'));
9173 0         0 $ui->p('Type a "?" to explore possible commands, e.g.');
9174 0         0 $ui->line($ui->blue(' cds show ?'));
9175 0         0 $ui->p('or use TAB or TAB-TAB for command completion.');
9176 0         0 $ui->space;
9177 0         0 $ui->p('To get help, type');
9178 0         0 $ui->line($ui->blue(' cds help'));
9179 0         0 $ui->space;
9180 0         0 $ui->p('To suppress this welcome message, type');
9181 0         0 $ui->line($ui->blue(' cds suppress welcome message'));
9182 0         0 $ui->space;
9183             }
9184              
9185             package CDS::Commands::WhatIs;
9186              
9187             # BEGIN AUTOGENERATED
9188              
9189             sub register {
9190 0     0   0 my $class = shift;
9191 0         0 my $cds = shift;
9192 0         0 my $help = shift;
9193              
9194 0         0 my $node000 = CDS::Parser::Node->new(0);
9195 0         0 my $node001 = CDS::Parser::Node->new(0);
9196 0         0 my $node002 = CDS::Parser::Node->new(0);
9197 0         0 my $node003 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
9198 0         0 my $node004 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&whatIs});
9199 0         0 $cds->addArrow($node001, 1, 0, 'what');
9200 0         0 $help->addArrow($node000, 1, 0, 'what');
9201 0         0 $node000->addArrow($node003, 1, 0, 'is');
9202 0         0 $node001->addArrow($node002, 1, 0, 'is');
9203 0         0 $node002->addArrow($node004, 1, 0, 'TEXT', \&collectText);
9204             }
9205              
9206             sub collectText {
9207 0     0   0 my $o = shift;
9208 0         0 my $label = shift;
9209 0         0 my $value = shift;
9210              
9211 0         0 $o->{text} = $value;
9212             }
9213              
9214             sub new {
9215 0     0   0 my $class = shift;
9216 0         0 my $actor = shift;
9217 0         0 bless {actor => $actor, ui => $actor->ui} }
9218              
9219             # END AUTOGENERATED
9220              
9221             # HTML FOLDER NAME what-is
9222             # HTML TITLE What is
9223             sub help {
9224 0     0   0 my $o = shift;
9225 0         0 my $cmd = shift;
9226              
9227 0         0 my $ui = $o->{ui};
9228 0         0 $ui->space;
9229 0         0 $ui->command('cds what is TEXT');
9230 0         0 $ui->p('Tells what TEXT could be under the current configuration.');
9231 0         0 $ui->space;
9232             }
9233              
9234             sub whatIs {
9235 0     0   0 my $o = shift;
9236 0         0 my $cmd = shift;
9237              
9238 0         0 $cmd->collect($o);
9239 0         0 $o->{butNot} = [];
9240              
9241 0         0 $o->{ui}->space;
9242 0         0 $o->{ui}->title($o->{ui}->blue($o->{text}), ' may be …');
9243              
9244 0     0   0 $o->test('ACCOUNT', 'an ACCOUNT', sub { shift->url });
  0         0  
9245 0     0   0 $o->test('AESKEY', 'an AESKEY', sub { unpack('H*', shift) });
  0         0  
9246 0     0   0 $o->test('BOX', 'a BOX', sub { shift->url });
  0         0  
9247 0     0   0 $o->test('BOXLABEL', 'a BOXLABEL', sub { shift });
  0         0  
9248 0         0 $o->test('FILE', 'a FILE', \&fileResult);
9249 0         0 $o->test('FILENAME', 'a FILENAME', \&fileResult);
9250 0         0 $o->test('FOLDER', 'a FOLDER', \&fileResult);
9251 0     0   0 $o->test('GROUP', 'a GROUP on this system', sub { shift });
  0         0  
9252 0     0   0 $o->test('HASH', 'a HASH or ACTOR hash', sub { shift->hex });
  0         0  
9253 0         0 $o->test('KEYPAIR', 'a KEYPAIR', \&keyPairResult);
9254 0     0   0 $o->test('LABEL', 'a remembered LABEL', sub { shift });
  0         0  
9255 0     0   0 $o->test('OBJECT', 'an OBJECT', sub { shift->url });
  0         0  
9256 0         0 $o->test('OBJECTFILE', 'an OBJECTFILE', \&objectFileResult);
9257 0     0   0 $o->test('STORE', 'a STORE', sub { shift->url });
  0         0  
9258 0     0   0 $o->test('USER', 'a USER on this system', sub { shift });
  0         0  
9259              
9260 0         0 for my $butNot (@{$o->{butNot}}) {
  0         0  
9261 0         0 $o->{ui}->space;
9262 0         0 $o->{ui}->line('… but not ', $butNot->{text}, ', because:');
9263 0         0 for my $warning (@{$butNot->{warnings}}) {
  0         0  
9264 0         0 $o->{ui}->warning($warning);
9265             }
9266             }
9267              
9268 0         0 $o->{ui}->space;
9269             }
9270              
9271             sub test {
9272 0     0   0 my $o = shift;
9273 0         0 my $expect = shift;
9274 0         0 my $text = shift;
9275 0         0 my $resultHandler = shift;
9276              
9277 0         0 my $token = CDS::Parser::Token->new($o->{actor}, $o->{text});
9278 0         0 my $result = $token->produce($expect);
9279 0 0       0 if (defined $result) {
    0          
9280 0         0 my $whichOne = &$resultHandler($result);
9281 0         0 $o->{ui}->line('… ', $text, ' ', $o->{ui}->gray($whichOne));
9282 0         0 } elsif (scalar @{$token->{warnings}}) {
9283 0         0 push @{$o->{butNot}}, {text => $text, warnings => $token->{warnings}};
  0         0  
9284             }
9285             }
9286              
9287             sub keyPairResult {
9288 0     0   0 my $keyPairToken = shift;
9289              
9290 0         0 return $keyPairToken->file.' ('.$keyPairToken->keyPair->publicKey->hash->hex.')';
9291             }
9292              
9293             sub objectFileResult {
9294 0     0   0 my $objectFileToken = shift;
9295              
9296 0 0       0 return $objectFileToken->file if $objectFileToken->object->byteLength > 1024 * 1024;
9297 0         0 return $objectFileToken->file.' ('.$objectFileToken->object->calculateHash->hex.')';
9298             }
9299              
9300             sub fileResult {
9301 0     0   0 my $file = shift;
9302              
9303 0         0 my @s = stat $file;
9304 0 0       0 my $label =
    0          
    0          
    0          
    0          
    0          
    0          
    0          
9305             ! scalar @s ? ' (non-existing)' :
9306             Fcntl::S_ISDIR($s[2]) ? ' (folder)' :
9307             Fcntl::S_ISREG($s[2]) ? ' (file, '.$s[7].' bytes)' :
9308             Fcntl::S_ISLNK($s[2]) ? ' (symbolic link)' :
9309             Fcntl::S_ISBLK($s[2]) ? ' (block device)' :
9310             Fcntl::S_ISCHR($s[2]) ? ' (char device)' :
9311             Fcntl::S_ISSOCK($s[2]) ? ' (socket)' :
9312             Fcntl::S_ISFIFO($s[2]) ? ' (pipe)' : ' (unknown type)';
9313              
9314 0         0 return $file.$label;
9315             }
9316              
9317             package CDS::Configuration;
9318              
9319             our $xdgConfigurationFolder = ($ENV{XDG_CONFIG_HOME} || $ENV{HOME}.'/.config').'/condensation';
9320             our $xdgDataFolder = ($ENV{XDG_DATA_HOME} || $ENV{HOME}.'/.local/share').'/condensation';
9321              
9322             sub getOrCreateDefault {
9323 0     0   0 my $class = shift;
9324 0         0 my $ui = shift;
9325              
9326 0         0 my $configuration = $class->new($ui, $xdgConfigurationFolder, $xdgDataFolder);
9327 0         0 $configuration->createIfNecessary();
9328 0         0 return $configuration;
9329             }
9330              
9331             sub new {
9332 0     0   0 my $class = shift;
9333 0         0 my $ui = shift;
9334 0         0 my $folder = shift;
9335 0         0 my $defaultStoreFolder = shift;
9336              
9337 0         0 return bless {ui => $ui, folder => $folder, defaultStoreFolder => $defaultStoreFolder};
9338             }
9339              
9340 0     0   0 sub ui { shift->{ui} }
9341 0     0   0 sub folder { shift->{folder} }
9342              
9343             sub createIfNecessary {
9344 0     0   0 my $o = shift;
9345              
9346 0         0 my $keyPairFile = $o->{folder}.'/key-pair';
9347 0 0       0 return 1 if -f $keyPairFile;
9348              
9349 0         0 $o->{ui}->progress('Creating configuration folders …');
9350 0   0     0 $o->createFolder($o->{folder}) // return $o->{ui}->error('Failed to create the folder "', $o->{folder}, '".');
9351 0   0     0 $o->createFolder($o->{defaultStoreFolder}) // return $o->{ui}->error('Failed to create the folder "', $o->{defaultStoreFolder}, '".');
9352 0         0 CDS::FolderStore->new($o->{defaultStoreFolder})->createIfNecessary;
9353              
9354 0         0 $o->{ui}->progress('Generating key pair …');
9355 0         0 my $keyPair = CDS::KeyPair->generate;
9356 0   0     0 $keyPair->writeToFile($keyPairFile) // return $o->{ui}->error('Failed to write the configuration file "', $keyPairFile, '". Make sure that this location is writable.');
9357 0         0 $o->{ui}->removeProgress;
9358 0         0 return 1;
9359             }
9360              
9361             sub createFolder {
9362 0     0   0 my $o = shift;
9363 0         0 my $folder = shift;
9364              
9365 0         0 for my $path (CDS->intermediateFolders($folder)) {
9366 0         0 mkdir $path;
9367             }
9368              
9369 0         0 return -d $folder;
9370             }
9371              
9372             sub file {
9373 0     0   0 my $o = shift;
9374 0         0 my $filename = shift;
9375              
9376 0         0 return $o->{folder}.'/'.$filename;
9377             }
9378              
9379             sub messagingStoreUrl {
9380 0     0   0 my $o = shift;
9381              
9382 0   0     0 return $o->readFirstLine('messaging-store') // 'file://'.$o->{defaultStoreFolder};
9383             }
9384              
9385             sub storageStoreUrl {
9386 0     0   0 my $o = shift;
9387              
9388 0   0     0 return $o->readFirstLine('store') // 'file://'.$o->{defaultStoreFolder};
9389             }
9390              
9391             sub setMessagingStoreUrl {
9392 0     0   0 my $o = shift;
9393 0         0 my $storeUrl = shift;
9394              
9395 0         0 CDS->writeTextToFile($o->file('messaging-store'), $storeUrl);
9396             }
9397              
9398             sub setStorageStoreUrl {
9399 0     0   0 my $o = shift;
9400 0         0 my $storeUrl = shift;
9401              
9402 0         0 CDS->writeTextToFile($o->file('store'), $storeUrl);
9403             }
9404              
9405             sub keyPair {
9406 0     0   0 my $o = shift;
9407              
9408 0         0 return CDS::KeyPair->fromFile($o->file('key-pair'));
9409             }
9410              
9411             sub setKeyPair {
9412 0     0   0 my $o = shift;
9413 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
9414              
9415 0         0 $keyPair->writeToFile($o->file('key-pair'));
9416             }
9417              
9418             sub readFirstLine {
9419 0     0   0 my $o = shift;
9420 0         0 my $file = shift;
9421              
9422 0   0     0 my $content = CDS->readTextFromFile($o->file($file)) // return;
9423 0 0       0 $content = $1 if $content =~ /^(.*)\n/;
9424 0 0       0 $content = $1 if $content =~ /^\s*(.*?)\s*$/;
9425 0         0 return $content;
9426             }
9427              
9428             package CDS::DetachedDocument;
9429              
9430 1     1   25947 use parent -norequire, 'CDS::Document';
  1         2  
  1         7  
9431              
9432             sub new {
9433 0     0   0 my $class = shift;
9434 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
9435              
9436 0         0 return $class->SUPER::new($keyPair, CDS::InMemoryStore->create);
9437             }
9438              
9439             sub savingDone {
9440 0     0   0 my $o = shift;
9441 0         0 my $revision = shift;
9442 0         0 my $newPart = shift;
9443 0         0 my $obsoleteParts = shift;
9444              
9445             # We don't do anything
9446 0         0 $o->{unsaved}->savingDone;
9447             }
9448              
9449             package CDS::DiscoverActorGroup;
9450              
9451             sub discover {
9452 0     0   0 my $class = shift;
9453 0 0 0     0 my $builder = shift; die 'wrong type '.ref($builder).' for $builder' if defined $builder && ref $builder ne 'CDS::ActorGroupBuilder';
  0         0  
9454 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
9455 0         0 my $delegate = shift;
9456              
9457 0         0 my $o = bless {
9458             knownPublicKeys => $builder->knownPublicKeys, # A hashref of known public keys (e.g. from the existing actor group)
9459             keyPair => $keyPair,
9460             delegate => $delegate, # The delegate
9461             nodesByUrl => {}, # Nodes on which this actor group is active, by URL
9462             coverage => {}, # Hashes that belong to this actor group
9463             };
9464              
9465             # Add all active members
9466 0         0 for my $member ($builder->members) {
9467 0 0       0 next if $member->status ne 'active';
9468 0         0 my $node = $o->node($member->hash, $member->storeUrl);
9469 0 0       0 if ($node->{revision} < $member->revision) {
9470 0         0 $node->{revision} = $member->revision;
9471 0         0 $node->{status} = 'active';
9472             }
9473              
9474 0         0 $o->{coverage}->{$member->hash->bytes} = 1;
9475             }
9476              
9477             # Determine the revision at start
9478 0         0 my $revisionAtStart = 0;
9479 0         0 for my $node (values %{$o->{nodesByUrl}}) {
  0         0  
9480 0 0       0 $revisionAtStart = $node->{revision} if $revisionAtStart < $node->{revision};
9481             }
9482              
9483             # Reload the cards of all known accounts
9484 0         0 for my $node (values %{$o->{nodesByUrl}}) {
  0         0  
9485 0         0 $node->discover;
9486             }
9487              
9488             # From here, try extending to other accounts
9489 0         0 while ($o->extend) {}
9490              
9491             # Compile the list of actors and cards
9492 0         0 my @members;
9493             my @cards;
9494 0         0 for my $node (values %{$o->{nodesByUrl}}) {
  0         0  
9495 0 0       0 next if ! $node->{reachable};
9496 0 0       0 next if ! $node->{attachedToUs};
9497 0 0       0 next if ! $node->{actorOnStore};
9498 0 0       0 next if ! $node->isActiveOrIdle;
9499             #-- member ++ $node->{actorHash}->hex ++ $node->{cardsRead} ++ $node->{cards} // 'undef' ++ $node->{actorOnStore} // 'undef'
9500 0         0 push @members, CDS::ActorGroup::Member->new($node->{actorOnStore}, $node->{storeUrl}, $node->{revision}, $node->isActive);
9501 0         0 push @cards, @{$node->{cards}};
  0         0  
9502             }
9503              
9504             # Get the newest list of entrusted actors
9505 0         0 my $parser = CDS::ActorGroupBuilder->new;
9506 0         0 for my $card (@cards) {
9507 0         0 $parser->parseEntrustedActors($card->card->child('entrusted actors'), 0);
9508             }
9509              
9510             # Get the entrusted actors
9511 0         0 my $entrustedActors = [];
9512 0         0 for my $actor ($parser->entrustedActors) {
9513 0         0 my $store = $o->{delegate}->onDiscoverActorGroupVerifyStore($actor->storeUrl);
9514 0 0       0 next if ! $store;
9515              
9516 0         0 my $knownPublicKey = $o->{knownPublicKeys}->{$actor->hash->bytes};
9517 0 0       0 if ($knownPublicKey) {
9518 0         0 push @$entrustedActors, CDS::ActorGroup::EntrustedActor->new(CDS::ActorOnStore->new($knownPublicKey, $store), $actor->storeUrl);
9519 0         0 next;
9520             }
9521              
9522 0         0 my ($publicKey, $invalidReason, $storeError) = $keyPair->getPublicKey($actor->hash, $store);
9523              
9524 0 0       0 if (defined $invalidReason) {
9525 0         0 $o->{discoverer}->{delegate}->onDiscoverActorGroupInvalidPublicKey($actor->hash, $store, $invalidReason);
9526 0         0 next;
9527             }
9528              
9529 0 0       0 if (defined $storeError) {
9530 0         0 $o->{discoverer}->{delegate}->onDiscoverActorGroupStoreError($store, $storeError);
9531 0         0 next;
9532             }
9533              
9534 0         0 push @$entrustedActors, CDS::ActorGroup::EntrustedActor->new(CDS::ActorOnStore->new($publicKey, $store), $actor->storeUrl);
9535             }
9536              
9537 0 0       0 my $members = [sort { $b->{revision} <=> $a->{revision} || $b->{status} cmp $a->{status} } @members];
  0         0  
9538 0         0 return CDS::ActorGroup->new($members, $parser->entrustedActorsRevision, $entrustedActors), [@cards], [grep { $_->{attachedToUs} } values %{$o->{nodesByUrl}}];
  0         0  
  0         0  
9539             }
9540              
9541             sub node {
9542 0     0   0 my $o = shift;
9543 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
9544 0         0 my $storeUrl = shift;
9545             # private
9546 0         0 my $url = $storeUrl.'/accounts/'.$actorHash->hex;
9547 0         0 my $node = $o->{nodesByUrl}->{$url};
9548 0 0       0 return $node if $node;
9549 0         0 return $o->{nodesByUrl}->{$url} = CDS::DiscoverActorGroup::Node->new($o, $actorHash, $storeUrl);
9550             }
9551              
9552             sub covers {
9553 0     0   0 my $o = shift;
9554 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
9555 0         0 $o->{coverage}->{$hash->bytes} }
9556              
9557             sub extend {
9558 0     0   0 my $o = shift;
9559              
9560             # Start with the newest node
9561 0         0 my $mainNode;
9562 0         0 my $mainRevision = -1;
9563 0         0 for my $node (values %{$o->{nodesByUrl}}) {
  0         0  
9564 0 0       0 next if ! $node->{attachedToUs};
9565 0 0       0 next if $node->{revision} <= $mainRevision;
9566 0         0 $mainNode = $node;
9567 0         0 $mainRevision = $node->{revision};
9568             }
9569              
9570 0 0       0 return 0 if ! $mainNode;
9571              
9572             # Reset the reachable flag
9573 0         0 for my $node (values %{$o->{nodesByUrl}}) {
  0         0  
9574 0         0 $node->{reachable} = 0;
9575             }
9576 0         0 $mainNode->{reachable} = 1;
9577              
9578             # Traverse the graph along active links to find accounts to discover.
9579 0         0 my @toDiscover;
9580 0         0 my @toCheck = ($mainNode);
9581 0         0 while (1) {
9582 0   0     0 my $currentNode = shift(@toCheck) // last;
9583 0         0 for my $link (@{$currentNode->{links}}) {
  0         0  
9584 0         0 my $node = $link->{node};
9585 0 0       0 next if $node->{reachable};
9586 0 0       0 my $prospectiveStatus = $link->{revision} > $node->{revision} ? $link->{status} : $node->{status};
9587 0 0       0 next if $prospectiveStatus ne 'active';
9588 0         0 $node->{reachable} = 1;
9589 0 0       0 push @toCheck, $node if $node->{attachedToUs};
9590 0 0       0 push @toDiscover, $node if ! $node->{attachedToUs};
9591             }
9592             }
9593              
9594             # Discover these accounts
9595 0         0 my $hasChanges = 0;
9596 0         0 for my $node (sort { $b->{revision} <=> $a->{revision} } @toDiscover) {
  0         0  
9597 0         0 $node->discover;
9598 0 0       0 next if ! $node->{attachedToUs};
9599 0         0 $hasChanges = 1;
9600             }
9601              
9602 0         0 return $hasChanges;
9603             }
9604              
9605             package CDS::DiscoverActorGroup::Card;
9606              
9607             sub new {
9608 0     0   0 my $class = shift;
9609 0         0 my $storeUrl = shift;
9610 0 0 0     0 my $actorOnStore = shift; die 'wrong type '.ref($actorOnStore).' for $actorOnStore' if defined $actorOnStore && ref $actorOnStore ne 'CDS::ActorOnStore';
  0         0  
9611 0 0 0     0 my $envelopeHash = shift; die 'wrong type '.ref($envelopeHash).' for $envelopeHash' if defined $envelopeHash && ref $envelopeHash ne 'CDS::Hash';
  0         0  
9612 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
9613 0 0 0     0 my $cardHash = shift; die 'wrong type '.ref($cardHash).' for $cardHash' if defined $cardHash && ref $cardHash ne 'CDS::Hash';
  0         0  
9614 0         0 my $card = shift;
9615              
9616 0         0 return bless {
9617             storeUrl => $storeUrl,
9618             actorOnStore => $actorOnStore,
9619             envelopeHash => $envelopeHash,
9620             envelope => $envelope,
9621             cardHash => $cardHash,
9622             card => $card,
9623             };
9624             }
9625              
9626 0     0   0 sub storeUrl { shift->{storeUrl} }
9627 0     0   0 sub actorOnStore { shift->{actorOnStore} }
9628 0     0   0 sub envelopeHash { shift->{envelopeHash} }
9629 0     0   0 sub envelope { shift->{envelope} }
9630 0     0   0 sub cardHash { shift->{cardHash} }
9631 0     0   0 sub card { shift->{card} }
9632              
9633             package CDS::DiscoverActorGroup::Link;
9634              
9635             sub new {
9636 0     0   0 my $class = shift;
9637 0         0 my $node = shift;
9638 0         0 my $revision = shift;
9639 0         0 my $status = shift;
9640              
9641 0         0 bless {
9642             node => $node,
9643             revision => $revision,
9644             status => $status,
9645             };
9646             }
9647              
9648 0     0   0 sub node { shift->{node} }
9649 0     0   0 sub revision { shift->{revision} }
9650 0     0   0 sub status { shift->{status} }
9651              
9652             package CDS::DiscoverActorGroup::Node;
9653              
9654             sub new {
9655 0     0   0 my $class = shift;
9656 0         0 my $discoverer = shift;
9657 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
9658 0         0 my $storeUrl = shift;
9659              
9660 0         0 return bless {
9661             discoverer => $discoverer,
9662             actorHash => $actorHash,
9663             storeUrl => $storeUrl,
9664             revision => -1,
9665             status => 'idle',
9666             reachable => 0, # whether this node is reachable from the main node
9667             store => undef,
9668             actorOnStore => undef,
9669             links => [], # all links found in the cards
9670             attachedToUs => 0, # whether the account belongs to us
9671             cardsRead => 0,
9672             cards => [],
9673             };
9674             }
9675              
9676             sub cards {
9677 0     0   0 my $o = shift;
9678 0         0 @{$o->{cards}} }
  0         0  
9679             sub isActive {
9680 0     0   0 my $o = shift;
9681 0         0 $o->{status} eq 'active' }
9682             sub isActiveOrIdle {
9683 0     0   0 my $o = shift;
9684 0 0       0 $o->{status} eq 'active' || $o->{status} eq 'idle' }
9685              
9686 0     0   0 sub actorHash { shift->{actorHash} }
9687 0     0   0 sub storeUrl { shift->{storeUrl} }
9688 0     0   0 sub revision { shift->{revision} }
9689 0     0   0 sub status { shift->{status} }
9690 0     0   0 sub attachedToUs { shift->{attachedToUs} }
9691             sub links {
9692 0     0   0 my $o = shift;
9693 0         0 @{$o->{links}} }
  0         0  
9694              
9695             sub discover {
9696 0     0   0 my $o = shift;
9697              
9698             #-- discover ++ $o->{actorHash}->hex
9699 0         0 $o->readCards;
9700 0         0 $o->attach;
9701             }
9702              
9703             sub readCards {
9704 0     0   0 my $o = shift;
9705              
9706 0 0       0 return if $o->{cardsRead};
9707 0         0 $o->{cardsRead} = 1;
9708             #-- read cards of ++ $o->{actorHash}->hex
9709              
9710             # Get the store
9711 0   0     0 my $store = $o->{discoverer}->{delegate}->onDiscoverActorGroupVerifyStore($o->{storeUrl}, $o->{actorHash}) // return;
9712              
9713             # Get the public key if necessary
9714 0 0       0 if (! $o->{actorOnStore}) {
9715 0         0 my $publicKey = $o->{discoverer}->{knownPublicKeys}->{$o->{actorHash}->bytes};
9716 0 0       0 if (! $publicKey) {
9717 0         0 my ($downloadedPublicKey, $invalidReason, $storeError) = $o->{discoverer}->{keyPair}->getPublicKey($o->{actorHash}, $store);
9718 0 0       0 return $o->{discoverer}->{delegate}->onDiscoverActorGroupStoreError($store, $storeError) if defined $storeError;
9719 0 0       0 return $o->{discoverer}->{delegate}->onDiscoverActorGroupInvalidPublicKey($o->{actorHash}, $store, $invalidReason) if defined $invalidReason;
9720 0         0 $publicKey = $downloadedPublicKey;
9721             }
9722              
9723 0         0 $o->{actorOnStore} = CDS::ActorOnStore->new($publicKey, $store);
9724             }
9725              
9726             # List the public box
9727 0         0 my ($hashes, $storeError) = $store->list($o->{actorHash}, 'public', 0, $o->{discoverer}->{keyPair});
9728 0 0       0 return $o->{discoverer}->{delegate}->onDiscoverActorGroupStoreError($store, $storeError) if defined $storeError;
9729              
9730 0         0 for my $envelopeHash (@$hashes) {
9731             # Open the envelope
9732 0         0 my ($object, $storeError) = $store->get($envelopeHash, $o->{discoverer}->{keyPair});
9733 0 0       0 return $o->{discoverer}->{delegate}->onDiscoverActorGroupStoreError($store, $storeError) if defined $storeError;
9734 0 0       0 if (! $object) {
9735 0         0 $o->{discoverer}->{delegate}->onDiscoverActorGroupInvalidCard($o->{actorOnStore}, $envelopeHash, 'Envelope object not found.');
9736 0         0 next;
9737             }
9738              
9739 0         0 my $envelope = CDS::Record->fromObject($object);
9740 0 0       0 if (! $envelope) {
9741 0         0 $o->{discoverer}->{delegate}->onDiscoverActorGroupInvalidCard($o->{actorOnStore}, $envelopeHash, 'Envelope is not a record.');
9742 0         0 next;
9743             }
9744              
9745 0         0 my $cardHash = $envelope->child('content')->hashValue;
9746 0 0       0 if (! $cardHash) {
9747 0         0 $o->{discoverer}->{delegate}->onDiscoverActorGroupInvalidCard($o->{actorOnStore}, $envelopeHash, 'Missing content hash.');
9748 0         0 next;
9749             }
9750              
9751 0 0       0 if (! CDS->verifyEnvelopeSignature($envelope, $o->{actorOnStore}->publicKey, $cardHash)) {
9752 0         0 $o->{discoverer}->{delegate}->onDiscoverActorGroupInvalidCard($o->{actorOnStore}, $envelopeHash, 'Invalid signature.');
9753 0         0 next;
9754             }
9755              
9756             # Read the card
9757 0         0 my ($cardObject, $storeError1) = $store->get($cardHash, $o->{discoverer}->{keyPair});
9758 0 0       0 return $o->{discoverer}->{delegate}->onDiscoverActorGroupStoreError($store, $storeError) if defined $storeError1;
9759 0 0       0 if (! $cardObject) {
9760 0         0 $o->{discoverer}->{delegate}->onDiscoverActorGroupInvalidCard($o->{actorOnStore}, $envelopeHash, 'Card object not found.');
9761 0         0 next;
9762             }
9763              
9764 0         0 my $card = CDS::Record->fromObject($cardObject);
9765 0 0       0 if (! $card) {
9766 0         0 $o->{discoverer}->{delegate}->onDiscoverActorGroupInvalidCard($o->{actorOnStore}, $envelopeHash, 'Card is not a record.');
9767 0         0 next;
9768             }
9769              
9770             # Add the card to the list of cards
9771 0         0 push @{$o->{cards}}, CDS::DiscoverActorGroup::Card->new($o->{storeUrl}, $o->{actorOnStore}, $envelopeHash, $envelope, $cardHash, $card);
  0         0  
9772              
9773             # Parse the account list
9774 0         0 my $builder = CDS::ActorGroupBuilder->new;
9775 0         0 $builder->parseMembers($card->child('actor group'), 0);
9776 0         0 for my $member ($builder->members) {
9777 0         0 my $node = $o->{discoverer}->node($member->hash, $member->storeUrl);
9778             #-- new link ++ $o->{actorHash}->hex ++ $status ++ $hash->hex
9779 0         0 push @{$o->{links}}, CDS::DiscoverActorGroup::Link->new($node, $member->revision, $member->status);
  0         0  
9780             }
9781             }
9782             }
9783              
9784             sub attach {
9785 0     0   0 my $o = shift;
9786              
9787 0 0       0 return if $o->{attachedToUs};
9788 0 0       0 return if ! $o->hasLinkToUs;
9789              
9790             # Attach this node
9791 0         0 $o->{attachedToUs} = 1;
9792              
9793             # Merge all links
9794 0         0 for my $link (@{$o->{links}}) {
  0         0  
9795 0         0 $link->{node}->merge($link->{revision}, $link->{status});
9796             }
9797              
9798             # Add the hash to the coverage
9799 0         0 $o->{discoverer}->{coverage}->{$o->{actorHash}->bytes} = 1;
9800             }
9801              
9802             sub merge {
9803 0     0   0 my $o = shift;
9804 0         0 my $revision = shift;
9805 0         0 my $status = shift;
9806              
9807 0 0       0 return if $o->{revision} >= $revision;
9808 0         0 $o->{revision} = $revision;
9809 0         0 $o->{status} = $status;
9810             }
9811              
9812             sub hasLinkToUs {
9813 0     0   0 my $o = shift;
9814              
9815 0 0       0 return 1 if $o->{discoverer}->covers($o->{actorHash});
9816 0         0 for my $link (@{$o->{links}}) {
  0         0  
9817 0 0       0 return 1 if $o->{discoverer}->covers($link->{node}->{actorHash});
9818             }
9819 0         0 return;
9820             }
9821              
9822             package CDS::Document;
9823              
9824             sub new {
9825 0     0   0 my $class = shift;
9826 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
9827 0         0 my $store = shift;
9828              
9829 0         0 my $o = bless {
9830             keyPair => $keyPair,
9831             unsaved => CDS::Unsaved->new($store),
9832             itemsBySelector => {},
9833             parts => {},
9834             hasPartsToMerge => 0,
9835             }, $class;
9836              
9837 0         0 $o->{root} = CDS::Selector->root($o);
9838 0         0 $o->{changes} = CDS::Document::Part->new;
9839 0         0 return $o;
9840             }
9841              
9842 0     0   0 sub keyPair { shift->{keyPair} }
9843 0     0   0 sub unsaved { shift->{unsaved} }
9844             sub parts {
9845 0     0   0 my $o = shift;
9846 0         0 values %{$o->{parts}} }
  0         0  
9847 0     0   0 sub hasPartsToMerge { shift->{hasPartsToMerge} }
9848              
9849             ### Items
9850              
9851 0     0   0 sub root { shift->{root} }
9852             sub rootItem {
9853 0     0   0 my $o = shift;
9854 0         0 $o->getOrCreate($o->{root}) }
9855              
9856             sub get {
9857 0     0   0 my $o = shift;
9858 0 0 0     0 my $selector = shift; die 'wrong type '.ref($selector).' for $selector' if defined $selector && ref $selector ne 'CDS::Selector';
  0         0  
9859 0         0 $o->{itemsBySelector}->{$selector->{id}} }
9860              
9861             sub getOrCreate {
9862 0     0   0 my $o = shift;
9863 0 0 0     0 my $selector = shift; die 'wrong type '.ref($selector).' for $selector' if defined $selector && ref $selector ne 'CDS::Selector';
  0         0  
9864              
9865 0         0 my $item = $o->{itemsBySelector}->{$selector->{id}};
9866 0 0       0 $o->{itemsBySelector}->{$selector->{id}} = $item = CDS::Document::Item->new($selector) if ! $item;
9867 0         0 return $item;
9868             }
9869              
9870             sub prune {
9871 0     0   0 my $o = shift;
9872 0         0 $o->rootItem->pruneTree; }
9873              
9874             ### Merging
9875              
9876             sub merge {
9877 0     0   0 my $o = shift;
9878              
9879 0         0 for my $hashAndKey (@_) {
9880 0 0       0 next if ! $hashAndKey;
9881 0 0       0 next if $o->{parts}->{$hashAndKey->hash->bytes};
9882 0         0 my $part = CDS::Document::Part->new;
9883 0         0 $part->{hashAndKey} = $hashAndKey;
9884 0         0 $o->{parts}->{$hashAndKey->hash->bytes} = $part;
9885 0         0 $o->{hasPartsToMerge} = 1;
9886             }
9887             }
9888              
9889             sub read {
9890 0     0   0 my $o = shift;
9891              
9892 0 0       0 return 1 if ! $o->{hasPartsToMerge};
9893              
9894             # Load the parts
9895 0         0 for my $part (values %{$o->{parts}}) {
  0         0  
9896 0 0       0 next if $part->{isMerged};
9897 0 0       0 next if $part->{loadedRecord};
9898              
9899 0         0 my ($record, $object, $invalidReason, $storeError) = $o->{keyPair}->getAndDecryptRecord($part->{hashAndKey}, $o->{unsaved});
9900 0 0       0 return if defined $storeError;
9901              
9902 0 0       0 delete $o->{parts}->{$part->{hashAndKey}->hash->bytes} if defined $invalidReason;
9903 0         0 $part->{loadedRecord} = $record;
9904             }
9905              
9906             # Merge the loaded parts
9907 0         0 for my $part (values %{$o->{parts}}) {
  0         0  
9908 0 0       0 next if $part->{isMerged};
9909 0 0       0 next if ! $part->{loadedRecord};
9910 0 0       0 my $oldFormat = $part->{loadedRecord}->child('client')->textValue =~ /0.19/ ? 1 : 0;
9911 0         0 $o->mergeNode($part, $o->{root}, $part->{loadedRecord}->child('root'), $oldFormat);
9912 0         0 delete $part->{loadedRecord};
9913 0         0 $part->{isMerged} = 1;
9914             }
9915              
9916 0         0 $o->{hasPartsToMerge} = 0;
9917 0         0 return 1;
9918             }
9919              
9920             sub mergeNode {
9921 0     0   0 my $o = shift;
9922 0         0 my $part = shift;
9923 0 0 0     0 my $selector = shift; die 'wrong type '.ref($selector).' for $selector' if defined $selector && ref $selector ne 'CDS::Selector';
  0         0  
9924 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
9925 0         0 my $oldFormat = shift;
9926              
9927             # Prepare
9928 0         0 my @children = $record->children;
9929 0 0       0 return if ! scalar @children;
9930 0         0 my $item = $o->getOrCreate($selector);
9931              
9932             # Merge value
9933 0         0 my $valueRecord = shift @children;
9934 0 0       0 $valueRecord = $valueRecord->firstChild if $oldFormat;
9935 0         0 $item->mergeValue($part, $valueRecord->asInteger, $valueRecord);
9936              
9937             # Merge children
9938 0         0 for my $child (@children) { $o->mergeNode($part, $selector->child($child->bytes), $child, $oldFormat); }
  0         0  
9939             }
9940              
9941             # *** Saving
9942             # Call $document->save at any time to save the current state (if necessary).
9943              
9944             # This is called by the items whenever some data changes.
9945             sub dataChanged {
9946 0     0   0 my $o = shift;
9947             }
9948              
9949             sub save {
9950 0     0   0 my $o = shift;
9951              
9952 0         0 $o->{unsaved}->startSaving;
9953 0         0 my $revision = CDS->now;
9954 0         0 my $newPart = undef;
9955              
9956             #-- saving ++ $o->{changes}->{count}
9957 0 0       0 if ($o->{changes}->{count}) {
9958             # Take the changes
9959 0         0 $newPart = $o->{changes};
9960 0         0 $o->{changes} = CDS::Document::Part->new;
9961              
9962             # Select all parts smaller than 2 * changes
9963 0         0 $newPart->{selected} = 1;
9964 0         0 my $count = $newPart->{count};
9965 0         0 while (1) {
9966 0         0 my $addedPart = 0;
9967 0         0 for my $part (values %{$o->{parts}}) {
  0         0  
9968             #-- candidate ++ $part->{count} ++ $count
9969 0 0 0     0 next if ! $part->{isMerged} || $part->{selected} || $part->{count} >= $count * 2;
      0        
9970 0         0 $count += $part->{count};
9971 0         0 $part->{selected} = 1;
9972 0         0 $addedPart = 1;
9973             }
9974              
9975 0 0       0 last if ! $addedPart;
9976             }
9977              
9978             # Include the selected items
9979 0         0 for my $item (values %{$o->{itemsBySelector}}) {
  0         0  
9980 0 0       0 next if ! $item->{part}->{selected};
9981 0         0 $item->setPart($newPart);
9982 0         0 $item->createSaveRecord;
9983             }
9984              
9985 0         0 my $record = CDS::Record->new;
9986 0         0 $record->add('created')->addInteger($revision);
9987 0         0 $record->add('client')->add(CDS->version);
9988 0         0 $record->addRecord($o->rootItem->createSaveRecord);
9989              
9990             # Detach the save records
9991 0         0 for my $item (values %{$o->{itemsBySelector}}) {
  0         0  
9992 0         0 $item->detachSaveRecord;
9993             }
9994              
9995             # Serialize and encrypt the record
9996 0         0 my $key = CDS->randomKey;
9997 0         0 my $newObject = $record->toObject->crypt($key);
9998 0         0 $newPart->{hashAndKey} = CDS::HashAndKey->new($newObject->calculateHash, $key);
9999 0         0 $newPart->{isMerged} = 1;
10000 0         0 $newPart->{selected} = 0;
10001 0         0 $o->{parts}->{$newPart->{hashAndKey}->hash->bytes} = $newPart;
10002             #-- added ++ $o->{parts} ++ scalar keys %{$o->{parts}} ++ $newPart->{count}
10003 0         0 $o->{unsaved}->{savingState}->addObject($newPart->{hashAndKey}->hash, $newObject);
10004             }
10005              
10006             # Remove obsolete parts
10007 0         0 my $obsoleteParts = [];
10008 0         0 for my $part (values %{$o->{parts}}) {
  0         0  
10009 0 0       0 next if ! $part->{isMerged};
10010 0 0       0 next if $part->{count};
10011 0         0 push @$obsoleteParts, $part;
10012 0         0 delete $o->{parts}->{$part->{hashAndKey}->hash->bytes};
10013             }
10014              
10015             # Commit
10016             #-- saving done ++ $revision ++ $newPart ++ $obsoleteParts
10017 0         0 return $o->savingDone($revision, $newPart, $obsoleteParts);
10018             }
10019              
10020             package CDS::Document::Item;
10021              
10022             sub new {
10023 0     0   0 my $class = shift;
10024 0 0 0     0 my $selector = shift; die 'wrong type '.ref($selector).' for $selector' if defined $selector && ref $selector ne 'CDS::Selector';
  0         0  
10025              
10026 0         0 my $parentSelector = $selector->parent;
10027 0 0       0 my $parent = $parentSelector ? $selector->document->getOrCreate($parentSelector) : undef;
10028              
10029 0         0 my $o = bless {
10030             document => $selector->document,
10031             selector => $selector,
10032             parent => $parent,
10033             children => [],
10034             part => undef,
10035             revision => 0,
10036             record => CDS::Record->new
10037             };
10038              
10039 0 0       0 push @{$parent->{children}}, $o if $parent;
  0         0  
10040 0         0 return $o;
10041             }
10042              
10043             sub pruneTree {
10044 0     0   0 my $o = shift;
10045              
10046             # Try to remove children
10047 0         0 for my $child (@{$o->{children}}) { $child->pruneTree; }
  0         0  
  0         0  
10048              
10049             # Don't remove the root item
10050 0 0       0 return if ! $o->{parent};
10051              
10052             # Don't remove if the item has children, or a value
10053 0 0       0 return if scalar @{$o->{children}};
  0         0  
10054 0 0       0 return if $o->{revision} > 0;
10055              
10056             # Remove this from the tree
10057 0         0 $o->{parent}->{children} = [grep { $_ != $o } @{$o->{parent}->{children}}];
  0         0  
  0         0  
10058              
10059             # Remove this from the document hash
10060 0         0 delete $o->{document}->{itemsBySelector}->{$o->{selector}->{id}};
10061             }
10062              
10063             # Low-level part change.
10064             sub setPart {
10065 0     0   0 my $o = shift;
10066 0         0 my $part = shift;
10067              
10068 0 0       0 $o->{part}->{count} -= 1 if $o->{part};
10069 0         0 $o->{part} = $part;
10070 0 0       0 $o->{part}->{count} += 1 if $o->{part};
10071             }
10072              
10073             # Merge a value
10074              
10075             sub mergeValue {
10076 0     0   0 my $o = shift;
10077 0         0 my $part = shift;
10078 0         0 my $revision = shift;
10079 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
10080              
10081 0 0       0 return if $revision <= 0;
10082 0 0       0 return if $revision < $o->{revision};
10083 0 0 0     0 return if $revision == $o->{revision} && $part->{size} < $o->{part}->{size};
10084 0         0 $o->setPart($part);
10085 0         0 $o->{revision} = $revision;
10086 0         0 $o->{record} = $record;
10087 0         0 $o->{document}->dataChanged;
10088 0         0 return 1;
10089             }
10090              
10091             sub forget {
10092 0     0   0 my $o = shift;
10093              
10094 0 0       0 return if $o->{revision} <= 0;
10095 0         0 $o->{revision} = 0;
10096 0         0 $o->{record} = CDS::Record->new;
10097 0         0 $o->setPart;
10098             }
10099              
10100             # Saving
10101              
10102             sub createSaveRecord {
10103 0     0   0 my $o = shift;
10104              
10105 0 0       0 return $o->{saveRecord} if $o->{saveRecord};
10106 0 0       0 $o->{saveRecord} = $o->{parent} ? $o->{parent}->createSaveRecord->add($o->{selector}->{label}) : CDS::Record->new('root');
10107 0 0       0 if ($o->{part}->{selected}) {
10108 0 0       0 CDS->log('Item saving zero revision of ', $o->{selector}->label) if $o->{revision} <= 0;
10109 0         0 $o->{saveRecord}->addInteger($o->{revision})->addRecord($o->{record}->children);
10110             } else {
10111 0         0 $o->{saveRecord}->add('');
10112             }
10113 0         0 return $o->{saveRecord};
10114             }
10115              
10116             sub detachSaveRecord {
10117 0     0   0 my $o = shift;
10118              
10119 0 0       0 return if ! $o->{saveRecord};
10120 0         0 delete $o->{saveRecord};
10121 0 0       0 $o->{parent}->detachSaveRecord if $o->{parent};
10122             }
10123              
10124             package CDS::Document::Part;
10125              
10126             sub new {
10127 0     0   0 my $class = shift;
10128              
10129 0         0 return bless {
10130             isMerged => 0,
10131             hashAndKey => undef,
10132             size => 0,
10133             count => 0,
10134             selected => 0,
10135             };
10136             }
10137              
10138             # In this implementation, we only keep track of the number of values of the list, but
10139             # not of the corresponding items. This saves memory (~100 MiB for 1M items), but takes
10140             # more time (0.5 s for 1M items) when saving. Since command line programs usually write
10141             # the document only once, this is acceptable. Reading the tree anyway takes about 10
10142             # times more time.
10143              
10144             package CDS::ErrorHandlingStore;
10145              
10146 1     1   4543 use parent -norequire, 'CDS::Store';
  1         2  
  1         5  
10147              
10148             sub new {
10149 0     0   0 my $class = shift;
10150 0         0 my $store = shift;
10151 0         0 my $url = shift;
10152 0         0 my $errorHandler = shift;
10153              
10154 0         0 return bless {
10155             store => $store,
10156             url => $url,
10157             errorHandler => $errorHandler,
10158             }
10159             }
10160              
10161 0     0   0 sub store { shift->{store} }
10162 0     0   0 sub url { shift->{url} }
10163 0     0   0 sub errorHandler { shift->{errorHandler} }
10164              
10165             sub id {
10166 0     0   0 my $o = shift;
10167 0         0 'Error handling'."\n ".$o->{store}->id }
10168              
10169             sub get {
10170 0     0   0 my $o = shift;
10171 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
10172 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10173              
10174 0 0       0 return undef, 'Store disabled.' if $o->{errorHandler}->hasStoreError($o, 'GET');
10175              
10176 0         0 my ($object, $error) = $o->{store}->get($hash, $keyPair);
10177 0 0       0 if (defined $error) {
10178 0         0 $o->{errorHandler}->onStoreError($o, 'GET', $error);
10179 0         0 return undef, $error;
10180             }
10181              
10182 0         0 $o->{errorHandler}->onStoreSuccess($o, 'GET');
10183 0         0 return $object, $error;
10184             }
10185              
10186             sub book {
10187 0     0   0 my $o = shift;
10188 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
10189 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10190              
10191 0 0       0 return undef, 'Store disabled.' if $o->{errorHandler}->hasStoreError($o, 'BOOK');
10192              
10193 0         0 my ($booked, $error) = $o->{store}->book($hash, $keyPair);
10194 0 0       0 if (defined $error) {
10195 0         0 $o->{errorHandler}->onStoreError($o, 'BOOK', $error);
10196 0         0 return undef, $error;
10197             }
10198              
10199 0         0 $o->{errorHandler}->onStoreSuccess($o, 'BOOK');
10200 0         0 return $booked;
10201             }
10202              
10203             sub put {
10204 0     0   0 my $o = shift;
10205 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
10206 0 0 0     0 my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0         0  
10207 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10208              
10209 0 0       0 return 'Store disabled.' if $o->{errorHandler}->hasStoreError($o, 'PUT');
10210              
10211 0         0 my $error = $o->{store}->put($hash, $object, $keyPair);
10212 0 0       0 if (defined $error) {
10213 0         0 $o->{errorHandler}->onStoreError($o, 'PUT', $error);
10214 0         0 return $error;
10215             }
10216              
10217 0         0 $o->{errorHandler}->onStoreSuccess($o, 'PUT');
10218 0         0 return;
10219             }
10220              
10221             sub list {
10222 0     0   0 my $o = shift;
10223 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
10224 0         0 my $boxLabel = shift;
10225 0         0 my $timeout = shift;
10226 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10227              
10228 0 0       0 return undef, 'Store disabled.' if $o->{errorHandler}->hasStoreError($o, 'LIST');
10229              
10230 0         0 my ($hashes, $error) = $o->{store}->list($accountHash, $boxLabel, $timeout, $keyPair);
10231 0 0       0 if (defined $error) {
10232 0         0 $o->{errorHandler}->onStoreError($o, 'LIST', $error);
10233 0         0 return undef, $error;
10234             }
10235              
10236 0         0 $o->{errorHandler}->onStoreSuccess($o, 'LIST');
10237 0         0 return $hashes;
10238             }
10239              
10240             sub add {
10241 0     0   0 my $o = shift;
10242 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
10243 0         0 my $boxLabel = shift;
10244 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
10245 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10246              
10247 0 0       0 return 'Store disabled.' if $o->{errorHandler}->hasStoreError($o, 'ADD');
10248              
10249 0         0 my $error = $o->{store}->add($accountHash, $boxLabel, $hash, $keyPair);
10250 0 0       0 if (defined $error) {
10251 0         0 $o->{errorHandler}->onStoreError($o, 'ADD', $error);
10252 0         0 return $error;
10253             }
10254              
10255 0         0 $o->{errorHandler}->onStoreSuccess($o, 'ADD');
10256 0         0 return;
10257             }
10258              
10259             sub remove {
10260 0     0   0 my $o = shift;
10261 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
10262 0         0 my $boxLabel = shift;
10263 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
10264 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10265              
10266 0 0       0 return 'Store disabled.' if $o->{errorHandler}->hasStoreError($o, 'REMOVE');
10267              
10268 0         0 my $error = $o->{store}->remove($accountHash, $boxLabel, $hash, $keyPair);
10269 0 0       0 if (defined $error) {
10270 0         0 $o->{errorHandler}->onStoreError($o, 'REMOVE', $error);
10271 0         0 return $error;
10272             }
10273              
10274 0         0 $o->{errorHandler}->onStoreSuccess($o, 'REMOVE');
10275 0         0 return;
10276             }
10277              
10278             sub modify {
10279 0     0   0 my $o = shift;
10280 0         0 my $modifications = shift;
10281 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10282              
10283 0 0       0 return 'Store disabled.' if $o->{errorHandler}->hasStoreError($o, 'MODIFY');
10284              
10285 0         0 my $error = $o->{store}->modify($modifications, $keyPair);
10286 0 0       0 if (defined $error) {
10287 0         0 $o->{errorHandler}->onStoreError($o, 'MODIFY', $error);
10288 0         0 return $error;
10289             }
10290              
10291 0         0 $o->{errorHandler}->onStoreSuccess($o, 'MODIFY');
10292 0         0 return;
10293             }
10294              
10295             # A Condensation store on a local folder.
10296             package CDS::FolderStore;
10297              
10298 1     1   1108 use parent -norequire, 'CDS::Store';
  1         12  
  1         12  
10299              
10300             sub forUrl {
10301 0     0   0 my $class = shift;
10302 0         0 my $url = shift;
10303              
10304 0 0       0 return if substr($url, 0, 8) ne 'file:///';
10305 0         0 return $class->new(substr($url, 7));
10306             }
10307              
10308             sub new {
10309 0     0   0 my $class = shift;
10310 0         0 my $folder = shift;
10311              
10312 0         0 return bless {
10313             folder => $folder,
10314             permissions => CDS::FolderStore::PosixPermissions->forFolder($folder.'/accounts'),
10315             };
10316             }
10317              
10318             sub id {
10319 0     0   0 my $o = shift;
10320 0         0 'file://'.$o->{folder} }
10321 0     0   0 sub folder { shift->{folder} }
10322              
10323 0     0   0 sub permissions { shift->{permissions} }
10324             sub setPermissions {
10325 0     0   0 my $o = shift;
10326 0         0 my $permissions = shift;
10327 0         0 $o->{permissions} = $permissions; }
10328              
10329             sub get {
10330 0     0   0 my $o = shift;
10331 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
10332 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10333              
10334 0         0 my $hashHex = $hash->hex;
10335 0         0 my $file = $o->{folder}.'/objects/'.substr($hashHex, 0, 2).'/'.substr($hashHex, 2);
10336 0         0 return CDS::Object->fromBytes(CDS->readBytesFromFile($file));
10337             }
10338              
10339             sub book {
10340 0     0   0 my $o = shift;
10341 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
10342 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10343              
10344             # Book the object if it exists
10345 0         0 my $hashHex = $hash->hex;
10346 0         0 my $folder = $o->{folder}.'/objects/'.substr($hashHex, 0, 2);
10347 0         0 my $file = $folder.'/'.substr($hashHex, 2);
10348 0 0 0     0 return 1 if -e $file && utime(undef, undef, $file);
10349 0         0 return;
10350             }
10351              
10352             sub put {
10353 0     0   0 my $o = shift;
10354 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
10355 0 0 0     0 my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0         0  
10356 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10357              
10358             # Book the object if it exists
10359 0         0 my $hashHex = $hash->hex;
10360 0         0 my $folder = $o->{folder}.'/objects/'.substr($hashHex, 0, 2);
10361 0         0 my $file = $folder.'/'.substr($hashHex, 2);
10362 0 0 0     0 return if -e $file && utime(undef, undef, $file);
10363              
10364             # Write the file, set the permissions, and move it to the right place
10365 0         0 my $permissions = $o->{permissions};
10366 0         0 $permissions->mkdir($folder, $permissions->objectFolderMode);
10367 0   0     0 my $temporaryFile = $permissions->writeTemporaryFile($folder, $permissions->objectFileMode, $object->bytes) // return 'Failed to write object';
10368 0 0       0 rename($temporaryFile, $file) || return 'Failed to rename object.';
10369 0         0 return;
10370             }
10371              
10372             sub list {
10373 0     0   0 my $o = shift;
10374 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
10375 0         0 my $boxLabel = shift;
10376 0         0 my $timeout = shift;
10377 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10378              
10379 0 0       0 return undef, 'Invalid box label.' if ! CDS->isValidBoxLabel($boxLabel);
10380              
10381             # Prepare
10382 0         0 my $boxFolder = $o->{folder}.'/accounts/'.$accountHash->hex.'/'.$boxLabel;
10383              
10384             # List
10385 0 0       0 return $o->listFolder($boxFolder) if ! $timeout;
10386              
10387             # Watch
10388 0         0 my $hashes;
10389 0         0 my $watcher = CDS::FolderStore::Watcher->new($boxFolder);
10390 0         0 my $watchUntil = CDS->now + $timeout;
10391 0         0 while (1) {
10392             # List
10393 0         0 $hashes = $o->listFolder($boxFolder);
10394 0 0       0 last if scalar @$hashes;
10395              
10396             # Wait
10397 0   0     0 $watcher->wait($watchUntil - CDS->now, $watchUntil) // last;
10398             }
10399              
10400 0         0 $watcher->done;
10401 0         0 return $hashes;
10402             }
10403              
10404             sub listFolder {
10405 0     0   0 my $o = shift;
10406 0         0 my $boxFolder = shift;
10407             # private
10408 0         0 my $hashes = [];
10409 0         0 for my $file (CDS->listFolder($boxFolder)) {
10410 0   0     0 push @$hashes, CDS::Hash->fromHex($file) // next;
10411             }
10412              
10413 0         0 return $hashes;
10414             }
10415              
10416             sub add {
10417 0     0   0 my $o = shift;
10418 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
10419 0         0 my $boxLabel = shift;
10420 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
10421 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10422              
10423 0         0 my $permissions = $o->{permissions};
10424              
10425 0 0       0 next if ! CDS->isValidBoxLabel($boxLabel);
10426 0         0 my $accountFolder = $o->{folder}.'/accounts/'.$accountHash->hex;
10427 0         0 $permissions->mkdir($accountFolder, $permissions->accountFolderMode);
10428 0         0 my $boxFolder = $accountFolder.'/'.$boxLabel;
10429 0         0 $permissions->mkdir($boxFolder, $permissions->boxFolderMode($boxLabel));
10430 0         0 my $boxFileMode = $permissions->boxFileMode($boxLabel);
10431              
10432 0   0     0 my $temporaryFile = $permissions->writeTemporaryFile($boxFolder, $boxFileMode, '') // return 'Failed to write file.';
10433 0 0       0 rename($temporaryFile, $boxFolder.'/'.$hash->hex) || return 'Failed to rename file.';
10434 0         0 return;
10435             }
10436              
10437             sub remove {
10438 0     0   0 my $o = shift;
10439 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
10440 0         0 my $boxLabel = shift;
10441 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
10442 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10443              
10444 0 0       0 next if ! CDS->isValidBoxLabel($boxLabel);
10445 0         0 my $accountFolder = $o->{folder}.'/accounts/'.$accountHash->hex;
10446 0         0 my $boxFolder = $accountFolder.'/'.$boxLabel;
10447 0 0       0 next if ! -d $boxFolder;
10448 0         0 unlink $boxFolder.'/'.$hash->hex;
10449 0         0 return;
10450             }
10451              
10452             sub modify {
10453 0     0   0 my $o = shift;
10454 0         0 my $modifications = shift;
10455 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10456              
10457 0         0 return $modifications->executeIndividually($o, $keyPair);
10458             }
10459              
10460             # Store administration functions
10461              
10462             sub exists {
10463 0     0   0 my $o = shift;
10464              
10465 0   0     0 return -d $o->{folder}.'/accounts' && -d $o->{folder}.'/objects';
10466             }
10467              
10468             # Creates the store if it does not exist. The store folder itself must exist.
10469             sub createIfNecessary {
10470 0     0   0 my $o = shift;
10471              
10472 0         0 my $accountsFolder = $o->{folder}.'/accounts';
10473 0         0 my $objectsFolder = $o->{folder}.'/objects';
10474 0         0 $o->{permissions}->mkdir($accountsFolder, $o->{permissions}->baseFolderMode);
10475 0         0 $o->{permissions}->mkdir($objectsFolder, $o->{permissions}->baseFolderMode);
10476 0   0     0 return -d $accountsFolder && -d $objectsFolder;
10477             }
10478              
10479             # Lists accounts. This is a non-standard extension.
10480             sub accounts {
10481 0     0   0 my $o = shift;
10482              
10483 0         0 return grep { defined $_ }
10484 0         0 map { CDS::Hash->fromHex($_) }
10485 0         0 CDS->listFolder($o->{folder}.'/accounts');
10486             }
10487              
10488             # Adds an account. This is a non-standard extension.
10489             sub addAccount {
10490 0     0   0 my $o = shift;
10491 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
10492              
10493 0         0 my $accountFolder = $o->{folder}.'/accounts/'.$accountHash->hex;
10494 0         0 $o->{permissions}->mkdir($accountFolder, $o->{permissions}->accountFolderMode);
10495 0         0 return -d $accountFolder;
10496             }
10497              
10498             # Removes an account. This is a non-standard extension.
10499             sub removeAccount {
10500 0     0   0 my $o = shift;
10501 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
10502              
10503 0         0 my $accountFolder = $o->{folder}.'/accounts/'.$accountHash->hex;
10504 0         0 my $trashFolder = $o->{folder}.'/accounts/.deleted-'.CDS->randomHex(16);
10505 0         0 rename $accountFolder, $trashFolder;
10506 0         0 system('rm', '-rf', $trashFolder);
10507 0         0 return ! -d $accountFolder;
10508             }
10509              
10510             # Checks (and optionally fixes) the POSIX permissions of all files and folders. This is a non-standard extension.
10511             sub checkPermissions {
10512 0     0   0 my $o = shift;
10513 0         0 my $logger = shift;
10514              
10515 0         0 my $permissions = $o->{permissions};
10516              
10517             # Check the accounts folder
10518 0         0 my $accountsFolder = $o->{folder}.'/accounts';
10519 0 0       0 $permissions->checkPermissions($accountsFolder, $permissions->baseFolderMode, $logger) || return;
10520              
10521             # Check the account folders
10522 0         0 for my $account (sort { $a cmp $b } CDS->listFolder($accountsFolder)) {
  0         0  
10523 0 0       0 next if $account !~ /^[0-9a-f]{64}$/;
10524 0         0 my $accountFolder = $accountsFolder.'/'.$account;
10525 0 0       0 $permissions->checkPermissions($accountFolder, $permissions->accountFolderMode, $logger) || return;
10526              
10527             # Check the box folders
10528 0         0 for my $boxLabel (sort { $a cmp $b } CDS->listFolder($accountFolder)) {
  0         0  
10529 0 0       0 next if $boxLabel =~ /^\./;
10530 0         0 my $boxFolder = $accountFolder.'/'.$boxLabel;
10531 0 0       0 $permissions->checkPermissions($boxFolder, $permissions->boxFolderMode($boxLabel), $logger) || return;
10532              
10533             # Check each file
10534 0         0 my $filePermissions = $permissions->boxFileMode($boxLabel);
10535 0         0 for my $file (sort { $a cmp $b } CDS->listFolder($boxFolder)) {
  0         0  
10536 0 0       0 next if $file !~ /^[0-9a-f]{64}/;
10537 0 0       0 $permissions->checkPermissions($boxFolder.'/'.$file, $filePermissions, $logger) || return;
10538             }
10539             }
10540             }
10541              
10542             # Check the objects folder
10543 0         0 my $objectsFolder = $o->{folder}.'/objects';
10544 0         0 my $fileMode = $permissions->objectFileMode;
10545 0         0 my $folderMode = $permissions->objectFolderMode;
10546 0 0       0 $permissions->checkPermissions($objectsFolder, $folderMode, $logger) || return;
10547              
10548             # Check the 256 sub folders
10549 0         0 for my $sub (sort { $a cmp $b } CDS->listFolder($objectsFolder)) {
  0         0  
10550 0 0       0 next if $sub !~ /^[0-9a-f][0-9a-f]$/;
10551 0         0 my $subFolder = $objectsFolder.'/'.$sub;
10552 0 0       0 $permissions->checkPermissions($subFolder, $folderMode, $logger) || return;
10553              
10554 0         0 for my $file (sort { $a cmp $b } CDS->listFolder($subFolder)) {
  0         0  
10555 0 0       0 next if $file !~ /^[0-9a-f]{62}/;
10556 0 0       0 $permissions->checkPermissions($subFolder.'/'.$file, $fileMode, $logger) || return;
10557             }
10558             }
10559              
10560 0         0 return 1;
10561             }
10562              
10563             # Handles POSIX permissions (user, group, and mode).
10564             package CDS::FolderStore::PosixPermissions;
10565              
10566             # Returns the permissions set corresponding to the mode, uid, and gid of the base folder.
10567             # If the permissions are ambiguous, the more restrictive set is chosen.
10568             sub forFolder {
10569 0     0   0 my $class = shift;
10570 0         0 my $folder = shift;
10571              
10572 0         0 my @s = stat $folder;
10573 0   0     0 my $mode = $s[2] // 0;
10574              
10575             return
10576 0 0       0 ($mode & 077) == 077 ? CDS::FolderStore::PosixPermissions::World->new :
    0          
10577             ($mode & 070) == 070 ? CDS::FolderStore::PosixPermissions::Group->new($s[5]) :
10578             CDS::FolderStore::PosixPermissions::User->new($s[4]);
10579             }
10580              
10581 0     0   0 sub uid { shift->{uid} }
10582 0     0   0 sub gid { shift->{gid} }
10583              
10584             sub user {
10585 0     0   0 my $o = shift;
10586              
10587 0   0     0 my $uid = $o->{uid} // return;
10588 0   0     0 return getpwuid($uid) // $uid;
10589             }
10590              
10591             sub group {
10592 0     0   0 my $o = shift;
10593              
10594 0   0     0 my $gid = $o->{gid} // return;
10595 0   0     0 return getgrgid($gid) // $gid;
10596             }
10597              
10598             sub writeTemporaryFile {
10599 0     0   0 my $o = shift;
10600 0         0 my $folder = shift;
10601 0         0 my $mode = shift;
10602              
10603             # Write the file
10604 0         0 my $temporaryFile = $folder.'/.'.CDS->randomHex(16);
10605 0 0       0 open(my $fh, '>:bytes', $temporaryFile) || return;
10606 0         0 print $fh @_;
10607 0         0 close $fh;
10608              
10609             # Set the permissions
10610 0         0 chmod $mode, $temporaryFile;
10611 0         0 my $uid = $o->uid;
10612 0         0 my $gid = $o->gid;
10613 0 0 0     0 chown $uid // -1, $gid // -1, $temporaryFile if defined $uid && $uid != $< || defined $gid && $gid != $(;
      0        
      0        
      0        
      0        
10614 0         0 return $temporaryFile;
10615             }
10616              
10617             sub mkdir {
10618 0     0   0 my $o = shift;
10619 0         0 my $folder = shift;
10620 0         0 my $mode = shift;
10621              
10622 0 0       0 return if -d $folder;
10623              
10624             # Create the folder (note: mode is altered by umask)
10625 0         0 my $success = mkdir $folder, $mode;
10626              
10627             # Set the permissions
10628 0         0 chmod $mode, $folder;
10629 0         0 my $uid = $o->uid;
10630 0         0 my $gid = $o->gid;
10631 0 0 0     0 chown $uid // -1, $gid // -1, $folder if defined $uid && $uid != $< || defined $gid && $gid != $(;
      0        
      0        
      0        
      0        
10632 0         0 return $success;
10633             }
10634              
10635             # Check the permissions of a file or folder, and fix them if desired.
10636             # A logger object is called for the different cases (access error, correct permissions, wrong permissions, error fixing permissions).
10637             sub checkPermissions {
10638 0     0   0 my $o = shift;
10639 0         0 my $item = shift;
10640 0         0 my $expectedMode = shift;
10641 0         0 my $logger = shift;
10642              
10643 0         0 my $expectedUid = $o->uid;
10644 0         0 my $expectedGid = $o->gid;
10645              
10646             # Stat the item
10647 0         0 my @s = stat $item;
10648 0 0       0 return $logger->accessError($item) if ! scalar @s;
10649 0         0 my $mode = $s[2] & 07777;
10650 0         0 my $uid = $s[4];
10651 0         0 my $gid = $s[5];
10652              
10653             # Check
10654 0   0     0 my $wrongUid = defined $expectedUid && $uid != $expectedUid;
10655 0   0     0 my $wrongGid = defined $expectedGid && $gid != $expectedGid;
10656 0         0 my $wrongMode = $mode != $expectedMode;
10657 0 0 0     0 if ($wrongUid || $wrongGid || $wrongMode) {
      0        
10658             # Something is wrong
10659 0 0       0 $logger->wrong($item, $uid, $gid, $mode, $expectedUid, $expectedGid, $expectedMode) || return 1;
10660              
10661             # Fix uid and gid
10662 0 0 0     0 if ($wrongUid || $wrongGid) {
10663 0   0     0 my $count = chown $expectedUid // -1, $expectedGid // -1, $item;
      0        
10664 0 0       0 return $logger->setError($item) if $count < 1;
10665             }
10666              
10667             # Fix mode
10668 0 0       0 if ($wrongMode) {
10669 0         0 my $count = chmod $expectedMode, $item;
10670 0 0       0 return $logger->setError($item) if $count < 1;
10671             }
10672             } else {
10673             # Everything is OK
10674 0         0 $logger->correct($item, $mode, $uid, $gid);
10675             }
10676              
10677 0         0 return 1;
10678             }
10679              
10680             # The store belongs to a group. Every user belonging to the group is treated equivalent, and users are supposed to trust each other to some extent.
10681             # The resulting store will have files belonging to multiple users, but the same group.
10682             package CDS::FolderStore::PosixPermissions::Group;
10683              
10684 1     1   2491 use parent -norequire, 'CDS::FolderStore::PosixPermissions';
  1         1  
  1         4  
10685              
10686             sub new {
10687 0     0   0 my $class = shift;
10688 0         0 my $gid = shift;
10689              
10690 0   0     0 return bless {gid => $gid // $(};
10691             }
10692              
10693             sub target {
10694 0     0   0 my $o = shift;
10695 0         0 'members of the group '.$o->group }
10696 0     0   0 sub baseFolderMode { 0771 }
10697 0     0   0 sub objectFolderMode { 0771 }
10698 0     0   0 sub objectFileMode { 0664 }
10699 0     0   0 sub accountFolderMode { 0771 }
10700             sub boxFolderMode {
10701 0     0   0 my $o = shift;
10702 0         0 my $boxLabel = shift;
10703 0 0       0 $boxLabel eq 'public' ? 0775 : 0770 }
10704             sub boxFileMode {
10705 0     0   0 my $o = shift;
10706 0         0 my $boxLabel = shift;
10707 0 0       0 $boxLabel eq 'public' ? 0664 : 0660 }
10708              
10709             # The store belongs to a single user. Other users shall only be able to read objects and the public box, and post to the message box.
10710             package CDS::FolderStore::PosixPermissions::User;
10711              
10712 1     1   186 use parent -norequire, 'CDS::FolderStore::PosixPermissions';
  1         2  
  1         4  
10713              
10714             sub new {
10715 0     0   0 my $class = shift;
10716 0         0 my $uid = shift;
10717              
10718 0   0     0 return bless {uid => $uid // $<};
10719             }
10720              
10721             sub target {
10722 0     0   0 my $o = shift;
10723 0         0 'user '.$o->user }
10724 0     0   0 sub baseFolderMode { 0711 }
10725 0     0   0 sub objectFolderMode { 0711 }
10726 0     0   0 sub objectFileMode { 0644 }
10727 0     0   0 sub accountFolderMode { 0711 }
10728             sub boxFolderMode {
10729 0     0   0 my $o = shift;
10730 0         0 my $boxLabel = shift;
10731 0 0       0 $boxLabel eq 'public' ? 0755 : 0700 }
10732             sub boxFileMode {
10733 0     0   0 my $o = shift;
10734 0         0 my $boxLabel = shift;
10735 0 0       0 $boxLabel eq 'public' ? 0644 : 0600 }
10736              
10737             # The store is open to everybody. This does not usually make sense, but is offered here for completeness.
10738             # This is the simplest permission scheme.
10739             package CDS::FolderStore::PosixPermissions::World;
10740              
10741 1     1   235 use parent -norequire, 'CDS::FolderStore::PosixPermissions';
  1         2  
  1         3  
10742              
10743             sub new {
10744 0     0   0 my $class = shift;
10745              
10746 0         0 return bless {};
10747             }
10748              
10749 0     0   0 sub target { 'everybody' }
10750 0     0   0 sub baseFolderMode { 0777 }
10751 0     0   0 sub objectFolderMode { 0777 }
10752 0     0   0 sub objectFileMode { 0666 }
10753 0     0   0 sub accountFolderMode { 0777 }
10754 0     0   0 sub boxFolderMode { 0777 }
10755 0     0   0 sub boxFileMode { 0666 }
10756              
10757             package CDS::FolderStore::Watcher;
10758              
10759             sub new {
10760 0     0   0 my $class = shift;
10761 0         0 my $folder = shift;
10762              
10763 0         0 return bless {folder => $folder};
10764             }
10765              
10766             sub wait {
10767 0     0   0 my $o = shift;
10768 0         0 my $remaining = shift;
10769 0         0 my $until = shift;
10770              
10771 0 0       0 return if $remaining <= 0;
10772 0         0 sleep 1;
10773 0         0 return 1;
10774             }
10775              
10776             sub done {
10777 0     0   0 my $o = shift;
10778             }
10779              
10780             package CDS::GroupDataSharer;
10781              
10782             sub new {
10783 0     0   0 my $class = shift;
10784 0         0 my $actor = shift;
10785              
10786 0         0 my $o = bless {
10787             actor => $actor,
10788             label => 'shared group data',
10789             dataHandlers => {},
10790             messageChannel => CDS::MessageChannel->new($actor, 'group data', CDS->MONTH),
10791             revision => 0,
10792             version => '',
10793             }, $class;
10794              
10795 0         0 $actor->storagePrivateRoot->addDataHandler($o->{label}, $o);
10796 0         0 return $o;
10797             }
10798              
10799             ### Group data handlers
10800              
10801             sub addDataHandler {
10802 0     0   0 my $o = shift;
10803 0         0 my $label = shift;
10804 0         0 my $dataHandler = shift;
10805              
10806 0         0 $o->{dataHandlers}->{$label} = $dataHandler;
10807             }
10808              
10809             sub removeDataHandler {
10810 0     0   0 my $o = shift;
10811 0         0 my $label = shift;
10812 0         0 my $dataHandler = shift;
10813              
10814 0         0 my $registered = $o->{dataHandlers}->{$label};
10815 0 0       0 return if $registered != $dataHandler;
10816 0         0 delete $o->{dataHandlers}->{$label};
10817             }
10818              
10819             ### MergeableData interface
10820              
10821             sub addDataTo {
10822 0     0   0 my $o = shift;
10823 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
10824              
10825 0 0       0 return if ! $o->{revision};
10826 0         0 $record->addInteger($o->{revision})->add($o->{version});
10827             }
10828              
10829             sub mergeData {
10830 0     0   0 my $o = shift;
10831 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
10832              
10833 0         0 for my $child ($record->children) {
10834 0         0 my $revision = $child->asInteger;
10835 0 0       0 next if $revision <= $o->{revision};
10836              
10837 0         0 $o->{revision} = $revision;
10838 0         0 $o->{version} = $child->bytesValue;
10839             }
10840             }
10841              
10842             sub mergeExternalData {
10843 0     0   0 my $o = shift;
10844 0         0 my $store = shift;
10845 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
10846 0 0 0     0 my $source = shift; die 'wrong type '.ref($source).' for $source' if defined $source && ref $source ne 'CDS::Source';
  0         0  
10847              
10848 0         0 $o->mergeData($record);
10849 0 0       0 return if ! $source;
10850 0         0 $source->keep;
10851 0         0 $o->{actor}->storagePrivateRoot->unsaved->state->addMergedSource($source);
10852             }
10853              
10854             ### Sending messages
10855              
10856             sub createMessage {
10857 0     0   0 my $o = shift;
10858              
10859 0         0 my $message = CDS::Record->new;
10860 0         0 my $data = $message->add('group data');
10861 0         0 for my $label (keys %{$o->{dataHandlers}}) {
  0         0  
10862 0         0 my $dataHandler = $o->{dataHandlers}->{$label};
10863 0         0 $dataHandler->addDataTo($data->add($label));
10864             }
10865 0         0 return $message;
10866             }
10867              
10868             sub share {
10869 0     0   0 my $o = shift;
10870              
10871             # Get the group data members
10872 0   0     0 my $members = $o->{actor}->getGroupDataMembers // return;
10873 0 0       0 return 1 if ! scalar @$members;
10874              
10875             # Create the group data message, and check if it changed
10876 0         0 my $message = $o->createMessage;
10877 0         0 my $versionHash = $message->toObject->calculateHash;
10878 0 0       0 return if $versionHash->bytes eq $o->{version};
10879              
10880 0         0 $o->{revision} = CDS->now;
10881 0         0 $o->{version} = $versionHash->bytes;
10882 0         0 $o->{actor}->storagePrivateRoot->dataChanged;
10883              
10884             # Procure the sent list
10885 0   0     0 $o->{actor}->procureSentList // return;
10886              
10887             # Get the entrusted keys
10888 0   0     0 my $entrustedKeys = $o->{actor}->getEntrustedKeys // return;
10889              
10890             # Transfer the data
10891 0         0 $o->{messageChannel}->addTransfer([$message->dependentHashes], $o->{actor}->storagePrivateRoot->unsaved, 'group data message');
10892              
10893             # Send the message
10894 0         0 $o->{messageChannel}->setRecipients($members, $entrustedKeys);
10895 0         0 my ($submission, $missingObject) = $o->{messageChannel}->submit($message, $o);
10896 0 0       0 $o->{actor}->onMissingObject($missingObject) if $missingObject;
10897 0 0       0 return if ! $submission;
10898 0         0 return 1;
10899             }
10900              
10901             sub onMessageChannelSubmissionCancelled {
10902 0     0   0 my $o = shift;
10903             }
10904              
10905             sub onMessageChannelSubmissionRecipientDone {
10906 0     0   0 my $o = shift;
10907 0 0 0     0 my $recipientActorOnStore = shift; die 'wrong type '.ref($recipientActorOnStore).' for $recipientActorOnStore' if defined $recipientActorOnStore && ref $recipientActorOnStore ne 'CDS::ActorOnStore';
  0         0  
10908             }
10909              
10910             sub onMessageChannelSubmissionRecipientFailed {
10911 0     0   0 my $o = shift;
10912 0 0 0     0 my $recipientActorOnStore = shift; die 'wrong type '.ref($recipientActorOnStore).' for $recipientActorOnStore' if defined $recipientActorOnStore && ref $recipientActorOnStore ne 'CDS::ActorOnStore';
  0         0  
10913             }
10914              
10915             sub onMessageChannelSubmissionDone {
10916 0     0   0 my $o = shift;
10917 0         0 my $succeeded = shift;
10918 0         0 my $failed = shift;
10919             }
10920              
10921             ### Receiving messages
10922              
10923             sub processGroupDataMessage {
10924 0     0   0 my $o = shift;
10925 0         0 my $message = shift;
10926 0         0 my $section = shift;
10927              
10928 0 0       0 if (! $o->{actor}->isGroupMember($message->sender->publicKey->hash)) {
10929             # TODO:
10930             # If the sender is not a known group member, we should run actor group discovery on the sender. He may be part of us, but we don't know that yet.
10931             # At the very least, we should keep this message, and reconsider it if the actor group changes within the next few minutes (e.g. through another message).
10932 0         0 return;
10933             }
10934              
10935 0         0 for my $child ($section->children) {
10936 0   0     0 my $dataHandler = $o->{dataHandlers}->{$child->bytes} // next;
10937 0         0 $dataHandler->mergeExternalData($message->sender->store, $child, $message->source);
10938             }
10939              
10940 0         0 return 1;
10941             }
10942              
10943             package CDS::HTTPServer;
10944              
10945 1     1   1348 use parent -norequire, 'HTTP::Server::Simple';
  1         2  
  1         4  
10946              
10947             sub new {
10948 0     0   0 my $class = shift;
10949              
10950 0         0 my $o = $class->SUPER::new(@_);
10951 0         0 $o->{logger} = CDS::HTTPServer::Logger->new(*STDERR);
10952 0         0 $o->{handlers} = [];
10953 0         0 return $o;
10954             }
10955              
10956             sub addHandler {
10957 0     0   0 my $o = shift;
10958 0         0 my $handler = shift;
10959              
10960 0         0 push @{$o->{handlers}}, $handler;
  0         0  
10961             }
10962              
10963             sub setLogger {
10964 0     0   0 my $o = shift;
10965 0         0 my $logger = shift;
10966              
10967 0         0 $o->{logger} = $logger;
10968             }
10969              
10970 0     0   0 sub logger { shift->{logger} }
10971              
10972             sub setCorsAllowEverybody {
10973 0     0   0 my $o = shift;
10974 0         0 my $value = shift;
10975              
10976 0         0 $o->{corsAllowEverybody} = $value;
10977             }
10978              
10979 0     0   0 sub corsAllowEverybody { shift->{corsAllowEverybody} }
10980              
10981             # *** HTTP::Server::Simple interface
10982              
10983             sub print_banner {
10984 0     0   0 my $o = shift;
10985              
10986 0         0 $o->{logger}->onServerStarts($o->port);
10987             }
10988              
10989             sub setup {
10990 0     0   0 my $o = shift;
10991              
10992 0         0 my %parameters = @_;
10993             $o->{request} = CDS::HTTPServer::Request->new({
10994             logger => $o->logger,
10995             method => $parameters{method},
10996             path => $parameters{path},
10997             protocol => $parameters{protocol},
10998             queryString => $parameters{query_string},
10999             peerAddress => $parameters{peeraddr},
11000             peerPort => $parameters{peerport},
11001 0         0 headers => {},
11002             corsAllowEverybody => $o->corsAllowEverybody,
11003             });
11004             }
11005              
11006             sub headers {
11007 0     0   0 my $o = shift;
11008 0         0 my $headers = shift;
11009              
11010 0         0 while (scalar @$headers) {
11011 0         0 my $key = shift @$headers;
11012 0         0 my $value = shift @$headers;
11013 0         0 $o->{request}->setHeader($key, $value);
11014             }
11015              
11016             # Read the content length
11017 0   0     0 $o->{request}->setRemainingData($o->{request}->header('content-length') // 0);
11018             }
11019              
11020             sub handler {
11021 0     0   0 my $o = shift;
11022              
11023             # Start writing the log line
11024 0         0 $o->{logger}->onRequestStarts($o->{request});
11025              
11026             # Process the request
11027 0         0 my $responseCode = $o->process;
11028 0         0 $o->{logger}->onRequestDone($o->{request}, $responseCode);
11029              
11030             # Wrap up
11031 0         0 $o->{request}->dropData;
11032 0         0 $o->{request} = undef;
11033 0         0 return;
11034             }
11035              
11036             sub process {
11037 0     0   0 my $o = shift;
11038              
11039             # Run the handler
11040 0         0 for my $handler (@{$o->{handlers}}) {
  0         0  
11041 0   0     0 my $responseCode = $handler->process($o->{request}) || next;
11042 0         0 return $responseCode;
11043             }
11044              
11045             # Default handler
11046 0         0 return $o->{request}->reply404;
11047             }
11048              
11049             sub bad_request {
11050 0     0   0 my $o = shift;
11051              
11052 0         0 my $content = 'Bad Request';
11053 0         0 print 'HTTP/1.1 400 Bad Request', "\r\n";
11054 0         0 print 'Content-Length: ', length $content, "\r\n";
11055 0         0 print 'Content-Type: text/plain; charset=utf-8', "\r\n";
11056 0         0 print "\r\n";
11057 0         0 print $content;
11058 0         0 $o->{request} = undef;
11059             }
11060              
11061             package CDS::HTTPServer::IdentificationHandler;
11062              
11063             sub new {
11064 0     0   0 my $class = shift;
11065 0         0 my $root = shift;
11066              
11067 0         0 return bless {root => $root};
11068             }
11069              
11070             sub process {
11071 0     0   0 my $o = shift;
11072 0         0 my $request = shift;
11073              
11074 0   0     0 my $path = $request->pathAbove($o->{root}) // return;
11075 0 0       0 return if $path ne '/';
11076              
11077             # Options
11078 0 0       0 return $request->replyOptions('HEAD', 'GET') if $request->method eq 'OPTIONS';
11079              
11080             # Get
11081 0 0 0     0 return $request->reply200HTML('Condensation HTTP StoreThis is a Condensation HTTP Store server.') if $request->method eq 'HEAD' || $request->method eq 'GET';
11082              
11083 0         0 return $request->reply405;
11084             }
11085              
11086             package CDS::HTTPServer::Logger;
11087              
11088             sub new {
11089 0     0   0 my $class = shift;
11090 0         0 my $fileHandle = shift;
11091              
11092 0         0 return bless {
11093             fileHandle => $fileHandle,
11094             lineStarted => 0,
11095             };
11096             }
11097              
11098             sub onServerStarts {
11099 0     0   0 my $o = shift;
11100 0         0 my $port = shift;
11101              
11102 0         0 my $fh = $o->{fileHandle};
11103 0         0 my @t = localtime(time);
11104 0         0 printf $fh '%04d-%02d-%02d %02d:%02d:%02d ', $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0];
11105 0         0 print $fh 'Server ready at http://localhost:', $port, "\n";
11106             }
11107              
11108             sub onRequestStarts {
11109 0     0   0 my $o = shift;
11110 0         0 my $request = shift;
11111              
11112 0         0 my $fh = $o->{fileHandle};
11113 0         0 my @t = localtime(time);
11114 0         0 printf $fh '%04d-%02d-%02d %02d:%02d:%02d ', $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0];
11115 0         0 print $fh $request->peerAddress, ' ', $request->method, ' ', $request->path;
11116 0         0 $o->{lineStarted} = 1;
11117             }
11118              
11119             sub onRequestError {
11120 0     0   0 my $o = shift;
11121 0         0 my $request = shift;
11122              
11123 0         0 my $fh = $o->{fileHandle};
11124 0 0       0 print $fh "\n" if $o->{lineStarted};
11125 0         0 print $fh ' ', @_, "\n";
11126 0         0 $o->{lineStarted} = 0;
11127             }
11128              
11129             sub onRequestDone {
11130 0     0   0 my $o = shift;
11131 0         0 my $request = shift;
11132 0         0 my $responseCode = shift;
11133              
11134 0         0 my $fh = $o->{fileHandle};
11135 0 0       0 print $fh ' ===> ' if ! $o->{lineStarted};
11136 0         0 print $fh ' ', $responseCode, "\n";
11137 0         0 $o->{lineStarted} = 0;
11138             }
11139              
11140             package CDS::HTTPServer::MessageGatewayHandler;
11141              
11142             sub new {
11143 0     0   0 my $class = shift;
11144 0         0 my $root = shift;
11145 0         0 my $actor = shift;
11146 0         0 my $store = shift;
11147 0 0 0     0 my $recipientHash = shift; die 'wrong type '.ref($recipientHash).' for $recipientHash' if defined $recipientHash && ref $recipientHash ne 'CDS::Hash';
  0         0  
11148              
11149 0         0 return bless {root => $root, actor => $actor, store => $store, recipientHash => $recipientHash};
11150             }
11151              
11152             sub process {
11153 0     0   0 my $o = shift;
11154 0         0 my $request = shift;
11155              
11156 0   0     0 my $path = $request->pathAbove($o->{root}) // return;
11157 0 0       0 return if $path ne '/';
11158              
11159             # Options
11160 0 0       0 return $request->replyOptions('HEAD', 'GET', 'PUT', 'POST', 'DELETE') if $request->method eq 'OPTIONS';
11161              
11162             # Prepare a message
11163 0         0 my $message = CDS::Record->new;
11164 0         0 $message->add('time')->addInteger(CDS->now);
11165 0         0 $message->add('ip')->add($request->peerAddress);
11166 0         0 $message->add('method')->add($request->method);
11167 0         0 $message->add('path')->add($request->path);
11168 0         0 $message->add('query string')->add($request->queryString);
11169              
11170 0         0 my $headersRecord = $message->add('headers');
11171 0         0 my $headers = $request->headers;
11172 0         0 for my $key (keys %$headers) {
11173 0         0 $headersRecord->add($key)->add($headers->{$key});
11174             }
11175              
11176             # Prepare a channel
11177 0         0 my $channel = CDS::MessageChannel->new($o->{actor}, CDS->randomBytes(8), CDS->WEEK);
11178 0         0 $o->{messageChannel}->setRecipients([$o->{recipientHash}], []);
11179              
11180             # Add the data
11181 0 0       0 if ($request->remainingData > 1024) {
    0          
11182             # Store the data as a separate object
11183 0         0 my $object = CDS::Object->create(CDS::Object->emptyHeader, $request->readData);
11184 0         0 my $key = CDS->randomKey;
11185 0         0 my $encryptedObject = $object->crypt($key);
11186 0         0 my $hash = $encryptedObject->calculateHash;
11187 0         0 $message->add('data')->addHash($hash);
11188 0         0 $channel->addObject($hash, $encryptedObject);
11189             } elsif ($request->remainingData) {
11190 0         0 $message->add('data')->add($request->readData)
11191             }
11192              
11193             # Submit
11194 0         0 my ($submission, $missingObject) = $channel->submit($message, $o);
11195 0         0 $o->{actor}->sendMessages;
11196              
11197 0 0       0 return $submission ? $request->reply200 : $request->reply500('Unable to send the message.');
11198             }
11199              
11200             sub onMessageChannelSubmissionCancelled {
11201 0     0   0 my $o = shift;
11202             }
11203              
11204             sub onMessageChannelSubmissionRecipientDone {
11205 0     0   0 my $o = shift;
11206 0 0 0     0 my $recipientActorOnStore = shift; die 'wrong type '.ref($recipientActorOnStore).' for $recipientActorOnStore' if defined $recipientActorOnStore && ref $recipientActorOnStore ne 'CDS::ActorOnStore';
  0         0  
11207             }
11208              
11209             sub onMessageChannelSubmissionRecipientFailed {
11210 0     0   0 my $o = shift;
11211 0 0 0     0 my $recipientActorOnStore = shift; die 'wrong type '.ref($recipientActorOnStore).' for $recipientActorOnStore' if defined $recipientActorOnStore && ref $recipientActorOnStore ne 'CDS::ActorOnStore';
  0         0  
11212             }
11213              
11214             sub onMessageChannelSubmissionDone {
11215 0     0   0 my $o = shift;
11216 0         0 my $succeeded = shift;
11217 0         0 my $failed = shift;
11218             }
11219              
11220             package CDS::HTTPServer::Request;
11221              
11222             sub new {
11223 0     0   0 my $class = shift;
11224 0         0 my $parameters = shift;
11225              
11226 0         0 return bless $parameters;
11227             }
11228              
11229 0     0   0 sub logger { shift->{logger} }
11230 0     0   0 sub method { shift->{method} }
11231 0     0   0 sub path { shift->{path} }
11232 0     0   0 sub queryString { shift->{queryString} }
11233 0     0   0 sub peerAddress { shift->{peerAddress} }
11234 0     0   0 sub peerPort { shift->{peerPort} }
11235 0     0   0 sub headers { shift->{headers} }
11236 0     0   0 sub remainingData { shift->{remainingData} }
11237 0     0   0 sub corsAllowEverybody { shift->{corsAllowEverybody} }
11238              
11239             # *** Path
11240              
11241             sub pathAbove {
11242 0     0   0 my $o = shift;
11243 0         0 my $root = shift;
11244              
11245 0 0       0 $root .= '/' if $root !~ /\/$/;
11246 0 0       0 return if substr($o->{path}, 0, length $root) ne $root;
11247 0         0 return substr($o->{path}, length($root) - 1);
11248             }
11249              
11250             # *** Request data
11251              
11252             sub setRemainingData {
11253 0     0   0 my $o = shift;
11254 0         0 my $remainingData = shift;
11255              
11256 0         0 $o->{remainingData} = $remainingData;
11257             }
11258              
11259             # Reads the request data
11260             sub readData {
11261 0     0   0 my $o = shift;
11262              
11263 0         0 my @buffers;
11264 0         0 while ($o->{remainingData} > 0) {
11265 0   0     0 my $read = sysread(STDIN, my $buffer, $o->{remainingData}) || return;
11266 0         0 $o->{remainingData} -= $read;
11267 0         0 push @buffers, $buffer;
11268             }
11269              
11270 0         0 return join('', @buffers);
11271             }
11272              
11273             # Read the request data and writes it directly to a file handle
11274             sub copyDataAndCalculateHash {
11275 0     0   0 my $o = shift;
11276 0         0 my $fh = shift;
11277              
11278 0         0 my $sha = Digest::SHA->new(256);
11279 0         0 while ($o->{remainingData} > 0) {
11280 0   0     0 my $read = sysread(STDIN, my $buffer, $o->{remainingData}) || return;
11281 0         0 $o->{remainingData} -= $read;
11282 0         0 $sha->add($buffer);
11283 0         0 print $fh $buffer;
11284             }
11285              
11286 0         0 return $sha->digest;
11287             }
11288              
11289             # Reads and drops the request data
11290             sub dropData {
11291 0     0   0 my $o = shift;
11292              
11293 0         0 while ($o->{remainingData} > 0) {
11294 0   0     0 $o->{remainingData} -= read(STDIN, my $buffer, $o->{remainingData}) || return;
11295             }
11296             }
11297              
11298             # *** Headers
11299              
11300             sub setHeader {
11301 0     0   0 my $o = shift;
11302 0         0 my $key = shift;
11303 0         0 my $value = shift;
11304              
11305 0         0 $o->{headers}->{lc($key)} = $value;
11306             }
11307              
11308             sub header {
11309 0     0   0 my $o = shift;
11310 0         0 my $key = shift;
11311              
11312 0         0 return $o->{headers}->{lc($key)};
11313             }
11314              
11315             # *** Query string
11316              
11317             sub parseQueryString {
11318 0     0   0 my $o = shift;
11319              
11320 0 0       0 return {} if ! defined $o->{queryString};
11321              
11322 0         0 my $values = {};
11323 0         0 for my $pair (split /&/, $o->{queryString}) {
11324 0 0       0 if ($pair =~ /^(.*?)=(.*)$/) {
11325 0         0 my $key = $1;
11326 0         0 my $value = $2;
11327 0         0 $values->{&uri_decode($key)} = &uri_decode($value);
11328             } else {
11329 0         0 $values->{&uri_decode($pair)} = 1;
11330             }
11331             }
11332              
11333 0         0 return $values;
11334             }
11335              
11336             sub uri_decode {
11337 0     0   0 my $encoded = shift;
11338              
11339 0         0 $encoded =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
  0         0  
11340 0         0 return $encoded;
11341             }
11342              
11343             # *** Condensation signature
11344              
11345             sub checkSignature {
11346 0     0   0 my $o = shift;
11347 0         0 my $store = shift;
11348 0         0 my $contentBytesToSign = shift;
11349              
11350             # Check the date
11351 0   0     0 my $dateString = $o->{headers}->{'condensation-date'} // $o->{headers}->{'date'} // return;
      0        
11352 0   0     0 my $date = HTTP::Date::str2time($dateString) // return;
11353 0         0 my $now = time;
11354 0 0 0     0 return if $date < $now - 120 || $date > $now + 60;
11355              
11356             # Get and check the actor
11357 0   0     0 my $actorHash = CDS::Hash->fromHex($o->{headers}->{'condensation-actor'}) // return;
11358 0         0 my ($publicKeyObject, $error) = $store->get($actorHash);
11359 0 0       0 return if ! $publicKeyObject;
11360 0 0       0 return if ! $publicKeyObject->calculateHash->equals($actorHash);
11361 0   0     0 my $publicKey = CDS::PublicKey->fromObject($publicKeyObject) // return;
11362              
11363             # Text to sign
11364 0         0 my $bytesToSign = $dateString."\0".uc($o->{method})."\0".$o->{headers}->{'host'}.$o->{path};
11365 0 0       0 $bytesToSign .= "\0".$contentBytesToSign if defined $contentBytesToSign;
11366 0         0 my $hashToSign = CDS::Hash->calculateFor($bytesToSign);
11367              
11368             # Check the signature
11369 0   0     0 my $signatureString = $o->{headers}->{'condensation-signature'} // return;
11370 0   0     0 $signatureString =~ /^\s*([0-9a-z]{512,512})\s*$/ // return;
11371 0         0 my $signature = pack('H*', $1);
11372 0 0       0 return if ! $publicKey->verifyHash($hashToSign, $signature);
11373              
11374             # Return the verified actor hash
11375 0         0 return $actorHash;
11376             }
11377              
11378             # *** Reply functions
11379              
11380             sub reply200 {
11381 0     0   0 my $o = shift;
11382 0   0     0 my $content = shift // '';
11383              
11384 0 0       0 return length $content ? $o->reply(200, 'OK', &textContentType, $content) : $o->reply(204, 'No Content', {});
11385             }
11386              
11387             sub reply200Bytes {
11388 0     0   0 my $o = shift;
11389 0   0     0 my $content = shift // '';
11390              
11391 0 0       0 return length $content ? $o->reply(200, 'OK', {'Content-Type' => 'application/octet-stream'}, $content) : $o->reply(204, 'No Content', {});
11392             }
11393              
11394             sub reply200HTML {
11395 0     0   0 my $o = shift;
11396 0   0     0 my $content = shift // '';
11397              
11398 0 0       0 return length $content ? $o->reply(200, 'OK', {'Content-Type' => 'text/html; charset=utf-8'}, $content) : $o->reply(204, 'No Content', {});
11399             }
11400              
11401             sub replyOptions {
11402 0     0   0 my $o = shift;
11403              
11404 0         0 my $headers = {};
11405 0         0 $headers->{'Allow'} = join(', ', @_, 'OPTIONS');
11406 0 0 0     0 $headers->{'Access-Control-Allow-Methods'} = join(', ', @_, 'OPTIONS') if $o->corsAllowEverybody && $o->{headers}->{'origin'};
11407 0         0 return $o->reply(200, 'OK', $headers);
11408             }
11409              
11410             sub replyFatalError {
11411 0     0   0 my $o = shift;
11412              
11413 0         0 $o->{logger}->onRequestError($o, @_);
11414 0         0 return $o->reply500;
11415             }
11416              
11417             sub reply303 {
11418 0     0   0 my $o = shift;
11419 0         0 my $location = shift;
11420 0         0 $o->reply(303, 'See Other', {'Location' => $location}) }
11421 0     0   0 sub reply400 { shift->reply(400, 'Bad Request', &textContentType, @_) }
11422 0     0   0 sub reply403 { shift->reply(403, 'Forbidden', &textContentType, @_) }
11423 0     0   0 sub reply404 { shift->reply(404, 'Not Found', &textContentType, @_) }
11424 0     0   0 sub reply405 { shift->reply(405, 'Method Not Allowed', &textContentType, @_) }
11425 0     0   0 sub reply500 { shift->reply(500, 'Internal Server Error', &textContentType, @_) }
11426 0     0   0 sub reply503 { shift->reply(503, 'Service Not Available', &textContentType, @_) }
11427              
11428             sub reply {
11429 0     0   0 my $o = shift;
11430 0         0 my $responseCode = shift;
11431 0         0 my $responseLabel = shift;
11432 0   0     0 my $headers = shift // {};
11433 0   0     0 my $content = shift // '';
11434              
11435             # Content-related headers
11436 0         0 $headers->{'Content-Length'} = length($content);
11437              
11438             # Origin
11439 0 0 0     0 if ($o->corsAllowEverybody && (my $origin = $o->{headers}->{'origin'})) {
11440 0         0 $headers->{'Access-Control-Allow-Origin'} = $origin;
11441 0         0 $headers->{'Access-Control-Allow-Headers'} = 'Content-Type';
11442 0         0 $headers->{'Access-Control-Max-Age'} = '86400';
11443             }
11444              
11445             # Write the reply
11446 0         0 print 'HTTP/1.1 ', $responseCode, ' ', $responseLabel, "\r\n";
11447 0         0 for my $key (keys %$headers) {
11448 0         0 print $key, ': ', $headers->{$key}, "\r\n";
11449             }
11450 0         0 print "\r\n";
11451 0 0       0 print $content if $o->{method} ne 'HEAD';
11452              
11453             # Return the response code
11454 0         0 return $responseCode;
11455             }
11456              
11457 0     0   0 sub textContentType { {'Content-Type' => 'text/plain; charset=utf-8'} }
11458              
11459             package CDS::HTTPServer::StaticContentHandler;
11460              
11461             sub new {
11462 0     0   0 my $class = shift;
11463 0         0 my $path = shift;
11464 0         0 my $content = shift;
11465 0         0 my $contentType = shift;
11466              
11467 0         0 return bless {
11468             path => $path,
11469             content => $content,
11470             contentType => $contentType,
11471             };
11472             }
11473              
11474             sub process {
11475 0     0   0 my $o = shift;
11476 0         0 my $request = shift;
11477              
11478 0 0       0 return if $request->path ne $o->{path};
11479              
11480             # Options
11481 0 0       0 return $request->replyOptions('HEAD', 'GET') if $request->method eq 'OPTIONS';
11482              
11483             # GET
11484 0 0       0 return $request->reply(200, 'OK', {'Content-Type' => $o->{contentType}}, $o->{content}) if $request->method eq 'GET';
11485              
11486             # Everything else
11487 0         0 return $request->reply405;
11488             }
11489              
11490             package CDS::HTTPServer::StaticFilesHandler;
11491              
11492             sub new {
11493 0     0   0 my $class = shift;
11494 0         0 my $root = shift;
11495 0         0 my $folder = shift;
11496 0   0     0 my $defaultFile = shift // '';
11497              
11498 0         0 return bless {
11499             root => $root,
11500             folder => $folder,
11501             defaultFile => $defaultFile,
11502             mimeTypesByExtension => {
11503             'css' => 'text/css',
11504             'gif' => 'image/gif',
11505             'html' => 'text/html',
11506             'jpg' => 'image/jpeg',
11507             'jpeg' => 'image/jpeg',
11508             'js' => 'application/javascript',
11509             'mp4' => 'video/mp4',
11510             'ogg' => 'video/ogg',
11511             'pdf' => 'application/pdf',
11512             'png' => 'image/png',
11513             'svg' => 'image/svg+xml',
11514             'txt' => 'text/plain',
11515             'webm' => 'video/webm',
11516             'zip' => 'application/zip',
11517             },
11518             };
11519             }
11520              
11521 0     0   0 sub folder { shift->{folder} }
11522 0     0   0 sub defaultFile { shift->{defaultFile} }
11523 0     0   0 sub mimeTypesByExtension { shift->{mimeTypesByExtension} }
11524              
11525             sub setContentType {
11526 0     0   0 my $o = shift;
11527 0         0 my $extension = shift;
11528 0         0 my $contentType = shift;
11529              
11530 0         0 $o->{mimeTypesByExtension}->{$extension} = $contentType;
11531             }
11532              
11533             sub process {
11534 0     0   0 my $o = shift;
11535 0         0 my $request = shift;
11536              
11537             # Options
11538 0 0       0 return $request->replyOptions('HEAD', 'GET') if $request->method eq 'OPTIONS';
11539              
11540             # Get
11541 0 0 0     0 return $o->get($request) if $request->method eq 'GET' || $request->method eq 'HEAD';
11542              
11543             # Anything else
11544 0         0 return $request->reply405;
11545             }
11546              
11547             sub get {
11548 0     0   0 my $o = shift;
11549 0         0 my $request = shift;
11550              
11551 0   0     0 my $path = $request->pathAbove($o->{root}) // return;
11552 0         0 return $o->deliverFileForPath($request, $path);
11553             }
11554              
11555             sub deliverFileForPath {
11556 0     0   0 my $o = shift;
11557 0         0 my $request = shift;
11558 0         0 my $path = shift;
11559              
11560             # Hidden files (starting with a dot), as well as "." and ".." never exist
11561 0         0 for my $segment (split /\/+/, $path) {
11562 0 0       0 return $request->reply404 if $segment =~ /^\./;
11563             }
11564              
11565             # If a folder is requested, we serve the default file
11566 0         0 my $file = $o->{folder}.$path;
11567 0 0       0 if (-d $file) {
11568 0 0       0 return $request->reply404 if ! length $o->{defaultFile};
11569 0 0       0 return $request->reply303($request->path.'/') if $file !~ /\/$/;
11570 0         0 $file .= $o->{defaultFile};
11571             }
11572              
11573 0         0 return $o->deliverFile($request, $file);
11574             }
11575              
11576             sub deliverFile {
11577 0     0   0 my $o = shift;
11578 0         0 my $request = shift;
11579 0         0 my $file = shift;
11580 0   0     0 my $contentType = shift // $o->guessContentType($file);
11581              
11582 0   0     0 my $bytes = $o->readFile($file) // return $request->reply404;
11583 0         0 return $request->reply(200, 'OK', {'Content-Type' => $contentType}, $bytes);
11584             }
11585              
11586             # Guesses the content type from the extension
11587             sub guessContentType {
11588 0     0   0 my $o = shift;
11589 0         0 my $file = shift;
11590              
11591 0 0       0 my $extension = $file =~ /\.([A-Za-z0-9]*)$/ ? lc($1) : '';
11592 0   0     0 return $o->{mimeTypesByExtension}->{$extension} // 'application/octet-stream';
11593             }
11594              
11595             # Reads a file
11596             sub readFile {
11597 0     0   0 my $o = shift;
11598 0         0 my $file = shift;
11599              
11600 0 0       0 open(my $fh, '<:bytes', $file) || return;
11601 0 0       0 if (! -f $fh) {
11602 0         0 close $fh;
11603 0         0 return;
11604             }
11605              
11606 0         0 local $/ = undef;
11607 0         0 my $bytes = <$fh>;
11608 0         0 close $fh;
11609 0         0 return $bytes;
11610             }
11611              
11612             package CDS::HTTPServer::StoreHandler;
11613              
11614             sub new {
11615 0     0   0 my $class = shift;
11616 0         0 my $root = shift;
11617 0         0 my $store = shift;
11618 0         0 my $checkPutHash = shift;
11619 0   0     0 my $checkSignatures = shift // 1;
11620              
11621 0         0 return bless {
11622             root => $root,
11623             store => $store,
11624             checkPutHash => $checkPutHash,
11625             checkEnvelopeHash => $checkPutHash,
11626             checkSignatures => $checkSignatures,
11627             maximumWatchTimeout => 0,
11628             };
11629             }
11630              
11631             sub process {
11632 0     0   0 my $o = shift;
11633 0         0 my $request = shift;
11634              
11635 0   0     0 my $path = $request->pathAbove($o->{root}) // return;
11636              
11637             # Objects request
11638 0 0       0 if ($request->path =~ /^\/objects\/([0-9a-f]{64})$/) {
11639 0         0 my $hash = CDS::Hash->fromHex($1);
11640 0         0 return $o->objects($request, $hash);
11641             }
11642              
11643             # Box request
11644 0 0       0 if ($request->path =~ /^\/accounts\/([0-9a-f]{64})\/(messages|private|public)$/) {
11645 0         0 my $accountHash = CDS::Hash->fromHex($1);
11646 0         0 my $boxLabel = $2;
11647 0         0 return $o->box($request, $accountHash, $boxLabel);
11648             }
11649              
11650             # Box entry request
11651 0 0       0 if ($request->path =~ /^\/accounts\/([0-9a-f]{64})\/(messages|private|public)\/([0-9a-f]{64})$/) {
11652 0         0 my $accountHash = CDS::Hash->fromHex($1);
11653 0         0 my $boxLabel = $2;
11654 0         0 my $hash = CDS::Hash->fromHex($3);
11655 0         0 return $o->boxEntry($request, $accountHash, $boxLabel, $hash);
11656             }
11657              
11658             # Account request
11659 0 0       0 if ($request->path =~ /^\/accounts\/([0-9a-f]{64})$/) {
11660 0 0       0 return $request->replyOptions if $request->method eq 'OPTIONS';
11661 0         0 return $request->reply405;
11662             }
11663              
11664             # Accounts request
11665 0 0       0 if ($request->path =~ /^\/accounts$/) {
11666 0         0 return $o->accounts($request);
11667             }
11668              
11669             # Other requests on /objects or /accounts
11670 0 0       0 if ($request->path =~ /^\/(accounts|objects)(\/|$)/) {
11671 0         0 return $request->reply404;
11672             }
11673              
11674             # Nothing for us
11675 0         0 return;
11676             }
11677              
11678             sub objects {
11679 0     0   0 my $o = shift;
11680 0         0 my $request = shift;
11681 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
11682              
11683             # Options
11684 0 0       0 if ($request->method eq 'OPTIONS') {
11685 0         0 return $request->replyOptions('HEAD', 'GET', 'PUT', 'POST');
11686             }
11687              
11688             # Retrieve object
11689 0 0 0     0 if ($request->method eq 'HEAD' || $request->method eq 'GET') {
11690 0         0 my ($object, $error) = $o->{store}->get($hash);
11691 0 0       0 return $request->replyFatalError($error) if defined $error;
11692 0 0       0 return $request->reply404 if ! $object;
11693             # We don't check the SHA256 sum here - this should be done by the client
11694 0         0 return $request->reply200Bytes($object->bytes);
11695             }
11696              
11697             # Put object
11698 0 0       0 if ($request->method eq 'PUT') {
11699 0   0     0 my $bytes = $request->readData // return $request->reply400('No data received.');
11700 0   0     0 my $object = CDS::Object->fromBytes($bytes) // return $request->reply400('Not a Condensation object.');
11701 0 0 0     0 return $request->reply400('SHA256 sum does not match hash.') if $o->{checkPutHash} && ! $object->calculateHash->equals($hash);
11702              
11703 0 0       0 if ($o->{checkSignatures}) {
11704 0         0 my $checkSignatureStore = CDS::CheckSignatureStore->new($o->{store});
11705 0         0 $checkSignatureStore->put($hash, $object);
11706 0 0       0 return $request->reply403 if ! $request->checkSignature($checkSignatureStore);
11707             }
11708              
11709 0         0 my $error = $o->{store}->put($hash, $object);
11710 0 0       0 return $request->replyFatalError($error) if defined $error;
11711 0         0 return $request->reply200;
11712             }
11713              
11714             # Book object
11715 0 0       0 if ($request->method eq 'POST') {
11716 0 0 0     0 return $request->reply403 if $o->{checkSignatures} && ! $request->checkSignature($o->{store});
11717 0 0       0 return $request->reply400('You cannot send data when booking an object.') if $request->remainingData;
11718 0         0 my ($booked, $error) = $o->{store}->book($hash);
11719 0 0       0 return $request->replyFatalError($error) if defined $error;
11720 0 0       0 return $booked ? $request->reply200 : $request->reply404;
11721             }
11722              
11723 0         0 return $request->reply405;
11724             }
11725              
11726             sub box {
11727 0     0   0 my $o = shift;
11728 0         0 my $request = shift;
11729 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
11730 0         0 my $boxLabel = shift;
11731              
11732             # Options
11733 0 0       0 if ($request->method eq 'OPTIONS') {
11734 0         0 return $request->replyOptions('HEAD', 'GET', 'PUT', 'POST');
11735             }
11736              
11737             # List box
11738 0 0 0     0 if ($request->method eq 'HEAD' || $request->method eq 'GET') {
11739 0   0     0 my $watch = $request->headers->{'condensation-watch'} // '';
11740 0 0       0 my $timeout = $watch =~ /^(\d+)\s*ms$/ ? $1 + 0 : 0;
11741 0 0       0 $timeout = $o->{maximumWatchTimeout} if $timeout > $o->{maximumWatchTimeout};
11742 0         0 my ($hashes, $error) = $o->{store}->list($accountHash, $boxLabel, $timeout);
11743 0 0       0 return $request->replyFatalError($error) if defined $error;
11744 0         0 return $request->reply200Bytes(join('', map { $_->bytes } @$hashes));
  0         0  
11745             }
11746              
11747 0         0 return $request->reply405;
11748             }
11749              
11750             sub boxEntry {
11751 0     0   0 my $o = shift;
11752 0         0 my $request = shift;
11753 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
11754 0         0 my $boxLabel = shift;
11755 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
11756              
11757             # Options
11758 0 0       0 if ($request->method eq 'OPTIONS') {
11759 0         0 return $request->replyOptions('HEAD', 'PUT', 'DELETE');
11760             }
11761              
11762             # Add
11763 0 0       0 if ($request->method eq 'PUT') {
11764 0 0       0 if ($o->{checkSignatures}) {
11765 0         0 my $actorHash = $request->checkSignature($o->{store});
11766 0 0       0 return $request->reply403 if ! $actorHash;
11767 0 0       0 return $request->reply403 if ! $o->verifyAddition($actorHash, $accountHash, $boxLabel, $hash);
11768             }
11769              
11770 0         0 my $error = $o->{store}->add($accountHash, $boxLabel, $hash);
11771 0 0       0 return $request->replyFatalError($error) if defined $error;
11772 0         0 return $request->reply200;
11773             }
11774              
11775             # Remove
11776 0 0       0 if ($request->method eq 'DELETE') {
11777 0 0       0 if ($o->{checkSignatures}) {
11778 0         0 my $actorHash = $request->checkSignature($o->{store});
11779 0 0       0 return $request->reply403 if ! $actorHash;
11780 0 0       0 return $request->reply403 if ! $o->verifyRemoval($actorHash, $accountHash, $boxLabel, $hash);
11781             }
11782              
11783 0         0 my ($booked, $error) = $o->{store}->remove($accountHash, $boxLabel, $hash);
11784 0 0       0 return $request->replyFatalError($error) if defined $error;
11785 0         0 return $request->reply200;
11786             }
11787              
11788 0         0 return $request->reply405;
11789             }
11790              
11791             sub accounts {
11792 0     0   0 my $o = shift;
11793 0         0 my $request = shift;
11794              
11795             # Options
11796 0 0       0 if ($request->method eq 'OPTIONS') {
11797 0         0 return $request->replyOptions('POST');
11798             }
11799              
11800             # Modify boxes
11801 0 0       0 if ($request->method eq 'POST') {
11802 0   0     0 my $bytes = $request->readData // return $request->reply400('No data received.');
11803 0         0 my $modifications = CDS::StoreModifications->fromBytes($bytes);
11804 0 0       0 return $request->reply400('Invalid modifications.') if ! $modifications;
11805              
11806 0 0       0 if ($o->{checkSignatures}) {
11807 0         0 my $actorHash = $request->checkSignature(CDS::CheckSignatureStore->new($o->{store}, $modifications->objects), $bytes);
11808 0 0       0 return $request->reply403 if ! $actorHash;
11809 0 0       0 return $request->reply403 if ! $o->verifyModifications($actorHash, $modifications);
11810             }
11811              
11812 0         0 my $error = $o->{store}->modify($modifications);
11813 0 0       0 return $request->replyFatalError($error) if defined $error;
11814 0         0 return $request->reply200;
11815             }
11816              
11817 0         0 return $request->reply405;
11818             }
11819              
11820             sub verifyModifications {
11821 0     0   0 my $o = shift;
11822 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
11823 0         0 my $modifications = shift;
11824              
11825 0         0 for my $operation (@{$modifications->additions}) {
  0         0  
11826 0 0       0 return if ! $o->verifyAddition($actorHash, $operation->{accountHash}, $operation->{boxLabel}, $operation->{hash});
11827             }
11828              
11829 0         0 for my $operation (@{$modifications->removals}) {
  0         0  
11830 0 0       0 return if ! $o->verifyRemoval($actorHash, $operation->{accountHash}, $operation->{boxLabel}, $operation->{hash});
11831             }
11832              
11833 0         0 return 1;
11834             }
11835              
11836             sub verifyAddition {
11837 0     0   0 my $o = shift;
11838 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
11839 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
11840 0         0 my $boxLabel = shift;
11841 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
11842              
11843 0 0       0 return 1 if $accountHash->equals($actorHash);
11844 0 0       0 return 1 if $boxLabel eq 'messages';
11845 0         0 return;
11846             }
11847              
11848             sub verifyRemoval {
11849 0     0   0 my $o = shift;
11850 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
11851 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
11852 0         0 my $boxLabel = shift;
11853 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
11854              
11855 0 0       0 return 1 if $accountHash->equals($actorHash);
11856              
11857             # Get the envelope
11858 0         0 my ($bytes, $error) = $o->{store}->get($hash);
11859 0 0       0 return if defined $error;
11860 0 0       0 return 1 if ! defined $bytes;
11861 0   0     0 my $record = CDS::Record->fromObject(CDS::Object->fromBytes($bytes)) // return;
11862              
11863             # Allow anyone listed under "updated by"
11864 0         0 my $actorHashBytes24 = substr($actorHash->bytes, 0, 24);
11865 0         0 for my $child ($record->child('updated by')->children) {
11866 0         0 my $hashBytes24 = $child->bytes;
11867 0 0       0 next if length $hashBytes24 != 24;
11868 0 0       0 return 1 if $hashBytes24 eq $actorHashBytes24;
11869             }
11870              
11871 0         0 return;
11872             }
11873              
11874             # A Condensation store accessed through HTTP or HTTPS.
11875             package CDS::HTTPStore;
11876              
11877 1     1   5657 use parent -norequire, 'CDS::Store';
  1         3  
  1         5  
11878              
11879             sub forUrl {
11880 1     1   3 my $class = shift;
11881 1         2 my $url = shift;
11882              
11883 1 50       8 $url =~ /^(http|https):\/\// || return;
11884 1         3 return $class->new($url);
11885             }
11886              
11887             sub new {
11888 1     1   2 my $class = shift;
11889 1         2 my $url = shift;
11890              
11891 1         5 return bless {url => $url};
11892             }
11893              
11894             sub id {
11895 0     0   0 my $o = shift;
11896 0         0 $o->{url} }
11897              
11898             sub get {
11899 0     0   0 my $o = shift;
11900 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
11901 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
11902              
11903 0         0 my $response = $o->request('GET', $o->{url}.'/objects/'.$hash->hex, HTTP::Headers->new);
11904 0 0       0 return if $response->code == 404;
11905 0 0       0 return undef, 'get ==> HTTP '.$response->status_line if ! $response->is_success;
11906 0         0 return CDS::Object->fromBytes($response->decoded_content(charset => 'none'));
11907             }
11908              
11909             sub put {
11910 0     0   0 my $o = shift;
11911 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
11912 0 0 0     0 my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0         0  
11913 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
11914              
11915 0         0 my $headers = HTTP::Headers->new;
11916 0         0 $headers->header('Content-Type' => 'application/condensation-object');
11917 0         0 my $response = $o->request('PUT', $o->{url}.'/objects/'.$hash->hex, $headers, $keyPair, $object->bytes);
11918 0 0       0 return if $response->is_success;
11919 0         0 return 'put ==> HTTP '.$response->status_line;
11920             }
11921              
11922             sub book {
11923 0     0   0 my $o = shift;
11924 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
11925 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
11926              
11927 0         0 my $response = $o->request('POST', $o->{url}.'/objects/'.$hash->hex, HTTP::Headers->new, $keyPair);
11928 0 0       0 return if $response->code == 404;
11929 0 0       0 return 1 if $response->is_success;
11930 0         0 return undef, 'book ==> HTTP '.$response->status_line;
11931             }
11932              
11933             sub list {
11934 0     0   0 my $o = shift;
11935 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
11936 0         0 my $boxLabel = shift;
11937 0         0 my $timeout = shift;
11938 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
11939              
11940 0         0 my $boxUrl = $o->{url}.'/accounts/'.$accountHash->hex.'/'.$boxLabel;
11941 0         0 my $headers = HTTP::Headers->new;
11942 0 0       0 $headers->header('Condensation-Watch' => $timeout.' ms') if $timeout > 0;
11943 0         0 my $response = $o->request('GET', $boxUrl, $headers);
11944 0 0       0 return undef, 'list ==> HTTP '.$response->status_line if ! $response->is_success;
11945 0         0 my $bytes = $response->decoded_content(charset => 'none');
11946              
11947 0 0       0 if (length($bytes) % 32 != 0) {
11948 0         0 print STDERR 'old procotol', "\n";
11949 0         0 my $hashes = [];
11950 0         0 for my $line (split /\n/, $bytes) {
11951 0   0     0 push @$hashes, CDS::Hash->fromHex($line) // next;
11952             }
11953 0         0 return $hashes;
11954             }
11955              
11956 0         0 my $countHashes = int(length($bytes) / 32);
11957 0         0 return [map { CDS::Hash->fromBytes(substr($bytes, $_ * 32, 32)) } 0 .. $countHashes - 1];
  0         0  
11958             }
11959              
11960             sub add {
11961 0     0   0 my $o = shift;
11962 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
11963 0         0 my $boxLabel = shift;
11964 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
11965 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
11966              
11967 0         0 my $headers = HTTP::Headers->new;
11968 0         0 my $response = $o->request('PUT', $o->{url}.'/accounts/'.$accountHash->hex.'/'.$boxLabel.'/'.$hash->hex, $headers, $keyPair);
11969 0 0       0 return if $response->is_success;
11970 0         0 return 'add ==> HTTP '.$response->status_line;
11971             }
11972              
11973             sub remove {
11974 0     0   0 my $o = shift;
11975 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
11976 0         0 my $boxLabel = shift;
11977 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
11978 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
11979              
11980 0         0 my $headers = HTTP::Headers->new;
11981 0         0 my $response = $o->request('DELETE', $o->{url}.'/accounts/'.$accountHash->hex.'/'.$boxLabel.'/'.$hash->hex, $headers, $keyPair);
11982 0 0       0 return if $response->is_success;
11983 0         0 return 'remove ==> HTTP '.$response->status_line;
11984             }
11985              
11986             sub modify {
11987 0     0   0 my $o = shift;
11988 0         0 my $modifications = shift;
11989 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
11990              
11991 0         0 my $bytes = $modifications->toRecord->toObject->bytes;
11992 0         0 my $headers = HTTP::Headers->new;
11993 0         0 $headers->header('Content-Type' => 'application/condensation-modifications');
11994 0         0 my $response = $o->request('POST', $o->{url}.'/accounts', $headers, $keyPair, $bytes, 1);
11995 0 0       0 return if $response->is_success;
11996 0         0 return 'modify ==> HTTP '.$response->status_line;
11997             }
11998              
11999             # Executes a HTTP request.
12000             sub request {
12001 0     0   0 my $class = shift;
12002 0         0 my $method = shift;
12003 0         0 my $url = shift;
12004 0         0 my $headers = shift;
12005 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
12006 0         0 my $data = shift;
12007 0         0 my $signData = shift;
12008             # private
12009 0         0 $headers->date(time);
12010 0         0 $headers->header('User-Agent' => CDS->version);
12011              
12012 0 0       0 if ($keyPair) {
12013 0 0       0 my $hostAndPath = $url =~ /^https?:\/\/(.*)$/ ? $1 : $url;
12014 0         0 my $date = CDS::ISODate->millisecondString;
12015 0         0 my $bytesToSign = $date."\0".uc($method)."\0".$hostAndPath;
12016 0 0       0 $bytesToSign .= "\0".$data if $signData;
12017 0         0 my $hashBytesToSign = Digest::SHA::sha256($bytesToSign);
12018 0         0 my $signature = $keyPair->sign($hashBytesToSign);
12019 0         0 $headers->header('Condensation-Date' => $date);
12020 0         0 $headers->header('Condensation-Actor' => $keyPair->publicKey->hash->hex);
12021 0         0 $headers->header('Condensation-Signature' => unpack('H*', $signature));
12022             }
12023              
12024 0         0 return LWP::UserAgent->new->request(HTTP::Request->new($method, $url, $headers, $data));
12025             }
12026              
12027             # Models a hash, and offers binary and hexadecimal representation.
12028             package CDS::Hash;
12029              
12030             sub fromBytes {
12031 0     0   0 my $class = shift;
12032 0   0     0 my $hashBytes = shift // return;
12033              
12034 0 0       0 return if length $hashBytes != 32;
12035 0         0 return bless \$hashBytes;
12036             }
12037              
12038             sub fromHex {
12039 4     4   74 my $class = shift;
12040 4   50     9 my $hashHex = shift // return;
12041              
12042 4 100       20 $hashHex =~ /^\s*([a-fA-F0-9]{64,64})\s*$/ || return;
12043 2         14 my $hashBytes = pack('H*', $hashHex);
12044 2         9 return bless \$hashBytes;
12045             }
12046              
12047             sub calculateFor {
12048 0     0     my $class = shift;
12049 0           my $bytes = shift;
12050              
12051             # The Perl built-in SHA256 implementation is a tad faster than our SHA256 implementation.
12052             #return $class->fromBytes(CDS::C::sha256($bytes));
12053 0           return $class->fromBytes(Digest::SHA::sha256($bytes));
12054             }
12055              
12056             sub hex {
12057 0     0     my $o = shift;
12058              
12059 0           return unpack('H*', $$o);
12060             }
12061              
12062             sub shortHex {
12063 0     0     my $o = shift;
12064              
12065 0           return unpack('H*', substr($$o, 0, 8)) . '…';
12066             }
12067              
12068             sub bytes {
12069 0     0     my $o = shift;
12070 0           $$o }
12071              
12072             sub equals {
12073 0     0     my $this = shift;
12074 0           my $that = shift;
12075              
12076 0 0 0       return 1 if ! defined $this && ! defined $that;
12077 0 0 0       return if ! defined $this || ! defined $that;
12078 0           return $$this eq $$that;
12079             }
12080              
12081             sub cmp {
12082 0     0     my $this = shift;
12083 0           my $that = shift;
12084 0           $$this cmp $$that }
12085              
12086             # A hash with an AES key.
12087             package CDS::HashAndKey;
12088              
12089             sub new {
12090 0     0     my $class = shift;
12091 0 0 0       my $hash = shift // return; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0   0        
12092 0   0       my $key = shift // return;
12093              
12094 0           return bless {
12095             hash => $hash,
12096             key => $key,
12097             };
12098             }
12099              
12100 0     0     sub hash { shift->{hash} }
12101 0     0     sub key { shift->{key} }
12102              
12103             package CDS::ISODate;
12104              
12105             # Parses a date accepting various ISO variants, and calculates the timestamp using Time::Local
12106             sub parse {
12107 0     0     my $class = shift;
12108 0   0       my $dateString = shift // return;
12109              
12110 0 0         if ($dateString =~ /^(\d\d\d\d)-(\d\d)-(\d\d)$/) {
    0          
    0          
    0          
    0          
    0          
12111 0           return (timegm(0, 0, 0, $3, $2 - 1, $1 - 1900) + 86400 - 30) * 1000;
12112             } elsif ($dateString =~ /^(\d\d\d\d)-(\d\d)-(\d\d)(T|\s+)(\d\d):(\d\d):(\d\d|\d\d\.\d*)$/) {
12113 0           return (timelocal(0, $6, $5, $3, $2 - 1, $1 - 1900) + $7) * 1000;
12114             } elsif ($dateString =~ /^(\d\d\d\d)-(\d\d)-(\d\d)(T|\s+)(\d\d):(\d\d):(\d\d|\d\d\.\d*)Z$/) {
12115 0           return (timegm(0, $6, $5, $3, $2 - 1, $1 - 1900) + $7) * 1000;
12116             } elsif ($dateString =~ /^(\d\d\d\d)-(\d\d)-(\d\d)(T|\s+)(\d\d):(\d\d):(\d\d|\d\d\.\d*)+(\d\d):(\d\d)$/) {
12117 0           return (timegm(0, $6, $5, $3, $2 - 1, $1 - 1900) + $7 - $8 * 3600 - $9 * 60) * 1000;
12118             } elsif ($dateString =~ /^(\d\d\d\d)-(\d\d)-(\d\d)(T|\s+)(\d\d):(\d\d):(\d\d|\d\d\.\d*)-(\d\d):(\d\d)$/) {
12119 0           return (timegm(0, $6, $5, $3, $2 - 1, $1 - 1900) + $7 + $8 * 3600 + $9 * 60) * 1000;
12120             } elsif ($dateString =~ /^\s*(\d+)\s*$/) {
12121 0           return $1;
12122             } else {
12123 0           return;
12124             }
12125             }
12126              
12127             # Returns a properly formatted string with a precision of 1 day (i.e., the "date" only)
12128             sub dayString {
12129 0     0     my $class = shift;
12130 0   0       my $time = shift // 1000 * time;
12131              
12132 0           my @t = gmtime($time / 1000);
12133 0           return sprintf('%04d-%02d-%02d', $t[5] + 1900, $t[4] + 1, $t[3]);
12134             }
12135              
12136             # Returns a properly formatted string with a precision of 1 second (i.e., "time of day" and "date") using UTC
12137             sub secondString {
12138 0     0     my $class = shift;
12139 0   0       my $time = shift // 1000 * time;
12140              
12141 0           my @t = gmtime($time / 1000);
12142 0           return sprintf('%04d-%02d-%02dT%02d:%02d:%02dZ', $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0]);
12143             }
12144              
12145             # Returns a properly formatted string with a precision of 1 second (i.e., "time of day" and "date") using UTC
12146             sub millisecondString {
12147 0     0     my $class = shift;
12148 0   0       my $time = shift // 1000 * time;
12149              
12150 0           my @t = gmtime($time / 1000);
12151 0           return sprintf('%04d-%02d-%02dT%02d:%02d:%02d.%03dZ', $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0], int($time) % 1000);
12152             }
12153              
12154             # Returns a properly formatted string with a precision of 1 second (i.e., "time of day" and "date") using local time
12155             sub localSecondString {
12156 0     0     my $class = shift;
12157 0   0       my $time = shift // 1000 * time;
12158              
12159 0           my @t = localtime($time / 1000);
12160 0           return sprintf('%04d-%02d-%02dT%02d:%02d:%02d', $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0]);
12161             }
12162              
12163             package CDS::InMemoryStore;
12164              
12165             sub create {
12166 0     0     my $class = shift;
12167              
12168 0           return CDS::InMemoryStore->new('inMemoryStore:'.unpack('H*', CDS->randomBytes(16)));
12169             }
12170              
12171             sub new {
12172 0     0     my $o = shift;
12173 0           my $id = shift;
12174              
12175 0           return bless {
12176             id => $id,
12177             objects => {},
12178             accounts => {},
12179             };
12180             }
12181              
12182 0     0     sub id { shift->{id} }
12183              
12184             sub accountForWriting {
12185 0     0     my $o = shift;
12186 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12187              
12188 0           my $account = $o->{accounts}->{$hash->bytes};
12189 0 0         return $account if $account;
12190 0           return $o->{accounts}->{$hash->bytes} = {messages => {}, private => {}, public => {}};
12191             }
12192              
12193             # *** Store interface
12194              
12195             sub get {
12196 0     0     my $o = shift;
12197 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12198 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12199              
12200 0   0       my $entry = $o->{objects}->{$hash->bytes} // return;
12201 0           return $entry->{object};
12202             }
12203              
12204             sub book {
12205 0     0     my $o = shift;
12206 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12207 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12208              
12209 0   0       my $entry = $o->{objects}->{$hash->bytes} // return;
12210 0           $entry->{booked} = CDS->now;
12211 0           return 1;
12212             }
12213              
12214             sub put {
12215 0     0     my $o = shift;
12216 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12217 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
12218 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12219              
12220 0           $o->{objects}->{$hash->bytes} = {object => $object, booked => CDS->now};
12221 0           return;
12222             }
12223              
12224             sub list {
12225 0     0     my $o = shift;
12226 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
12227 0           my $boxLabel = shift;
12228 0           my $timeout = shift;
12229 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12230              
12231 0   0       my $account = $o->{accounts}->{$accountHash->bytes} // return [];
12232 0   0       my $box = $account->{$boxLabel} // return undef, 'Invalid box label.';
12233 0           return values %$box;
12234             }
12235              
12236             sub add {
12237 0     0     my $o = shift;
12238 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
12239 0           my $boxLabel = shift;
12240 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12241 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12242              
12243 0   0       my $box = $o->accountForWriting($accountHash)->{$boxLabel} // return;
12244 0           $box->{$hash->bytes} = $hash;
12245             }
12246              
12247             sub remove {
12248 0     0     my $o = shift;
12249 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
12250 0           my $boxLabel = shift;
12251 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12252 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12253              
12254 0   0       my $box = $o->accountForWriting($accountHash)->{$boxLabel} // return;
12255 0           delete $box->{$hash->bytes};
12256             }
12257              
12258             sub modify {
12259 0     0     my $o = shift;
12260 0           my $modifications = shift;
12261 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12262              
12263 0           return $modifications->executeIndividually($o, $keyPair);
12264             }
12265              
12266             # Garbage collection
12267              
12268             sub collectGarbage {
12269 0     0     my $o = shift;
12270 0           my $graceTime = shift;
12271              
12272             # Mark all objects as not used
12273 0           for my $entry (values %{$o->{objects}}) {
  0            
12274 0           $entry->{inUse} = 0;
12275             }
12276              
12277             # Mark all objects newer than the grace time
12278 0           for my $entry (values %{$o->{objects}}) {
  0            
12279 0 0         $o->markEntry($entry) if $entry->{booked} > $graceTime;
12280             }
12281              
12282             # Mark all objects referenced from a box
12283 0           for my $account (values %{$o->{accounts}}) {
  0            
12284 0           for my $hash (values %{$account->{messages}}) { $o->markHash($hash); }
  0            
  0            
12285 0           for my $hash (values %{$account->{private}}) { $o->markHash($hash); }
  0            
  0            
12286 0           for my $hash (values %{$account->{public}}) { $o->markHash($hash); }
  0            
  0            
12287             }
12288              
12289             # Remove empty accounts
12290 0           while (my ($key, $account) = each %{$o->{accounts}}) {
  0            
12291 0 0         next if scalar keys %{$account->{messages}};
  0            
12292 0 0         next if scalar keys %{$account->{private}};
  0            
12293 0 0         next if scalar keys %{$account->{public}};
  0            
12294 0           delete $o->{accounts}->{$key};
12295             }
12296              
12297             # Remove obsolete objects
12298 0           while (my ($key, $entry) = each %{$o->{objects}}) {
  0            
12299 0 0         next if $entry->{inUse};
12300 0           delete $o->{objects}->{$key};
12301             }
12302             }
12303              
12304             sub markHash {
12305 0     0     my $o = shift;
12306 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12307             # private
12308 0   0       my $child = $o->{objects}->{$hash->bytes} // return;
12309 0           $o->mark($child);
12310             }
12311              
12312             sub markEntry {
12313 0     0     my $o = shift;
12314 0           my $entry = shift;
12315             # private
12316 0 0         return if $entry->{inUse};
12317 0           $entry->{inUse} = 1;
12318              
12319             # Mark all children
12320 0           for my $hash ($entry->{object}->hashes) {
12321 0           $o->markHash($hash);
12322             }
12323             }
12324              
12325             package CDS::KeyPair;
12326              
12327             sub transfer {
12328 0     0     my $o = shift;
12329 0           my $hashes = shift;
12330 0           my $sourceStore = shift;
12331 0           my $destinationStore = shift;
12332              
12333 0           for my $hash (@$hashes) {
12334 0           my ($missing, $store, $storeError) = $o->recursiveTransfer($hash, $sourceStore, $destinationStore, {});
12335 0 0         return $missing if $missing;
12336 0 0         return undef, $store, $storeError if defined $storeError;
12337             }
12338              
12339 0           return;
12340             }
12341              
12342             sub recursiveTransfer {
12343 0     0     my $o = shift;
12344 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12345 0           my $sourceStore = shift;
12346 0           my $destinationStore = shift;
12347 0           my $done = shift;
12348             # private
12349 0 0         return if $done->{$hash->bytes};
12350 0           $done->{$hash->bytes} = 1;
12351              
12352             # Book
12353 0           my ($booked, $bookError) = $destinationStore->book($hash, $o);
12354 0 0         return undef, $destinationStore, $bookError if defined $bookError;
12355 0 0         return if $booked;
12356              
12357             # Get
12358 0           my ($object, $getError) = $sourceStore->get($hash, $o);
12359 0 0         return undef, $sourceStore, $getError if defined $getError;
12360 0 0         return CDS::MissingObject->new($hash, $sourceStore) if ! defined $object;
12361              
12362             # Process children
12363 0           for my $child ($object->hashes) {
12364 0           my ($missing, $store, $error) = $o->recursiveTransfer($child, $sourceStore, $destinationStore, $done);
12365 0 0         return undef, $store, $error if defined $error;
12366 0 0         if (defined $missing) {
12367 0           push @{$missing->{path}}, $child;
  0            
12368 0           return $missing;
12369             }
12370             }
12371              
12372             # Put
12373 0           my $putError = $destinationStore->put($hash, $object, $o);
12374 0 0         return undef, $destinationStore, $putError if defined $putError;
12375 0           return;
12376             }
12377              
12378             sub createPublicEnvelope {
12379 0     0     my $o = shift;
12380 0 0 0       my $contentHash = shift; die 'wrong type '.ref($contentHash).' for $contentHash' if defined $contentHash && ref $contentHash ne 'CDS::Hash';
  0            
12381              
12382 0           my $envelope = CDS::Record->new;
12383 0           $envelope->add('content')->addHash($contentHash);
12384 0           $envelope->add('signature')->add($o->signHash($contentHash));
12385 0           return $envelope;
12386             }
12387              
12388             sub createPrivateEnvelope {
12389 0     0     my $o = shift;
12390 0           my $contentHashAndKey = shift;
12391 0           my $recipientPublicKeys = shift;
12392              
12393 0           my $envelope = CDS::Record->new;
12394 0           $envelope->add('content')->addHash($contentHashAndKey->hash);
12395 0           $o->addRecipientsToEnvelope($envelope, $contentHashAndKey->key, $recipientPublicKeys);
12396 0           $envelope->add('signature')->add($o->signHash($contentHashAndKey->hash));
12397 0           return $envelope;
12398             }
12399              
12400             sub createMessageEnvelope {
12401 0     0     my $o = shift;
12402 0           my $storeUrl = shift;
12403 0 0 0       my $messageRecord = shift; die 'wrong type '.ref($messageRecord).' for $messageRecord' if defined $messageRecord && ref $messageRecord ne 'CDS::Record';
  0            
12404 0           my $recipientPublicKeys = shift;
12405 0           my $expires = shift;
12406              
12407 0           my $contentRecord = CDS::Record->new;
12408 0           $contentRecord->add('store')->addText($storeUrl);
12409 0           $contentRecord->add('sender')->addHash($o->publicKey->hash);
12410 0           $contentRecord->addRecord($messageRecord->children);
12411 0           my $contentObject = $contentRecord->toObject;
12412 0           my $contentKey = CDS->randomKey;
12413 0           my $encryptedContent = CDS::C::aesCrypt($contentObject->bytes, $contentKey, CDS->zeroCTR);
12414             #my $hashToSign = $contentObject->calculateHash; # prior to 2020-05-05
12415 0           my $hashToSign = CDS::Hash->calculateFor($encryptedContent);
12416              
12417 0           my $envelope = CDS::Record->new;
12418 0           $envelope->add('content')->add($encryptedContent);
12419 0           $o->addRecipientsToEnvelope($envelope, $contentKey, $recipientPublicKeys);
12420 0           $envelope->add('updated by')->add(substr($o->publicKey->hash->bytes, 0, 24));
12421 0 0         $envelope->add('expires')->addInteger($expires) if defined $expires;
12422 0           $envelope->add('signature')->add($o->signHash($hashToSign));
12423 0           return $envelope;
12424             }
12425              
12426             sub addRecipientsToEnvelope {
12427 0     0     my $o = shift;
12428 0 0 0       my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0            
12429 0           my $key = shift;
12430 0           my $recipientPublicKeys = shift;
12431             # private
12432 0           my $encryptedKeyRecord = $envelope->add('encrypted for');
12433 0           my $myHashBytes24 = substr($o->{publicKey}->hash->bytes, 0, 24);
12434 0           $encryptedKeyRecord->add($myHashBytes24)->add($o->{publicKey}->encrypt($key));
12435 0           for my $publicKey (@$recipientPublicKeys) {
12436 0 0         next if $publicKey->hash->equals($o->{publicKey}->hash);
12437 0           my $hashBytes24 = substr($publicKey->hash->bytes, 0, 24);
12438 0           $encryptedKeyRecord->add($hashBytes24)->add($publicKey->encrypt($key));
12439             }
12440             }
12441              
12442             sub generate {
12443 0     0     my $class = shift;
12444              
12445             # Generate a new private key
12446 0           my $rsaPrivateKey = CDS::C::privateKeyGenerate();
12447              
12448             # Serialize the public key
12449 0           my $rsaPublicKey = CDS::C::publicKeyFromPrivateKey($rsaPrivateKey);
12450 0           my $record = CDS::Record->new;
12451 0           $record->add('e')->add(CDS::C::publicKeyE($rsaPublicKey));
12452 0           $record->add('n')->add(CDS::C::publicKeyN($rsaPublicKey));
12453 0           my $publicKey = CDS::PublicKey->fromObject($record->toObject);
12454              
12455             # Return a new CDS::KeyPair instance
12456 0           return CDS::KeyPair->new($publicKey, $rsaPrivateKey);
12457             }
12458              
12459             sub fromFile {
12460 0     0     my $class = shift;
12461 0           my $file = shift;
12462              
12463 0   0       my $bytes = CDS->readBytesFromFile($file) // return;
12464 0           my $record = CDS::Record->fromObject(CDS::Object->fromBytes($bytes));
12465 0           return $class->fromRecord($record);
12466             }
12467              
12468             sub fromHex {
12469 0     0     my $class = shift;
12470 0           my $hex = shift;
12471              
12472 0           return $class->fromRecord(CDS::Record->fromObject(CDS::Object->fromBytes(pack 'H*', $hex)));
12473             }
12474              
12475             sub fromRecord {
12476 0     0     my $class = shift;
12477 0 0 0       my $record = shift // return; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0   0        
12478              
12479 0   0       my $publicKey = CDS::PublicKey->fromObject(CDS::Object->fromBytes($record->child('public key object')->bytesValue)) // return;
12480 0           my $rsaKey = $record->child('rsa key');
12481 0           my $e = $rsaKey->child('e')->bytesValue;
12482 0           my $p = $rsaKey->child('p')->bytesValue;
12483 0           my $q = $rsaKey->child('q')->bytesValue;
12484 0   0       return $class->new($publicKey, CDS::C::privateKeyNew($e, $p, $q) // return);
12485             }
12486              
12487             sub new {
12488 0     0     my $class = shift;
12489 0 0 0       my $publicKey = shift; die 'wrong type '.ref($publicKey).' for $publicKey' if defined $publicKey && ref $publicKey ne 'CDS::PublicKey';
  0            
12490 0           my $rsaPrivateKey = shift;
12491              
12492 0           return bless {
12493             publicKey => $publicKey, # The public key
12494             rsaPrivateKey => $rsaPrivateKey, # The private key
12495             };
12496             }
12497              
12498 0     0     sub publicKey { shift->{publicKey} }
12499 0     0     sub rsaPrivateKey { shift->{rsaPrivateKey} }
12500              
12501             ### Serialization ###
12502              
12503             sub toRecord {
12504 0     0     my $o = shift;
12505              
12506 0           my $record = CDS::Record->new;
12507 0           $record->add('public key object')->add($o->{publicKey}->object->bytes);
12508 0           my $rsaKeyRecord = $record->add('rsa key');
12509 0           $rsaKeyRecord->add('e')->add(CDS::C::privateKeyE($o->{rsaPrivateKey}));
12510 0           $rsaKeyRecord->add('p')->add(CDS::C::privateKeyP($o->{rsaPrivateKey}));
12511 0           $rsaKeyRecord->add('q')->add(CDS::C::privateKeyQ($o->{rsaPrivateKey}));
12512 0           return $record;
12513             }
12514              
12515             sub toHex {
12516 0     0     my $o = shift;
12517              
12518 0           my $object = $o->toRecord->toObject;
12519 0           return unpack('H*', $object->header).unpack('H*', $object->data);
12520             }
12521              
12522             sub writeToFile {
12523 0     0     my $o = shift;
12524 0           my $file = shift;
12525              
12526 0           my $object = $o->toRecord->toObject;
12527 0           return CDS->writeBytesToFile($file, $object->bytes);
12528             }
12529              
12530             ### Private key interface ###
12531              
12532             sub decrypt {
12533 0     0     my $o = shift;
12534 0           my $bytes = shift;
12535             # decrypt(bytes) -> bytes
12536 0           return CDS::C::privateKeyDecrypt($o->{rsaPrivateKey}, $bytes);
12537             }
12538              
12539             sub sign {
12540 0     0     my $o = shift;
12541 0           my $digest = shift;
12542             # sign(bytes) -> bytes
12543 0           return CDS::C::privateKeySign($o->{rsaPrivateKey}, $digest);
12544             }
12545              
12546             sub signHash {
12547 0     0     my $o = shift;
12548 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12549             # signHash(hash) -> bytes
12550 0           return CDS::C::privateKeySign($o->{rsaPrivateKey}, $hash->bytes);
12551             }
12552              
12553             ### Retrieval ###
12554              
12555             # Retrieves an object from one of the stores, and decrypts it.
12556             sub getAndDecrypt {
12557 0     0     my $o = shift;
12558 0 0 0       my $hashAndKey = shift; die 'wrong type '.ref($hashAndKey).' for $hashAndKey' if defined $hashAndKey && ref $hashAndKey ne 'CDS::HashAndKey';
  0            
12559 0           my $store = shift;
12560              
12561 0           my ($object, $error) = $store->get($hashAndKey->hash, $o);
12562 0 0         return undef, undef, $error if defined $error;
12563 0 0         return undef, 'Not found.', undef if ! $object;
12564 0           return $object->crypt($hashAndKey->key);
12565             }
12566              
12567             # Retrieves an object from one of the stores, and parses it as record.
12568             sub getRecord {
12569 0     0     my $o = shift;
12570 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12571 0           my $store = shift;
12572              
12573 0           my ($object, $error) = $store->get($hash, $o);
12574 0 0         return undef, undef, undef, $error if defined $error;
12575 0 0         return undef, undef, 'Not found.', undef if ! $object;
12576 0   0       my $record = CDS::Record->fromObject($object) // return undef, undef, 'Not a record.', undef;
12577 0           return $record, $object;
12578             }
12579              
12580             # Retrieves an object from one of the stores, decrypts it, and parses it as record.
12581             sub getAndDecryptRecord {
12582 0     0     my $o = shift;
12583 0 0 0       my $hashAndKey = shift; die 'wrong type '.ref($hashAndKey).' for $hashAndKey' if defined $hashAndKey && ref $hashAndKey ne 'CDS::HashAndKey';
  0            
12584 0           my $store = shift;
12585              
12586 0           my ($object, $error) = $store->get($hashAndKey->hash, $o);
12587 0 0         return undef, undef, undef, $error if defined $error;
12588 0 0         return undef, undef, 'Not found.', undef if ! $object;
12589 0           my $decrypted = $object->crypt($hashAndKey->key);
12590 0   0       my $record = CDS::Record->fromObject($decrypted) // return undef, undef, 'Not a record.', undef;
12591 0           return $record, $object;
12592             }
12593              
12594             # Retrieves an public key object from one of the stores, and parses its public key.
12595             sub getPublicKey {
12596 0     0     my $o = shift;
12597 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12598 0           my $store = shift;
12599              
12600 0           my ($object, $error) = $store->get($hash, $o);
12601 0 0         return undef, undef, $error if defined $error;
12602 0 0         return undef, 'Not found.', undef if ! $object;
12603 0   0       return CDS::PublicKey->fromObject($object) // return undef, 'Not a public key.', undef;
12604             }
12605              
12606             ### Equality ###
12607              
12608             sub equals {
12609 0     0     my $this = shift;
12610 0           my $that = shift;
12611              
12612 0 0 0       return 1 if ! defined $this && ! defined $that;
12613 0 0 0       return if ! defined $this || ! defined $that;
12614 0           return $this->publicKey->hash->equals($that->publicKey->hash);
12615             }
12616              
12617             ### Open envelopes ###
12618              
12619             sub decryptKeyOnEnvelope {
12620 0     0     my $o = shift;
12621 0 0 0       my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0            
12622              
12623             # Read the AES key
12624 0           my $hashBytes24 = substr($o->{publicKey}->hash->bytes, 0, 24);
12625 0           my $encryptedAesKey = $envelope->child('encrypted for')->child($hashBytes24)->bytesValue;
12626 0 0         $encryptedAesKey = $envelope->child('encrypted for')->child($o->{publicKey}->hash->bytes)->bytesValue if ! length $encryptedAesKey; # todo: remove this
12627 0 0         return if ! length $encryptedAesKey;
12628              
12629             # Decrypt the AES key
12630 0           my $aesKeyBytes = $o->decrypt($encryptedAesKey);
12631 0 0 0       return if ! $aesKeyBytes || length $aesKeyBytes != 32;
12632              
12633 0           return $aesKeyBytes;
12634             }
12635              
12636             # The result of parsing a KEYPAIR token (see Token.pm).
12637             package CDS::KeyPairToken;
12638              
12639             sub new {
12640 0     0     my $class = shift;
12641 0           my $file = shift;
12642 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12643              
12644 0           return bless {
12645             file => $file,
12646             keyPair => $keyPair,
12647             };
12648             }
12649              
12650 0     0     sub file { shift->{file} }
12651 0     0     sub keyPair { shift->{keyPair} }
12652              
12653             package CDS::LoadActorGroup;
12654              
12655             sub load {
12656 0     0     my $class = shift;
12657 0 0 0       my $builder = shift; die 'wrong type '.ref($builder).' for $builder' if defined $builder && ref $builder ne 'CDS::ActorGroupBuilder';
  0            
12658 0           my $store = shift;
12659 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12660 0           my $delegate = shift;
12661              
12662 0           my $o = bless {
12663             store => $store,
12664             keyPair => $keyPair,
12665             knownPublicKeys => $builder->knownPublicKeys,
12666             };
12667              
12668 0           my $members = [];
12669 0           for my $member ($builder->members) {
12670 0           my $isActive = $member->status eq 'active';
12671 0           my $isIdle = $member->status eq 'idle';
12672 0 0 0       next if ! $isActive && ! $isIdle;
12673              
12674 0           my ($publicKey, $storeError) = $o->getPublicKey($member->hash);
12675 0 0         return undef, $storeError if defined $storeError;
12676 0 0         next if ! $publicKey;
12677              
12678 0   0       my $accountStore = $delegate->onLoadActorGroupVerifyStore($member->storeUrl) // next;
12679 0           my $actorOnStore = CDS::ActorOnStore->new($publicKey, $accountStore);
12680 0           push @$members, CDS::ActorGroup::Member->new($actorOnStore, $member->storeUrl, $member->revision, $isActive);
12681             }
12682              
12683 0           my $entrustedActors = [];
12684 0           for my $actor ($builder->entrustedActors) {
12685 0           my ($publicKey, $storeError) = $o->getPublicKey($actor->hash);
12686 0 0         return undef, $storeError if defined $storeError;
12687 0 0         next if ! $publicKey;
12688              
12689 0   0       my $accountStore = $delegate->onLoadActorGroupVerifyStore($actor->storeUrl) // next;
12690 0           my $actorOnStore = CDS::ActorOnStore->new($publicKey, $accountStore);
12691 0           push @$entrustedActors, CDS::ActorGroup::EntrustedActor->new($actorOnStore, $actor->storeUrl);
12692             }
12693              
12694 0           return CDS::ActorGroup->new($members, $builder->entrustedActorsRevision, $entrustedActors);
12695             }
12696              
12697             sub getPublicKey {
12698 0     0     my $o = shift;
12699 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12700              
12701 0           my $knownPublicKey = $o->{knownPublicKeys}->{$hash->bytes};
12702 0 0         return $knownPublicKey if $knownPublicKey;
12703              
12704 0           my ($publicKey, $invalidReason, $storeError) = $o->{keyPair}->getPublicKey($hash, $o->{store});
12705 0 0         return undef, $storeError if defined $storeError;
12706 0 0         return if defined $invalidReason;
12707              
12708 0           $o->{knownPublicKeys}->{$hash->bytes} = $publicKey;
12709 0           return $publicKey;
12710             };
12711              
12712             # A store that prints all accesses to a filehandle (STDERR by default).
12713             package CDS::LogStore;
12714              
12715 1     1   6677 use parent -norequire, 'CDS::Store';
  1         2  
  1         7  
12716              
12717             sub new {
12718 0     0     my $class = shift;
12719 0           my $store = shift;
12720 0   0       my $fileHandle = shift // *STDERR;
12721 0   0       my $prefix = shift // '';
12722              
12723 0           return bless {
12724             id => "Log Store\n".$store->id,
12725             store => $store,
12726             fileHandle => $fileHandle,
12727             prefix => '',
12728             };
12729             }
12730              
12731 0     0     sub id { shift->{id} }
12732 0     0     sub store { shift->{store} }
12733 0     0     sub fileHandle { shift->{fileHandle} }
12734 0     0     sub prefix { shift->{prefix} }
12735              
12736             sub get {
12737 0     0     my $o = shift;
12738 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12739 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12740              
12741 0           my $start = CDS::C::performanceStart();
12742 0           my ($object, $error) = $o->{store}->get($hash, $keyPair);
12743 0           my $elapsed = CDS::C::performanceElapsed($start);
12744 0 0         $o->log('get', $hash->shortHex, defined $object ? &formatByteLength($object->byteLength).' bytes' : defined $error ? 'failed: '.$error : 'not found', $elapsed);
    0          
12745 0           return $object, $error;
12746             }
12747              
12748             sub put {
12749 0     0     my $o = shift;
12750 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12751 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
12752 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12753              
12754 0           my $start = CDS::C::performanceStart();
12755 0           my $error = $o->{store}->put($hash, $object, $keyPair);
12756 0           my $elapsed = CDS::C::performanceElapsed($start);
12757 0 0         $o->log('put', $hash->shortHex . ' ' . &formatByteLength($object->byteLength) . ' bytes', defined $error ? 'failed: '.$error : 'OK', $elapsed);
12758 0           return $error;
12759             }
12760              
12761             sub book {
12762 0     0     my $o = shift;
12763 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12764 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12765              
12766 0           my $start = CDS::C::performanceStart();
12767 0           my ($booked, $error) = $o->{store}->book($hash, $keyPair);
12768 0           my $elapsed = CDS::C::performanceElapsed($start);
12769 0 0         $o->log('book', $hash->shortHex, defined $booked ? 'OK' : defined $error ? 'failed: '.$error : 'not found', $elapsed);
    0          
12770 0           return $booked, $error;
12771             }
12772              
12773             sub list {
12774 0     0     my $o = shift;
12775 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
12776 0           my $boxLabel = shift;
12777 0           my $timeout = shift;
12778 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12779              
12780 0           my $start = CDS::C::performanceStart();
12781 0           my ($hashes, $error) = $o->{store}->list($accountHash, $boxLabel, $timeout, $keyPair);
12782 0           my $elapsed = CDS::C::performanceElapsed($start);
12783 0 0         $o->log('list', $accountHash->shortHex . ' ' . $boxLabel . ($timeout ? ' ' . $timeout . ' s' : ''), defined $hashes ? scalar(@$hashes).' entries' : 'failed: '.$error, $elapsed);
    0          
12784 0           return $hashes, $error;
12785             }
12786              
12787             sub add {
12788 0     0     my $o = shift;
12789 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
12790 0           my $boxLabel = shift;
12791 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12792 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12793              
12794 0           my $start = CDS::C::performanceStart();
12795 0           my $error = $o->{store}->add($accountHash, $boxLabel, $hash, $keyPair);
12796 0           my $elapsed = CDS::C::performanceElapsed($start);
12797 0 0         $o->log('add', $accountHash->shortHex . ' ' . $boxLabel . ' ' . $hash->shortHex, defined $error ? 'failed: '.$error : 'OK', $elapsed);
12798 0           return $error;
12799             }
12800              
12801             sub remove {
12802 0     0     my $o = shift;
12803 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
12804 0           my $boxLabel = shift;
12805 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12806 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12807              
12808 0           my $start = CDS::C::performanceStart();
12809 0           my $error = $o->{store}->remove($accountHash, $boxLabel, $hash, $keyPair);
12810 0           my $elapsed = CDS::C::performanceElapsed($start);
12811 0 0         $o->log('remove', $accountHash->shortHex . ' ' . $boxLabel . ' ' . $hash->shortHex, defined $error ? 'failed: '.$error : 'OK', $elapsed);
12812 0           return $error;
12813             }
12814              
12815             sub modify {
12816 0     0     my $o = shift;
12817 0           my $modifications = shift;
12818 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12819              
12820 0           my $start = CDS::C::performanceStart();
12821 0           my $error = $o->{store}->modify($modifications, $keyPair);
12822 0           my $elapsed = CDS::C::performanceElapsed($start);
12823 0 0         $o->log('modify', scalar(keys %{$modifications->objects}) . ' objects ' . scalar @{$modifications->additions} . ' additions ' . scalar @{$modifications->removals} . ' removals', defined $error ? 'failed: '.$error : 'OK', $elapsed);
  0            
  0            
  0            
12824 0           return $error;
12825             }
12826              
12827             sub log {
12828 0     0     my $o = shift;
12829 0           my $cmd = shift;
12830 0           my $input = shift;
12831 0           my $output = shift;
12832 0           my $elapsed = shift;
12833              
12834 0   0       my $fh = $o->{fileHandle} // return;
12835 0           print $fh $o->{prefix}, &left(8, $cmd), &left(40, $input), ' => ', &left(40, $output), &formatDuration($elapsed), ' us', "\n";
12836             }
12837              
12838             sub left {
12839 0     0     my $width = shift;
12840 0           my $text = shift;
12841             # private
12842 0 0         return $text . (' ' x ($width - length $text)) if length $text < $width;
12843 0           return $text;
12844             }
12845              
12846             sub formatByteLength {
12847 0     0     my $byteLength = shift;
12848             # private
12849 0           my $s = ''.$byteLength;
12850 0 0         $s = ' ' x (9 - length $s) . $s if length $s < 9;
12851 0           my $len = length $s;
12852 0           return substr($s, 0, $len - 6).' '.substr($s, $len - 6, 3).' '.substr($s, $len - 3, 3);
12853             }
12854              
12855             sub formatDuration {
12856 0     0     my $elapsed = shift;
12857             # private
12858 0           my $s = ''.$elapsed;
12859 0 0         $s = ' ' x (9 - length $s) . $s if length $s < 9;
12860 0           my $len = length $s;
12861 0           return substr($s, 0, $len - 6).' '.substr($s, $len - 6, 3).' '.substr($s, $len - 3, 3);
12862             }
12863              
12864             # Reads the message box of an actor.
12865             package CDS::MessageBoxReader;
12866              
12867             sub new {
12868 0     0     my $class = shift;
12869 0           my $pool = shift;
12870 0 0 0       my $actorOnStore = shift; die 'wrong type '.ref($actorOnStore).' for $actorOnStore' if defined $actorOnStore && ref $actorOnStore ne 'CDS::ActorOnStore';
  0            
12871 0           my $streamTimeout = shift;
12872              
12873 0   0       return bless {
12874             pool => $pool,
12875             actorOnStore => $actorOnStore,
12876             streamCache => CDS::StreamCache->new($pool, $actorOnStore, $streamTimeout // CDS->MINUTE),
12877             entries => {},
12878             };
12879             }
12880              
12881 0     0     sub pool { shift->{pool} }
12882 0     0     sub actorOnStore { shift->{actorOnStore} }
12883              
12884             sub read {
12885 0     0     my $o = shift;
12886 0   0       my $timeout = shift // 0;
12887              
12888 0           my $store = $o->{actorOnStore}->store;
12889 0           my ($hashes, $listError) = $store->list($o->{actorOnStore}->publicKey->hash, 'messages', $timeout, $o->{pool}->{keyPair});
12890 0 0         return if defined $listError;
12891              
12892 0           for my $hash (@$hashes) {
12893 0           my $entry = $o->{entries}->{$hash->bytes};
12894 0 0         $o->{entries}->{$hash->bytes} = $entry = CDS::MessageBoxReader::Entry->new($hash) if ! $entry;
12895 0 0         next if $entry->{processed};
12896              
12897             # Check the sender store, if necessary
12898 0 0         if ($entry->{waitingForStore}) {
12899 0           my ($dummy, $checkError) = $entry->{waitingForStore}->get(CDS->emptyBytesHash, $o->{pool}->{keyPair});
12900 0 0         next if defined $checkError;
12901             }
12902              
12903             # Get the envelope
12904 0           my ($object, $getError) = $o->{actorOnStore}->store->get($entry->{hash}, $o->{pool}->{keyPair});
12905 0 0         return if defined $getError;
12906              
12907             # Mark the entry as processed
12908 0           $entry->{processed} = 1;
12909              
12910 0 0         if (! defined $object) {
12911 0           $o->invalid($entry, 'Envelope object not found.');
12912 0           next;
12913             }
12914              
12915             # Parse the record
12916 0           my $envelope = CDS::Record->fromObject($object);
12917 0 0         if (! $envelope) {
12918 0           $o->invalid($entry, 'Envelope is not a record.');
12919 0           next;
12920             }
12921              
12922 0 0 0       my $message =
12923             $envelope->contains('head') && $envelope->contains('mac') ?
12924             $o->readStreamMessage($entry, $envelope) :
12925             $o->readNormalMessage($entry, $envelope);
12926 0 0         next if ! $message;
12927              
12928 0           $o->{pool}->{delegate}->onMessageBoxEntry($message);
12929             }
12930              
12931 0           $o->{streamCache}->removeObsolete;
12932 0           return 1;
12933             }
12934              
12935             sub readNormalMessage {
12936 0     0     my $o = shift;
12937 0           my $entry = shift;
12938 0 0 0       my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0            
12939             # private
12940             # Read the embedded content object
12941 0           my $encryptedBytes = $envelope->child('content')->bytesValue;
12942 0 0         return $o->invalid($entry, 'Missing content object.') if ! length $encryptedBytes;
12943              
12944             # Decrypt the key
12945 0           my $aesKey = $o->{pool}->{keyPair}->decryptKeyOnEnvelope($envelope);
12946 0 0         return $o->invalid($entry, 'Not encrypted for us.') if ! $aesKey;
12947              
12948             # Decrypt the content
12949 0           my $contentObject = CDS::Object->fromBytes(CDS::C::aesCrypt($encryptedBytes, $aesKey, CDS->zeroCTR));
12950 0 0         return $o->invalid($entry, 'Invalid content object.') if ! $contentObject;
12951              
12952 0           my $content = CDS::Record->fromObject($contentObject);
12953 0 0         return $o->invalid($entry, 'Content object is not a record.') if ! $content;
12954              
12955             # Verify the sender hash
12956 0           my $senderHash = $content->child('sender')->hashValue;
12957 0 0         return $o->invalid($entry, 'Missing sender hash.') if ! $senderHash;
12958              
12959             # Verify the sender store
12960 0           my $storeRecord = $content->child('store');
12961 0 0         return $o->invalid($entry, 'Missing sender store.') if ! scalar $storeRecord->children;
12962              
12963 0           my $senderStoreUrl = $storeRecord->textValue;
12964 0           my $senderStore = $o->{pool}->{delegate}->onMessageBoxVerifyStore($senderStoreUrl, $entry->{hash}, $envelope, $senderHash);
12965 0 0         return $o->invalid($entry, 'Invalid sender store.') if ! $senderStore;
12966              
12967             # Retrieve the sender's public key
12968 0           my ($senderPublicKey, $invalidReason, $publicKeyStoreError) = $o->getPublicKey($senderHash, $senderStore);
12969 0 0         return if defined $publicKeyStoreError;
12970 0 0         return $o->invalid($entry, 'Failed to retrieve the sender\'s public key: '.$invalidReason) if defined $invalidReason;
12971              
12972             # Verify the signature
12973 0           my $signedHash = CDS::Hash->calculateFor($encryptedBytes);
12974 0 0         if (! CDS->verifyEnvelopeSignature($envelope, $senderPublicKey, $signedHash)) {
12975             # For backwards compatibility with versions before 2020-05-05
12976 0 0         return $o->invalid($entry, 'Invalid signature.') if ! CDS->verifyEnvelopeSignature($envelope, $senderPublicKey, $contentObject->calculateHash);
12977             }
12978              
12979             # The envelope is valid
12980 0           my $sender = CDS::ActorOnStore->new($senderPublicKey, $senderStore);
12981 0           my $source = CDS::Source->new($o->{pool}->{keyPair}, $o->{actorOnStore}, 'messages', $entry->{hash});
12982 0           return CDS::ReceivedMessage->new($o, $entry, $source, $envelope, $senderStoreUrl, $sender, $content);
12983             }
12984              
12985             sub readStreamMessage {
12986 0     0     my $o = shift;
12987 0           my $entry = shift;
12988 0 0 0       my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0            
12989             # private
12990             # Get the head
12991 0           my $head = $envelope->child('head')->hashValue;
12992 0 0         return $o->invalid($entry, 'Invalid head message hash.') if ! $head;
12993              
12994             # Get the head envelope
12995 0           my $streamHead = $o->{streamCache}->readStreamHead($head);
12996 0 0         return if ! $streamHead;
12997 0 0         return $o->invalid($entry, 'Invalid stream head: '.$streamHead->error) if $streamHead->error;
12998              
12999             # Read the embedded content object
13000 0           my $encryptedBytes = $envelope->child('content')->bytesValue;
13001 0 0         return $o->invalid($entry, 'Missing content object.') if ! length $encryptedBytes;
13002              
13003             # Get the CTR
13004 0           my $ctr = $envelope->child('ctr')->bytesValue;
13005 0 0         return $o->invalid($entry, 'Invalid CTR.') if length $ctr != 16;
13006              
13007             # Get the MAC
13008 0           my $mac = $envelope->child('mac')->bytesValue;
13009 0 0         return $o->invalid($entry, 'Invalid MAC.') if ! $mac;
13010              
13011             # Verify the MAC
13012 0           my $signedHash = CDS::Hash->calculateFor($encryptedBytes);
13013 0           my $expectedMac = CDS::C::aesCrypt($signedHash->bytes, $streamHead->aesKey, $ctr);
13014 0 0         return $o->invalid($entry, 'Invalid MAC.') if $mac ne $expectedMac;
13015              
13016             # Decrypt the content
13017 0           my $contentObject = CDS::Object->fromBytes(CDS::C::aesCrypt($encryptedBytes, $streamHead->aesKey, CDS::C::counterPlusInt($ctr, 2)));
13018 0 0         return $o->invalid($entry, 'Invalid content object.') if ! $contentObject;
13019              
13020 0           my $content = CDS::Record->fromObject($contentObject);
13021 0 0         return $o->invalid($entry, 'Content object is not a record.') if ! $content;
13022              
13023             # The envelope is valid
13024 0           my $source = CDS::Source->new($o->{pool}->{keyPair}, $o->{actorOnStore}, 'messages', $entry->{hash});
13025 0           return CDS::ReceivedMessage->new($o, $entry, $source, $envelope, $streamHead->senderStoreUrl, $streamHead->sender, $content, $streamHead);
13026             }
13027              
13028             sub invalid {
13029 0     0     my $o = shift;
13030 0           my $entry = shift;
13031 0           my $reason = shift;
13032             # private
13033 0           my $source = CDS::Source->new($o->{pool}->{keyPair}, $o->{actorOnStore}, 'messages', $entry->{hash});
13034 0           $o->{pool}->{delegate}->onMessageBoxInvalidEntry($source, $reason);
13035             }
13036              
13037             sub getPublicKey {
13038 0     0     my $o = shift;
13039 0 0 0       my $senderHash = shift; die 'wrong type '.ref($senderHash).' for $senderHash' if defined $senderHash && ref $senderHash ne 'CDS::Hash';
  0            
13040 0           my $senderStore = shift;
13041 0           my $senderStoreUrl = shift;
13042             # private
13043             # Use the account key if sender and recipient are the same
13044 0 0         return $o->{actorOnStore}->publicKey if $senderHash->equals($o->{actorOnStore}->publicKey->hash);
13045              
13046             # Reuse a cached public key
13047 0           my $cachedPublicKey = $o->{pool}->{publicKeyCache}->get($senderHash);
13048 0 0         return $cachedPublicKey if $cachedPublicKey;
13049              
13050             # Retrieve the sender's public key from the sender's store
13051 0           my ($publicKey, $invalidReason, $storeError) = $o->{pool}->{keyPair}->getPublicKey($senderHash, $senderStore);
13052 0 0         return undef, undef, $storeError if defined $storeError;
13053 0 0         return undef, $invalidReason if defined $invalidReason;
13054 0           $o->{pool}->{publicKeyCache}->add($publicKey);
13055 0           return $publicKey;
13056             }
13057              
13058             package CDS::MessageBoxReader::Entry;
13059              
13060             sub new {
13061 0     0     my $class = shift;
13062 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
13063              
13064 0           return bless {
13065             hash => $hash,
13066             processed => 0,
13067             };
13068             }
13069              
13070             package CDS::MessageBoxReaderPool;
13071              
13072             sub new {
13073 0     0     my $class = shift;
13074 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
13075 0           my $publicKeyCache = shift;
13076 0           my $delegate = shift;
13077              
13078 0           return bless {
13079             keyPair => $keyPair,
13080             publicKeyCache => $publicKeyCache,
13081             delegate => $delegate,
13082             };
13083             }
13084              
13085 0     0     sub keyPair { shift->{keyPair} }
13086 0     0     sub publicKeyCache { shift->{publicKeyCache} }
13087              
13088             # Delegate
13089             # onMessageBoxVerifyStore($senderStoreUrl, $hash, $envelope, $senderHash)
13090             # onMessageBoxEntry($receivedMessage)
13091             # onMessageBoxStream($receivedMessage)
13092             # onMessageBoxInvalidEntry($source, $reason)
13093              
13094             package CDS::MessageChannel;
13095              
13096             sub new {
13097 0     0     my $class = shift;
13098 0           my $actor = shift;
13099 0           my $label = shift;
13100 0           my $validity = shift;
13101              
13102 0           my $o = bless {
13103             actor => $actor,
13104             label => $label,
13105             validity => $validity,
13106             };
13107              
13108 0           $o->{unsaved} = CDS::Unsaved->new($actor->sentList->unsaved);
13109 0           $o->{transfers} = [];
13110 0           $o->{recipients} = [];
13111 0           $o->{entrustedKeys} = [];
13112 0           $o->{obsoleteHashes} = {};
13113 0           $o->{currentSubmissionId} = 0;
13114 0           return $o;
13115             }
13116              
13117 0     0     sub actor { shift->{actor} }
13118 0     0     sub label { shift->{label} }
13119 0     0     sub validity { shift->{validity} }
13120 0     0     sub unsaved { shift->{unsaved} }
13121             sub item {
13122 0     0     my $o = shift;
13123 0           $o->{actor}->sentList->getOrCreate($o->{label}) }
13124             sub recipients {
13125 0     0     my $o = shift;
13126 0           @{$o->{recipients}} }
  0            
13127             sub entrustedKeys {
13128 0     0     my $o = shift;
13129 0           @{$o->{entrustedKeys}} }
  0            
13130              
13131             sub addObject {
13132 0     0     my $o = shift;
13133 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
13134 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
13135              
13136 0           $o->{unsaved}->state->addObject($hash, $object);
13137             }
13138              
13139             sub addTransfer {
13140 0     0     my $o = shift;
13141 0           my $hashes = shift;
13142 0           my $sourceStore = shift;
13143 0           my $context = shift;
13144              
13145 0 0         return if ! scalar @$hashes;
13146 0           push @{$o->{transfers}}, {hashes => $hashes, sourceStore => $sourceStore, context => $context};
  0            
13147             }
13148              
13149             sub setRecipientActorGroup {
13150 0     0     my $o = shift;
13151 0 0 0       my $actorGroup = shift; die 'wrong type '.ref($actorGroup).' for $actorGroup' if defined $actorGroup && ref $actorGroup ne 'CDS::ActorGroup';
  0            
13152              
13153 0           $o->{recipients} = [map { $_->actorOnStore } $actorGroup->members];
  0            
13154 0           $o->{entrustedKeys} = [map { $_->actorOnStore->publicKey } $actorGroup->entrustedActors];
  0            
13155             }
13156              
13157             sub setRecipients {
13158 0     0     my $o = shift;
13159 0           my $recipients = shift;
13160 0           my $entrustedKeys = shift;
13161              
13162 0           $o->{recipients} = $recipients;
13163 0           $o->{entrustedKeys} = $entrustedKeys;
13164             }
13165              
13166             sub submit {
13167 0     0     my $o = shift;
13168 0           my $message = shift;
13169 0           my $done = shift;
13170              
13171             # Check if the sent list has been loaded
13172 0 0         return if ! $o->{actor}->sentListReady;
13173              
13174             # Transfer
13175 0           my $transfers = $o->{transfers};
13176 0           $o->{transfers} = [];
13177 0           for my $transfer (@$transfers) {
13178 0           my ($missingObject, $store, $error) = $o->{actor}->keyPair->transfer($transfer->{hashes}, $transfer->{sourceStore}, $o->{actor}->messagingPrivateRoot->unsaved);
13179 0 0         return if defined $error;
13180              
13181 0 0         if ($missingObject) {
13182 0           $missingObject->{context} = $transfer->{context};
13183 0           return undef, $missingObject;
13184             }
13185             }
13186              
13187             # Send the message
13188 0           return CDS::MessageChannel::Submission->new($o, $message, $done);
13189             }
13190              
13191             sub clear {
13192 0     0     my $o = shift;
13193              
13194 0           $o->item->clear(CDS->now + $o->{validity});
13195             }
13196              
13197             package CDS::MessageChannel::Submission;
13198              
13199             sub new {
13200 0     0     my $class = shift;
13201 0           my $channel = shift;
13202 0           my $message = shift;
13203 0           my $done = shift;
13204              
13205 0           $channel->{currentSubmissionId} += 1;
13206              
13207             my $o = bless {
13208             channel => $channel,
13209             message => $message,
13210             done => $done,
13211             submissionId => $channel->{currentSubmissionId},
13212 0           recipients => [$channel->recipients],
13213             entrustedKeys => [$channel->entrustedKeys],
13214             expires => CDS->now + $channel->validity,
13215             };
13216              
13217             # Add the current envelope hash to the obsolete hashes
13218 0           my $item = $channel->item;
13219 0 0         $channel->{obsoleteHashes}->{$item->envelopeHash->bytes} = $item->envelopeHash if $item->envelopeHash;
13220 0           $o->{obsoleteHashesSnapshot} = [values %{$channel->{obsoleteHashes}}];
  0            
13221              
13222             # Create an envelope
13223 0           my $publicKeys = [];
13224 0           push @$publicKeys, $channel->{actor}->keyPair->publicKey;
13225 0           push @$publicKeys, map { $_->publicKey } @{$o->{recipients}};
  0            
  0            
13226 0           push @$publicKeys, @{$o->{entrustedKeys}};
  0            
13227 0           $o->{envelopeObject} = $channel->{actor}->keyPair->createMessageEnvelope($channel->{actor}->messagingStoreUrl, $message, $publicKeys, $o->{expires})->toObject;
13228 0           $o->{envelopeHash} = $o->{envelopeObject}->calculateHash;
13229              
13230             # Set the new item and wait until it gets saved
13231 0           $channel->{unsaved}->startSaving;
13232 0           $channel->{unsaved}->savingState->addDataSavedHandler($o);
13233 0           $channel->{actor}->sentList->unsaved->state->merge($channel->{unsaved}->savingState);
13234 0           $item->set($o->{expires}, $o->{envelopeHash}, $message);
13235 0           $channel->{unsaved}->savingDone;
13236              
13237 0           return $o;
13238             }
13239              
13240 0     0     sub channel { shift->{channel} }
13241 0     0     sub message { shift->{message} }
13242             sub recipients {
13243 0     0     my $o = shift;
13244 0           @{$o->{recipients}} }
  0            
13245             sub entrustedKeys {
13246 0     0     my $o = shift;
13247 0           @{$o->{entrustedKeys}} }
  0            
13248 0     0     sub expires { shift->{expires} }
13249 0     0     sub envelopeObject { shift->{envelopeObject} }
13250 0     0     sub envelopeHash { shift->{envelopeHash} }
13251              
13252             sub onDataSaved {
13253 0     0     my $o = shift;
13254              
13255             # If we are not the head any more, give up
13256 0 0         return $o->{done}->onMessageChannelSubmissionCancelled if $o->{submissionId} != $o->{channel}->{currentSubmissionId};
13257 0           $o->{channel}->{obsoleteHashes}->{$o->{envelopeHash}->bytes} = $o->{envelopeHash};
13258              
13259             # Process all recipients
13260 0           my $succeeded = 0;
13261 0           my $failed = 0;
13262 0           for my $recipient (@{$o->{recipients}}) {
  0            
13263 0           my $modifications = CDS::StoreModifications->new;
13264              
13265             # Prepare the list of removals
13266 0           my $removals = [];
13267 0           for my $hash (@{$o->{obsoleteHashesSnapshot}}) {
  0            
13268 0           $modifications->remove($recipient->publicKey->hash, 'messages', $hash);
13269             }
13270              
13271             # Add the message entry
13272 0           $modifications->add($recipient->publicKey->hash, 'messages', $o->{envelopeHash}, $o->{envelopeObject});
13273 0           my $error = $recipient->store->modify($modifications, $o->{channel}->{actor}->keyPair);
13274              
13275 0 0         if (defined $error) {
13276 0           $failed += 1;
13277 0           $o->{done}->onMessageChannelSubmissionRecipientFailed($recipient, $error);
13278             } else {
13279 0           $succeeded += 1;
13280 0           $o->{done}->onMessageChannelSubmissionRecipientDone($recipient);
13281             }
13282             }
13283              
13284 0 0 0       if ($failed == 0 || scalar keys %{$o->{obsoleteHashes}} > 64) {
  0            
13285 0           for my $hash (@{$o->{obsoleteHashesSnapshot}}) {
  0            
13286 0           delete $o->{channel}->{obsoleteHashes}->{$hash->bytes};
13287             }
13288             }
13289              
13290 0           $o->{done}->onMessageChannelSubmissionDone($succeeded, $failed);
13291             }
13292              
13293             package CDS::MissingObject;
13294              
13295             sub new {
13296 0     0     my $class = shift;
13297 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
13298 0           my $store = shift;
13299              
13300 0           return bless {hash => $hash, store => $store, path => [], context => undef};
13301             }
13302              
13303 0     0     sub hash { shift->{hash} }
13304 0     0     sub store { shift->{store} }
13305             sub path {
13306 0     0     my $o = shift;
13307 0           @{$o->{path}} }
  0            
13308 0     0     sub context { shift->{context} }
13309              
13310             package CDS::NewAnnounce;
13311              
13312             sub new {
13313 0     0     my $class = shift;
13314 0           my $messagingStore = shift;
13315              
13316 0           my $o = bless {
13317             messagingStore => $messagingStore,
13318             unsaved => CDS::Unsaved->new($messagingStore->store),
13319             transfers => [],
13320             card => CDS::Record->new,
13321             };
13322              
13323 0           my $publicKey = $messagingStore->actor->keyPair->publicKey;
13324 0           $o->{card}->add('public key')->addHash($publicKey->hash);
13325 0           $o->addObject($publicKey->hash, $publicKey->object);
13326 0           return $o;
13327             }
13328              
13329 0     0     sub messagingStore { shift->{messagingStore} }
13330 0     0     sub card { shift->{card} }
13331              
13332             sub addObject {
13333 0     0     my $o = shift;
13334 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
13335 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
13336              
13337 0           $o->{unsaved}->state->addObject($hash, $object);
13338             }
13339              
13340             sub addTransfer {
13341 0     0     my $o = shift;
13342 0           my $hashes = shift;
13343 0           my $sourceStore = shift;
13344 0           my $context = shift;
13345              
13346 0 0         return if ! scalar @$hashes;
13347 0           push @{$o->{transfers}}, {hashes => $hashes, sourceStore => $sourceStore, context => $context};
  0            
13348             }
13349              
13350             sub addActorGroup {
13351 0     0     my $o = shift;
13352 0           my $actorGroupBuilder = shift;
13353              
13354 0           $actorGroupBuilder->addToRecord($o->{card}, 0);
13355             }
13356              
13357             sub submit {
13358 0     0     my $o = shift;
13359              
13360 0           my $keyPair = $o->{messagingStore}->actor->keyPair;
13361              
13362             # Create the public card
13363 0           my $cardObject = $o->{card}->toObject;
13364 0           my $cardHash = $cardObject->calculateHash;
13365 0           $o->addObject($cardHash, $cardObject);
13366              
13367             # Prepare the public envelope
13368 0           my $me = $keyPair->publicKey->hash;
13369 0           my $envelopeObject = $keyPair->createPublicEnvelope($cardHash)->toObject;
13370 0           my $envelopeHash = $envelopeObject->calculateHash;
13371 0           $o->addTransfer([$cardHash], $o->{unsaved}, 'Announcing');
13372              
13373             # Transfer all trees
13374 0           for my $transfer (@{$o->{transfers}}) {
  0            
13375 0           my ($missingObject, $store, $error) = $keyPair->transfer($transfer->{hashes}, $transfer->{sourceStore}, $o->{messagingStore}->store);
13376 0 0         return if defined $error;
13377              
13378 0 0         if ($missingObject) {
13379 0           $missingObject->{context} = $transfer->{context};
13380 0           return undef, $missingObject;
13381             }
13382             }
13383              
13384             # Prepare a modification
13385 0           my $modifications = CDS::StoreModifications->new;
13386 0           $modifications->add($me, 'public', $envelopeHash, $envelopeObject);
13387              
13388             # List the current cards to remove them
13389             # Ignore errors, in the worst case, we are going to have multiple entries in the public box
13390 0           my ($hashes, $error) = $o->{messagingStore}->store->list($me, 'public', 0, $keyPair);
13391 0 0         if ($hashes) {
13392 0           for my $hash (@$hashes) {
13393 0           $modifications->remove($me, 'public', $hash);
13394             }
13395             }
13396              
13397             # Modify the public box
13398 0           my $modifyError = $o->{messagingStore}->store->modify($modifications, $keyPair);
13399 0 0         return if defined $modifyError;
13400 0           return $envelopeHash, $cardHash;
13401             }
13402              
13403             package CDS::NewMessagingStore;
13404              
13405             sub new {
13406 0     0     my $class = shift;
13407 0           my $actor = shift;
13408 0           my $store = shift;
13409              
13410 0           return bless {
13411             actor => $actor,
13412             store => $store,
13413             };
13414             }
13415              
13416 0     0     sub actor { shift->{actor} }
13417 0     0     sub store { shift->{store} }
13418              
13419             # A Condensation object.
13420             # A valid object starts with a 4-byte length (big-endian), followed by 32 * length bytes of hashes, followed by 0 or more bytes of data.
13421             package CDS::Object;
13422              
13423 0     0     sub emptyHeader { "\0\0\0\0" }
13424              
13425             sub create {
13426 0     0     my $class = shift;
13427 0           my $header = shift;
13428 0           my $data = shift;
13429              
13430 0 0         return if length $header < 4;
13431 0           my $hashesCount = unpack('L>', substr($header, 0, 4));
13432 0 0         return if length $header != 4 + $hashesCount * 32;
13433 0           return bless {
13434             bytes => $header.$data,
13435             hashesCount => $hashesCount,
13436             header => $header,
13437             data => $data
13438             };
13439             }
13440              
13441             sub fromBytes {
13442 0     0     my $class = shift;
13443 0   0       my $bytes = shift // return;
13444              
13445 0 0         return if length $bytes < 4;
13446              
13447 0           my $hashesCount = unpack 'L>', substr($bytes, 0, 4);
13448 0           my $dataStart = $hashesCount * 32 + 4;
13449 0 0         return if $dataStart > length $bytes;
13450              
13451 0           return bless {
13452             bytes => $bytes,
13453             hashesCount => $hashesCount,
13454             header => substr($bytes, 0, $dataStart),
13455             data => substr($bytes, $dataStart)
13456             };
13457             }
13458              
13459             sub fromFile {
13460 0     0     my $class = shift;
13461 0           my $file = shift;
13462              
13463 0           return $class->fromBytes(CDS->readBytesFromFile($file));
13464             }
13465              
13466 0     0     sub bytes { shift->{bytes} }
13467 0     0     sub header { shift->{header} }
13468 0     0     sub data { shift->{data} }
13469 0     0     sub hashesCount { shift->{hashesCount} }
13470             sub byteLength {
13471 0     0     my $o = shift;
13472 0           length($o->{header}) + length($o->{data}) }
13473              
13474             sub calculateHash {
13475 0     0     my $o = shift;
13476              
13477 0           return CDS::Hash->calculateFor($o->{bytes});
13478             }
13479              
13480             sub hashes {
13481 0     0     my $o = shift;
13482              
13483 0           return map { CDS::Hash->fromBytes(substr($o->{header}, $_ * 32 + 4, 32)) } 0 .. $o->{hashesCount} - 1;
  0            
13484             }
13485              
13486             sub hashAtIndex {
13487 0     0     my $o = shift;
13488 0   0       my $index = shift // return;
13489              
13490 0 0 0       return if $index < 0 || $index >= $o->{hashesCount};
13491 0           return CDS::Hash->fromBytes(substr($o->{header}, $index * 32 + 4, 32));
13492             }
13493              
13494             sub crypt {
13495 0     0     my $o = shift;
13496 0           my $key = shift;
13497              
13498 0           return CDS::Object->create($o->{header}, CDS::C::aesCrypt($o->{data}, $key, CDS->zeroCTR));
13499             }
13500              
13501             sub writeToFile {
13502 0     0     my $o = shift;
13503 0           my $file = shift;
13504              
13505 0           return CDS->writeBytesToFile($file, $o->{bytes});
13506             }
13507              
13508             # A store using a cache store to deliver frequently accessed objects faster, and a backend store.
13509             package CDS::ObjectCache;
13510              
13511 1     1   6145 use parent -norequire, 'CDS::Store';
  1         2  
  1         6  
13512              
13513             sub new {
13514 0     0     my $class = shift;
13515 0           my $backend = shift;
13516 0           my $cache = shift;
13517              
13518 0           return bless {
13519             id => "Object Cache\n".$backend->id."\n".$cache->id,
13520             backend => $backend,
13521             cache => $cache,
13522             };
13523             }
13524              
13525 0     0     sub id { shift->{id} }
13526 0     0     sub backend { shift->{backend} }
13527 0     0     sub cache { shift->{cache} }
13528              
13529             sub get {
13530 0     0     my $o = shift;
13531 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
13532 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
13533              
13534 0           my $objectFromCache = $o->{cache}->get($hash);
13535 0 0         return $objectFromCache if $objectFromCache;
13536              
13537 0           my ($object, $error) = $o->{backend}->get($hash, $keyPair);
13538 0 0         return undef, $error if ! defined $object;
13539 0           $o->{cache}->put($hash, $object, undef);
13540 0           return $object;
13541             }
13542              
13543             sub put {
13544 0     0     my $o = shift;
13545              
13546             # The important thing is that the backend succeeds. The cache is a nice-to-have.
13547 0           $o->{cache}->put(@_);
13548 0           return $o->{backend}->put(@_);
13549             }
13550              
13551             sub book {
13552 0     0     my $o = shift;
13553              
13554             # The important thing is that the backend succeeds. The cache is a nice-to-have.
13555 0           $o->{cache}->book(@_);
13556 0           return $o->{backend}->book(@_);
13557             }
13558              
13559             sub list {
13560 0     0     my $o = shift;
13561              
13562             # Just pass this through to the backend.
13563 0           return $o->{backend}->list(@_);
13564             }
13565              
13566             sub add {
13567 0     0     my $o = shift;
13568              
13569             # Just pass this through to the backend.
13570 0           return $o->{backend}->add(@_);
13571             }
13572              
13573             sub remove {
13574 0     0     my $o = shift;
13575              
13576             # Just pass this through to the backend.
13577 0           return $o->{backend}->remove(@_);
13578             }
13579              
13580             sub modify {
13581 0     0     my $o = shift;
13582              
13583             # Just pass this through to the backend.
13584 0           return $o->{backend}->modify(@_);
13585             }
13586              
13587             # The result of parsing an OBJECTFILE token (see Token.pm).
13588             package CDS::ObjectFileToken;
13589              
13590             sub new {
13591 0     0     my $class = shift;
13592 0           my $file = shift;
13593 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
13594              
13595 0           return bless {
13596             file => $file,
13597             object => $object,
13598             };
13599             }
13600              
13601 0     0     sub file { shift->{file} }
13602 0     0     sub object { shift->{object} }
13603              
13604             # The result of parsing an OBJECT token.
13605             package CDS::ObjectToken;
13606              
13607             sub new {
13608 0     0     my $class = shift;
13609 0           my $cliStore = shift;
13610 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
13611              
13612 0           return bless {
13613             cliStore => $cliStore,
13614             hash => $hash,
13615             };
13616             }
13617              
13618 0     0     sub cliStore { shift->{cliStore} }
13619 0     0     sub hash { shift->{hash} }
13620             sub url {
13621 0     0     my $o = shift;
13622 0           $o->{cliStore}->url.'/objects/'.$o->{hash}->hex }
13623              
13624             package CDS::Parser;
13625              
13626             sub new {
13627 0     0     my $class = shift;
13628 0           my $actor = shift;
13629 0           my $command = shift;
13630              
13631 0           my $start = CDS::Parser::Node->new(0);
13632 0           return bless {
13633             actor => $actor,
13634             ui => $actor->ui,
13635             start => $start,
13636             states => [CDS::Parser::State->new($start)],
13637             command => $command,
13638             };
13639             }
13640              
13641 0     0     sub actor { shift->{actor} }
13642 0     0     sub start { shift->{start} }
13643              
13644             sub execute {
13645 0     0     my $o = shift;
13646              
13647 0           my $processed = [$o->{command}];
13648 0           for my $arg (@_) {
13649 0 0         return $o->howToContinue($processed) if $arg eq '?';
13650 0 0         return $o->explain if $arg eq '??';
13651 0           my $token = CDS::Parser::Token->new($o->{actor}, $arg);
13652 0           $o->advance($token);
13653 0 0         return $o->invalid($processed, $token) if ! scalar @{$o->{states}};
  0            
13654 0           push @$processed, $arg;
13655             }
13656              
13657 0           my @results = grep { $_->runHandler } @{$o->{states}};
  0            
  0            
13658 0 0         return $o->howToContinue($processed) if ! scalar @results;
13659              
13660 0           my $maxWeight = 0;
13661 0           for my $result (@results) {
13662 0 0         $maxWeight = $result->cumulativeWeight if $maxWeight < $result->cumulativeWeight;
13663             }
13664              
13665 0           @results = grep { $_->cumulativeWeight == $maxWeight } @results;
  0            
13666 0 0         return $o->ambiguous if scalar @results > 1;
13667              
13668 0           my $result = shift @results;
13669 0           my $handler = $result->runHandler;
13670 0           my $instance = &{$handler->{constructor}}(undef, $o->{actor});
  0            
13671 0           &{$handler->{function}}($instance, $result);
  0            
13672             }
13673              
13674             sub advance {
13675 0     0     my $o = shift;
13676 0           my $token = shift;
13677              
13678 0           $o->{previousStates} = $o->{states};
13679 0           $o->{states} = [];
13680 0           for my $state (@{$o->{previousStates}}) {
  0            
13681 0           push @{$o->{states}}, $state->advance($token);
  0            
13682             }
13683             }
13684              
13685             sub showCompletions {
13686 0     0     my $o = shift;
13687 0           my $cmd = shift;
13688              
13689             # Parse the command line
13690 0           my $state = '';
13691 0           my $arg = '';
13692 0           my @args;
13693 0           for my $c (split //, $cmd) {
13694 0 0         if ($state eq '') {
    0          
    0          
    0          
    0          
13695 0 0         if ($c eq ' ') {
    0          
    0          
    0          
13696 0 0         push @args, $arg if length $arg;
13697 0           $arg = '';
13698             } elsif ($c eq '\'') {
13699 0 0         push @args, $arg if length $arg;
13700 0           $arg = '';
13701 0           $state = '\'';
13702             } elsif ($c eq '"') {
13703 0 0         push @args, $arg if length $arg;
13704 0           $arg = '';
13705 0           $state = '"';
13706             } elsif ($c eq '\\') {
13707 0           $state = '\\';
13708             } else {
13709 0           $arg .= $c;
13710             }
13711             } elsif ($state eq '\\') {
13712 0           $arg .= $c;
13713 0           $state = '';
13714             } elsif ($state eq '\'') {
13715 0 0         if ($c eq '\'') {
13716 0 0         push @args, $arg if length $arg;
13717 0           $arg = '';
13718 0           $state = '';
13719             } else {
13720 0           $arg .= $c;
13721             }
13722             } elsif ($state eq '"') {
13723 0 0         if ($c eq '"') {
    0          
13724 0 0         push @args, $arg if length $arg;
13725 0           $arg = '';
13726 0           $state = '';
13727             } elsif ($c eq '\\') {
13728 0           $state = '"\\';
13729             } else {
13730 0           $arg .= $c;
13731             }
13732             } elsif ($state eq '\\"') {
13733 0           $arg .= $c;
13734 0           $state = '"';
13735             }
13736             }
13737              
13738             # Use the last token to complete
13739 0           my $lastToken = CDS::Parser::Token->new($o->{actor}, $arg);
13740              
13741             # Look for possible states
13742 0           shift @args;
13743 0           for my $arg (@args) {
13744 0 0         return if $arg eq '?';
13745 0           $o->advance(CDS::Parser::Token->new($o->{actor}, $arg));
13746             }
13747              
13748             # Complete the last token
13749 0           my %possibilities;
13750 0           for my $state (@{$o->{states}}) {
  0            
13751 0           for my $possibility ($state->complete($lastToken)) {
13752 0           $possibilities{$possibility} = 1;
13753             }
13754             }
13755              
13756             # Print all possibilities
13757 0           for my $possibility (keys %possibilities) {
13758 0           print $possibility, "\n";
13759             }
13760             }
13761              
13762             sub ambiguous {
13763 0     0     my $o = shift;
13764              
13765 0           $o->{ui}->space;
13766 0           $o->{ui}->pRed('Your query is ambiguous. This is an error in the command grammar.');
13767 0           $o->explain;
13768             }
13769              
13770             sub explain {
13771 0     0     my $o = shift;
13772              
13773 0 0         for my $interpretation (sort { $b->cumulativeWeight <=> $a->cumulativeWeight || $b->isExecutable <=> $a->isExecutable } @{$o->{states}}) {
  0            
  0            
13774 0           $o->{ui}->space;
13775 0 0         $o->{ui}->title('Interpretation with weight ', $interpretation->cumulativeWeight, $interpretation->isExecutable ? $o->{ui}->green(' (executable)') : $o->{ui}->orange(' (incomplete)'));
13776 0           $o->showTuples($interpretation->path);
13777             }
13778              
13779 0           $o->{ui}->space;
13780             }
13781              
13782             sub showTuples {
13783 0     0     my $o = shift;
13784              
13785 0           for my $state (@_) {
13786 0           my $label = $state->label;
13787 0           my $value = $state->value;
13788              
13789 0           my $valueRef = ref $value;
13790 0 0 0       my $valueText =
    0          
    0          
    0          
13791             $valueRef eq '' ? $value // '' :
13792             $valueRef eq 'CDS::Hash' ? $value->hex :
13793             $valueRef eq 'CDS::ErrorHandlingStore' ? $value->url :
13794             $valueRef eq 'CDS::AccountToken' ? $value->actorHash->hex . ' on ' . $value->cliStore->url :
13795             $valueRef;
13796 0 0         $o->{ui}->line($o->{ui}->left(12, $label), $state->collectHandler ? $valueText : $o->{ui}->gray($valueText));
13797             }
13798             }
13799              
13800             sub cmd {
13801 0     0     my $o = shift;
13802 0           my $processed = shift;
13803              
13804 0           my $cmd = join(' ', map { $_ =~ s/(\\|'|")/\\$1/g ; $_ } @$processed);
  0            
  0            
13805 0 0         $cmd = '…'.substr($cmd, length($cmd) - 20, 20) if length $cmd > 30;
13806 0           return $cmd;
13807             }
13808              
13809             sub howToContinue {
13810 0     0     my $o = shift;
13811 0           my $processed = shift;
13812              
13813 0           my $cmd = $o->cmd($processed);
13814             #$o->displayWarnings($o->{states});
13815 0           $o->{ui}->space;
13816 0           for my $possibility (CDS::Parser::Continuations->collect($o->{states})) {
13817 0           $o->{ui}->line($o->{ui}->gray($cmd), $possibility);
13818             }
13819 0           $o->{ui}->space;
13820             }
13821              
13822             sub invalid {
13823 0     0     my $o = shift;
13824 0           my $processed = shift;
13825 0           my $invalid = shift;
13826              
13827 0           my $cmd = $o->cmd($processed);
13828 0           $o->displayWarnings($o->{previousStates});
13829 0           $o->{ui}->space;
13830              
13831 0           $o->{ui}->line($o->{ui}->gray($cmd), ' ', $o->{ui}->red($invalid->{text}));
13832 0 0         if (scalar @{$invalid->{warnings}}) {
  0            
13833 0           for my $warning (@{$invalid->{warnings}}) {
  0            
13834 0           $o->{ui}->warning($warning);
13835             }
13836             }
13837              
13838 0           $o->{ui}->space;
13839 0           $o->{ui}->title('Possible continuations');
13840 0           for my $possibility (CDS::Parser::Continuations->collect($o->{previousStates})) {
13841 0           $o->{ui}->line($o->{ui}->gray($cmd), $possibility);
13842             }
13843 0           $o->{ui}->space;
13844             }
13845              
13846             sub displayWarnings {
13847 0     0     my $o = shift;
13848 0           my $states = shift;
13849              
13850 0           for my $state (@$states) {
13851 0           my $current = $state;
13852 0           while ($current) {
13853 0           for my $warning (@{$current->{warnings}}) {
  0            
13854 0           $o->{ui}->warning($warning);
13855             }
13856 0           $current = $current->{previous};
13857             }
13858             }
13859             }
13860              
13861             # An arrow points from one node to another. The arrow is taken in State::advance if the next argument matches to the label.
13862             package CDS::Parser::Arrow;
13863              
13864             sub new {
13865 0     0     my $class = shift;
13866 0           my $node = shift;
13867 0           my $official = shift;
13868 0           my $weight = shift;
13869 0           my $label = shift;
13870 0           my $handler = shift;
13871              
13872 0           return bless {
13873             node => $node, # target node
13874             official => $official, # whether to show this arrow with '?'
13875             weight => $weight, # weight
13876             label => $label, # label
13877             handler => $handler, # handler to invoke if we take this arrow
13878             };
13879             }
13880              
13881             package CDS::Parser::Continuations;
13882              
13883             sub collect {
13884 0     0     my $class = shift;
13885 0           my $states = shift;
13886              
13887 0           my $o = bless {possibilities => {}};
13888              
13889 0           my $visitedNodes = {};
13890 0           for my $state (@$states) {
13891 0           $o->visit($visitedNodes, $state->node, '');
13892             }
13893              
13894 0           for my $possibility (keys %{$o->{possibilities}}) {
  0            
13895 0 0         delete $o->{possibilities}->{$possibility} if exists $o->{possibilities}->{$possibility.' …'};
13896             }
13897              
13898 0           return sort keys %{$o->{possibilities}};
  0            
13899             }
13900              
13901             sub visit {
13902 0     0     my $o = shift;
13903 0           my $visitedNodes = shift;
13904 0           my $node = shift;
13905 0           my $text = shift;
13906              
13907 0           $visitedNodes->{$node} = 1;
13908              
13909 0           my $arrows = [];
13910 0           $node->collectArrows($arrows);
13911              
13912 0           for my $arrow (@$arrows) {
13913 0 0         next if ! $arrow->{official};
13914              
13915 0           my $text = $text.' '.$arrow->{label};
13916 0 0         $o->{possibilities}->{$text} = 1 if $arrow->{node}->hasHandler;
13917 0 0 0       if ($arrow->{node}->endProposals || exists $visitedNodes->{$arrow->{node}}) {
13918 0 0         $o->{possibilities}->{$text . ($o->canContinue($arrow->{node}) ? ' …' : '')} = 1;
13919 0           next;
13920             }
13921              
13922 0           $o->visit($visitedNodes, $arrow->{node}, $text);
13923             }
13924              
13925 0           delete $visitedNodes->{$node};
13926             }
13927              
13928             sub canContinue {
13929 0     0     my $o = shift;
13930 0           my $node = shift;
13931              
13932 0           my $arrows = [];
13933 0           $node->collectArrows($arrows);
13934              
13935 0           for my $arrow (@$arrows) {
13936 0 0         next if ! $arrow->{official};
13937 0           return 1;
13938             }
13939              
13940 0           return;
13941             }
13942              
13943             # Nodes and arrows define the graph on which the parse state can move.
13944             package CDS::Parser::Node;
13945              
13946             sub new {
13947 0     0     my $class = shift;
13948 0           my $endProposals = shift;
13949 0           my $handler = shift;
13950              
13951 0           return bless {
13952             arrows => [], # outgoing arrows
13953             defaults => [], # default nodes, at which the current state could be as well
13954             endProposals => $endProposals, # if set, the proposal search algorithm stops at this node
13955             handler => $handler, # handler to be executed if parsing ends here
13956             };
13957             }
13958              
13959 0     0     sub endProposals { shift->{endProposals} }
13960              
13961             # Adds an arrow.
13962             sub addArrow {
13963 0     0     my $o = shift;
13964 0           my $to = shift;
13965 0           my $official = shift;
13966 0           my $weight = shift;
13967 0           my $label = shift;
13968 0           my $handler = shift;
13969              
13970 0           push @{$o->{arrows}}, CDS::Parser::Arrow->new($to, $official, $weight, $label, $handler);
  0            
13971             }
13972              
13973             # Adds a default node.
13974             sub addDefault {
13975 0     0     my $o = shift;
13976 0           my $node = shift;
13977              
13978 0           push @{$o->{defaults}}, $node;
  0            
13979             }
13980              
13981             sub collectArrows {
13982 0     0     my $o = shift;
13983 0           my $arrows = shift;
13984              
13985 0           push @$arrows, @{$o->{arrows}};
  0            
13986 0           for my $default (@{$o->{defaults}}) { $default->collectArrows($arrows); }
  0            
  0            
13987             }
13988              
13989             sub hasHandler {
13990 0     0     my $o = shift;
13991              
13992 0 0         return 1 if $o->{handler};
13993 0 0         for my $default (@{$o->{defaults}}) { return 1 if $default->hasHandler; }
  0            
  0            
13994 0           return;
13995             }
13996              
13997             sub getHandler {
13998 0     0     my $o = shift;
13999              
14000 0 0         return $o->{handler} if $o->{handler};
14001 0           for my $default (@{$o->{defaults}}) {
  0            
14002 0   0       my $handler = $default->getHandler // next;
14003 0           return $handler;
14004             }
14005 0           return;
14006             }
14007              
14008             # A parser state denotes a possible current state (after having parsed a certain number of arguments).
14009             # A parser keeps track of multiple states. When advancing, a state may disappear (if no possibility exists), or fan out (if multiple possibilities exist).
14010             # A state is immutable.
14011             package CDS::Parser::State;
14012              
14013             sub new {
14014 0     0     my $class = shift;
14015 0           my $node = shift;
14016 0           my $previous = shift;
14017 0           my $arrow = shift;
14018 0           my $value = shift;
14019 0           my $warnings = shift;
14020              
14021             return bless {
14022             node => $node, # current node
14023             previous => $previous, # previous state
14024             arrow => $arrow, # the arrow we took to get here
14025             value => $value, # the value we collected with the last arrow
14026             warnings => $warnings, # the warnings we collected with the last arrow
14027 0 0         cumulativeWeight => ($previous ? $previous->cumulativeWeight : 0) + ($arrow ? $arrow->{weight} : 0), # the weight we collected until here
    0          
14028             };
14029             }
14030              
14031 0     0     sub node { shift->{node} }
14032             sub runHandler {
14033 0     0     my $o = shift;
14034 0           $o->{node}->getHandler }
14035             sub isExecutable {
14036 0     0     my $o = shift;
14037 0 0         $o->{node}->getHandler ? 1 : 0 }
14038             sub collectHandler {
14039 0     0     my $o = shift;
14040 0 0         $o->{arrow} ? $o->{arrow}->{handler} : undef }
14041             sub label {
14042 0     0     my $o = shift;
14043 0 0         $o->{arrow} ? $o->{arrow}->{label} : 'cds' }
14044 0     0     sub value { shift->{value} }
14045 0     0     sub arrow { shift->{arrow} }
14046 0     0     sub cumulativeWeight { shift->{cumulativeWeight} }
14047              
14048             sub advance {
14049 0     0     my $o = shift;
14050 0           my $token = shift;
14051              
14052 0           my $arrows = [];
14053 0           $o->{node}->collectArrows($arrows);
14054              
14055             # Let the token know what possibilities we have
14056 0           for my $arrow (@$arrows) {
14057 0           $token->prepare($arrow->{label});
14058             }
14059              
14060             # Ask the token to interpret the text
14061 0           my @states;
14062 0           for my $arrow (@$arrows) {
14063 0   0       my $value = $token->as($arrow->{label}) // next;
14064 0           push @states, CDS::Parser::State->new($arrow->{node}, $o, $arrow, $value, $token->{warnings});
14065             }
14066              
14067 0           return @states;
14068             }
14069              
14070             sub complete {
14071 0     0     my $o = shift;
14072 0           my $token = shift;
14073              
14074 0           my $arrows = [];
14075 0           $o->{node}->collectArrows($arrows);
14076              
14077             # Let the token know what possibilities we have
14078 0           for my $arrow (@$arrows) {
14079 0 0         next if ! $arrow->{official};
14080 0           $token->prepare($arrow->{label});
14081             }
14082              
14083             # Ask the token to interpret the text
14084 0           for my $arrow (@$arrows) {
14085 0 0         next if ! $arrow->{official};
14086 0           $token->complete($arrow->{label});
14087             }
14088              
14089 0           return @{$token->{possibilities}};
  0            
14090             }
14091              
14092             sub arrows {
14093 0     0     my $o = shift;
14094              
14095 0           my $arrows = [];
14096 0           $o->{node}->collectArrows($arrows);
14097 0           return @$arrows;
14098             }
14099              
14100             sub path {
14101 0     0     my $o = shift;
14102              
14103 0           my @path;
14104 0           my $state = $o;
14105 0           while ($state) {
14106 0           unshift @path, $state;
14107 0           $state = $state->{previous};
14108             }
14109 0           return @path;
14110             }
14111              
14112             sub collect {
14113 0     0     my $o = shift;
14114 0           my $data = shift;
14115              
14116 0           for my $state ($o->path) {
14117 0   0       my $collectHandler = $state->collectHandler // next;
14118 0           &$collectHandler($data, $state->label, $state->value);
14119             }
14120             }
14121              
14122             package CDS::Parser::Token;
14123              
14124             sub new {
14125 0     0     my $class = shift;
14126 0           my $actor = shift;
14127 0           my $text = shift;
14128              
14129 0           return bless {
14130             actor => $actor,
14131             text => $text,
14132             keywords => {},
14133             cache => {},
14134             warnings => [],
14135             possibilities => [],
14136             };
14137             }
14138              
14139             sub prepare {
14140 0     0     my $o = shift;
14141 0           my $expect = shift;
14142              
14143 0 0         $o->{keywords}->{$expect} = 1 if $expect =~ /^[a-z0-9]*$/;
14144             }
14145              
14146             sub as {
14147 0     0     my $o = shift;
14148 0           my $expect = shift;
14149 0 0         exists $o->{cache}->{$expect} ? $o->{cache}->{$expect} : $o->{cache}->{$expect} = $o->produce($expect) }
14150              
14151             sub produce {
14152 0     0     my $o = shift;
14153 0           my $expect = shift;
14154              
14155 0 0         return $o->account if $expect eq 'ACCOUNT';
14156 0 0         return $o->hash if $expect eq 'ACTOR';
14157 0 0         return $o->actorGroup if $expect eq 'ACTORGROUP';
14158 0 0         return $o->aesKey if $expect eq 'AESKEY';
14159 0 0         return $o->box if $expect eq 'BOX';
14160 0 0         return $o->boxLabel if $expect eq 'BOXLABEL';
14161 0 0         return $o->file if $expect eq 'FILE';
14162 0 0         return $o->filename if $expect eq 'FILENAME';
14163 0 0         return $o->folder if $expect eq 'FOLDER';
14164 0 0         return $o->foldername if $expect eq 'FOLDERNAME';
14165 0 0         return $o->group if $expect eq 'GROUP';
14166 0 0         return $o->hash if $expect eq 'HASH';
14167 0 0         return $o->keyPair if $expect eq 'KEYPAIR';
14168 0 0         return $o->label if $expect eq 'LABEL';
14169 0 0         return $o->object if $expect eq 'OBJECT';
14170 0 0         return $o->objectFile if $expect eq 'OBJECTFILE';
14171 0 0         return $o->port if $expect eq 'PORT';
14172 0 0         return $o->store if $expect eq 'STORE';
14173 0 0         return $o->text if $expect eq 'TEXT';
14174 0 0         return $o->user if $expect eq 'USER';
14175 0 0         return $o->{text} eq $expect ? '' : undef;
14176             }
14177              
14178             sub complete {
14179 0     0     my $o = shift;
14180 0           my $expect = shift;
14181              
14182 0 0         return $o->completeAccount if $expect eq 'ACCOUNT';
14183 0 0         return $o->completeHash if $expect eq 'ACTOR';
14184 0 0         return $o->completeActorGroup if $expect eq 'ACTORGROUP';
14185 0 0         return if $expect eq 'AESKEY';
14186 0 0         return $o->completeBox if $expect eq 'BOX';
14187 0 0         return $o->completeBoxLabel if $expect eq 'BOXLABEL';
14188 0 0         return $o->completeFile if $expect eq 'FILE';
14189 0 0         return $o->completeFile if $expect eq 'FILENAME';
14190 0 0         return $o->completeFolder if $expect eq 'FOLDER';
14191 0 0         return $o->completeFolder if $expect eq 'FOLDERNAME';
14192 0 0         return $o->completeGroup if $expect eq 'GROUP';
14193 0 0         return $o->completeHash if $expect eq 'HASH';
14194 0 0         return $o->completeKeyPair if $expect eq 'KEYPAIR';
14195 0 0         return $o->completeLabel if $expect eq 'LABEL';
14196 0 0         return $o->completeObject if $expect eq 'OBJECT';
14197 0 0         return $o->completeObjectFile if $expect eq 'OBJECTFILE';
14198 0 0         return $o->completeStoreUrl if $expect eq 'STORE';
14199 0 0         return $o->completeUser if $expect eq 'USER';
14200 0 0         return if $expect eq 'TEXT';
14201 0           $o->addPossibility($expect);
14202             }
14203              
14204             sub addPossibility {
14205 0     0     my $o = shift;
14206 0           my $possibility = shift;
14207              
14208 0 0         push @{$o->{possibilities}}, $possibility.' ' if substr($possibility, 0, length $o->{text}) eq $o->{text};
  0            
14209             }
14210              
14211             sub addPartialPossibility {
14212 0     0     my $o = shift;
14213 0           my $possibility = shift;
14214              
14215 0 0         push @{$o->{possibilities}}, $possibility if substr($possibility, 0, length $o->{text}) eq $o->{text};
  0            
14216             }
14217              
14218             sub isKeyword {
14219 0     0     my $o = shift;
14220 0           exists $o->{keywords}->{$o->{text}} }
14221              
14222             sub account {
14223 0     0     my $o = shift;
14224              
14225             # From a remembered account
14226 0           my $record = $o->{actor}->remembered($o->{text});
14227 0           my $storeUrl = $record->child('store')->textValue;
14228 0           my $actorHash = CDS::Hash->fromBytes($record->child('actor')->bytesValue);
14229 0 0 0       if ($actorHash && length $storeUrl) {
14230 0   0       my $store = $o->{actor}->storeForUrl($storeUrl) // return $o->warning('Invalid store URL "', $storeUrl, '" in remembered account.');
14231 0           my $accountToken = CDS::AccountToken->new($store, $actorHash);
14232 0 0         return $o->warning('"', $o->{text}, '" is interpreted as a keyword. If you mean the account, write "', $accountToken->url, '".') if $o->isKeyword;
14233 0           return $accountToken;
14234             }
14235              
14236             # From a URL
14237 0 0         if ($o->{text} =~ /^\s*(.*?)\/accounts\/([0-9a-fA-F]{64,64})\/*\s*$/) {
14238 0           my $storeUrl = $1;
14239 0           my $actorHash = CDS::Hash->fromHex($2);
14240 0 0 0       $storeUrl = 'file://'.Cwd::abs_path($storeUrl) if $storeUrl !~ /^[a-zA-Z0-9_\+-]*:/ && -d $storeUrl;
14241 0   0       my $cliStore = $o->{actor}->storeForUrl($storeUrl) // return $o->warning('Invalid store URL "', $storeUrl, '".');
14242 0           return CDS::AccountToken->new($cliStore, $actorHash);
14243             }
14244              
14245 0           return;
14246             }
14247              
14248             sub completeAccount {
14249 0     0     my $o = shift;
14250              
14251 0           $o->completeUrl;
14252              
14253 0           my $records = $o->{actor}->rememberedRecords;
14254 0           for my $label (keys %$records) {
14255 0           my $record = $records->{$label};
14256 0           my $storeUrl = $record->child('store')->textValue;
14257 0 0         next if ! length $storeUrl;
14258 0   0       my $actorHash = CDS::Hash->fromBytes($record->child('actor')->bytesValue) // next;
14259              
14260 0           $o->addPossibility($label);
14261 0           $o->addPossibility($storeUrl.'/accounts/'.$actorHash->hex);
14262             }
14263              
14264 0           return;
14265             }
14266              
14267             sub aesKey {
14268 0     0     my $o = shift;
14269              
14270 0 0         $o->{text} =~ /^[0-9A-Fa-f]{64}$/ || return;
14271 0           return pack('H*', $o->{text});
14272             }
14273              
14274             sub box {
14275 0     0     my $o = shift;
14276              
14277             # From a URL
14278 0 0         if ($o->{text} =~ /^\s*(.*?)\/accounts\/([0-9a-fA-F]{64,64})\/(messages|private|public)\/*\s*$/) {
14279 0           my $storeUrl = $1;
14280 0           my $boxLabel = $3;
14281 0           my $actorHash = CDS::Hash->fromHex($2);
14282 0 0 0       $storeUrl = 'file://'.Cwd::abs_path($storeUrl) if $storeUrl !~ /^[a-zA-Z0-9_\+-]*:/ && -d $storeUrl;
14283 0   0       my $cliStore = $o->{actor}->storeForUrl($storeUrl) // return $o->warning('Invalid store URL "', $storeUrl, '".');
14284 0           my $accountToken = CDS::AccountToken->new($cliStore, $actorHash);
14285 0           return CDS::BoxToken->new($accountToken, $boxLabel);
14286             }
14287              
14288 0           return;
14289             }
14290              
14291             sub completeBox {
14292 0     0     my $o = shift;
14293              
14294 0           $o->completeUrl;
14295 0           return;
14296             }
14297              
14298             sub boxLabel {
14299 0     0     my $o = shift;
14300              
14301 0 0         return $o->{text} if $o->{text} eq 'messages';
14302 0 0         return $o->{text} if $o->{text} eq 'private';
14303 0 0         return $o->{text} if $o->{text} eq 'public';
14304 0           return;
14305             }
14306              
14307             sub completeBoxLabel {
14308 0     0     my $o = shift;
14309              
14310 0           $o->addPossibility('messages');
14311 0           $o->addPossibility('private');
14312 0           $o->addPossibility('public');
14313             }
14314              
14315             sub file {
14316 0     0     my $o = shift;
14317              
14318 0   0       my $file = Cwd::abs_path($o->{text}) // return;
14319 0 0         return if ! -f $file;
14320 0 0         return $o->warning('"', $o->{text}, '" is interpreted as keyword. If you mean the file, write "./', $o->{text}, '".') if $o->isKeyword;
14321 0           return $file;
14322             }
14323              
14324             sub completeFile {
14325 0     0     my $o = shift;
14326              
14327 0           my $folder = './';
14328 0           my $startFilename = $o->{text};
14329 0 0         $startFilename = $ENV{HOME}.'/'.$1 if $startFilename =~ /^~\/(.*)$/;
14330 0 0         if ($startFilename eq '~') {
    0          
14331 0           $folder = $ENV{HOME}.'/';
14332 0           $startFilename = '';
14333             } elsif ($startFilename =~ /^(.*\/)([^\/]*)$/) {
14334 0           $folder = $1;
14335 0           $startFilename = $2;
14336             }
14337              
14338 0           for my $filename (CDS->listFolder($folder)) {
14339 0 0         next if $filename eq '.';
14340 0 0         next if $filename eq '..';
14341 0 0         next if substr($filename, 0, length $startFilename) ne $startFilename;
14342 0           my $file = $folder.$filename;
14343 0 0         $file .= '/' if -d $file;
14344 0 0         $file .= ' ' if -f $file;
14345 0           push @{$o->{possibilities}}, $file;
  0            
14346             }
14347             }
14348              
14349             sub filename {
14350 0     0     my $o = shift;
14351              
14352 0 0         return $o->warning('"', $o->{text}, '" is interpreted as keyword. If you mean the file, write "./', $o->{text}, '".') if $o->isKeyword;
14353 0           return Cwd::abs_path($o->{text});
14354             }
14355              
14356             sub folder {
14357 0     0     my $o = shift;
14358              
14359 0   0       my $folder = Cwd::abs_path($o->{text}) // return;
14360 0 0         return if ! -d $folder;
14361 0 0         return $o->warning('"', $o->{text}, '" is interpreted as keyword. If you mean the folder, write "./', $o->{text}, '".') if $o->isKeyword;
14362 0           return $folder;
14363             }
14364              
14365             sub completeFolder {
14366 0     0     my $o = shift;
14367              
14368 0           my $folder = './';
14369 0           my $startFilename = $o->{text};
14370 0 0         if ($o->{text} =~ /^(.*\/)([^\/]*)$/) {
14371 0           $folder = $1;
14372 0           $startFilename = $2;
14373             }
14374              
14375 0           for my $filename (CDS->listFolder($folder)) {
14376 0 0         next if $filename eq '.';
14377 0 0         next if $filename eq '..';
14378 0 0         next if substr($filename, 0, length $startFilename) ne $startFilename;
14379 0           my $file = $folder.$filename;
14380 0 0         next if ! -d $file;
14381 0           push @{$o->{possibilities}}, $file.'/';
  0            
14382             }
14383             }
14384              
14385             sub foldername {
14386 0     0     my $o = shift;
14387              
14388 0 0         return $o->warning('"', $o->{text}, '" is interpreted as keyword. If you mean the folder, write "./', $o->{text}, '".') if $o->isKeyword;
14389 0           return Cwd::abs_path($o->{text});
14390             }
14391              
14392             sub group {
14393 0     0     my $o = shift;
14394              
14395 0 0         return int($1) if $o->{text} =~ /^\s*(\d{1,5})\s*$/;
14396 0           return getgrnam($o->{text});
14397             }
14398              
14399             sub completeGroup {
14400 0     0     my $o = shift;
14401              
14402 0           while (my $name = getgrent) {
14403 0           $o->addPossibility($name);
14404             }
14405             }
14406              
14407             sub hash {
14408 0     0     my $o = shift;
14409              
14410 0           my $hash = CDS::Hash->fromHex($o->{text});
14411 0 0         return $hash if $hash;
14412              
14413             # Check if it's a remembered actor hash
14414 0           my $record = $o->{actor}->remembered($o->{text});
14415 0   0       my $actorHash = CDS::Hash->fromBytes($record->child('actor')->bytesValue) // return;
14416 0 0         return $o->warning('"', $o->{text}, '" is interpreted as keyword. If you mean the actor, write "', $actorHash->hex, '".') if $o->isKeyword;
14417 0           return $actorHash;
14418             }
14419              
14420             sub completeHash {
14421 0     0     my $o = shift;
14422              
14423 0           my $records = $o->{actor}->rememberedRecords;
14424 0           for my $label (keys %$records) {
14425 0           my $record = $records->{$label};
14426 0   0       my $hash = CDS::Hash->fromBytes($record->child('actor')->bytesValue) // next;
14427 0           $o->addPossibility($label);
14428 0           $o->addPossibility($hash->hex);
14429             }
14430              
14431 0           for my $child ($o->{actor}->actorGroupSelector->children) {
14432 0   0       my $hash = $child->record->child('hash')->hashValue // next;
14433 0           $o->addPossibility($hash->hex);
14434             }
14435             }
14436              
14437             sub keyPair {
14438 0     0     my $o = shift;
14439              
14440             # Remembered key pair
14441 0           my $record = $o->{actor}->remembered($o->{text});
14442 0           my $file = $record->child('key pair')->textValue;
14443              
14444             # Key pair from file
14445 0 0         if (! length $file) {
14446 0   0       $file = Cwd::abs_path($o->{text}) // return;
14447 0 0 0       return $o->warning('"', $o->{text}, '" is interpreted as keyword. If you mean the file, write "./', $o->{text}, '".') if $o->isKeyword && -f $file;
14448             }
14449              
14450             # Load the key pair
14451 0 0         return if ! -f $file;
14452 0   0       my $bytes = CDS->readBytesFromFile($file) // return $o->warning('The key pair file "', $file, '" could not be read.');
14453 0   0       my $keyPair = CDS::KeyPair->fromRecord(CDS::Record->fromObject(CDS::Object->fromBytes($bytes))) // return $o->warning('The file "', $file, '" does not contain a key pair.');
14454 0           return CDS::KeyPairToken->new($file, $keyPair);
14455             }
14456              
14457             sub completeKeyPair {
14458 0     0     my $o = shift;
14459              
14460 0           $o->completeFile;
14461              
14462 0           my $records = $o->{actor}->rememberedRecords;
14463 0           for my $label (keys %$records) {
14464 0           my $record = $records->{$label};
14465 0 0         next if ! length $record->child('key pair')->textValue;
14466 0           $o->addPossibility($label);
14467             }
14468             }
14469              
14470             sub label {
14471 0     0     my $o = shift;
14472              
14473 0           my $records = $o->{actor}->remembered($o->{text});
14474 0 0         return $o->{text} if $records->children;
14475 0           return;
14476             }
14477              
14478             sub completeLabel {
14479 0     0     my $o = shift;
14480              
14481 0           my $records = $o->{actor}->rememberedRecords;
14482 0           for my $label (keys %$records) {
14483 0 0         next if substr($label, 0, length $o->{text}) ne $o->{text};
14484 0           $o->addPossibility($label);
14485             }
14486             }
14487              
14488             sub object {
14489 0     0     my $o = shift;
14490              
14491             # Folder stores use the first two hex digits as folder
14492 0 0         my $url = $o->{text} =~ /^\s*(.*?\/objects\/)([0-9a-fA-F]{2,2})\/([0-9a-fA-F]{62,62})\/*\s*$/ ? $1.$2.$3 : $o->{text};
14493              
14494             # From a URL
14495 0 0         if ($url =~ /^\s*(.*?)\/objects\/([0-9a-fA-F]{64,64})\/*\s*$/) {
14496 0           my $storeUrl = $1;
14497 0           my $hash = CDS::Hash->fromHex($2);
14498 0 0 0       $storeUrl = 'file://'.Cwd::abs_path($storeUrl) if $storeUrl !~ /^[a-zA-Z0-9_\+-]*:/ && -d $storeUrl;
14499 0   0       my $cliStore = $o->{actor}->storeForUrl($storeUrl) // return $o->warning('Invalid store URL "', $storeUrl, '".');
14500 0           return CDS::ObjectToken->new($cliStore, $hash);
14501             }
14502              
14503 0           return;
14504             }
14505              
14506             sub completeObject {
14507 0     0     my $o = shift;
14508              
14509 0           $o->completeUrl;
14510 0           return;
14511             }
14512              
14513             sub objectFile {
14514 0     0     my $o = shift;
14515              
14516             # Key pair from file
14517 0   0       my $file = Cwd::abs_path($o->{text}) // return;
14518 0 0 0       return $o->warning('"', $o->{text}, '" is interpreted as keyword. If you mean the file, write "./', $o->{text}, '".') if $o->isKeyword && -f $file;
14519              
14520             # Load the object
14521 0 0         return if ! -f $file;
14522 0   0       my $bytes = CDS->readBytesFromFile($file) // return $o->warning('The object file "', $file, '" could not be read.');
14523 0   0       my $object = CDS::Object->fromBytes($bytes) // return $o->warning('The file "', $file, '" does not contain a Condensation object.');
14524 0           return CDS::ObjectFileToken->new($file, $object);
14525             }
14526              
14527             sub completeObjectFile {
14528 0     0     my $o = shift;
14529              
14530 0           $o->completeFile;
14531 0           return;
14532             }
14533              
14534             sub actorGroup {
14535 0     0     my $o = shift;
14536              
14537             # We only accept named actor groups. Accepting a single account as actor group is ambiguous whenever ACCOUNT and ACTORGROUP are accepted. For commands that are requiring an ACTORGROUP, they can also accept an ACCOUNT and then convert it.
14538              
14539             # Check if it's an actor group label
14540 0           my $record = $o->{actor}->remembered($o->{text})->child('actor group');
14541 0 0         return if ! scalar $record->children;
14542 0 0         return $o->warning('"', $o->{text}, '" is interpreted as keyword. To refer to the actor group, rename it.') if $o->isKeyword;
14543              
14544 0           my $builder = CDS::ActorGroupBuilder->new;
14545 0           $builder->addKnownPublicKey($o->{actor}->keyPair->publicKey);
14546 0           $builder->parse($record, 1);
14547 0           my ($actorGroup, $storeError) = $builder->load($o->{actor}->groupDocument->unsaved, $o->{actor}->keyPair, $o);
14548 0 0         return $o->{actor}->storeError($o->{actor}->storageStore, $storeError) if defined $storeError;
14549 0           return CDS::ActorGroupToken->new($o->{text}, $actorGroup);
14550             }
14551              
14552             sub onLoadActorGroupVerifyStore {
14553 0     0     my $o = shift;
14554 0           my $storeUrl = shift;
14555 0           $o->{actor}->storeForUrl($storeUrl); }
14556              
14557             sub completeActorGroup {
14558 0     0     my $o = shift;
14559              
14560 0           my $records = $o->{actor}->rememberedRecords;
14561 0           for my $label (keys %$records) {
14562 0           my $record = $records->{$label};
14563 0 0         next if ! scalar $record->child('actor group')->children;
14564 0           $o->addPossibility($label);
14565             }
14566 0           return;
14567             }
14568              
14569             sub port {
14570 0     0     my $o = shift;
14571              
14572 0           my $port = int($o->{text});
14573 0 0 0       return if $port <= 0 || $port > 65536;
14574 0           return $port;
14575             }
14576              
14577             sub rememberedStoreUrl {
14578 0     0     my $o = shift;
14579              
14580 0           my $record = $o->{actor}->remembered($o->{text});
14581 0           my $storeUrl = $record->child('store')->textValue;
14582 0 0         return if ! length $storeUrl;
14583              
14584 0 0         return $o->warning('"', $o->{text}, '" is interpreted as keyword. If you mean the store, write "', $storeUrl, '".') if $o->isKeyword;
14585 0           return $storeUrl;
14586             }
14587              
14588             sub directStoreUrl {
14589 0     0     my $o = shift;
14590              
14591 0 0         return $o->warning('"', $o->{text}, '" is interpreted as keyword. If you mean the folder store, write "./', $o->{text}, '".') if $o->isKeyword;
14592 0 0         return if $o->{text} =~ /[0-9a-f]{32}/;
14593              
14594 0 0         return $o->{text} if $o->{text} =~ /^[a-zA-Z0-9_\+-]*:/;
14595 0 0 0       return 'file://'.Cwd::abs_path($o->{text}) if -d $o->{text} && -d $o->{text}.'/accounts' && -d $o->{text}.'/objects';
      0        
14596 0           return;
14597             }
14598              
14599             sub store {
14600 0     0     my $o = shift;
14601              
14602 0   0       my $url = $o->rememberedStoreUrl // $o->directStoreUrl // return;
      0        
14603 0   0       return $o->{actor}->storeForUrl($url) // return $o->warning('"', $o->{text}, '" looks like a store, but no implementation is available to handle this protocol.');
14604             }
14605              
14606             sub completeFolderStoreUrl {
14607 0     0     my $o = shift;
14608              
14609 0           my $folder = './';
14610 0           my $startFilename = $o->{text};
14611 0 0         if ($o->{text} =~ /^(.*\/)([^\/]*)$/) {
14612 0           $folder = $1;
14613 0           $startFilename = $2;
14614             }
14615              
14616 0           for my $filename (CDS->listFolder($folder)) {
14617 0 0         next if $filename eq '.';
14618 0 0         next if $filename eq '..';
14619 0 0         next if substr($filename, 0, length $startFilename) ne $startFilename;
14620 0           my $file = $folder.$filename;
14621 0 0         next if ! -d $file;
14622 0 0 0       push @{$o->{possibilities}}, $file . (-d $file.'/accounts' && -d $file.'/objects' ? ' ' : '/');
  0            
14623             }
14624             }
14625              
14626             sub completeStoreUrl {
14627 0     0     my $o = shift;
14628              
14629 0           $o->completeFolderStoreUrl;
14630 0           $o->completeUrl;
14631              
14632 0           my $records = $o->{actor}->rememberedRecords;
14633 0           for my $label (keys %$records) {
14634 0           my $record = $records->{$label};
14635 0 0         next if length $record->child('actor')->bytesValue;
14636 0           my $storeUrl = $record->child('store')->textValue;
14637 0 0         next if ! length $storeUrl;
14638 0           $o->addPossibility($label);
14639 0           $o->addPossibility($storeUrl);
14640             }
14641             }
14642              
14643             sub completeUrl {
14644 0     0     my $o = shift;
14645              
14646 0           $o->addPartialPossibility('http://');
14647 0           $o->addPartialPossibility('https://');
14648 0           $o->addPartialPossibility('ftp://');
14649 0           $o->addPartialPossibility('sftp://');
14650 0           $o->addPartialPossibility('file://');
14651             }
14652              
14653             sub text {
14654 0     0     my $o = shift;
14655              
14656 0           return $o->{text};
14657             }
14658              
14659             sub user {
14660 0     0     my $o = shift;
14661              
14662 0 0         return int($1) if $o->{text} =~ /^\s*(\d{1,5})\s*$/;
14663 0           return getpwnam($o->{text});
14664             }
14665              
14666             sub completeUser {
14667 0     0     my $o = shift;
14668              
14669 0           while (my $name = getpwent) {
14670 0           $o->addPossibility($name);
14671             }
14672             }
14673              
14674             sub warning {
14675 0     0     my $o = shift;
14676              
14677 0           push @{$o->{warnings}}, join('', @_);
  0            
14678 0           return;
14679             }
14680              
14681             # Reads the private box of an actor.
14682             package CDS::PrivateBoxReader;
14683              
14684             sub new {
14685 0     0     my $class = shift;
14686 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
14687 0           my $store = shift;
14688 0           my $delegate = shift;
14689              
14690 0           return bless {
14691             keyPair => $keyPair,
14692             actorOnStore => CDS::ActorOnStore->new($keyPair->publicKey, $store),
14693             delegate => $delegate,
14694             entries => {},
14695             };
14696             }
14697              
14698 0     0     sub keyPair { shift->{keyPair} }
14699 0     0     sub actorOnStore { shift->{actorOnStore} }
14700 0     0     sub delegate { shift->{delegate} }
14701              
14702             sub read {
14703 0     0     my $o = shift;
14704              
14705 0           my $store = $o->{actorOnStore}->store;
14706 0           my ($hashes, $listError) = $store->list($o->{actorOnStore}->publicKey->hash, 'private', 0, $o->{keyPair});
14707 0 0         return if defined $listError;
14708              
14709             # Keep track of the processed entries
14710 0           my $newEntries = {};
14711 0           for my $hash (@$hashes) {
14712 0   0       $newEntries->{$hash->bytes} = $o->{entries}->{$hash->bytes} // {hash => $hash, processed => 0};
14713             }
14714 0           $o->{entries} = $newEntries;
14715              
14716             # Process new entries
14717 0           for my $entry (values %$newEntries) {
14718 0 0         next if $entry->{processed};
14719              
14720             # Get the envelope
14721 0           my ($object, $getError) = $store->get($entry->{hash}, $o->{keyPair});
14722 0 0         return if defined $getError;
14723              
14724 0 0         if (! defined $object) {
14725 0           $o->invalid($entry, 'Envelope object not found.');
14726 0           next;
14727             }
14728              
14729             # Parse the record
14730 0           my $envelope = CDS::Record->fromObject($object);
14731 0 0         if (! $envelope) {
14732 0           $o->invalid($entry, 'Envelope is not a record.');
14733 0           next;
14734             }
14735              
14736             # Read the content hash
14737 0           my $contentHash = $envelope->child('content')->hashValue;
14738 0 0         if (! $contentHash) {
14739 0           $o->invalid($entry, 'Missing content hash.');
14740 0           next;
14741             }
14742              
14743             # Verify the signature
14744 0 0         if (! CDS->verifyEnvelopeSignature($envelope, $o->{keyPair}->publicKey, $contentHash)) {
14745 0           $o->invalid($entry, 'Invalid signature.');
14746 0           next;
14747             }
14748              
14749             # Decrypt the key
14750 0           my $aesKey = $o->{keyPair}->decryptKeyOnEnvelope($envelope);
14751 0 0         if (! $aesKey) {
14752 0           $o->invalid($entry, 'Not encrypted for us.');
14753 0           next;
14754             }
14755              
14756             # Retrieve the content
14757 0           my $contentHashAndKey = CDS::HashAndKey->new($contentHash, $aesKey);
14758 0           my ($contentRecord, $contentObject, $contentInvalidReason, $contentStoreError) = $o->{keyPair}->getAndDecryptRecord($contentHashAndKey, $store);
14759 0 0         return if defined $contentStoreError;
14760              
14761 0 0         if (defined $contentInvalidReason) {
14762 0           $o->invalid($entry, $contentInvalidReason);
14763 0           next;
14764             }
14765              
14766 0           $entry->{processed} = 1;
14767 0           my $source = CDS::Source->new($o->{keyPair}, $o->{actorOnStore}, 'private', $entry->{hash});
14768 0           $o->{delegate}->onPrivateBoxEntry($source, $envelope, $contentHashAndKey, $contentRecord);
14769             }
14770              
14771 0           return 1;
14772             }
14773              
14774             sub invalid {
14775 0     0     my $o = shift;
14776 0           my $entry = shift;
14777 0           my $reason = shift;
14778              
14779 0           $entry->{processed} = 1;
14780 0           my $source = CDS::Source->new($o->{actorOnStore}, 'private', $entry->{hash});
14781 0           $o->{delegate}->onPrivateBoxInvalidEntry($source, $reason);
14782             }
14783              
14784             # Delegate
14785             # onPrivateBoxEntry($source, $envelope, $contentHashAndKey, $contentRecord)
14786             # onPrivateBoxInvalidEntry($source, $reason)
14787              
14788             package CDS::PrivateRoot;
14789              
14790             sub new {
14791 0     0     my $class = shift;
14792 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
14793 0           my $store = shift;
14794 0           my $delegate = shift;
14795              
14796 0           my $o = bless {
14797             unsaved => CDS::Unsaved->new($store),
14798             delegate => $delegate,
14799             dataHandlers => {},
14800             hasChanges => 0,
14801             procured => 0,
14802             mergedEntries => [],
14803             };
14804              
14805 0           $o->{privateBoxReader} = CDS::PrivateBoxReader->new($keyPair, $store, $o);
14806 0           return $o;
14807             }
14808              
14809 0     0     sub delegate { shift->{delegate} }
14810 0     0     sub privateBoxReader { shift->{privateBoxReader} }
14811 0     0     sub unsaved { shift->{unsaved} }
14812 0     0     sub hasChanges { shift->{hasChanges} }
14813 0     0     sub procured { shift->{procured} }
14814              
14815             sub addDataHandler {
14816 0     0     my $o = shift;
14817 0           my $label = shift;
14818 0           my $dataHandler = shift;
14819              
14820 0           $o->{dataHandlers}->{$label} = $dataHandler;
14821             }
14822              
14823             sub removeDataHandler {
14824 0     0     my $o = shift;
14825 0           my $label = shift;
14826 0           my $dataHandler = shift;
14827              
14828 0           my $registered = $o->{dataHandlers}->{$label};
14829 0 0         return if $registered != $dataHandler;
14830 0           delete $o->{dataHandlers}->{$label};
14831             }
14832              
14833             # *** Procurement
14834              
14835             sub procure {
14836 0     0     my $o = shift;
14837 0           my $interval = shift;
14838              
14839 0           my $now = CDS->now;
14840 0 0         return $o->{procured} if $o->{procured} + $interval > $now;
14841 0   0       $o->{privateBoxReader}->read // return;
14842 0           $o->{procured} = $now;
14843 0           return $now;
14844             }
14845              
14846             # *** Merging
14847              
14848             sub onPrivateBoxEntry {
14849 0     0     my $o = shift;
14850 0 0 0       my $source = shift; die 'wrong type '.ref($source).' for $source' if defined $source && ref $source ne 'CDS::Source';
  0            
14851 0 0 0       my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0            
14852 0           my $contentHashAndKey = shift;
14853 0           my $content = shift;
14854              
14855 0           for my $section ($content->children) {
14856 0   0       my $dataHandler = $o->{dataHandlers}->{$section->bytes} // next;
14857 0           $dataHandler->mergeData($section);
14858             }
14859              
14860 0           push @{$o->{mergedEntries}}, $source->hash;
  0            
14861             }
14862              
14863             sub onPrivateBoxInvalidEntry {
14864 0     0     my $o = shift;
14865 0 0 0       my $source = shift; die 'wrong type '.ref($source).' for $source' if defined $source && ref $source ne 'CDS::Source';
  0            
14866 0           my $reason = shift;
14867              
14868 0           $o->{delegate}->onPrivateRootReadingInvalidEntry($source, $reason);
14869 0           $source->discard;
14870             }
14871              
14872             # *** Saving
14873              
14874             sub dataChanged {
14875 0     0     my $o = shift;
14876              
14877 0           $o->{hasChanges} = 1;
14878             }
14879              
14880             sub save {
14881 0     0     my $o = shift;
14882 0           my $entrustedKeys = shift;
14883              
14884 0           $o->{unsaved}->startSaving;
14885 0 0         return $o->savingSucceeded if ! $o->{hasChanges};
14886 0           $o->{hasChanges} = 0;
14887              
14888             # Create the record
14889 0           my $record = CDS::Record->new;
14890 0           $record->add('created')->addInteger(CDS->now);
14891 0           $record->add('client')->add(CDS->version);
14892 0           for my $label (keys %{$o->{dataHandlers}}) {
  0            
14893 0           my $dataHandler = $o->{dataHandlers}->{$label};
14894 0           $dataHandler->addDataTo($record->add($label));
14895             }
14896              
14897             # Submit the object
14898 0           my $key = CDS->randomKey;
14899 0           my $object = $record->toObject->crypt($key);
14900 0           my $hash = $object->calculateHash;
14901 0           $o->{unsaved}->savingState->addObject($hash, $object);
14902 0           my $hashAndKey = CDS::HashAndKey->new($hash, $key);
14903              
14904             # Create the envelope
14905 0           my $keyPair = $o->{privateBoxReader}->keyPair;
14906 0           my $publicKeys = [$keyPair->publicKey, @$entrustedKeys];
14907 0           my $envelopeObject = $keyPair->createPrivateEnvelope($hashAndKey, $publicKeys)->toObject;
14908 0           my $envelopeHash = $envelopeObject->calculateHash;
14909 0           $o->{unsaved}->savingState->addObject($envelopeHash, $envelopeObject);
14910              
14911             # Transfer
14912 0           my ($missing, $store, $storeError) = $keyPair->transfer([$hash], $o->{unsaved}, $o->{privateBoxReader}->actorOnStore->store);
14913 0 0 0       return $o->savingFailed($missing) if defined $missing || defined $storeError;
14914              
14915             # Modify the private box
14916 0           my $modifications = CDS::StoreModifications->new;
14917 0           $modifications->add($keyPair->publicKey->hash, 'private', $envelopeHash, $envelopeObject);
14918 0           for my $hash (@{$o->{mergedEntries}}) {
  0            
14919 0           $modifications->remove($keyPair->publicKey->hash, 'private', $hash);
14920             }
14921              
14922 0           my $modifyError = $o->{privateBoxReader}->actorOnStore->store->modify($modifications, $keyPair);
14923 0 0         return $o->savingFailed if defined $modifyError;
14924              
14925             # Set the new merged hashes
14926 0           $o->{mergedEntries} = [$envelopeHash];
14927 0           return $o->savingSucceeded;
14928             }
14929              
14930             sub savingSucceeded {
14931 0     0     my $o = shift;
14932              
14933             # Discard all merged sources
14934 0           for my $source ($o->{unsaved}->savingState->mergedSources) {
14935 0           $source->discard;
14936             }
14937              
14938             # Call all data saved handlers
14939 0           for my $handler ($o->{unsaved}->savingState->dataSavedHandlers) {
14940 0           $handler->onDataSaved;
14941             }
14942              
14943 0           $o->{unsaved}->savingDone;
14944 0           return 1;
14945             }
14946              
14947             sub savingFailed {
14948 0     0     my $o = shift;
14949 0           my $missing = shift;
14950             # private
14951 0           $o->{unsaved}->savingFailed;
14952 0           $o->{hasChanges} = 1;
14953 0           return undef, $missing;
14954             }
14955              
14956             # A public key of somebody.
14957             package CDS::PublicKey;
14958              
14959             sub fromObject {
14960 0     0     my $class = shift;
14961 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
14962              
14963 0   0       my $record = CDS::Record->fromObject($object) // return;
14964 0   0       my $rsaPublicKey = CDS::C::publicKeyNew($record->child('e')->bytesValue, $record->child('n')->bytesValue) // return;
14965 0           return bless {
14966             hash => $object->calculateHash,
14967             rsaPublicKey => $rsaPublicKey,
14968             object => $object,
14969             lastAccess => 0, # used by PublicKeyCache
14970             };
14971             }
14972              
14973 0     0     sub object { shift->{object} }
14974             sub bytes {
14975 0     0     my $o = shift;
14976 0           $o->{object}->bytes }
14977              
14978             ### Public key interface ###
14979              
14980 0     0     sub hash { shift->{hash} }
14981             sub encrypt {
14982 0     0     my $o = shift;
14983 0           my $bytes = shift;
14984 0           CDS::C::publicKeyEncrypt($o->{rsaPublicKey}, $bytes) }
14985             sub verifyHash {
14986 0     0     my $o = shift;
14987 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
14988 0           my $signature = shift;
14989 0           CDS::C::publicKeyVerify($o->{rsaPublicKey}, $hash->bytes, $signature) }
14990              
14991             package CDS::PublicKeyCache;
14992              
14993             sub new {
14994 0     0     my $class = shift;
14995 0           my $maxSize = shift;
14996              
14997 0           return bless {
14998             cache => {},
14999             maxSize => $maxSize,
15000             };
15001             }
15002              
15003             sub add {
15004 0     0     my $o = shift;
15005 0 0 0       my $publicKey = shift; die 'wrong type '.ref($publicKey).' for $publicKey' if defined $publicKey && ref $publicKey ne 'CDS::PublicKey';
  0            
15006              
15007 0           $o->{cache}->{$publicKey->hash->bytes} = {publicKey => $publicKey, lastAccess => CDS->now};
15008 0           $o->deleteOldest;
15009 0           return;
15010             }
15011              
15012             sub get {
15013 0     0     my $o = shift;
15014 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15015              
15016 0   0       my $entry = $o->{cache}->{$hash->bytes} // return;
15017 0           $entry->{lastAccess} = CDS->now;
15018 0           return $entry->{publicKey};
15019             }
15020              
15021             sub deleteOldest {
15022 0     0     my $o = shift;
15023             # private
15024 0 0         return if scalar values %{$o->{cache}} < $o->{maxSize};
  0            
15025              
15026 0           my @entries = sort { $a->{lastAccess} <=> $b->{lastAccess} } values %{$o->{cache}};
  0            
  0            
15027 0           my $toRemove = int(scalar(@entries) - $o->{maxSize} / 2);
15028 0           for my $entry (@entries) {
15029 0           $toRemove -= 1;
15030 0 0         last if $toRemove <= 0;
15031 0           delete $o->{cache}->{$entry->{publicKey}->hash->bytes};
15032             }
15033             }
15034              
15035             package CDS::PutTree;
15036              
15037             sub new {
15038 0     0     my $o = shift;
15039 0           my $store = shift;
15040 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
15041 0           my $commitPool = shift;
15042              
15043 0           return bless {
15044             store => $store,
15045             commitPool => $commitPool,
15046             keyPair => $keyPair,
15047             done => {},
15048             };
15049             }
15050              
15051             sub put {
15052 0     0     my $o = shift;
15053 0 0 0       my $hash = shift // return; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0   0        
15054              
15055 0 0         return if $o->{done}->{$hash->bytes};
15056              
15057             # Get the item
15058 0   0       my $hashAndObject = $o->{commitPool}->object($hash) // return;
15059              
15060             # Upload all children
15061 0           for my $hash ($hashAndObject->object->hashes) {
15062 0           my $error = $o->put($hash);
15063 0 0         return $error if defined $error;
15064             }
15065              
15066             # Upload this object
15067 0           my $error = $o->{store}->put($hashAndObject->hash, $hashAndObject->object, $o->{keyPair});
15068 0 0         return $error if defined $error;
15069 0           $o->{done}->{$hash->bytes} = 1;
15070 0           return;
15071             }
15072              
15073             package CDS::ReceivedMessage;
15074              
15075             sub new {
15076 0     0     my $class = shift;
15077 0           my $messageBoxReader = shift;
15078 0           my $entry = shift;
15079 0 0 0       my $source = shift; die 'wrong type '.ref($source).' for $source' if defined $source && ref $source ne 'CDS::Source';
  0            
15080 0 0 0       my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0            
15081 0           my $senderStoreUrl = shift;
15082 0           my $sender = shift;
15083 0           my $content = shift;
15084 0           my $streamHead = shift;
15085              
15086 0           return bless {
15087             messageBoxReader => $messageBoxReader,
15088             entry => $entry,
15089             source => $source,
15090             envelope => $envelope,
15091             senderStoreUrl => $senderStoreUrl,
15092             sender => $sender,
15093             content => $content,
15094             streamHead => $streamHead,
15095             isDone => 0,
15096             };
15097             }
15098              
15099 0     0     sub source { shift->{source} }
15100 0     0     sub envelope { shift->{envelope} }
15101 0     0     sub senderStoreUrl { shift->{senderStoreUrl} }
15102 0     0     sub sender { shift->{sender} }
15103 0     0     sub content { shift->{content} }
15104              
15105             sub waitForSenderStore {
15106 0     0     my $o = shift;
15107              
15108 0           $o->{entry}->{waitingForStore} = $o->sender->store;
15109             }
15110              
15111             sub skip {
15112 0     0     my $o = shift;
15113              
15114 0           $o->{entry}->{processed} = 0;
15115             }
15116              
15117             # A record is a tree, whereby each nodes holds a byte sequence and an optional hash.
15118             # Child nodes are ordered, although the order does not always matter.
15119             package CDS::Record;
15120              
15121             sub fromObject {
15122 0     0     my $class = shift;
15123 0 0 0       my $object = shift // return; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0   0        
15124              
15125 0           my $root = CDS::Record->new;
15126 0   0       $root->addFromObject($object) // return;
15127 0           return $root;
15128             }
15129              
15130             sub new {
15131 0     0     my $class = shift;
15132 0           my $bytes = shift;
15133 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15134              
15135 0   0       bless {
15136             bytes => $bytes // '',
15137             hash => $hash,
15138             children => [],
15139             };
15140             }
15141              
15142             # *** Adding
15143              
15144             # Adds a record
15145             sub add {
15146 0     0     my $o = shift;
15147 0           my $bytes = shift;
15148 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15149              
15150 0           my $record = CDS::Record->new($bytes, $hash);
15151 0           push @{$o->{children}}, $record;
  0            
15152 0           return $record;
15153             }
15154              
15155             sub addText {
15156 0     0     my $o = shift;
15157 0           my $value = shift;
15158 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15159 0   0       $o->add(Encode::encode_utf8($value // ''), $hash) }
15160             sub addBoolean {
15161 0     0     my $o = shift;
15162 0           my $value = shift;
15163 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15164 0           $o->add(CDS->bytesFromBoolean($value), $hash) }
15165             sub addInteger {
15166 0     0     my $o = shift;
15167 0           my $value = shift;
15168 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15169 0   0       $o->add(CDS->bytesFromInteger($value // 0), $hash) }
15170             sub addUnsigned {
15171 0     0     my $o = shift;
15172 0           my $value = shift;
15173 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15174 0   0       $o->add(CDS->bytesFromUnsigned($value // 0), $hash) }
15175             sub addFloat32 {
15176 0     0     my $o = shift;
15177 0           my $value = shift;
15178 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15179 0   0       $o->add(CDS->bytesFromFloat32($value // 0), $hash) }
15180             sub addFloat64 {
15181 0     0     my $o = shift;
15182 0           my $value = shift;
15183 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15184 0   0       $o->add(CDS->bytesFromFloat64($value // 0), $hash) }
15185             sub addHash {
15186 0     0     my $o = shift;
15187 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15188 0           $o->add('', $hash) }
15189             sub addHashAndKey {
15190 0     0     my $o = shift;
15191 0 0 0       my $hashAndKey = shift; die 'wrong type '.ref($hashAndKey).' for $hashAndKey' if defined $hashAndKey && ref $hashAndKey ne 'CDS::HashAndKey';
  0            
15192 0 0         $hashAndKey ? $o->add($hashAndKey->key, $hashAndKey->hash) : $o->add('') }
15193             sub addRecord {
15194 0     0     my $o = shift;
15195 0           push @{$o->{children}}, @_; return; }
  0            
  0            
15196              
15197             sub addFromObject {
15198 0     0     my $o = shift;
15199 0 0 0       my $object = shift // return; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0   0        
15200              
15201 0 0         return 1 if ! length $object->data;
15202 0           return CDS::RecordReader->new($object)->readChildren($o);
15203             }
15204              
15205             # *** Set value
15206              
15207             sub set {
15208 0     0     my $o = shift;
15209 0           my $bytes = shift;
15210 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15211              
15212 0           $o->{bytes} = $bytes;
15213 0           $o->{hash} = $hash;
15214 0           return;
15215             }
15216              
15217             # *** Querying
15218              
15219             # Returns true if the record contains a child with the indicated bytes.
15220             sub contains {
15221 0     0     my $o = shift;
15222 0           my $bytes = shift;
15223              
15224 0           for my $child (@{$o->{children}}) {
  0            
15225 0 0         return 1 if $child->{bytes} eq $bytes;
15226             }
15227 0           return;
15228             }
15229              
15230             # Returns the child record for the given bytes. If no record with these bytes exists, a record with these bytes is returned (but not added).
15231             sub child {
15232 0     0     my $o = shift;
15233 0           my $bytes = shift;
15234              
15235 0           for my $child (@{$o->{children}}) {
  0            
15236 0 0         return $child if $child->{bytes} eq $bytes;
15237             }
15238 0           return $o->new($bytes);
15239             }
15240              
15241             # Returns the first child, or an empty record.
15242             sub firstChild {
15243 0     0     my $o = shift;
15244 0   0       $o->{children}->[0] // $o->new }
15245              
15246             # Returns the nth child, or an empty record.
15247             sub nthChild {
15248 0     0     my $o = shift;
15249 0           my $i = shift;
15250 0   0       $o->{children}->[$i] // $o->new }
15251              
15252             sub containsText {
15253 0     0     my $o = shift;
15254 0           my $text = shift;
15255 0   0       $o->contains(Encode::encode_utf8($text // '')) }
15256             sub childWithText {
15257 0     0     my $o = shift;
15258 0           my $text = shift;
15259 0   0       $o->child(Encode::encode_utf8($text // '')) }
15260              
15261             # *** Get value
15262              
15263 0     0     sub bytes { shift->{bytes} }
15264 0     0     sub hash { shift->{hash} }
15265             sub children {
15266 0     0     my $o = shift;
15267 0           @{$o->{children}} }
  0            
15268              
15269             sub asText {
15270 0     0     my $o = shift;
15271 0   0       Encode::decode_utf8($o->{bytes}) // '' }
15272             sub asBoolean {
15273 0     0     my $o = shift;
15274 0           CDS->booleanFromBytes($o->{bytes}) }
15275             sub asInteger {
15276 0     0     my $o = shift;
15277 0   0       CDS->integerFromBytes($o->{bytes}) // 0 }
15278             sub asUnsigned {
15279 0     0     my $o = shift;
15280 0   0       CDS->unsignedFromBytes($o->{bytes}) // 0 }
15281             sub asFloat {
15282 0     0     my $o = shift;
15283 0   0       CDS->floatFromBytes($o->{bytes}) // 0 }
15284              
15285             sub asHashAndKey {
15286 0     0     my $o = shift;
15287              
15288 0 0         return if ! $o->{hash};
15289 0 0         return if length $o->{bytes} != 32;
15290 0           return CDS::HashAndKey->new($o->{hash}, $o->{bytes});
15291             }
15292              
15293             sub bytesValue {
15294 0     0     my $o = shift;
15295 0           $o->firstChild->bytes }
15296             sub hashValue {
15297 0     0     my $o = shift;
15298 0           $o->firstChild->hash }
15299             sub textValue {
15300 0     0     my $o = shift;
15301 0           $o->firstChild->asText }
15302             sub booleanValue {
15303 0     0     my $o = shift;
15304 0           $o->firstChild->asBoolean }
15305             sub integerValue {
15306 0     0     my $o = shift;
15307 0           $o->firstChild->asInteger }
15308             sub unsignedValue {
15309 0     0     my $o = shift;
15310 0           $o->firstChild->asUnsigned }
15311             sub floatValue {
15312 0     0     my $o = shift;
15313 0           $o->firstChild->asFloat }
15314             sub hashAndKeyValue {
15315 0     0     my $o = shift;
15316 0           $o->firstChild->asHashAndKey }
15317              
15318             # *** Dependent hashes
15319              
15320             sub dependentHashes {
15321 0     0     my $o = shift;
15322              
15323 0           my $hashes = {};
15324 0           $o->traverseHashes($hashes);
15325 0           return values %$hashes;
15326             }
15327              
15328             sub traverseHashes {
15329 0     0     my $o = shift;
15330 0           my $hashes = shift;
15331             # private
15332 0 0         $hashes->{$o->{hash}->bytes} = $o->{hash} if $o->{hash};
15333 0           for my $child (@{$o->{children}}) {
  0            
15334 0           $child->traverseHashes($hashes);
15335             }
15336             }
15337              
15338             # *** Size
15339              
15340             sub countEntries {
15341 0     0     my $o = shift;
15342              
15343 0           my $count = 1;
15344 0           for my $child (@{$o->{children}}) { $count += $child->countEntries; }
  0            
  0            
15345 0           return $count;
15346             }
15347              
15348             sub calculateSize {
15349 0     0     my $o = shift;
15350              
15351 0           return 4 + $o->calculateSizeContribution;
15352             }
15353              
15354             sub calculateSizeContribution {
15355 0     0     my $o = shift;
15356             # private
15357 0           my $byteLength = length $o->{bytes};
15358 0 0         my $size = $byteLength < 30 ? 1 : $byteLength < 286 ? 2 : 9;
    0          
15359 0           $size += $byteLength;
15360 0 0         $size += 32 + 4 if $o->{hash};
15361 0           for my $child (@{$o->{children}}) {
  0            
15362 0           $size += $child->calculateSizeContribution;
15363             }
15364 0           return $size;
15365             }
15366              
15367             # *** Serialization
15368              
15369             # Serializes this record into a Condensation object.
15370             sub toObject {
15371 0     0     my $o = shift;
15372              
15373 0           my $writer = CDS::RecordWriter->new;
15374 0           $writer->writeChildren($o);
15375 0           return CDS::Object->create($writer->header, $writer->data);
15376             }
15377              
15378             package CDS::RecordReader;
15379              
15380             sub new {
15381 0     0     my $class = shift;
15382 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
15383              
15384 0           return bless {
15385             object => $object,
15386             data => $object->data,
15387             pos => 0,
15388             hasError => 0
15389             };
15390             }
15391              
15392 0     0     sub hasError { shift->{hasError} }
15393              
15394             sub readChildren {
15395 0     0     my $o = shift;
15396 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
15397              
15398 0           while (1) {
15399             # Flags
15400 0   0       my $flags = $o->readUnsigned8 // return;
15401              
15402             # Data
15403 0           my $length = $flags & 0x1f;
15404 0 0 0       my $byteLength = $length == 30 ? 30 + ($o->readUnsigned8 // return) : $length == 31 ? ($o->readUnsigned64 // return) : $length;
    0 0        
15405 0           my $bytes = $o->readBytes($byteLength);
15406 0 0 0       my $hash = $flags & 0x20 ? $o->{object}->hashAtIndex($o->readUnsigned32 // return) : undef;
15407 0 0         return if $o->{hasError};
15408              
15409             # Children
15410 0           my $child = $record->add($bytes, $hash);
15411 0 0 0       return if $flags & 0x40 && ! $o->readChildren($child);
15412 0 0         return 1 if ! ($flags & 0x80);
15413             }
15414             }
15415              
15416             sub use {
15417 0     0     my $o = shift;
15418 0           my $length = shift;
15419              
15420 0           my $start = $o->{pos};
15421 0           $o->{pos} += $length;
15422 0 0         return substr($o->{data}, $start, $length) if $o->{pos} <= length $o->{data};
15423 0           $o->{hasError} = 1;
15424 0           return;
15425             }
15426              
15427             sub readUnsigned8 {
15428 0     0     my $o = shift;
15429 0   0       unpack('C', $o->use(1) // return) }
15430             sub readUnsigned32 {
15431 0     0     my $o = shift;
15432 0   0       unpack('L>', $o->use(4) // return) }
15433             sub readUnsigned64 {
15434 0     0     my $o = shift;
15435 0   0       unpack('Q>', $o->use(8) // return) }
15436             sub readBytes {
15437 0     0     my $o = shift;
15438 0           my $length = shift;
15439 0           $o->use($length) }
15440             sub trailer {
15441 0     0     my $o = shift;
15442 0           substr($o->{data}, $o->{pos}) }
15443              
15444             package CDS::RecordWriter;
15445              
15446             sub new {
15447 0     0     my $class = shift;
15448              
15449 0           return bless {
15450             hashesCount => 0,
15451             hashes => '',
15452             data => ''
15453             };
15454             }
15455              
15456             sub header {
15457 0     0     my $o = shift;
15458 0           pack('L>', $o->{hashesCount}).$o->{hashes} }
15459 0     0     sub data { shift->{data} }
15460              
15461             sub writeChildren {
15462 0     0     my $o = shift;
15463 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
15464              
15465 0           my @children = @{$record->{children}};
  0            
15466 0 0         return if ! scalar @children;
15467 0           my $lastChild = pop @children;
15468 0           for my $child (@children) { $o->writeNode($child, 1); }
  0            
15469 0           $o->writeNode($lastChild, 0);
15470             }
15471              
15472             sub writeNode {
15473 0     0     my $o = shift;
15474 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
15475 0           my $hasMoreSiblings = shift;
15476              
15477             # Flags
15478 0           my $byteLength = length $record->{bytes};
15479 0 0         my $flags = $byteLength < 30 ? $byteLength : $byteLength < 286 ? 30 : 31;
    0          
15480 0 0         $flags |= 0x20 if defined $record->{hash};
15481 0           my $countChildren = scalar @{$record->{children}};
  0            
15482 0 0         $flags |= 0x40 if $countChildren;
15483 0 0         $flags |= 0x80 if $hasMoreSiblings;
15484 0           $o->writeUnsigned8($flags);
15485              
15486             # Data
15487 0 0         $o->writeUnsigned8($byteLength - 30) if ($flags & 0x1f) == 30;
15488 0 0         $o->writeUnsigned64($byteLength) if ($flags & 0x1f) == 31;
15489 0           $o->writeBytes($record->{bytes});
15490 0 0         $o->writeUnsigned32($o->addHash($record->{hash})) if $flags & 0x20;
15491              
15492             # Children
15493 0           $o->writeChildren($record);
15494             }
15495              
15496             sub writeUnsigned8 {
15497 0     0     my $o = shift;
15498 0           my $value = shift;
15499 0           $o->{data} .= pack('C', $value) }
15500             sub writeUnsigned32 {
15501 0     0     my $o = shift;
15502 0           my $value = shift;
15503 0           $o->{data} .= pack('L>', $value) }
15504             sub writeUnsigned64 {
15505 0     0     my $o = shift;
15506 0           my $value = shift;
15507 0           $o->{data} .= pack('Q>', $value) }
15508              
15509             sub writeBytes {
15510 0     0     my $o = shift;
15511 0           my $bytes = shift;
15512              
15513 0 0         warn $bytes.' is a utf8 string, not a byte string.' if utf8::is_utf8($bytes);
15514 0           $o->{data} .= $bytes;
15515             }
15516              
15517             sub addHash {
15518 0     0     my $o = shift;
15519 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15520              
15521 0           my $index = $o->{hashesCount};
15522 0           $o->{hashes} .= $hash->bytes;
15523 0           $o->{hashesCount} += 1;
15524 0           return $index;
15525             }
15526              
15527             package CDS::RootDocument;
15528              
15529 1     1   13241 use parent -norequire, 'CDS::Document';
  1         2  
  1         6  
15530              
15531             sub new {
15532 0     0     my $class = shift;
15533 0           my $privateRoot = shift;
15534 0           my $label = shift;
15535              
15536 0           my $o = $class->SUPER::new($privateRoot->privateBoxReader->keyPair, $privateRoot->unsaved);
15537 0           $o->{privateRoot} = $privateRoot;
15538 0           $o->{label} = $label;
15539 0           $privateRoot->addDataHandler($label, $o);
15540              
15541             # State
15542 0           $o->{dataSharingMessage} = undef;
15543 0           return $o;
15544             }
15545              
15546 0     0     sub privateRoot { shift->{privateRoot} }
15547 0     0     sub label { shift->{label} }
15548              
15549             sub savingDone {
15550 0     0     my $o = shift;
15551 0           my $revision = shift;
15552 0           my $newPart = shift;
15553 0           my $obsoleteParts = shift;
15554              
15555 0           $o->{privateRoot}->unsaved->state->merge($o->{unsaved}->savingState);
15556 0           $o->{unsaved}->savingDone;
15557 0 0 0       $o->{privateRoot}->dataChanged if $newPart || scalar @$obsoleteParts;
15558             }
15559              
15560             sub addDataTo {
15561 0     0     my $o = shift;
15562 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
15563              
15564 0           for my $part (sort { $a->{hashAndKey}->hash->bytes cmp $b->{hashAndKey}->hash->bytes } values %{$o->{parts}}) {
  0            
  0            
15565 0           $record->addHashAndKey($part->{hashAndKey});
15566             }
15567             }
15568             sub mergeData {
15569 0     0     my $o = shift;
15570 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
15571              
15572 0           my @hashesAndKeys;
15573 0           for my $child ($record->children) {
15574 0   0       push @hashesAndKeys, $child->asHashAndKey // next;
15575             }
15576              
15577 0           $o->merge(@hashesAndKeys);
15578             }
15579              
15580             sub mergeExternalData {
15581 0     0     my $o = shift;
15582 0           my $store = shift;
15583 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
15584 0 0 0       my $source = shift; die 'wrong type '.ref($source).' for $source' if defined $source && ref $source ne 'CDS::Source';
  0            
15585              
15586 0           my @hashes;
15587             my @hashesAndKeys;
15588 0           for my $child ($record->children) {
15589 0   0       my $hashAndKey = $child->asHashAndKey // next;
15590 0 0         next if $o->{parts}->{$hashAndKey->hash->bytes};
15591 0           push @hashes, $hashAndKey->hash;
15592 0           push @hashesAndKeys, $hashAndKey;
15593             }
15594              
15595 0           my ($missing, $transferStore, $storeError) = $o->{keyPair}->transfer([@hashes], $store, $o->{privateRoot}->unsaved);
15596 0 0         return if defined $storeError;
15597 0 0         return if $missing;
15598              
15599 0 0         if ($source) {
15600 0           $source->keep;
15601 0           $o->{privateRoot}->unsaved->state->addMergedSource($source);
15602             }
15603              
15604 0           $o->merge(@hashesAndKeys);
15605 0           return 1;
15606             }
15607              
15608             package CDS::Selector;
15609              
15610             sub root {
15611 0     0     my $class = shift;
15612 0           my $document = shift;
15613              
15614 0           return bless {document => $document, id => 'ROOT', label => ''};
15615             }
15616              
15617 0     0     sub document { shift->{document} }
15618 0     0     sub parent { shift->{parent} }
15619 0     0     sub label { shift->{label} }
15620              
15621             sub child {
15622 0     0     my $o = shift;
15623 0           my $label = shift;
15624              
15625             return bless {
15626             document => $o->{document},
15627 0           id => $o->{id}.'/'.unpack('H*', $label),
15628             parent => $o,
15629             label => $label,
15630             };
15631             }
15632              
15633             sub childWithText {
15634 0     0     my $o = shift;
15635 0           my $label = shift;
15636              
15637 0   0       return $o->child(Encode::encode_utf8($label // ''));
15638             }
15639              
15640             sub children {
15641 0     0     my $o = shift;
15642              
15643 0   0       my $item = $o->{document}->get($o) // return;
15644 0           return map { $_->{selector} } @{$item->{children}};
  0            
  0            
15645             }
15646              
15647             # Value
15648              
15649             sub revision {
15650 0     0     my $o = shift;
15651              
15652 0   0       my $item = $o->{document}->get($o) // return 0;
15653 0           return $item->{revision};
15654             }
15655              
15656             sub isSet {
15657 0     0     my $o = shift;
15658              
15659 0   0       my $item = $o->{document}->get($o) // return;
15660 0           return scalar $item->{record}->children > 0;
15661             }
15662              
15663             sub record {
15664 0     0     my $o = shift;
15665              
15666 0   0       my $item = $o->{document}->get($o) // return CDS::Record->new;
15667 0           return $item->{record};
15668             }
15669              
15670             sub set {
15671 0     0     my $o = shift;
15672 0 0 0       my $record = shift // return; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0   0        
15673              
15674 0           my $now = CDS->now;
15675 0           my $item = $o->{document}->getOrCreate($o);
15676 0 0         $item->mergeValue($o->{document}->{changes}, $item->{revision} >= $now ? $item->{revision} + 1 : $now, $record);
15677             }
15678              
15679             sub merge {
15680 0     0     my $o = shift;
15681 0           my $revision = shift;
15682 0 0 0       my $record = shift // return; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0   0        
15683              
15684 0           my $item = $o->{document}->getOrCreate($o);
15685 0           return $item->mergeValue($o->{document}->{changes}, $revision, $record);
15686             }
15687              
15688             sub clear {
15689 0     0     my $o = shift;
15690 0           $o->set(CDS::Record->new) }
15691              
15692             sub clearInThePast {
15693 0     0     my $o = shift;
15694              
15695 0 0         $o->merge($o->revision + 1, CDS::Record->new) if $o->isSet;
15696             }
15697              
15698             sub forget {
15699 0     0     my $o = shift;
15700              
15701 0   0       my $item = $o->{document}->get($o) // return;
15702 0           $item->forget;
15703             }
15704              
15705             sub forgetBranch {
15706 0     0     my $o = shift;
15707              
15708 0           for my $child ($o->children) { $child->forgetBranch; }
  0            
15709 0           $o->forget;
15710             }
15711              
15712             # Convenience methods (simple interface)
15713              
15714             sub firstValue {
15715 0     0     my $o = shift;
15716              
15717 0   0       my $item = $o->{document}->get($o) // return CDS::Record->new;
15718 0           return $item->{record}->firstChild;
15719             }
15720              
15721             sub bytesValue {
15722 0     0     my $o = shift;
15723 0           $o->firstValue->bytes }
15724             sub hashValue {
15725 0     0     my $o = shift;
15726 0           $o->firstValue->hash }
15727             sub textValue {
15728 0     0     my $o = shift;
15729 0           $o->firstValue->asText }
15730             sub booleanValue {
15731 0     0     my $o = shift;
15732 0           $o->firstValue->asBoolean }
15733             sub integerValue {
15734 0     0     my $o = shift;
15735 0           $o->firstValue->asInteger }
15736             sub unsignedValue {
15737 0     0     my $o = shift;
15738 0           $o->firstValue->asUnsigned }
15739             sub floatValue {
15740 0     0     my $o = shift;
15741 0           $o->firstValue->asFloat }
15742             sub hashAndKeyValue {
15743 0     0     my $o = shift;
15744 0           $o->firstValue->asHashAndKey }
15745              
15746             # Sets a new value unless the node has that value already.
15747             sub setBytes {
15748 0     0     my $o = shift;
15749 0           my $bytes = shift;
15750 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15751              
15752 0           my $record = CDS::Record->new;
15753 0           $record->add($bytes, $hash);
15754 0           $o->set($record);
15755             }
15756              
15757             sub setHash {
15758 0     0     my $o = shift;
15759 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15760 0           $o->setBytes('', $hash); };
15761             sub setText {
15762 0     0     my $o = shift;
15763 0           my $value = shift;
15764 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15765 0           $o->setBytes(Encode::encode_utf8($value), $hash); };
15766             sub setBoolean {
15767 0     0     my $o = shift;
15768 0           my $value = shift;
15769 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15770 0           $o->setBytes(CDS->bytesFromBoolean($value), $hash); };
15771             sub setInteger {
15772 0     0     my $o = shift;
15773 0           my $value = shift;
15774 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15775 0           $o->setBytes(CDS->bytesFromInteger($value), $hash); };
15776             sub setUnsigned {
15777 0     0     my $o = shift;
15778 0           my $value = shift;
15779 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15780 0           $o->setBytes(CDS->bytesFromUnsigned($value), $hash); };
15781             sub setFloat32 {
15782 0     0     my $o = shift;
15783 0           my $value = shift;
15784 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15785 0           $o->setBytes(CDS->bytesFromFloat32($value), $hash); };
15786             sub setFloat64 {
15787 0     0     my $o = shift;
15788 0           my $value = shift;
15789 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15790 0           $o->setBytes(CDS->bytesFromFloat64($value), $hash); };
15791             sub setHashAndKey {
15792 0     0     my $o = shift;
15793 0 0 0       my $hashAndKey = shift; die 'wrong type '.ref($hashAndKey).' for $hashAndKey' if defined $hashAndKey && ref $hashAndKey ne 'CDS::HashAndKey';
  0            
15794 0           $o->setBytes($hashAndKey->key, $hashAndKey->hash); };
15795              
15796             # Adding objects and merged sources
15797              
15798             sub addObject {
15799 0     0     my $o = shift;
15800 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15801 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
15802              
15803 0           $o->{document}->{unsaved}->state->addObject($hash, $object);
15804             }
15805              
15806             sub addMergedSource {
15807 0     0     my $o = shift;
15808 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15809              
15810 0           $o->{document}->{unsaved}->state->addMergedSource($hash);
15811             }
15812              
15813             package CDS::SentItem;
15814              
15815 1     1   2254 use parent -norequire, 'CDS::UnionList::Item';
  1         2  
  1         4  
15816              
15817             sub new {
15818 0     0     my $class = shift;
15819 0           my $unionList = shift;
15820 0           my $id = shift;
15821              
15822 0           my $o = $class->SUPER::new($unionList, $id);
15823 0           $o->{validUntil} = 0;
15824 0           $o->{message} = CDS::Record->new;
15825 0           return $o;
15826             }
15827              
15828 0     0     sub validUntil { shift->{validUntil} }
15829             sub envelopeHash {
15830 0     0     my $o = shift;
15831 0           CDS::Hash->fromBytes($o->{message}->bytes) }
15832             sub envelopeHashBytes {
15833 0     0     my $o = shift;
15834 0           $o->{message}->bytes }
15835 0     0     sub message { shift->{message} }
15836              
15837             sub addToRecord {
15838 0     0     my $o = shift;
15839 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
15840              
15841 0           $record->add($o->{id})->addInteger($o->{validUntil})->addRecord($o->{message});
15842             }
15843              
15844             sub set {
15845 0     0     my $o = shift;
15846 0           my $validUntil = shift;
15847 0 0 0       my $envelopeHash = shift; die 'wrong type '.ref($envelopeHash).' for $envelopeHash' if defined $envelopeHash && ref $envelopeHash ne 'CDS::Hash';
  0            
15848 0 0 0       my $messageRecord = shift; die 'wrong type '.ref($messageRecord).' for $messageRecord' if defined $messageRecord && ref $messageRecord ne 'CDS::Record';
  0            
15849              
15850 0           my $message = CDS::Record->new($envelopeHash->bytes);
15851 0           $message->addRecord($messageRecord->children);
15852 0           $o->merge($o->{unionList}->{changes}, CDS->max($validUntil, $o->{validUntil} + 1), $message);
15853             }
15854              
15855             sub clear {
15856 0     0     my $o = shift;
15857 0           my $validUntil = shift;
15858              
15859 0           $o->merge($o->{unionList}->{changes}, CDS->max($validUntil, $o->{validUntil} + 1), CDS::Record->new);
15860             }
15861              
15862             sub merge {
15863 0     0     my $o = shift;
15864 0           my $part = shift;
15865 0           my $validUntil = shift;
15866 0           my $message = shift;
15867              
15868 0 0         return if $o->{validUntil} > $validUntil;
15869 0 0 0       return if $o->{validUntil} == $validUntil && $part->{size} < $o->{part}->{size};
15870 0           $o->{validUntil} = $validUntil;
15871 0           $o->{message} = $message;
15872 0           $o->setPart($part);
15873             }
15874              
15875             package CDS::SentList;
15876              
15877 1     1   482 use parent -norequire, 'CDS::UnionList';
  1         2  
  1         40  
15878              
15879             sub new {
15880 0     0     my $class = shift;
15881 0           my $privateRoot = shift;
15882              
15883 0           return $class->SUPER::new($privateRoot, 'sent list');
15884             }
15885              
15886             sub createItem {
15887 0     0     my $o = shift;
15888 0           my $id = shift;
15889              
15890 0           return CDS::SentItem->new($o, $id);
15891             }
15892              
15893             sub mergeRecord {
15894 0     0     my $o = shift;
15895 0           my $part = shift;
15896 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
15897              
15898 0           my $item = $o->getOrCreate($record->bytes);
15899 0           for my $child ($record->children) {
15900 0           my $validUntil = $child->asInteger;
15901 0           my $message = $child->firstChild;
15902 0           $item->merge($part, $validUntil, $message);
15903             }
15904             }
15905              
15906             sub forgetObsoleteItems {
15907 0     0     my $o = shift;
15908              
15909 0           my $now = CDS->now;
15910 0           my $toDelete = [];
15911 0           for my $item (values %{$o->{items}}) {
  0            
15912 0 0         next if $item->{validUntil} >= $now;
15913 0           $o->forgetItem($item);
15914             }
15915             }
15916              
15917             package CDS::Source;
15918              
15919             sub new {
15920 0     0     my $class = shift;
15921 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
15922 0 0 0       my $actorOnStore = shift; die 'wrong type '.ref($actorOnStore).' for $actorOnStore' if defined $actorOnStore && ref $actorOnStore ne 'CDS::ActorOnStore';
  0            
15923 0           my $boxLabel = shift;
15924 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15925              
15926 0           return bless {
15927             keyPair => $keyPair,
15928             actorOnStore => $actorOnStore,
15929             boxLabel => $boxLabel,
15930             hash => $hash,
15931             referenceCount => 1,
15932             };
15933             }
15934              
15935 0     0     sub keyPair { shift->{keyPair} }
15936 0     0     sub actorOnStore { shift->{actorOnStore} }
15937 0     0     sub boxLabel { shift->{boxLabel} }
15938 0     0     sub hash { shift->{hash} }
15939 0     0     sub referenceCount { shift->{referenceCount} }
15940              
15941             sub keep {
15942 0     0     my $o = shift;
15943              
15944 0 0         if ($o->{referenceCount} < 1) {
15945 0           warn 'The source '.$o->{actorOnStore}->publicKey->hash->hex.'/'.$o->{boxLabel}.'/'.$o->{hash}->hex.' has already been discarded, and cannot be kept any more.';
15946 0           return;
15947             }
15948              
15949 0           $o->{referenceCount} += 1;
15950             }
15951              
15952             sub discard {
15953 0     0     my $o = shift;
15954              
15955 0 0         if ($o->{referenceCount} < 1) {
15956 0           warn 'The source '.$o->{actorOnStore}->publicKey->hash->hex.'/'.$o->{boxLabel}.'/'.$o->{hash}->hex.' has already been discarded, and cannot be discarded again.';
15957 0           return;
15958             }
15959              
15960 0           $o->{referenceCount} -= 1;
15961 0 0         return if $o->{referenceCount} > 0;
15962              
15963 0           $o->{actorOnStore}->store->remove($o->{actorOnStore}->publicKey->hash, $o->{boxLabel}, $o->{hash}, $o->{keyPair});
15964             }
15965              
15966             # A store mapping objects and accounts to a group of stores.
15967             package CDS::SplitStore;
15968              
15969 1     1   672 use parent -norequire, 'CDS::Store';
  1         2  
  1         3  
15970              
15971             sub new {
15972 0     0     my $class = shift;
15973 0           my $key = shift;
15974              
15975 0           return bless {
15976             id => 'Split Store\n'.unpack('H*', CDS::C::aesCrypt(CDS->zeroCTR, $key, CDS->zeroCTR)),
15977             key => $key,
15978             accountStores => [],
15979             objectStores => [],
15980             };
15981             }
15982              
15983 0     0     sub id { shift->{id} }
15984              
15985             ### Store configuration
15986              
15987             sub assignAccounts {
15988 0     0     my $o = shift;
15989 0           my $fromIndex = shift;
15990 0           my $toIndex = shift;
15991 0           my $store = shift;
15992              
15993 0           for my $i ($fromIndex .. $toIndex) {
15994 0           $o->{accountStores}->[$i] = $store;
15995             }
15996             }
15997              
15998             sub assignObjects {
15999 0     0     my $o = shift;
16000 0           my $fromIndex = shift;
16001 0           my $toIndex = shift;
16002 0           my $store = shift;
16003              
16004 0           for my $i ($fromIndex .. $toIndex) {
16005 0           $o->{objectStores}->[$i] = $store;
16006             }
16007             }
16008              
16009             sub objectStore {
16010 0     0     my $o = shift;
16011 0           my $index = shift;
16012 0           $o->{objectStores}->[$index] }
16013             sub accountStore {
16014 0     0     my $o = shift;
16015 0           my $index = shift;
16016 0           $o->{accountStores}->[$index] }
16017              
16018             ### Hash encryption
16019              
16020             our $zeroCounter = "\0" x 16;
16021              
16022             sub storeIndex {
16023 0     0     my $o = shift;
16024 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16025              
16026             # To avoid attacks on a single store, the hash is encrypted with a key known to the operator only
16027 0           my $encryptedBytes = CDS::C::aesCrypt(substr($hash->bytes, 0, 16), $o->{key}, $zeroCounter);
16028              
16029             # Use the first byte as store index
16030 0           return ord(substr($encryptedBytes, 0, 1));
16031             }
16032              
16033             ### Store interface
16034              
16035             sub get {
16036 0     0     my $o = shift;
16037 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16038 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
16039              
16040 0   0       my $store = $o->objectStore($o->storeIndex($hash)) // return undef, 'No store assigned.';
16041 0           return $store->get($hash, $keyPair);
16042             }
16043              
16044             sub put {
16045 0     0     my $o = shift;
16046 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16047 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
16048 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
16049              
16050 0   0       my $store = $o->objectStore($o->storeIndex($hash)) // return undef, 'No store assigned.';
16051 0           return $store->put($hash, $object, $keyPair);
16052             }
16053              
16054             sub book {
16055 0     0     my $o = shift;
16056 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16057 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
16058              
16059 0   0       my $store = $o->objectStore($o->storeIndex($hash)) // return undef, 'No store assigned.';
16060 0           return $store->book($hash, $keyPair);
16061             }
16062              
16063             sub list {
16064 0     0     my $o = shift;
16065 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
16066 0           my $boxLabel = shift;
16067 0           my $timeout = shift;
16068 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
16069              
16070 0   0       my $store = $o->accountStore($o->storeIndex($accountHash)) // return undef, 'No store assigned.';
16071 0           return $store->list($accountHash, $boxLabel, $timeout, $keyPair);
16072             }
16073              
16074             sub add {
16075 0     0     my $o = shift;
16076 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
16077 0           my $boxLabel = shift;
16078 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16079 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
16080              
16081 0   0       my $store = $o->accountStore($o->storeIndex($accountHash)) // return 'No store assigned.';
16082 0           return $store->add($accountHash, $boxLabel, $hash, $keyPair);
16083             }
16084              
16085             sub remove {
16086 0     0     my $o = shift;
16087 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
16088 0           my $boxLabel = shift;
16089 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16090 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
16091              
16092 0   0       my $store = $o->accountStore($o->storeIndex($accountHash)) // return 'No store assigned.';
16093 0           return $store->remove($accountHash, $boxLabel, $hash, $keyPair);
16094             }
16095              
16096             sub modify {
16097 0     0     my $o = shift;
16098 0           my $modifications = shift;
16099 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
16100              
16101             # Put objects
16102 0           my %objectsByStoreId;
16103 0           for my $entry (values %{$modifications->objects}) {
  0            
16104 0           my $store = $o->objectStore($o->storeIndex($entry->{hash}));
16105 0           my $target = $objectsByStoreId{$store->id};
16106 0           $objectsByStoreId{$store->id} = $target = {store => $store, modifications => CDS::StoreModifications->new};
16107 0           $target->modifications->put($entry->{hash}, $entry->{object});
16108             }
16109              
16110 0           for my $item (values %objectsByStoreId) {
16111 0           my $error = $item->{store}->modify($item->{modifications}, $keyPair);
16112 0 0         return $error if $error;
16113             }
16114              
16115             # Add box entries
16116 0           my %additionsByStoreId;
16117 0           for my $operation (@{$modifications->additions}) {
  0            
16118 0           my $store = $o->accountStore($o->storeIndex($operation->{accountHash}));
16119 0           my $target = $additionsByStoreId{$store->id};
16120 0           $additionsByStoreId{$store->id} = $target = {store => $store, modifications => CDS::StoreModifications->new};
16121 0           $target->modifications->add($operation->{accountHash}, $operation->{boxLabel}, $operation->{hash});
16122             }
16123              
16124 0           for my $item (values %additionsByStoreId) {
16125 0           my $error = $item->{store}->modify($item->{modifications}, $keyPair);
16126 0 0         return $error if $error;
16127             }
16128              
16129             # Remove box entries (but ignore errors)
16130 0           my %removalsByStoreId;
16131 0           for my $operation (@$modifications->removals) {
16132 0           my $store = $o->accountStore($o->storeIndex($operation->{accountHash}));
16133 0           my $target = $removalsByStoreId{$store->id};
16134 0           $removalsByStoreId{$store->id} = $target = {store => $store, modifications => CDS::StoreModifications->new};
16135 0           $target->modifications->add($operation->{accountHash}, $operation->{boxLabel}, $operation->{hash});
16136             }
16137              
16138 0           for my $item (values %removalsByStoreId) {
16139 0           $item->{store}->modify($item->{modifications}, $keyPair);
16140             }
16141              
16142 0           return;
16143             }
16144              
16145             # General
16146             # sub id($o) # () => String
16147             package CDS::Store;
16148              
16149             # Object store functions
16150             # sub get($o, $hash, $keyPair) # Hash, KeyPair? => Object?, String?
16151             # sub put($o, $hash, $object, $keyPair) # Hash, Object, KeyPair? => String?
16152             # sub book($o, $hash, $keyPair) # Hash, KeyPair? => 1?, String?
16153              
16154             # Account store functions
16155             # sub list($o, $accountHash, $boxLabel, $timeout, $keyPair) # Hash, String, Duration, KeyPair? => @$Hash, String?
16156             # sub add($o, $accountHash, $boxLabel, $hash, $keyPair) # Hash, String, Hash, KeyPair? => String?
16157             # sub remove($o, $accountHash, $boxLabel, $hash, $keyPair) # Hash, String, Hash, KeyPair? => String?
16158             # sub modify($o, $storeModifications, $keyPair) # StoreModifications, KeyPair? => String?
16159              
16160             package CDS::StoreModifications;
16161              
16162             sub new {
16163 0     0     my $class = shift;
16164              
16165 0           return bless {
16166             objects => {},
16167             additions => [],
16168             removals => [],
16169             };
16170             }
16171              
16172 0     0     sub objects { shift->{objects} }
16173 0     0     sub additions { shift->{additions} }
16174 0     0     sub removals { shift->{removals} }
16175              
16176             sub isEmpty {
16177 0     0     my $o = shift;
16178              
16179 0 0         return if scalar keys %{$o->{objects}};
  0            
16180 0 0         return if scalar @{$o->{additions}};
  0            
16181 0 0         return if scalar @{$o->{removals}};
  0            
16182 0           return 1;
16183             }
16184              
16185             sub put {
16186 0     0     my $o = shift;
16187 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16188 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
16189              
16190 0           $o->{objects}->{$hash->bytes} = {hash => $hash, object => $object};
16191             }
16192              
16193             sub add {
16194 0     0     my $o = shift;
16195 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
16196 0           my $boxLabel = shift;
16197 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16198 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
16199              
16200 0 0         $o->put($hash, $object) if $object;
16201 0           push @{$o->{additions}}, {accountHash => $accountHash, boxLabel => $boxLabel, hash => $hash};
  0            
16202             }
16203              
16204             sub remove {
16205 0     0     my $o = shift;
16206 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
16207 0           my $boxLabel = shift;
16208 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16209              
16210 0           push @{$o->{removals}}, {accountHash => $accountHash, boxLabel => $boxLabel, hash => $hash};
  0            
16211             }
16212              
16213             sub executeIndividually {
16214 0     0     my $o = shift;
16215 0           my $store = shift;
16216 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
16217              
16218             # Process objects
16219 0           for my $entry (values %{$o->{objects}}) {
  0            
16220 0           my $error = $store->put($entry->{hash}, $entry->{object}, $keyPair);
16221 0 0         return $error if $error;
16222             }
16223              
16224             # Process additions
16225 0           for my $entry (@{$o->{additions}}) {
  0            
16226 0           my $error = $store->add($entry->{accountHash}, $entry->{boxLabel}, $entry->{hash}, $keyPair);
16227 0 0         return $error if $error;
16228             }
16229              
16230             # Process removals (and ignore errors)
16231 0           for my $entry (@{$o->{removals}}) {
  0            
16232 0           $store->remove($entry->{accountHash}, $entry->{boxLabel}, $entry->{hash}, $keyPair);
16233             }
16234              
16235 0           return;
16236             }
16237              
16238             # Returns a text representation of box additions and removals.
16239             sub toRecord {
16240 0     0     my $o = shift;
16241              
16242 0           my $record = CDS::Record->new;
16243              
16244             # Objects
16245 0           my $objectsRecord = $record->add('put');
16246 0           for my $entry (values %{$o->{objects}}) {
  0            
16247 0           $objectsRecord->add($entry->{hash}->bytes)->add($entry->{object}->bytes);
16248             }
16249              
16250             # Box additions and removals
16251 0           &addEntriesToRecord($o->{additions}, $record->add('add'));
16252 0           &addEntriesToRecord($o->{removals}, $record->add('remove'));
16253              
16254 0           return $record;
16255             }
16256              
16257             sub addEntriesToRecord {
16258 0     0     my $unsortedEntries = shift;
16259 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
16260             # private
16261 0 0         my @additions = sort { ($a->{accountHash}->bytes cmp $b->{accountHash}->bytes) || ($a->{boxLabel} cmp $b->{boxLabel}) } @$unsortedEntries;
  0            
16262 0           my $entry = shift @additions;
16263 0           while (defined $entry) {
16264 0           my $accountHash = $entry->{accountHash};
16265 0           my $accountRecord = $record->add($accountHash->bytes);
16266              
16267 0   0       while (defined $entry && $entry->{accountHash}->bytes eq $accountHash->bytes) {
16268 0           my $boxLabel = $entry->{boxLabel};
16269 0           my $boxRecord = $accountRecord->add($boxLabel);
16270              
16271 0   0       while (defined $entry && $entry->{boxLabel} eq $boxLabel) {
16272 0           $boxRecord->add($entry->{hash}->bytes);
16273 0           $entry = shift @additions;
16274             }
16275             }
16276             }
16277             }
16278              
16279             sub fromBytes {
16280 0     0     my $class = shift;
16281 0           my $bytes = shift;
16282              
16283 0   0       my $object = CDS::Object->fromBytes($bytes) // return;
16284 0   0       my $record = CDS::Record->fromObject($object) // return;
16285 0           return $class->fromRecord($record);
16286             }
16287              
16288             sub fromRecord {
16289 0     0     my $class = shift;
16290 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
16291              
16292 0           my $modifications = $class->new;
16293              
16294             # Read objects (and "envelopes" entries used before 2022-01)
16295 0           for my $objectRecord ($record->child('put')->children, $record->child('envelopes')->children) {
16296 0   0       my $hash = CDS::Hash->fromBytes($objectRecord->bytes) // return;
16297 0   0       my $object = CDS::Object->fromBytes($objectRecord->firstChild->bytes) // return;
16298             #return if $o->{checkEnvelopeHash} && ! $object->calculateHash->equals($hash);
16299 0           $modifications->put($hash, $object);
16300             }
16301              
16302             # Read additions and removals
16303 0   0       &readEntriesFromRecord($modifications->{additions}, $record->child('add')) // return;
16304 0   0       &readEntriesFromRecord($modifications->{removals}, $record->child('remove')) // return;
16305              
16306 0           return $modifications;
16307             }
16308              
16309             sub readEntriesFromRecord {
16310 0     0     my $entries = shift;
16311 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
16312             # private
16313 0           for my $accountHashRecord ($record->children) {
16314 0   0       my $accountHash = CDS::Hash->fromBytes($accountHashRecord->bytes) // return;
16315 0           for my $boxLabelRecord ($accountHashRecord->children) {
16316 0           my $boxLabel = $boxLabelRecord->bytes;
16317 0 0         return if ! CDS->isValidBoxLabel($boxLabel);
16318              
16319 0           for my $hashRecord ($boxLabelRecord->children) {
16320 0   0       my $hash = CDS::Hash->fromBytes($hashRecord->bytes) // return;
16321 0           push @$entries, {accountHash => $accountHash, boxLabel => $boxLabel, hash => $hash};
16322             }
16323             }
16324             }
16325              
16326 0           return 1;
16327             }
16328              
16329             package CDS::StreamCache;
16330              
16331             sub new {
16332 0     0     my $class = shift;
16333 0           my $pool = shift;
16334 0 0 0       my $actorOnStore = shift; die 'wrong type '.ref($actorOnStore).' for $actorOnStore' if defined $actorOnStore && ref $actorOnStore ne 'CDS::ActorOnStore';
  0            
16335 0           my $timeout = shift;
16336              
16337 0           return bless {
16338             pool => $pool,
16339             actorOnStore => $actorOnStore,
16340             timeout => $timeout,
16341             cache => {},
16342             };
16343             }
16344              
16345 0     0     sub messageBoxReader { shift->{messageBoxReader} }
16346              
16347             sub removeObsolete {
16348 0     0     my $o = shift;
16349              
16350 0           my $limit = CDS->now - $o->{timeout};
16351 0           for my $key (%{$o->{knownStreamHeads}}) {
  0            
16352 0   0       my $streamHead = $o->{knownStreamHeads}->{$key} // next;
16353 0 0         next if $streamHead->lastUsed < $limit;
16354 0           delete $o->{knownStreamHeads}->{$key};
16355             }
16356             }
16357              
16358             sub readStreamHead {
16359 0     0     my $o = shift;
16360 0           my $head = shift;
16361              
16362 0           my $streamHead = $o->{knownStreamHeads}->{$head->hex};
16363 0 0         if ($streamHead) {
16364 0           $streamHead->stillInUse;
16365 0           return $streamHead;
16366             }
16367              
16368             # Retrieve the head envelope
16369 0           my ($object, $getError) = $o->{actorOnStore}->store->get($head, $o->{pool}->{keyPair});
16370 0 0         return if defined $getError;
16371              
16372             # Parse the head envelope
16373 0           my $envelope = CDS::Record->fromObject($object);
16374 0 0         return $o->invalid($head, 'Not a record.') if ! $envelope;
16375              
16376             # Read the embedded content object
16377 0           my $encryptedBytes = $envelope->child('content')->bytesValue;
16378 0 0         return $o->invalid($head, 'Missing content object.') if ! length $encryptedBytes;
16379              
16380             # Decrypt the key
16381 0           my $aesKey = $o->{pool}->{keyPair}->decryptKeyOnEnvelope($envelope);
16382 0 0         return $o->invalid($head, 'Not encrypted for us.') if ! $aesKey;
16383              
16384             # Decrypt the content
16385 0           my $contentObject = CDS::Object->fromBytes(CDS::C::aesCrypt($encryptedBytes, $aesKey, CDS->zeroCTR));
16386 0 0         return $o->invalid($head, 'Invalid content object.') if ! $contentObject;
16387              
16388 0           my $content = CDS::Record->fromObject($contentObject);
16389 0 0         return $o->invalid($head, 'Content object is not a record.') if ! $content;
16390              
16391             # Verify the sender hash
16392 0           my $senderHash = $content->child('sender')->hashValue;
16393 0 0         return $o->invalid($head, 'Missing sender hash.') if ! $senderHash;
16394              
16395             # Verify the sender store
16396 0           my $storeRecord = $content->child('store');
16397 0 0         return $o->invalid($head, 'Missing sender store.') if ! scalar $storeRecord->children;
16398              
16399 0           my $senderStoreUrl = $storeRecord->textValue;
16400 0           my $senderStore = $o->{pool}->{delegate}->onMessageBoxVerifyStore($senderStoreUrl, $head, $envelope, $senderHash);
16401 0 0         return $o->invalid($head, 'Invalid sender store.') if ! $senderStore;
16402              
16403             # Retrieve the sender's public key
16404 0           my ($senderPublicKey, $invalidReason, $publicKeyStoreError) = $o->getPublicKey($senderHash, $senderStore);
16405 0 0         return if defined $publicKeyStoreError;
16406 0 0         return $o->invalid($head, 'Failed to retrieve the sender\'s public key: '.$invalidReason) if defined $invalidReason;
16407              
16408             # Verify the signature
16409 0           my $signedHash = CDS::Hash->calculateFor($encryptedBytes);
16410 0 0         return $o->invalid($head, 'Invalid signature.') if ! CDS->verifyEnvelopeSignature($envelope, $senderPublicKey, $signedHash);
16411              
16412             # The envelope is valid
16413 0           my $sender = CDS::ActorOnStore->new($senderPublicKey, $senderStore);
16414 0           my $newStreamHead = CDS::StreamHead->new($head, $envelope, $senderStoreUrl, $sender, $aesKey, $content);
16415 0           $o->{knownStreamHeads}->{$head->hex} = $newStreamHead;
16416 0           return $newStreamHead;
16417             }
16418              
16419             sub invalid {
16420 0     0     my $o = shift;
16421 0           my $head = shift;
16422 0           my $reason = shift;
16423             # private
16424 0           my $newStreamHead = CDS::StreamHead->new($head, undef, undef, undef, undef, undef, $reason);
16425 0           $o->{knownStreamHeads}->{$head->hex} = $newStreamHead;
16426 0           return $newStreamHead;
16427             }
16428              
16429             package CDS::StreamHead;
16430              
16431             sub new {
16432 0     0     my $class = shift;
16433 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16434 0 0 0       my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0            
16435 0           my $senderStoreUrl = shift;
16436 0           my $sender = shift;
16437 0           my $content = shift;
16438 0           my $error = shift;
16439              
16440 0           return bless {
16441             hash => $hash,
16442             envelope => $envelope,
16443             senderStoreUrl => $senderStoreUrl,
16444             sender => $sender,
16445             content => $content,
16446             error => $error,
16447             lastUsed => CDS->now,
16448             };
16449             }
16450              
16451 0     0     sub hash { shift->{hash} }
16452 0     0     sub envelope { shift->{envelope} }
16453 0     0     sub senderStoreUrl { shift->{senderStoreUrl} }
16454 0     0     sub sender { shift->{sender} }
16455 0     0     sub content { shift->{content} }
16456 0     0     sub error { shift->{error} }
16457             sub isValid {
16458 0     0     my $o = shift;
16459 0           ! defined $o->{error} }
16460 0     0     sub lastUsed { shift->{lastUsed} }
16461              
16462             sub stillInUse {
16463 0     0     my $o = shift;
16464              
16465 0           $o->{lastUsed} = CDS->now;
16466             }
16467              
16468             package CDS::SubDocument;
16469              
16470 1     1   3467 use parent -norequire, 'CDS::Document';
  1         2  
  1         5  
16471              
16472             sub new {
16473 0     0     my $class = shift;
16474 0 0 0       my $parentSelector = shift; die 'wrong type '.ref($parentSelector).' for $parentSelector' if defined $parentSelector && ref $parentSelector ne 'CDS::Selector';
  0            
16475              
16476 0           my $o = $class->SUPER::new($parentSelector->document->keyPair, $parentSelector->document->unsaved);
16477 0           $o->{parentSelector} = $parentSelector;
16478 0           return $o;
16479             }
16480              
16481 0     0     sub parentSelector { shift->{parentSelector} }
16482              
16483             sub partSelector {
16484 0     0     my $o = shift;
16485 0 0 0       my $hashAndKey = shift; die 'wrong type '.ref($hashAndKey).' for $hashAndKey' if defined $hashAndKey && ref $hashAndKey ne 'CDS::HashAndKey';
  0            
16486              
16487 0           $o->{parentSelector}->child(substr($hashAndKey->hash->bytes, 0, 16));
16488             }
16489              
16490             sub read {
16491 0     0     my $o = shift;
16492              
16493 0           $o->merge(map { $_->hashAndKeyValue } $o->{parentSelector}->children);
  0            
16494 0           return $o->SUPER::read;
16495             }
16496              
16497             sub savingDone {
16498 0     0     my $o = shift;
16499 0           my $revision = shift;
16500 0           my $newPart = shift;
16501 0           my $obsoleteParts = shift;
16502              
16503 0           $o->{parentSelector}->document->unsaved->state->merge($o->{unsaved}->savingState);
16504              
16505             # Remove obsolete parts
16506 0           for my $part (@$obsoleteParts) {
16507 0           $o->partSelector($part->{hashAndKey})->merge($revision, CDS::Record->new);
16508             }
16509              
16510             # Add the new part
16511 0 0         if ($newPart) {
16512 0           my $record = CDS::Record->new;
16513 0           $record->addHashAndKey($newPart->{hashAndKey});
16514 0           $o->partSelector($newPart->{hashAndKey})->merge($revision, $record);
16515             }
16516              
16517 0           $o->{unsaved}->savingDone;
16518             }
16519              
16520             # Useful functions to display textual information on the terminal
16521             package CDS::UI;
16522              
16523             sub new {
16524 0     0     my $class = shift;
16525 0   0       my $fileHandle = shift // *STDOUT;
16526 0           my $pure = shift;
16527              
16528 0           binmode $fileHandle, ":utf8";
16529 0           return bless {
16530             fileHandle => $fileHandle,
16531             pure => $pure,
16532             indentCount => 0,
16533             indent => '',
16534             valueIndent => 16,
16535             hasSpace => 0,
16536             hasError => 0,
16537             hasWarning => 0,
16538             };
16539             }
16540              
16541 0     0     sub fileHandle { shift->{fileHandle} }
16542              
16543             ### Indent
16544              
16545             sub pushIndent {
16546 0     0     my $o = shift;
16547              
16548 0           $o->{indentCount} += 1;
16549 0           $o->{indent} = ' ' x $o->{indentCount};
16550 0           return;
16551             }
16552              
16553             sub popIndent {
16554 0     0     my $o = shift;
16555              
16556 0           $o->{indentCount} -= 1;
16557 0           $o->{indent} = ' ' x $o->{indentCount};
16558 0           return;
16559             }
16560              
16561             sub valueIndent {
16562 0     0     my $o = shift;
16563 0           my $width = shift;
16564              
16565 0           $o->{valueIndent} = $width;
16566             }
16567              
16568             ### Low-level (non-semantic) output
16569              
16570             sub print {
16571 0     0     my $o = shift;
16572              
16573 0   0       my $fh = $o->{fileHandle} // return;
16574 0           print $fh @_;
16575             }
16576              
16577             sub raw {
16578 0     0     my $o = shift;
16579              
16580 0           $o->removeProgress;
16581 0   0       my $fh = $o->{fileHandle} // return;
16582 0           binmode $fh, ":bytes";
16583 0           print $fh @_;
16584 0           binmode $fh, ":utf8";
16585 0           $o->{hasSpace} = 0;
16586 0           return;
16587             }
16588              
16589             sub space {
16590 0     0     my $o = shift;
16591              
16592 0           $o->removeProgress;
16593 0 0         return if $o->{hasSpace};
16594 0           $o->{hasSpace} = 1;
16595 0           $o->print("\n");
16596 0           return;
16597             }
16598              
16599             # A line of text (without word-wrap).
16600             sub line {
16601 0     0     my $o = shift;
16602              
16603 0           $o->removeProgress;
16604 0           my $span = CDS::UI::Span->new(@_);
16605 0           $o->print($o->{indent});
16606 0           $span->printTo($o);
16607 0           $o->print(chr(0x1b), '[0m', "\n");
16608 0           $o->{hasSpace} = 0;
16609 0           return;
16610             }
16611              
16612             # A line of word-wrapped text.
16613             sub p {
16614 0     0     my $o = shift;
16615              
16616 0           $o->removeProgress;
16617 0           my $span = CDS::UI::Span->new(@_);
16618 0           $span->wordWrap({lineLength => 0, maxLength => 100 - length $o->{indent}, indent => $o->{indent}});
16619 0           $o->print($o->{indent});
16620 0           $span->printTo($o);
16621 0           $o->print(chr(0x1b), '[0m', "\n");
16622 0           $o->{hasSpace} = 0;
16623 0           return;
16624             }
16625              
16626             # Line showing the progress.
16627             sub progress {
16628 0     0     my $o = shift;
16629              
16630 0 0         return if $o->{pure};
16631 0           $| = 1;
16632 0           $o->{hasProgress} = 1;
16633 0           my $text = ' '.join('', @_);
16634 0 0         $text = substr($text, 0, 79).'…' if length $text > 80;
16635 0 0         $text .= ' ' x (80 - length $text) if length $text < 80;
16636 0           $o->print($text, "\r");
16637             }
16638              
16639             # Progress line removal.
16640             sub removeProgress {
16641 0     0     my $o = shift;
16642              
16643 0 0         return if $o->{pure};
16644 0 0         return if ! $o->{hasProgress};
16645 0           $o->print(' ' x 80, "\r");
16646 0           $o->{hasProgress} = 0;
16647 0           $| = 0;
16648             }
16649              
16650             ### Low-level (non-semantic) formatting
16651              
16652             sub span {
16653 0     0     my $o = shift;
16654 0           CDS::UI::Span->new(@_) }
16655              
16656             sub bold {
16657 0     0     my $o = shift;
16658              
16659 0           my $span = CDS::UI::Span->new(@_);
16660 0           $span->{bold} = 1;
16661 0           return $span;
16662             }
16663              
16664             sub underlined {
16665 0     0     my $o = shift;
16666              
16667 0           my $span = CDS::UI::Span->new(@_);
16668 0           $span->{underlined} = 1;
16669 0           return $span;
16670             }
16671              
16672             sub foreground {
16673 0     0     my $o = shift;
16674 0           my $foreground = shift;
16675              
16676 0           my $span = CDS::UI::Span->new(@_);
16677 0           $span->{foreground} = $foreground;
16678 0           return $span;
16679             }
16680              
16681             sub background {
16682 0     0     my $o = shift;
16683 0           my $background = shift;
16684              
16685 0           my $span = CDS::UI::Span->new(@_);
16686 0           $span->{background} = $background;
16687 0           return $span;
16688             }
16689              
16690             sub red {
16691 0     0     my $o = shift;
16692 0           $o->foreground(196, @_) } # for failure
16693             sub green {
16694 0     0     my $o = shift;
16695 0           $o->foreground(40, @_) } # for success
16696             sub orange {
16697 0     0     my $o = shift;
16698 0           $o->foreground(166, @_) } # for warnings
16699             sub blue {
16700 0     0     my $o = shift;
16701 0           $o->foreground(33, @_) } # to highlight something (selection)
16702             sub violet {
16703 0     0     my $o = shift;
16704 0           $o->foreground(93, @_) } # to highlight something (selection)
16705             sub gold {
16706 0     0     my $o = shift;
16707 0           $o->foreground(238, @_) } # for commands that can be executed
16708             sub gray {
16709 0     0     my $o = shift;
16710 0           $o->foreground(246, @_) } # for additional (less important) information
16711              
16712             sub darkBold {
16713 0     0     my $o = shift;
16714              
16715 0           my $span = CDS::UI::Span->new(@_);
16716 0           $span->{bold} = 1;
16717 0           $span->{foreground} = 240;
16718 0           return $span;
16719             }
16720              
16721             ### Semantic output
16722              
16723             sub title {
16724 0     0     my $o = shift;
16725 0           $o->line($o->bold(@_)) }
16726              
16727             sub left {
16728 0     0     my $o = shift;
16729 0           my $width = shift;
16730 0           my $text = shift;
16731              
16732 0 0         return substr($text, 0, $width - 1).'…' if length $text > $width;
16733 0           return $text . ' ' x ($width - length $text);
16734             }
16735              
16736             sub right {
16737 0     0     my $o = shift;
16738 0           my $width = shift;
16739 0           my $text = shift;
16740              
16741 0 0         return substr($text, 0, $width - 1).'…' if length $text > $width;
16742 0           return ' ' x ($width - length $text) . $text;
16743             }
16744              
16745             sub keyValue {
16746 0     0     my $o = shift;
16747 0           my $key = shift;
16748 0           my $firstLine = shift;
16749              
16750 0           my $indent = $o->{valueIndent} - length $o->{indent};
16751 0 0 0       $key = substr($key, 0, $indent - 2).'…' if defined $firstLine && length $key >= $indent;
16752 0           $key .= ' ' x ($indent - length $key);
16753 0           $o->line($o->gray($key), $firstLine);
16754 0           my $noKey = ' ' x $indent;
16755 0           for my $line (@_) { $o->line($noKey, $line); }
  0            
16756 0           return;
16757             }
16758              
16759             sub command {
16760 0     0     my $o = shift;
16761 0           $o->line($o->bold(@_)) }
16762              
16763             sub verbose {
16764 0     0     my $o = shift;
16765 0 0         $o->line($o->foreground(45, @_)) if $o->{verbose} }
16766              
16767             sub pGreen {
16768 0     0     my $o = shift;
16769              
16770 0           $o->p($o->green(@_));
16771 0           return;
16772             }
16773              
16774             sub pOrange {
16775 0     0     my $o = shift;
16776              
16777 0           $o->p($o->orange(@_));
16778 0           return;
16779             }
16780              
16781             sub pRed {
16782 0     0     my $o = shift;
16783              
16784 0           $o->p($o->red(@_));
16785 0           return;
16786             }
16787              
16788             ### Warnings and errors
16789              
16790 0     0     sub hasWarning { shift->{hasWarning} }
16791 0     0     sub hasError { shift->{hasError} }
16792              
16793             sub warning {
16794 0     0     my $o = shift;
16795              
16796 0           $o->{hasWarning} = 1;
16797 0           $o->p($o->orange(@_));
16798 0           return;
16799             }
16800              
16801             sub error {
16802 0     0     my $o = shift;
16803              
16804 0           $o->{hasError} = 1;
16805 0           my $span = CDS::UI::Span->new(@_);
16806 0           $span->{background} = 196;
16807 0           $span->{foreground} = 15;
16808 0           $span->{bold} = 1;
16809 0           $o->line($span);
16810 0           return;
16811             }
16812              
16813             ### Semantic formatting
16814              
16815             sub a {
16816 0     0     my $o = shift;
16817 0           $o->underlined(@_) }
16818              
16819             ### Human readable formats
16820              
16821             sub niceBytes {
16822 0     0     my $o = shift;
16823 0           my $bytes = shift;
16824 0           my $maxLength = shift;
16825              
16826 0           my $length = length $bytes;
16827 0 0 0       my $text = defined $maxLength && $length > $maxLength ? substr($bytes, 0, $maxLength - 1).'…' : $bytes;
16828 0           $text =~ s/[\x00-\x1f\x7f-\xff]/./g;
16829 0           return $text;
16830             }
16831              
16832             sub niceFileSize {
16833 0     0     my $o = shift;
16834 0           my $fileSize = shift;
16835              
16836 0 0         return $fileSize.' bytes' if $fileSize < 1000;
16837 0 0         return sprintf('%0.1f', $fileSize / 1000).' KB' if $fileSize < 10000;
16838 0 0         return sprintf('%0.0f', $fileSize / 1000).' KB' if $fileSize < 1000000;
16839 0 0         return sprintf('%0.1f', $fileSize / 1000000).' MB' if $fileSize < 10000000;
16840 0 0         return sprintf('%0.0f', $fileSize / 1000000).' MB' if $fileSize < 1000000000;
16841 0 0         return sprintf('%0.1f', $fileSize / 1000000000).' GB' if $fileSize < 10000000000;
16842 0           return sprintf('%0.0f', $fileSize / 1000000000).' GB';
16843             }
16844              
16845             sub niceDateTimeLocal {
16846 0     0     my $o = shift;
16847 0   0       my $time = shift // time() * 1000;
16848              
16849 0           my @t = localtime($time / 1000);
16850 0           return sprintf('%04d-%02d-%02d %02d:%02d:%02d', $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0]);
16851             }
16852              
16853             sub niceDateTime {
16854 0     0     my $o = shift;
16855 0   0       my $time = shift // time() * 1000;
16856              
16857 0           my @t = gmtime($time / 1000);
16858 0           return sprintf('%04d-%02d-%02d %02d:%02d:%02d UTC', $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0]);
16859             }
16860              
16861             sub niceDate {
16862 0     0     my $o = shift;
16863 0   0       my $time = shift // time() * 1000;
16864              
16865 0           my @t = gmtime($time / 1000);
16866 0           return sprintf('%04d-%02d-%02d', $t[5] + 1900, $t[4] + 1, $t[3]);
16867             }
16868              
16869             sub niceTime {
16870 0     0     my $o = shift;
16871 0   0       my $time = shift // time() * 1000;
16872              
16873 0           my @t = gmtime($time / 1000);
16874 0           return sprintf('%02d:%02d:%02d UTC', $t[2], $t[1], $t[0]);
16875             }
16876              
16877             ### Special output
16878              
16879             sub record {
16880 0     0     my $o = shift;
16881 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
16882 0           my $storeUrl = shift;
16883 0           CDS::UI::Record->display($o, $record, $storeUrl) }
16884              
16885             sub recordChildren {
16886 0     0     my $o = shift;
16887 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
16888 0           my $storeUrl = shift;
16889              
16890 0           for my $child ($record->children) {
16891 0           CDS::UI::Record->display($o, $child, $storeUrl);
16892             }
16893             }
16894              
16895             sub selector {
16896 0     0     my $o = shift;
16897 0 0 0       my $selector = shift; die 'wrong type '.ref($selector).' for $selector' if defined $selector && ref $selector ne 'CDS::Selector';
  0            
16898 0           my $rootLabel = shift;
16899              
16900 0           my $item = $selector->document->get($selector);
16901 0 0         my $revision = $item->{revision} ? $o->green(' ', $o->niceDateTime($item->{revision})) : '';
16902              
16903 0 0         if ($selector->{id} eq 'ROOT') {
16904 0   0       $o->line($o->bold($rootLabel // 'Data tree'), $revision);
16905 0           $o->recordChildren($selector->record);
16906 0           $o->selectorChildren($selector);
16907             } else {
16908 0           my $label = $selector->label;
16909 0 0         my $labelText = length $label > 64 ? substr($label, 0, 64).'…' : $label;
16910 0           $labelText =~ s/[\x00-\x1f\x7f-\xff]/·/g;
16911 0           $o->line($o->blue($labelText), $revision);
16912              
16913 0           $o->pushIndent;
16914 0           $o->recordChildren($selector->record);
16915 0           $o->selectorChildren($selector);
16916 0           $o->popIndent;
16917             }
16918             }
16919              
16920             sub selectorChildren {
16921 0     0     my $o = shift;
16922 0 0 0       my $selector = shift; die 'wrong type '.ref($selector).' for $selector' if defined $selector && ref $selector ne 'CDS::Selector';
  0            
16923              
16924 0           for my $child (sort { $a->{id} cmp $b->{id} } $selector->children) {
  0            
16925 0           $o->selector($child);
16926             }
16927             }
16928              
16929             sub hexDump {
16930 0     0     my $o = shift;
16931 0           my $bytes = shift;
16932 0           CDS::UI::HexDump->new($o, $bytes) }
16933              
16934             package CDS::UI::HexDump;
16935              
16936             sub new {
16937 0     0     my $class = shift;
16938 0           my $ui = shift;
16939 0           my $bytes = shift;
16940              
16941 0           return bless {ui => $ui, bytes => $bytes, styleChanges => [], };
16942             }
16943              
16944 0     0     sub reset { chr(0x1b).'[0m' }
16945             sub foreground {
16946 0     0     my $o = shift;
16947 0           my $color = shift;
16948 0           chr(0x1b).'[0;38;5;'.$color.'m' }
16949              
16950             sub changeStyle {
16951 0     0     my $o = shift;
16952              
16953 0           push @{$o->{styleChanges}}, @_;
  0            
16954             }
16955              
16956             sub styleHashList {
16957 0     0     my $o = shift;
16958 0           my $offset = shift;
16959              
16960 0           my $hashesCount = unpack('L>', substr($o->{bytes}, $offset, 4));
16961 0           my $dataStart = $offset + 4 + $hashesCount * 32;
16962 0 0         return $offset if $dataStart > length $o->{bytes};
16963              
16964             # Styles
16965 0           my $darkGreen = $o->foreground(28);
16966 0           my $green0 = $o->foreground(40);
16967 0           my $green1 = $o->foreground(34);
16968              
16969             # Color the hash count
16970 0           my $pos = $offset;
16971 0           $o->changeStyle({at => $pos, style => $darkGreen, breakBefore => 1});
16972 0           $pos += 4;
16973              
16974             # Color the hashes
16975 0           my $alternate = 0;
16976 0           while ($hashesCount) {
16977 0 0         $o->changeStyle({at => $pos, style => $alternate ? $green1 : $green0, breakBefore => 1});
16978 0           $pos += 32;
16979 0           $alternate = 1 - $alternate;
16980 0           $hashesCount -= 1;
16981             }
16982              
16983 0           return $dataStart;
16984             }
16985              
16986             sub styleRecord {
16987 0     0     my $o = shift;
16988 0           my $offset = shift;
16989              
16990             # Styles
16991 0           my $blue = $o->foreground(33);
16992 0           my $black = $o->reset;
16993 0           my $violet = $o->foreground(93);
16994 0           my @styleChanges;
16995              
16996             # Prepare
16997 0           my $pos = $offset;
16998 0           my $hasError = 0;
16999 0           my $level = 0;
17000              
17001 0     0     my $use = sub { my $length = shift;
17002 0           my $start = $pos;
17003 0           $pos += $length;
17004 0 0         return substr($o->{bytes}, $start, $length) if $pos <= length $o->{bytes};
17005 0           $hasError = 1;
17006 0           return;
17007 0           };
17008              
17009 0   0 0     my $readUnsigned8 = sub { unpack('C', &$use(1) // return) };
  0            
17010 0   0 0     my $readUnsigned32 = sub { unpack('L>', &$use(4) // return) };
  0            
17011 0   0 0     my $readUnsigned64 = sub { unpack('Q>', &$use(8) // return) };
  0            
17012              
17013             # Parse all record nodes
17014 0           while ($level >= 0) {
17015             # Flags
17016 0           push @styleChanges, {at => $pos, style => $blue, breakBefore => 1};
17017 0   0       my $flags = &$readUnsigned8 // last;
17018              
17019             # Data
17020 0           my $length = $flags & 0x1f;
17021 0 0 0       my $byteLength = $length == 30 ? 30 + (&$readUnsigned8 // last) : $length == 31 ? (&$readUnsigned64 // last) : $length;
    0 0        
17022              
17023 0 0         if ($byteLength) {
17024 0           push @styleChanges, {at => $pos, style => $black};
17025 0   0       &$use($byteLength) // last;
17026             }
17027              
17028 0 0         if ($flags & 0x20) {
17029 0           push @styleChanges, {at => $pos, style => $violet};
17030 0   0       &$readUnsigned32 // last;
17031             }
17032              
17033             # Children
17034 0 0         $level += 1 if $flags & 0x40;
17035 0 0         $level -= 1 if ! ($flags & 0x80);
17036             }
17037              
17038             # Don't apply any styles if there are errors
17039 0 0         $hasError = 1 if $pos != length $o->{bytes};
17040 0 0         return $offset if $hasError;
17041              
17042 0           $o->changeStyle(@styleChanges);
17043 0           return $pos;
17044             }
17045              
17046             sub display {
17047 0     0     my $o = shift;
17048              
17049 0           $o->{ui}->valueIndent(8);
17050              
17051 0           my $resetStyle = chr(0x1b).'[0m';
17052 0           my $length = length($o->{bytes});
17053 0           my $lineStart = 0;
17054 0           my $currentStyle = '';
17055              
17056 0           my @styleChanges = sort { $a->{at} <=> $b->{at} } @{$o->{styleChanges}};
  0            
  0            
17057 0           push @styleChanges, {at => $length};
17058 0           my $nextChange = shift(@styleChanges);
17059              
17060 0           $o->{ui}->line($o->{ui}->gray('···· 0 1 2 3 4 5 6 7 8 9 a b c d e f 0123456789abcdef'));
17061 0           while ($lineStart < $length) {
17062 0           my $hexLine = $currentStyle;
17063 0           my $textLine = $currentStyle;
17064              
17065 0           my $k = 0;
17066 0           while ($k < 16) {
17067 0           my $index = $lineStart + $k;
17068 0 0         last if $index >= $length;
17069              
17070 0           my $break = 0;
17071 0           while ($index >= $nextChange->{at}) {
17072 0           $currentStyle = $nextChange->{style};
17073 0   0       $break = $nextChange->{breakBefore} && $k > 0;
17074 0           $hexLine .= $currentStyle;
17075 0           $textLine .= $currentStyle;
17076 0           $nextChange = shift @styleChanges;
17077 0 0         last if $break;
17078             }
17079              
17080 0 0         last if $break;
17081              
17082 0           my $byte = substr($o->{bytes}, $lineStart + $k, 1);
17083 0           $hexLine .= ' '.unpack('H*', $byte);
17084              
17085 0           my $code = ord($byte);
17086 0 0 0       $textLine .= $code >= 32 && $code <= 126 ? $byte : '·';
17087              
17088 0           $k += 1;
17089             }
17090              
17091 0           $hexLine .= ' ' x (16 - $k);
17092 0           $textLine .= ' ' x (16 - $k);
17093 0           $o->{ui}->line($o->{ui}->gray(unpack('H4', pack('S>', $lineStart))), ' ', $hexLine, $resetStyle, ' ', $textLine, $resetStyle);
17094              
17095 0           $lineStart += $k;
17096             }
17097             }
17098              
17099             package CDS::UI::ProgressStore;
17100              
17101 1     1   4941 use parent -norequire, 'CDS::Store';
  1         2  
  1         5  
17102              
17103             sub new {
17104 0     0     my $class = shift;
17105 0           my $store = shift;
17106 0           my $url = shift;
17107 0           my $ui = shift;
17108              
17109 0           return bless {
17110             store => $store,
17111             url => $url,
17112             ui => $ui,
17113             }
17114             }
17115              
17116 0     0     sub store { shift->{store} }
17117 0     0     sub url { shift->{url} }
17118 0     0     sub ui { shift->{ui} }
17119              
17120             sub id {
17121 0     0     my $o = shift;
17122 0           'Progress'."\n ".$o->{store}->id }
17123              
17124             ### Object store functions
17125              
17126             sub get {
17127 0     0     my $o = shift;
17128 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
17129 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
17130              
17131 0           $o->{ui}->progress('GET ', $hash->shortHex, ' on ', $o->{url});
17132 0           return $o->{store}->get($hash, $keyPair);
17133             }
17134              
17135             sub book {
17136 0     0     my $o = shift;
17137 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
17138 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
17139              
17140 0           $o->{ui}->progress('BOOK ', $hash->shortHex, ' on ', $o->{url});
17141 0           return $o->{store}->book($hash, $keyPair);
17142             }
17143              
17144             sub put {
17145 0     0     my $o = shift;
17146 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
17147 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
17148 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
17149              
17150 0           $o->{ui}->progress('PUT ', $hash->shortHex, ' (', $o->{ui}->niceFileSize($object->byteLength), ') on ', $o->{url});
17151 0           return $o->{store}->put($hash, $object, $keyPair);
17152             }
17153              
17154             ### Account store functions
17155              
17156             sub list {
17157 0     0     my $o = shift;
17158 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
17159 0           my $boxLabel = shift;
17160 0           my $timeout = shift;
17161 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
17162              
17163 0 0         $o->{ui}->progress($timeout == 0 ? 'LIST ' : 'WATCH ', $boxLabel, ' of ', $accountHash->shortHex, ' on ', $o->{url});
17164 0           return $o->{store}->list($accountHash, $boxLabel, $timeout, $keyPair);
17165             }
17166              
17167             sub add {
17168 0     0     my $o = shift;
17169 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
17170 0           my $boxLabel = shift;
17171 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
17172 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
17173              
17174 0           $o->{ui}->progress('ADD ', $accountHash->shortHex, ' ', $boxLabel, ' ', $hash->shortHex, ' on ', $o->{url});
17175 0           return $o->{store}->add($accountHash, $boxLabel, $hash, $keyPair);
17176             }
17177              
17178             sub remove {
17179 0     0     my $o = shift;
17180 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
17181 0           my $boxLabel = shift;
17182 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
17183 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
17184              
17185 0           $o->{ui}->progress('REMOVE ', $accountHash->shortHex, ' ', $boxLabel, ' ', $hash->shortHex, ' on ', $o->{url});
17186 0           return $o->{store}->remove($accountHash, $boxLabel, $hash, $keyPair);
17187             }
17188              
17189             sub modify {
17190 0     0     my $o = shift;
17191 0           my $modifications = shift;
17192 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
17193              
17194 0           $o->{ui}->progress('MODIFY +', scalar @{$modifications->additions}, ' -', scalar @{$modifications->removals}, ' on ', $o->{url});
  0            
  0            
17195 0           return $o->{store}->modify($modifications, $keyPair);
17196             }
17197              
17198             # Displays a record, and tries to guess the byte interpretation
17199             package CDS::UI::Record;
17200              
17201             sub display {
17202 0     0     my $class = shift;
17203 0           my $ui = shift;
17204 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
17205 0           my $storeUrl = shift;
17206              
17207 0 0         my $o = bless {
17208             ui => $ui,
17209             onStore => defined $storeUrl ? $ui->gray(' on ', $storeUrl) : '',
17210             };
17211              
17212 0           $o->record($record, '');
17213             }
17214              
17215             sub record {
17216 0     0     my $o = shift;
17217 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
17218 0           my $context = shift;
17219              
17220 0           my $bytes = $record->bytes;
17221 0           my $hash = $record->hash;
17222 0           my @children = $record->children;
17223              
17224             # Try to interpret the key / value pair with a set of heuristic rules
17225             my @value =
17226             ! length $bytes && $hash ? ($o->{ui}->gold('cds show record '), $hash->hex, $o->{onStore}) :
17227             ! length $bytes ? $o->{ui}->gray('empty') :
17228 0 0 0       length $bytes == 32 && $hash ? ($o->{ui}->gold('cds show record '), $hash->hex, $o->{onStore}, $o->{ui}->gold(' decrypted with ', unpack('H*', $bytes))) :
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
17229             $context eq 'e' ? $o->hexValue($bytes) :
17230             $context eq 'n' ? $o->hexValue($bytes) :
17231             $context eq 'p' ? $o->hexValue($bytes) :
17232             $context eq 'q' ? $o->hexValue($bytes) :
17233             $context eq 'encrypted for' ? $o->hexValue($bytes) :
17234             $context eq 'updated by' ? $o->hexValue($bytes) :
17235             $context =~ /(^| )id( |$)/ ? $o->hexValue($bytes) :
17236             $context =~ /(^| )key( |$)/ ? $o->hexValue($bytes) :
17237             $context =~ /(^| )signature( |$)/ ? $o->hexValue($bytes) :
17238             $context =~ /(^| )revision( |$)/ ? $o->revisionValue($bytes) :
17239             $context =~ /(^| )date( |$)/ ? $o->dateValue($bytes) :
17240             $context =~ /(^| )expires( |$)/ ? $o->dateValue($bytes) :
17241             $o->guessValue($bytes);
17242              
17243 0 0 0       push @value, ' ', $o->{ui}->blue($hash->hex), $o->{onStore} if $hash && ($bytes && length $bytes != 32);
      0        
17244 0           $o->{ui}->line(@value);
17245              
17246             # Children
17247 0           $o->{ui}->pushIndent;
17248 0           for my $child (@children) { $o->record($child, $bytes); }
  0            
17249 0           $o->{ui}->popIndent;
17250             }
17251              
17252             sub hexValue {
17253 0     0     my $o = shift;
17254 0           my $bytes = shift;
17255              
17256 0           my $length = length $bytes;
17257 0 0         return '#'.unpack('H*', substr($bytes, 0, $length)) if $length <= 64;
17258 0           return '#'.unpack('H*', substr($bytes, 0, 64)), '…', $o->{ui}->gray(' (', $length, ' bytes)');
17259             }
17260              
17261             sub guessValue {
17262 0     0     my $o = shift;
17263 0           my $bytes = shift;
17264              
17265 0           my $length = length $bytes;
17266 0 0         my $text = $length > 64 ? substr($bytes, 0, 64).'…' : $bytes;
17267 0           $text =~ s/[\x00-\x1f\x7f-\xff]/·/g;
17268 0           my @value = ($text);
17269              
17270 0 0         if ($length <= 8) {
17271 0           my $integer = CDS->integerFromBytes($bytes);
17272 0 0         push @value, $o->{ui}->gray(' = ', $integer, $o->looksLikeTimestamp($integer) ? ' = '.$o->{ui}->niceDateTime($integer).' = '.$o->{ui}->niceDateTimeLocal($integer) : '');
17273             }
17274              
17275 0 0 0       push @value, $o->{ui}->gray(' = ', CDS->floatFromBytes($bytes)) if $length == 4 || $length == 8;
17276 0 0         push @value, $o->{ui}->gray(' = ', CDS::Hash->fromBytes($bytes)->hex) if $length == 32;
17277 0 0         push @value, $o->{ui}->gray(' (', length $bytes, ' bytes)') if length $bytes > 64;
17278 0           return @value;
17279             }
17280              
17281             sub dateValue {
17282 0     0     my $o = shift;
17283 0           my $bytes = shift;
17284              
17285 0           my $integer = CDS->integerFromBytes($bytes);
17286 0 0         return $integer if ! $o->looksLikeTimestamp($integer);
17287 0           return $o->{ui}->niceDateTime($integer), ' ', $o->{ui}->gray($o->{ui}->niceDateTimeLocal($integer));
17288             }
17289              
17290             sub revisionValue {
17291 0     0     my $o = shift;
17292 0           my $bytes = shift;
17293              
17294 0           my $integer = CDS->integerFromBytes($bytes);
17295 0 0         return $integer if ! $o->looksLikeTimestamp($integer);
17296 0           return $o->{ui}->niceDateTime($integer);
17297             }
17298              
17299             sub looksLikeTimestamp {
17300 0     0     my $o = shift;
17301 0           my $integer = shift;
17302              
17303 0   0       return $integer > 100000000000 && $integer < 10000000000000;
17304             }
17305              
17306             package CDS::UI::Span;
17307              
17308             sub new {
17309 0     0     my $class = shift;
17310              
17311 0           return bless {
17312             text => [@_],
17313             };
17314             }
17315              
17316             sub printTo {
17317 0     0     my $o = shift;
17318 0           my $ui = shift;
17319 0           my $parent = shift;
17320              
17321 0 0         if ($parent) {
17322 0   0       $o->{appliedForeground} = $o->{foreground} // $parent->{appliedForeground};
17323 0   0       $o->{appliedBackground} = $o->{background} // $parent->{appliedBackground};
17324 0   0       $o->{appliedBold} = $o->{bold} // $parent->{appliedBold} // 0;
      0        
17325 0   0       $o->{appliedUnderlined} = $o->{underlined} // $parent->{appliedUnderlined} // 0;
      0        
17326             } else {
17327 0           $o->{appliedForeground} = $o->{foreground};
17328 0           $o->{appliedBackground} = $o->{background};
17329 0   0       $o->{appliedBold} = $o->{bold} // 0;
17330 0   0       $o->{appliedUnderlined} = $o->{underlined} // 0;
17331             }
17332              
17333 0           my $style = chr(0x1b).'[0';
17334 0 0         $style .= ';1' if $o->{appliedBold};
17335 0 0         $style .= ';4' if $o->{appliedUnderlined};
17336 0 0         $style .= ';38;5;'.$o->{appliedForeground} if defined $o->{appliedForeground};
17337 0 0         $style .= ';48;5;'.$o->{appliedBackground} if defined $o->{appliedBackground};
17338 0           $style .= 'm';
17339              
17340 0           my $needStyle = 1;
17341 0           for my $child (@{$o->{text}}) {
  0            
17342 0           my $ref = ref $child;
17343 0 0         if ($ref eq 'CDS::UI::Span') {
    0          
    0          
17344 0           $child->printTo($ui, $o);
17345 0           $needStyle = 1;
17346 0           next;
17347             } elsif (length $ref) {
17348 0           warn 'Printing REF';
17349 0           $child = $ref;
17350             } elsif (! defined $child) {
17351 0           warn 'Printing UNDEF';
17352 0           $child = 'UNDEF';
17353             }
17354              
17355 0 0         if ($needStyle) {
17356 0           $ui->print($style);
17357 0           $needStyle = 0;
17358             }
17359              
17360 0           $ui->print($child);
17361             }
17362             }
17363              
17364             sub wordWrap {
17365 0     0     my $o = shift;
17366 0           my $state = shift;
17367              
17368 0           my $index = -1;
17369 0           for my $child (@{$o->{text}}) {
  0            
17370 0           $index += 1;
17371              
17372 0 0         next if ! defined $child;
17373              
17374 0           my $ref = ref $child;
17375 0 0         if ($ref eq 'CDS::UI::Span') {
    0          
    0          
17376 0           $child->wordWrap($state);
17377 0           next;
17378             } elsif (length $ref) {
17379 0           warn 'Printing REF';
17380 0           $child = $ref;
17381             } elsif (! defined $child) {
17382 0           warn 'Printing UNDEF';
17383 0           $child = 'UNDEF';
17384             }
17385              
17386 0           my $position = -1;
17387 0           for my $char (split //, $child) {
17388 0           $position += 1;
17389 0           $state->{lineLength} += 1;
17390 0 0 0       if ($char eq ' ' || $char eq "\t") {
    0 0        
17391 0           $state->{wrapSpan} = $o;
17392 0           $state->{wrapIndex} = $index;
17393 0           $state->{wrapPosition} = $position;
17394 0           $state->{wrapReturn} = $state->{lineLength};
17395             } elsif ($state->{wrapSpan} && $state->{lineLength} > $state->{maxLength}) {
17396 0           my $text = $state->{wrapSpan}->{text}->[$state->{wrapIndex}];
17397 0           $text = substr($text, 0, $state->{wrapPosition})."\n".$state->{indent}.substr($text, $state->{wrapPosition} + 1);
17398 0           $state->{wrapSpan}->{text}->[$state->{wrapIndex}] = $text;
17399 0           $state->{lineLength} -= $state->{wrapReturn};
17400 0 0 0       $position += length $state->{indent} if $state->{wrapSpan} == $o && $state->{wrapIndex} == $index;
17401 0           $state->{wrapSpan} = undef;
17402             }
17403             }
17404             }
17405             }
17406              
17407             package CDS::UnionList;
17408              
17409             sub new {
17410 0     0     my $class = shift;
17411 0           my $privateRoot = shift;
17412 0           my $label = shift;
17413              
17414 0           my $o = bless {
17415             privateRoot => $privateRoot,
17416             label => $label,
17417             unsaved => CDS::Unsaved->new($privateRoot->unsaved),
17418             items => {},
17419             parts => {},
17420             hasPartsToMerge => 0,
17421             }, $class;
17422              
17423 0           $o->{unused} = CDS::UnionList::Part->new;
17424 0           $o->{changes} = CDS::UnionList::Part->new;
17425 0           $privateRoot->addDataHandler($label, $o);
17426 0           return $o;
17427             }
17428              
17429 0     0     sub privateRoot { shift->{privateRoot} }
17430 0     0     sub unsaved { shift->{unsaved} }
17431             sub items {
17432 0     0     my $o = shift;
17433 0           values %{$o->{items}} }
  0            
17434             sub parts {
17435 0     0     my $o = shift;
17436 0           values %{$o->{parts}} }
  0            
17437              
17438             sub get {
17439 0     0     my $o = shift;
17440 0           my $id = shift;
17441 0           $o->{items}->{$id} }
17442              
17443             sub getOrCreate {
17444 0     0     my $o = shift;
17445 0           my $id = shift;
17446              
17447 0           my $item = $o->{items}->{$id};
17448 0 0         return $item if $item;
17449 0           my $newItem = $o->createItem($id);
17450 0           $o->{items}->{$id} = $newItem;
17451 0           return $newItem;
17452             }
17453              
17454             # abstract sub createItem($o, $id)
17455             # abstract sub forgetObsoleteItems($o)
17456              
17457             sub forget {
17458 0     0     my $o = shift;
17459 0           my $id = shift;
17460              
17461 0   0       my $item = $o->{items}->{$id} // return;
17462 0           $item->{part}->{count} -= 1;
17463 0           delete $o->{items}->{$id};
17464             }
17465              
17466             sub forgetItem {
17467 0     0     my $o = shift;
17468 0           my $item = shift;
17469              
17470 0           $item->{part}->{count} -= 1;
17471 0           delete $o->{items}->{$item->id};
17472             }
17473              
17474             # *** MergeableData interface
17475              
17476             sub addDataTo {
17477 0     0     my $o = shift;
17478 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
17479              
17480 0           for my $part (sort { $a->{hashAndKey}->hash->bytes cmp $b->{hashAndKey}->hash->bytes } values %{$o->{parts}}) {
  0            
  0            
17481 0           $record->addHashAndKey($part->{hashAndKey});
17482             }
17483             }
17484              
17485             sub mergeData {
17486 0     0     my $o = shift;
17487 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
17488              
17489 0           my @hashesAndKeys;
17490 0           for my $child ($record->children) {
17491 0   0       push @hashesAndKeys, $child->asHashAndKey // next;
17492             }
17493              
17494 0           $o->merge(@hashesAndKeys);
17495             }
17496              
17497             sub mergeExternalData {
17498 0     0     my $o = shift;
17499 0           my $store = shift;
17500 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
17501 0 0 0       my $source = shift; die 'wrong type '.ref($source).' for $source' if defined $source && ref $source ne 'CDS::Source';
  0            
17502              
17503 0           my @hashes;
17504             my @hashesAndKeys;
17505 0           for my $child ($record->children) {
17506 0   0       my $hashAndKey = $child->asHashAndKey // next;
17507 0 0         next if $o->{parts}->{$hashAndKey->hash->bytes};
17508 0           push @hashes, $hashAndKey->hash;
17509 0           push @hashesAndKeys, $hashAndKey;
17510             }
17511              
17512 0           my $keyPair = $o->{privateRoot}->privateBoxReader->keyPair;
17513 0           my ($missing, $transferStore, $storeError) = $keyPair->transfer([@hashes], $store, $o->{privateRoot}->unsaved);
17514 0 0         return if defined $storeError;
17515 0 0         return if $missing;
17516              
17517 0 0         if ($source) {
17518 0           $source->keep;
17519 0           $o->{privateRoot}->unsaved->state->addMergedSource($source);
17520             }
17521              
17522 0           $o->merge(@hashesAndKeys);
17523 0           return 1;
17524             }
17525              
17526             sub merge {
17527 0     0     my $o = shift;
17528              
17529 0           for my $hashAndKey (@_) {
17530 0 0         next if ! $hashAndKey;
17531 0 0         next if $o->{parts}->{$hashAndKey->hash->bytes};
17532 0           my $part = CDS::UnionList::Part->new;
17533 0           $part->{hashAndKey} = $hashAndKey;
17534 0           $o->{parts}->{$hashAndKey->hash->bytes} = $part;
17535 0           $o->{hasPartsToMerge} = 1;
17536             }
17537             }
17538              
17539             # *** Reading
17540              
17541             sub read {
17542 0     0     my $o = shift;
17543              
17544 0 0         return 1 if ! $o->{hasPartsToMerge};
17545              
17546             # Load the parts
17547 0           for my $part (values %{$o->{parts}}) {
  0            
17548 0 0         next if $part->{isMerged};
17549 0 0         next if $part->{loadedRecord};
17550              
17551 0           my ($record, $object, $invalidReason, $storeError) = $o->{privateRoot}->privateBoxReader->keyPair->getAndDecryptRecord($part->{hashAndKey}, $o->{privateRoot}->unsaved);
17552 0 0         return if defined $storeError;
17553              
17554 0 0         delete $o->{parts}->{$part->{hashAndKey}->hash->bytes} if defined $invalidReason;
17555 0           $part->{loadedRecord} = $record;
17556             }
17557              
17558             # Merge the loaded parts
17559 0           for my $part (values %{$o->{parts}}) {
  0            
17560 0 0         next if $part->{isMerged};
17561 0 0         next if ! $part->{loadedRecord};
17562              
17563             # Merge
17564 0           for my $child ($part->{loadedRecord}->children) {
17565 0           $o->mergeRecord($part, $child);
17566             }
17567              
17568 0           delete $part->{loadedRecord};
17569 0           $part->{isMerged} = 1;
17570             }
17571              
17572 0           $o->{hasPartsToMerge} = 0;
17573 0           return 1;
17574             }
17575              
17576             # abstract sub mergeRecord($o, $part, $record)
17577              
17578             # *** Saving
17579              
17580             sub hasChanges {
17581 0     0     my $o = shift;
17582 0           $o->{changes}->{count} > 0 }
17583              
17584             sub save {
17585 0     0     my $o = shift;
17586              
17587 0           $o->forgetObsoleteItems;
17588 0           $o->{unsaved}->startSaving;
17589              
17590 0 0         if ($o->{changes}->{count}) {
17591             # Take the changes
17592 0           my $newPart = $o->{changes};
17593 0           $o->{changes} = CDS::UnionList::Part->new;
17594              
17595             # Add all changes
17596 0           my $record = CDS::Record->new;
17597 0           for my $item (values %{$o->{items}}) {
  0            
17598 0 0         next if $item->{part} != $newPart;
17599 0           $item->addToRecord($record);
17600             }
17601              
17602             # Select all parts smaller than 2 * count elements
17603 0           my $count = $newPart->{count};
17604 0           while (1) {
17605 0           my $addedPart = 0;
17606 0           for my $part (values %{$o->{parts}}) {
  0            
17607 0 0 0       next if ! $part->{isMerged} || $part->{selected} || $part->{count} >= $count * 2;
      0        
17608 0           $count += $part->{count};
17609 0           $part->{selected} = 1;
17610 0           $addedPart = 1;
17611             }
17612              
17613 0 0         last if ! $addedPart;
17614             }
17615              
17616             # Include the selected items
17617 0           for my $item (values %{$o->{items}}) {
  0            
17618 0 0         next if ! $item->{part}->{selected};
17619 0           $item->setPart($newPart);
17620 0           $item->addToRecord($record);
17621             }
17622              
17623             # Serialize the new part
17624 0           my $key = CDS->randomKey;
17625 0           my $newObject = $record->toObject->crypt($key);
17626 0           my $newHash = $newObject->calculateHash;
17627 0           $newPart->{hashAndKey} = CDS::HashAndKey->new($newHash, $key);
17628 0           $newPart->{isMerged} = 1;
17629 0           $o->{parts}->{$newHash->bytes} = $newPart;
17630 0           $o->{privateRoot}->unsaved->state->addObject($newHash, $newObject);
17631 0           $o->{privateRoot}->dataChanged;
17632             }
17633              
17634             # Remove obsolete parts
17635 0           for my $part (values %{$o->{parts}}) {
  0            
17636 0 0         next if ! $part->{isMerged};
17637 0 0         next if $part->{count};
17638 0           delete $o->{parts}->{$part->{hashAndKey}->hash->bytes};
17639 0           $o->{privateRoot}->dataChanged;
17640             }
17641              
17642             # Propagate the unsaved state
17643 0           $o->{privateRoot}->unsaved->state->merge($o->{unsaved}->savingState);
17644 0           $o->{unsaved}->savingDone;
17645 0           return 1;
17646             }
17647              
17648             package CDS::UnionList::Item;
17649              
17650             sub new {
17651 0     0     my $class = shift;
17652 0           my $unionList = shift;
17653 0           my $id = shift;
17654              
17655 0           $unionList->{unused}->{count} += 1;
17656             return bless {
17657             unionList => $unionList,
17658             id => $id,
17659             part => $unionList->{unused},
17660 0           }, $class;
17661             }
17662              
17663 0     0     sub unionList { shift->{unionList} }
17664 0     0     sub id { shift->{id} }
17665              
17666             sub setPart {
17667 0     0     my $o = shift;
17668 0           my $part = shift;
17669              
17670 0           $o->{part}->{count} -= 1;
17671 0           $o->{part} = $part;
17672 0           $o->{part}->{count} += 1;
17673             }
17674              
17675             # abstract sub addToRecord($o, $record)
17676              
17677             package CDS::UnionList::Part;
17678              
17679             sub new {
17680 0     0     my $class = shift;
17681              
17682 0           return bless {
17683             isMerged => 0,
17684             hashAndKey => undef,
17685             size => 0,
17686             count => 0,
17687             selected => 0,
17688             };
17689             }
17690              
17691             package CDS::Unsaved;
17692              
17693 1     1   4058 use parent -norequire, 'CDS::Store';
  1         2  
  1         4  
17694              
17695             sub new {
17696 0     0     my $class = shift;
17697 0           my $store = shift;
17698              
17699 0           return bless {
17700             state => CDS::Unsaved::State->new,
17701             savingState => undef,
17702             store => $store,
17703             };
17704             }
17705              
17706 0     0     sub state { shift->{state} }
17707 0     0     sub savingState { shift->{savingState} }
17708              
17709             # *** Saving, state propagation
17710              
17711             sub isSaving {
17712 0     0     my $o = shift;
17713 0           defined $o->{savingState} }
17714              
17715             sub startSaving {
17716 0     0     my $o = shift;
17717              
17718 0 0         die 'Start saving, but already saving' if $o->{savingState};
17719 0           $o->{savingState} = $o->{state};
17720 0           $o->{state} = CDS::Unsaved::State->new;
17721             }
17722              
17723             sub savingDone {
17724 0     0     my $o = shift;
17725              
17726 0 0         die 'Not in saving state' if ! $o->{savingState};
17727 0           $o->{savingState} = undef;
17728             }
17729              
17730             sub savingFailed {
17731 0     0     my $o = shift;
17732              
17733 0 0         die 'Not in saving state' if ! $o->{savingState};
17734 0           $o->{state}->merge($o->{savingState});
17735 0           $o->{savingState} = undef;
17736             }
17737              
17738             # *** Store interface
17739              
17740             sub id {
17741 0     0     my $o = shift;
17742 0           'Unsaved'."\n".unpack('H*', CDS->randomBytes(16))."\n".$o->{store}->id }
17743              
17744             sub get {
17745 0     0     my $o = shift;
17746 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
17747 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
17748              
17749 0           my $stateObject = $o->{state}->{objects}->{$hash->bytes};
17750 0 0         return $stateObject->{object} if $stateObject;
17751              
17752 0 0         if ($o->{savingState}) {
17753 0           my $savingStateObject = $o->{savingState}->{objects}->{$hash->bytes};
17754 0 0         return $savingStateObject->{object} if $savingStateObject;
17755             }
17756              
17757 0           return $o->{store}->get($hash, $keyPair);
17758             }
17759              
17760             sub book {
17761 0     0     my $o = shift;
17762 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
17763 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
17764              
17765 0           return $o->{store}->book($hash, $keyPair);
17766             }
17767              
17768             sub put {
17769 0     0     my $o = shift;
17770 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
17771 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
17772 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
17773              
17774 0           return $o->{store}->put($hash, $object, $keyPair);
17775             }
17776              
17777             sub list {
17778 0     0     my $o = shift;
17779 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
17780 0           my $boxLabel = shift;
17781 0           my $timeout = shift;
17782 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
17783              
17784 0           return $o->{store}->list($accountHash, $boxLabel, $timeout, $keyPair);
17785             }
17786              
17787             sub modify {
17788 0     0     my $o = shift;
17789 0           my $additions = shift;
17790 0           my $removals = shift;
17791 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
17792              
17793 0           return $o->{store}->modify($additions, $removals, $keyPair);
17794             }
17795              
17796             package CDS::Unsaved::State;
17797              
17798             sub new {
17799 0     0     my $class = shift;
17800              
17801 0           return bless {
17802             objects => {},
17803             mergedSources => [],
17804             dataSavedHandlers => [],
17805             };
17806             }
17807              
17808 0     0     sub objects { shift->{objects} }
17809             sub mergedSources {
17810 0     0     my $o = shift;
17811 0           @{$o->{mergedSources}} }
  0            
17812             sub dataSavedHandlers {
17813 0     0     my $o = shift;
17814 0           @{$o->{dataSavedHandlers}} }
  0            
17815              
17816             sub addObject {
17817 0     0     my $o = shift;
17818 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
17819 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
17820              
17821 0           $o->{objects}->{$hash->bytes} = {hash => $hash, object => $object};
17822             }
17823              
17824             sub addMergedSource {
17825 0     0     my $o = shift;
17826              
17827 0           push @{$o->{mergedSources}}, @_;
  0            
17828             }
17829              
17830             sub addDataSavedHandler {
17831 0     0     my $o = shift;
17832              
17833 0           push @{$o->{dataSavedHandlers}}, @_;
  0            
17834             }
17835              
17836             sub merge {
17837 0     0     my $o = shift;
17838 0           my $state = shift;
17839              
17840 0           for my $key (keys %{$state->{objects}}) {
  0            
17841 0           $o->{objects}->{$key} = $state->{objects}->{$key};
17842             }
17843              
17844 0           push @{$o->{mergedSources}}, @{$state->{mergedSources}};
  0            
  0            
17845 0           push @{$o->{dataSavedHandlers}}, @{$state->{dataSavedHandlers}};
  0            
  0            
17846             }