File Coverage

blib/lib/CDS.pm
Criterion Covered Total %
statement 119 11142 1.0
branch 3 3154 0.1
condition 1 2196 0.0
subroutine 39 1541 2.5
pod 0 36 0.0
total 162 18069 0.9


line stmt bran cond sub pod time code
1             # This is part of the Condensation Perl Module 0.31 (cli) built on 2022-12-08.
2             # See https://condensation.io for information about the Condensation Data System.
3              
4 1     1   68808 use strict;
  1         2  
  1         29  
5 1     1   6 use warnings;
  1         1  
  1         22  
6 1     1   24 use 5.010000;
  1         3  
7 1     1   716 use CDS::C;
  1         2  
  1         44  
8              
9             =pod
10              
11             =head1 CDS - Condensation Data System
12              
13             Condensation is a general-purpose distributed data system with conflict-free synchronization, and inherent end-to-end security.
14              
15             This is the Perl implementation. It comes with a Perl module:
16              
17             use CDS;
18              
19             and a command line tool:
20              
21             cds
22              
23             More information is available on L.
24              
25             =cut
26              
27 1     1   6 use Cwd;
  1         2  
  1         49  
28 1     1   811 use Digest::SHA;
  1         2929  
  1         46  
29 1     1   525 use Encode;
  1         14905  
  1         86  
30 1     1   7 use Fcntl;
  1         2  
  1         226  
31 1     1   474 use HTTP::Date;
  1         3940  
  1         56  
32 1     1   480 use HTTP::Headers;
  1         6628  
  1         37  
33 1     1   439 use HTTP::Request;
  1         15151  
  1         30  
34 1     1   505 use HTTP::Server::Simple;
  1         17880  
  1         34  
35 1     1   646 use LWP::UserAgent;
  1         23938  
  1         34  
36 1     1   6 use Time::Local;
  1         2  
  1         52  
37 1     1   608 use utf8;
  1         30  
  1         9  
38             package CDS;
39              
40             our $VERSION = '0.31';
41             our $edition = 'cli';
42             our $releaseDate = '2022-12-08';
43              
44 0     0 0 0 sub now { time * 1000 }
45              
46 0     0 0 0 sub SECOND { 1000 }
47 0     0 0 0 sub MINUTE { 60 * 1000 }
48 0     0 0 0 sub HOUR { 60 * 60 * 1000 }
49 0     0 0 0 sub DAY { 24 * 60 * 60 * 1000 }
50 0     0 0 0 sub WEEK { 7 * 24 * 60 * 60 * 1000 }
51 0     0 0 0 sub MONTH { 30 * 24 * 60 * 60 * 1000 }
52 0     0 0 0 sub YEAR { 365 * 24 * 60 * 60 * 1000 }
53              
54             # File system utility functions.
55              
56             sub readBytesFromFile {
57 0     0 0 0 my $class = shift;
58 0         0 my $filename = shift;
59              
60 0 0       0 open(my $fh, '<:bytes', $filename) || return;
61 0         0 local $/;
62 0         0 my $content = <$fh>;
63 0         0 close $fh;
64 0         0 return $content;
65             }
66              
67             sub writeBytesToFile {
68 0     0 0 0 my $class = shift;
69 0         0 my $filename = shift;
70              
71 0 0       0 open(my $fh, '>:bytes', $filename) || return;
72 0         0 print $fh @_;
73 0         0 close $fh;
74 0         0 return 1;
75             }
76              
77             sub readTextFromFile {
78 0     0 0 0 my $class = shift;
79 0         0 my $filename = shift;
80              
81 0 0       0 open(my $fh, '<:utf8', $filename) || return;
82 0         0 local $/;
83 0         0 my $content = <$fh>;
84 0         0 close $fh;
85 0         0 return $content;
86             }
87              
88             sub writeTextToFile {
89 0     0 0 0 my $class = shift;
90 0         0 my $filename = shift;
91              
92 0 0       0 open(my $fh, '>:utf8', $filename) || return;
93 0         0 print $fh @_;
94 0         0 close $fh;
95 0         0 return 1;
96             }
97              
98             sub listFolder {
99 0     0 0 0 my $class = shift;
100 0         0 my $folder = shift;
101              
102 0 0       0 opendir(my $dh, $folder) || return;
103 0         0 my @files = readdir $dh;
104 0         0 closedir $dh;
105 0         0 return @files;
106             }
107              
108             sub intermediateFolders {
109 0     0 0 0 my $class = shift;
110 0         0 my $path = shift;
111              
112 0         0 my @paths = ($path);
113 0         0 while (1) {
114 0 0       0 $path =~ /^(.+)\/(.*?)$/ || last;
115 0         0 $path = $1;
116 0 0       0 next if ! length $2;
117 0         0 unshift @paths, $path;
118             }
119 0         0 return @paths;
120             }
121              
122             # This is for debugging purposes only.
123             sub log {
124 0     0 0 0 my $class = shift;
125              
126 0         0 print STDERR @_, "\n";
127             }
128              
129             sub min {
130 0     0 0 0 my $class = shift;
131              
132 0         0 my $min = shift;
133 0         0 for my $number (@_) {
134 0 0       0 $min = $min < $number ? $min : $number;
135             }
136              
137 0         0 return $min;
138             }
139              
140             sub max {
141 0     0 0 0 my $class = shift;
142              
143 0         0 my $max = shift;
144 0         0 for my $number (@_) {
145 0 0       0 $max = $max > $number ? $max : $number;
146             }
147              
148 0         0 return $max;
149             }
150              
151             sub booleanCompare {
152 0     0 0 0 my $class = shift;
153 0         0 my $a = shift;
154 0         0 my $b = shift;
155 0 0 0     0 $a && $b ? 0 : $a ? 1 : $b ? -1 : 0 }
    0          
    0          
156              
157             # Utility functions for random sequences
158              
159             srand(time);
160             our @hexDigits = ('0'..'9', 'a'..'f');
161              
162             sub randomHex {
163 0     0 0 0 my $class = shift;
164 0         0 my $length = shift;
165              
166 0         0 return substr(unpack('H*', CDS::C::randomBytes(int(($length + 1) / 2))), 0, $length);
167             }
168              
169             sub randomBytes {
170 0     0 0 0 my $class = shift;
171 0         0 my $length = shift;
172              
173 0         0 return CDS::C::randomBytes($length);
174             }
175              
176             sub randomKey {
177 0     0 0 0 my $class = shift;
178              
179 0         0 return CDS::C::randomBytes(32);
180             }
181              
182 0     0 0 0 sub version { 'Condensation, Perl, '.$CDS::VERSION }
183              
184             # Conversion of numbers and booleans to and from bytes.
185             # To convert text, use Encode::encode_utf8($text) and Encode::decode_utf8($bytes).
186             # To convert hex sequences, use pack('H*', $hex) and unpack('H*', $bytes).
187              
188             sub bytesFromBoolean {
189 0     0 0 0 my $class = shift;
190 0         0 my $value = shift;
191 0 0       0 $value ? 'y' : '' }
192              
193             sub bytesFromInteger {
194 0     0 0 0 my $class = shift;
195 0         0 my $value = shift;
196              
197 0 0 0     0 return '' if $value >= 0 && $value < 1;
198 0 0 0     0 return pack 'c', $value if $value >= -0x80 && $value < 0x80;
199 0 0 0     0 return pack 's>', $value if $value >= -0x8000 && $value < 0x8000;
200              
201             # This works up to 63 bits, plus 1 sign bit
202 0         0 my $bytes = pack 'q>', $value;
203              
204 0         0 my $pos = 0;
205 0         0 my $first = ord(substr($bytes, 0, 1));
206 0 0       0 if ($value > 0) {
    0          
207             # Perl internally uses an unsigned 64-bit integer if the value is positive
208 0 0       0 return "\x7f\xff\xff\xff\xff\xff\xff\xff" if $first >= 128;
209 0         0 while ($first == 0) {
210 0         0 my $next = ord(substr($bytes, $pos + 1, 1));
211 0 0       0 last if $next >= 128;
212 0         0 $first = $next;
213 0         0 $pos += 1;
214             }
215             } elsif ($first == 255) {
216 0         0 while ($first == 255) {
217 0         0 my $next = ord(substr($bytes, $pos + 1, 1));
218 0 0       0 last if $next < 128;
219 0         0 $first = $next;
220 0         0 $pos += 1;
221             }
222             }
223              
224 0         0 return substr($bytes, $pos);
225             }
226              
227             sub bytesFromUnsigned {
228 0     0 0 0 my $class = shift;
229 0         0 my $value = shift;
230              
231 0 0       0 return '' if $value < 1;
232 0 0       0 return pack 'C', $value if $value < 0x100;
233 0 0       0 return pack 'S>', $value if $value < 0x10000;
234              
235             # This works up to 64 bits
236 0         0 my $bytes = pack 'Q>', $value;
237 0         0 my $pos = 0;
238 0         0 $pos += 1 while substr($bytes, $pos, 1) eq "\0";
239 0         0 return substr($bytes, $pos);
240             }
241              
242             sub bytesFromFloat32 {
243 0     0 0 0 my $class = shift;
244 0         0 my $value = shift;
245 0         0 pack('f', $value) }
246             sub bytesFromFloat64 {
247 0     0 0 0 my $class = shift;
248 0         0 my $value = shift;
249 0         0 pack('d', $value) }
250              
251             sub booleanFromBytes {
252 0     0 0 0 my $class = shift;
253 0         0 my $bytes = shift;
254              
255 0         0 return length $bytes > 0;
256             }
257              
258             sub integerFromBytes {
259 0     0 0 0 my $class = shift;
260 0         0 my $bytes = shift;
261              
262 0 0       0 return 0 if ! length $bytes;
263 0         0 my $value = unpack('C', substr($bytes, 0, 1));
264 0 0       0 $value -= 0x100 if $value & 0x80;
265 0         0 for my $i (1 .. length($bytes) - 1) {
266 0         0 $value *= 256;
267 0         0 $value += unpack('C', substr($bytes, $i, 1));
268             }
269 0         0 return $value;
270             }
271              
272             sub unsignedFromBytes {
273 0     0 0 0 my $class = shift;
274 0         0 my $bytes = shift;
275              
276 0         0 my $value = 0;
277 0         0 for my $i (0 .. length($bytes) - 1) {
278 0         0 $value *= 256;
279 0         0 $value += unpack('C', substr($bytes, $i, 1));
280             }
281 0         0 return $value;
282             }
283              
284             sub floatFromBytes {
285 0     0 0 0 my $class = shift;
286 0         0 my $bytes = shift;
287              
288 0 0       0 return unpack('f', $bytes) if length $bytes == 4;
289 0 0       0 return unpack('d', $bytes) if length $bytes == 8;
290 0         0 return undef;
291             }
292              
293             # Initial counter value for AES in CTR mode
294 0     0 0 0 sub zeroCTR { "\0" x 16 }
295              
296             my $emptyBytesHash = CDS::Hash->fromHex('e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855');
297 0     0 0 0 sub emptyBytesHash { $emptyBytesHash }
298              
299             # Checks if a box label is valid.
300             sub isValidBoxLabel {
301 0     0 0 0 my $class = shift;
302 0         0 my $label = shift;
303 0 0 0     0 $label eq 'messages' || $label eq 'private' || $label eq 'public' }
304              
305             # Groups box additions or removals by account hash and box label.
306             sub groupedBoxOperations {
307 0     0 0 0 my $class = shift;
308 0         0 my $operations = shift;
309              
310 0         0 my %byAccountHash;
311 0         0 for my $operation (@$operations) {
312 0         0 my $accountHashBytes = $operation->{accountHash}->bytes;
313 0 0       0 $byAccountHash{$accountHashBytes} = {accountHash => $operation->{accountHash}, byBoxLabel => {}} if ! exists $byAccountHash{$accountHashBytes};
314 0         0 my $byBoxLabel = $byAccountHash{$accountHashBytes}->{byBoxLabel};
315 0         0 my $boxLabel = $operation->{boxLabel};
316 0 0       0 $byBoxLabel->{$boxLabel} = [] if ! exists $byBoxLabel->{$boxLabel};
317 0         0 push @{$byBoxLabel->{$boxLabel}}, $operation;
  0         0  
318             }
319              
320 0         0 return values %byAccountHash;
321             }
322              
323             ### Open envelopes ###
324              
325             sub verifyEnvelopeSignature {
326 0     0 0 0 my $class = shift;
327 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
328 0 0 0     0 my $publicKey = shift; die 'wrong type '.ref($publicKey).' for $publicKey' if defined $publicKey && ref $publicKey ne 'CDS::PublicKey';
  0         0  
329 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
330              
331             # Read the signature
332 0         0 my $signature = $envelope->child('signature')->bytesValue;
333 0 0       0 return if length $signature < 1;
334              
335             # Verify the signature
336 0 0       0 return if ! $publicKey->verifyHash($hash, $signature);
337 0         0 return 1;
338             }
339              
340             # The result of parsing an ACCOUNT token (see Token.pm).
341             package CDS::AccountToken;
342              
343             sub new {
344 0     0   0 my $class = shift;
345 0         0 my $cliStore = shift;
346 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
347              
348 0         0 return bless {
349             cliStore => $cliStore,
350             actorHash => $actorHash,
351             };
352             }
353              
354 0     0   0 sub cliStore { shift->{cliStore} }
355 0     0   0 sub actorHash { shift->{actorHash} }
356             sub url {
357 0     0   0 my $o = shift;
358 0         0 $o->{cliStore}->url.'/accounts/'.$o->{actorHash}->hex }
359              
360             package CDS::ActorGroup;
361              
362             # 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.
363             sub new {
364 0     0   0 my $class = shift;
365 0         0 my $members = shift;
366 0         0 my $entrustedActorsRevision = shift;
367 0         0 my $entrustedActors = shift;
368              
369             # Create the cache for the "contains" method
370 0         0 my $containCache = {};
371 0         0 for my $member (@$members) {
372 0         0 $containCache->{$member->actorOnStore->publicKey->hash->bytes} = 1;
373             }
374              
375 0         0 return bless {
376             members => $members,
377             entrustedActorsRevision => $entrustedActorsRevision,
378             entrustedActors => $entrustedActors,
379             containsCache => $containCache,
380             };
381             }
382              
383             sub members {
384 0     0   0 my $o = shift;
385 0         0 @{$o->{members}} }
  0         0  
386 0     0   0 sub entrustedActorsRevision { shift->{entrustedActorsRevision} }
387             sub entrustedActors {
388 0     0   0 my $o = shift;
389 0         0 @{$o->{entrustedActors}} }
  0         0  
390              
391             # Checks whether the actor group contains at least one active member.
392             sub isActive {
393 0     0   0 my $o = shift;
394              
395 0         0 for my $member (@{$o->{members}}) {
  0         0  
396 0 0       0 return 1 if $member->isActive;
397             }
398 0         0 return;
399             }
400              
401             # Returns the most recent active member, the most recent idle member, or undef if the group is empty.
402             sub leader {
403 0     0   0 my $o = shift;
404              
405 0         0 for my $member (@{$o->{members}}) {
  0         0  
406 0 0       0 return $member if $member->isActive;
407             }
408 0         0 return $o->{members}->[0];
409             }
410              
411             # Returns true if the account belongs to this actor group.
412             # Note that multiple (different) actor groups may claim that the account belongs to them. In practice, an account usually belongs to one actor group.
413             sub contains {
414 0     0   0 my $o = shift;
415 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
416              
417 0         0 return exists $o->{containsCache}->{$actorHash->bytes};
418             }
419              
420             # Returns true if the account is entrusted by this actor group.
421             sub entrusts {
422 0     0   0 my $o = shift;
423 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
424              
425 0         0 for my $actor (@{$o->{entrustedActors}}) {
  0         0  
426 0 0       0 return 1 if $actorHash->equals($actor->publicKey->hash);
427             }
428 0         0 return;
429             }
430              
431             # Returns all public keys.
432             sub publicKeys {
433 0     0   0 my $o = shift;
434              
435 0         0 my @publicKeys;
436 0         0 for my $member (@{$o->{members}}) {
  0         0  
437 0         0 push @publicKeys, $member->actorOnStore->publicKey;
438             }
439 0         0 for my $actor (@{$o->{entrustedActors}}) {
  0         0  
440 0         0 push @publicKeys, $actor->actorOnStore->publicKey;
441             }
442 0         0 return @publicKeys;
443             }
444              
445             # Returns an ActorGroupBuilder with all members and entrusted keys of this ActorGroup.
446             sub toBuilder {
447 0     0   0 my $o = shift;
448              
449 0         0 my $builder = CDS::ActorGroupBuilder->new;
450 0         0 $builder->mergeEntrustedActors($o->{entrustedActorsRevision});
451 0         0 for my $member (@{$o->{members}}) {
  0         0  
452 0         0 my $publicKey = $member->actorOnStore->publicKey;
453 0         0 $builder->addKnownPublicKey($publicKey);
454 0 0       0 $builder->addMember($publicKey->hash, $member->storeUrl, $member->revision, $member->isActive ? 'active' : 'idle');
455             }
456 0         0 for my $actor (@{$o->{entrustedActors}}) {
  0         0  
457 0         0 my $publicKey = $actor->actorOnStore->publicKey;
458 0         0 $builder->addKnownPublicKey($publicKey);
459 0         0 $builder->addEntrustedActor($publicKey->hash, $actor->storeUrl);
460             }
461 0         0 return $builder;
462             }
463              
464             package CDS::ActorGroup::EntrustedActor;
465              
466             sub new {
467 0     0   0 my $class = shift;
468 0 0 0     0 my $actorOnStore = shift; die 'wrong type '.ref($actorOnStore).' for $actorOnStore' if defined $actorOnStore && ref $actorOnStore ne 'CDS::ActorOnStore';
  0         0  
469 0         0 my $storeUrl = shift;
470              
471 0         0 return bless {
472             actorOnStore => $actorOnStore,
473             storeUrl => $storeUrl,
474             };
475             }
476              
477 0     0   0 sub actorOnStore { shift->{actorOnStore} }
478 0     0   0 sub storeUrl { shift->{storeUrl} }
479              
480             package CDS::ActorGroup::Member;
481              
482             sub new {
483 0     0   0 my $class = shift;
484 0 0 0     0 my $actorOnStore = shift; die 'wrong type '.ref($actorOnStore).' for $actorOnStore' if defined $actorOnStore && ref $actorOnStore ne 'CDS::ActorOnStore';
  0         0  
485 0         0 my $storeUrl = shift;
486 0         0 my $revision = shift;
487 0         0 my $isActive = shift;
488              
489 0         0 return bless {
490             actorOnStore => $actorOnStore,
491             storeUrl => $storeUrl,
492             revision => $revision,
493             isActive => $isActive,
494             };
495             }
496              
497 0     0   0 sub actorOnStore { shift->{actorOnStore} }
498 0     0   0 sub storeUrl { shift->{storeUrl} }
499 0     0   0 sub revision { shift->{revision} }
500 0     0   0 sub isActive { shift->{isActive} }
501              
502             package CDS::ActorGroupBuilder;
503              
504             sub new {
505 0     0   0 my $class = shift;
506              
507 0         0 return bless {
508             knownPublicKeys => {}, # A hashref of known public keys (e.g. from the existing actor group)
509             members => {}, # Members by URL
510             entrustedActorsRevision => 0, # Revision of the list of entrusted actors
511             entrustedActors => {}, # Entrusted actors by hash
512             };
513             }
514              
515             sub members {
516 0     0   0 my $o = shift;
517 0         0 values %{$o->{members}} }
  0         0  
518 0     0   0 sub entrustedActorsRevision { shift->{entrustedActorsRevision} }
519             sub entrustedActors {
520 0     0   0 my $o = shift;
521 0         0 values %{$o->{entrustedActors}} }
  0         0  
522 0     0   0 sub knownPublicKeys { shift->{knownPublicKeys} }
523              
524             sub addKnownPublicKey {
525 0     0   0 my $o = shift;
526 0 0 0     0 my $publicKey = shift; die 'wrong type '.ref($publicKey).' for $publicKey' if defined $publicKey && ref $publicKey ne 'CDS::PublicKey';
  0         0  
527              
528 0         0 $o->{publicKeys}->{$publicKey->hash->bytes} = $publicKey;
529             }
530              
531             sub addMember {
532 0     0   0 my $o = shift;
533 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
534 0         0 my $storeUrl = shift;
535 0   0     0 my $revision = shift // 0;
536 0   0     0 my $status = shift // 'active';
537              
538 0         0 my $url = $storeUrl.'/accounts/'.$hash->hex;
539 0         0 my $member = $o->{members}->{$url};
540 0 0 0     0 return if $member && $revision <= $member->revision;
541 0         0 $o->{members}->{$url} = CDS::ActorGroupBuilder::Member->new($hash, $storeUrl, $revision, $status);
542 0         0 return 1;
543             }
544              
545             sub removeMember {
546 0     0   0 my $o = shift;
547 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
548 0         0 my $storeUrl = shift;
549              
550 0         0 my $url = $storeUrl.'/accounts/'.$hash->hex;
551 0         0 delete $o->{members}->{$url};
552             }
553              
554             sub parseMembers {
555 0     0   0 my $o = shift;
556 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
557 0         0 my $linkedPublicKeys = shift;
558              
559 0 0       0 die 'linked public keys?' if ! defined $linkedPublicKeys;
560 0         0 for my $storeRecord ($record->children) {
561 0         0 my $accountStoreUrl = $storeRecord->asText;
562              
563 0         0 for my $statusRecord ($storeRecord->children) {
564 0         0 my $status = $statusRecord->bytes;
565              
566 0         0 for my $child ($statusRecord->children) {
567 0 0       0 my $hash = $linkedPublicKeys ? $child->hash : CDS::Hash->fromBytes($child->bytes);
568 0   0     0 $o->addMember($hash // next, $accountStoreUrl, $child->integerValue, $status);
569             }
570             }
571             }
572             }
573              
574             sub mergeEntrustedActors {
575 0     0   0 my $o = shift;
576 0         0 my $revision = shift;
577              
578 0 0       0 return if $revision <= $o->{entrustedActorsRevision};
579 0         0 $o->{entrustedActorsRevision} = $revision;
580 0         0 $o->{entrustedActors} = {};
581 0         0 return 1;
582             }
583              
584             sub addEntrustedActor {
585 0     0   0 my $o = shift;
586 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
587 0         0 my $storeUrl = shift;
588              
589 0         0 my $actor = CDS::ActorGroupBuilder::EntrustedActor->new($hash, $storeUrl);
590 0         0 $o->{entrustedActors}->{$hash->bytes} = $actor;
591             }
592              
593             sub removeEntrustedActor {
594 0     0   0 my $o = shift;
595 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
596              
597 0         0 delete $o->{entrustedActors}->{$hash->bytes};
598             }
599              
600             sub parseEntrustedActors {
601 0     0   0 my $o = shift;
602 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
603 0         0 my $linkedPublicKeys = shift;
604              
605 0         0 for my $revisionRecord ($record->children) {
606 0 0       0 next if ! $o->mergeEntrustedActors($revisionRecord->asInteger);
607 0         0 $o->parseEntrustedActorList($revisionRecord, $linkedPublicKeys);
608             }
609             }
610              
611             sub parseEntrustedActorList {
612 0     0   0 my $o = shift;
613 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
614 0         0 my $linkedPublicKeys = shift;
615              
616 0 0       0 die 'linked public keys?' if ! defined $linkedPublicKeys;
617 0         0 for my $storeRecord ($record->children) {
618 0         0 my $storeUrl = $storeRecord->asText;
619              
620 0         0 for my $child ($storeRecord->children) {
621 0 0       0 my $hash = $linkedPublicKeys ? $child->hash : CDS::Hash->fromBytes($child->bytes);
622 0   0     0 $o->addEntrustedActor($hash // next, $storeUrl);
623             }
624             }
625             }
626              
627             sub parse {
628 0     0   0 my $o = shift;
629 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
630 0         0 my $linkedPublicKeys = shift;
631              
632 0         0 $o->parseMembers($record->child('actor group'), $linkedPublicKeys);
633 0         0 $o->parseEntrustedActors($record->child('entrusted actors'), $linkedPublicKeys);
634             }
635              
636             sub load {
637 0     0   0 my $o = shift;
638 0         0 my $store = shift;
639 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
640 0         0 my $delegate = shift;
641              
642 0         0 return CDS::LoadActorGroup->load($o, $store, $keyPair, $delegate);
643             }
644              
645             sub discover {
646 0     0   0 my $o = shift;
647 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
648 0         0 my $delegate = shift;
649              
650 0         0 return CDS::DiscoverActorGroup->discover($o, $keyPair, $delegate);
651             }
652              
653             # Serializes the actor group to a record that can be passed to parse.
654             sub addToRecord {
655 0     0   0 my $o = shift;
656 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
657 0         0 my $linkedPublicKeys = shift;
658              
659 0 0       0 die 'linked public keys?' if ! defined $linkedPublicKeys;
660              
661 0         0 my $actorGroupRecord = $record->add('actor group');
662 0         0 my $currentStoreUrl = undef;
663 0         0 my $currentStoreRecord = undef;
664 0         0 my $currentStatus = undef;
665 0         0 my $currentStatusRecord = undef;
666 0 0       0 for my $member (sort { $a->storeUrl cmp $b->storeUrl || CDS->booleanCompare($b->status, $a->status) } $o->members) {
  0         0  
667 0 0       0 next if ! $member->revision;
668              
669 0 0 0     0 if (! defined $currentStoreUrl || $currentStoreUrl ne $member->storeUrl) {
670 0         0 $currentStoreUrl = $member->storeUrl;
671 0         0 $currentStoreRecord = $actorGroupRecord->addText($currentStoreUrl);
672 0         0 $currentStatus = undef;
673 0         0 $currentStatusRecord = undef;
674             }
675              
676 0 0 0     0 if (! defined $currentStatus || $currentStatus ne $member->status) {
677 0         0 $currentStatus = $member->status;
678 0         0 $currentStatusRecord = $currentStoreRecord->add($currentStatus);
679             }
680              
681 0 0       0 my $hashRecord = $linkedPublicKeys ? $currentStatusRecord->addHash($member->hash) : $currentStatusRecord->add($member->hash->bytes);
682 0         0 $hashRecord->addInteger($member->revision);
683             }
684              
685 0 0       0 if ($o->{entrustedActorsRevision}) {
686 0         0 my $listRecord = $o->entrustedActorListToRecord($linkedPublicKeys);
687 0         0 $record->add('entrusted actors')->addInteger($o->{entrustedActorsRevision})->addRecord($listRecord->children);
688             }
689             }
690              
691             sub toRecord {
692 0     0   0 my $o = shift;
693 0         0 my $linkedPublicKeys = shift;
694              
695 0         0 my $record = CDS::Record->new;
696 0         0 $o->addToRecord($record, $linkedPublicKeys);
697 0         0 return $record;
698             }
699              
700             sub entrustedActorListToRecord {
701 0     0   0 my $o = shift;
702 0         0 my $linkedPublicKeys = shift;
703              
704 0         0 my $record = CDS::Record->new;
705 0         0 my $currentStoreUrl = undef;
706 0         0 my $currentStoreRecord = undef;
707 0         0 for my $actor ($o->entrustedActors) {
708 0 0 0     0 if (! defined $currentStoreUrl || $currentStoreUrl ne $actor->storeUrl) {
709 0         0 $currentStoreUrl = $actor->storeUrl;
710 0         0 $currentStoreRecord = $record->addText($currentStoreUrl);
711             }
712              
713 0 0       0 $linkedPublicKeys ? $currentStoreRecord->addHash($actor->hash) : $currentStoreRecord->add($actor->hash->bytes);
714             }
715              
716 0         0 return $record;
717             }
718              
719             package CDS::ActorGroupBuilder::EntrustedActor;
720              
721             sub new {
722 0     0   0 my $class = shift;
723 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
724 0         0 my $storeUrl = shift;
725              
726 0         0 return bless {
727             hash => $hash,
728             storeUrl => $storeUrl,
729             };
730             }
731              
732 0     0   0 sub hash { shift->{hash} }
733 0     0   0 sub storeUrl { shift->{storeUrl} }
734              
735             package CDS::ActorGroupBuilder::Member;
736              
737             sub new {
738 0     0   0 my $class = shift;
739 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
740 0         0 my $storeUrl = shift;
741 0         0 my $revision = shift;
742 0         0 my $status = shift;
743              
744 0         0 return bless {
745             hash => $hash,
746             storeUrl => $storeUrl,
747             revision => $revision,
748             status => $status,
749             };
750             }
751              
752 0     0   0 sub hash { shift->{hash} }
753 0     0   0 sub storeUrl { shift->{storeUrl} }
754 0     0   0 sub revision { shift->{revision} }
755 0     0   0 sub status { shift->{status} }
756              
757             # The result of parsing an ACTORGROUP token (see Token.pm).
758             package CDS::ActorGroupToken;
759              
760             sub new {
761 0     0   0 my $class = shift;
762 0         0 my $label = shift;
763 0 0 0     0 my $actorGroup = shift; die 'wrong type '.ref($actorGroup).' for $actorGroup' if defined $actorGroup && ref $actorGroup ne 'CDS::ActorGroup';
  0         0  
764              
765 0         0 return bless {
766             label => $label,
767             actorGroup => $actorGroup,
768             };
769             }
770              
771 0     0   0 sub label { shift->{label} }
772 0     0   0 sub actorGroup { shift->{actorGroup} }
773              
774             # A public key and a store.
775             package CDS::ActorOnStore;
776              
777             sub new {
778 0     0   0 my $class = shift;
779 0 0 0     0 my $publicKey = shift; die 'wrong type '.ref($publicKey).' for $publicKey' if defined $publicKey && ref $publicKey ne 'CDS::PublicKey';
  0         0  
780 0         0 my $store = shift;
781              
782 0         0 return bless {
783             publicKey => $publicKey,
784             store => $store
785             };
786             }
787              
788 0     0   0 sub publicKey { shift->{publicKey} }
789 0     0   0 sub store { shift->{store} }
790              
791             sub equals {
792 0     0   0 my $this = shift;
793 0         0 my $that = shift;
794              
795 0 0 0     0 return 1 if ! defined $this && ! defined $that;
796 0 0 0     0 return if ! defined $this || ! defined $that;
797 0   0     0 return $this->{store}->id eq $that->{store}->id && $this->{publicKey}->{hash}->equals($that->{publicKey}->{hash});
798             }
799              
800             package CDS::ActorWithDocument;
801              
802             sub new {
803 0     0   0 my $class = shift;
804 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
805 0         0 my $storageStore = shift;
806 0         0 my $messagingStore = shift;
807 0         0 my $messagingStoreUrl = shift;
808 0         0 my $publicKeyCache = shift;
809              
810 0         0 my $o = bless {
811             keyPair => $keyPair,
812             storageStore => $storageStore,
813             messagingStore => $messagingStore,
814             messagingStoreUrl => $messagingStoreUrl,
815             groupDataHandlers => [],
816             }, $class;
817              
818             # Private data on the storage store
819 0         0 $o->{storagePrivateRoot} = CDS::PrivateRoot->new($keyPair, $storageStore, $o);
820 0         0 $o->{groupDocument} = CDS::RootDocument->new($o->{storagePrivateRoot}, 'group data');
821 0         0 $o->{localDocument} = CDS::RootDocument->new($o->{storagePrivateRoot}, 'local data');
822              
823             # Private data on the messaging store
824 0 0       0 $o->{messagingPrivateRoot} = $storageStore->id eq $messagingStore->id ? $o->{storagePrivateRoot} : CDS::PrivateRoot->new($keyPair, $messagingStore, $o);
825 0         0 $o->{sentList} = CDS::SentList->new($o->{messagingPrivateRoot});
826 0         0 $o->{sentListReady} = 0;
827              
828             # Group data sharing
829 0         0 $o->{groupDataSharer} = CDS::GroupDataSharer->new($o);
830 0         0 $o->{groupDataSharer}->addDataHandler($o->{groupDocument}->label, $o->{groupDocument});
831              
832             # Selectors
833 0         0 $o->{groupRoot} = $o->{groupDocument}->root;
834 0         0 $o->{localRoot} = $o->{localDocument}->root;
835 0         0 $o->{publicDataSelector} = $o->{groupRoot}->child('public data');
836 0         0 $o->{actorGroupSelector} = $o->{groupRoot}->child('actor group');
837 0         0 $o->{actorSelector} = $o->{actorGroupSelector}->child(substr($keyPair->publicKey->hash->bytes, 0, 16));
838 0         0 $o->{entrustedActorsSelector} = $o->{groupRoot}->child('entrusted actors');
839              
840             # Message reader
841 0         0 my $pool = CDS::MessageBoxReaderPool->new($keyPair, $publicKeyCache, $o);
842 0         0 $o->{messageBoxReader} = CDS::MessageBoxReader->new($pool, CDS::ActorOnStore->new($keyPair->publicKey, $messagingStore), CDS->HOUR);
843              
844             # Active actor group members and entrusted keys
845 0         0 $o->{cachedGroupDataMembers} = {};
846 0         0 $o->{cachedEntrustedKeys} = {};
847 0         0 return $o;
848             }
849              
850 0     0   0 sub keyPair { shift->{keyPair} }
851 0     0   0 sub storageStore { shift->{storageStore} }
852 0     0   0 sub messagingStore { shift->{messagingStore} }
853 0     0   0 sub messagingStoreUrl { shift->{messagingStoreUrl} }
854              
855 0     0   0 sub storagePrivateRoot { shift->{storagePrivateRoot} }
856 0     0   0 sub groupDocument { shift->{groupDocument} }
857 0     0   0 sub localDocument { shift->{localDocument} }
858              
859 0     0   0 sub messagingPrivateRoot { shift->{messagingPrivateRoot} }
860 0     0   0 sub sentList { shift->{sentList} }
861 0     0   0 sub sentListReady { shift->{sentListReady} }
862              
863 0     0   0 sub groupDataSharer { shift->{groupDataSharer} }
864              
865 0     0   0 sub groupRoot { shift->{groupRoot} }
866 0     0   0 sub localRoot { shift->{localRoot} }
867 0     0   0 sub publicDataSelector { shift->{publicDataSelector} }
868 0     0   0 sub actorGroupSelector { shift->{actorGroupSelector} }
869 0     0   0 sub actorSelector { shift->{actorSelector} }
870 0     0   0 sub entrustedActorsSelector { shift->{entrustedActorsSelector} }
871              
872             ### Our own actor ###
873              
874             sub isMe {
875 0     0   0 my $o = shift;
876 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
877              
878 0         0 return $o->{keyPair}->publicKey->hash->equals($actorHash);
879             }
880              
881             sub setName {
882 0     0   0 my $o = shift;
883 0         0 my $name = shift;
884              
885 0         0 $o->{actorSelector}->child('name')->set($name);
886             }
887              
888             sub getName {
889 0     0   0 my $o = shift;
890              
891 0         0 return $o->{actorSelector}->child('name')->textValue;
892             }
893              
894             sub updateMyRegistration {
895 0     0   0 my $o = shift;
896              
897 0         0 $o->{actorSelector}->addObject($o->{keyPair}->publicKey->hash, $o->{keyPair}->publicKey->object);
898 0         0 my $record = CDS::Record->new;
899 0         0 $record->add('hash')->addHash($o->{keyPair}->publicKey->hash);
900 0         0 $record->add('store')->addText($o->{messagingStoreUrl});
901 0         0 $o->{actorSelector}->set($record);
902             }
903              
904             sub setMyActiveFlag {
905 0     0   0 my $o = shift;
906 0         0 my $flag = shift;
907              
908 0         0 $o->{actorSelector}->child('active')->setBoolean($flag);
909             }
910              
911             sub setMyGroupDataFlag {
912 0     0   0 my $o = shift;
913 0         0 my $flag = shift;
914              
915 0         0 $o->{actorSelector}->child('group data')->setBoolean($flag);
916             }
917              
918             ### Actor group
919              
920             sub groupMemberSelector {
921 0     0   0 my $o = shift;
922 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
923              
924 0         0 return $o->{actorGroupSelector}->child(substr($actorHash->bytes, 0, 16));
925             }
926              
927             sub isGroupMember {
928 0     0   0 my $o = shift;
929 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
930              
931 0 0       0 return 1 if $actorHash->equals($o->{keyPair}->publicKey->hash);
932 0   0     0 my $memberSelector = $o->groupMemberSelector($actorHash) // return;
933 0 0       0 return 0 if $memberSelector->child('revoked')->isSet;
934 0         0 my $record = $memberSelector->record;
935 0         0 return $actorHash->equals($record->child('hash')->hashValue);
936             }
937              
938             sub forgetOldIdleActors {
939 0     0   0 my $o = shift;
940 0         0 my $limit = shift;
941              
942 0         0 for my $child ($o->{actorGroupSelector}->children) {
943 0 0       0 next if $child->child('active')->booleanValue;
944 0 0       0 next if $child->child('group data')->booleanValue;
945 0 0       0 next if $child->revision > $limit;
946 0         0 $child->forgetBranch;
947             }
948             }
949              
950             sub setGroupMember {
951 0     0   0 my $o = shift;
952 0 0 0     0 my $publicKey = shift; die 'wrong type '.ref($publicKey).' for $publicKey' if defined $publicKey && ref $publicKey ne 'CDS::PublicKey';
  0         0  
953 0         0 my $storeUrl = shift;
954 0         0 my $active = shift;
955 0         0 my $groupData = shift;
956              
957 0         0 my $memberSelector = $o->groupMemberSelector($publicKey->hash);
958 0         0 my $record = CDS::Record->new;
959 0         0 $record->add('hash')->addHash($publicKey->hash);
960 0         0 $record->add('store')->addText($storeUrl);
961 0         0 $memberSelector->set($record);
962 0         0 $memberSelector->addObject($publicKey->hash, $publicKey->object);
963              
964 0         0 $memberSelector->child('active')->setBoolean($active);
965 0         0 $memberSelector->child('group data')->setBoolean($groupData);
966             }
967              
968             sub revokeGroupMember {
969 0     0   0 my $o = shift;
970 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
971 0         0 my $storeUrl = shift;
972              
973 0         0 my $memberSelector = $o->groupMemberSelector($actorHash);
974 0 0       0 return if ! $memberSelector->isSet;
975 0         0 $memberSelector->child('revoked')->setBoolean(1);
976             }
977              
978             ### Group data members
979              
980             sub getGroupDataMembers {
981 0     0   0 my $o = shift;
982              
983             # Update the cached list
984 0         0 for my $child ($o->{actorGroupSelector}->children) {
985 0         0 my $record = $child->record;
986 0         0 my $hash = $record->child('hash')->hashValue;
987 0 0       0 $hash = undef if $hash->equals($o->{keyPair}->publicKey->hash);
988 0 0       0 $hash = undef if $child->child('revoked')->isSet;
989 0 0       0 $hash = undef if ! $child->child('group data')->isSet;
990              
991             # Remove
992 0 0       0 if (! $hash) {
993 0         0 delete $o->{cachedGroupDataMembers}->{$child->label};
994 0         0 next;
995             }
996              
997             # Keep
998 0         0 my $member = $o->{cachedGroupDataMembers}->{$child->label};
999 0         0 my $storeUrl = $record->child('store')->textValue;
1000 0 0 0     0 next if $member && $member->{storeUrl} eq $storeUrl && $member->{actorOnStore}->publicKey->hash->equals($hash);
      0        
1001              
1002             # Verify the store
1003 0         0 my $store = $o->onVerifyMemberStore($storeUrl, $child);
1004 0 0       0 if (! $store) {
1005 0         0 delete $o->{cachedGroupDataMembers}->{$child->label};
1006 0         0 next;
1007             }
1008              
1009             # Reuse the public key and add
1010 0 0 0     0 if ($member && $member->{actorOnStore}->publicKey->hash->equals($hash)) {
1011 0         0 my $actorOnStore = CDS::ActorOnStore->new($member->{actorOnStore}->publicKey, $store);
1012 0         0 $o->{cachedEntrustedKeys}->{$child->label} = {storeUrl => $storeUrl, actorOnStore => $actorOnStore};
1013             }
1014              
1015             # Get the public key and add
1016 0         0 my ($publicKey, $invalidReason, $storeError) = $o->{keyPair}->getPublicKey($hash, $o->{groupDocument}->unsaved);
1017 0 0       0 return if defined $storeError;
1018 0 0       0 if (defined $invalidReason) {
1019 0         0 delete $o->{cachedGroupDataMembers}->{$child->label};
1020 0         0 next;
1021             }
1022              
1023 0         0 my $actorOnStore = CDS::ActorOnStore->new($publicKey, $store);
1024 0         0 $o->{cachedGroupDataMembers}->{$child->label} = {storeUrl => $storeUrl, actorOnStore => $actorOnStore};
1025             }
1026              
1027             # Return the current list
1028 0         0 return [map { $_->{actorOnStore} } values %{$o->{cachedGroupDataMembers}}];
  0         0  
  0         0  
1029             }
1030              
1031             ### Entrusted actors
1032              
1033             sub entrust {
1034 0     0   0 my $o = shift;
1035 0         0 my $storeUrl = shift;
1036 0 0 0     0 my $publicKey = shift; die 'wrong type '.ref($publicKey).' for $publicKey' if defined $publicKey && ref $publicKey ne 'CDS::PublicKey';
  0         0  
1037              
1038             # TODO: this is not compatible with the Java implementation (which uses a record with "hash" and "store")
1039 0         0 my $selector = $o->{entrustedActorsSelector};
1040 0         0 my $builder = CDS::ActorGroupBuilder->new;
1041 0         0 $builder->parseEntrustedActorList($selector->record, 1);
1042 0         0 $builder->removeEntrustedActor($publicKey->hash);
1043 0         0 $builder->addEntrustedActor($storeUrl, $publicKey->hash);
1044 0         0 $selector->addObject($publicKey->hash, $publicKey->object);
1045 0         0 $selector->set($builder->entrustedActorListToRecord(1));
1046 0         0 $o->{cachedEntrustedKeys}->{$publicKey->hash->bytes} = $publicKey;
1047             }
1048              
1049             sub doNotEntrust {
1050 0     0   0 my $o = shift;
1051 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
1052              
1053 0         0 my $selector = $o->{entrustedActorsSelector};
1054 0         0 my $builder = CDS::ActorGroupBuilder->new;
1055 0         0 $builder->parseEntrustedActorList($selector->record, 1);
1056 0         0 $builder->removeEntrustedActor($hash);
1057 0         0 $selector->set($builder->entrustedActorListToRecord(1));
1058 0         0 delete $o->{cachedEntrustedKeys}->{$hash->bytes};
1059             }
1060              
1061             sub getEntrustedKeys {
1062 0     0   0 my $o = shift;
1063              
1064 0         0 my $entrustedKeys = [];
1065 0         0 for my $storeRecord ($o->{entrustedActorsSelector}->record->children) {
1066 0         0 for my $child ($storeRecord->children) {
1067 0   0     0 my $hash = $child->hash // next;
1068 0   0     0 push @$entrustedKeys, $o->getEntrustedKey($hash) // next;
1069             }
1070             }
1071              
1072             # We could remove unused keys from $o->{cachedEntrustedKeys} here, but since this is
1073             # such a rare event, and doesn't consume a lot of memory, this would be overkill.
1074              
1075 0         0 return $entrustedKeys;
1076             }
1077              
1078             sub getEntrustedKey {
1079 0     0   0 my $o = shift;
1080 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
1081              
1082 0         0 my $entrustedKey = $o->{cachedEntrustedKeys}->{$hash->bytes};
1083 0 0       0 return $entrustedKey if $entrustedKey;
1084              
1085 0         0 my ($publicKey, $invalidReason, $storeError) = $o->{keyPair}->getPublicKey($hash, $o->{groupDocument}->unsaved);
1086 0 0       0 return if defined $storeError;
1087 0 0       0 return if defined $invalidReason;
1088 0         0 $o->{cachedEntrustedKeys}->{$hash->bytes} = $publicKey;
1089 0         0 return $publicKey;
1090             }
1091              
1092             ### Private data
1093              
1094             sub procurePrivateData {
1095 0     0   0 my $o = shift;
1096 0   0     0 my $interval = shift // CDS->DAY;
1097              
1098 0   0     0 $o->{storagePrivateRoot}->procure($interval) // return;
1099 0   0     0 $o->{groupDocument}->read // return;
1100 0   0     0 $o->{localDocument}->read // return;
1101 0         0 return 1;
1102             }
1103              
1104             sub savePrivateDataAndShareGroupData {
1105 0     0   0 my $o = shift;
1106              
1107 0         0 $o->{localDocument}->save;
1108 0         0 $o->{groupDocument}->save;
1109 0         0 $o->{groupDataSharer}->share;
1110 0   0     0 my $entrustedKeys = $o->getEntrustedKeys // return;
1111 0         0 my ($ok, $missingHash) = $o->{storagePrivateRoot}->save($entrustedKeys);
1112 0 0       0 return 1 if $ok;
1113 0 0       0 $o->onMissingObject($missingHash) if $missingHash;
1114 0         0 return;
1115             }
1116              
1117             # abstract sub onVerifyMemberStore($storeUrl, $selector)
1118             # abstract sub onPrivateRootReadingInvalidEntry($o, $source, $reason)
1119             # abstract sub onMissingObject($missingHash)
1120              
1121             ### Sending messages
1122              
1123             sub procureSentList {
1124 0     0   0 my $o = shift;
1125 0   0     0 my $interval = shift // CDS->DAY;
1126              
1127 0   0     0 $o->{messagingPrivateRoot}->procure($interval) // return;
1128 0   0     0 $o->{sentList}->read // return;
1129 0         0 $o->{sentListReady} = 1;
1130 0         0 return 1;
1131             }
1132              
1133             sub openMessageChannel {
1134 0     0   0 my $o = shift;
1135 0         0 my $label = shift;
1136 0         0 my $validity = shift;
1137              
1138 0         0 return CDS::MessageChannel->new($o, $label, $validity);
1139             }
1140              
1141             sub sendMessages {
1142 0     0   0 my $o = shift;
1143              
1144 0 0       0 return 1 if ! $o->{sentList}->hasChanges;
1145 0         0 $o->{sentList}->save;
1146 0   0     0 my $entrustedKeys = $o->getEntrustedKeys // return;
1147 0         0 my ($ok, $missingHash) = $o->{messagingPrivateRoot}->save($entrustedKeys);
1148 0 0       0 return 1 if $ok;
1149 0 0       0 $o->onMissingObject($missingHash) if $missingHash;
1150 0         0 return;
1151             }
1152              
1153             ### Receiving messages
1154              
1155             # abstract sub onMessageBoxVerifyStore($o, $senderStoreUrl, $hash, $envelope, $senderHash)
1156             # abstract sub onMessage($o, $message)
1157             # abstract sub onInvalidMessage($o, $source, $reason)
1158             # abstract sub onMessageBoxEntry($o, $message)
1159             # abstract sub onMessageBoxInvalidEntry($o, $source, $reason)
1160              
1161             ### Announcing ###
1162              
1163             sub announceOnAllStores {
1164 0     0   0 my $o = shift;
1165              
1166 0         0 $o->announce($o->{storageStore});
1167 0 0       0 $o->announce($o->{messagingStore}) if $o->{messagingStore}->id ne $o->{storageStore}->id;
1168             }
1169              
1170             sub announce {
1171 0     0   0 my $o = shift;
1172 0         0 my $store = shift;
1173              
1174 0 0       0 die 'probably calling old announce, which should now be announceOnAllStores' if ! defined $store;
1175              
1176             # Prepare the actor group
1177 0         0 my $builder = CDS::ActorGroupBuilder->new;
1178              
1179 0         0 my $me = $o->keyPair->publicKey->hash;
1180 0         0 $builder->addMember($me, $o->messagingStoreUrl, CDS->now, 'active');
1181 0         0 for my $child ($o->actorGroupSelector->children) {
1182 0         0 my $record = $child->record;
1183 0   0     0 my $hash = $record->child('hash')->hashValue // next;
1184 0 0       0 next if $hash->equals($me);
1185 0         0 my $storeUrl = $record->child('store')->textValue;
1186 0         0 my $revokedSelector = $child->child('revoked');
1187 0         0 my $activeSelector = $child->child('active');
1188 0         0 my $revision = CDS->max($child->revision, $revokedSelector->revision, $activeSelector->revision);
1189 0 0       0 my $actorStatus = $revokedSelector->booleanValue ? 'revoked' : $activeSelector->booleanValue ? 'active' : 'idle';
    0          
1190 0         0 $builder->addMember($hash, $storeUrl, $revision, $actorStatus);
1191             }
1192              
1193 0 0       0 $builder->parseEntrustedActorList($o->entrustedActorsSelector->record, 1) if $builder->mergeEntrustedActors($o->entrustedActorsSelector->revision);
1194              
1195             # Create the card
1196 0         0 my $card = $builder->toRecord(0);
1197 0         0 $card->add('public key')->addHash($o->{keyPair}->publicKey->hash);
1198              
1199             # Add the public data
1200 0         0 for my $child ($o->publicDataSelector->children) {
1201 0         0 my $childRecord = $child->record;
1202 0         0 $card->addRecord($childRecord->children);
1203             }
1204              
1205             # Create an unsaved state
1206 0         0 my $unsaved = CDS::Unsaved->new($o->publicDataSelector->document->unsaved);
1207              
1208             # Add the public card and the public key
1209 0         0 my $cardObject = $card->toObject;
1210 0         0 my $cardHash = $cardObject->calculateHash;
1211 0         0 $unsaved->state->addObject($cardHash, $cardObject);
1212 0         0 $unsaved->state->addObject($me, $o->keyPair->publicKey->object);
1213              
1214             # Prepare the public envelope
1215 0         0 my $envelopeObject = $o->keyPair->createPublicEnvelope($cardHash)->toObject;
1216 0         0 my $envelopeHash = $envelopeObject->calculateHash;
1217              
1218             # Upload the objects
1219 0         0 my ($missingObject, $transferStore, $transferError) = $o->keyPair->transfer([$cardHash], $unsaved, $store);
1220 0 0       0 return if defined $transferError;
1221 0 0       0 if ($missingObject) {
1222 0         0 $missingObject->{context} = 'announce on '.$store->id;
1223 0         0 $o->onMissingObject($missingObject);
1224 0         0 return;
1225             }
1226              
1227             # Prepare to modify
1228 0         0 my $modifications = CDS::StoreModifications->new;
1229 0         0 $modifications->add($me, 'public', $envelopeHash, $envelopeObject);
1230              
1231             # List the current cards to remove them
1232             # Ignore errors, in the worst case, we are going to have multiple entries in the public box
1233 0         0 my ($hashes, $error) = $store->list($me, 'public', 0, $o->keyPair);
1234 0 0       0 if ($hashes) {
1235 0         0 for my $hash (@$hashes) {
1236 0         0 $modifications->remove($me, 'public', $hash);
1237             }
1238             }
1239              
1240             # Modify the public box
1241 0         0 my $modifyError = $store->modify($modifications, $o->keyPair);
1242 0 0       0 return if defined $modifyError;
1243 0         0 return $envelopeHash, $cardHash;
1244             }
1245              
1246             # The result of parsing a BOX token (see Token.pm).
1247             package CDS::BoxToken;
1248              
1249             sub new {
1250 0     0   0 my $class = shift;
1251 0         0 my $accountToken = shift;
1252 0         0 my $boxLabel = shift;
1253              
1254 0         0 return bless {
1255             accountToken => $accountToken,
1256             boxLabel => $boxLabel
1257             };
1258             }
1259              
1260 0     0   0 sub accountToken { shift->{accountToken} }
1261 0     0   0 sub boxLabel { shift->{boxLabel} }
1262             sub url {
1263 0     0   0 my $o = shift;
1264 0         0 $o->{accountToken}->url.'/'.$o->{boxLabel} }
1265              
1266             package CDS::CLI;
1267              
1268             sub run {
1269 0     0   0 my $class = shift;
1270              
1271 0         0 my $isTTY = -t STDOUT;
1272 0         0 my $isCompletion = exists $ENV{COMP_LINE};
1273 0   0     0 my $ui = CDS::UI->new(*STDOUT, $isCompletion || ! $isTTY);
1274              
1275 0   0     0 my $actor = CDS::CLIActor->openOrCreateDefault($ui) // return 1;
1276 0         0 my $parser = CDS::Parser->new($actor, 'cds');
1277 0         0 my $cds = CDS::Parser::Node->new(0, {constructor => \&CDS::CLI::new, function => \&CDS::CLI::default});
1278 0         0 my $help = CDS::Parser::Node->new(1, {constructor => \&CDS::Commands::Help::new, function => \&CDS::Commands::Help::help});
1279 0         0 $cds->addArrow($help, 1, 0, 'help');
1280 0         0 $parser->start->addDefault($cds);
1281              
1282 0         0 CDS::Commands::ActorGroup->register($cds, $help);
1283 0         0 CDS::Commands::Announce->register($cds, $help);
1284 0         0 CDS::Commands::Book->register($cds, $help);
1285 0         0 CDS::Commands::CheckKeyPair->register($cds, $help);
1286 0         0 CDS::Commands::CollectGarbage->register($cds, $help);
1287 0         0 CDS::Commands::CreateKeyPair->register($cds, $help);
1288 0         0 CDS::Commands::Curl->register($cds, $help);
1289 0         0 CDS::Commands::DiscoverActorGroup->register($cds, $help);
1290 0         0 CDS::Commands::EntrustedActors->register($cds, $help);
1291 0         0 CDS::Commands::FolderStore->register($cds, $help);
1292 0         0 CDS::Commands::Get->register($cds, $help);
1293 0         0 CDS::Commands::Help->register($cds, $help);
1294 0         0 CDS::Commands::List->register($cds, $help);
1295 0         0 CDS::Commands::Modify->register($cds, $help);
1296 0         0 CDS::Commands::OpenEnvelope->register($cds, $help);
1297 0         0 CDS::Commands::Put->register($cds, $help);
1298 0         0 CDS::Commands::Remember->register($cds, $help);
1299 0         0 CDS::Commands::Select->register($cds, $help);
1300 0         0 CDS::Commands::ShowCard->register($cds, $help);
1301 0         0 CDS::Commands::ShowKeyPair->register($cds, $help);
1302 0         0 CDS::Commands::ShowMessages->register($cds, $help);
1303 0         0 CDS::Commands::ShowObject->register($cds, $help);
1304 0         0 CDS::Commands::ShowPrivateData->register($cds, $help);
1305 0         0 CDS::Commands::ShowTree->register($cds, $help);
1306 0         0 CDS::Commands::StartHTTPServer->register($cds, $help);
1307 0         0 CDS::Commands::Transfer->register($cds, $help);
1308 0         0 CDS::Commands::UseCache->register($cds, $help);
1309 0         0 CDS::Commands::UseStore->register($cds, $help);
1310 0         0 CDS::Commands::Welcome->register($cds, $help);
1311 0         0 CDS::Commands::WhatIs->register($cds, $help);
1312              
1313 0 0       0 if ($isCompletion) {
1314 0         0 my $line = $ENV{COMP_LINE};
1315 0 0       0 $line = substr($line, 0, $ENV{COMP_POINT}) if exists $ENV{COMP_POINT};
1316 0         0 $parser->showCompletions($line);
1317             } else {
1318 0         0 $actor->ui->pushIndent;
1319 0         0 $parser->execute(@ARGV);
1320 0         0 $actor->ui->popIndent;
1321 0         0 $actor->ui->removeProgress;
1322 0 0       0 return 1 if $actor->ui->hasError;
1323             }
1324              
1325 0         0 return 0;
1326             }
1327              
1328             sub new {
1329 0     0   0 my $class = shift;
1330 0         0 my $actor = shift;
1331              
1332 0         0 return bless {actor => $actor};
1333             }
1334              
1335             sub default {
1336 0     0   0 my $o = shift;
1337 0         0 my $cmd = shift;
1338              
1339 0         0 my $ui = $o->{actor}->ui;
1340              
1341             # Version
1342 0         0 $ui->space;
1343 0         0 $ui->title('Condensation CLI');
1344 0         0 $ui->line('Version ', $CDS::VERSION, ', ', $CDS::releaseDate, '.');
1345              
1346             # Welcome message
1347 0         0 my $welcome = CDS::Commands::Welcome->new($o->{actor});
1348 0 0       0 if ($welcome->isEnabled) {
1349 0         0 $welcome->show;
1350             } else {
1351 0         0 $ui->line('Type "cds help" to get help.');
1352             }
1353              
1354             # Actor info
1355 0         0 $ui->space;
1356 0         0 $ui->title('Your key pair');
1357 0         0 CDS::Commands::ShowKeyPair->new($o->{actor})->show($o->{actor}->keyPairToken);
1358              
1359 0         0 $ui->space;
1360 0         0 $ui->title('Your stores');
1361 0         0 $ui->line($ui->darkBold('Storage store '), $o->{actor}->storageStore->url);
1362 0         0 $ui->line($ui->darkBold('Messaging store '), $o->{actor}->messagingStoreUrl);
1363              
1364             # Read messages to merge any data before displaying the rest
1365 0         0 $ui->space;
1366 0         0 $o->{actor}->readMessages;
1367              
1368 0         0 $ui->space;
1369 0         0 $ui->title('Your actor group');
1370 0         0 $o->{actor}->registerIfNecessary;
1371 0         0 CDS::Commands::ActorGroup->new($o->{actor})->show;
1372              
1373 0         0 $ui->space;
1374 0         0 $ui->title('Your entrusted actors');
1375 0         0 CDS::Commands::EntrustedActors->new($o->{actor})->show;
1376              
1377 0         0 $ui->space;
1378 0         0 $ui->title('Selection (in this terminal)');
1379 0         0 CDS::Commands::Select->new($o->{actor})->showSelection;
1380              
1381 0         0 $ui->space;
1382 0         0 $ui->title('Remembered values');
1383 0         0 CDS::Commands::Remember->new($o->{actor})->showRememberedValues;
1384              
1385             # Announce if necessary
1386 0         0 $ui->space;
1387 0         0 $o->{actor}->announceIfNecessary;
1388              
1389             # Save any changes
1390 0         0 $o->{actor}->saveOrShowError;
1391 0         0 $ui->space;
1392 0         0 return;
1393             }
1394              
1395             package CDS::CLIActor;
1396              
1397 1     1   9583 use parent -norequire, 'CDS::ActorWithDocument';
  1         2  
  1         6  
1398              
1399             sub openOrCreateDefault {
1400 0     0   0 my $class = shift;
1401 0         0 my $ui = shift;
1402              
1403 0         0 $class->open(CDS::Configuration->getOrCreateDefault($ui));
1404             }
1405              
1406             sub open {
1407 0     0   0 my $class = shift;
1408 0         0 my $configuration = shift;
1409              
1410             # Read the store configuration
1411 0         0 my $ui = $configuration->ui;
1412 0         0 my $storeManager = CDS::CLIStoreManager->new($ui);
1413              
1414 0         0 my $storageStoreUrl = $configuration->storageStoreUrl;
1415 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'), '".');
1416              
1417 0         0 my $messagingStoreUrl = $configuration->messagingStoreUrl;
1418 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'), '".');
1419              
1420             # Read the key pair
1421 0   0     0 my $keyPair = $configuration->keyPair // return $ui->error('Your key pair (', $configuration->file('key-pair'), ') is missing.');
1422              
1423             # Create the actor
1424 0         0 my $publicKeyCache = CDS::PublicKeyCache->new(128);
1425 0         0 my $o = $class->SUPER::new($keyPair, $storageStore, $messagingStore, $messagingStoreUrl, $publicKeyCache);
1426 0         0 $o->{ui} = $ui;
1427 0         0 $o->{storeManager} = $storeManager;
1428 0         0 $o->{configuration} = $configuration;
1429 0         0 $o->{sessionRoot} = $o->localRoot->child('sessions')->child(''.getppid);
1430 0         0 $o->{keyPairToken} = CDS::KeyPairToken->new($configuration->file('key-pair'), $keyPair);
1431              
1432             # Message handlers
1433 0         0 $o->{messageHandlers} = {};
1434 0         0 $o->setMessageHandler('sender', \&onIgnoreMessage);
1435 0         0 $o->setMessageHandler('store', \&onIgnoreMessage);
1436 0         0 $o->setMessageHandler('group data', \&onGroupDataMessage);
1437              
1438             # Read the private data
1439 0 0       0 if (! $o->procurePrivateData) {
1440 0         0 $o->{ui}->space;
1441 0         0 $ui->pRed('Failed to read the local private data.');
1442 0         0 $o->{ui}->space;
1443 0         0 return;
1444             }
1445              
1446 0         0 return $o;
1447             }
1448              
1449 0     0   0 sub ui { shift->{ui} }
1450 0     0   0 sub storeManager { shift->{storeManager} }
1451 0     0   0 sub configuration { shift->{configuration} }
1452 0     0   0 sub sessionRoot { shift->{sessionRoot} }
1453 0     0   0 sub keyPairToken { shift->{keyPairToken} }
1454              
1455             ### Saving
1456              
1457             sub saveOrShowError {
1458 0     0   0 my $o = shift;
1459              
1460 0         0 $o->forgetOldSessions;
1461 0         0 my ($ok, $missingHash) = $o->savePrivateDataAndShareGroupData;
1462 0 0       0 return if ! $ok;
1463 0 0       0 return $o->onMissingObject($missingHash) if $missingHash;
1464 0         0 $o->sendMessages;
1465 0         0 return 1;
1466             }
1467              
1468             sub onMissingObject {
1469 0     0   0 my $o = shift;
1470 0 0 0     0 my $missingObject = shift; die 'wrong type '.ref($missingObject).' for $missingObject' if defined $missingObject && ref $missingObject ne 'CDS::Object';
  0         0  
1471              
1472 0         0 $o->{ui}->space;
1473 0         0 $o->{ui}->pRed('The object ', $missingObject->hash->hex, ' was missing while saving data.');
1474 0         0 $o->{ui}->space;
1475 0         0 $o->{ui}->p('This is a fatal error with two possible sources:');
1476 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.');
1477 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.');
1478 0         0 $o->{ui}->space;
1479             }
1480              
1481             sub onGroupDataSharingStoreError {
1482 0     0   0 my $o = shift;
1483 0 0 0     0 my $recipientActorOnStore = shift; die 'wrong type '.ref($recipientActorOnStore).' for $recipientActorOnStore' if defined $recipientActorOnStore && ref $recipientActorOnStore ne 'CDS::ActorOnStore';
  0         0  
1484 0         0 my $storeError = shift;
1485              
1486 0         0 $o->{ui}->space;
1487 0         0 $o->{ui}->pRed('Unable to share the group data with ', $recipientActorOnStore->publicKey->hash->hex, '.');
1488 0         0 $o->{ui}->space;
1489             }
1490              
1491             ### Reading
1492              
1493             sub onPrivateRootReadingInvalidEntry {
1494 0     0   0 my $o = shift;
1495 0 0 0     0 my $source = shift; die 'wrong type '.ref($source).' for $source' if defined $source && ref $source ne 'CDS::Source';
  0         0  
1496 0         0 my $reason = shift;
1497              
1498 0         0 $o->{ui}->space;
1499 0         0 $o->{ui}->pRed('The envelope ', $source->hash->shortHex, ' points to invalid private data (', $reason, ').');
1500 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:');
1501 0         0 $o->{ui}->line(' cds open envelope ', $source->hash->hex, ' from ', $source->actorOnStore->publicKey->hash->hex, ' on ', $source->actorOnStore->store->url);
1502 0         0 $o->{ui}->line(' cds show record ', $source->hash->hex, ' on ', $source->actorOnStore->store->url);
1503 0         0 $o->{ui}->line(' cds list private box of ', $source->actorOnStore->publicKey->hash->hex, ' on ', $source->actorOnStore->store->url);
1504 0         0 $o->{ui}->p('To remove the invalid entry, type:');
1505 0         0 $o->{ui}->line(' cds remove ', $source->hash->hex, ' from private box of ', $source->actorOnStore->publicKey->hash->hex, ' on ', $source->actorOnStore->store->url);
1506 0         0 $o->{ui}->space;
1507             }
1508              
1509             sub onVerifyMemberStore {
1510 0     0   0 my $o = shift;
1511 0         0 my $storeUrl = shift;
1512 0 0 0     0 my $actorSelector = shift; die 'wrong type '.ref($actorSelector).' for $actorSelector' if defined $actorSelector && ref $actorSelector ne 'CDS::Selector';
  0         0  
1513 0         0 $o->storeForUrl($storeUrl) }
1514              
1515             ### Announcing
1516              
1517             sub registerIfNecessary {
1518 0     0   0 my $o = shift;
1519              
1520 0         0 my $now = CDS->now;
1521 0 0       0 return if $o->{actorSelector}->revision > $now - CDS->DAY;
1522 0         0 $o->updateMyRegistration;
1523 0         0 $o->setMyActiveFlag(1);
1524 0         0 $o->setMyGroupDataFlag(1);
1525             }
1526              
1527             sub announceIfNecessary {
1528 0     0   0 my $o = shift;
1529              
1530 0         0 my $state = join('', map { CDS->bytesFromUnsigned($_->revision) } sort { $a->label cmp $b->label } $o->{actorGroupSelector}->children);
  0         0  
  0         0  
1531 0         0 $o->announceOnStoreIfNecessary($o->{storageStore}, $state);
1532 0 0       0 $o->announceOnStoreIfNecessary($o->{messagingStore}, $state) if $o->{messagingStore}->id ne $o->{storageStore}->id;
1533             }
1534              
1535             sub announceOnStoreIfNecessary {
1536 0     0   0 my $o = shift;
1537 0         0 my $store = shift;
1538 0         0 my $state = shift;
1539              
1540 0         0 my $stateSelector = $o->{localRoot}->child('announced')->childWithText($store->id);
1541 0 0       0 return if $stateSelector->bytesValue eq $state;
1542 0         0 my ($envelopeHash, $cardHash) = $o->announce($store);
1543 0 0       0 return $o->{ui}->pRed('Updating the card on ', $store->url, ' failed.') if ! $envelopeHash;
1544 0         0 $stateSelector->setBytes($state);
1545 0         0 $o->{ui}->pGreen('The card on ', $store->url, ' has been updated.');
1546 0         0 return 1;
1547             }
1548              
1549             ### Store resolving
1550              
1551             sub storeForUrl {
1552 0     0   0 my $o = shift;
1553 0         0 my $url = shift;
1554              
1555 0         0 $o->{storeManager}->setCacheStoreUrl($o->{sessionRoot}->child('use cache')->textValue);
1556 0         0 return $o->{storeManager}->storeForUrl($url);
1557             }
1558              
1559             ### Processing messages
1560              
1561             sub setMessageHandler {
1562 0     0   0 my $o = shift;
1563 0         0 my $type = shift;
1564 0         0 my $handler = shift;
1565              
1566 0         0 $o->{messageHandlers}->{$type} = $handler;
1567             }
1568              
1569             sub readMessages {
1570 0     0   0 my $o = shift;
1571              
1572 0         0 $o->{ui}->title('Messages');
1573 0         0 $o->{countMessages} = 0;
1574 0         0 $o->{messageBoxReader}->read;
1575 0 0       0 $o->{ui}->line($o->{ui}->gray('none')) if ! $o->{countMessages};
1576             }
1577              
1578             sub onMessageBoxVerifyStore {
1579 0     0   0 my $o = shift;
1580 0         0 my $senderStoreUrl = shift;
1581 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
1582 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
1583 0 0 0     0 my $senderHash = shift; die 'wrong type '.ref($senderHash).' for $senderHash' if defined $senderHash && ref $senderHash ne 'CDS::Hash';
  0         0  
1584              
1585 0         0 return $o->storeForUrl($senderStoreUrl);
1586             }
1587              
1588             sub onMessageBoxEntry {
1589 0     0   0 my $o = shift;
1590 0         0 my $message = shift;
1591              
1592 0         0 $o->{countMessages} += 1;
1593              
1594 0         0 for my $section ($message->content->children) {
1595 0         0 my $type = $section->bytes;
1596 0   0     0 my $handler = $o->{messageHandlers}->{$type} // \&onUnknownMessage;
1597 0         0 &$handler($o, $message, $section);
1598             }
1599              
1600             # 1. message processed
1601             # -> source can be deleted immediately (e.g. invalid)
1602             # source.discard()
1603             # -> source has been merged, and will be deleted when changes have been saved
1604             # document.addMergedSource(source)
1605             # 2. wait for sender store
1606             # -> set entry.waitForStore = senderStore
1607             # 3. skip
1608             # -> set entry.processed = false
1609              
1610 0         0 my $source = $message->source;
1611 0         0 $message->source->discard;
1612             }
1613              
1614             sub onGroupDataMessage {
1615 0     0   0 my $o = shift;
1616 0         0 my $message = shift;
1617 0         0 my $section = shift;
1618              
1619 0         0 my $ok = $o->{groupDataSharer}->processGroupDataMessage($message, $section);
1620 0         0 $o->{groupDocument}->read;
1621 0 0       0 return $o->{ui}->line('Group data from ', $message->sender->publicKey->hash->hex) if $ok;
1622 0         0 $o->{ui}->line($o->{ui}->red('Group data from foreign actor ', $message->sender->publicKey->hash->hex, ' (ignored)'));
1623             }
1624              
1625             sub onIgnoreMessage {
1626 0     0   0 my $o = shift;
1627 0         0 my $message = shift;
1628 0         0 my $section = shift;
1629             }
1630              
1631             sub onUnknownMessage {
1632 0     0   0 my $o = shift;
1633 0         0 my $message = shift;
1634 0         0 my $section = shift;
1635              
1636 0         0 $o->{ui}->line($o->{ui}->orange('Unknown message of type "', $section->asText, '" from ', $message->sender->publicKey->hash->hex));
1637             }
1638              
1639             sub onMessageBoxInvalidEntry {
1640 0     0   0 my $o = shift;
1641 0 0 0     0 my $source = shift; die 'wrong type '.ref($source).' for $source' if defined $source && ref $source ne 'CDS::Source';
  0         0  
1642 0         0 my $reason = shift;
1643              
1644 0         0 $o->{ui}->warning('Discarding invalid message ', $source->hash->hex, ' (', $reason, ').');
1645 0         0 $source->discard;
1646             }
1647              
1648             ### Remembered values
1649              
1650             sub labelSelector {
1651 0     0   0 my $o = shift;
1652 0         0 my $label = shift;
1653              
1654 0         0 my $bytes = Encode::encode_utf8($label);
1655 0         0 return $o->groupRoot->child('labels')->child($bytes);
1656             }
1657              
1658             sub remembered {
1659 0     0   0 my $o = shift;
1660 0         0 my $label = shift;
1661              
1662 0         0 return $o->labelSelector($label)->record;
1663             }
1664              
1665             sub remember {
1666 0     0   0 my $o = shift;
1667 0         0 my $label = shift;
1668 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
1669              
1670 0         0 $o->labelSelector($label)->set($record);
1671             }
1672              
1673             sub rememberedRecords {
1674 0     0   0 my $o = shift;
1675              
1676 0         0 my $records = {};
1677 0         0 for my $child ($o->{groupRoot}->child('labels')->children) {
1678 0 0       0 next if ! $child->isSet;
1679 0         0 my $label = Encode::decode_utf8($child->label);
1680 0         0 $records->{$label} = $child->record;
1681             }
1682              
1683 0         0 return $records;
1684             }
1685              
1686             sub storeLabel {
1687 0     0   0 my $o = shift;
1688 0         0 my $storeUrl = shift;
1689              
1690 0         0 my $records = $o->rememberedRecords;
1691 0         0 for my $label (keys %$records) {
1692 0         0 my $record = $records->{$label};
1693 0 0       0 next if length $record->child('actor')->bytesValue;
1694 0 0       0 next if $storeUrl ne $record->child('store')->textValue;
1695 0         0 return $label;
1696             }
1697              
1698 0         0 return;
1699             }
1700              
1701             sub actorLabel {
1702 0     0   0 my $o = shift;
1703 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
1704              
1705 0         0 my $records = $o->rememberedRecords;
1706 0         0 for my $label (keys %$records) {
1707 0         0 my $record = $records->{$label};
1708 0 0       0 next if $actorHash->bytes ne $record->child('actor')->bytesValue;
1709 0         0 return $label;
1710             }
1711              
1712 0         0 return;
1713             }
1714              
1715             sub actorLabelByHashStartBytes {
1716 0     0   0 my $o = shift;
1717 0         0 my $actorHashStartBytes = shift;
1718              
1719 0         0 my $length = length $actorHashStartBytes;
1720 0         0 my $records = $o->rememberedRecords;
1721 0         0 for my $label (keys %$records) {
1722 0         0 my $record = $records->{$label};
1723 0 0       0 next if $actorHashStartBytes ne substr($record->child('actor')->bytesValue, 0, $length);
1724 0         0 return $label;
1725             }
1726              
1727 0         0 return;
1728             }
1729              
1730             sub accountLabel {
1731 0     0   0 my $o = shift;
1732 0         0 my $storeUrl = shift;
1733 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
1734              
1735 0         0 my $storeLabel;
1736             my $actorLabel;
1737              
1738 0         0 my $records = $o->rememberedRecords;
1739 0         0 for my $label (keys %$records) {
1740 0         0 my $record = $records->{$label};
1741 0         0 my $actorBytes = $record->child('actor')->bytesValue;
1742              
1743 0         0 my $correctActor = $actorHash->bytes eq $actorBytes;
1744 0 0       0 $actorLabel = $label if $correctActor;
1745              
1746 0 0       0 if ($storeUrl eq $record->child('store')->textValue) {
1747 0 0       0 return $label if $correctActor;
1748 0 0       0 $storeLabel = $label if ! length $actorBytes;
1749             }
1750             }
1751              
1752 0         0 return (undef, $storeLabel, $actorLabel);
1753             }
1754              
1755             sub keyPairLabel {
1756 0     0   0 my $o = shift;
1757 0         0 my $file = shift;
1758              
1759 0         0 my $records = $o->rememberedRecords;
1760 0         0 for my $label (keys %$records) {
1761 0         0 my $record = $records->{$label};
1762 0 0       0 next if $file ne $record->child('key pair')->textValue;
1763 0         0 return $label;
1764             }
1765              
1766 0         0 return;
1767             }
1768              
1769             ### References that can be used in commands
1770              
1771             sub actorReference {
1772 0     0   0 my $o = shift;
1773 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
1774              
1775 0   0     0 return $o->actorLabel($actorHash) // $actorHash->hex;
1776             }
1777              
1778             sub storeReference {
1779 0     0   0 my $o = shift;
1780 0         0 my $store = shift;
1781 0         0 $o->storeUrlReference($store->url); }
1782              
1783             sub storeUrlReference {
1784 0     0   0 my $o = shift;
1785 0         0 my $storeUrl = shift;
1786              
1787 0   0     0 return $o->storeLabel($storeUrl) // $storeUrl;
1788             }
1789              
1790             sub accountReference {
1791 0     0   0 my $o = shift;
1792 0         0 my $accountToken = shift;
1793              
1794 0         0 my ($accountLabel, $storeLabel, $actorLabel) = $o->accountLabel($accountToken->{cliStore}->url, $accountToken->{actorHash});
1795 0 0       0 return $accountLabel if defined $accountLabel;
1796 0 0       0 return defined $actorLabel ? $actorLabel : $accountToken->{actorHash}->hex, ' on ', defined $storeLabel ? $storeLabel : $accountToken->{cliStore}->url;
    0          
1797             }
1798              
1799             sub boxReference {
1800 0     0   0 my $o = shift;
1801 0         0 my $boxToken = shift;
1802              
1803 0         0 return $o->boxName($boxToken->{boxLabel}), ' of ', $o->accountReference($boxToken->{accountToken});
1804             }
1805              
1806             sub keyPairReference {
1807 0     0   0 my $o = shift;
1808 0         0 my $keyPairToken = shift;
1809              
1810 0   0     0 return $o->keyPairLabel($keyPairToken->file) // $keyPairToken->file;
1811             }
1812              
1813             sub blueActorReference {
1814 0     0   0 my $o = shift;
1815 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
1816              
1817 0         0 my $label = $o->actorLabel($actorHash);
1818 0 0       0 return defined $label ? $o->{ui}->blue($label) : $actorHash->hex;
1819             }
1820              
1821             sub blueStoreReference {
1822 0     0   0 my $o = shift;
1823 0         0 my $store = shift;
1824 0         0 $o->blueStoreUrlReference($store->url); }
1825              
1826             sub blueStoreUrlReference {
1827 0     0   0 my $o = shift;
1828 0         0 my $storeUrl = shift;
1829              
1830 0         0 my $label = $o->storeLabel($storeUrl);
1831 0 0       0 return defined $label ? $o->{ui}->blue($label) : $storeUrl;
1832             }
1833              
1834             sub blueAccountReference {
1835 0     0   0 my $o = shift;
1836 0         0 my $accountToken = shift;
1837              
1838 0         0 my ($accountLabel, $storeLabel, $actorLabel) = $o->accountLabel($accountToken->{cliStore}->url, $accountToken->{actorHash});
1839 0 0       0 return $o->{ui}->blue($accountLabel) if defined $accountLabel;
1840 0 0       0 return defined $actorLabel ? $o->{ui}->blue($actorLabel) : $accountToken->{actorHash}->hex, ' on ', defined $storeLabel ? $o->{ui}->blue($storeLabel) : $accountToken->{cliStore}->url;
    0          
1841             }
1842              
1843             sub blueBoxReference {
1844 0     0   0 my $o = shift;
1845 0         0 my $boxToken = shift;
1846              
1847 0         0 return $o->boxName($boxToken->{boxLabel}), ' of ', $o->blueAccountReference($boxToken->{accountToken});
1848             }
1849              
1850             sub blueKeyPairReference {
1851 0     0   0 my $o = shift;
1852 0         0 my $keyPairToken = shift;
1853              
1854 0         0 my $label = $o->keyPairLabel($keyPairToken->file);
1855 0 0       0 return defined $label ? $o->{ui}->blue($label) : $keyPairToken->file;
1856             }
1857              
1858             sub boxName {
1859 0     0   0 my $o = shift;
1860 0         0 my $boxLabel = shift;
1861              
1862 0 0       0 return 'private box' if $boxLabel eq 'private';
1863 0 0       0 return 'public box' if $boxLabel eq 'public';
1864 0 0       0 return 'message box' if $boxLabel eq 'messages';
1865 0         0 return $boxLabel;
1866             }
1867              
1868             ### Session
1869              
1870             sub forgetOldSessions {
1871 0     0   0 my $o = shift;
1872              
1873 0         0 for my $child ($o->{sessionRoot}->parent->children) {
1874 0         0 my $pid = $child->label;
1875 0 0       0 next if -e '/proc/'.$pid;
1876 0         0 $child->forgetBranch;
1877             }
1878             }
1879              
1880             sub selectedKeyPairToken {
1881 0     0   0 my $o = shift;
1882              
1883 0         0 my $file = $o->{sessionRoot}->child('selected key pair')->textValue;
1884 0 0       0 return if ! length $file;
1885 0   0     0 my $keyPair = CDS::KeyPair->fromFile($file) // return;
1886 0         0 return CDS::KeyPairToken->new($file, $keyPair);
1887             }
1888              
1889             sub selectedStoreUrl {
1890 0     0   0 my $o = shift;
1891              
1892 0         0 my $storeUrl = $o->{sessionRoot}->child('selected store')->textValue;
1893 0 0       0 return if ! length $storeUrl;
1894 0         0 return $storeUrl;
1895             }
1896              
1897             sub selectedStore {
1898 0     0   0 my $o = shift;
1899              
1900 0   0     0 my $storeUrl = $o->selectedStoreUrl // return;
1901 0         0 return $o->storeForUrl($storeUrl);
1902             }
1903              
1904             sub selectedActorHash {
1905 0     0   0 my $o = shift;
1906              
1907 0         0 return CDS::Hash->fromBytes($o->{sessionRoot}->child('selected actor')->bytesValue);
1908             }
1909              
1910             sub preferredKeyPairToken {
1911 0     0   0 my $o = shift;
1912 0   0     0 $o->selectedKeyPairToken // $o->keyPairToken }
1913             sub preferredStore {
1914 0     0   0 my $o = shift;
1915 0   0     0 $o->selectedStore // $o->storageStore }
1916             sub preferredStores {
1917 0     0   0 my $o = shift;
1918 0   0     0 $o->selectedStore // ($o->storageStore, $o->messagingStore) }
1919             sub preferredActorHash {
1920 0     0   0 my $o = shift;
1921 0   0     0 $o->selectedActorHash // $o->keyPair->publicKey->hash }
1922              
1923             ### Common functions
1924              
1925             sub uiGetObject {
1926 0     0   0 my $o = shift;
1927 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
1928 0         0 my $store = shift;
1929 0         0 my $keyPairToken = shift;
1930              
1931 0         0 my ($object, $storeError) = $store->get($hash, $keyPairToken->keyPair);
1932 0 0       0 return if defined $storeError;
1933 0 0       0 return $o->{ui}->error('The object ', $hash->hex, ' does not exist on "', $store->url, '".') if ! $object;
1934 0         0 return $object;
1935             }
1936              
1937             sub uiGetRecord {
1938 0     0   0 my $o = shift;
1939 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
1940 0         0 my $store = shift;
1941 0         0 my $keyPairToken = shift;
1942              
1943 0   0     0 my $object = $o->uiGetObject($hash, $store, $keyPairToken) // return;
1944 0   0     0 return CDS::Record->fromObject($object) // return $o->{ui}->error('The object ', $hash->hex, ' is not a record.');
1945             }
1946              
1947             sub uiGetPublicKey {
1948 0     0   0 my $o = shift;
1949 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
1950 0         0 my $store = shift;
1951 0         0 my $keyPairToken = shift;
1952              
1953 0   0     0 my $object = $o->uiGetObject($hash, $store, $keyPairToken) // return;
1954 0   0     0 return CDS::PublicKey->fromObject($object) // return $o->{ui}->error('The object ', $hash->hex, ' is not a public key.');
1955             }
1956              
1957             sub isEnvelope {
1958 0     0   0 my $o = shift;
1959 0 0 0     0 my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0         0  
1960              
1961 0   0     0 my $record = CDS::Record->fromObject($object) // return;
1962 0 0       0 return if ! $record->contains('signed');
1963 0         0 my $signatureRecord = $record->child('signature')->firstChild;
1964 0 0       0 return if ! $signatureRecord->hash;
1965 0 0       0 return if ! length $signatureRecord->bytes;
1966 0         0 return 1;
1967             }
1968              
1969             package CDS::CLIStoreManager;
1970              
1971             sub new {
1972 0     0   0 my $class = shift;
1973 0         0 my $ui = shift;
1974              
1975 0         0 return bless {ui => $ui, failedStores => {}};
1976             }
1977              
1978 0     0   0 sub ui { shift->{ui} }
1979              
1980             sub rawStoreForUrl {
1981 0     0   0 my $o = shift;
1982 0         0 my $url = shift;
1983              
1984 0 0       0 return if ! $url;
1985             return
1986 0   0     0 CDS::FolderStore->forUrl($url) //
      0        
1987             CDS::HTTPStore->forUrl($url) //
1988             undef;
1989             }
1990              
1991             sub storeForUrl {
1992 0     0   0 my $o = shift;
1993 0         0 my $url = shift;
1994              
1995 0         0 my $store = $o->rawStoreForUrl($url);
1996 0         0 my $progressStore = CDS::UI::ProgressStore->new($store, $url, $o->{ui});
1997 0 0       0 my $cachedStore = defined $o->{cacheStore} ? CDS::ObjectCache->new($progressStore, $o->{cacheStore}) : $progressStore;
1998 0         0 return CDS::ErrorHandlingStore->new($cachedStore, $url, $o);
1999             }
2000              
2001             sub onStoreSuccess {
2002 0     0   0 my $o = shift;
2003 0         0 my $store = shift;
2004 0         0 my $function = shift;
2005              
2006 0         0 delete $o->{failedStores}->{$store->store->id};
2007             }
2008              
2009             sub onStoreError {
2010 0     0   0 my $o = shift;
2011 0         0 my $store = shift;
2012 0         0 my $function = shift;
2013 0         0 my $error = shift;
2014              
2015 0         0 $o->{failedStores}->{$store->store->id} = 1;
2016 0         0 $o->{ui}->error('The store "', $store->{url}, '" reports: ', $error);
2017             }
2018              
2019             sub hasStoreError {
2020 0     0   0 my $o = shift;
2021 0         0 my $store = shift;
2022 0         0 my $function = shift;
2023              
2024 0 0       0 return if ! $o->{failedStores}->{$store->store->id};
2025 0         0 $o->{ui}->error('Ignoring store "', $store->{url}, '", because it previously reported errors.');
2026 0         0 return 1;
2027             }
2028              
2029             sub setCacheStoreUrl {
2030 0     0   0 my $o = shift;
2031 0         0 my $storeUrl = shift;
2032              
2033 0 0 0     0 return if ($storeUrl // '') eq ($o->{cacheStoreUrl} // '');
      0        
2034 0         0 $o->{cacheStoreUrl} = $storeUrl;
2035 0         0 $o->{cacheStore} = $o->rawStoreForUrl($storeUrl);
2036             }
2037              
2038             package CDS::CheckSignatureStore;
2039              
2040             sub new {
2041 0     0   0 my $o = shift;
2042 0         0 my $store = shift;
2043 0         0 my $objects = shift;
2044              
2045 0   0     0 return bless {
2046             store => $store,
2047             id => "Check signature store\n".$store->id,
2048             objects => $objects // {},
2049             };
2050             }
2051              
2052 0     0   0 sub id { shift->{id} }
2053              
2054             sub get {
2055 0     0   0 my $o = shift;
2056 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
2057 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
2058              
2059 0   0     0 my $entry = $o->{objects}->{$hash->bytes} // return $o->{store}->get($hash);
2060 0         0 return $entry->{object};
2061             }
2062              
2063             sub book {
2064 0     0   0 my $o = shift;
2065 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
2066 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
2067              
2068 0         0 return exists $o->{objects}->{$hash->bytes};
2069             }
2070              
2071             sub put {
2072 0     0   0 my $o = shift;
2073 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
2074 0 0 0     0 my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0         0  
2075 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
2076              
2077 0         0 $o->{objects}->{$hash->bytes} = {hash => $hash, object => $object};
2078 0         0 return;
2079             }
2080              
2081             sub list {
2082 0     0   0 my $o = shift;
2083 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
2084 0         0 my $boxLabel = shift;
2085 0         0 my $timeout = shift;
2086 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
2087              
2088 0         0 return 'This store only handles objects.';
2089             }
2090              
2091             sub add {
2092 0     0   0 my $o = shift;
2093 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
2094 0         0 my $boxLabel = shift;
2095 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
2096 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
2097              
2098 0         0 return 'This store only handles objects.';
2099             }
2100              
2101             sub remove {
2102 0     0   0 my $o = shift;
2103 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
2104 0         0 my $boxLabel = shift;
2105 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
2106 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
2107              
2108 0         0 return 'This store only handles objects.';
2109             }
2110              
2111             sub modify {
2112 0     0   0 my $o = shift;
2113 0         0 my $modifications = shift;
2114 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
2115              
2116 0         0 return $modifications->executeIndividually($o, $keyPair);
2117             }
2118              
2119             # BEGIN AUTOGENERATED
2120             package CDS::Commands::ActorGroup;
2121              
2122             sub register {
2123 0     0   0 my $class = shift;
2124 0         0 my $cds = shift;
2125 0         0 my $help = shift;
2126              
2127 0         0 my $node000 = CDS::Parser::Node->new(0);
2128 0         0 my $node001 = CDS::Parser::Node->new(0);
2129 0         0 my $node002 = CDS::Parser::Node->new(0);
2130 0         0 my $node003 = CDS::Parser::Node->new(0);
2131 0         0 my $node004 = CDS::Parser::Node->new(0);
2132 0         0 my $node005 = CDS::Parser::Node->new(0);
2133 0         0 my $node006 = CDS::Parser::Node->new(0);
2134 0         0 my $node007 = CDS::Parser::Node->new(0);
2135 0         0 my $node008 = CDS::Parser::Node->new(0);
2136 0         0 my $node009 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
2137 0         0 my $node010 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&show});
2138 0         0 my $node011 = CDS::Parser::Node->new(0);
2139 0         0 my $node012 = CDS::Parser::Node->new(0);
2140 0         0 my $node013 = CDS::Parser::Node->new(0);
2141 0         0 my $node014 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&joinMember});
2142 0         0 my $node015 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&setMember});
2143 0         0 my $node016 = CDS::Parser::Node->new(0);
2144 0         0 $cds->addArrow($node001, 1, 0, 'show');
2145 0         0 $cds->addArrow($node003, 1, 0, 'join');
2146 0         0 $cds->addArrow($node004, 1, 0, 'set');
2147 0         0 $help->addArrow($node000, 1, 0, 'actor');
2148 0         0 $node000->addArrow($node009, 1, 0, 'group');
2149 0         0 $node001->addArrow($node002, 1, 0, 'actor');
2150 0         0 $node002->addArrow($node010, 1, 0, 'group');
2151 0         0 $node003->addArrow($node005, 1, 0, 'member');
2152 0         0 $node004->addArrow($node007, 1, 0, 'member');
2153 0         0 $node005->addDefault($node006);
2154 0         0 $node005->addArrow($node011, 1, 0, 'ACTOR', \&collectActor);
2155 0         0 $node006->addArrow($node006, 1, 0, 'ACCOUNT', \&collectAccount);
2156 0         0 $node006->addArrow($node014, 1, 1, 'ACCOUNT', \&collectAccount);
2157 0         0 $node007->addDefault($node008);
2158 0         0 $node008->addArrow($node008, 1, 0, 'ACTOR', \&collectActor1);
2159 0         0 $node008->addArrow($node013, 1, 0, 'ACTOR', \&collectActor1);
2160 0         0 $node011->addArrow($node012, 1, 0, 'on');
2161 0         0 $node012->addArrow($node014, 1, 0, 'STORE', \&collectStore);
2162 0         0 $node013->addArrow($node015, 1, 0, 'active', \&collectActive);
2163 0         0 $node013->addArrow($node015, 1, 0, 'backup', \&collectBackup);
2164 0         0 $node013->addArrow($node015, 1, 0, 'idle', \&collectIdle);
2165 0         0 $node013->addArrow($node015, 1, 0, 'revoked', \&collectRevoked);
2166 0         0 $node014->addArrow($node016, 1, 0, 'and');
2167 0         0 $node016->addDefault($node005);
2168             }
2169              
2170             sub collectAccount {
2171 0     0   0 my $o = shift;
2172 0         0 my $label = shift;
2173 0         0 my $value = shift;
2174              
2175 0         0 push @{$o->{accountTokens}}, $value;
  0         0  
2176             }
2177              
2178             sub collectActive {
2179 0     0   0 my $o = shift;
2180 0         0 my $label = shift;
2181 0         0 my $value = shift;
2182              
2183 0         0 $o->{status} = 'active';
2184             }
2185              
2186             sub collectActor {
2187 0     0   0 my $o = shift;
2188 0         0 my $label = shift;
2189 0         0 my $value = shift;
2190              
2191 0         0 $o->{actorHash} = $value;
2192             }
2193              
2194             sub collectActor1 {
2195 0     0   0 my $o = shift;
2196 0         0 my $label = shift;
2197 0         0 my $value = shift;
2198              
2199 0         0 push @{$o->{actorHashes}}, $value;
  0         0  
2200             }
2201              
2202             sub collectBackup {
2203 0     0   0 my $o = shift;
2204 0         0 my $label = shift;
2205 0         0 my $value = shift;
2206              
2207 0         0 $o->{status} = 'backup';
2208             }
2209              
2210             sub collectIdle {
2211 0     0   0 my $o = shift;
2212 0         0 my $label = shift;
2213 0         0 my $value = shift;
2214              
2215 0         0 $o->{status} = 'idle';
2216             }
2217              
2218             sub collectRevoked {
2219 0     0   0 my $o = shift;
2220 0         0 my $label = shift;
2221 0         0 my $value = shift;
2222              
2223 0         0 $o->{status} = 'revoked';
2224             }
2225              
2226             sub collectStore {
2227 0     0   0 my $o = shift;
2228 0         0 my $label = shift;
2229 0         0 my $value = shift;
2230              
2231 0         0 push @{$o->{accountTokens}}, CDS::AccountToken->new($value, $o->{actorHash});
  0         0  
2232 0         0 delete $o->{actorHash};
2233             }
2234              
2235             sub new {
2236 0     0   0 my $class = shift;
2237 0         0 my $actor = shift;
2238 0         0 bless {actor => $actor, ui => $actor->ui} }
2239              
2240             # END AUTOGENERATED
2241              
2242             # HTML FOLDER NAME actor-group
2243             # HTML TITLE Actor group
2244             sub help {
2245 0     0   0 my $o = shift;
2246 0         0 my $cmd = shift;
2247              
2248 0         0 my $ui = $o->{ui};
2249 0         0 $ui->space;
2250 0         0 $ui->command('cds show actor group');
2251 0         0 $ui->p('Shows all members of our actor group and the entrusted keys.');
2252 0         0 $ui->space;
2253 0         0 $ui->command('cds join ACCOUNT*');
2254 0         0 $ui->command('cds join ACTOR on STORE');
2255 0         0 $ui->p('Adds a member to our actor group. To complete the association, the new member must join us, too.');
2256 0         0 $ui->space;
2257 0         0 $ui->command('cds set member ACTOR* active');
2258 0         0 $ui->command('cds set member ACTOR* backup');
2259 0         0 $ui->command('cds set member ACTOR* idle');
2260 0         0 $ui->command('cds set member ACTOR* revoked');
2261 0         0 $ui->p('Changes the status of a member to one of the following:');
2262 0         0 $ui->p($ui->bold('Active members'), ' share the group data among themselves, and are advertised to receive messages.');
2263 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.');
2264 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.');
2265 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.');
2266 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.');
2267 0         0 $ui->space;
2268 0         0 $ui->p('After modifying the actor group members, you should "cds announce" yourself to publish the changes.');
2269 0         0 $ui->space;
2270             }
2271              
2272             sub show {
2273 0     0   0 my $o = shift;
2274 0         0 my $cmd = shift;
2275              
2276 0         0 my $hasMembers = 0;
2277 0         0 for my $actorSelector ($o->{actor}->actorGroupSelector->children) {
2278 0         0 my $record = $actorSelector->record;
2279 0   0     0 my $hash = $record->child('hash')->hashValue // next;
2280 0 0       0 next if substr($hash->bytes, 0, length $actorSelector->label) ne $actorSelector->label;
2281 0         0 my $storeUrl = $record->child('store')->textValue;
2282 0         0 my $revisionText = $o->{ui}->niceDateTimeLocal($actorSelector->revision);
2283 0         0 $o->{ui}->line($o->{ui}->gray($revisionText), ' ', $o->coloredType7($actorSelector), ' ', $hash->hex, ' on ', $storeUrl);
2284 0         0 $hasMembers = 1;
2285             }
2286              
2287 0 0       0 return if $hasMembers;
2288 0         0 $o->{ui}->line($o->{ui}->blue('(just you)'));
2289             }
2290              
2291             sub type {
2292 0     0   0 my $o = shift;
2293 0 0 0     0 my $actorSelector = shift; die 'wrong type '.ref($actorSelector).' for $actorSelector' if defined $actorSelector && ref $actorSelector ne 'CDS::Selector';
  0         0  
2294              
2295 0         0 my $groupData = $actorSelector->child('group data')->isSet;
2296 0         0 my $active = $actorSelector->child('active')->isSet;
2297 0         0 my $revoked = $actorSelector->child('revoked')->isSet;
2298             return
2299 0 0 0     0 $revoked ? 'revoked' :
    0          
    0          
    0          
2300             $active && $groupData ? 'active' :
2301             $groupData ? 'backup' :
2302             $active ? 'weird' :
2303             'idle';
2304             }
2305              
2306             sub coloredType7 {
2307 0     0   0 my $o = shift;
2308 0 0 0     0 my $actorSelector = shift; die 'wrong type '.ref($actorSelector).' for $actorSelector' if defined $actorSelector && ref $actorSelector ne 'CDS::Selector';
  0         0  
2309              
2310 0         0 my $groupData = $actorSelector->child('group data')->isSet;
2311 0         0 my $active = $actorSelector->child('active')->isSet;
2312 0         0 my $revoked = $actorSelector->child('revoked')->isSet;
2313             return
2314             $revoked ? $o->{ui}->red('revoked') :
2315             $active && $groupData ? $o->{ui}->green('active ') :
2316             $groupData ? $o->{ui}->blue('backup ') :
2317             $active ? $o->{ui}->orange('weird ') :
2318 0 0 0     0 $o->{ui}->gray('idle ');
    0          
    0          
    0          
2319             }
2320              
2321             sub joinMember {
2322 0     0   0 my $o = shift;
2323 0         0 my $cmd = shift;
2324              
2325 0         0 $o->{accountTokens} = [];
2326 0         0 $cmd->collect($o);
2327              
2328 0         0 my $selector = $o->{actor}->actorGroupSelector;
2329 0         0 for my $accountToken (@{$o->{accountTokens}}) {
  0         0  
2330 0         0 my $actorHash = $accountToken->actorHash;
2331              
2332             # Get the public key
2333 0         0 my ($publicKey, $invalidReason, $storeError) = $o->{actor}->keyPair->getPublicKey($actorHash, $accountToken->cliStore);
2334 0 0       0 if (defined $storeError) {
2335 0         0 $o->{ui}->pRed('Unable to get the public key of ', $actorHash->hex, ' from ', $accountToken->cliStore->url, ': ', $storeError);
2336 0         0 next;
2337             }
2338              
2339 0 0       0 if (defined $invalidReason) {
2340 0         0 $o->{ui}->pRed('Unable to get the public key of ', $actorHash->hex, ' from ', $accountToken->cliStore->url, ': ', $invalidReason);
2341 0         0 next;
2342             }
2343              
2344             # Add or update this member
2345 0         0 my $label = substr($actorHash->bytes, 0, 16);
2346 0         0 my $actorSelector = $selector->child($label);
2347 0         0 my $wasMember = $actorSelector->isSet;
2348              
2349 0         0 my $record = CDS::Record->new;
2350 0         0 $record->add('hash')->addHash($actorHash);
2351 0         0 $record->add('store')->addText($accountToken->cliStore->url);
2352 0         0 $actorSelector->set($record);
2353 0         0 $actorSelector->addObject($publicKey->hash, $publicKey->object);
2354              
2355 0 0       0 $o->{ui}->pGreen('Updated ', $o->type($actorSelector), ' member ', $actorHash->hex, '.') if $wasMember;
2356 0 0       0 $o->{ui}->pGreen('Added ', $actorHash->hex, ' as ', $o->type($actorSelector), ' member of the actor group.') if ! $wasMember;
2357             }
2358              
2359             # Save
2360 0         0 $o->{actor}->saveOrShowError;
2361             }
2362              
2363             sub setFlag {
2364 0     0   0 my $o = shift;
2365 0 0 0     0 my $actorSelector = shift; die 'wrong type '.ref($actorSelector).' for $actorSelector' if defined $actorSelector && ref $actorSelector ne 'CDS::Selector';
  0         0  
2366 0         0 my $label = shift;
2367 0         0 my $value = shift;
2368              
2369 0         0 my $child = $actorSelector->child($label);
2370 0 0       0 if ($value) {
2371 0         0 $child->setBoolean(1);
2372             } else {
2373 0         0 $child->clear;
2374             }
2375             }
2376              
2377             sub setMember {
2378 0     0   0 my $o = shift;
2379 0         0 my $cmd = shift;
2380              
2381 0         0 $o->{actorHashes} = [];
2382 0         0 $cmd->collect($o);
2383              
2384 0         0 my $selector = $o->{actor}->actorGroupSelector;
2385 0         0 for my $actorHash (@{$o->{actorHashes}}) {
  0         0  
2386 0         0 my $label = substr($actorHash->bytes, 0, 16);
2387 0         0 my $actorSelector = $selector->child($label);
2388              
2389 0         0 my $record = $actorSelector->record;
2390 0         0 my $hash = $record->child('hash')->hashValue;
2391 0 0       0 if (! $hash) {
2392 0         0 $o->{ui}->pRed($actorHash->hex, ' is not a member of our actor group.');
2393 0         0 next;
2394             }
2395              
2396 0   0     0 $o->setFlag($actorSelector, 'group data', $o->{status} eq 'active' || $o->{status} eq 'backup');
2397 0         0 $o->setFlag($actorSelector, 'active', $o->{status} eq 'active');
2398 0         0 $o->setFlag($actorSelector, 'revoked', $o->{status} eq 'revoked');
2399 0         0 $o->{ui}->pGreen($actorHash->hex, ' is now ', $o->type($actorSelector), '.');
2400             }
2401              
2402             # Save
2403 0         0 $o->{actor}->saveOrShowError;
2404             }
2405              
2406             # BEGIN AUTOGENERATED
2407             package CDS::Commands::Announce;
2408              
2409             sub register {
2410 0     0   0 my $class = shift;
2411 0         0 my $cds = shift;
2412 0         0 my $help = shift;
2413              
2414 0         0 my $node000 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
2415 0         0 my $node001 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&announceMe});
2416 0         0 my $node002 = CDS::Parser::Node->new(1);
2417 0         0 my $node003 = CDS::Parser::Node->new(0);
2418 0         0 my $node004 = CDS::Parser::Node->new(0);
2419 0         0 my $node005 = CDS::Parser::Node->new(0);
2420 0         0 my $node006 = CDS::Parser::Node->new(0);
2421 0         0 my $node007 = CDS::Parser::Node->new(0);
2422 0         0 my $node008 = CDS::Parser::Node->new(0);
2423 0         0 my $node009 = CDS::Parser::Node->new(0);
2424 0         0 my $node010 = CDS::Parser::Node->new(0);
2425 0         0 my $node011 = CDS::Parser::Node->new(0);
2426 0         0 my $node012 = CDS::Parser::Node->new(0);
2427 0         0 my $node013 = CDS::Parser::Node->new(1);
2428 0         0 my $node014 = CDS::Parser::Node->new(0);
2429 0         0 my $node015 = CDS::Parser::Node->new(0);
2430 0         0 my $node016 = CDS::Parser::Node->new(0);
2431 0         0 my $node017 = CDS::Parser::Node->new(0, {constructor => \&new, function => \&announceKeyPair});
2432 0         0 $cds->addArrow($node001, 1, 0, 'announce');
2433 0         0 $cds->addArrow($node002, 1, 0, 'announce');
2434 0         0 $help->addArrow($node000, 1, 0, 'announce');
2435 0         0 $node002->addArrow($node003, 1, 0, 'KEYPAIR', \&collectKeypair);
2436 0         0 $node003->addArrow($node004, 1, 0, 'on');
2437 0         0 $node004->addArrow($node005, 1, 0, 'STORE', \&collectStore);
2438 0         0 $node005->addArrow($node006, 1, 0, 'without');
2439 0         0 $node005->addArrow($node007, 1, 0, 'with');
2440 0         0 $node005->addDefault($node017);
2441 0         0 $node006->addArrow($node006, 1, 0, 'ACTOR', \&collectActor);
2442 0         0 $node006->addArrow($node017, 1, 0, 'ACTOR', \&collectActor);
2443 0         0 $node007->addArrow($node008, 1, 0, 'active', \&collectActive);
2444 0         0 $node007->addArrow($node008, 1, 0, 'entrusted', \&collectEntrusted);
2445 0         0 $node007->addArrow($node008, 1, 0, 'idle', \&collectIdle);
2446 0         0 $node007->addArrow($node008, 1, 0, 'revoked', \&collectRevoked);
2447 0         0 $node008->addDefault($node009);
2448 0         0 $node008->addDefault($node010);
2449 0         0 $node009->addArrow($node009, 1, 0, 'ACCOUNT', \&collectAccount);
2450 0         0 $node009->addArrow($node013, 1, 1, 'ACCOUNT', \&collectAccount);
2451 0         0 $node010->addArrow($node010, 1, 0, 'ACTOR', \&collectActor1);
2452 0         0 $node010->addArrow($node011, 1, 0, 'ACTOR', \&collectActor1);
2453 0         0 $node011->addArrow($node012, 1, 0, 'on');
2454 0         0 $node012->addArrow($node013, 1, 0, 'STORE', \&collectStore1);
2455 0         0 $node013->addArrow($node014, 1, 0, 'but');
2456 0         0 $node013->addArrow($node016, 1, 0, 'and');
2457 0         0 $node013->addDefault($node017);
2458 0         0 $node014->addArrow($node015, 1, 0, 'without');
2459 0         0 $node015->addArrow($node015, 1, 0, 'ACTOR', \&collectActor);
2460 0         0 $node015->addArrow($node017, 1, 0, 'ACTOR', \&collectActor);
2461 0         0 $node016->addDefault($node007);
2462             }
2463              
2464             sub collectAccount {
2465 0     0   0 my $o = shift;
2466 0         0 my $label = shift;
2467 0         0 my $value = shift;
2468              
2469 0         0 push @{$o->{with}}, {status => $o->{status}, accountToken => $value};
  0         0  
2470             }
2471              
2472             sub collectActive {
2473 0     0   0 my $o = shift;
2474 0         0 my $label = shift;
2475 0         0 my $value = shift;
2476              
2477 0         0 $o->{status} = 'active';
2478             }
2479              
2480             sub collectActor {
2481 0     0   0 my $o = shift;
2482 0         0 my $label = shift;
2483 0         0 my $value = shift;
2484              
2485 0         0 $o->{without}->{$value->bytes} = $value;
2486             }
2487              
2488             sub collectActor1 {
2489 0     0   0 my $o = shift;
2490 0         0 my $label = shift;
2491 0         0 my $value = shift;
2492              
2493 0         0 push @{$o->{actorHashes}}, $value;
  0         0  
2494             }
2495              
2496             sub collectEntrusted {
2497 0     0   0 my $o = shift;
2498 0         0 my $label = shift;
2499 0         0 my $value = shift;
2500              
2501 0         0 $o->{status} = 'entrusted';
2502             }
2503              
2504             sub collectIdle {
2505 0     0   0 my $o = shift;
2506 0         0 my $label = shift;
2507 0         0 my $value = shift;
2508              
2509 0         0 $o->{status} = 'idle';
2510             }
2511              
2512             sub collectKeypair {
2513 0     0   0 my $o = shift;
2514 0         0 my $label = shift;
2515 0         0 my $value = shift;
2516              
2517 0         0 $o->{keyPairToken} = $value;
2518             }
2519              
2520             sub collectRevoked {
2521 0     0   0 my $o = shift;
2522 0         0 my $label = shift;
2523 0         0 my $value = shift;
2524              
2525 0         0 $o->{status} = 'revoked';
2526             }
2527              
2528             sub collectStore {
2529 0     0   0 my $o = shift;
2530 0         0 my $label = shift;
2531 0         0 my $value = shift;
2532              
2533 0         0 $o->{store} = $value;
2534             }
2535              
2536             sub collectStore1 {
2537 0     0   0 my $o = shift;
2538 0         0 my $label = shift;
2539 0         0 my $value = shift;
2540              
2541 0         0 for my $actorHash (@{$o->{actorHashes}}) {
  0         0  
2542 0         0 my $accountToken = CDS::AccountToken->new($value, $actorHash);
2543 0         0 push @{$o->{with}}, {status => $o->{status}, accountToken => $accountToken};
  0         0  
2544             }
2545              
2546 0         0 $o->{actorHashes} = [];
2547             }
2548              
2549             sub new {
2550 0     0   0 my $class = shift;
2551 0         0 my $actor = shift;
2552 0         0 bless {actor => $actor, ui => $actor->ui} }
2553              
2554             # END AUTOGENERATED
2555              
2556             # HTML FOLDER NAME announce
2557             # HTML TITLE Announce
2558             sub help {
2559 0     0   0 my $o = shift;
2560 0         0 my $cmd = shift;
2561              
2562 0         0 my $ui = $o->{ui};
2563 0         0 $ui->space;
2564 0         0 $ui->command('cds announce');
2565 0         0 $ui->p('Announces yourself on your accounts.');
2566 0         0 $ui->space;
2567 0         0 $ui->command('cds announce KEYPAIR on STORE');
2568 0         0 $ui->command('… with (active|idle|revoked|entrusted) ACCOUNT*');
2569 0         0 $ui->command('… with (active|idle|revoked|entrusted) ACTOR* on STORE');
2570 0         0 $ui->command('… without ACTOR*');
2571 0         0 $ui->command('… with … and … and … but without …');
2572 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.');
2573 0         0 $ui->p('If no card exists, a minimalistic card is created.');
2574 0         0 $ui->p('Use this with care, as the generated card may not be compliant with the card produced by the actor.');
2575 0         0 $ui->space;
2576             }
2577              
2578             sub announceMe {
2579 0     0   0 my $o = shift;
2580 0         0 my $cmd = shift;
2581              
2582 0         0 $o->announceOnStore($o->{actor}->storageStore);
2583 0 0       0 $o->announceOnStore($o->{actor}->messagingStore) if $o->{actor}->messagingStore->id ne $o->{actor}->storageStore->id;
2584 0         0 $o->{ui}->space;
2585             }
2586              
2587             sub announceOnStore {
2588 0     0   0 my $o = shift;
2589 0         0 my $store = shift;
2590              
2591 0         0 $o->{ui}->space;
2592 0         0 $o->{ui}->title($store->url);
2593 0         0 my ($envelopeHash, $cardHash, $invalidReason, $storeError) = $o->{actor}->announce($store);
2594 0 0       0 return if defined $storeError;
2595 0 0       0 return $o->{ui}->pRed($invalidReason) if defined $invalidReason;
2596 0         0 $o->{ui}->pGreen('Announced');
2597             }
2598              
2599             sub announceKeyPair {
2600 0     0   0 my $o = shift;
2601 0         0 my $cmd = shift;
2602              
2603 0         0 $o->{actors} = [];
2604 0         0 $o->{with} = [];
2605 0         0 $o->{without} = {};
2606 0         0 $o->{now} = CDS->now;
2607 0         0 $cmd->collect($o);
2608              
2609             # List
2610 0         0 $o->{keyPair} = $o->{keyPairToken}->keyPair;
2611 0         0 my ($hashes, $listError) = $o->{store}->list($o->{keyPair}->publicKey->hash, 'public', 0, $o->{keyPair});
2612 0 0       0 return if defined $listError;
2613              
2614             # Check if there are more than one cards
2615 0 0       0 if (scalar @$hashes > 1) {
2616 0         0 $o->{ui}->space;
2617 0         0 $o->{ui}->p('This account contains more than one public card:');
2618 0         0 $o->{ui}->pushIndent;
2619 0         0 for my $hash (@$hashes) {
2620 0         0 $o->{ui}->line($o->{ui}->gold('cds show card ', $hash->hex, ' on ', $o->{storeUrl}));
2621             }
2622 0         0 $o->{ui}->popIndent;
2623 0         0 $o->{ui}->p('Remove all but the most recent card. Cards can be removed as follows:');
2624 0         0 my $keyPairReference = $o->{actor}->blueKeyPairReference($o->{keyPairToken});
2625 0         0 $o->{ui}->line($o->{ui}->gold('cds remove ', 'HASH', ' on ', $o->{storeUrl}, ' using ', $keyPairReference));
2626 0         0 $o->{ui}->space;
2627 0         0 return;
2628             }
2629              
2630             # Read the card
2631 0 0       0 my $cardRecord = scalar @$hashes ? $o->readCard($hashes->[0]) : CDS::Record->new;
2632 0 0       0 return if ! $cardRecord;
2633              
2634             # Parse
2635 0         0 my $builder = CDS::ActorGroupBuilder->new;
2636 0         0 $builder->parse($cardRecord, 0);
2637              
2638             # Apply the changes
2639 0         0 for my $change (@{$o->{with}}) {
  0         0  
2640 0 0       0 if ($change->{status} eq 'entrusted') {
2641 0         0 $builder->addEntrustedActor($change->{accountToken}->cliStore->url, $change->{accountToken}->actorHash);
2642 0         0 $builder->{entrustedActorsRevision} = $o->{now};
2643             } else {
2644 0         0 $builder->addMember($change->{accountToken}->cliStore->url, $change->{accountToken}->actorHash, $o->{now}, $change->{status});
2645             }
2646             }
2647              
2648 0         0 for my $hash (values %{$o->{without}}) {
  0         0  
2649 0         0 $builder->removeEntrustedActor($hash)
2650             }
2651              
2652 0         0 for my $member ($builder->members) {
2653 0 0       0 next if ! $o->{without}->{$member->hash->bytes};
2654 0         0 $builder->removeMember($member->storeUrl, $member->hash);
2655             }
2656              
2657             # Write the new card
2658 0         0 my $newCard = $builder->toRecord(0);
2659 0         0 $newCard->add('public key')->addHash($o->{keyPair}->publicKey->hash);
2660              
2661 0         0 for my $child ($cardRecord->children) {
2662 0 0       0 if ($child->bytes eq 'actor group') {
    0          
    0          
2663             } elsif ($child->bytes eq 'entrusted actors') {
2664             } elsif ($child->bytes eq 'public key') {
2665             } else {
2666 0         0 $newCard->addRecord($child);
2667             }
2668             }
2669              
2670 0         0 $o->announce($newCard, $hashes);
2671             }
2672              
2673             sub readCard {
2674 0     0   0 my $o = shift;
2675 0 0 0     0 my $envelopeHash = shift; die 'wrong type '.ref($envelopeHash).' for $envelopeHash' if defined $envelopeHash && ref $envelopeHash ne 'CDS::Hash';
  0         0  
2676              
2677             # Open the envelope
2678 0         0 my ($object, $storeError) = $o->{store}->get($envelopeHash, $o->{keyPair});
2679 0 0       0 return if defined $storeError;
2680 0 0       0 return $o->{ui}->error('Envelope object ', $envelopeHash->hex, ' not found.') if ! $object;
2681              
2682 0   0     0 my $envelope = CDS::Record->fromObject($object) // return $o->{ui}->error($envelopeHash->hex, ' is not a record.');
2683 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.');
2684 0 0       0 return $o->{ui}->error($envelopeHash->hex, ' has an invalid signature.') if ! CDS->verifyEnvelopeSignature($envelope, $o->{keyPair}->publicKey, $cardHash);
2685              
2686             # Read the card
2687 0         0 my ($cardObject, $storeError1) = $o->{store}->get($cardHash, $o->{keyPair});
2688 0 0       0 return if defined $storeError1;
2689 0 0       0 return $o->{ui}->error('Card object ', $cardHash->hex, ' not found.') if ! $cardObject;
2690              
2691 0   0     0 return CDS::Record->fromObject($cardObject) // return $o->{ui}->error($cardHash->hex, ' is not a record.');
2692             }
2693              
2694             sub applyChanges {
2695 0     0   0 my $o = shift;
2696 0 0 0     0 my $actorGroup = shift; die 'wrong type '.ref($actorGroup).' for $actorGroup' if defined $actorGroup && ref $actorGroup ne 'CDS::ActorGroup';
  0         0  
2697 0         0 my $status = shift;
2698 0         0 my $accounts = shift;
2699              
2700 0         0 for my $account (@$accounts) {
2701 0         0 $actorGroup->{$account->url} = {storeUrl => $account->cliStore->url, actorHash => $account->actorHash, revision => $o->{now}, status => $status};
2702             }
2703             }
2704              
2705             sub announce {
2706 0     0   0 my $o = shift;
2707 0         0 my $card = shift;
2708 0         0 my $sourceHashes = shift;
2709              
2710 0         0 my $inMemoryStore = CDS::InMemoryStore->create;
2711              
2712             # Serialize the card
2713 0         0 my $cardObject = $card->toObject;
2714 0         0 my $cardHash = $cardObject->calculateHash;
2715 0         0 $inMemoryStore->put($cardHash, $cardObject);
2716 0         0 $inMemoryStore->put($o->{keyPair}->publicKey->hash, $o->{keyPair}->publicKey->object);
2717              
2718             # Prepare the public envelope
2719 0         0 my $envelopeObject = $o->{keyPair}->createPublicEnvelope($cardHash)->toObject;
2720 0         0 my $envelopeHash = $envelopeObject->calculateHash;
2721 0         0 $inMemoryStore->put($envelopeHash, $envelopeObject);
2722              
2723             # Transfer
2724 0         0 my ($missingHash, $failedStore, $storeError) = $o->{keyPair}->transfer([$envelopeHash], $inMemoryStore, $o->{store});
2725 0 0       0 return if $storeError;
2726 0 0       0 return $o->{ui}->pRed('Object ', $missingHash, ' is missing.') if $missingHash;
2727              
2728             # Modify
2729 0         0 my $modifications = CDS::StoreModifications->new;
2730 0         0 $modifications->add($o->{keyPair}->publicKey->hash, 'public', $envelopeHash);
2731 0         0 for my $hash (@$sourceHashes) {
2732 0         0 $modifications->remove($o->{keyPair}->publicKey->hash, 'public', $hash);
2733             }
2734              
2735 0         0 my $modifyError = $o->{store}->modify($modifications, $o->{keyPair});
2736 0 0       0 return if $modifyError;
2737              
2738 0         0 $o->{ui}->pGreen('Announced on ', $o->{store}->url, '.');
2739             }
2740              
2741             # BEGIN AUTOGENERATED
2742             package CDS::Commands::Book;
2743              
2744             sub register {
2745 0     0   0 my $class = shift;
2746 0         0 my $cds = shift;
2747 0         0 my $help = shift;
2748              
2749 0         0 my $node000 = CDS::Parser::Node->new(0);
2750 0         0 my $node001 = CDS::Parser::Node->new(0);
2751 0         0 my $node002 = CDS::Parser::Node->new(0);
2752 0         0 my $node003 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
2753 0         0 my $node004 = CDS::Parser::Node->new(0);
2754 0         0 my $node005 = CDS::Parser::Node->new(0);
2755 0         0 my $node006 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&book});
2756 0         0 $cds->addArrow($node000, 1, 0, 'book');
2757 0         0 $cds->addArrow($node001, 1, 0, 'book');
2758 0         0 $cds->addArrow($node002, 1, 0, 'book');
2759 0         0 $help->addArrow($node003, 1, 0, 'book');
2760 0         0 $node000->addArrow($node000, 1, 0, 'HASH', \&collectHash);
2761 0         0 $node000->addArrow($node004, 1, 0, 'HASH', \&collectHash);
2762 0         0 $node001->addArrow($node001, 1, 0, 'OBJECT', \&collectObject);
2763 0         0 $node001->addArrow($node006, 1, 0, 'OBJECT', \&collectObject);
2764 0         0 $node002->addArrow($node002, 1, 0, 'HASH', \&collectHash);
2765 0         0 $node002->addArrow($node006, 1, 0, 'HASH', \&collectHash);
2766 0         0 $node004->addArrow($node005, 1, 0, 'on');
2767 0         0 $node005->addArrow($node005, 1, 0, 'STORE', \&collectStore);
2768 0         0 $node005->addArrow($node006, 1, 0, 'STORE', \&collectStore);
2769             }
2770              
2771             sub collectHash {
2772 0     0   0 my $o = shift;
2773 0         0 my $label = shift;
2774 0         0 my $value = shift;
2775              
2776 0         0 push @{$o->{hashes}}, $value;
  0         0  
2777             }
2778              
2779             sub collectObject {
2780 0     0   0 my $o = shift;
2781 0         0 my $label = shift;
2782 0         0 my $value = shift;
2783              
2784 0         0 push @{$o->{objectTokens}}, $value;
  0         0  
2785             }
2786              
2787             sub collectStore {
2788 0     0   0 my $o = shift;
2789 0         0 my $label = shift;
2790 0         0 my $value = shift;
2791              
2792 0         0 push @{$o->{stores}}, $value;
  0         0  
2793             }
2794              
2795             sub new {
2796 0     0   0 my $class = shift;
2797 0         0 my $actor = shift;
2798 0         0 bless {actor => $actor, ui => $actor->ui} }
2799              
2800             # END AUTOGENERATED
2801              
2802             # HTML FOLDER NAME store-book
2803             # HTML TITLE Book
2804             sub help {
2805 0     0   0 my $o = shift;
2806 0         0 my $cmd = shift;
2807              
2808 0         0 my $ui = $o->{ui};
2809 0         0 $ui->space;
2810 0         0 $ui->command('cds book OBJECT*');
2811 0         0 $ui->command('cds book HASH* on STORE*');
2812 0         0 $ui->p('Books all indicated objects and reports whether booking as successful.');
2813 0         0 $ui->space;
2814 0         0 $ui->command('cds book HASH*');
2815 0         0 $ui->p('As above, but uses the selected store.');
2816 0         0 $ui->space;
2817             }
2818              
2819             sub book {
2820 0     0   0 my $o = shift;
2821 0         0 my $cmd = shift;
2822              
2823 0         0 $o->{keyPair} = $o->{actor}->preferredKeyPairToken->keyPair;
2824 0         0 $o->{hashes} = [];
2825 0         0 $o->{stores} = [];
2826 0         0 $o->{objectTokens} = [];
2827 0         0 $cmd->collect($o);
2828              
2829             # Use the selected store
2830 0 0       0 push @{$o->{stores}}, $o->{actor}->preferredStore if ! scalar @{$o->{stores}};
  0         0  
  0         0  
2831              
2832             # Book all hashes on all stores
2833 0         0 my %triedStores;
2834 0         0 for my $store (@{$o->{stores}}) {
  0         0  
2835 0 0       0 next if $triedStores{$store->url};
2836 0         0 $triedStores{$store->url} = 1;
2837 0         0 for my $hash (@{$o->{hashes}}) {
  0         0  
2838 0         0 $o->process($store, $hash);
2839             }
2840             }
2841              
2842             # Book the direct object references
2843 0         0 for my $objectToken (@{$o->{objectTokens}}) {
  0         0  
2844 0         0 $o->process($objectToken->cliStore, $objectToken->hash);
2845             }
2846              
2847             # Warn the user if no key pair is selected
2848 0 0       0 return if ! $o->{hasErrors};
2849 0 0       0 return if $o->{keyPair};
2850 0         0 $o->{ui}->space;
2851 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".');
2852             }
2853              
2854             sub process {
2855 0     0   0 my $o = shift;
2856 0         0 my $store = shift;
2857 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
2858              
2859             # Upload the object
2860 0         0 my $success = $store->book($hash, $o->{keyPair});
2861 0 0       0 if ($success) {
2862 0         0 $o->{ui}->line($o->{ui}->green('OK '), $hash->hex, ' on ', $store->url);
2863             } else {
2864 0         0 $o->{ui}->line($o->{ui}->red('not found '), $hash->hex, ' on ', $store->url);
2865 0         0 $o->{hasErrors} = 1;
2866             }
2867             }
2868              
2869             # BEGIN AUTOGENERATED
2870             package CDS::Commands::CheckKeyPair;
2871              
2872             sub register {
2873 0     0   0 my $class = shift;
2874 0         0 my $cds = shift;
2875 0         0 my $help = shift;
2876              
2877 0         0 my $node000 = CDS::Parser::Node->new(0);
2878 0         0 my $node001 = CDS::Parser::Node->new(0);
2879 0         0 my $node002 = CDS::Parser::Node->new(0);
2880 0         0 my $node003 = CDS::Parser::Node->new(0);
2881 0         0 my $node004 = CDS::Parser::Node->new(0);
2882 0         0 my $node005 = CDS::Parser::Node->new(0);
2883 0         0 my $node006 = CDS::Parser::Node->new(0);
2884 0         0 my $node007 = CDS::Parser::Node->new(0);
2885 0         0 my $node008 = CDS::Parser::Node->new(0);
2886 0         0 my $node009 = CDS::Parser::Node->new(0);
2887 0         0 my $node010 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
2888 0         0 my $node011 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&checkKeyPair});
2889 0         0 $cds->addArrow($node004, 1, 0, 'check');
2890 0         0 $cds->addArrow($node005, 1, 0, 'fix');
2891 0         0 $help->addArrow($node000, 1, 0, 'check');
2892 0         0 $help->addArrow($node001, 1, 0, 'fix');
2893 0         0 $node000->addArrow($node002, 1, 0, 'key');
2894 0         0 $node001->addArrow($node003, 1, 0, 'key');
2895 0         0 $node002->addArrow($node010, 1, 0, 'pair');
2896 0         0 $node003->addArrow($node010, 1, 0, 'pair');
2897 0         0 $node004->addArrow($node006, 1, 0, 'key');
2898 0         0 $node005->addArrow($node007, 1, 0, 'key');
2899 0         0 $node006->addArrow($node008, 1, 0, 'pair');
2900 0         0 $node007->addArrow($node009, 1, 0, 'pair');
2901 0         0 $node008->addArrow($node011, 1, 0, 'FILE', \&collectFile);
2902 0         0 $node009->addArrow($node011, 1, 0, 'FILE', \&collectFile1);
2903             }
2904              
2905             sub collectFile {
2906 0     0   0 my $o = shift;
2907 0         0 my $label = shift;
2908 0         0 my $value = shift;
2909              
2910 0         0 $o->{file} = $value;
2911             }
2912              
2913             sub collectFile1 {
2914 0     0   0 my $o = shift;
2915 0         0 my $label = shift;
2916 0         0 my $value = shift;
2917              
2918 0         0 $o->{file} = $value;
2919 0         0 $o->{fix} = 1;
2920             }
2921              
2922             sub new {
2923 0     0   0 my $class = shift;
2924 0         0 my $actor = shift;
2925 0         0 bless {actor => $actor, ui => $actor->ui} }
2926              
2927             # END AUTOGENERATED
2928              
2929             # HTML FOLDER NAME check-key-pair
2930             # HTML TITLE Check key pair
2931             sub help {
2932 0     0   0 my $o = shift;
2933 0         0 my $cmd = shift;
2934              
2935 0         0 my $ui = $o->{ui};
2936 0         0 $ui->space;
2937 0         0 $ui->command('cds check key pair FILE');
2938 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.');
2939 0         0 $ui->space;
2940             }
2941              
2942             sub checkKeyPair {
2943 0     0   0 my $o = shift;
2944 0         0 my $cmd = shift;
2945              
2946 0         0 $cmd->collect($o);
2947              
2948             # Check if we have a complete private key
2949 0   0     0 my $bytes = CDS->readBytesFromFile($o->{file}) // return $o->{ui}->error('The file "', $o->{file}, '" cannot be read.');
2950 0         0 my $record = CDS::Record->fromObject(CDS::Object->fromBytes($bytes));
2951              
2952 0         0 my $rsaKey = $record->child('rsa key');
2953 0         0 my $e = $rsaKey->child('e')->bytesValue;
2954 0 0       0 return $o->{ui}->error('The exponent "e" of the private key is missing.') if ! length $e;
2955 0         0 my $p = $rsaKey->child('p')->bytesValue;
2956 0 0       0 return $o->{ui}->error('The prime "p" of the private key is missing.') if ! length $p;
2957 0         0 my $q = $rsaKey->child('q')->bytesValue;
2958 0 0       0 return $o->{ui}->error('The prime "q" of the private key is missing.') if ! length $q;
2959 0         0 $o->{ui}->pGreen('The private key is complete.');
2960              
2961             # Derive the public key
2962 0         0 my $privateKey = CDS::C::privateKeyNew($e, $p, $q);
2963 0         0 my $publicKey = CDS::C::publicKeyFromPrivateKey($privateKey);
2964 0         0 my $n = CDS::C::publicKeyN($publicKey);
2965              
2966             # Check if we have a matching public key
2967 0         0 my $publicKeyObjectBytes = $record->child('public key object')->bytesValue;
2968 0 0       0 return $o->{ui}->error('The public key is missing.') if ! length $publicKeyObjectBytes;
2969 0   0     0 $o->{publicKeyObject} = CDS::Object->fromBytes($publicKeyObjectBytes) // return $o->{ui}->error('The public key is is not a valid Condensation object.');
2970 0         0 $o->{publicKeyHash} = $o->{publicKeyObject}->calculateHash;
2971 0         0 my $publicKeyRecord = CDS::Record->fromObject($o->{publicKeyObject});
2972 0 0       0 return $o->{ui}->error('The public key is not a valid record.') if ! $publicKeyRecord;
2973 0         0 my $publicN = $publicKeyRecord->child('n')->bytesValue;
2974 0 0       0 return $o->{ui}->error('The modulus "n" of the public key is missing.') if ! length $publicN;
2975 0   0     0 my $publicE = $publicKeyRecord->child('e')->bytesValue // $o->{ui}->error('The public key is incomplete.');
2976 0 0       0 return $o->{ui}->error('The exponent "e" of the public key is missing.') if ! length $publicE;
2977 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;
2978 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;
2979 0         0 $o->{ui}->pGreen('The public key ', $o->{publicKeyHash}->hex, ' is complete.');
2980              
2981             # At this point, the configuration looks good, and we can load the key pair
2982 0   0     0 CDS::KeyPair->fromRecord($record) // $o->{ui}->error('Your key pair looks complete, but could not be loaded.');
2983             }
2984              
2985             # BEGIN AUTOGENERATED
2986             package CDS::Commands::CollectGarbage;
2987              
2988             sub register {
2989 0     0   0 my $class = shift;
2990 0         0 my $cds = shift;
2991 0         0 my $help = shift;
2992              
2993 0         0 my $node000 = CDS::Parser::Node->new(0);
2994 0         0 my $node001 = CDS::Parser::Node->new(0);
2995 0         0 my $node002 = CDS::Parser::Node->new(0);
2996 0         0 my $node003 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
2997 0         0 my $node004 = CDS::Parser::Node->new(0, {constructor => \&new, function => \&collectGarbage});
2998 0         0 my $node005 = CDS::Parser::Node->new(0);
2999 0         0 my $node006 = CDS::Parser::Node->new(0, {constructor => \&new, function => \&reportGarbage});
3000 0         0 my $node007 = CDS::Parser::Node->new(0);
3001 0         0 my $node008 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&collectGarbage});
3002 0         0 my $node009 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&reportGarbage});
3003 0         0 $cds->addArrow($node001, 1, 0, 'report');
3004 0         0 $cds->addArrow($node002, 1, 0, 'collect');
3005 0         0 $help->addArrow($node000, 1, 0, 'collect');
3006 0         0 $node000->addArrow($node003, 1, 0, 'garbage');
3007 0         0 $node001->addArrow($node006, 1, 0, 'garbage');
3008 0         0 $node002->addArrow($node004, 1, 0, 'garbage');
3009 0         0 $node004->addArrow($node005, 1, 0, 'of');
3010 0         0 $node004->addDefault($node008);
3011 0         0 $node005->addArrow($node008, 1, 0, 'STORE', \&collectStore);
3012 0         0 $node006->addArrow($node007, 1, 0, 'of');
3013 0         0 $node006->addDefault($node009);
3014 0         0 $node007->addArrow($node009, 1, 0, 'STORE', \&collectStore);
3015             }
3016              
3017             sub collectStore {
3018 0     0   0 my $o = shift;
3019 0         0 my $label = shift;
3020 0         0 my $value = shift;
3021              
3022 0         0 $o->{store} = $value;
3023             }
3024              
3025             sub new {
3026 0     0   0 my $class = shift;
3027 0         0 my $actor = shift;
3028 0         0 bless {actor => $actor, ui => $actor->ui} }
3029              
3030             # END AUTOGENERATED
3031              
3032             # HTML FOLDER NAME collect-garbage
3033             # HTML TITLE Garbage collection
3034             sub help {
3035 0     0   0 my $o = shift;
3036 0         0 my $cmd = shift;
3037              
3038 0         0 my $ui = $o->{ui};
3039 0         0 $ui->space;
3040 0         0 $ui->command('cds collect garbage [of STORE]');
3041 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.');
3042 0         0 $ui->p('If no store is provided, garbage collection is run on the selected store, or the actor\'s storage store.');
3043 0         0 $ui->space;
3044 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.');
3045 0         0 $ui->space;
3046 0         0 $ui->command('cds report garbage [of STORE]');
3047 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.');
3048 0         0 $ui->space;
3049             }
3050              
3051             sub collectGarbage {
3052 0     0   0 my $o = shift;
3053 0         0 my $cmd = shift;
3054              
3055 0         0 $cmd->collect($o);
3056 0         0 $o->run(CDS::Commands::CollectGarbage::Delete->new($o->{ui}));
3057             }
3058              
3059             sub wrapUpDeletion {
3060 0     0   0 my $o = shift;
3061             }
3062              
3063             sub reportGarbage {
3064 0     0   0 my $o = shift;
3065 0         0 my $cmd = shift;
3066              
3067 0         0 $cmd->collect($o);
3068 0         0 $o->run(CDS::Commands::CollectGarbage::Report->new($o->{ui}));
3069 0         0 $o->{ui}->space;
3070             }
3071              
3072             # Creates a folder with the selected permissions.
3073             sub run {
3074 0     0   0 my $o = shift;
3075 0         0 my $handler = shift;
3076              
3077             # Prepare
3078 0   0     0 my $store = $o->{store} // $o->{actor}->selectedStore // $o->{actor}->storageStore;
      0        
3079 0   0     0 my $folderStore = CDS::FolderStore->forUrl($store->url) // return $o->{ui}->error('"', $store->url, '" is not a folder store.');
3080 0   0     0 $handler->initialize($folderStore) // return;
3081              
3082 0         0 $o->{storeFolder} = $folderStore->folder;
3083 0         0 $o->{accountsFolder} = $folderStore->folder.'/accounts';
3084 0         0 $o->{objectsFolder} = $folderStore->folder.'/objects';
3085 0         0 my $dateLimit = time - 86400;
3086 0         0 my $envelopeExpirationLimit = time * 1000;
3087              
3088             # Read the tree index
3089 0         0 $o->readIndex;
3090              
3091             # Process all accounts
3092 0         0 $o->{ui}->space;
3093 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');
3094 0         0 $o->startProgress('linked objects');
3095 0         0 $o->{usedHashes} = {};
3096 0         0 $o->{missingObjects} = {};
3097 0         0 $o->{brokenOrigins} = {};
3098 0         0 my $countAccounts = 0;
3099 0         0 my $countKeptEnvelopes = 0;
3100 0         0 my $countDeletedEnvelopes = 0;
3101 0         0 for my $accountHash (sort { $$a cmp $$b } $folderStore->accounts) {
  0         0  
3102             # This would be the private key, but we don't use it right now
3103 0         0 $o->{usedHashes}->{$accountHash->hex} = 1;
3104              
3105 0         0 my $newestDate = 0;
3106 0         0 my %sizeByBox;
3107 0         0 my $accountFolder = $o->{accountsFolder}.'/'.$accountHash->hex;
3108 0         0 foreach my $boxLabel (CDS->listFolder($accountFolder)) {
3109 0 0       0 next if $boxLabel =~ /^\./;
3110 0         0 my $boxFolder = $accountFolder.'/'.$boxLabel;
3111 0         0 my $date = &lastModified($boxFolder);
3112 0 0       0 $newestDate = $date if $newestDate < $date;
3113 0         0 my $size = 0;
3114 0         0 foreach my $filename (CDS->listFolder($boxFolder)) {
3115 0 0       0 next if $filename =~ /^\./;
3116 0         0 my $hash = pack('H*', $filename);
3117 0         0 my $file = $boxFolder.'/'.$filename;
3118              
3119 0         0 my $timestamp = $o->envelopeExpiration($hash, $boxFolder);
3120 0 0 0     0 if ($timestamp > 0 && $timestamp < $envelopeExpirationLimit) {
3121 0         0 $countDeletedEnvelopes += 1;
3122 0   0     0 $handler->deleteEnvelope($file) // return;
3123 0         0 next;
3124             }
3125              
3126 0         0 $countKeptEnvelopes += 1;
3127 0         0 my $date = &lastModified($file);
3128 0 0       0 $newestDate = $date if $newestDate < $date;
3129 0         0 $size += $o->traverse($hash, $boxFolder);
3130             }
3131 0         0 $sizeByBox{$boxLabel} = $size;
3132             }
3133              
3134             $o->{ui}->line($accountHash->hex, ' ',
3135             $o->{ui}->right(10, $o->{ui}->niceFileSize($sizeByBox{'messages'} || 0)), ' ',
3136             $o->{ui}->right(10, $o->{ui}->niceFileSize($sizeByBox{'private'} || 0)), ' ',
3137             $o->{ui}->right(10, $o->{ui}->niceFileSize($sizeByBox{'public'} || 0)), ' ',
3138 0 0 0     0 $newestDate == 0 ? 'never' : $o->{ui}->niceDateTime($newestDate * 1000));
      0        
      0        
3139              
3140 0         0 $countAccounts += 1;
3141             }
3142              
3143 0         0 $o->{ui}->line($countAccounts, ' accounts traversed');
3144 0         0 $o->{ui}->space;
3145              
3146             # Mark all objects that are younger than 1 day (so that objects being uploaded right now but not linked yet remain)
3147 0         0 $o->{ui}->title('Objects');
3148 0         0 $o->startProgress('objects');
3149              
3150 0         0 my %objects;
3151 0         0 my @topFolders = sort grep {$_ !~ /^\./} CDS->listFolder($o->{objectsFolder});
  0         0  
3152 0         0 foreach my $topFolder (@topFolders) {
3153 0         0 my @files = sort grep {$_ !~ /^\./} CDS->listFolder($o->{objectsFolder}.'/'.$topFolder);
  0         0  
3154 0         0 foreach my $filename (@files) {
3155 0         0 $o->incrementProgress;
3156 0         0 my $hash = pack 'H*', $topFolder.$filename;
3157 0         0 my @s = stat $o->{objectsFolder}.'/'.$topFolder.'/'.$filename;
3158 0         0 $objects{$hash} = $s[7];
3159 0 0       0 next if $s[9] < $dateLimit;
3160 0         0 $o->traverse($hash, 'recent object');
3161             }
3162             }
3163              
3164 0         0 $o->{ui}->line(scalar keys %objects, ' objects traversed');
3165 0         0 $o->{ui}->space;
3166              
3167             # Delete all unmarked objects, and add the marked objects to the new tree index
3168 0         0 my $index = CDS::Record->new;
3169 0         0 my $countKeptObjects = 0;
3170 0         0 my $sizeKeptObjects = 0;
3171 0         0 my $countDeletedObjects = 0;
3172 0         0 my $sizeDeletedObjects = 0;
3173              
3174 0         0 $handler->startDeletion;
3175 0         0 $o->startProgress('delete-objects');
3176 0         0 for my $hash (keys %objects) {
3177 0         0 my $size = $objects{$hash};
3178 0 0       0 if (exists $o->{usedHashes}->{$hash}) {
3179 0         0 $countKeptObjects += 1;
3180 0         0 $sizeKeptObjects += $size;
3181 0         0 my $entry = $o->{index}->{$hash};
3182 0 0       0 $index->addRecord($entry) if $entry;
3183             } else {
3184 0         0 $o->incrementProgress;
3185 0         0 $countDeletedObjects += 1;
3186 0         0 $sizeDeletedObjects += $size;
3187 0         0 my $hashHex = unpack 'H*', $hash;
3188 0         0 my $file = $o->{objectsFolder}.'/'.substr($hashHex, 0, 2).'/'.substr($hashHex, 2);
3189 0   0     0 $handler->deleteObject($file) // return;
3190             }
3191             }
3192              
3193             # Write the new tree index
3194 0         0 CDS->writeBytesToFile($o->{storeFolder}.'/.index-new', $index->toObject->bytes);
3195 0         0 rename $o->{storeFolder}.'/.index-new', $o->{storeFolder}.'/.index';
3196              
3197             # Show what has been done
3198 0         0 $o->{ui}->space;
3199 0         0 $o->{ui}->line($countDeletedEnvelopes, ' ', $handler->{deletedEnvelopesText});
3200 0         0 $o->{ui}->line($countKeptEnvelopes, ' ', $handler->{keptEnvelopesText});
3201 0         0 my $line1 = $countDeletedObjects.' '.$handler->{deletedObjectsText};
3202 0         0 my $line2 = $countKeptObjects.' '.$handler->{keptObjectsText};
3203 0         0 my $maxLength = CDS->max(length $line1, length $line2);
3204 0         0 $o->{ui}->line($o->{ui}->left($maxLength, $line1), ' ', $o->{ui}->gray($o->{ui}->niceFileSize($sizeDeletedObjects)));
3205 0         0 $o->{ui}->line($o->{ui}->left($maxLength, $line2), ' ', $o->{ui}->gray($o->{ui}->niceFileSize($sizeKeptObjects)));
3206 0         0 $o->{ui}->space;
3207 0         0 $handler->wrapUp;
3208              
3209 0         0 my $missing = scalar keys %{$o->{missingObjects}};
  0         0  
3210 0 0       0 if ($missing) {
3211 0         0 $o->{ui}->warning($missing, ' objects are referenced from other objects, but missing:');
3212              
3213 0         0 my $count = 0;
3214 0         0 for my $hashBytes (sort keys %{$o->{missingObjects}}) {
  0         0  
3215 0         0 $o->{ui}->warning(' ', unpack('H*', $hashBytes));
3216              
3217 0         0 $count += 1;
3218 0 0 0     0 if ($missing > 10 && $count > 5) {
3219 0         0 $o->{ui}->warning(' …');
3220 0         0 last;
3221             }
3222             }
3223              
3224 0         0 $o->{ui}->space;
3225 0         0 $o->{ui}->warning('The missing objects are from the following origins:');
3226 0         0 for my $origin (sort keys %{$o->{brokenOrigins}}) {
  0         0  
3227 0         0 $o->{ui}->line(' ', $o->{ui}->orange($origin));
3228             }
3229              
3230 0         0 $o->{ui}->space;
3231             }
3232             }
3233              
3234             sub traverse {
3235 0     0   0 my $o = shift;
3236 0         0 my $hashBytes = shift;
3237 0         0 my $origin = shift;
3238              
3239 0 0       0 return $o->{usedHashes}->{$hashBytes} if exists $o->{usedHashes}->{$hashBytes};
3240              
3241             # Get index information about the object
3242 0   0     0 my $record = $o->index($hashBytes, $origin) // return 0;
3243 0         0 my $size = $record->nthChild(0)->asInteger;
3244              
3245             # Process children
3246 0         0 my $pos = 0;
3247 0         0 my $hashes = $record->nthChild(1)->bytes;
3248 0         0 while ($pos < length $hashes) {
3249 0         0 $size += $o->traverse(substr($hashes, $pos, 32), $origin);
3250 0         0 $pos += 32;
3251             }
3252              
3253             # Keep the size for future use
3254 0         0 $o->{usedHashes}->{$hashBytes} = $size;
3255 0         0 return $size;
3256             }
3257              
3258             sub readIndex {
3259 0     0   0 my $o = shift;
3260              
3261 0         0 $o->{index} = {};
3262 0         0 my $file = $o->{storeFolder}.'/.index';
3263 0   0     0 my $record = CDS::Record->fromObject(CDS::Object->fromBytes(CDS->readBytesFromFile($file))) // return;
3264 0         0 for my $child ($record->children) {
3265 0         0 $o->{index}->{$child->bytes} = $child;
3266             }
3267             }
3268              
3269             sub index {
3270 0     0   0 my $o = shift;
3271 0         0 my $hashBytes = shift;
3272 0         0 my $origin = shift;
3273              
3274 0         0 $o->incrementProgress;
3275              
3276             # Report a known result
3277 0 0       0 if ($o->{missingObjects}->{$hashBytes}) {
3278 0         0 $o->{brokenOrigins}->{$origin} = 1;
3279 0         0 return;
3280             }
3281              
3282 0 0       0 return $o->{index}->{$hashBytes} if exists $o->{index}->{$hashBytes};
3283              
3284             # Object file
3285 0         0 my $hashHex = unpack 'H*', $hashBytes;
3286 0         0 my $file = $o->{objectsFolder}.'/'.substr($hashHex, 0, 2).'/'.substr($hashHex, 2);
3287              
3288             # Size and existence
3289 0         0 my @s = stat $file;
3290 0 0       0 if (! scalar @s) {
3291 0         0 $o->{missingObjects}->{$hashBytes} = 1;
3292 0         0 $o->{brokenOrigins}->{$origin} = 1;
3293 0         0 return;
3294             }
3295 0         0 my $size = $s[7];
3296 0 0       0 return $o->{ui}->error('Unexpected: object ', $hashHex, ' has ', $size, ' bytes') if $size < 4;
3297              
3298             # Read header
3299 0         0 open O, '<', $file;
3300 0         0 read O, my $buffer, 4;
3301 0         0 my $links = unpack 'L>', $buffer;
3302 0 0       0 return $o->{ui}->error('Unexpected: object ', $hashHex, ' has ', $links, ' references') if $links > 160000;
3303 0 0       0 return $o->{ui}->error('Unexpected: object ', $hashHex, ' is too small for ', $links, ' references') if 4 + $links * 32 > $s[7];
3304 0         0 my $hashes = '';
3305 0 0       0 read O, $hashes, $links * 32 if $links > 0;
3306 0         0 close O;
3307              
3308 0 0       0 return $o->{ui}->error('Incomplete read: ', length $hashes, ' out of ', $links * 32, ' bytes received.') if length $hashes != $links * 32;
3309              
3310 0         0 my $record = CDS::Record->new($hashBytes);
3311 0         0 $record->addInteger($size);
3312 0         0 $record->add($hashes);
3313 0         0 return $o->{index}->{$hashBytes} = $record;
3314             }
3315              
3316             sub envelopeExpiration {
3317 0     0   0 my $o = shift;
3318 0         0 my $hashBytes = shift;
3319 0         0 my $origin = shift;
3320              
3321 0   0     0 my $entry = $o->index($hashBytes, $origin) // return 0;
3322 0 0       0 return $entry->nthChild(2)->asInteger if scalar $entry->children > 2;
3323              
3324             # Object file
3325 0         0 my $hashHex = unpack 'H*', $hashBytes;
3326 0         0 my $file = $o->{objectsFolder}.'/'.substr($hashHex, 0, 2).'/'.substr($hashHex, 2);
3327 0         0 my $record = CDS::Record->fromObject(CDS::Object->fromBytes(CDS->readBytesFromFile($file)));
3328 0         0 my $expires = $record->child('expires')->integerValue;
3329 0         0 $entry->addInteger($expires);
3330 0         0 return $expires;
3331             }
3332              
3333             sub startProgress {
3334 0     0   0 my $o = shift;
3335 0         0 my $title = shift;
3336              
3337 0         0 $o->{progress} = 0;
3338 0         0 $o->{progressTitle} = $title;
3339 0         0 $o->{ui}->progress($o->{progress}, ' ', $o->{progressTitle});
3340             }
3341              
3342             sub incrementProgress {
3343 0     0   0 my $o = shift;
3344              
3345 0         0 $o->{progress} += 1;
3346 0 0       0 return if $o->{progress} % 100;
3347 0         0 $o->{ui}->progress($o->{progress}, ' ', $o->{progressTitle});
3348             }
3349              
3350             sub lastModified {
3351 0     0   0 my $file = shift;
3352              
3353 0         0 my @s = stat $file;
3354 0 0       0 return scalar @s ? $s[9] : 0;
3355             }
3356              
3357             package CDS::Commands::CollectGarbage::Delete;
3358              
3359             sub new {
3360 0     0   0 my $class = shift;
3361 0         0 my $ui = shift;
3362              
3363 0         0 return bless {
3364             ui => $ui,
3365             deletedEnvelopesText => 'expired envelopes deleted',
3366             keptEnvelopesText => 'envelopes kept',
3367             deletedObjectsText => 'objects deleted',
3368             keptObjectsText => 'objects kept',
3369             };
3370             }
3371              
3372             sub initialize {
3373 0     0   0 my $o = shift;
3374 0         0 my $folder = shift;
3375 0         0 1 }
3376              
3377             sub startDeletion {
3378 0     0   0 my $o = shift;
3379              
3380 0         0 $o->{ui}->title('Deleting obsolete objects');
3381             }
3382              
3383             sub deleteEnvelope {
3384 0     0   0 my $o = shift;
3385 0         0 my $file = shift;
3386 0         0 $o->deleteObject($file) }
3387              
3388             sub deleteObject {
3389 0     0   0 my $o = shift;
3390 0         0 my $file = shift;
3391              
3392 0   0     0 unlink $file // return $o->{ui}->error('Unable to delete "', $file, '". Giving up …');
3393 0         0 return 1;
3394             }
3395              
3396             sub wrapUp {
3397 0     0   0 my $o = shift;
3398             }
3399              
3400             package CDS::Commands::CollectGarbage::Report;
3401              
3402             sub new {
3403 0     0   0 my $class = shift;
3404 0         0 my $ui = shift;
3405              
3406 0         0 return bless {
3407             ui => $ui,
3408             countReported => 0,
3409             deletedEnvelopesText => 'envelopes have expired',
3410             keptEnvelopesText => 'envelopes are in use',
3411             deletedObjectsText => 'objects can be deleted',
3412             keptObjectsText => 'objects are in use',
3413             };
3414             }
3415              
3416             sub initialize {
3417 0     0   0 my $o = shift;
3418 0         0 my $folderStore = shift;
3419              
3420 0         0 $o->{file} = $folderStore->folder.'/.garbage';
3421 0 0       0 open($o->{fh}, '>', $o->{file}) || return $o->{ui}->error('Failed to open ', $o->{file}, ' for writing.');
3422 0         0 return 1;
3423             }
3424              
3425             sub startDeletion {
3426 0     0   0 my $o = shift;
3427              
3428 0         0 $o->{ui}->title('Deleting obsolete objects');
3429             }
3430              
3431             sub deleteEnvelope {
3432 0     0   0 my $o = shift;
3433 0         0 my $file = shift;
3434 0         0 $o->deleteObject($file) }
3435              
3436             sub deleteObject {
3437 0     0   0 my $o = shift;
3438 0         0 my $file = shift;
3439              
3440 0         0 my $fh = $o->{fh};
3441 0         0 print $fh 'rm ', $file, "\n";
3442 0         0 $o->{countReported} += 1;
3443 0 0       0 print $fh 'echo ', $o->{countReported}, ' files deleted', "\n" if $o->{countReported} % 100 == 0;
3444 0         0 return 1;
3445             }
3446              
3447             sub wrapUp {
3448 0     0   0 my $o = shift;
3449              
3450 0         0 close $o->{fh};
3451 0 0       0 if ($o->{countReported} == 0) {
3452 0         0 unlink $o->{file};
3453             } else {
3454 0         0 $o->{ui}->space;
3455 0         0 $o->{ui}->p('The report was written to ', $o->{file}, '.');
3456 0         0 $o->{ui}->space;
3457             }
3458             }
3459              
3460             # BEGIN AUTOGENERATED
3461             package CDS::Commands::CreateKeyPair;
3462              
3463             sub register {
3464 0     0   0 my $class = shift;
3465 0         0 my $cds = shift;
3466 0         0 my $help = shift;
3467              
3468 0         0 my $node000 = CDS::Parser::Node->new(0);
3469 0         0 my $node001 = CDS::Parser::Node->new(0);
3470 0         0 my $node002 = CDS::Parser::Node->new(0);
3471 0         0 my $node003 = CDS::Parser::Node->new(0);
3472 0         0 my $node004 = CDS::Parser::Node->new(0);
3473 0         0 my $node005 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
3474 0         0 my $node006 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&createKeyPair});
3475 0         0 $cds->addArrow($node002, 1, 0, 'create');
3476 0         0 $help->addArrow($node000, 1, 0, 'create');
3477 0         0 $node000->addArrow($node001, 1, 0, 'key');
3478 0         0 $node001->addArrow($node005, 1, 0, 'pair');
3479 0         0 $node002->addArrow($node003, 1, 0, 'key');
3480 0         0 $node003->addArrow($node004, 1, 0, 'pair');
3481 0         0 $node004->addArrow($node006, 1, 0, 'FILENAME', \&collectFilename);
3482             }
3483              
3484             sub collectFilename {
3485 0     0   0 my $o = shift;
3486 0         0 my $label = shift;
3487 0         0 my $value = shift;
3488              
3489 0         0 $o->{filename} = $value;
3490             }
3491              
3492             sub new {
3493 0     0   0 my $class = shift;
3494 0         0 my $actor = shift;
3495 0         0 bless {actor => $actor, ui => $actor->ui} }
3496              
3497             # END AUTOGENERATED
3498              
3499             # HTML FOLDER NAME create-key-pair
3500             # HTML TITLE Create key pair
3501             sub help {
3502 0     0   0 my $o = shift;
3503 0         0 my $cmd = shift;
3504              
3505 0         0 my $ui = $o->{ui};
3506 0         0 $ui->space;
3507 0         0 $ui->command('cds create key pair FILENAME');
3508 0         0 $ui->p('Generates a key pair, and writes it to FILENAME.');
3509 0         0 $ui->space;
3510 0         0 $ui->title('Related commands');
3511 0         0 $ui->line(' cds select …');
3512 0         0 $ui->line(' cds use …');
3513 0         0 $ui->line(' cds entrust …');
3514 0         0 $ui->line(' cds drop …');
3515 0         0 $ui->space;
3516             }
3517              
3518             sub createKeyPair {
3519 0     0   0 my $o = shift;
3520 0         0 my $cmd = shift;
3521              
3522 0         0 $cmd->collect($o);
3523 0 0       0 return $o->{ui}->error('The file "', $o->{filename}, '" exists.') if -e $o->{filename};
3524 0         0 my $keyPair = CDS::KeyPair->generate;
3525 0   0     0 $keyPair->writeToFile($o->{filename}) // return $o->{ui}->error('Failed to write the key pair file "', $o->{filename}, '".');
3526 0         0 $o->{ui}->pGreen('Key pair "', $o->{filename}, '" created.');
3527             }
3528              
3529             # BEGIN AUTOGENERATED
3530             package CDS::Commands::Curl;
3531              
3532             sub register {
3533 0     0   0 my $class = shift;
3534 0         0 my $cds = shift;
3535 0         0 my $help = shift;
3536              
3537 0         0 my $node000 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
3538 0         0 my $node001 = CDS::Parser::Node->new(1);
3539 0         0 my $node002 = CDS::Parser::Node->new(0);
3540 0         0 my $node003 = CDS::Parser::Node->new(0);
3541 0         0 my $node004 = CDS::Parser::Node->new(0);
3542 0         0 my $node005 = CDS::Parser::Node->new(0);
3543 0         0 my $node006 = CDS::Parser::Node->new(0);
3544 0         0 my $node007 = CDS::Parser::Node->new(0);
3545 0         0 my $node008 = CDS::Parser::Node->new(0);
3546 0         0 my $node009 = CDS::Parser::Node->new(0);
3547 0         0 my $node010 = CDS::Parser::Node->new(0);
3548 0         0 my $node011 = CDS::Parser::Node->new(0);
3549 0         0 my $node012 = CDS::Parser::Node->new(0);
3550 0         0 my $node013 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlGet});
3551 0         0 my $node014 = CDS::Parser::Node->new(0);
3552 0         0 my $node015 = CDS::Parser::Node->new(0);
3553 0         0 my $node016 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlPut});
3554 0         0 my $node017 = CDS::Parser::Node->new(0);
3555 0         0 my $node018 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlBook});
3556 0         0 my $node019 = CDS::Parser::Node->new(0);
3557 0         0 my $node020 = CDS::Parser::Node->new(0);
3558 0         0 my $node021 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlList});
3559 0         0 my $node022 = CDS::Parser::Node->new(0);
3560 0         0 my $node023 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlGet});
3561 0         0 my $node024 = CDS::Parser::Node->new(0);
3562 0         0 my $node025 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlPut});
3563 0         0 my $node026 = CDS::Parser::Node->new(0);
3564 0         0 my $node027 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlBook});
3565 0         0 my $node028 = CDS::Parser::Node->new(0);
3566 0         0 my $node029 = CDS::Parser::Node->new(1);
3567 0         0 my $node030 = CDS::Parser::Node->new(0);
3568 0         0 my $node031 = CDS::Parser::Node->new(0);
3569 0         0 my $node032 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlList});
3570 0         0 my $node033 = CDS::Parser::Node->new(0);
3571 0         0 my $node034 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlGet});
3572 0         0 my $node035 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlPut});
3573 0         0 my $node036 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlBook});
3574 0         0 my $node037 = CDS::Parser::Node->new(1);
3575 0         0 my $node038 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlList});
3576 0         0 my $node039 = CDS::Parser::Node->new(0);
3577 0         0 my $node040 = CDS::Parser::Node->new(0);
3578 0         0 my $node041 = CDS::Parser::Node->new(0);
3579 0         0 my $node042 = CDS::Parser::Node->new(0);
3580 0         0 my $node043 = CDS::Parser::Node->new(0);
3581 0         0 my $node044 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlList});
3582 0         0 my $node045 = CDS::Parser::Node->new(1);
3583 0         0 my $node046 = CDS::Parser::Node->new(0);
3584 0         0 my $node047 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlModify});
3585 0         0 my $node048 = CDS::Parser::Node->new(0);
3586 0         0 my $node049 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlModify});
3587 0         0 my $node050 = CDS::Parser::Node->new(0);
3588 0         0 my $node051 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&curlModify});
3589 0         0 $cds->addArrow($node001, 1, 0, 'curl');
3590 0         0 $help->addArrow($node000, 1, 0, 'curl');
3591 0         0 $node001->addArrow($node002, 1, 0, 'get');
3592 0         0 $node001->addArrow($node003, 1, 0, 'put');
3593 0         0 $node001->addArrow($node004, 1, 0, 'book');
3594 0         0 $node001->addArrow($node005, 1, 0, 'get');
3595 0         0 $node001->addArrow($node006, 1, 0, 'book');
3596 0         0 $node001->addArrow($node007, 1, 0, 'list');
3597 0         0 $node001->addArrow($node007, 1, 0, 'watch', \&collectWatch);
3598 0         0 $node001->addDefault($node011);
3599 0         0 $node002->addArrow($node013, 1, 0, 'HASH', \&collectHash);
3600 0         0 $node003->addArrow($node016, 1, 0, 'FILE', \&collectFile);
3601 0         0 $node004->addArrow($node018, 1, 0, 'HASH', \&collectHash);
3602 0         0 $node005->addArrow($node023, 1, 0, 'OBJECT', \&collectObject);
3603 0         0 $node006->addArrow($node027, 1, 0, 'OBJECT', \&collectObject);
3604 0         0 $node007->addArrow($node008, 1, 0, 'message');
3605 0         0 $node007->addArrow($node009, 1, 0, 'private');
3606 0         0 $node007->addArrow($node010, 1, 0, 'public');
3607 0         0 $node007->addArrow($node021, 0, 0, 'messages', \&collectMessages);
3608 0         0 $node007->addArrow($node021, 0, 0, 'private', \&collectPrivate);
3609 0         0 $node007->addArrow($node021, 0, 0, 'public', \&collectPublic);
3610 0         0 $node008->addArrow($node021, 1, 0, 'box', \&collectMessages);
3611 0         0 $node009->addArrow($node021, 1, 0, 'box', \&collectPrivate);
3612 0         0 $node010->addArrow($node021, 1, 0, 'box', \&collectPublic);
3613 0         0 $node011->addArrow($node012, 1, 0, 'remove');
3614 0         0 $node011->addArrow($node020, 1, 0, 'add');
3615 0         0 $node012->addArrow($node012, 1, 0, 'HASH', \&collectHash1);
3616 0         0 $node012->addArrow($node037, 1, 0, 'HASH', \&collectHash1);
3617 0         0 $node013->addArrow($node014, 1, 0, 'from');
3618 0         0 $node013->addArrow($node015, 0, 0, 'on');
3619 0         0 $node013->addDefault($node023);
3620 0         0 $node014->addArrow($node023, 1, 0, 'STORE', \&collectStore);
3621 0         0 $node015->addArrow($node023, 0, 0, 'STORE', \&collectStore);
3622 0         0 $node016->addArrow($node017, 1, 0, 'onto');
3623 0         0 $node016->addDefault($node025);
3624 0         0 $node017->addArrow($node025, 1, 0, 'STORE', \&collectStore);
3625 0         0 $node018->addArrow($node019, 1, 0, 'on');
3626 0         0 $node018->addDefault($node027);
3627 0         0 $node019->addArrow($node027, 1, 0, 'STORE', \&collectStore);
3628 0         0 $node020->addArrow($node029, 1, 0, 'FILE', \&collectFile1);
3629 0         0 $node020->addArrow($node029, 1, 0, 'HASH', \&collectHash2);
3630 0         0 $node021->addArrow($node022, 1, 0, 'of');
3631 0         0 $node022->addArrow($node032, 1, 0, 'ACTOR', \&collectActor);
3632 0         0 $node023->addArrow($node024, 1, 0, 'using');
3633 0         0 $node024->addArrow($node034, 1, 0, 'KEYPAIR', \&collectKeypair);
3634 0         0 $node025->addArrow($node026, 1, 0, 'using');
3635 0         0 $node026->addArrow($node035, 1, 0, 'KEYPAIR', \&collectKeypair);
3636 0         0 $node027->addArrow($node028, 1, 0, 'using');
3637 0         0 $node028->addArrow($node036, 1, 0, 'KEYPAIR', \&collectKeypair);
3638 0         0 $node029->addDefault($node020);
3639 0         0 $node029->addArrow($node030, 1, 0, 'and');
3640 0         0 $node029->addArrow($node040, 1, 0, 'to');
3641 0         0 $node030->addArrow($node031, 1, 0, 'remove');
3642 0         0 $node031->addArrow($node031, 1, 0, 'HASH', \&collectHash1);
3643 0         0 $node031->addArrow($node037, 1, 0, 'HASH', \&collectHash1);
3644 0         0 $node032->addArrow($node033, 1, 0, 'on');
3645 0         0 $node033->addArrow($node038, 1, 0, 'STORE', \&collectStore);
3646 0         0 $node037->addArrow($node040, 1, 0, 'from');
3647 0         0 $node038->addArrow($node039, 1, 0, 'using');
3648 0         0 $node039->addArrow($node044, 1, 0, 'KEYPAIR', \&collectKeypair);
3649 0         0 $node040->addArrow($node041, 1, 0, 'message');
3650 0         0 $node040->addArrow($node042, 1, 0, 'private');
3651 0         0 $node040->addArrow($node043, 1, 0, 'public');
3652 0         0 $node040->addArrow($node045, 0, 0, 'messages', \&collectMessages1);
3653 0         0 $node040->addArrow($node045, 0, 0, 'private', \&collectPrivate1);
3654 0         0 $node040->addArrow($node045, 0, 0, 'public', \&collectPublic1);
3655 0         0 $node041->addArrow($node045, 1, 0, 'box', \&collectMessages1);
3656 0         0 $node042->addArrow($node045, 1, 0, 'box', \&collectPrivate1);
3657 0         0 $node043->addArrow($node045, 1, 0, 'box', \&collectPublic1);
3658 0         0 $node045->addArrow($node046, 1, 0, 'of');
3659 0         0 $node045->addDefault($node047);
3660 0         0 $node046->addArrow($node047, 1, 0, 'ACTOR', \&collectActor1);
3661 0         0 $node047->addArrow($node011, 1, 0, 'and', \&collectAnd);
3662 0         0 $node047->addArrow($node048, 1, 0, 'on');
3663 0         0 $node048->addArrow($node049, 1, 0, 'STORE', \&collectStore);
3664 0         0 $node049->addArrow($node050, 1, 0, 'using');
3665 0         0 $node050->addArrow($node051, 1, 0, 'KEYPAIR', \&collectKeypair);
3666             }
3667              
3668             sub collectActor {
3669 0     0   0 my $o = shift;
3670 0         0 my $label = shift;
3671 0         0 my $value = shift;
3672              
3673 0         0 $o->{actorHash} = $value;
3674             }
3675              
3676             sub collectActor1 {
3677 0     0   0 my $o = shift;
3678 0         0 my $label = shift;
3679 0         0 my $value = shift;
3680              
3681 0         0 $o->{currentBatch}->{actorHash} = $value;
3682             }
3683              
3684             sub collectAnd {
3685 0     0   0 my $o = shift;
3686 0         0 my $label = shift;
3687 0         0 my $value = shift;
3688              
3689 0         0 push @{$o->{batches}}, $o->{currentBatch};
  0         0  
3690             $o->{currentBatch} = {
3691 0         0 addHashes => [],
3692             addEnvelopes => [],
3693             removeHashes => []
3694             };
3695             }
3696              
3697             sub collectFile {
3698 0     0   0 my $o = shift;
3699 0         0 my $label = shift;
3700 0         0 my $value = shift;
3701              
3702 0         0 $o->{file} = $value;
3703             }
3704              
3705             sub collectFile1 {
3706 0     0   0 my $o = shift;
3707 0         0 my $label = shift;
3708 0         0 my $value = shift;
3709              
3710 0         0 push @{$o->{currentBatch}->{addFiles}}, $value;
  0         0  
3711             }
3712              
3713             sub collectHash {
3714 0     0   0 my $o = shift;
3715 0         0 my $label = shift;
3716 0         0 my $value = shift;
3717              
3718 0         0 $o->{hash} = $value;
3719             }
3720              
3721             sub collectHash1 {
3722 0     0   0 my $o = shift;
3723 0         0 my $label = shift;
3724 0         0 my $value = shift;
3725              
3726 0         0 push @{$o->{currentBatch}->{removeHashes}}, $value;
  0         0  
3727             }
3728              
3729             sub collectHash2 {
3730 0     0   0 my $o = shift;
3731 0         0 my $label = shift;
3732 0         0 my $value = shift;
3733              
3734 0         0 push @{$o->{currentBatch}->{addHashes}}, $value;
  0         0  
3735             }
3736              
3737             sub collectKeypair {
3738 0     0   0 my $o = shift;
3739 0         0 my $label = shift;
3740 0         0 my $value = shift;
3741              
3742 0         0 $o->{keyPairToken} = $value;
3743             }
3744              
3745             sub collectMessages {
3746 0     0   0 my $o = shift;
3747 0         0 my $label = shift;
3748 0         0 my $value = shift;
3749              
3750 0         0 $o->{boxLabel} = 'messages';
3751             }
3752              
3753             sub collectMessages1 {
3754 0     0   0 my $o = shift;
3755 0         0 my $label = shift;
3756 0         0 my $value = shift;
3757              
3758 0         0 $o->{currentBatch}->{boxLabel} = 'messages';
3759             }
3760              
3761             sub collectObject {
3762 0     0   0 my $o = shift;
3763 0         0 my $label = shift;
3764 0         0 my $value = shift;
3765              
3766 0         0 $o->{hash} = $value->hash;
3767 0         0 $o->{store} = $value->cliStore;
3768             }
3769              
3770             sub collectPrivate {
3771 0     0   0 my $o = shift;
3772 0         0 my $label = shift;
3773 0         0 my $value = shift;
3774              
3775 0         0 $o->{boxLabel} = 'private';
3776             }
3777              
3778             sub collectPrivate1 {
3779 0     0   0 my $o = shift;
3780 0         0 my $label = shift;
3781 0         0 my $value = shift;
3782              
3783 0         0 $o->{currentBatch}->{boxLabel} = 'private';
3784             }
3785              
3786             sub collectPublic {
3787 0     0   0 my $o = shift;
3788 0         0 my $label = shift;
3789 0         0 my $value = shift;
3790              
3791 0         0 $o->{boxLabel} = 'public';
3792             }
3793              
3794             sub collectPublic1 {
3795 0     0   0 my $o = shift;
3796 0         0 my $label = shift;
3797 0         0 my $value = shift;
3798              
3799 0         0 $o->{currentBatch}->{boxLabel} = 'public';
3800             }
3801              
3802             sub collectStore {
3803 0     0   0 my $o = shift;
3804 0         0 my $label = shift;
3805 0         0 my $value = shift;
3806              
3807 0         0 $o->{store} = $value;
3808             }
3809              
3810             sub collectWatch {
3811 0     0   0 my $o = shift;
3812 0         0 my $label = shift;
3813 0         0 my $value = shift;
3814              
3815 0         0 $o->{watchTimeout} = 60000;
3816             }
3817              
3818             sub new {
3819 0     0   0 my $class = shift;
3820 0         0 my $actor = shift;
3821 0         0 bless {actor => $actor, ui => $actor->ui} }
3822              
3823             # END AUTOGENERATED
3824              
3825             # HTML FOLDER NAME curl
3826             # HTML TITLE Curl
3827             sub help {
3828 0     0   0 my $o = shift;
3829 0         0 my $cmd = shift;
3830              
3831 0         0 my $ui = $o->{ui};
3832 0         0 $ui->space;
3833 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.');
3834 0         0 $ui->space;
3835 0         0 $ui->command('cds curl get OBJECT');
3836 0         0 $ui->command('cds curl get HASH [from|on STORE]');
3837 0         0 $ui->p('Downloads an object with a GET request on an object store.');
3838 0         0 $ui->space;
3839 0         0 $ui->command('cds curl put FILE [onto STORE]');
3840 0         0 $ui->p('Uploads an object with a PUT request on an object store.');
3841 0         0 $ui->space;
3842 0         0 $ui->command('cds curl book OBJECT');
3843 0         0 $ui->command('cds curl book HASH [on STORE]');
3844 0         0 $ui->p('Books an object with a POST request on an object store.');
3845 0         0 $ui->space;
3846 0         0 $ui->command('cds curl list message box of ACTOR [on STORE]');
3847 0         0 $ui->command('cds curl list private box of ACTOR [on STORE]');
3848 0         0 $ui->command('cds curl list public box of ACTOR [on STORE]');
3849 0         0 $ui->p('Lists the indicated box with a GET request on an account store.');
3850 0         0 $ui->space;
3851 0         0 $ui->command('cds curl watch message box of ACTOR [on STORE]');
3852 0         0 $ui->command('cds curl watch private box of ACTOR [on STORE]');
3853 0         0 $ui->command('cds curl watch public box of ACTOR [on STORE]');
3854 0         0 $ui->p('As above, but with a watch timeout of 60 second.');
3855 0         0 $ui->space;
3856 0         0 $ui->command('cds curl add (FILE|HASH)* to (message|private|public) box of ACTOR [and …] [on STORE]');
3857 0         0 $ui->command('cds curl remove HASH* from (message|private|public) box of ACTOR [and …] [on STORE]');
3858 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).');
3859 0         0 $ui->space;
3860 0         0 $ui->command('… using KEYPAIR');
3861 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.');
3862 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.');
3863 0         0 $ui->space;
3864             }
3865              
3866             sub curlGet {
3867 0     0   0 my $o = shift;
3868 0         0 my $cmd = shift;
3869              
3870 0         0 $cmd->collect($o);
3871 0 0       0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken if ! $o->{keyPairToken};
3872 0 0       0 $o->{store} = $o->{actor}->preferredStore if ! $o->{store};
3873              
3874 0         0 my $objectToken = CDS::ObjectToken->new($o->{store}, $o->{hash});
3875 0         0 $o->curlRequest('GET', $objectToken->url, ['--output', $o->{hash}->hex]);
3876             }
3877              
3878             sub curlPut {
3879 0     0   0 my $o = shift;
3880 0         0 my $cmd = shift;
3881              
3882 0         0 $cmd->collect($o);
3883 0 0       0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken if ! $o->{keyPairToken};
3884 0 0       0 $o->{store} = $o->{actor}->preferredStore if ! $o->{store};
3885              
3886 0   0     0 my $bytes = CDS->readBytesFromFile($o->{file}) // return $o->{ui}->error('Unable to read "', $o->{file}, '".');
3887 0         0 my $hash = CDS::Hash->calculateFor($bytes);
3888 0         0 my $objectToken = CDS::ObjectToken->new($o->{store}, $hash);
3889 0         0 $o->curlRequest('PUT', $objectToken->url, ['--data-binary', '@'.$o->{file}, '-H', 'Content-Type: application/condensation-object']);
3890             }
3891              
3892             sub curlBook {
3893 0     0   0 my $o = shift;
3894 0         0 my $cmd = shift;
3895              
3896 0         0 $cmd->collect($o);
3897 0 0       0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken if ! $o->{keyPairToken};
3898 0 0       0 $o->{store} = $o->{actor}->preferredStore if ! $o->{store};
3899              
3900 0         0 my $objectToken = CDS::ObjectToken->new($o->{store}, $o->{hash});
3901 0         0 $o->curlRequest('POST', $objectToken->url, []);
3902             }
3903              
3904             sub curlList {
3905 0     0   0 my $o = shift;
3906 0         0 my $cmd = shift;
3907              
3908 0         0 $cmd->collect($o);
3909 0 0       0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken if ! $o->{keyPairToken};
3910 0 0       0 $o->{store} = $o->{actor}->preferredStore if ! $o->{store};
3911 0 0       0 $o->{actorHash} = $o->{actor}->preferredActorHash if ! $o->{actorHash};
3912              
3913 0         0 my $boxToken = CDS::BoxToken->new(CDS::AccountToken->new($o->{store}, $o->{actorHash}), $o->{boxLabel});
3914 0         0 my $args = ['--output', '.cds-curl-list'];
3915 0 0       0 push @$args, '-H', 'Condensation-Watch: '.$o->{watchTimeout}.' ms' if $o->{watchTimeout};
3916 0         0 $o->curlRequest('GET', $boxToken->url, $args);
3917             }
3918              
3919             sub curlModify {
3920 0     0   0 my $o = shift;
3921 0         0 my $cmd = shift;
3922              
3923             $o->{currentBatch} = {
3924 0         0 addHashes => [],
3925             addEnvelopes => [],
3926             removeHashes => [],
3927             };
3928 0         0 $o->{batches} = [];
3929 0         0 $cmd->collect($o);
3930 0 0       0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken if ! $o->{keyPairToken};
3931 0 0       0 $o->{store} = $o->{actor}->preferredStore if ! $o->{store};
3932              
3933             # Prepare the modifications
3934 0         0 my $modifications = CDS::StoreModifications->new;
3935              
3936 0         0 for my $batch (@{$o->{batches}}, $o->{currentBatch}) {
  0         0  
3937 0 0       0 $batch->{actorHash} = $o->{actor}->preferredActorHash if ! $batch->{actorHash};
3938              
3939 0         0 for my $hash (@{$batch->{addHashes}}) {
  0         0  
3940 0         0 $modifications->add($batch->{actorHash}, $batch->{boxLabel}, $hash);
3941             }
3942              
3943 0         0 for my $file (@{$batch->{addFiles}}) {
  0         0  
3944 0   0     0 my $bytes = CDS->readBytesFromFile($file) // return $o->{ui}->error('Unable to read "', $file, '".');
3945 0   0     0 my $object = CDS::Object->fromBytes($bytes) // return $o->{ui}->error('"', $file, '" is not a Condensation object.');
3946 0         0 my $hash = $object->calculateHash;
3947 0 0       0 $o->{ui}->warning('"', $file, '" is not a valid envelope. The server may reject it.') if ! $o->{actor}->isEnvelope($object);
3948 0         0 $modifications->add($batch->{actorHash}, $batch->{boxLabel}, $hash, $object);
3949             }
3950              
3951 0         0 for my $hash (@{$batch->{removeHashes}}) {
  0         0  
3952 0         0 $modifications->remove($batch->{actorHash}, $batch->{boxLabel}, $hash);
3953             }
3954             }
3955              
3956 0 0       0 $o->{ui}->warning('You didn\'t specify any changes. The server should accept, but ignore this.') if $modifications->isEmpty;
3957              
3958             # Write a new file
3959 0         0 my $modificationsObject = $modifications->toRecord->toObject;
3960 0         0 my $modificationsHash = $modificationsObject->calculateHash;
3961 0         0 my $file = '.cds-curl-modifications-'.substr($modificationsHash->hex, 0, 8);
3962 0   0     0 CDS->writeBytesToFile($file, $modificationsObject->header, $modificationsObject->data) // return $o->{ui}->error('Unable to write modifications to "', $file, '".');
3963 0         0 $o->{ui}->line(scalar @{$modifications->additions}, ' addition(s) and ', scalar @{$modifications->removals}, ' removal(s) written to "', $file, '".');
  0         0  
  0         0  
3964              
3965             # Submit
3966 0         0 $o->curlRequest('POST', $o->{store}->url.'/accounts', ['--data-binary', '@'.$file, '-H', 'Content-Type: application/condensation-modifications'], $modificationsObject);
3967             }
3968              
3969             sub curlRequest {
3970 0     0   0 my $o = shift;
3971 0         0 my $method = shift;
3972 0         0 my $url = shift;
3973 0         0 my $curlArgs = shift;
3974 0         0 my $contentObjectToSign = shift;
3975              
3976             # Parse the URL
3977 0 0       0 $url =~ /^(https?):\/\/([^\/]+)(\/.*|)$/i || return $o->{ui}->error('"', $url, '" does not look like a valid and complete http://… or https://… URL.');
3978 0         0 my $protocol = lc($1);
3979 0         0 my $host = $2;
3980 0         0 my $path = $3;
3981              
3982             # Strip off user and password, if any
3983 0         0 my $credentials;
3984 0 0       0 if ($host =~ /^(.*)\@([^\@]*)$/) {
3985 0         0 $credentials = $1;
3986 0         0 $host = lc($2);
3987             } else {
3988 0         0 $host = lc($host);
3989             }
3990              
3991             # Remove default port
3992 0 0       0 if ($host =~ /^(.*):(\d+)$/) {
3993 0 0 0     0 $host = $1 if $protocol eq 'http' && $2 == 80;
3994 0 0 0     0 $host = $1 if $protocol eq 'https' && $2 == 443;
3995             }
3996              
3997             # Checks the path and warn the user if obvious things are likely to go wrong
3998 0 0       0 $o->{ui}->warning('Warning: "//" in URL may not work') if $path =~ /\/\//;
3999 0 0       0 $o->{ui}->warning('Warning: /./ or /../ in URL may not work') if $path =~ /\/\.+\//;
4000 0 0       0 $o->{ui}->warning('Warning: /. or /.. at the end of the URL may not work') if $path =~ /\/\.+$/;
4001              
4002             # Signature
4003              
4004             # Date
4005 0         0 my $dateString = CDS::ISODate->millisecondString(CDS->now);
4006              
4007             # Text to sign
4008 0         0 my $bytesToSign = $dateString."\0".uc($method)."\0".$host.$path;
4009 0 0       0 $bytesToSign .= "\0".$contentObjectToSign->header.$contentObjectToSign->data if defined $contentObjectToSign;
4010              
4011             # Signature
4012 0         0 my $keyPair = $o->{keyPairToken}->keyPair;
4013 0         0 my $hashToSign = CDS::Hash->calculateFor($bytesToSign);
4014 0         0 my $signature = $keyPair->signHash($hashToSign);
4015 0         0 push @$curlArgs, '-H', 'Condensation-Date: '.$dateString;
4016 0         0 push @$curlArgs, '-H', 'Condensation-Actor: '.$keyPair->publicKey->hash->hex;
4017 0         0 push @$curlArgs, '-H', 'Condensation-Signature: '.unpack('H*', $signature);
4018              
4019             # Write signature information to files
4020 0 0       0 CDS->writeBytesToFile('.cds-curl-bytesToSign', $bytesToSign) || $o->{ui}->warning('Unable to write the bytes to sign to ".cds-curl-bytesToSign".');
4021 0 0       0 CDS->writeBytesToFile('.cds-curl-hashToSign', $hashToSign->bytes) || $o->{ui}->warning('Unable to write the hash to sign to ".cds-curl-hashToSign".');
4022 0 0       0 CDS->writeBytesToFile('.cds-curl-signature', $signature) || $o->{ui}->warning('Unable to write signature to ".cds-curl-signature".');
4023              
4024             # Method
4025 0 0       0 unshift @$curlArgs, '-X', $method if $method ne 'GET';
4026 0         0 unshift @$curlArgs, '-#', '--dump-header', '-';
4027              
4028             # Print
4029 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  
4030              
4031             # Execute
4032 0         0 system('curl', @$curlArgs, $url);
4033             }
4034              
4035             sub withQuotesIfNecessary {
4036 0     0   0 my $text = shift;
4037              
4038 0 0       0 return $text =~ /[^a-zA-Z0-9\.\/\@:,_-]/ ? '\''.$text.'\'' : $text;
4039             }
4040              
4041             # BEGIN AUTOGENERATED
4042             package CDS::Commands::DiscoverActorGroup;
4043              
4044             sub register {
4045 0     0   0 my $class = shift;
4046 0         0 my $cds = shift;
4047 0         0 my $help = shift;
4048              
4049 0         0 my $node000 = CDS::Parser::Node->new(0);
4050 0         0 my $node001 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
4051 0         0 my $node002 = CDS::Parser::Node->new(1);
4052 0         0 my $node003 = CDS::Parser::Node->new(0);
4053 0         0 my $node004 = CDS::Parser::Node->new(0);
4054 0         0 my $node005 = CDS::Parser::Node->new(0);
4055 0         0 my $node006 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showActorGroupCmd});
4056 0         0 my $node007 = CDS::Parser::Node->new(0);
4057 0         0 my $node008 = CDS::Parser::Node->new(0);
4058 0         0 my $node009 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&discover});
4059 0         0 my $node010 = CDS::Parser::Node->new(0);
4060 0         0 my $node011 = CDS::Parser::Node->new(0);
4061 0         0 my $node012 = CDS::Parser::Node->new(0);
4062 0         0 my $node013 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&discover});
4063 0         0 $cds->addArrow($node000, 1, 0, 'show');
4064 0         0 $cds->addArrow($node002, 1, 0, 'discover');
4065 0         0 $help->addArrow($node001, 1, 0, 'discover');
4066 0         0 $help->addArrow($node001, 1, 0, 'rediscover');
4067 0         0 $node000->addArrow($node006, 1, 0, 'ACTORGROUP', \&collectActorgroup);
4068 0         0 $node002->addDefault($node003);
4069 0         0 $node002->addDefault($node004);
4070 0         0 $node002->addDefault($node005);
4071 0         0 $node002->addArrow($node009, 1, 0, 'me', \&collectMe);
4072 0         0 $node002->addArrow($node013, 1, 0, 'ACTORGROUP', \&collectActorgroup1);
4073 0         0 $node003->addArrow($node003, 1, 0, 'ACCOUNT', \&collectAccount);
4074 0         0 $node003->addArrow($node009, 1, 1, 'ACCOUNT', \&collectAccount);
4075 0         0 $node004->addArrow($node004, 1, 0, 'KEYPAIR', \&collectKeypair);
4076 0         0 $node004->addArrow($node007, 1, 0, 'KEYPAIR', \&collectKeypair);
4077 0         0 $node005->addArrow($node005, 1, 0, 'ACTOR', \&collectActor);
4078 0         0 $node005->addArrow($node007, 1, 0, 'ACTOR', \&collectActor);
4079 0         0 $node007->addArrow($node008, 1, 0, 'on');
4080 0         0 $node007->addDefault($node009);
4081 0         0 $node008->addArrow($node009, 1, 0, 'STORE', \&collectStore);
4082 0         0 $node009->addArrow($node010, 1, 0, 'and');
4083 0         0 $node010->addArrow($node011, 1, 0, 'remember');
4084 0         0 $node011->addArrow($node012, 1, 0, 'as');
4085 0         0 $node012->addArrow($node013, 1, 0, 'TEXT', \&collectText);
4086             }
4087              
4088             sub collectAccount {
4089 0     0   0 my $o = shift;
4090 0         0 my $label = shift;
4091 0         0 my $value = shift;
4092              
4093 0         0 push @{$o->{accounts}}, $value;
  0         0  
4094             }
4095              
4096             sub collectActor {
4097 0     0   0 my $o = shift;
4098 0         0 my $label = shift;
4099 0         0 my $value = shift;
4100              
4101 0         0 push @{$o->{actorHashes}}, $value;
  0         0  
4102             }
4103              
4104             sub collectActorgroup {
4105 0     0   0 my $o = shift;
4106 0         0 my $label = shift;
4107 0         0 my $value = shift;
4108              
4109 0         0 $o->{actorGroupToken} = $value;
4110             }
4111              
4112             sub collectActorgroup1 {
4113 0     0   0 my $o = shift;
4114 0         0 my $label = shift;
4115 0         0 my $value = shift;
4116              
4117 0         0 $o->{actorGroupToken} = $value;
4118 0         0 $o->{label} = $value->label;
4119             }
4120              
4121             sub collectKeypair {
4122 0     0   0 my $o = shift;
4123 0         0 my $label = shift;
4124 0         0 my $value = shift;
4125              
4126 0         0 push @{$o->{actorHashes}}, $value->keyPair->publicKey->hash;
  0         0  
4127             }
4128              
4129             sub collectMe {
4130 0     0   0 my $o = shift;
4131 0         0 my $label = shift;
4132 0         0 my $value = shift;
4133              
4134 0         0 $o->{me} = 1;
4135             }
4136              
4137             sub collectStore {
4138 0     0   0 my $o = shift;
4139 0         0 my $label = shift;
4140 0         0 my $value = shift;
4141              
4142 0         0 $o->{store} = $value;
4143             }
4144              
4145             sub collectText {
4146 0     0   0 my $o = shift;
4147 0         0 my $label = shift;
4148 0         0 my $value = shift;
4149              
4150 0         0 $o->{label} = $value;
4151             }
4152              
4153             sub new {
4154 0     0   0 my $class = shift;
4155 0         0 my $actor = shift;
4156 0         0 bless {actor => $actor, ui => $actor->ui} }
4157              
4158             # END AUTOGENERATED
4159              
4160             # HTML FOLDER NAME discover
4161             # HTML TITLE Discover actor groups
4162             sub help {
4163 0     0   0 my $o = shift;
4164 0         0 my $cmd = shift;
4165              
4166 0         0 my $ui = $o->{ui};
4167 0         0 $ui->space;
4168 0         0 $ui->command('cds discover ACCOUNT');
4169 0         0 $ui->command('cds discover ACTOR [on STORE]');
4170 0         0 $ui->p('Discovers the actor group the given account belongs to. Only active group members are discovered.');
4171 0         0 $ui->space;
4172 0         0 $ui->command('cds discover ACCOUNT*');
4173 0         0 $ui->command('cds discover ACTOR* on STORE');
4174 0         0 $ui->p('Same as above, but starts discovery with multiple accounts. All accounts must belong to the same actor group.');
4175 0         0 $ui->p('Note that this rarely makes sense. The actor group discovery algorithm reliably discovers an actor group from a single account.');
4176 0         0 $ui->space;
4177 0         0 $ui->command('cds discover me');
4178 0         0 $ui->p('Discovers your own actor group.');
4179 0         0 $ui->space;
4180 0         0 $ui->command('… and remember as TEXT');
4181 0         0 $ui->p('The discovered actor group is remembered as TEXT. See "cds help remember" for details.');
4182 0         0 $ui->space;
4183 0         0 $ui->command('cds discover ACTORGROUP');
4184 0         0 $ui->p('Updates a previously remembered actor group.');
4185 0         0 $ui->space;
4186 0         0 $ui->command('cds show ACTORGROUP');
4187 0         0 $ui->p('Shows a previously discovered and remembered actor group.');
4188 0         0 $ui->space;
4189             }
4190              
4191             sub discover {
4192 0     0   0 my $o = shift;
4193 0         0 my $cmd = shift;
4194              
4195 0         0 $o->{accounts} = [];
4196 0         0 $o->{actorHashes} = [];
4197 0         0 $cmd->collect($o);
4198              
4199             # Discover
4200 0         0 my $builder = $o->prepareBuilder;
4201 0         0 my ($actorGroup, $cards, $nodes) = $builder->discover($o->{actor}->keyPair, $o);
4202              
4203             # Show the graph
4204 0         0 $o->{ui}->space;
4205 0         0 $o->{ui}->title('Graph');
4206 0         0 for my $node (@$nodes) {
4207 0 0       0 my $status = $node->status eq 'active' ? $o->{ui}->green('active ') : $o->{ui}->gray('idle ');
4208 0         0 $o->{ui}->line($o->{ui}->blue($node->actorHash->hex), ' on ', $node->storeUrl, ' ', $status, $o->{ui}->gray($o->{ui}->niceDateTime($node->revision)));
4209 0         0 $o->{ui}->pushIndent;
4210 0         0 for my $link ($node->links) {
4211 0         0 my $isMostRecentInformation = $link->revision == $link->node->revision;
4212 0 0       0 my $color = $isMostRecentInformation ? 246 : 250;
4213 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)));
4214             }
4215 0         0 $o->{ui}->popIndent;
4216             }
4217              
4218             # Show all accounts
4219 0         0 $o->showActorGroup($actorGroup);
4220              
4221             # Show all cards
4222 0         0 $o->{ui}->space;
4223 0         0 $o->{ui}->title('Cards');
4224 0         0 for my $card (@$cards) {
4225 0         0 $o->{ui}->line($o->{ui}->gold('cds show record ', $card->cardHash->hex, ' on ', $card->storeUrl));
4226             }
4227              
4228             # Remember the actor group if desired
4229 0 0       0 if ($o->{label}) {
4230 0         0 my $selector = $o->{actor}->labelSelector($o->{label});
4231              
4232 0         0 my $record = CDS::Record->new;
4233 0         0 my $actorGroupRecord = $record->add('actor group');
4234 0         0 $actorGroupRecord->add('discovered')->addInteger(CDS->now);
4235 0         0 $actorGroupRecord->addRecord($actorGroup->toBuilder->toRecord(1)->children);
4236 0         0 $selector->set($record);
4237              
4238 0         0 for my $publicKey ($actorGroup->publicKeys) {
4239 0         0 $selector->addObject($publicKey->hash, $publicKey->object);
4240             }
4241              
4242 0   0     0 $o->{actor}->saveOrShowError // return;
4243             }
4244              
4245 0         0 $o->{ui}->space;
4246             }
4247              
4248             sub prepareBuilder {
4249 0     0   0 my $o = shift;
4250              
4251             # Actor group
4252 0 0       0 return $o->{actorGroupToken}->actorGroup->toBuilder if $o->{actorGroupToken};
4253              
4254             # Other than actor group
4255 0         0 my $builder = CDS::ActorGroupBuilder->new;
4256 0         0 $builder->addKnownPublicKey($o->{actor}->keyPair->publicKey);
4257              
4258             # Me
4259 0 0       0 $builder->addMember($o->{actor}->messagingStoreUrl, $o->{actor}->keyPair->publicKey->hash) if $o->{me};
4260              
4261             # Accounts
4262 0         0 for my $account (@{$o->{accounts}}) {
  0         0  
4263 0         0 $builder->addMember($account->cliStore->url, $account->actorHash);
4264             }
4265              
4266             # Actors on store
4267 0 0       0 if (scalar @{$o->{actorHashes}}) {
  0         0  
4268 0   0     0 my $store = $o->{store} // $o->{actor}->preferredStore;
4269 0         0 for my $actorHash (@{$o->{actorHashes}}) {
  0         0  
4270 0         0 $builder->addMember($actorHash, $store->url);
4271             }
4272             }
4273              
4274 0         0 return $builder;
4275             }
4276              
4277             sub showActorGroupCmd {
4278 0     0   0 my $o = shift;
4279 0         0 my $cmd = shift;
4280              
4281 0         0 $cmd->collect($o);
4282 0         0 $o->showActorGroup($o->{actorGroupToken}->actorGroup);
4283 0         0 $o->{ui}->space;
4284             }
4285              
4286             sub showActorGroup {
4287 0     0   0 my $o = shift;
4288 0 0 0     0 my $actorGroup = shift; die 'wrong type '.ref($actorGroup).' for $actorGroup' if defined $actorGroup && ref $actorGroup ne 'CDS::ActorGroup';
  0         0  
4289              
4290 0         0 $o->{ui}->space;
4291 0 0       0 $o->{ui}->title(length $o->{label} ? 'Actors of '.$o->{label} : 'Actor group');
4292 0         0 for my $member ($actorGroup->members) {
4293 0 0       0 my $date = $member->revision ? $o->{ui}->niceDateTimeLocal($member->revision) : ' ';
4294 0 0       0 my $status = $member->isActive ? $o->{ui}->green('active ') : $o->{ui}->gray('idle ');
4295 0         0 my $storeReference = $o->{actor}->blueStoreUrlReference($member->storeUrl);
4296 0         0 $o->{ui}->line($o->{ui}->gray($date), ' ', $status, ' ', $member->actorOnStore->publicKey->hash->hex, ' on ', $storeReference);
4297             }
4298              
4299 0 0       0 if ($actorGroup->entrustedActorsRevision) {
4300 0         0 $o->{ui}->space;
4301 0 0       0 $o->{ui}->title(length $o->{label} ? 'Actors entrusted by '.$o->{label} : 'Entrusted actors');
4302 0         0 $o->{ui}->line($o->{ui}->gray($o->{ui}->niceDateTimeLocal($actorGroup->entrustedActorsRevision)));
4303 0         0 for my $actor ($actorGroup->entrustedActors) {
4304 0         0 my $storeReference = $o->{actor}->storeUrlReference($actor->storeUrl);
4305 0         0 $o->{ui}->line($actor->actorOnStore->publicKey->hash->hex, $o->{ui}->gray(' on ', $storeReference));
4306             }
4307              
4308 0 0       0 $o->{ui}->line($o->{ui}->gray('(none)')) if ! scalar $actorGroup->entrustedActors;
4309             }
4310             }
4311              
4312             sub onDiscoverActorGroupVerifyStore {
4313 0     0   0 my $o = shift;
4314 0         0 my $storeUrl = shift;
4315 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
4316              
4317 0         0 return $o->{actor}->storeForUrl($storeUrl);
4318             }
4319              
4320             sub onDiscoverActorGroupInvalidPublicKey {
4321 0     0   0 my $o = shift;
4322 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
4323 0         0 my $store = shift;
4324 0         0 my $reason = shift;
4325              
4326 0         0 $o->{ui}->warning('Public key ', $actorHash->hex, ' on ', $store->url, ' is invalid: ', $reason);
4327             }
4328              
4329             sub onDiscoverActorGroupInvalidCard {
4330 0     0   0 my $o = shift;
4331 0 0 0     0 my $actorOnStore = shift; die 'wrong type '.ref($actorOnStore).' for $actorOnStore' if defined $actorOnStore && ref $actorOnStore ne 'CDS::ActorOnStore';
  0         0  
4332 0 0 0     0 my $envelopeHash = shift; die 'wrong type '.ref($envelopeHash).' for $envelopeHash' if defined $envelopeHash && ref $envelopeHash ne 'CDS::Hash';
  0         0  
4333 0         0 my $reason = shift;
4334              
4335 0         0 $o->{ui}->warning('Card ', $envelopeHash->hex, ' on ', $actorOnStore->store->url, ' is invalid: ', $reason);
4336             }
4337              
4338             sub onDiscoverActorGroupStoreError {
4339 0     0   0 my $o = shift;
4340 0         0 my $store = shift;
4341 0         0 my $error = shift;
4342              
4343             }
4344              
4345             # BEGIN AUTOGENERATED
4346             package CDS::Commands::EntrustedActors;
4347              
4348             sub register {
4349 0     0   0 my $class = shift;
4350 0         0 my $cds = shift;
4351 0         0 my $help = shift;
4352              
4353 0         0 my $node000 = CDS::Parser::Node->new(0);
4354 0         0 my $node001 = CDS::Parser::Node->new(0);
4355 0         0 my $node002 = CDS::Parser::Node->new(0);
4356 0         0 my $node003 = CDS::Parser::Node->new(0);
4357 0         0 my $node004 = CDS::Parser::Node->new(0);
4358 0         0 my $node005 = CDS::Parser::Node->new(0);
4359 0         0 my $node006 = CDS::Parser::Node->new(0);
4360 0         0 my $node007 = CDS::Parser::Node->new(0);
4361 0         0 my $node008 = CDS::Parser::Node->new(0);
4362 0         0 my $node009 = CDS::Parser::Node->new(0);
4363 0         0 my $node010 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
4364 0         0 my $node011 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&show});
4365 0         0 my $node012 = CDS::Parser::Node->new(0);
4366 0         0 my $node013 = CDS::Parser::Node->new(0);
4367 0         0 my $node014 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&doNotEntrust});
4368 0         0 my $node015 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&entrust});
4369 0         0 my $node016 = CDS::Parser::Node->new(0);
4370 0         0 $cds->addArrow($node001, 1, 0, 'show');
4371 0         0 $cds->addArrow($node003, 1, 0, 'do');
4372 0         0 $cds->addArrow($node005, 1, 0, 'entrust');
4373 0         0 $help->addArrow($node000, 1, 0, 'entrusted');
4374 0         0 $node000->addArrow($node010, 1, 0, 'actors');
4375 0         0 $node001->addArrow($node002, 1, 0, 'entrusted');
4376 0         0 $node002->addArrow($node011, 1, 0, 'actors');
4377 0         0 $node003->addArrow($node004, 1, 0, 'not');
4378 0         0 $node004->addArrow($node008, 1, 0, 'entrust');
4379 0         0 $node005->addDefault($node006);
4380 0         0 $node005->addDefault($node007);
4381 0         0 $node005->addArrow($node012, 1, 0, 'ACTOR', \&collectActor);
4382 0         0 $node006->addArrow($node006, 1, 0, 'ACCOUNT', \&collectAccount);
4383 0         0 $node006->addArrow($node015, 1, 1, 'ACCOUNT', \&collectAccount);
4384 0         0 $node007->addArrow($node007, 1, 0, 'ACTOR', \&collectActor1);
4385 0         0 $node007->addArrow($node015, 1, 0, 'ACTOR', \&collectActor1);
4386 0         0 $node008->addDefault($node009);
4387 0         0 $node009->addArrow($node009, 1, 0, 'ACTOR', \&collectActor2);
4388 0         0 $node009->addArrow($node014, 1, 0, 'ACTOR', \&collectActor2);
4389 0         0 $node012->addArrow($node013, 1, 0, 'on');
4390 0         0 $node013->addArrow($node015, 1, 0, 'STORE', \&collectStore);
4391 0         0 $node015->addArrow($node016, 1, 0, 'and');
4392 0         0 $node016->addDefault($node005);
4393             }
4394              
4395             sub collectAccount {
4396 0     0   0 my $o = shift;
4397 0         0 my $label = shift;
4398 0         0 my $value = shift;
4399              
4400 0         0 push @{$o->{accountTokens}}, $value;
  0         0  
4401             }
4402              
4403             sub collectActor {
4404 0     0   0 my $o = shift;
4405 0         0 my $label = shift;
4406 0         0 my $value = shift;
4407              
4408 0         0 $o->{actorHash} = $value;
4409             }
4410              
4411             sub collectActor1 {
4412 0     0   0 my $o = shift;
4413 0         0 my $label = shift;
4414 0         0 my $value = shift;
4415              
4416 0         0 push @{$o->{accountTokens}}, CDS::AccountToken->new($o->{actor}->preferredStore, $value);
  0         0  
4417             }
4418              
4419             sub collectActor2 {
4420 0     0   0 my $o = shift;
4421 0         0 my $label = shift;
4422 0         0 my $value = shift;
4423              
4424 0         0 push @{$o->{actorHashes}}, $value;
  0         0  
4425             }
4426              
4427             sub collectStore {
4428 0     0   0 my $o = shift;
4429 0         0 my $label = shift;
4430 0         0 my $value = shift;
4431              
4432 0         0 push @{$o->{accountTokens}}, CDS::AccountToken->new($value, $o->{actorHash});
  0         0  
4433 0         0 delete $o->{actorHash};
4434             }
4435              
4436             sub new {
4437 0     0   0 my $class = shift;
4438 0         0 my $actor = shift;
4439 0         0 bless {actor => $actor, ui => $actor->ui} }
4440              
4441             # END AUTOGENERATED
4442              
4443             # HTML FOLDER NAME entrusted-actors
4444             # HTML TITLE Entrusted actors
4445             sub help {
4446 0     0   0 my $o = shift;
4447 0         0 my $cmd = shift;
4448              
4449 0         0 my $ui = $o->{ui};
4450 0         0 $ui->space;
4451 0         0 $ui->command('cds show entrusted actors');
4452 0         0 $ui->p('Shows all entrusted actors.');
4453 0         0 $ui->space;
4454 0         0 $ui->command('cds entrust ACCOUNT*');
4455 0         0 $ui->command('cds entrust ACTOR on STORE');
4456 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.');
4457 0         0 $ui->space;
4458 0         0 $ui->command('cds do not entrust ACTOR*');
4459 0         0 $ui->p('Removes the indicated entrusted actors.');
4460 0         0 $ui->space;
4461 0         0 $ui->p('After modifying the entrusted actors, you should "cds announce" yourself to publish the changes.');
4462 0         0 $ui->space;
4463             }
4464              
4465             sub show {
4466 0     0   0 my $o = shift;
4467 0         0 my $cmd = shift;
4468              
4469 0         0 my $builder = CDS::ActorGroupBuilder->new;
4470 0         0 $builder->parseEntrustedActorList($o->{actor}->entrustedActorsSelector->record, 1);
4471              
4472 0         0 my @actors = $builder->entrustedActors;
4473 0         0 for my $actor (@actors) {
4474 0         0 my $storeReference = $o->{actor}->storeUrlReference($actor->storeUrl);
4475 0         0 $o->{ui}->line($actor->hash->hex, $o->{ui}->gray(' on ', $storeReference));
4476             }
4477              
4478 0 0       0 return if scalar @actors;
4479 0         0 $o->{ui}->line($o->{ui}->gray('none'));
4480             }
4481              
4482             sub entrust {
4483 0     0   0 my $o = shift;
4484 0         0 my $cmd = shift;
4485              
4486 0         0 $o->{accountTokens} = [];
4487 0         0 $cmd->collect($o);
4488              
4489             # Get the list of currently entrusted actors
4490 0         0 my $entrusted = $o->createEntrustedActorsIndex;
4491              
4492             # Add new actors
4493 0         0 for my $accountToken (@{$o->{accountTokens}}) {
  0         0  
4494 0         0 my $actorHash = $accountToken->actorHash;
4495              
4496             # Check if the key is already entrusted
4497 0 0       0 if ($entrusted->{$accountToken->url}) {
4498 0         0 $o->{ui}->pOrange($accountToken->url, ' is already entrusted.');
4499 0         0 next;
4500             }
4501              
4502             # Get the public key
4503 0         0 my ($publicKey, $invalidReason, $storeError) = $o->{actor}->keyPair->getPublicKey($actorHash, $accountToken->cliStore);
4504 0 0       0 if (defined $storeError) {
4505 0         0 $o->{ui}->pRed('Unable to get the public key ', $actorHash->hex, ' from ', $accountToken->cliStore->url, ': ', $storeError);
4506 0         0 next;
4507             }
4508              
4509 0 0       0 if (defined $invalidReason) {
4510 0         0 $o->{ui}->pRed('Unable to get the public key ', $actorHash->hex, ' from ', $accountToken->cliStore->url, ': ', $invalidReason);
4511 0         0 next;
4512             }
4513              
4514             # Add it
4515 0         0 $o->{actor}->entrust($accountToken->cliStore->url, $publicKey);
4516 0 0       0 $o->{ui}->pGreen($entrusted->{$actorHash->hex} ? 'Updated ' : 'Added ', $actorHash->hex, ' as entrusted actor.');
4517             }
4518              
4519             # Save
4520 0         0 $o->{actor}->saveOrShowError;
4521             }
4522              
4523             sub doNotEntrust {
4524 0     0   0 my $o = shift;
4525 0         0 my $cmd = shift;
4526              
4527 0         0 $o->{actorHashes} = [];
4528 0         0 $cmd->collect($o);
4529              
4530             # Get the list of currently entrusted actors
4531 0         0 my $entrusted = $o->createEntrustedActorsIndex;
4532              
4533             # Remove entrusted actors
4534 0         0 for my $actorHash (@{$o->{actorHashes}}) {
  0         0  
4535 0 0       0 if ($entrusted->{$actorHash->hex}) {
4536 0         0 $o->{actor}->doNotEntrust($actorHash);
4537 0         0 $o->{ui}->pGreen('Removed ', $actorHash->hex, ' from the list of entrusted actors.');
4538             } else {
4539 0         0 $o->{ui}->pOrange($actorHash->hex, ' is not entrusted.');
4540             }
4541             }
4542              
4543             # Save
4544 0         0 $o->{actor}->saveOrShowError;
4545             }
4546              
4547             sub createEntrustedActorsIndex {
4548 0     0   0 my $o = shift;
4549              
4550 0         0 my $builder = CDS::ActorGroupBuilder->new;
4551 0         0 $builder->parseEntrustedActorList($o->{actor}->entrustedActorsSelector->record, 1);
4552              
4553 0         0 my $index = {};
4554 0         0 for my $actor ($builder->entrustedActors) {
4555 0         0 my $url = $actor->storeUrl.'/accounts/'.$actor->hash->hex;
4556 0         0 $index->{$actor->hash->hex} = 1;
4557 0         0 $index->{$url} = 1;
4558             }
4559              
4560 0         0 return $index;
4561             }
4562              
4563             package CDS::Commands::FolderStore;
4564              
4565             # BEGIN AUTOGENERATED
4566              
4567             sub register {
4568 0     0   0 my $class = shift;
4569 0         0 my $cds = shift;
4570 0         0 my $help = shift;
4571              
4572 0         0 my $node000 = CDS::Parser::Node->new(0);
4573 0         0 my $node001 = CDS::Parser::Node->new(0);
4574 0         0 my $node002 = CDS::Parser::Node->new(0);
4575 0         0 my $node003 = CDS::Parser::Node->new(0);
4576 0         0 my $node004 = CDS::Parser::Node->new(0);
4577 0         0 my $node005 = CDS::Parser::Node->new(0);
4578 0         0 my $node006 = CDS::Parser::Node->new(0);
4579 0         0 my $node007 = CDS::Parser::Node->new(0);
4580 0         0 my $node008 = CDS::Parser::Node->new(0);
4581 0         0 my $node009 = CDS::Parser::Node->new(0);
4582 0         0 my $node010 = CDS::Parser::Node->new(0);
4583 0         0 my $node011 = CDS::Parser::Node->new(0);
4584 0         0 my $node012 = CDS::Parser::Node->new(0);
4585 0         0 my $node013 = CDS::Parser::Node->new(0);
4586 0         0 my $node014 = CDS::Parser::Node->new(0);
4587 0         0 my $node015 = CDS::Parser::Node->new(0);
4588 0         0 my $node016 = CDS::Parser::Node->new(0);
4589 0         0 my $node017 = CDS::Parser::Node->new(0);
4590 0         0 my $node018 = CDS::Parser::Node->new(0);
4591 0         0 my $node019 = CDS::Parser::Node->new(0);
4592 0         0 my $node020 = CDS::Parser::Node->new(0);
4593 0         0 my $node021 = CDS::Parser::Node->new(0);
4594 0         0 my $node022 = CDS::Parser::Node->new(0);
4595 0         0 my $node023 = CDS::Parser::Node->new(0);
4596 0         0 my $node024 = CDS::Parser::Node->new(0);
4597 0         0 my $node025 = CDS::Parser::Node->new(1);
4598 0         0 my $node026 = CDS::Parser::Node->new(0);
4599 0         0 my $node027 = CDS::Parser::Node->new(0);
4600 0         0 my $node028 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
4601 0         0 my $node029 = CDS::Parser::Node->new(1);
4602 0         0 my $node030 = CDS::Parser::Node->new(0);
4603 0         0 my $node031 = CDS::Parser::Node->new(0);
4604 0         0 my $node032 = CDS::Parser::Node->new(0);
4605 0         0 my $node033 = CDS::Parser::Node->new(0);
4606 0         0 my $node034 = CDS::Parser::Node->new(0);
4607 0         0 my $node035 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&checkPermissions});
4608 0         0 my $node036 = CDS::Parser::Node->new(0);
4609 0         0 my $node037 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&fixPermissions});
4610 0         0 my $node038 = CDS::Parser::Node->new(0);
4611 0         0 my $node039 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showPermissions});
4612 0         0 my $node040 = CDS::Parser::Node->new(0);
4613 0         0 my $node041 = CDS::Parser::Node->new(1);
4614 0         0 my $node042 = CDS::Parser::Node->new(0);
4615 0         0 my $node043 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&addAccount});
4616 0         0 my $node044 = CDS::Parser::Node->new(0);
4617 0         0 my $node045 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&removeAccount});
4618 0         0 my $node046 = CDS::Parser::Node->new(0);
4619 0         0 my $node047 = CDS::Parser::Node->new(1);
4620 0         0 my $node048 = CDS::Parser::Node->new(0);
4621 0         0 my $node049 = CDS::Parser::Node->new(0);
4622 0         0 my $node050 = CDS::Parser::Node->new(0);
4623 0         0 my $node051 = CDS::Parser::Node->new(0);
4624 0         0 my $node052 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&checkPermissions});
4625 0         0 my $node053 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&fixPermissions});
4626 0         0 my $node054 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showPermissions});
4627 0         0 my $node055 = CDS::Parser::Node->new(1);
4628 0         0 my $node056 = CDS::Parser::Node->new(0);
4629 0         0 my $node057 = CDS::Parser::Node->new(0);
4630 0         0 my $node058 = CDS::Parser::Node->new(0);
4631 0         0 my $node059 = CDS::Parser::Node->new(0);
4632 0         0 my $node060 = CDS::Parser::Node->new(0);
4633 0         0 my $node061 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&addAccount});
4634 0         0 my $node062 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&removeAccount});
4635 0         0 my $node063 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&setPermissions});
4636 0         0 my $node064 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&createStore});
4637 0         0 $cds->addArrow($node001, 1, 0, 'create');
4638 0         0 $cds->addArrow($node003, 1, 0, 'check');
4639 0         0 $cds->addArrow($node004, 1, 0, 'fix');
4640 0         0 $cds->addArrow($node005, 1, 0, 'show');
4641 0         0 $cds->addArrow($node007, 1, 0, 'set');
4642 0         0 $cds->addArrow($node009, 1, 0, 'add');
4643 0         0 $cds->addArrow($node010, 1, 0, 'add');
4644 0         0 $cds->addArrow($node011, 1, 0, 'add');
4645 0         0 $cds->addArrow($node012, 1, 0, 'add');
4646 0         0 $cds->addArrow($node013, 1, 0, 'add');
4647 0         0 $cds->addArrow($node023, 1, 0, 'remove');
4648 0         0 $help->addArrow($node000, 1, 0, 'create');
4649 0         0 $node000->addArrow($node028, 1, 0, 'store');
4650 0         0 $node001->addArrow($node002, 1, 0, 'store');
4651 0         0 $node002->addArrow($node029, 1, 0, 'FOLDERNAME', \&collectFoldername);
4652 0         0 $node003->addArrow($node035, 1, 0, 'permissions');
4653 0         0 $node004->addArrow($node037, 1, 0, 'permissions');
4654 0         0 $node005->addArrow($node006, 1, 0, 'permission');
4655 0         0 $node006->addArrow($node039, 1, 0, 'scheme');
4656 0         0 $node007->addArrow($node008, 1, 0, 'permission');
4657 0         0 $node008->addArrow($node041, 1, 0, 'scheme');
4658 0         0 $node009->addArrow($node014, 1, 0, 'account');
4659 0         0 $node010->addArrow($node015, 1, 0, 'account');
4660 0         0 $node011->addArrow($node016, 1, 0, 'account');
4661 0         0 $node012->addArrow($node017, 1, 0, 'account');
4662 0         0 $node013->addArrow($node018, 1, 0, 'account');
4663 0         0 $node014->addArrow($node019, 1, 0, 'for');
4664 0         0 $node015->addArrow($node020, 1, 0, 'for');
4665 0         0 $node016->addArrow($node021, 1, 0, 'for');
4666 0         0 $node017->addArrow($node043, 1, 1, 'ACCOUNT', \&collectAccount);
4667 0         0 $node018->addArrow($node022, 1, 0, 'for');
4668 0         0 $node019->addArrow($node043, 1, 0, 'OBJECTFILE', \&collectObjectfile);
4669 0         0 $node020->addArrow($node043, 1, 0, 'KEYPAIR', \&collectKeypair);
4670 0         0 $node021->addArrow($node025, 1, 0, 'ACTOR', \&collectActor);
4671 0         0 $node022->addArrow($node043, 1, 0, 'OBJECT', \&collectObject);
4672 0         0 $node023->addArrow($node024, 1, 0, 'account');
4673 0         0 $node024->addArrow($node045, 1, 0, 'HASH', \&collectHash);
4674 0         0 $node025->addArrow($node026, 1, 0, 'on');
4675 0         0 $node025->addArrow($node027, 0, 0, 'from');
4676 0         0 $node026->addArrow($node043, 1, 0, 'STORE', \&collectStore);
4677 0         0 $node027->addArrow($node043, 0, 0, 'STORE', \&collectStore);
4678 0         0 $node029->addArrow($node030, 1, 0, 'for');
4679 0         0 $node029->addArrow($node031, 1, 0, 'for');
4680 0         0 $node029->addArrow($node032, 1, 0, 'for');
4681 0         0 $node029->addDefault($node047);
4682 0         0 $node030->addArrow($node033, 1, 0, 'user');
4683 0         0 $node031->addArrow($node034, 1, 0, 'group');
4684 0         0 $node032->addArrow($node047, 1, 0, 'everybody', \&collectEverybody);
4685 0         0 $node033->addArrow($node047, 1, 0, 'USER', \&collectUser);
4686 0         0 $node034->addArrow($node047, 1, 0, 'GROUP', \&collectGroup);
4687 0         0 $node035->addArrow($node036, 1, 0, 'of');
4688 0         0 $node036->addArrow($node052, 1, 0, 'STORE', \&collectStore1);
4689 0         0 $node037->addArrow($node038, 1, 0, 'of');
4690 0         0 $node038->addArrow($node053, 1, 0, 'STORE', \&collectStore1);
4691 0         0 $node039->addArrow($node040, 1, 0, 'of');
4692 0         0 $node040->addArrow($node054, 1, 0, 'STORE', \&collectStore1);
4693 0         0 $node041->addArrow($node042, 1, 0, 'of');
4694 0         0 $node041->addDefault($node055);
4695 0         0 $node042->addArrow($node055, 1, 0, 'STORE', \&collectStore1);
4696 0         0 $node043->addArrow($node044, 1, 0, 'to');
4697 0         0 $node044->addArrow($node061, 1, 0, 'STORE', \&collectStore1);
4698 0         0 $node045->addArrow($node046, 1, 0, 'from');
4699 0         0 $node046->addArrow($node062, 1, 0, 'STORE', \&collectStore1);
4700 0         0 $node047->addArrow($node048, 1, 0, 'and');
4701 0         0 $node047->addDefault($node064);
4702 0         0 $node048->addArrow($node049, 1, 0, 'remember');
4703 0         0 $node049->addArrow($node050, 1, 0, 'it');
4704 0         0 $node050->addArrow($node051, 1, 0, 'as');
4705 0         0 $node051->addArrow($node064, 1, 0, 'TEXT', \&collectText);
4706 0         0 $node055->addArrow($node056, 1, 0, 'to');
4707 0         0 $node055->addArrow($node057, 1, 0, 'to');
4708 0         0 $node055->addArrow($node058, 1, 0, 'to');
4709 0         0 $node056->addArrow($node059, 1, 0, 'user');
4710 0         0 $node057->addArrow($node060, 1, 0, 'group');
4711 0         0 $node058->addArrow($node063, 1, 0, 'everybody', \&collectEverybody);
4712 0         0 $node059->addArrow($node063, 1, 0, 'USER', \&collectUser);
4713 0         0 $node060->addArrow($node063, 1, 0, 'GROUP', \&collectGroup);
4714             }
4715              
4716             sub collectAccount {
4717 0     0   0 my $o = shift;
4718 0         0 my $label = shift;
4719 0         0 my $value = shift;
4720              
4721 0         0 $o->{accountToken} = $value;
4722             }
4723              
4724             sub collectActor {
4725 0     0   0 my $o = shift;
4726 0         0 my $label = shift;
4727 0         0 my $value = shift;
4728              
4729 0         0 $o->{actorHash} = $value;
4730             }
4731              
4732             sub collectEverybody {
4733 0     0   0 my $o = shift;
4734 0         0 my $label = shift;
4735 0         0 my $value = shift;
4736              
4737 0         0 $o->{permissions} = CDS::FolderStore::PosixPermissions::World->new;
4738             }
4739              
4740             sub collectFoldername {
4741 0     0   0 my $o = shift;
4742 0         0 my $label = shift;
4743 0         0 my $value = shift;
4744              
4745 0         0 $o->{foldername} = $value;
4746             }
4747              
4748             sub collectGroup {
4749 0     0   0 my $o = shift;
4750 0         0 my $label = shift;
4751 0         0 my $value = shift;
4752              
4753 0         0 $o->{permissions} = CDS::FolderStore::PosixPermissions::Group->new($o->{group});
4754             }
4755              
4756             sub collectHash {
4757 0     0   0 my $o = shift;
4758 0         0 my $label = shift;
4759 0         0 my $value = shift;
4760              
4761 0         0 $o->{hash} = $value;
4762             }
4763              
4764             sub collectKeypair {
4765 0     0   0 my $o = shift;
4766 0         0 my $label = shift;
4767 0         0 my $value = shift;
4768              
4769 0         0 $o->{keyPairToken} = $value;
4770             }
4771              
4772             sub collectObject {
4773 0     0   0 my $o = shift;
4774 0         0 my $label = shift;
4775 0         0 my $value = shift;
4776              
4777 0         0 $o->{accountToken} = CDS::AccountToken->new($value->cliStore, $value->hash);
4778             }
4779              
4780             sub collectObjectfile {
4781 0     0   0 my $o = shift;
4782 0         0 my $label = shift;
4783 0         0 my $value = shift;
4784              
4785 0         0 $o->{file} = $value;
4786             }
4787              
4788             sub collectStore {
4789 0     0   0 my $o = shift;
4790 0         0 my $label = shift;
4791 0         0 my $value = shift;
4792              
4793 0         0 $o->{accountToken} = CDS::AccountToken->new($value, $o->{actorHash});
4794             }
4795              
4796             sub collectStore1 {
4797 0     0   0 my $o = shift;
4798 0         0 my $label = shift;
4799 0         0 my $value = shift;
4800              
4801 0         0 $o->{store} = $value;
4802             }
4803              
4804             sub collectText {
4805 0     0   0 my $o = shift;
4806 0         0 my $label = shift;
4807 0         0 my $value = shift;
4808              
4809 0         0 $o->{label} = $value;
4810             }
4811              
4812             sub collectUser {
4813 0     0   0 my $o = shift;
4814 0         0 my $label = shift;
4815 0         0 my $value = shift;
4816              
4817 0         0 $o->{permissions} = CDS::FolderStore::PosixPermissions::User->new($value);
4818             }
4819              
4820             sub new {
4821 0     0   0 my $class = shift;
4822 0         0 my $actor = shift;
4823 0         0 bless {actor => $actor, ui => $actor->ui} }
4824              
4825             # END AUTOGENERATED
4826              
4827             # HTML FOLDER NAME folder-store
4828             # HTML TITLE Folder store management
4829             sub help {
4830 0     0   0 my $o = shift;
4831 0         0 my $cmd = shift;
4832              
4833 0         0 my $ui = $o->{ui};
4834 0         0 $ui->space;
4835 0         0 $ui->command('cds create store FOLDERNAME');
4836 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.');
4837 0         0 $ui->space;
4838 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.');
4839 0         0 $ui->space;
4840 0         0 $ui->command('… for user USER');
4841 0         0 $ui->p('Makes the store accessible to the user USER.');
4842 0         0 $ui->space;
4843 0         0 $ui->command('… for group GROUP');
4844 0         0 $ui->p('Makes the store accessible to the group GROUP.');
4845 0         0 $ui->space;
4846 0         0 $ui->command('… for everybody');
4847 0         0 $ui->p('Makes the store accessible to everybody.');
4848 0         0 $ui->space;
4849 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.');
4850 0         0 $ui->space;
4851 0         0 $ui->command('… and remember it as TEXT');
4852 0         0 $ui->p('Remembers the store under the label TEXT. See "cds help remember" for details.');
4853 0         0 $ui->space;
4854 0         0 $ui->command('cds check permissions [of STORE]');
4855 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.');
4856 0         0 $ui->p('If the store is omitted, the selected store is used.');
4857 0         0 $ui->space;
4858 0         0 $ui->command('cds fix permissions [of STORE]');
4859 0         0 $ui->p('Same as above, but tries to fix the permissions (chown, chmod) instead of just reporting them.');
4860 0         0 $ui->space;
4861 0         0 $ui->command('cds show permission scheme [of STORE]');
4862 0         0 $ui->p('Reports the permission scheme of the store.');
4863 0         0 $ui->space;
4864 0         0 $ui->command('cds set permission scheme [of STORE] to (user USER|group GROUP|everybody)');
4865 0         0 $ui->p('Sets the permission scheme of the stores, and changes all permissions accordingly.');
4866 0         0 $ui->space;
4867 0         0 $ui->command('cds add account ACCOUNT [to STORE]');
4868 0         0 $ui->command('cds add account for FILE [to STORE]');
4869 0         0 $ui->command('cds add account for KEYPAIR [to STORE]');
4870 0         0 $ui->command('cds add account for OBJECT [to STORE]');
4871 0         0 $ui->command('cds add account for ACTOR on STORE [to STORE]');
4872 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.');
4873 0         0 $ui->space;
4874 0         0 $ui->command('cds remove account HASH [from STORE]');
4875 0         0 $ui->p('Removes the indicated account from the store. This immediately destroys the user\'s data.');
4876 0         0 $ui->space;
4877             }
4878              
4879             sub createStore {
4880 0     0   0 my $o = shift;
4881 0         0 my $cmd = shift;
4882              
4883 0         0 $o->{permissions} = CDS::FolderStore::PosixPermissions::User->new;
4884 0         0 $cmd->collect($o);
4885              
4886             # Give up if the folder is non-empty (but we accept hidden files)
4887 0         0 for my $file (CDS->listFolder($o->{foldername})) {
4888 0 0       0 next if $file =~ /^\./;
4889 0         0 $o->{ui}->pRed('The folder ', $o->{foldername}, ' is not empty. Giving up …');
4890 0         0 return;
4891             }
4892              
4893             # Create the object store
4894 0   0     0 $o->create($o->{foldername}.'/objects') // return;
4895 0         0 $o->{ui}->pGreen('Object store created for ', $o->{permissions}->target, '.');
4896              
4897             # Create the account store
4898 0   0     0 $o->create($o->{foldername}.'/accounts') // return;
4899 0         0 $o->{ui}->pGreen('Account store created for ', $o->{permissions}->target, '.');
4900              
4901             # Return if the user does not want us to add the store
4902 0 0       0 return if ! defined $o->{label};
4903              
4904             # Remember the store
4905 0         0 my $record = CDS::Record->new;
4906 0         0 $record->addText('store')->addText('file://'.$o->{foldername});
4907 0         0 $o->{actor}->remember($o->{label}, $record);
4908 0         0 $o->{actor}->saveOrShowError;
4909             }
4910              
4911             # Creates a folder with the selected permissions.
4912             sub create {
4913 0     0   0 my $o = shift;
4914 0         0 my $folder = shift;
4915              
4916             # Create the folders to here if necessary
4917 0         0 for my $intermediateFolder (CDS->intermediateFolders($folder)) {
4918 0         0 mkdir $intermediateFolder, 0755;
4919             }
4920              
4921             # mkdir (if it does not exist yet) and chmod (if it does exist already)
4922 0         0 mkdir $folder, $o->{permissions}->baseFolderMode;
4923 0         0 chmod $o->{permissions}->baseFolderMode, $folder;
4924 0   0     0 chown $o->{permissions}->uid // -1, $o->{permissions}->gid // -1, $folder;
      0        
4925              
4926             # Check if the result is correct
4927 0         0 my @s = stat $folder;
4928 0 0       0 return $o->{ui}->error('Unable to create ', $o->{foldername}, '.') if ! scalar @s;
4929 0         0 my $mode = $s[2];
4930 0 0       0 return $o->{ui}->error($folder, ' exists, but is not a folder') if ! Fcntl::S_ISDIR($mode);
4931 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;
4932 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;
4933 0 0       0 return $o->{ui}->error('Unable to set the mode on ', $folder, '.') if ($mode & 0777) != $o->{permissions}->baseFolderMode;
4934 0         0 return 1;
4935             }
4936              
4937             sub existingFolderStoreOrShowError {
4938 0     0   0 my $o = shift;
4939              
4940 0   0     0 my $store = $o->{store} // $o->{actor}->preferredStore;
4941              
4942 0         0 my $folderStore = CDS::FolderStore->forUrl($store->url);
4943 0 0       0 if (! $folderStore) {
4944 0         0 $o->{ui}->error('"', $store->url, '" is not a folder store.');
4945 0         0 $o->{ui}->space;
4946 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.');
4947 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.');
4948 0         0 $o->{ui}->space;
4949 0         0 return;
4950             }
4951              
4952 0 0       0 if (! $folderStore->exists) {
4953 0         0 $o->{ui}->error('"', $folderStore->folder, '" does not exist.');
4954 0         0 $o->{ui}->space;
4955 0         0 $o->{ui}->p('The folder either does not exist, or is not a folder store. You can create this store using:');
4956 0         0 $o->{ui}->line($o->{ui}->gold(' cds create store ', $folderStore->folder));
4957 0         0 $o->{ui}->space;
4958 0         0 return;
4959             }
4960              
4961 0         0 return $folderStore;
4962             }
4963              
4964             sub showPermissions {
4965 0     0   0 my $o = shift;
4966 0         0 my $cmd = shift;
4967              
4968 0         0 $cmd->collect($o);
4969 0   0     0 my $folderStore = $o->existingFolderStoreOrShowError // return;
4970 0         0 $o->showStore($folderStore);
4971 0         0 $o->{ui}->space;
4972             }
4973              
4974             sub showStore {
4975 0     0   0 my $o = shift;
4976 0         0 my $folderStore = shift;
4977              
4978 0         0 $o->{ui}->space;
4979 0         0 $o->{ui}->title('Store');
4980 0         0 $o->{ui}->line($folderStore->folder);
4981 0         0 $o->{ui}->line('Accessible to ', $folderStore->permissions->target, '.');
4982             }
4983              
4984             sub setPermissions {
4985 0     0   0 my $o = shift;
4986 0         0 my $cmd = shift;
4987              
4988 0         0 $cmd->collect($o);
4989              
4990 0   0     0 my $folderStore = $o->existingFolderStoreOrShowError // return;
4991 0         0 $o->showStore($folderStore);
4992              
4993 0         0 $folderStore->setPermissions($o->{permissions});
4994 0         0 $o->{ui}->line('Changing permissions …');
4995 0         0 my $logger = CDS::Commands::FolderStore::SetLogger->new($o, $folderStore->folder);
4996 0 0       0 $folderStore->checkPermissions($logger) || $o->traversalFailed($folderStore);
4997 0         0 $logger->summary;
4998              
4999 0         0 $o->{ui}->space;
5000             }
5001              
5002             sub checkPermissions {
5003 0     0   0 my $o = shift;
5004 0         0 my $cmd = shift;
5005              
5006 0         0 $cmd->collect($o);
5007              
5008 0   0     0 my $folderStore = $o->existingFolderStoreOrShowError // return;
5009 0         0 $o->showStore($folderStore);
5010              
5011 0         0 $o->{ui}->line('Checking permissions …');
5012 0         0 my $logger = CDS::Commands::FolderStore::CheckLogger->new($o, $folderStore->folder);
5013 0 0       0 $folderStore->checkPermissions($logger) || $o->traversalFailed($folderStore);
5014 0         0 $logger->summary;
5015              
5016 0         0 $o->{ui}->space;
5017             }
5018              
5019             sub fixPermissions {
5020 0     0   0 my $o = shift;
5021 0         0 my $cmd = shift;
5022              
5023 0         0 $cmd->collect($o);
5024              
5025 0   0     0 my $folderStore = $o->existingFolderStoreOrShowError // return;
5026 0         0 $o->showStore($folderStore);
5027              
5028 0         0 $o->{ui}->line('Fixing permissions …');
5029 0         0 my $logger = CDS::Commands::FolderStore::FixLogger->new($o, $folderStore->folder);
5030 0 0       0 $folderStore->checkPermissions($logger) || $o->traversalFailed($folderStore);
5031 0         0 $logger->summary;
5032              
5033 0         0 $o->{ui}->space;
5034             }
5035              
5036             sub traversalFailed {
5037 0     0   0 my $o = shift;
5038 0         0 my $folderStore = shift;
5039              
5040 0         0 $o->{ui}->space;
5041 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.');
5042 0         0 $o->{ui}->p('If you have root privileges, you can take over this store using:');
5043 0         0 my $userName = getpwuid($<);
5044 0         0 my $groupName = getgrgid($();
5045 0         0 $o->{ui}->line($o->{ui}->gold(' sudo chown -R ', $userName, ':', $groupName, ' ', $folderStore->folder));
5046 0         0 $o->{ui}->p('and then set the desired permission scheme:');
5047 0         0 $o->{ui}->line($o->{ui}->gold(' cds set permissions of ', $folderStore->folder, ' to …'));
5048 0         0 $o->{ui}->space;
5049 0         0 exit(1);
5050             }
5051              
5052             sub addAccount {
5053 0     0   0 my $o = shift;
5054 0         0 my $cmd = shift;
5055              
5056 0         0 $cmd->collect($o);
5057              
5058             # Prepare
5059 0   0     0 my $folderStore = $o->existingFolderStoreOrShowError // return;
5060 0   0     0 my $publicKey = $o->publicKey // return;
5061              
5062             # Upload the public key onto the store
5063 0         0 my $error = $folderStore->put($publicKey->hash, $publicKey->object);
5064 0 0       0 return $o->{ui}->error('Unable to upload the public key: ', $error) if $error;
5065              
5066             # Create the account folder
5067 0         0 my $folder = $folderStore->folder.'/accounts/'.$publicKey->hash->hex;
5068 0         0 my $permissions = $folderStore->permissions;
5069 0         0 $permissions->mkdir($folder, $permissions->accountFolderMode);
5070 0 0       0 return $o->{ui}->error('Unable to create folder "', $folder, '".') if ! -d $folder;
5071 0         0 $o->{ui}->pGreen('Account ', $publicKey->hash->hex, ' added.');
5072 0         0 return 1;
5073             }
5074              
5075             sub publicKey {
5076 0     0   0 my $o = shift;
5077              
5078 0 0       0 return $o->{keyPairToken}->keyPair->publicKey if $o->{keyPairToken};
5079              
5080 0 0       0 if ($o->{file}) {
5081 0   0     0 my $bytes = CDS->readBytesFromFile($o->{file}) // return $o->{ui}->error('Cannot read "', $o->{file}, '".');
5082 0   0     0 my $object = CDS::Object->fromBytes($bytes) // return $o->{ui}->error('"', $o->{file}, '" is not a public key.');
5083 0   0     0 return CDS::PublicKey->fromObject($object) // return $o->{ui}->error('"', $o->{file}, '" is not a public key.');
5084             }
5085              
5086 0         0 return $o->{actor}->uiGetPublicKey($o->{accountToken}->actorHash, $o->{accountToken}->cliStore, $o->{actor}->preferredKeyPairToken);
5087             }
5088              
5089             sub removeAccount {
5090 0     0   0 my $o = shift;
5091 0         0 my $cmd = shift;
5092              
5093 0         0 $cmd->collect($o);
5094              
5095             # Prepare the folder
5096 0   0     0 my $folderStore = $o->existingFolderStoreOrShowError // return;
5097 0         0 my $folder = $folderStore->folder.'/accounts/'.$o->{hash}->hex;
5098 0         0 my $deletedFolder = $folderStore->folder.'/accounts/deleted-'.$o->{hash}->hex;
5099              
5100             # Rename, so that it is not visible any more
5101 0 0       0 $o->recursivelyDelete($deletedFolder) if -e $deletedFolder;
5102 0 0       0 return $o->{ui}->line('The account ', $o->{hash}->hex, ' does not exist.') if ! -e $folder;
5103 0 0       0 rename($folder, $deletedFolder) || return $o->{ui}->error('Unable to rename the folder "', $folder, '".');
5104              
5105             # Try to delete it entirely
5106 0         0 $o->recursivelyDelete($deletedFolder);
5107 0         0 $o->{ui}->pGreen('Account ', $o->{hash}->hex, ' removed.');
5108 0         0 return 1;
5109             }
5110              
5111             sub recursivelyDelete {
5112 0     0   0 my $o = shift;
5113 0         0 my $folder = shift;
5114              
5115 0         0 for my $filename (CDS->listFolder($folder)) {
5116 0 0       0 next if $filename =~ /^\./;
5117 0         0 my $file = $folder.'/'.$filename;
5118 0 0       0 if (-f $file) {
    0          
5119 0   0     0 unlink $file || $o->{ui}->pOrange('Unable to remove the file "', $file, '".');
5120             } elsif (-d $file) {
5121 0         0 $o->recursivelyDelete($file);
5122             }
5123             }
5124              
5125 0 0       0 rmdir($folder) || $o->{ui}->pOrange('Unable to remove the folder "', $folder, '".');
5126             }
5127              
5128             package CDS::Commands::FolderStore::CheckLogger;
5129              
5130 1     1   28461 use parent -norequire, 'CDS::Commands::FolderStore::Logger';
  1         2  
  1         9  
5131              
5132             sub finalizeWrong {
5133 0     0   0 my $o = shift;
5134              
5135 0         0 $o->{ui}->pRed(@_);
5136 0         0 return 0;
5137             }
5138              
5139             sub summary {
5140 0     0   0 my $o = shift;
5141              
5142 0         0 $o->{ui}->p(($o->{correct} + $o->{wrong}).' files and folders traversed.');
5143 0 0       0 if ($o->{wrong} > 0) {
5144 0         0 $o->{ui}->p($o->{wrong}, ' files and folders have wrong permissions. To fix them, run');
5145 0         0 $o->{ui}->line($o->{ui}->gold(' cds fix permissions of ', $o->{store}->url));
5146             } else {
5147 0         0 $o->{ui}->pGreen('All permissions are OK.');
5148             }
5149             }
5150              
5151             package CDS::Commands::FolderStore::FixLogger;
5152              
5153 1     1   219 use parent -norequire, 'CDS::Commands::FolderStore::Logger';
  1         2  
  1         4  
5154              
5155             sub finalizeWrong {
5156 0     0   0 my $o = shift;
5157              
5158 0         0 $o->{ui}->line(@_);
5159 0         0 return 1;
5160             }
5161              
5162             sub summary {
5163 0     0   0 my $o = shift;
5164              
5165 0         0 $o->{ui}->p(($o->{correct} + $o->{wrong}).' files and folders traversed.');
5166 0 0       0 $o->{ui}->p('The permissions of ', $o->{wrong}, ' files and folders have been fixed.') if $o->{wrong} > 0;
5167 0         0 $o->{ui}->pGreen('All permissions are OK.');
5168             }
5169              
5170             package CDS::Commands::FolderStore::Logger;
5171              
5172             sub new {
5173 0     0   0 my $class = shift;
5174 0         0 my $parent = shift;
5175 0         0 my $baseFolder = shift;
5176              
5177             return bless {
5178             ui => $parent->{ui},
5179             store => $parent->{store},
5180 0         0 baseFolder => $baseFolder,
5181             correct => 0,
5182             wrong => 0,
5183             }, $class;
5184             }
5185              
5186             sub correct {
5187 0     0   0 my $o = shift;
5188              
5189 0         0 $o->{correct} += 1;
5190             }
5191              
5192             sub wrong {
5193 0     0   0 my $o = shift;
5194 0         0 my $item = shift;
5195 0         0 my $uid = shift;
5196 0         0 my $gid = shift;
5197 0         0 my $mode = shift;
5198 0         0 my $expectedUid = shift;
5199 0         0 my $expectedGid = shift;
5200 0         0 my $expectedMode = shift;
5201              
5202 0         0 my $len = length $o->{baseFolder};
5203 0         0 $o->{wrong} += 1;
5204 0 0 0     0 $item = '…'.substr($item, $len) if length $item > $len && substr($item, 0, $len) eq $o->{baseFolder};
5205 0         0 my @changes;
5206 0 0 0     0 push @changes, 'user '.&username($uid).' -> '.&username($expectedUid) if defined $expectedUid && $uid != $expectedUid;
5207 0 0 0     0 push @changes, 'group '.&groupname($gid).' -> '.&groupname($expectedGid) if defined $expectedGid && $gid != $expectedGid;
5208 0 0       0 push @changes, 'mode '.sprintf('%04o -> %04o', $mode, $expectedMode) if $mode != $expectedMode;
5209 0         0 return $o->finalizeWrong(join(', ', @changes), "\t", $item);
5210             }
5211              
5212             sub username {
5213 0     0   0 my $uid = shift;
5214              
5215 0   0     0 return getpwuid($uid) // $uid;
5216             }
5217              
5218             sub groupname {
5219 0     0   0 my $gid = shift;
5220              
5221 0   0     0 return getgrgid($gid) // $gid;
5222             }
5223              
5224             sub accessError {
5225 0     0   0 my $o = shift;
5226 0         0 my $item = shift;
5227              
5228 0         0 $o->{ui}->error('Error accessing ', $item, '.');
5229 0         0 return 0;
5230             }
5231              
5232             sub setError {
5233 0     0   0 my $o = shift;
5234 0         0 my $item = shift;
5235              
5236 0         0 $o->{ui}->error('Error setting permissions of ', $item, '.');
5237 0         0 return 0;
5238             }
5239              
5240             package CDS::Commands::FolderStore::SetLogger;
5241              
5242 1     1   645 use parent -norequire, 'CDS::Commands::FolderStore::Logger';
  1         4  
  1         6  
5243              
5244             sub finalizeWrong {
5245 0     0   0 my $o = shift;
5246              
5247 0         0 return 1;
5248             }
5249              
5250             sub summary {
5251 0     0   0 my $o = shift;
5252              
5253 0         0 $o->{ui}->p(($o->{correct} + $o->{wrong}).' files and folders traversed.');
5254 0 0       0 $o->{ui}->p('The permissions of ', $o->{wrong}, ' files and folders have been adjusted.') if $o->{wrong} > 0;
5255 0         0 $o->{ui}->pGreen('All permissions are OK.');
5256             }
5257              
5258             # BEGIN AUTOGENERATED
5259             package CDS::Commands::Get;
5260              
5261             sub register {
5262 0     0   0 my $class = shift;
5263 0         0 my $cds = shift;
5264 0         0 my $help = shift;
5265              
5266 0         0 my $node000 = CDS::Parser::Node->new(0);
5267 0         0 my $node001 = CDS::Parser::Node->new(0);
5268 0         0 my $node002 = CDS::Parser::Node->new(0);
5269 0         0 my $node003 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
5270 0         0 my $node004 = CDS::Parser::Node->new(0);
5271 0         0 my $node005 = CDS::Parser::Node->new(0);
5272 0         0 my $node006 = CDS::Parser::Node->new(0);
5273 0         0 my $node007 = CDS::Parser::Node->new(0);
5274 0         0 my $node008 = CDS::Parser::Node->new(0);
5275 0         0 my $node009 = CDS::Parser::Node->new(0);
5276 0         0 my $node010 = CDS::Parser::Node->new(0);
5277 0         0 my $node011 = CDS::Parser::Node->new(0);
5278 0         0 my $node012 = CDS::Parser::Node->new(1);
5279 0         0 my $node013 = CDS::Parser::Node->new(0);
5280 0         0 my $node014 = CDS::Parser::Node->new(0);
5281 0         0 my $node015 = CDS::Parser::Node->new(1);
5282 0         0 my $node016 = CDS::Parser::Node->new(0);
5283 0         0 my $node017 = CDS::Parser::Node->new(0);
5284 0         0 my $node018 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&get});
5285 0         0 my $node019 = CDS::Parser::Node->new(1);
5286 0         0 my $node020 = CDS::Parser::Node->new(0);
5287 0         0 my $node021 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&get});
5288 0         0 $cds->addArrow($node000, 1, 0, 'save');
5289 0         0 $cds->addArrow($node001, 1, 0, 'hex');
5290 0         0 $cds->addArrow($node004, 1, 0, 'get');
5291 0         0 $cds->addArrow($node005, 1, 0, 'save', \&collectSave);
5292 0         0 $help->addArrow($node003, 1, 0, 'get');
5293 0         0 $help->addArrow($node003, 1, 0, 'save');
5294 0         0 $node000->addArrow($node002, 1, 0, 'data');
5295 0         0 $node001->addArrow($node004, 1, 0, 'dump', \&collectDump);
5296 0         0 $node002->addArrow($node005, 1, 0, 'of', \&collectOf);
5297 0         0 $node004->addArrow($node006, 1, 0, 'HASH', \&collectHash);
5298 0         0 $node004->addArrow($node012, 1, 0, 'HASH', \&collectHash1);
5299 0         0 $node004->addArrow($node012, 1, 0, 'OBJECT', \&collectObject);
5300 0         0 $node005->addArrow($node009, 1, 0, 'HASH', \&collectHash);
5301 0         0 $node005->addArrow($node015, 1, 0, 'HASH', \&collectHash1);
5302 0         0 $node005->addArrow($node015, 1, 0, 'OBJECT', \&collectObject1);
5303 0         0 $node006->addArrow($node007, 1, 0, 'on');
5304 0         0 $node006->addArrow($node008, 0, 0, 'from');
5305 0         0 $node007->addArrow($node012, 1, 0, 'STORE', \&collectStore);
5306 0         0 $node008->addArrow($node012, 0, 0, 'STORE', \&collectStore);
5307 0         0 $node009->addArrow($node010, 1, 0, 'on');
5308 0         0 $node009->addArrow($node011, 0, 0, 'from');
5309 0         0 $node010->addArrow($node015, 1, 0, 'STORE', \&collectStore);
5310 0         0 $node011->addArrow($node015, 0, 0, 'STORE', \&collectStore);
5311 0         0 $node012->addArrow($node013, 1, 0, 'decrypted');
5312 0         0 $node012->addDefault($node018);
5313 0         0 $node013->addArrow($node014, 1, 0, 'with');
5314 0         0 $node014->addArrow($node018, 1, 0, 'AESKEY', \&collectAeskey);
5315 0         0 $node015->addArrow($node016, 1, 0, 'decrypted');
5316 0         0 $node015->addDefault($node019);
5317 0         0 $node016->addArrow($node017, 1, 0, 'with');
5318 0         0 $node017->addArrow($node019, 1, 0, 'AESKEY', \&collectAeskey);
5319 0         0 $node019->addArrow($node020, 1, 0, 'as');
5320 0         0 $node020->addArrow($node021, 1, 0, 'FILENAME', \&collectFilename);
5321             }
5322              
5323             sub collectAeskey {
5324 0     0   0 my $o = shift;
5325 0         0 my $label = shift;
5326 0         0 my $value = shift;
5327              
5328 0         0 $o->{aesKey} = $value;
5329             }
5330              
5331             sub collectDump {
5332 0     0   0 my $o = shift;
5333 0         0 my $label = shift;
5334 0         0 my $value = shift;
5335              
5336 0         0 $o->{hexDump} = 1;
5337             }
5338              
5339             sub collectFilename {
5340 0     0   0 my $o = shift;
5341 0         0 my $label = shift;
5342 0         0 my $value = shift;
5343              
5344 0         0 $o->{filename} = $value;
5345             }
5346              
5347             sub collectHash {
5348 0     0   0 my $o = shift;
5349 0         0 my $label = shift;
5350 0         0 my $value = shift;
5351              
5352 0         0 $o->{hash} = $value;
5353             }
5354              
5355             sub collectHash1 {
5356 0     0   0 my $o = shift;
5357 0         0 my $label = shift;
5358 0         0 my $value = shift;
5359              
5360 0         0 $o->{hash} = $value;
5361 0         0 $o->{store} = $o->{actor}->preferredStore;
5362             }
5363              
5364             sub collectObject {
5365 0     0   0 my $o = shift;
5366 0         0 my $label = shift;
5367 0         0 my $value = shift;
5368              
5369 0         0 $o->{hash} = $value->hash;
5370 0         0 $o->{store} = $value->cliStore;
5371             }
5372              
5373             sub collectObject1 {
5374 0     0   0 my $o = shift;
5375 0         0 my $label = shift;
5376 0         0 my $value = shift;
5377              
5378 0         0 $o->{hash} = $value->hash;
5379 0         0 push @{$o->{stores}}, $value->store;
  0         0  
5380             }
5381              
5382             sub collectOf {
5383 0     0   0 my $o = shift;
5384 0         0 my $label = shift;
5385 0         0 my $value = shift;
5386              
5387 0         0 $o->{saveData} = 1;
5388             }
5389              
5390             sub collectSave {
5391 0     0   0 my $o = shift;
5392 0         0 my $label = shift;
5393 0         0 my $value = shift;
5394              
5395 0         0 $o->{saveObject} = 1;
5396             }
5397              
5398             sub collectStore {
5399 0     0   0 my $o = shift;
5400 0         0 my $label = shift;
5401 0         0 my $value = shift;
5402              
5403 0         0 $o->{store} = $value;
5404             }
5405              
5406             sub new {
5407 0     0   0 my $class = shift;
5408 0         0 my $actor = shift;
5409 0         0 bless {actor => $actor, ui => $actor->ui} }
5410              
5411             # END AUTOGENERATED
5412              
5413             # HTML FOLDER NAME store-get
5414             # HTML TITLE Get
5415             sub help {
5416 0     0   0 my $o = shift;
5417 0         0 my $cmd = shift;
5418              
5419 0         0 my $ui = $o->{ui};
5420 0         0 $ui->space;
5421 0         0 $ui->command('cds get OBJECT');
5422 0         0 $ui->command('cds get HASH on STORE');
5423 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.');
5424 0         0 $ui->space;
5425 0         0 $ui->command('cds get HASH');
5426 0         0 $ui->p('As above, but uses the selected store.');
5427 0         0 $ui->space;
5428 0         0 $ui->command('… decrypted with AESKEY');
5429 0         0 $ui->p('Decrypts the object after retrieval.');
5430 0         0 $ui->space;
5431 0         0 $ui->command('cds save … as FILENAME');
5432 0         0 $ui->p('Saves the object to FILENAME instead of writing it to STDOUT.');
5433 0         0 $ui->space;
5434 0         0 $ui->command('cds save data of … as FILENAME');
5435 0         0 $ui->p('Saves the object\'s data to FILENAME.');
5436 0         0 $ui->space;
5437 0         0 $ui->command('cds hex dump …');
5438 0         0 $ui->p('Writes the object as hex string to STDOUT.');
5439 0         0 $ui->space;
5440 0         0 $ui->title('Related commands');
5441 0         0 $ui->line('cds open envelope OBJECT');
5442 0         0 $ui->line('cds show record OBJECT [decrypted with AESKEY]');
5443 0         0 $ui->line('cds show hashes of OBJECT');
5444 0         0 $ui->space;
5445             }
5446              
5447             sub get {
5448 0     0   0 my $o = shift;
5449 0         0 my $cmd = shift;
5450              
5451 0         0 $cmd->collect($o);
5452              
5453             # Retrieve the object
5454 0   0     0 my $object = $o->{actor}->uiGetObject($o->{hash}, $o->{store}, $o->{actor}->preferredKeyPairToken) // return;
5455              
5456             # Decrypt
5457 0 0       0 $object = $object->crypt($o->{aesKey}) if defined $o->{aesKey};
5458              
5459             # Output
5460 0 0       0 if ($o->{saveData}) {
    0          
    0          
5461 0   0     0 CDS->writeBytesToFile($o->{filename}, $object->data) // return $o->{ui}->error('Failed to write data to "', $o->{filename}, '".');
5462 0         0 $o->{ui}->pGreen(length $object->data, ' bytes written to ', $o->{filename}, '.');
5463             } elsif ($o->{saveObject}) {
5464 0   0     0 CDS->writeBytesToFile($o->{filename}, $object->bytes) // return $o->{ui}->error('Failed to write object to "', $o->{filename}, '".');
5465 0         0 $o->{ui}->pGreen(length $object->bytes, ' bytes written to ', $o->{filename}, '.');
5466             } elsif ($o->{hexDump}) {
5467 0         0 $o->{ui}->raw(unpack('H*', $object->bytes)."\n");
5468             } else {
5469 0         0 $o->{ui}->raw($object->bytes);
5470             }
5471             }
5472              
5473             # BEGIN AUTOGENERATED
5474             package CDS::Commands::Help;
5475              
5476             sub register {
5477 0     0   0 my $class = shift;
5478 0         0 my $cds = shift;
5479 0         0 my $help = shift;
5480              
5481 0         0 my $node000 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
5482 0         0 my $node001 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&version});
5483 0         0 $cds->addArrow($node000, 0, 0, '--h');
5484 0         0 $cds->addArrow($node000, 0, 0, '--help');
5485 0         0 $cds->addArrow($node000, 0, 0, '-?');
5486 0         0 $cds->addArrow($node000, 0, 0, '-h');
5487 0         0 $cds->addArrow($node000, 0, 0, '-help');
5488 0         0 $cds->addArrow($node000, 0, 0, '/?');
5489 0         0 $cds->addArrow($node000, 0, 0, '/h');
5490 0         0 $cds->addArrow($node000, 0, 0, '/help');
5491 0         0 $cds->addArrow($node001, 0, 0, '--version');
5492 0         0 $cds->addArrow($node001, 0, 0, '-version');
5493 0         0 $cds->addArrow($node001, 1, 0, 'version');
5494             }
5495              
5496             sub new {
5497 0     0   0 my $class = shift;
5498 0         0 my $actor = shift;
5499 0         0 bless {actor => $actor, ui => $actor->ui} }
5500              
5501             # END AUTOGENERATED
5502              
5503             # HTML IGNORE
5504             sub help {
5505 0     0   0 my $o = shift;
5506 0         0 my $cmd = shift;
5507              
5508 0         0 my $ui = $o->{ui};
5509 0         0 $ui->space;
5510 0         0 $ui->title('Condensation CLI');
5511 0         0 $ui->line('Version ', $CDS::VERSION, ', ', $CDS::releaseDate, ', implementing the Condensation 1 protocol');
5512 0         0 $ui->space;
5513 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'), '.');
5514 0         0 $ui->space;
5515 0         0 $ui->p('The command line interface (CLI) understands english-like queries like these:');
5516 0         0 $ui->pushIndent;
5517 0         0 $ui->line($ui->blue('cds show key pair'));
5518 0         0 $ui->line($ui->blue('cds create key pair thomas'));
5519 0         0 $ui->line($ui->blue('cds get 45db86549d6d2af3a45be834f2cb0e08cdbbd7699624e7bfd947a3505e6b03e5 \\'));
5520 0         0 $ui->line($ui->blue(' and decrypt with 8b8b091bbe577d5e8d38eae9cd327aa8123fe402a41ea9dd16d86f42fb70cf7e'));
5521 0         0 $ui->popIndent;
5522 0         0 $ui->space;
5523 0         0 $ui->p('If you don\'t know how to continue a command, simply put a ? to see all valid options:');
5524 0         0 $ui->pushIndent;
5525 0         0 $ui->line($ui->blue('cds ?'));
5526 0         0 $ui->line($ui->blue('cds show ?'));
5527 0         0 $ui->popIndent;
5528 0         0 $ui->space;
5529 0         0 $ui->p('To see a list of help topics, type');
5530 0         0 $ui->pushIndent;
5531 0         0 $ui->line($ui->blue('cds help ?'));
5532 0         0 $ui->popIndent;
5533 0         0 $ui->space;
5534             }
5535              
5536             sub version {
5537 0     0   0 my $o = shift;
5538 0         0 my $cmd = shift;
5539              
5540 0         0 my $ui = $o->{ui};
5541 0         0 $ui->line('Condensation CLI ', $CDS::VERSION, ', ', $CDS::releaseDate);
5542 0         0 $ui->line('implementing the Condensation 1 protocol');
5543             }
5544              
5545             # BEGIN AUTOGENERATED
5546             package CDS::Commands::List;
5547              
5548             sub register {
5549 0     0   0 my $class = shift;
5550 0         0 my $cds = shift;
5551 0         0 my $help = shift;
5552              
5553 0         0 my $node000 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
5554 0         0 my $node001 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&list});
5555 0         0 my $node002 = CDS::Parser::Node->new(0);
5556 0         0 my $node003 = CDS::Parser::Node->new(0);
5557 0         0 my $node004 = CDS::Parser::Node->new(0);
5558 0         0 my $node005 = CDS::Parser::Node->new(0);
5559 0         0 my $node006 = CDS::Parser::Node->new(0);
5560 0         0 my $node007 = CDS::Parser::Node->new(0);
5561 0         0 my $node008 = CDS::Parser::Node->new(0);
5562 0         0 my $node009 = CDS::Parser::Node->new(0);
5563 0         0 my $node010 = CDS::Parser::Node->new(0);
5564 0         0 my $node011 = CDS::Parser::Node->new(0);
5565 0         0 my $node012 = CDS::Parser::Node->new(0);
5566 0         0 my $node013 = CDS::Parser::Node->new(0);
5567 0         0 my $node014 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&listBoxes});
5568 0         0 my $node015 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&list});
5569 0         0 $cds->addArrow($node001, 1, 0, 'list');
5570 0         0 $cds->addArrow($node001, 1, 0, 'watch', \&collectWatch);
5571 0         0 $help->addArrow($node000, 1, 0, 'list');
5572 0         0 $node001->addDefault($node002);
5573 0         0 $node001->addArrow($node003, 1, 0, 'message');
5574 0         0 $node001->addArrow($node004, 1, 0, 'private');
5575 0         0 $node001->addArrow($node005, 1, 0, 'public');
5576 0         0 $node001->addArrow($node006, 0, 0, 'messages', \&collectMessages);
5577 0         0 $node001->addArrow($node006, 0, 0, 'private', \&collectPrivate);
5578 0         0 $node001->addArrow($node006, 0, 0, 'public', \&collectPublic);
5579 0         0 $node001->addArrow($node007, 1, 0, 'my', \&collectMy);
5580 0         0 $node001->addDefault($node011);
5581 0         0 $node002->addArrow($node002, 1, 0, 'BOX', \&collectBox);
5582 0         0 $node002->addArrow($node014, 1, 0, 'BOX', \&collectBox);
5583 0         0 $node003->addArrow($node006, 1, 0, 'box', \&collectMessages);
5584 0         0 $node004->addArrow($node006, 1, 0, 'box', \&collectPrivate);
5585 0         0 $node005->addArrow($node006, 1, 0, 'box', \&collectPublic);
5586 0         0 $node006->addArrow($node011, 1, 0, 'of');
5587 0         0 $node006->addDefault($node012);
5588 0         0 $node007->addArrow($node008, 1, 0, 'message');
5589 0         0 $node007->addArrow($node009, 1, 0, 'private');
5590 0         0 $node007->addArrow($node010, 1, 0, 'public');
5591 0         0 $node007->addArrow($node015, 1, 0, 'boxes');
5592 0         0 $node007->addArrow($node015, 0, 0, 'messages', \&collectMessages);
5593 0         0 $node007->addArrow($node015, 0, 0, 'private', \&collectPrivate);
5594 0         0 $node007->addArrow($node015, 0, 0, 'public', \&collectPublic);
5595 0         0 $node008->addArrow($node015, 1, 0, 'box', \&collectMessages);
5596 0         0 $node009->addArrow($node015, 1, 0, 'box', \&collectPrivate);
5597 0         0 $node010->addArrow($node015, 1, 0, 'box', \&collectPublic);
5598 0         0 $node011->addArrow($node012, 1, 0, 'ACTOR', \&collectActor);
5599 0         0 $node011->addArrow($node012, 1, 0, 'KEYPAIR', \&collectKeypair);
5600 0         0 $node011->addArrow($node015, 1, 1, 'ACCOUNT', \&collectAccount);
5601 0         0 $node011->addArrow($node015, 1, 0, 'ACTORGROUP', \&collectActorgroup);
5602 0         0 $node012->addArrow($node013, 1, 0, 'on');
5603 0         0 $node012->addDefault($node015);
5604 0         0 $node013->addArrow($node015, 1, 0, 'STORE', \&collectStore);
5605             }
5606              
5607             sub collectAccount {
5608 0     0   0 my $o = shift;
5609 0         0 my $label = shift;
5610 0         0 my $value = shift;
5611              
5612 0         0 $o->{actorHash} = $value->actorHash;
5613 0         0 $o->{store} = $value->cliStore;
5614             }
5615              
5616             sub collectActor {
5617 0     0   0 my $o = shift;
5618 0         0 my $label = shift;
5619 0         0 my $value = shift;
5620              
5621 0         0 $o->{actorHash} = $value;
5622             }
5623              
5624             sub collectActorgroup {
5625 0     0   0 my $o = shift;
5626 0         0 my $label = shift;
5627 0         0 my $value = shift;
5628              
5629 0         0 $o->{actorGroup} = $value;
5630             }
5631              
5632             sub collectBox {
5633 0     0   0 my $o = shift;
5634 0         0 my $label = shift;
5635 0         0 my $value = shift;
5636              
5637 0         0 push @{$o->{boxTokens}}, $value;
  0         0  
5638             }
5639              
5640             sub collectKeypair {
5641 0     0   0 my $o = shift;
5642 0         0 my $label = shift;
5643 0         0 my $value = shift;
5644              
5645 0         0 $o->{actorHash} = $value->keyPair->publicKey->hash;
5646 0         0 $o->{keyPairToken} = $value;
5647             }
5648              
5649             sub collectMessages {
5650 0     0   0 my $o = shift;
5651 0         0 my $label = shift;
5652 0         0 my $value = shift;
5653              
5654 0         0 $o->{boxLabels} = ['messages'];
5655             }
5656              
5657             sub collectMy {
5658 0     0   0 my $o = shift;
5659 0         0 my $label = shift;
5660 0         0 my $value = shift;
5661              
5662 0         0 $o->{my} = 1;
5663             }
5664              
5665             sub collectPrivate {
5666 0     0   0 my $o = shift;
5667 0         0 my $label = shift;
5668 0         0 my $value = shift;
5669              
5670 0         0 $o->{boxLabels} = ['private'];
5671             }
5672              
5673             sub collectPublic {
5674 0     0   0 my $o = shift;
5675 0         0 my $label = shift;
5676 0         0 my $value = shift;
5677              
5678 0         0 $o->{boxLabels} = ['public'];
5679             }
5680              
5681             sub collectStore {
5682 0     0   0 my $o = shift;
5683 0         0 my $label = shift;
5684 0         0 my $value = shift;
5685              
5686 0         0 $o->{store} = $value;
5687             }
5688              
5689             sub collectWatch {
5690 0     0   0 my $o = shift;
5691 0         0 my $label = shift;
5692 0         0 my $value = shift;
5693              
5694 0         0 $o->{watchTimeout} = 60000;
5695             }
5696              
5697             sub new {
5698 0     0   0 my $class = shift;
5699 0         0 my $actor = shift;
5700 0         0 bless {actor => $actor, ui => $actor->ui} }
5701              
5702             # END AUTOGENERATED
5703              
5704             # HTML FOLDER NAME store-list
5705             # HTML TITLE List
5706             sub help {
5707 0     0   0 my $o = shift;
5708 0         0 my $cmd = shift;
5709              
5710 0         0 my $ui = $o->{ui};
5711 0         0 $ui->space;
5712 0         0 $ui->command('cds list BOX');
5713 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.');
5714 0         0 $ui->space;
5715 0         0 $ui->command('cds list');
5716 0         0 $ui->p('Lists all boxes of the selected key pair.');
5717 0         0 $ui->space;
5718 0         0 $ui->command('cds list BOXLABEL');
5719 0         0 $ui->p('Lists only the indicated box of the selected key pair. BOXLABEL may be:');
5720 0         0 $ui->line(' message box');
5721 0         0 $ui->line(' public box');
5722 0         0 $ui->line(' private box');
5723 0         0 $ui->space;
5724 0         0 $ui->command('cds list my boxes');
5725 0         0 $ui->command('cds list my BOXLABEL');
5726 0         0 $ui->p('Lists your own boxes.');
5727 0         0 $ui->space;
5728 0         0 $ui->command('cds list [BOXLABEL of] ACTORGROUP|ACCOUNT');
5729 0         0 $ui->p('Lists boxes of an actor group, or account.');
5730 0         0 $ui->space;
5731 0         0 $ui->command('cds list [BOXLABEL of] KEYPAIR|ACTOR [on STORE]');
5732 0         0 $ui->p('Lists boxes of an actor on the specified or selected store.');
5733 0         0 $ui->space;
5734             }
5735              
5736             sub listBoxes {
5737 0     0   0 my $o = shift;
5738 0         0 my $cmd = shift;
5739              
5740 0         0 $o->{boxTokens} = [];
5741 0         0 $o->{boxLabels} = ['messages', 'private', 'public'];
5742 0         0 $cmd->collect($o);
5743              
5744             # Use the selected key pair to sign requests
5745 0 0       0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken if ! $o->{keyPairToken};
5746              
5747 0         0 for my $boxToken (@{$o->{boxTokens}}) {
  0         0  
5748 0         0 $o->listBox($boxToken);
5749             }
5750              
5751 0         0 $o->{ui}->space;
5752             }
5753              
5754             sub list {
5755 0     0   0 my $o = shift;
5756 0         0 my $cmd = shift;
5757              
5758 0         0 $o->{boxLabels} = ['messages', 'private', 'public'];
5759 0         0 $cmd->collect($o);
5760              
5761             # Actor hashes
5762 0         0 my @actorHashes;
5763             my @stores;
5764 0 0       0 if ($o->{my}) {
    0          
    0          
5765 0         0 $o->{keyPairToken} = $o->{actor}->keyPairToken;
5766 0         0 push @actorHashes, $o->{keyPairToken}->keyPair->publicKey->hash;
5767 0         0 push @stores, $o->{actor}->storageStore, $o->{actor}->messagingStore;
5768             } elsif ($o->{actorHash}) {
5769 0         0 push @actorHashes, $o->{actorHash};
5770             } elsif ($o->{actorGroup}) {
5771             # TODO
5772             } else {
5773 0         0 push @actorHashes, $o->{actor}->preferredActorHash;
5774             }
5775              
5776             # Stores
5777 0 0       0 push @stores, $o->{store} if $o->{store};
5778 0 0       0 push @stores, $o->{actor}->preferredStore if ! scalar @stores;
5779              
5780             # Use the selected key pair to sign requests
5781 0         0 my $preferredKeyPairToken = $o->{actor}->preferredKeyPairToken;
5782 0 0       0 $o->{keyPairToken} = $preferredKeyPairToken if ! $o->{keyPairToken};
5783 0 0       0 $o->{keyPairContext} = $preferredKeyPairToken->keyPair->equals($o->{keyPairToken}->keyPair) ? '' : $o->{ui}->gray(' using ', $o->{actor}->keyPairReference($o->{keyPairToken}));
5784              
5785             # List boxes
5786 0         0 for my $store (@stores) {
5787 0         0 for my $actorHash (@actorHashes) {
5788 0         0 for my $boxLabel (@{$o->{boxLabels}}) {
  0         0  
5789 0         0 $o->listBox(CDS::BoxToken->new(CDS::AccountToken->new($store, $actorHash), $boxLabel));
5790             }
5791             }
5792             }
5793              
5794 0         0 $o->{ui}->space;
5795             }
5796              
5797             sub listBox {
5798 0     0   0 my $o = shift;
5799 0         0 my $boxToken = shift;
5800              
5801 0         0 $o->{ui}->space;
5802 0         0 $o->{ui}->title($o->{actor}->blueBoxReference($boxToken));
5803              
5804             # Query the store
5805 0         0 my $store = $boxToken->accountToken->cliStore;
5806 0   0     0 my ($hashes, $storeError) = $store->list($boxToken->accountToken->actorHash, $boxToken->boxLabel, $o->{watchTimeout} // 0, $o->{keyPairToken}->keyPair);
5807 0 0       0 return if defined $storeError;
5808              
5809             # Print the result
5810 0         0 my $count = scalar @$hashes;
5811 0 0       0 return if ! $count;
5812              
5813 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));
5814 0 0 0     0 my $keyPairContext = $boxToken->boxLabel eq 'public' ? '' : $o->{keyPairContext} // '';
5815 0         0 foreach my $hash (sort { $a->bytes cmp $b->bytes } @$hashes) {
  0         0  
5816 0         0 $o->{ui}->line($o->{ui}->gold('cds open envelope ', $hash->hex), $context, $keyPairContext);
5817             }
5818 0 0       0 $o->{ui}->line($count.' entries') if $count > 5;
5819             }
5820              
5821             # BEGIN AUTOGENERATED
5822             package CDS::Commands::Modify;
5823              
5824             sub register {
5825 0     0   0 my $class = shift;
5826 0         0 my $cds = shift;
5827 0         0 my $help = shift;
5828              
5829 0         0 my $node000 = CDS::Parser::Node->new(0);
5830 0         0 my $node001 = CDS::Parser::Node->new(0);
5831 0         0 my $node002 = CDS::Parser::Node->new(0);
5832 0         0 my $node003 = CDS::Parser::Node->new(0);
5833 0         0 my $node004 = CDS::Parser::Node->new(0);
5834 0         0 my $node005 = CDS::Parser::Node->new(0);
5835 0         0 my $node006 = CDS::Parser::Node->new(0);
5836 0         0 my $node007 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
5837 0         0 my $node008 = CDS::Parser::Node->new(1);
5838 0         0 my $node009 = CDS::Parser::Node->new(0);
5839 0         0 my $node010 = CDS::Parser::Node->new(0);
5840 0         0 my $node011 = CDS::Parser::Node->new(0);
5841 0         0 my $node012 = CDS::Parser::Node->new(0);
5842 0         0 my $node013 = CDS::Parser::Node->new(0);
5843 0         0 my $node014 = CDS::Parser::Node->new(0);
5844 0         0 my $node015 = CDS::Parser::Node->new(0);
5845 0         0 my $node016 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&modify});
5846 0         0 $cds->addDefault($node000);
5847 0         0 $help->addArrow($node007, 1, 0, 'add');
5848 0         0 $help->addArrow($node007, 1, 0, 'purge');
5849 0         0 $help->addArrow($node007, 1, 0, 'remove');
5850 0         0 $node000->addArrow($node001, 1, 0, 'add');
5851 0         0 $node000->addArrow($node002, 1, 0, 'remove');
5852 0         0 $node000->addArrow($node003, 1, 0, 'add');
5853 0         0 $node000->addArrow($node008, 1, 0, 'purge', \&collectPurge);
5854 0         0 $node001->addArrow($node001, 1, 0, 'HASH', \&collectHash);
5855 0         0 $node001->addArrow($node004, 1, 0, 'HASH', \&collectHash);
5856 0         0 $node002->addArrow($node002, 1, 0, 'HASH', \&collectHash1);
5857 0         0 $node002->addArrow($node005, 1, 0, 'HASH', \&collectHash1);
5858 0         0 $node003->addArrow($node003, 1, 0, 'FILE', \&collectFile);
5859 0         0 $node003->addArrow($node006, 1, 0, 'FILE', \&collectFile);
5860 0         0 $node004->addArrow($node008, 1, 0, 'to');
5861 0         0 $node005->addArrow($node008, 1, 0, 'from');
5862 0         0 $node006->addArrow($node008, 1, 0, 'to');
5863 0         0 $node008->addArrow($node000, 1, 0, 'and');
5864 0         0 $node008->addArrow($node009, 1, 0, 'message');
5865 0         0 $node008->addArrow($node010, 1, 0, 'private');
5866 0         0 $node008->addArrow($node011, 1, 0, 'public');
5867 0         0 $node008->addArrow($node012, 0, 0, 'messages', \&collectMessages);
5868 0         0 $node008->addArrow($node012, 0, 0, 'private', \&collectPrivate);
5869 0         0 $node008->addArrow($node012, 0, 0, 'public', \&collectPublic);
5870 0         0 $node008->addArrow($node016, 1, 0, 'BOX', \&collectBox);
5871 0         0 $node009->addArrow($node012, 1, 0, 'box', \&collectMessages);
5872 0         0 $node010->addArrow($node012, 1, 0, 'box', \&collectPrivate);
5873 0         0 $node011->addArrow($node012, 1, 0, 'box', \&collectPublic);
5874 0         0 $node012->addArrow($node013, 1, 0, 'of');
5875 0         0 $node013->addArrow($node014, 1, 0, 'ACTOR', \&collectActor);
5876 0         0 $node013->addArrow($node014, 1, 0, 'KEYPAIR', \&collectKeypair);
5877 0         0 $node013->addArrow($node016, 1, 1, 'ACCOUNT', \&collectAccount);
5878 0         0 $node014->addArrow($node015, 1, 0, 'on');
5879 0         0 $node014->addDefault($node016);
5880 0         0 $node015->addArrow($node016, 1, 0, 'STORE', \&collectStore);
5881             }
5882              
5883             sub collectAccount {
5884 0     0   0 my $o = shift;
5885 0         0 my $label = shift;
5886 0         0 my $value = shift;
5887              
5888 0         0 $o->{boxToken} = CDS::BoxToken->new($value, $o->{boxLabel});
5889 0         0 delete $o->{boxLabel};
5890             }
5891              
5892             sub collectActor {
5893 0     0   0 my $o = shift;
5894 0         0 my $label = shift;
5895 0         0 my $value = shift;
5896              
5897 0         0 $o->{actorHash} = $value;
5898             }
5899              
5900             sub collectBox {
5901 0     0   0 my $o = shift;
5902 0         0 my $label = shift;
5903 0         0 my $value = shift;
5904              
5905 0         0 $o->{boxToken} = $value;
5906             }
5907              
5908             sub collectFile {
5909 0     0   0 my $o = shift;
5910 0         0 my $label = shift;
5911 0         0 my $value = shift;
5912              
5913 0         0 push @{$o->{fileAdditions}}, $value;
  0         0  
5914             }
5915              
5916             sub collectHash {
5917 0     0   0 my $o = shift;
5918 0         0 my $label = shift;
5919 0         0 my $value = shift;
5920              
5921 0         0 push @{$o->{additions}}, $value;
  0         0  
5922             }
5923              
5924             sub collectHash1 {
5925 0     0   0 my $o = shift;
5926 0         0 my $label = shift;
5927 0         0 my $value = shift;
5928              
5929 0         0 push @{$o->{removals}}, $value;
  0         0  
5930             }
5931              
5932             sub collectKeypair {
5933 0     0   0 my $o = shift;
5934 0         0 my $label = shift;
5935 0         0 my $value = shift;
5936              
5937 0         0 $o->{actorHash} = $value->publicKey->hash;
5938 0         0 $o->{keyPairToken} = $value;
5939             }
5940              
5941             sub collectMessages {
5942 0     0   0 my $o = shift;
5943 0         0 my $label = shift;
5944 0         0 my $value = shift;
5945              
5946 0         0 $o->{boxLabel} = 'messages';
5947             }
5948              
5949             sub collectPrivate {
5950 0     0   0 my $o = shift;
5951 0         0 my $label = shift;
5952 0         0 my $value = shift;
5953              
5954 0         0 $o->{boxLabel} = 'private';
5955             }
5956              
5957             sub collectPublic {
5958 0     0   0 my $o = shift;
5959 0         0 my $label = shift;
5960 0         0 my $value = shift;
5961              
5962 0         0 $o->{boxLabel} = 'public';
5963             }
5964              
5965             sub collectPurge {
5966 0     0   0 my $o = shift;
5967 0         0 my $label = shift;
5968 0         0 my $value = shift;
5969              
5970 0         0 $o->{purge} = 1;
5971             }
5972              
5973             sub collectStore {
5974 0     0   0 my $o = shift;
5975 0         0 my $label = shift;
5976 0         0 my $value = shift;
5977              
5978 0         0 $o->{boxToken} = CDS::BoxToken->new(CDS::AccountToken->new($value, $o->{actorHash}), $o->{boxLabel});
5979 0         0 delete $o->{boxLabel};
5980 0         0 delete $o->{actorHash};
5981             }
5982              
5983             sub new {
5984 0     0   0 my $class = shift;
5985 0         0 my $actor = shift;
5986 0         0 bless {actor => $actor, ui => $actor->ui} }
5987              
5988             # END AUTOGENERATED
5989              
5990             # HTML FOLDER NAME store-modify
5991             # HTML TITLE Modify
5992             sub help {
5993 0     0   0 my $o = shift;
5994 0         0 my $cmd = shift;
5995              
5996 0         0 my $ui = $o->{ui};
5997 0         0 $ui->space;
5998 0         0 $ui->command('cds add HASH* to BOX');
5999 0         0 $ui->p('Adds HASH to BOX.');
6000 0         0 $ui->space;
6001 0         0 $ui->command('cds add FILE* to BOX');
6002 0         0 $ui->p('Adds the envelope FILE to BOX.');
6003 0         0 $ui->space;
6004 0         0 $ui->command('cds remove HASH* from BOX');
6005 0         0 $ui->p('Removes HASH from BOX.');
6006 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.');
6007 0         0 $ui->space;
6008 0         0 $ui->command('cds purge BOX');
6009 0         0 $ui->p('Empties BOX, i.e., removes all its hashes.');
6010 0         0 $ui->space;
6011 0         0 $ui->command('… BOXLABEL of ACCOUNT');
6012 0         0 $ui->p('Modifies a box of an actor group, or account.');
6013 0         0 $ui->space;
6014 0         0 $ui->command('… BOXLABEL of KEYPAIR on STORE');
6015 0         0 $ui->command('… BOXLABEL of ACTOR on STORE');
6016 0         0 $ui->p('Modifies a box of a key pair or an actor on a specific store.');
6017 0         0 $ui->space;
6018             }
6019              
6020             sub modify {
6021 0     0   0 my $o = shift;
6022 0         0 my $cmd = shift;
6023              
6024 0         0 $o->{additions} = [];
6025 0         0 $o->{removals} = [];
6026 0         0 $cmd->collect($o);
6027              
6028             # Add a box using the selected store
6029 0 0 0     0 if ($o->{actorHash} && $o->{boxLabel}) {
6030 0         0 $o->{boxToken} = CDS::BoxToken->new(CDS::AccountToken->new($o->{actor}->preferredStore, $o->{actorHash}), $o->{boxLabel});
6031 0         0 delete $o->{actorHash};
6032 0         0 delete $o->{boxLabel};
6033             }
6034              
6035 0         0 my $store = $o->{boxToken}->accountToken->cliStore;
6036              
6037             # Prepare additions
6038 0         0 my $modifications = CDS::StoreModifications->new;
6039 0         0 for my $hash (@{$o->{additions}}) {
  0         0  
6040 0         0 $modifications->add($o->{boxToken}->accountToken->actorHash, $o->{boxToken}->boxLabel, $hash);
6041             }
6042              
6043 0         0 for my $file (@{$o->{fileAdditions}}) {
  0         0  
6044 0   0     0 my $bytes = CDS->readBytesFromFile($file) // return $o->{ui}->error('Unable to read "', $file, '".');
6045 0   0     0 my $object = CDS::Object->fromBytes($bytes) // return $o->{ui}->error('"', $file, '" is not a Condensation object.');
6046 0         0 my $hash = $object->calculateHash;
6047 0 0       0 $o->{ui}->warning('"', $file, '" is not a valid envelope. The server may reject it.') if ! $o->{actor}->isEnvelope($object);
6048 0         0 $modifications->add($o->{boxToken}->accountToken->actorHash, $o->{boxToken}->boxLabel, $hash, $object);
6049             }
6050              
6051             # Prepare removals
6052 0         0 my $boxRemovals = [];
6053 0         0 for my $hash (@{$o->{removals}}) {
  0         0  
6054 0         0 $modifications->remove($o->{boxToken}->accountToken->actorHash, $o->{boxToken}->boxLabel, $hash);
6055             }
6056              
6057             # If purging is requested, list the box
6058 0 0       0 if ($o->{purge}) {
6059 0         0 my ($hashes, $error) = $store->list($o->{boxToken}->accountToken->actorHash, $o->{boxToken}->boxLabel, 0);
6060 0 0       0 return if defined $error;
6061 0 0       0 $o->{ui}->warning('The box is empty.') if ! scalar @$hashes;
6062              
6063 0         0 for my $hash (@$hashes) {
6064 0         0 $modifications->remove($o->{boxToken}->accountToken->actorHash, $o->{boxToken}->boxLabel, $hash);
6065             }
6066             }
6067              
6068             # Cancel if there is nothing to do
6069 0 0       0 return if $modifications->isEmpty;
6070              
6071             # Modify the box
6072 0   0     0 my $keyPairToken = $o->{keyPairToken} // $o->{actor}->preferredKeyPairToken;
6073 0         0 my $error = $store->modify($modifications, $keyPairToken->keyPair);
6074 0 0       0 $o->{ui}->pGreen('Box modified.') if ! defined $error;
6075              
6076             # Print undo information
6077 0 0 0     0 if ($o->{purge} && scalar @$boxRemovals) {
6078 0         0 $o->{ui}->space;
6079 0         0 $o->{ui}->line($o->{ui}->gray('To undo purging, type:'));
6080 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  
6081 0         0 $o->{ui}->space;
6082             }
6083             }
6084              
6085             # BEGIN AUTOGENERATED
6086             package CDS::Commands::OpenEnvelope;
6087              
6088             sub register {
6089 0     0   0 my $class = shift;
6090 0         0 my $cds = shift;
6091 0         0 my $help = shift;
6092              
6093 0         0 my $node000 = CDS::Parser::Node->new(0);
6094 0         0 my $node001 = CDS::Parser::Node->new(0);
6095 0         0 my $node002 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
6096 0         0 my $node003 = CDS::Parser::Node->new(1);
6097 0         0 my $node004 = CDS::Parser::Node->new(1);
6098 0         0 my $node005 = CDS::Parser::Node->new(0);
6099 0         0 my $node006 = CDS::Parser::Node->new(0);
6100 0         0 my $node007 = CDS::Parser::Node->new(1);
6101 0         0 my $node008 = CDS::Parser::Node->new(0);
6102 0         0 my $node009 = CDS::Parser::Node->new(0);
6103 0         0 my $node010 = CDS::Parser::Node->new(0);
6104 0         0 my $node011 = CDS::Parser::Node->new(1);
6105 0         0 my $node012 = CDS::Parser::Node->new(0);
6106 0         0 my $node013 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&openEnvelope});
6107 0         0 $cds->addArrow($node001, 1, 0, 'open');
6108 0         0 $help->addArrow($node000, 1, 0, 'open');
6109 0         0 $node000->addArrow($node002, 1, 0, 'envelope');
6110 0         0 $node001->addArrow($node003, 1, 0, 'envelope');
6111 0         0 $node003->addArrow($node004, 1, 0, 'HASH', \&collectHash);
6112 0         0 $node003->addArrow($node007, 1, 0, 'OBJECT', \&collectObject);
6113 0         0 $node004->addArrow($node005, 1, 0, 'from');
6114 0         0 $node004->addArrow($node006, 1, 0, 'from');
6115 0         0 $node004->addDefault($node009);
6116 0         0 $node005->addArrow($node009, 1, 0, 'ACTOR', \&collectActor);
6117 0         0 $node006->addArrow($node011, 1, 1, 'ACCOUNT', \&collectAccount);
6118 0         0 $node007->addArrow($node008, 1, 0, 'from');
6119 0         0 $node007->addDefault($node011);
6120 0         0 $node008->addArrow($node011, 1, 0, 'ACTOR', \&collectActor);
6121 0         0 $node009->addArrow($node010, 1, 0, 'on');
6122 0         0 $node009->addDefault($node011);
6123 0         0 $node010->addArrow($node011, 1, 0, 'STORE', \&collectStore);
6124 0         0 $node011->addArrow($node012, 1, 0, 'using');
6125 0         0 $node011->addDefault($node013);
6126 0         0 $node012->addArrow($node013, 1, 0, 'KEYPAIR', \&collectKeypair);
6127             }
6128              
6129             sub collectAccount {
6130 0     0   0 my $o = shift;
6131 0         0 my $label = shift;
6132 0         0 my $value = shift;
6133              
6134 0         0 $o->{senderHash} = $value->actorHash;
6135 0         0 $o->{store} = $value->cliStore;
6136             }
6137              
6138             sub collectActor {
6139 0     0   0 my $o = shift;
6140 0         0 my $label = shift;
6141 0         0 my $value = shift;
6142              
6143 0         0 $o->{senderHash} = $value;
6144             }
6145              
6146             sub collectHash {
6147 0     0   0 my $o = shift;
6148 0         0 my $label = shift;
6149 0         0 my $value = shift;
6150              
6151 0         0 $o->{hash} = $value;
6152 0         0 $o->{store} = $o->{actor}->preferredStore;
6153             }
6154              
6155             sub collectKeypair {
6156 0     0   0 my $o = shift;
6157 0         0 my $label = shift;
6158 0         0 my $value = shift;
6159              
6160 0         0 $o->{keyPairToken} = $value;
6161             }
6162              
6163             sub collectObject {
6164 0     0   0 my $o = shift;
6165 0         0 my $label = shift;
6166 0         0 my $value = shift;
6167              
6168 0         0 $o->{hash} = $value->hash;
6169 0         0 $o->{store} = $value->cliStore;
6170             }
6171              
6172             sub collectStore {
6173 0     0   0 my $o = shift;
6174 0         0 my $label = shift;
6175 0         0 my $value = shift;
6176              
6177 0         0 $o->{store} = $value;
6178             }
6179              
6180             sub new {
6181 0     0   0 my $class = shift;
6182 0         0 my $actor = shift;
6183 0         0 bless {actor => $actor, ui => $actor->ui} }
6184              
6185             # END AUTOGENERATED
6186              
6187             # HTML FOLDER NAME open-envelope
6188             # HTML TITLE Open envelope
6189             sub help {
6190 0     0   0 my $o = shift;
6191 0         0 my $cmd = shift;
6192              
6193 0         0 my $ui = $o->{ui};
6194 0         0 $ui->space;
6195 0         0 $ui->command('cds open envelope OBJECT');
6196 0         0 $ui->command('cds open envelope HASH on STORE');
6197 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.');
6198 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.');
6199 0         0 $ui->space;
6200 0         0 $ui->command('cds open envelope HASH');
6201 0         0 $ui->p('As above, but uses the selected store.');
6202 0         0 $ui->space;
6203 0         0 $ui->command('… from ACTOR');
6204 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.');
6205 0         0 $ui->space;
6206 0         0 $ui->command('… using KEYPAIR');
6207 0         0 $ui->p('Tries to decrypt the AES key using this key pair, instead of the selected key pair.');
6208 0         0 $ui->space;
6209             }
6210              
6211             sub openEnvelope {
6212 0     0   0 my $o = shift;
6213 0         0 my $cmd = shift;
6214              
6215 0         0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken;
6216 0         0 $cmd->collect($o);
6217              
6218             # Get the envelope
6219 0   0     0 my $envelope = $o->{actor}->uiGetRecord($o->{hash}, $o->{store}, $o->{keyPairToken}) // return;
6220              
6221             # Continue by envelope type
6222 0         0 my $contentRecord = $envelope->child('content');
6223 0 0       0 if ($contentRecord->hashValue) {
    0          
6224 0 0       0 if ($envelope->contains('encrypted for')) {
6225 0         0 $o->processPrivateEnvelope($envelope);
6226             } else {
6227 0         0 $o->processPublicEnvelope($envelope);
6228             }
6229             } elsif (length $contentRecord->bytesValue) {
6230 0 0 0     0 if ($envelope->contains('head') && $envelope->contains('mac')) {
6231 0         0 $o->processStreamEnvelope($envelope);
6232             } else {
6233 0         0 $o->processMessageEnvelope($envelope);
6234             }
6235             } else {
6236 0         0 $o->processOther($envelope);
6237             }
6238             }
6239              
6240             sub processOther {
6241 0     0   0 my $o = shift;
6242 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
6243              
6244 0         0 $o->{ui}->space;
6245 0         0 $o->{ui}->pOrange('This is not an envelope. Envelopes always have a "content" section. The raw record is shown below.');
6246 0         0 $o->{ui}->space;
6247 0         0 $o->{ui}->title('Record');
6248 0         0 $o->{ui}->recordChildren($envelope, $o->{actor}->storeReference($o->{store}));
6249 0         0 $o->{ui}->space;
6250             }
6251              
6252             sub processPublicEnvelope {
6253 0     0   0 my $o = shift;
6254 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
6255              
6256 0         0 $o->{ui}->space;
6257 0         0 $o->{ui}->title('Public envelope');
6258 0         0 $o->{ui}->line($o->{ui}->gold('cds show record ', $o->{hash}->hex, ' on ', $o->{actor}->storeReference($o->{store})));
6259              
6260 0         0 my $contentHash = $envelope->child('content')->hashValue;
6261 0         0 $o->showPublicPrivateSignature($envelope, $contentHash);
6262              
6263 0         0 $o->{ui}->space;
6264 0         0 $o->{ui}->title('Content');
6265 0         0 $o->{ui}->line($o->{ui}->gold('cds show record ', $contentHash->hex, ' on ', $o->{actor}->storeReference($o->{store})));
6266              
6267 0         0 $o->{ui}->space;
6268             }
6269              
6270             sub processPrivateEnvelope {
6271 0     0   0 my $o = shift;
6272 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
6273              
6274 0         0 $o->{ui}->space;
6275 0         0 $o->{ui}->title('Private envelope');
6276 0         0 $o->{ui}->line($o->{ui}->gold('cds show record ', $o->{hash}->hex, ' on ', $o->{actor}->storeReference($o->{store})));
6277              
6278 0         0 my $aesKey = $o->decryptAesKey($envelope);
6279 0         0 my $contentHash = $envelope->child('content')->hashValue;
6280 0         0 $o->showPublicPrivateSignature($envelope, $contentHash);
6281 0         0 $o->showEncryptedFor($envelope);
6282              
6283 0         0 $o->{ui}->space;
6284 0 0       0 if ($aesKey) {
6285 0         0 $o->{ui}->title('Content');
6286 0         0 $o->{ui}->line($o->{ui}->gold('cds show record ', $contentHash->hex, ' on ', $o->{actor}->storeReference($o->{store}), ' decrypted with ', unpack('H*', $aesKey)));
6287             } else {
6288 0         0 $o->{ui}->title('Encrypted content');
6289 0         0 $o->{ui}->line($o->{ui}->gold('cds get ', $contentHash->hex, ' on ', $o->{actor}->storeReference($o->{store})));
6290             }
6291              
6292 0         0 $o->{ui}->space;
6293             }
6294              
6295             sub showPublicPrivateSignature {
6296 0     0   0 my $o = shift;
6297 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
6298 0 0 0     0 my $contentHash = shift; die 'wrong type '.ref($contentHash).' for $contentHash' if defined $contentHash && ref $contentHash ne 'CDS::Hash';
  0         0  
6299              
6300 0         0 $o->{ui}->space;
6301 0         0 $o->{ui}->title('Signed by');
6302 0 0       0 if ($o->{senderHash}) {
6303 0         0 my $accountToken = CDS::AccountToken->new($o->{store}, $o->{senderHash});
6304 0         0 $o->{ui}->line($o->{actor}->blueAccountReference($accountToken));
6305 0         0 $o->showSignature($envelope, $o->{senderHash}, $o->{store}, $contentHash);
6306             } else {
6307 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:');
6308 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})));
6309             }
6310             }
6311              
6312             sub processMessageEnvelope {
6313 0     0   0 my $o = shift;
6314 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
6315              
6316 0         0 $o->{ui}->space;
6317 0         0 $o->{ui}->title('Message envelope');
6318 0         0 $o->{ui}->line($o->{ui}->gold('cds show record ', $o->{hash}->hex, ' on ', $o->{actor}->storeReference($o->{store})));
6319              
6320             # Decrypt
6321 0         0 my $encryptedContentBytes = $envelope->child('content')->bytesValue;
6322 0         0 my $aesKey = $o->decryptAesKey($envelope);
6323 0 0       0 if (! $aesKey) {
6324 0         0 $o->{ui}->space;
6325 0         0 $o->{ui}->title('Encrypted content');
6326 0         0 $o->{ui}->line(length $encryptedContentBytes, ' bytes');
6327 0         0 return $o->processMessageEnvelope2($envelope);
6328             }
6329              
6330 0         0 my $contentObject = CDS::Object->fromBytes(CDS::C::aesCrypt($encryptedContentBytes, $aesKey, CDS->zeroCTR));
6331 0 0       0 if (! $contentObject) {
6332 0         0 $o->{ui}->pRed('The embedded content object is invalid, or the AES key (', unpack('H*', $aesKey), ') is wrong.');
6333 0         0 return $o->processMessageEnvelope2($envelope);
6334             }
6335              
6336             #my $signedHash = $contentObject->calculateHash; # before 2020-05-05
6337 0         0 my $signedHash = CDS::Hash->calculateFor($encryptedContentBytes);
6338 0         0 my $content = CDS::Record->fromObject($contentObject);
6339 0 0       0 if (! $content) {
6340 0         0 $o->{ui}->pRed('The embedded content object does not contain a record, or the AES key (', unpack('H*', $aesKey), ') is wrong.');
6341 0         0 return $o->processMessageEnvelope2($envelope);
6342             }
6343              
6344             # Sender hash
6345 0         0 my $senderHash = $content->child('sender')->hashValue;
6346 0 0       0 $o->{ui}->pRed('The content object is missing the sender.') if ! $senderHash;
6347              
6348             # Sender store
6349 0         0 my $senderStoreRecord = $content->child('store');
6350 0         0 my $senderStoreBytes = $senderStoreRecord->bytesValue;
6351 0         0 my $mentionsSenderStore = length $senderStoreBytes;
6352 0 0       0 $o->{ui}->pRed('The content object is missing the sender\'s store.') if ! $mentionsSenderStore;
6353 0 0       0 my $senderStore = scalar $mentionsSenderStore ? $o->{actor}->storeForUrl($senderStoreRecord->textValue) : undef;
6354              
6355             # Sender
6356 0         0 $o->{ui}->space;
6357 0         0 $o->{ui}->title('Signed by');
6358 0 0 0     0 if ($senderHash && $senderStore) {
    0          
    0          
    0          
6359 0         0 my $senderToken = CDS::AccountToken->new($senderStore, $senderHash);
6360 0         0 $o->{ui}->line($o->{actor}->blueAccountReference($senderToken));
6361 0         0 $o->showSignature($envelope, $senderHash, $senderStore, $signedHash);
6362             } elsif ($senderHash) {
6363 0   0     0 my $actorLabel = $o->{actor}->actorLabel($senderHash) // $senderHash->hex;
6364 0 0       0 if ($mentionsSenderStore) {
6365 0         0 $o->{ui}->line($actorLabel, ' on ', $o->{ui}->red($o->{ui}->niceBytes($senderStoreBytes, 64)));
6366             } else {
6367 0         0 $o->{ui}->line($actorLabel);
6368             }
6369 0         0 $o->{ui}->pOrange('The signature cannot be verified, because the signer\'s store is not known.');
6370             } elsif ($senderStore) {
6371 0         0 $o->{ui}->line($o->{ui}->red('?'), ' on ', $o->{actor}->storeReference($senderStore));
6372 0         0 $o->{ui}->pOrange('The signature cannot be verified, because the signer is not known.');
6373             } elsif ($mentionsSenderStore) {
6374 0         0 $o->{ui}->line($o->{ui}->red('?'), ' on ', $o->{ui}->red($o->{ui}->niceBytes($senderStoreBytes, 64)));
6375 0         0 $o->{ui}->pOrange('The signature cannot be verified, because the signer is not known.');
6376             } else {
6377 0         0 $o->{ui}->pOrange('The signature cannot be verified, because the signer is not known.');
6378             }
6379              
6380             # Content
6381 0         0 $o->{ui}->space;
6382 0         0 $o->{ui}->title('Content');
6383 0 0       0 $o->{ui}->recordChildren($content, $senderStore ? $o->{actor}->storeReference($senderStore) : undef);
6384              
6385 0         0 return $o->processMessageEnvelope2($envelope);
6386             }
6387              
6388             sub processMessageEnvelope2 {
6389 0     0   0 my $o = shift;
6390 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
6391              
6392             # Encrypted for
6393 0         0 $o->showEncryptedFor($envelope);
6394              
6395             # Updated by
6396 0         0 $o->{ui}->space;
6397 0         0 $o->{ui}->title('May be removed or updated by');
6398              
6399 0         0 for my $child ($envelope->child('updated by')->children) {
6400 0         0 $o->showActorHash24($child->bytes);
6401             }
6402              
6403             # Expires
6404 0         0 $o->{ui}->space;
6405 0         0 $o->{ui}->title('Expires');
6406 0         0 my $expires = $envelope->child('expires')->integerValue;
6407 0 0       0 $o->{ui}->line($expires ? $o->{ui}->niceDateTime($expires) : $o->{ui}->gray('never'));
6408 0         0 $o->{ui}->space;
6409             }
6410              
6411             sub processStreamHead {
6412 0     0   0 my $o = shift;
6413 0         0 my $head = shift;
6414              
6415 0         0 $o->{ui}->space;
6416 0         0 $o->{ui}->title('Stream head');
6417 0 0       0 return $o->{ui}->pRed('The envelope does not mention a stream head.') if ! $head;
6418 0         0 $o->{ui}->line($o->{ui}->gold('cds open envelope ', $head->hex, ' on ', $o->{actor}->storeReference($o->{store})));
6419              
6420             # Get the envelope
6421 0   0     0 my $envelope = $o->{actor}->uiGetRecord($head, $o->{store}, $o->{keyPairToken}) // return;
6422              
6423             # Decrypt the content
6424 0         0 my $encryptedContentBytes = $envelope->child('content')->bytesValue;
6425 0   0     0 my $aesKey = $o->decryptAesKey($envelope) // return;
6426 0   0     0 my $contentObject = CDS::Object->fromBytes(CDS::C::aesCrypt($encryptedContentBytes, $aesKey, CDS->zeroCTR)) // return {aesKey => $aesKey};
6427 0         0 my $signedHash = CDS::Hash->calculateFor($encryptedContentBytes);
6428 0   0     0 my $content = CDS::Record->fromObject($contentObject) // return {aesKey => $aesKey};
6429              
6430             # Sender
6431 0         0 my $senderHash = $content->child('sender')->hashValue;
6432 0         0 my $senderStoreRecord = $content->child('store');
6433 0         0 my $senderStore = $o->{actor}->storeForUrl($senderStoreRecord->textValue);
6434 0 0 0     0 return {aesKey => $aesKey, senderHash => $senderHash, senderStore => $senderStore} if ! $senderHash || ! $senderStore;
6435              
6436 0         0 $o->{ui}->pushIndent;
6437 0         0 $o->{ui}->space;
6438 0         0 $o->{ui}->title('Signed by');
6439 0         0 my $senderToken = CDS::AccountToken->new($senderStore, $senderHash);
6440 0         0 $o->{ui}->line($o->{actor}->blueAccountReference($senderToken));
6441 0         0 $o->showSignature($envelope, $senderHash, $senderStore, $signedHash);
6442              
6443             # Recipients
6444 0         0 $o->{ui}->space;
6445 0         0 $o->{ui}->title('Encrypted for');
6446 0         0 for my $child ($envelope->child('encrypted for')->children) {
6447 0         0 $o->showActorHash24($child->bytes);
6448             }
6449              
6450 0         0 $o->{ui}->popIndent;
6451 0         0 return {aesKey => $aesKey, senderHash => $senderHash, senderStore => $senderStore, isValid => 1};
6452             }
6453              
6454             sub processStreamEnvelope {
6455 0     0   0 my $o = shift;
6456 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
6457              
6458 0         0 $o->{ui}->space;
6459 0         0 $o->{ui}->title('Stream envelope');
6460 0         0 $o->{ui}->line($o->{ui}->gold('cds show record ', $o->{hash}->hex, ' on ', $o->{actor}->storeReference($o->{store})));
6461              
6462             # Get the head
6463 0         0 my $streamHead = $o->processStreamHead($envelope->child('head')->hashValue);
6464 0 0 0     0 $o->{ui}->pRed('The stream head cannot be opened. Open the stream head envelope for details.') if ! $streamHead || ! $streamHead->{isValid};
6465              
6466             # Get the content
6467 0         0 my $encryptedBytes = $envelope->child('content')->bytesValue;
6468              
6469             # Get the CTR
6470 0         0 $o->{ui}->space;
6471 0         0 $o->{ui}->title('CTR');
6472 0         0 my $ctr = $envelope->child('ctr')->bytesValue;
6473 0 0       0 if (length $ctr == 16) {
6474 0         0 $o->{ui}->line(unpack('H*', $ctr));
6475             } else {
6476 0         0 $o->{ui}->pRed('The CTR value is invalid.');
6477             }
6478              
6479 0 0       0 return $o->{ui}->space if ! $streamHead;
6480 0 0       0 return $o->{ui}->space if ! $streamHead->{aesKey};
6481              
6482             # Get and verify the MAC
6483 0         0 $o->{ui}->space;
6484 0         0 $o->{ui}->title('Message authentication (MAC)');
6485 0         0 my $mac = $envelope->child('mac')->bytesValue;
6486 0         0 my $signedHash = CDS::Hash->calculateFor($encryptedBytes);
6487 0         0 my $expectedMac = CDS::C::aesCrypt($signedHash->bytes, $streamHead->{aesKey}, $ctr);
6488 0 0       0 if ($mac eq $expectedMac) {
6489 0         0 $o->{ui}->pGreen('The MAC valid.');
6490             } else {
6491 0         0 $o->{ui}->pRed('The MAC is invalid.');
6492             }
6493              
6494             # Decrypt the content
6495 0         0 $o->{ui}->space;
6496 0         0 $o->{ui}->title('Content');
6497 0         0 my $contentObject = CDS::Object->fromBytes(CDS::C::aesCrypt($encryptedBytes, $streamHead->{aesKey}, CDS::C::counterPlusInt($ctr, 2)));
6498 0 0       0 if (! $contentObject) {
6499 0         0 $o->{ui}->pRed('The embedded content object is invalid, or the provided AES key (', unpack('H*', $streamHead->{aesKey}), ') is wrong.') ;
6500 0         0 $o->{ui}->space;
6501 0         0 return;
6502             }
6503              
6504 0         0 my $content = CDS::Record->fromObject($contentObject);
6505 0 0       0 return $o->{ui}->pRed('The content is not a record.') if ! $content;
6506 0 0       0 $o->{ui}->recordChildren($content, $streamHead->{senderStore} ? $o->{actor}->storeReference($streamHead->{senderStore}) : undef);
6507 0         0 $o->{ui}->space;
6508              
6509             # The envelope is valid
6510             #my $source = CDS::Source->new($o->{pool}->{keyPair}, $o->{actorOnStore}, 'messages', $entry->{hash});
6511             #return CDS::ReceivedMessage->new($o, $entry, $source, $envelope, $streamHead->senderStoreUrl, $streamHead->sender, $content, $streamHead);
6512              
6513             }
6514              
6515             sub showActorHash24 {
6516 0     0   0 my $o = shift;
6517 0         0 my $actorHashBytes = shift;
6518              
6519 0         0 my $actorHashHex = unpack('H*', $actorHashBytes);
6520 0 0       0 return $o->{ui}->line($o->{ui}->red($actorHashHex, ' (', length $actorHashBytes, ' instead of 24 bytes)')) if length $actorHashBytes != 24;
6521              
6522 0         0 my $actorName = $o->{actor}->actorLabelByHashStartBytes($actorHashBytes);
6523 0         0 $actorHashHex .= '·' x 16;
6524              
6525 0         0 my $keyPairHashBytes = $o->{keyPairToken}->keyPair->publicKey->hash->bytes;
6526 0         0 my $isMe = substr($keyPairHashBytes, 0, 24) eq $actorHashBytes;
6527 0 0       0 $o->{ui}->line($isMe ? $o->{ui}->violet($actorHashHex) : $actorHashHex, (defined $actorName ? $o->{ui}->blue(' '.$actorName) : ''));
    0          
6528 0         0 return $isMe;
6529             }
6530              
6531             sub showSignature {
6532 0     0   0 my $o = shift;
6533 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
6534 0 0 0     0 my $senderHash = shift; die 'wrong type '.ref($senderHash).' for $senderHash' if defined $senderHash && ref $senderHash ne 'CDS::Hash';
  0         0  
6535 0         0 my $senderStore = shift;
6536 0 0 0     0 my $signedHash = shift; die 'wrong type '.ref($signedHash).' for $signedHash' if defined $signedHash && ref $signedHash ne 'CDS::Hash';
  0         0  
6537              
6538             # Get the public key
6539 0         0 my $publicKey = $o->getPublicKey($senderHash, $senderStore);
6540 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;
6541              
6542             # Verify the signature
6543 0 0       0 if (CDS->verifyEnvelopeSignature($envelope, $publicKey, $signedHash)) {
6544 0         0 $o->{ui}->pGreen('The signature is valid.');
6545             } else {
6546 0         0 $o->{ui}->pRed('The signature is not valid.');
6547             }
6548             }
6549              
6550             sub getPublicKey {
6551 0     0   0 my $o = shift;
6552 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
6553 0         0 my $store = shift;
6554              
6555 0 0       0 return $o->{keyPairToken}->keyPair->publicKey if $hash->equals($o->{keyPairToken}->keyPair->publicKey->hash);
6556 0         0 return $o->{actor}->uiGetPublicKey($hash, $store, $o->{keyPairToken});
6557             }
6558              
6559             sub showEncryptedFor {
6560 0     0   0 my $o = shift;
6561 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
6562              
6563 0         0 $o->{ui}->space;
6564 0         0 $o->{ui}->title('Encrypted for');
6565              
6566 0         0 my $canDecrypt = 0;
6567 0         0 for my $child ($envelope->child('encrypted for')->children) {
6568 0 0       0 $canDecrypt = 1 if $o->showActorHash24($child->bytes);
6569             }
6570              
6571 0 0       0 return if $canDecrypt;
6572 0         0 $o->{ui}->space;
6573 0         0 my $keyPairHash = $o->{keyPairToken}->keyPair->publicKey->hash;
6574 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.');
6575             }
6576              
6577             sub decryptAesKey {
6578 0     0   0 my $o = shift;
6579 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
6580              
6581 0         0 my $keyPair = $o->{keyPairToken}->keyPair;
6582 0         0 my $hashBytes24 = substr($keyPair->publicKey->hash->bytes, 0, 24);
6583 0         0 my $child = $envelope->child('encrypted for')->child($hashBytes24);
6584              
6585 0         0 my $encryptedAesKey = $child->bytesValue;
6586 0 0       0 return if ! length $encryptedAesKey;
6587              
6588 0         0 my $aesKey = $keyPair->decrypt($encryptedAesKey);
6589 0 0 0     0 return $aesKey if defined $aesKey && length $aesKey == 32;
6590              
6591 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.');
6592 0         0 return;
6593             }
6594              
6595             # BEGIN AUTOGENERATED
6596             package CDS::Commands::Put;
6597              
6598             sub register {
6599 0     0   0 my $class = shift;
6600 0         0 my $cds = shift;
6601 0         0 my $help = shift;
6602              
6603 0         0 my $node000 = CDS::Parser::Node->new(0);
6604 0         0 my $node001 = CDS::Parser::Node->new(0);
6605 0         0 my $node002 = CDS::Parser::Node->new(0);
6606 0         0 my $node003 = CDS::Parser::Node->new(0);
6607 0         0 my $node004 = CDS::Parser::Node->new(0);
6608 0         0 my $node005 = CDS::Parser::Node->new(0);
6609 0         0 my $node006 = CDS::Parser::Node->new(0);
6610 0         0 my $node007 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
6611 0         0 my $node008 = CDS::Parser::Node->new(0);
6612 0         0 my $node009 = CDS::Parser::Node->new(0);
6613 0         0 my $node010 = CDS::Parser::Node->new(0);
6614 0         0 my $node011 = CDS::Parser::Node->new(0);
6615 0         0 my $node012 = CDS::Parser::Node->new(1);
6616 0         0 my $node013 = CDS::Parser::Node->new(0);
6617 0         0 my $node014 = CDS::Parser::Node->new(0);
6618 0         0 my $node015 = CDS::Parser::Node->new(0);
6619 0         0 my $node016 = CDS::Parser::Node->new(0);
6620 0         0 my $node017 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&put});
6621 0         0 $cds->addArrow($node000, 1, 0, 'put');
6622 0         0 $cds->addArrow($node001, 1, 0, 'put');
6623 0         0 $cds->addArrow($node002, 1, 0, 'put');
6624 0         0 $help->addArrow($node007, 1, 0, 'put');
6625 0         0 $node000->addArrow($node012, 1, 0, 'OBJECTFILE', \&collectObjectfile);
6626 0         0 $node001->addArrow($node003, 1, 0, 'object');
6627 0         0 $node002->addArrow($node004, 1, 0, 'public');
6628 0         0 $node003->addArrow($node008, 1, 0, 'with');
6629 0         0 $node004->addArrow($node005, 1, 0, 'key');
6630 0         0 $node005->addArrow($node006, 1, 0, 'of');
6631 0         0 $node006->addArrow($node012, 1, 0, 'KEYPAIR', \&collectKeypair);
6632 0         0 $node008->addDefault($node009);
6633 0         0 $node008->addDefault($node011);
6634 0         0 $node009->addArrow($node009, 1, 0, 'HASH', \&collectHash);
6635 0         0 $node009->addArrow($node010, 1, 0, 'HASH', \&collectHash);
6636 0         0 $node010->addArrow($node011, 1, 0, 'and');
6637 0         0 $node011->addArrow($node012, 1, 0, 'FILE', \&collectFile);
6638 0         0 $node012->addArrow($node013, 1, 0, 'encrypted');
6639 0         0 $node012->addDefault($node015);
6640 0         0 $node013->addArrow($node014, 1, 0, 'with');
6641 0         0 $node014->addArrow($node015, 1, 0, 'AESKEY', \&collectAeskey);
6642 0         0 $node015->addArrow($node016, 1, 0, 'onto');
6643 0         0 $node015->addDefault($node017);
6644 0         0 $node016->addArrow($node016, 1, 0, 'STORE', \&collectStore);
6645 0         0 $node016->addArrow($node017, 1, 0, 'STORE', \&collectStore);
6646             }
6647              
6648             sub collectAeskey {
6649 0     0   0 my $o = shift;
6650 0         0 my $label = shift;
6651 0         0 my $value = shift;
6652              
6653 0         0 $o->{aesKey} = $value;
6654             }
6655              
6656             sub collectFile {
6657 0     0   0 my $o = shift;
6658 0         0 my $label = shift;
6659 0         0 my $value = shift;
6660              
6661 0         0 $o->{dataFile} = $value;
6662             }
6663              
6664             sub collectHash {
6665 0     0   0 my $o = shift;
6666 0         0 my $label = shift;
6667 0         0 my $value = shift;
6668              
6669 0         0 push @{$o->{hashes}}, $value;
  0         0  
6670             }
6671              
6672             sub collectKeypair {
6673 0     0   0 my $o = shift;
6674 0         0 my $label = shift;
6675 0         0 my $value = shift;
6676              
6677 0         0 $o->{object} = $value->keyPair->publicKey->object;
6678             }
6679              
6680             sub collectObjectfile {
6681 0     0   0 my $o = shift;
6682 0         0 my $label = shift;
6683 0         0 my $value = shift;
6684              
6685 0         0 $o->{objectFile} = $value;
6686             }
6687              
6688             sub collectStore {
6689 0     0   0 my $o = shift;
6690 0         0 my $label = shift;
6691 0         0 my $value = shift;
6692              
6693 0         0 push @{$o->{stores}}, $value;
  0         0  
6694             }
6695              
6696             sub new {
6697 0     0   0 my $class = shift;
6698 0         0 my $actor = shift;
6699 0         0 bless {actor => $actor, ui => $actor->ui} }
6700              
6701             # END AUTOGENERATED
6702              
6703             # HTML FOLDER NAME store-put
6704             # HTML TITLE Put
6705             sub help {
6706 0     0   0 my $o = shift;
6707 0         0 my $cmd = shift;
6708              
6709 0         0 my $ui = $o->{ui};
6710 0         0 $ui->space;
6711 0         0 $ui->command('cds put FILE* [onto STORE*]');
6712 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.');
6713 0         0 $ui->space;
6714 0         0 $ui->command('cds put FILE encrypted with AESKEY [onto STORE*]');
6715 0         0 $ui->p('Encrypts the object before the upload.');
6716 0         0 $ui->space;
6717 0         0 $ui->command('cds put object with [HASH* and] FILE …');
6718 0         0 $ui->p('Creates an object with the HASHes as hash list and FILE as data.');
6719 0         0 $ui->space;
6720 0         0 $ui->command('cds put public key of KEYPAIR …');
6721 0         0 $ui->p('Uploads the public key of the indicated key pair onto the store.');
6722 0         0 $ui->space;
6723             }
6724              
6725             sub put {
6726 0     0   0 my $o = shift;
6727 0         0 my $cmd = shift;
6728              
6729 0         0 $o->{hashes} = [];
6730 0         0 $o->{stores} = [];
6731 0         0 $cmd->collect($o);
6732              
6733             # Stores
6734 0 0       0 push @{$o->{stores}}, $o->{actor}->preferredStore if ! scalar @{$o->{stores}};
  0         0  
  0         0  
6735              
6736 0         0 $o->{get} = [];
6737 0 0       0 return $o->putObject($o->{object}) if $o->{object};
6738 0 0       0 return $o->putObjectFile if $o->{objectFile};
6739 0         0 $o->putConstructedFile;
6740             }
6741              
6742             sub putObjectFile {
6743 0     0   0 my $o = shift;
6744              
6745 0         0 my $object = $o->{objectFile}->object;
6746              
6747             # Display object information
6748 0         0 $o->{ui}->space;
6749 0         0 $o->{ui}->title('Uploading ', $o->{objectFile}->file, ' ', $o->{ui}->gray($o->{ui}->niceFileSize($object->byteLength)));
6750 0 0       0 $o->{ui}->line($object->hashesCount == 1 ? '1 hash' : $object->hashesCount.' hashes');
6751 0         0 $o->{ui}->line($o->{ui}->niceFileSize(length $object->data).' data');
6752 0         0 $o->{ui}->space;
6753              
6754             # Upload
6755 0         0 $o->putObject($object);
6756             }
6757              
6758             sub putConstructedFile {
6759 0     0   0 my $o = shift;
6760              
6761             # Create the object
6762 0   0     0 my $data = CDS->readBytesFromFile($o->{dataFile}) // return $o->{ui}->error('Unable to read "', $o->{dataFile}, '".');
6763 0         0 my $header = pack('L>', scalar @{$o->{hashes}}) . join('', map { $_->bytes } @{$o->{hashes}});
  0         0  
  0         0  
  0         0  
6764 0         0 my $object = CDS::Object->create($header, $data);
6765              
6766             # Display object information
6767 0         0 $o->{ui}->space;
6768 0         0 $o->{ui}->title('Uploading new object ', $o->{ui}->gray($o->{ui}->niceFileSize(length $object->bytes)));
6769 0 0       0 $o->{ui}->line($object->hashesCount == 1 ? '1 hash' : $object->hashesCount.' hashes');
6770 0         0 $o->{ui}->line($o->{ui}->niceFileSize(length $object->data).' data from ', $o->{dataFile});
6771 0         0 $o->{ui}->space;
6772              
6773             # Upload
6774 0         0 $o->putObject($object);
6775             }
6776              
6777             sub putObject {
6778 0     0   0 my $o = shift;
6779 0 0 0     0 my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0         0  
6780              
6781 0         0 my $keyPair = $o->{actor}->preferredKeyPairToken->keyPair;
6782              
6783             # Encrypt it if desired
6784 0         0 my $objectBytes;
6785 0 0       0 if (defined $o->{aesKey}) {
6786 0         0 $object = $object->crypt($o->{aesKey});
6787 0         0 unshift @{$o->{get}}, ' decrypted with ', unpack('H*', $o->{aesKey}), ' ';
  0         0  
6788             }
6789              
6790             # Calculate the hash
6791 0         0 my $hash = $object->calculateHash;
6792              
6793             # Upload the object
6794 0         0 my $successfulStore;
6795 0         0 for my $store (@{$o->{stores}}) {
  0         0  
6796 0         0 my $error = $store->put($hash, $object, $keyPair);
6797 0 0       0 next if $error;
6798 0         0 $o->{ui}->pGreen('The object was uploaded onto ', $store->url, '.');
6799 0         0 $successfulStore = $store;
6800             }
6801              
6802             # Show the corresponding download line
6803 0 0       0 return if ! $successfulStore;
6804 0         0 $o->{ui}->space;
6805 0         0 $o->{ui}->line('To download the object, type:');
6806 0         0 $o->{ui}->line($o->{ui}->gold('cds get ', $hash->hex), $o->{ui}->gray(' on ', $successfulStore->url, @{$o->{get}}));
  0         0  
6807 0         0 $o->{ui}->space;
6808             }
6809              
6810             package CDS::Commands::Remember;
6811              
6812             # BEGIN AUTOGENERATED
6813              
6814             sub register {
6815 0     0   0 my $class = shift;
6816 0         0 my $cds = shift;
6817 0         0 my $help = shift;
6818              
6819 0         0 my $node000 = CDS::Parser::Node->new(0, {constructor => \&new, function => \&showLabels});
6820 0         0 my $node001 = CDS::Parser::Node->new(0);
6821 0         0 my $node002 = CDS::Parser::Node->new(0);
6822 0         0 my $node003 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
6823 0         0 my $node004 = CDS::Parser::Node->new(0);
6824 0         0 my $node005 = CDS::Parser::Node->new(0);
6825 0         0 my $node006 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&forget});
6826 0         0 my $node007 = CDS::Parser::Node->new(1);
6827 0         0 my $node008 = CDS::Parser::Node->new(0);
6828 0         0 my $node009 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&remember});
6829 0         0 $cds->addArrow($node000, 1, 0, 'remember');
6830 0         0 $cds->addArrow($node001, 1, 0, 'forget');
6831 0         0 $help->addArrow($node003, 1, 0, 'forget');
6832 0         0 $help->addArrow($node003, 1, 0, 'remember');
6833 0         0 $node000->addArrow($node004, 1, 0, 'ACTOR', \&collectActor);
6834 0         0 $node000->addArrow($node007, 1, 1, 'ACCOUNT', \&collectAccount);
6835 0         0 $node000->addArrow($node007, 1, 0, 'ACTOR', \&collectActor);
6836 0         0 $node000->addArrow($node007, 1, 0, 'KEYPAIR', \&collectKeypair);
6837 0         0 $node000->addArrow($node007, 1, 0, 'STORE', \&collectStore);
6838 0         0 $node001->addDefault($node002);
6839 0         0 $node002->addArrow($node002, 1, 0, 'LABEL', \&collectLabel);
6840 0         0 $node002->addArrow($node006, 1, 0, 'LABEL', \&collectLabel);
6841 0         0 $node004->addArrow($node005, 1, 0, 'on');
6842 0         0 $node005->addArrow($node007, 1, 0, 'STORE', \&collectStore);
6843 0         0 $node007->addArrow($node008, 1, 0, 'as');
6844 0         0 $node008->addArrow($node009, 1, 0, 'TEXT', \&collectText);
6845             }
6846              
6847             sub collectAccount {
6848 0     0   0 my $o = shift;
6849 0         0 my $label = shift;
6850 0         0 my $value = shift;
6851              
6852 0         0 $o->{store} = $value->cliStore;
6853 0         0 $o->{actorHash} = $value->actorHash;
6854             }
6855              
6856             sub collectActor {
6857 0     0   0 my $o = shift;
6858 0         0 my $label = shift;
6859 0         0 my $value = shift;
6860              
6861 0         0 $o->{actorHash} = $value;
6862             }
6863              
6864             sub collectKeypair {
6865 0     0   0 my $o = shift;
6866 0         0 my $label = shift;
6867 0         0 my $value = shift;
6868              
6869 0         0 $o->{keyPairToken} = $value;
6870             }
6871              
6872             sub collectLabel {
6873 0     0   0 my $o = shift;
6874 0         0 my $label = shift;
6875 0         0 my $value = shift;
6876              
6877 0         0 push @{$o->{forget}}, $value;
  0         0  
6878             }
6879              
6880             sub collectStore {
6881 0     0   0 my $o = shift;
6882 0         0 my $label = shift;
6883 0         0 my $value = shift;
6884              
6885 0         0 $o->{store} = $value;
6886             }
6887              
6888             sub collectText {
6889 0     0   0 my $o = shift;
6890 0         0 my $label = shift;
6891 0         0 my $value = shift;
6892              
6893 0         0 $o->{label} = $value;
6894             }
6895              
6896             sub new {
6897 0     0   0 my $class = shift;
6898 0         0 my $actor = shift;
6899 0         0 bless {actor => $actor, ui => $actor->ui} }
6900              
6901             # END AUTOGENERATED
6902              
6903             # HTML FOLDER NAME remember
6904             # HTML TITLE Remember
6905             sub help {
6906 0     0   0 my $o = shift;
6907 0         0 my $cmd = shift;
6908              
6909 0         0 my $ui = $o->{ui};
6910 0         0 $ui->space;
6911 0         0 $ui->command('cds remember');
6912 0         0 $ui->p('Shows all remembered values.');
6913 0         0 $ui->space;
6914 0         0 $ui->command('cds remember ACCOUNT|ACTOR|STORE|KEYPAIR as TEXT');
6915 0         0 $ui->command('cds remember ACTOR on STORE as TEXT');
6916 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 …).');
6917 0         0 $ui->space;
6918 0         0 $ui->p('Key pairs are stored as link (absolute path) to the key pair file, and specific to the device.');
6919 0         0 $ui->space;
6920 0         0 $ui->command('cds forget LABEL');
6921 0         0 $ui->p('Forgets the corresponding item.');
6922 0         0 $ui->space;
6923             }
6924              
6925             sub remember {
6926 0     0   0 my $o = shift;
6927 0         0 my $cmd = shift;
6928              
6929 0         0 $cmd->collect($o);
6930              
6931 0         0 my $record = CDS::Record->new;
6932 0 0       0 $record->add('store')->addText($o->{store}->url) if defined $o->{store};
6933 0 0       0 $record->add('actor')->add($o->{actorHash}->bytes) if defined $o->{actorHash};
6934 0 0       0 $record->add('key pair')->addText($o->{keyPairToken}->file) if defined $o->{keyPairToken};
6935 0         0 $o->{actor}->remember($o->{label}, $record);
6936 0         0 $o->{actor}->saveOrShowError;
6937             }
6938              
6939             sub forget {
6940 0     0   0 my $o = shift;
6941 0         0 my $cmd = shift;
6942              
6943 0         0 $o->{forget} = [];
6944 0         0 $cmd->collect($o);
6945              
6946 0         0 for my $label (@{$o->{forget}}) {
  0         0  
6947 0         0 $o->{actor}->groupRoot->child('labels')->child($label)->clear;
6948             }
6949              
6950 0         0 $o->{actor}->saveOrShowError;
6951             }
6952              
6953             sub showLabels {
6954 0     0   0 my $o = shift;
6955 0         0 my $cmd = shift;
6956              
6957 0         0 $o->{ui}->space;
6958 0         0 $o->showRememberedValues;
6959 0         0 $o->{ui}->space;
6960             }
6961              
6962             sub showRememberedValues {
6963 0     0   0 my $o = shift;
6964              
6965 0         0 my $hasLabel = 0;
6966 0         0 for my $child (sort { $a->{id} cmp $b->{id} } $o->{actor}->groupRoot->child('labels')->children) {
  0         0  
6967 0         0 my $record = $child->record;
6968 0         0 my $label = $o->{ui}->blue($o->{ui}->left(15, Encode::decode_utf8($child->label)));
6969              
6970 0         0 my $actorHash = CDS::Hash->fromBytes($record->child('actor')->bytesValue);
6971 0         0 my $storeUrl = $record->child('store')->textValue;
6972 0         0 my $keyPairFile = $record->child('key pair')->textValue;
6973              
6974 0 0       0 if (length $keyPairFile) {
6975 0         0 $o->{ui}->line($label, ' ', $o->{ui}->gray('key pair'), ' ', $keyPairFile);
6976 0         0 $hasLabel = 1;
6977             }
6978              
6979 0 0 0     0 if ($actorHash && length $storeUrl) {
    0          
    0          
6980 0         0 my $storeReference = $o->{actor}->blueStoreUrlReference($storeUrl);
6981 0         0 $o->{ui}->line($label, ' ', $o->{ui}->gray('account'), ' ', $actorHash->hex, ' on ', $storeReference);
6982 0         0 $hasLabel = 1;
6983             } elsif ($actorHash) {
6984 0         0 $o->{ui}->line($label, ' ', $o->{ui}->gray('actor'), ' ', $actorHash->hex);
6985 0         0 $hasLabel = 1;
6986             } elsif (length $storeUrl) {
6987 0         0 $o->{ui}->line($label, ' ', $o->{ui}->gray('store'), ' ', $storeUrl);
6988 0         0 $hasLabel = 1;
6989             }
6990              
6991 0         0 $o->showActorGroupLabel($label, $record->child('actor group'));
6992             }
6993              
6994 0 0       0 return if $hasLabel;
6995 0         0 $o->{ui}->line($o->{ui}->gray('none'));
6996             }
6997              
6998             sub showActorGroupLabel {
6999 0     0   0 my $o = shift;
7000 0         0 my $label = shift;
7001 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
7002              
7003 0 0       0 return if ! $record->contains('actor group');
7004              
7005 0         0 my $builder = CDS::ActorGroupBuilder->new;
7006 0         0 $builder->parse($record, 1);
7007              
7008 0         0 my $countActive = 0;
7009 0         0 my $countIdle = 0;
7010 0         0 my $newestActive = undef;
7011              
7012 0         0 for my $member ($builder->members) {
7013 0         0 my $isActive = $member->status eq 'active';
7014 0 0       0 $countActive += 1 if $isActive;
7015 0 0       0 $countIdle += 1 if $member->status eq 'idle';
7016              
7017 0 0       0 next if ! $isActive;
7018 0 0 0     0 next if $newestActive && $member->revision <= $newestActive->revision;
7019 0         0 $newestActive = $member;
7020             }
7021              
7022 0         0 my @line;
7023 0         0 push @line, $label, ' ', $o->{ui}->gray('actor group'), ' ';
7024 0 0       0 push @line, $newestActive->hash->hex, ' on ', $o->{actor}->blueStoreUrlReference($newestActive->storeUrl) if $newestActive;
7025 0 0       0 push @line, $o->{ui}->gray('(no active actor)') if ! $newestActive;
7026 0         0 push @line, $o->{ui}->green(' ', $countActive, ' active');
7027 0         0 my $discovered = $record->child('discovered')->integerValue;
7028 0 0       0 push @line, $o->{ui}->gray(' ', $o->{ui}->niceDateTimeLocal($discovered)) if $discovered;
7029 0         0 $o->{ui}->line(@line);
7030             }
7031              
7032             # BEGIN AUTOGENERATED
7033             package CDS::Commands::Select;
7034              
7035             sub register {
7036 0     0   0 my $class = shift;
7037 0         0 my $cds = shift;
7038 0         0 my $help = shift;
7039              
7040 0         0 my $node000 = CDS::Parser::Node->new(0);
7041 0         0 my $node001 = CDS::Parser::Node->new(0);
7042 0         0 my $node002 = CDS::Parser::Node->new(0);
7043 0         0 my $node003 = CDS::Parser::Node->new(0);
7044 0         0 my $node004 = CDS::Parser::Node->new(0);
7045 0         0 my $node005 = CDS::Parser::Node->new(0);
7046 0         0 my $node006 = CDS::Parser::Node->new(0);
7047 0         0 my $node007 = CDS::Parser::Node->new(0);
7048 0         0 my $node008 = CDS::Parser::Node->new(0);
7049 0         0 my $node009 = CDS::Parser::Node->new(0);
7050 0         0 my $node010 = CDS::Parser::Node->new(0);
7051 0         0 my $node011 = CDS::Parser::Node->new(0);
7052 0         0 my $node012 = CDS::Parser::Node->new(0);
7053 0         0 my $node013 = CDS::Parser::Node->new(0);
7054 0         0 my $node014 = CDS::Parser::Node->new(0);
7055 0         0 my $node015 = CDS::Parser::Node->new(0);
7056 0         0 my $node016 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
7057 0         0 my $node017 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showSelectionCmd});
7058 0         0 my $node018 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&unselectKeyPair});
7059 0         0 my $node019 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&unselectStore});
7060 0         0 my $node020 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&unselectActor});
7061 0         0 my $node021 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&unselectAll});
7062 0         0 my $node022 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&select});
7063 0         0 $cds->addArrow($node000, 1, 0, 'select');
7064 0         0 $cds->addArrow($node001, 1, 0, 'select');
7065 0         0 $cds->addArrow($node002, 1, 0, 'select');
7066 0         0 $cds->addArrow($node003, 1, 0, 'select');
7067 0         0 $cds->addArrow($node004, 1, 0, 'select');
7068 0         0 $cds->addArrow($node005, 1, 0, 'select');
7069 0         0 $cds->addArrow($node006, 1, 0, 'select');
7070 0         0 $cds->addArrow($node009, 1, 0, 'unselect');
7071 0         0 $cds->addArrow($node010, 1, 0, 'unselect');
7072 0         0 $cds->addArrow($node011, 1, 0, 'unselect');
7073 0         0 $cds->addArrow($node012, 1, 0, 'unselect');
7074 0         0 $cds->addArrow($node017, 1, 0, 'select');
7075 0         0 $help->addArrow($node016, 1, 0, 'select');
7076 0         0 $node000->addArrow($node022, 1, 0, 'KEYPAIR', \&collectKeypair);
7077 0         0 $node001->addArrow($node022, 1, 0, 'STORE', \&collectStore);
7078 0         0 $node002->addArrow($node014, 1, 0, 'ACTOR', \&collectActor);
7079 0         0 $node003->addArrow($node007, 1, 0, 'storage');
7080 0         0 $node004->addArrow($node008, 1, 0, 'messaging');
7081 0         0 $node005->addArrow($node022, 1, 0, 'ACTOR', \&collectActor);
7082 0         0 $node006->addArrow($node022, 1, 1, 'ACCOUNT', \&collectAccount);
7083 0         0 $node007->addArrow($node022, 1, 0, 'store', \&collectStore1);
7084 0         0 $node008->addArrow($node022, 1, 0, 'store', \&collectStore2);
7085 0         0 $node009->addArrow($node013, 1, 0, 'key');
7086 0         0 $node010->addArrow($node019, 1, 0, 'store');
7087 0         0 $node011->addArrow($node020, 1, 0, 'actor');
7088 0         0 $node012->addArrow($node021, 1, 0, 'all');
7089 0         0 $node013->addArrow($node018, 1, 0, 'pair');
7090 0         0 $node014->addArrow($node015, 1, 0, 'on');
7091 0         0 $node015->addArrow($node022, 1, 0, 'STORE', \&collectStore);
7092             }
7093              
7094             sub collectAccount {
7095 0     0   0 my $o = shift;
7096 0         0 my $label = shift;
7097 0         0 my $value = shift;
7098              
7099 0         0 $o->{store} = $value->cliStore;
7100 0         0 $o->{actorHash} = $value->actorHash;
7101             }
7102              
7103             sub collectActor {
7104 0     0   0 my $o = shift;
7105 0         0 my $label = shift;
7106 0         0 my $value = shift;
7107              
7108 0         0 $o->{actorHash} = $value;
7109             }
7110              
7111             sub collectKeypair {
7112 0     0   0 my $o = shift;
7113 0         0 my $label = shift;
7114 0         0 my $value = shift;
7115              
7116 0         0 $o->{keyPairToken} = $value;
7117 0         0 $o->{actorHash} = $value->keyPair->publicKey->hash;
7118             }
7119              
7120             sub collectStore {
7121 0     0   0 my $o = shift;
7122 0         0 my $label = shift;
7123 0         0 my $value = shift;
7124              
7125 0         0 $o->{store} = $value;
7126             }
7127              
7128             sub collectStore1 {
7129 0     0   0 my $o = shift;
7130 0         0 my $label = shift;
7131 0         0 my $value = shift;
7132              
7133 0         0 $o->{store} = $o->{actor}->storageStore;
7134             }
7135              
7136             sub collectStore2 {
7137 0     0   0 my $o = shift;
7138 0         0 my $label = shift;
7139 0         0 my $value = shift;
7140              
7141 0         0 $o->{store} = $o->{actor}->messagingStore;
7142             }
7143              
7144             sub new {
7145 0     0   0 my $class = shift;
7146 0         0 my $actor = shift;
7147 0         0 bless {actor => $actor, ui => $actor->ui} }
7148              
7149             # END AUTOGENERATED
7150              
7151             # HTML FOLDER NAME select
7152             # HTML TITLE Select
7153             sub help {
7154 0     0   0 my $o = shift;
7155 0         0 my $cmd = shift;
7156              
7157 0         0 my $ui = $o->{ui};
7158 0         0 $ui->space;
7159 0         0 $ui->command('cds select');
7160 0         0 $ui->p('Shows the current selection.');
7161 0         0 $ui->space;
7162 0         0 $ui->command('cds select KEYPAIR');
7163 0         0 $ui->p('Selects KEYPAIR on this terminal. Some commands will use this key pair by default.');
7164 0         0 $ui->space;
7165 0         0 $ui->command('cds unselect key pair');
7166 0         0 $ui->p('Removes the key pair selection.');
7167 0         0 $ui->space;
7168 0         0 $ui->command('cds select STORE');
7169 0         0 $ui->p('Selects STORE on this terminal. Some commands will use this store by default.');
7170 0         0 $ui->space;
7171 0         0 $ui->command('cds unselect store');
7172 0         0 $ui->p('Removes the store selection.');
7173 0         0 $ui->space;
7174 0         0 $ui->command('cds select ACTOR');
7175 0         0 $ui->p('Selects ACTOR on this terminal. Some commands will use this store by default.');
7176 0         0 $ui->space;
7177 0         0 $ui->command('cds unselect actor');
7178 0         0 $ui->p('Removes the actor selection.');
7179 0         0 $ui->space;
7180 0         0 $ui->command('cds unselect');
7181 0         0 $ui->p('Removes any selection.');
7182 0         0 $ui->space;
7183             }
7184              
7185             sub select {
7186 0     0   0 my $o = shift;
7187 0         0 my $cmd = shift;
7188              
7189 0         0 $cmd->collect($o);
7190              
7191 0 0       0 if ($o->{keyPairToken}) {
7192 0         0 $o->{actor}->sessionRoot->child('selected key pair')->setText($o->{keyPairToken}->file);
7193 0         0 $o->{ui}->pGreen('Key pair ', $o->{keyPairToken}->file, ' selected.');
7194             }
7195              
7196 0 0       0 if ($o->{store}) {
7197 0         0 $o->{actor}->sessionRoot->child('selected store')->setText($o->{store}->url);
7198 0         0 $o->{ui}->pGreen('Store ', $o->{store}->url, ' selected.');
7199             }
7200              
7201 0 0       0 if ($o->{actorHash}) {
7202 0         0 $o->{actor}->sessionRoot->child('selected actor')->setBytes($o->{actorHash}->bytes);
7203 0         0 $o->{ui}->pGreen('Actor ', $o->{actorHash}->hex, ' selected.');
7204             }
7205              
7206 0         0 $o->{actor}->saveOrShowError;
7207             }
7208              
7209             sub unselectKeyPair {
7210 0     0   0 my $o = shift;
7211 0         0 my $cmd = shift;
7212              
7213 0         0 $o->{actor}->sessionRoot->child('selected key pair')->clear;
7214 0         0 $o->{ui}->pGreen('Key pair selection cleared.');
7215 0         0 $o->{actor}->saveOrShowError;
7216             }
7217              
7218             sub unselectStore {
7219 0     0   0 my $o = shift;
7220 0         0 my $cmd = shift;
7221              
7222 0         0 $o->{actor}->sessionRoot->child('selected store')->clear;
7223 0         0 $o->{ui}->pGreen('Store selection cleared.');
7224 0         0 $o->{actor}->saveOrShowError;
7225             }
7226              
7227             sub unselectActor {
7228 0     0   0 my $o = shift;
7229 0         0 my $cmd = shift;
7230              
7231 0         0 $o->{actor}->sessionRoot->child('selected actor')->clear;
7232 0         0 $o->{ui}->pGreen('Actor selection cleared.');
7233 0         0 $o->{actor}->saveOrShowError;
7234             }
7235              
7236             sub unselectAll {
7237 0     0   0 my $o = shift;
7238 0         0 my $cmd = shift;
7239              
7240 0         0 $o->{actor}->sessionRoot->child('selected key pair')->clear;
7241 0         0 $o->{actor}->sessionRoot->child('selected store')->clear;
7242 0         0 $o->{actor}->sessionRoot->child('selected actor')->clear;
7243 0   0     0 $o->{actor}->saveOrShowError // return;
7244 0         0 $o->showSelection;
7245             }
7246              
7247             sub showSelectionCmd {
7248 0     0   0 my $o = shift;
7249 0         0 my $cmd = shift;
7250              
7251 0         0 $o->{ui}->space;
7252 0         0 $o->showSelection;
7253 0         0 $o->{ui}->space;
7254             }
7255              
7256             sub showSelection {
7257 0     0   0 my $o = shift;
7258              
7259 0         0 my $keyPairFile = $o->{actor}->sessionRoot->child('selected key pair')->textValue;
7260 0         0 my $storeUrl = $o->{actor}->sessionRoot->child('selected store')->textValue;
7261 0         0 my $actorBytes = $o->{actor}->sessionRoot->child('selected actor')->bytesValue;
7262              
7263 0 0       0 $o->{ui}->line($o->{ui}->darkBold('Selected key pair '), length $keyPairFile ? $keyPairFile : $o->{ui}->gray('none'));
7264 0 0       0 $o->{ui}->line($o->{ui}->darkBold('Selected store '), length $storeUrl ? $storeUrl : $o->{ui}->gray('none'));
7265 0 0       0 $o->{ui}->line($o->{ui}->darkBold('Selected actor '), length $actorBytes == 32 ? unpack('H*', $actorBytes) : $o->{ui}->gray('none'));
7266             }
7267              
7268             # BEGIN AUTOGENERATED
7269             package CDS::Commands::ShowCard;
7270              
7271             sub register {
7272 0     0   0 my $class = shift;
7273 0         0 my $cds = shift;
7274 0         0 my $help = shift;
7275              
7276 0         0 my $node000 = CDS::Parser::Node->new(0);
7277 0         0 my $node001 = CDS::Parser::Node->new(0);
7278 0         0 my $node002 = CDS::Parser::Node->new(0);
7279 0         0 my $node003 = CDS::Parser::Node->new(0);
7280 0         0 my $node004 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
7281 0         0 my $node005 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showMyCard});
7282 0         0 my $node006 = CDS::Parser::Node->new(1);
7283 0         0 my $node007 = CDS::Parser::Node->new(0);
7284 0         0 my $node008 = CDS::Parser::Node->new(0);
7285 0         0 my $node009 = CDS::Parser::Node->new(0);
7286 0         0 my $node010 = CDS::Parser::Node->new(0);
7287 0         0 my $node011 = CDS::Parser::Node->new(0);
7288 0         0 my $node012 = CDS::Parser::Node->new(0);
7289 0         0 my $node013 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showCard});
7290 0         0 $cds->addArrow($node001, 1, 0, 'show');
7291 0         0 $cds->addArrow($node002, 1, 0, 'show');
7292 0         0 $help->addArrow($node000, 1, 0, 'show');
7293 0         0 $node000->addArrow($node004, 1, 0, 'card');
7294 0         0 $node001->addArrow($node006, 1, 0, 'card');
7295 0         0 $node002->addArrow($node003, 1, 0, 'my');
7296 0         0 $node003->addArrow($node005, 1, 0, 'card');
7297 0         0 $node006->addArrow($node007, 1, 0, 'of');
7298 0         0 $node006->addArrow($node008, 1, 0, 'of');
7299 0         0 $node006->addArrow($node009, 1, 0, 'of');
7300 0         0 $node006->addArrow($node010, 1, 0, 'of');
7301 0         0 $node006->addDefault($node011);
7302 0         0 $node007->addArrow($node007, 1, 0, 'ACCOUNT', \&collectAccount);
7303 0         0 $node007->addArrow($node013, 1, 1, 'ACCOUNT', \&collectAccount);
7304 0         0 $node008->addArrow($node013, 1, 0, 'ACTORGROUP', \&collectActorgroup);
7305 0         0 $node009->addArrow($node011, 1, 0, 'KEYPAIR', \&collectKeypair);
7306 0         0 $node010->addArrow($node011, 1, 0, 'ACTOR', \&collectActor);
7307 0         0 $node011->addArrow($node012, 1, 0, 'on');
7308 0         0 $node011->addDefault($node013);
7309 0         0 $node012->addArrow($node012, 1, 0, 'STORE', \&collectStore);
7310 0         0 $node012->addArrow($node013, 1, 0, 'STORE', \&collectStore);
7311             }
7312              
7313             sub collectAccount {
7314 0     0   0 my $o = shift;
7315 0         0 my $label = shift;
7316 0         0 my $value = shift;
7317              
7318 0         0 push @{$o->{accountTokens}}, $value;
  0         0  
7319             }
7320              
7321             sub collectActor {
7322 0     0   0 my $o = shift;
7323 0         0 my $label = shift;
7324 0         0 my $value = shift;
7325              
7326 0         0 $o->{actorHash} = $value;
7327             }
7328              
7329             sub collectActorgroup {
7330 0     0   0 my $o = shift;
7331 0         0 my $label = shift;
7332 0         0 my $value = shift;
7333              
7334 0         0 for my $member ($value->actorGroup->members) {
7335 0         0 my $actorOnStore = $member->actorOnStore;
7336 0         0 $o->addKnownPublicKey($actorOnStore->publicKey);
7337 0         0 push @{$o->{accountTokens}}, CDS::AccountToken->new($actorOnStore->store, $actorOnStore->publicKey->hash);
  0         0  
7338             }
7339             }
7340              
7341             sub collectKeypair {
7342 0     0   0 my $o = shift;
7343 0         0 my $label = shift;
7344 0         0 my $value = shift;
7345              
7346 0         0 $o->{keyPairToken} = $value;
7347 0         0 $o->{actorHash} = $value->keyPair->publicKey->hash;
7348             }
7349              
7350             sub collectStore {
7351 0     0   0 my $o = shift;
7352 0         0 my $label = shift;
7353 0         0 my $value = shift;
7354              
7355 0         0 push @{$o->{stores}}, $value;
  0         0  
7356             }
7357              
7358             sub new {
7359 0     0   0 my $class = shift;
7360 0         0 my $actor = shift;
7361 0         0 bless {actor => $actor, ui => $actor->ui} }
7362              
7363             # END AUTOGENERATED
7364              
7365             # HTML FOLDER NAME show-card
7366             # HTML TITLE Show an actor's public card
7367             sub help {
7368 0     0   0 my $o = shift;
7369 0         0 my $cmd = shift;
7370              
7371 0         0 my $ui = $o->{ui};
7372 0         0 $ui->space;
7373 0         0 $ui->command('cds show card of ACCOUNT');
7374 0         0 $ui->command('cds show card of ACTOR [on STORE]');
7375 0         0 $ui->command('cds show card of KEYPAIR [on STORE]');
7376 0         0 $ui->p('Shows the card(s) of an actor.');
7377 0         0 $ui->space;
7378 0         0 $ui->command('cds show card of ACTORGROUP');
7379 0         0 $ui->p('Shows all cards of an actor group.');
7380 0         0 $ui->space;
7381 0         0 $ui->command('cds show card');
7382 0         0 $ui->p('Shows the card of the selected actor on the selected store.');
7383 0         0 $ui->space;
7384 0         0 $ui->command('cds show my card');
7385 0         0 $ui->p('Shows your own card.');
7386 0         0 $ui->space;
7387 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.');
7388 0         0 $ui->space;
7389 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.');
7390 0         0 $ui->space;
7391 0         0 $ui->p('You can publish your own card (i.e. the card of your main key pair) using');
7392 0         0 $ui->p(' cds announce');
7393 0         0 $ui->space;
7394             }
7395              
7396             sub showCard {
7397 0     0   0 my $o = shift;
7398 0         0 my $cmd = shift;
7399              
7400 0         0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken;
7401 0         0 $o->{stores} = [];
7402 0         0 $o->{accountTokens} = [];
7403 0         0 $o->{knownPublicKeys} = {};
7404 0         0 $cmd->collect($o);
7405              
7406             # Use actorHash/store
7407 0 0       0 if (! scalar @{$o->{accountTokens}}) {
  0         0  
7408 0 0       0 $o->{actorHash} = $o->{actor}->preferredActorHash if ! $o->{actorHash};
7409 0 0       0 push @{$o->{stores}}, $o->{actor}->preferredStores if ! scalar @{$o->{stores}};
  0         0  
  0         0  
7410 0         0 for my $store (@{$o->{stores}}) {
  0         0  
7411 0         0 push @{$o->{accountTokens}}, CDS::AccountToken->new($store, $o->{actorHash});
  0         0  
7412             }
7413             }
7414              
7415             # Show the cards
7416 0         0 $o->addKnownPublicKey($o->{keyPairToken}->keyPair->publicKey);
7417 0         0 $o->addKnownPublicKey($o->{actor}->keyPair->publicKey);
7418 0         0 for my $accountToken (@{$o->{accountTokens}}) {
  0         0  
7419 0         0 $o->processAccount($accountToken);
7420             }
7421              
7422 0         0 $o->{ui}->space;
7423             }
7424              
7425             sub showMyCard {
7426 0     0   0 my $o = shift;
7427 0         0 my $cmd = shift;
7428              
7429 0         0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken;
7430 0         0 $o->processAccount(CDS::AccountToken->new($o->{actor}->messagingStore, $o->{actor}->keyPair->publicKey->hash));
7431 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;
7432 0         0 $o->{ui}->space;
7433             }
7434              
7435             sub processAccount {
7436 0     0   0 my $o = shift;
7437 0         0 my $accountToken = shift;
7438              
7439 0         0 $o->{ui}->space;
7440              
7441             # Query the store
7442 0         0 my $store = $accountToken->cliStore;
7443 0         0 my ($hashes, $storeError) = $store->list($accountToken->actorHash, 'public', 0);
7444 0 0       0 if (defined $storeError) {
7445 0         0 $o->{ui}->title('public box of ', $o->{actor}->blueAccountReference($accountToken));
7446 0         0 return;
7447             }
7448              
7449             # Print the result
7450 0         0 my $count = scalar @$hashes;
7451 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          
7452 0 0       0 return if ! $count;
7453              
7454 0         0 foreach my $hash (sort { $a->bytes cmp $b->bytes } @$hashes) {
  0         0  
7455 0         0 $o->processEntry($accountToken, $hash);
7456             }
7457             }
7458              
7459             sub processEntry {
7460 0     0   0 my $o = shift;
7461 0         0 my $accountToken = shift;
7462 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
7463              
7464 0         0 my $keyPair = $o->{keyPairToken}->keyPair;
7465 0         0 my $store = $accountToken->cliStore;
7466 0         0 my $storeReference = $o->{actor}->storeReference($store);
7467              
7468             # Open the envelope
7469 0         0 $o->{ui}->line($o->{ui}->gold('cds open envelope ', $hash->hex), $o->{ui}->gray(' from ', $accountToken->actorHash->hex, ' on ', $storeReference));
7470              
7471 0   0     0 my $envelope = $o->{actor}->uiGetRecord($hash, $accountToken->cliStore, $o->{keyPairToken}) // return;
7472 0   0     0 my $publicKey = $o->getPublicKey($accountToken) // $o->{ui}->pRed('The owner\'s public key is missing. Skipping signature verification.');
7473 0   0     0 my $cardHash = $envelope->child('content')->hashValue // $o->{ui}->pRed('Missing content hash.');
7474 0 0 0     0 return $o->{ui}->pRed('Invalid signature.') if $publicKey && $cardHash && ! CDS->verifyEnvelopeSignature($envelope, $publicKey, $cardHash);
      0        
7475              
7476             # Read and show the card
7477 0 0       0 return if ! $cardHash;
7478 0         0 $o->{ui}->line($o->{ui}->gold('cds show record ', $cardHash->hex), $o->{ui}->gray(' on ', $storeReference));
7479 0   0     0 my $card = $o->{actor}->uiGetRecord($cardHash, $accountToken->cliStore, $o->{keyPairToken}) // return;
7480              
7481 0         0 $o->{ui}->pushIndent;
7482 0         0 $o->{ui}->recordChildren($card, $storeReference);
7483 0         0 $o->{ui}->popIndent;
7484 0         0 return;
7485             }
7486              
7487             sub getPublicKey {
7488 0     0   0 my $o = shift;
7489 0         0 my $accountToken = shift;
7490              
7491 0         0 my $hash = $accountToken->actorHash;
7492 0         0 my $knownPublicKey = $o->{knownPublicKeys}->{$hash->bytes};
7493 0 0       0 return $knownPublicKey if $knownPublicKey;
7494 0   0     0 my $publicKey = $o->{actor}->uiGetPublicKey($hash, $accountToken->cliStore, $o->{keyPairToken}) // return;
7495 0         0 $o->addKnownPublicKey($publicKey);
7496 0         0 return $publicKey;
7497             }
7498              
7499             sub addKnownPublicKey {
7500 0     0   0 my $o = shift;
7501 0 0 0     0 my $publicKey = shift; die 'wrong type '.ref($publicKey).' for $publicKey' if defined $publicKey && ref $publicKey ne 'CDS::PublicKey';
  0         0  
7502              
7503 0         0 $o->{knownPublicKeys}->{$publicKey->hash->bytes} = $publicKey;
7504             }
7505              
7506             # BEGIN AUTOGENERATED
7507             package CDS::Commands::ShowKeyPair;
7508              
7509             sub register {
7510 0     0   0 my $class = shift;
7511 0         0 my $cds = shift;
7512 0         0 my $help = shift;
7513              
7514 0         0 my $node000 = CDS::Parser::Node->new(0);
7515 0         0 my $node001 = CDS::Parser::Node->new(0);
7516 0         0 my $node002 = CDS::Parser::Node->new(0);
7517 0         0 my $node003 = CDS::Parser::Node->new(0);
7518 0         0 my $node004 = CDS::Parser::Node->new(0);
7519 0         0 my $node005 = CDS::Parser::Node->new(0);
7520 0         0 my $node006 = CDS::Parser::Node->new(0);
7521 0         0 my $node007 = CDS::Parser::Node->new(0);
7522 0         0 my $node008 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
7523 0         0 my $node009 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showKeyPair});
7524 0         0 my $node010 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showMyKeyPair});
7525 0         0 my $node011 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showSelectedKeyPair});
7526 0         0 $cds->addArrow($node002, 1, 0, 'show');
7527 0         0 $cds->addArrow($node003, 1, 0, 'show');
7528 0         0 $cds->addArrow($node004, 1, 0, 'show');
7529 0         0 $help->addArrow($node000, 1, 0, 'show');
7530 0         0 $node000->addArrow($node001, 1, 0, 'key');
7531 0         0 $node001->addArrow($node008, 1, 0, 'pair');
7532 0         0 $node002->addArrow($node009, 1, 0, 'KEYPAIR', \&collectKeypair);
7533 0         0 $node003->addArrow($node005, 1, 0, 'my');
7534 0         0 $node004->addArrow($node006, 1, 0, 'key');
7535 0         0 $node005->addArrow($node007, 1, 0, 'key');
7536 0         0 $node006->addArrow($node011, 1, 0, 'pair');
7537 0         0 $node007->addArrow($node010, 1, 0, 'pair');
7538             }
7539              
7540             sub collectKeypair {
7541 0     0   0 my $o = shift;
7542 0         0 my $label = shift;
7543 0         0 my $value = shift;
7544              
7545 0         0 $o->{keyPairToken} = $value;
7546             }
7547              
7548             sub new {
7549 0     0   0 my $class = shift;
7550 0         0 my $actor = shift;
7551 0         0 bless {actor => $actor, ui => $actor->ui} }
7552              
7553             # END AUTOGENERATED
7554              
7555             # HTML FOLDER NAME show-key-pair
7556             # HTML TITLE Show key pair
7557             sub help {
7558 0     0   0 my $o = shift;
7559 0         0 my $cmd = shift;
7560              
7561 0         0 my $ui = $o->{ui};
7562 0         0 $ui->space;
7563 0         0 $ui->command('cds show KEYPAIR');
7564 0         0 $ui->command('cds show my key pair');
7565 0         0 $ui->command('cds show key pair');
7566 0         0 $ui->p('Shows information about KEYPAIR, your key pair, or the currently selected key pair (see "cds use …").');
7567 0         0 $ui->space;
7568             }
7569              
7570             sub showKeyPair {
7571 0     0   0 my $o = shift;
7572 0         0 my $cmd = shift;
7573              
7574 0         0 $cmd->collect($o);
7575 0         0 $o->showAll($o->{keyPairToken});
7576             }
7577              
7578             sub showMyKeyPair {
7579 0     0   0 my $o = shift;
7580 0         0 my $cmd = shift;
7581              
7582 0         0 $cmd->collect($o);
7583 0         0 $o->showAll($o->{actor}->keyPairToken);
7584             }
7585              
7586             sub showSelectedKeyPair {
7587 0     0   0 my $o = shift;
7588 0         0 my $cmd = shift;
7589              
7590 0         0 $cmd->collect($o);
7591 0         0 $o->showAll($o->{actor}->preferredKeyPairToken);
7592             }
7593              
7594             sub show {
7595 0     0   0 my $o = shift;
7596 0         0 my $keyPairToken = shift;
7597              
7598 0 0       0 $o->{ui}->line($o->{ui}->darkBold('File '), $keyPairToken->file) if defined $keyPairToken->file;
7599 0         0 $o->{ui}->line($o->{ui}->darkBold('Hash '), $keyPairToken->keyPair->publicKey->hash->hex);
7600             }
7601              
7602             sub showAll {
7603 0     0   0 my $o = shift;
7604 0         0 my $keyPairToken = shift;
7605              
7606 0         0 $o->{ui}->space;
7607 0         0 $o->{ui}->title('Key pair');
7608 0         0 $o->show($keyPairToken);
7609 0         0 $o->showPublicKeyObject($keyPairToken);
7610 0         0 $o->showPublicKey($keyPairToken);
7611 0         0 $o->showPrivateKey($keyPairToken);
7612 0         0 $o->{ui}->space;
7613             }
7614              
7615             sub showPublicKeyObject {
7616 0     0   0 my $o = shift;
7617 0         0 my $keyPairToken = shift;
7618              
7619 0         0 my $object = $keyPairToken->keyPair->publicKey->object;
7620 0         0 $o->{ui}->space;
7621 0         0 $o->{ui}->title('Public key object');
7622 0         0 $o->byteData(' ', $object->bytes);
7623             }
7624              
7625             sub showPublicKey {
7626 0     0   0 my $o = shift;
7627 0         0 my $keyPairToken = shift;
7628              
7629 0         0 my $rsaPublicKey = $keyPairToken->keyPair->publicKey->{rsaPublicKey};
7630 0         0 $o->{ui}->space;
7631 0         0 $o->{ui}->title('Public key');
7632 0         0 $o->byteData('e ', CDS::C::publicKeyE($rsaPublicKey));
7633 0         0 $o->byteData('n ', CDS::C::publicKeyN($rsaPublicKey));
7634             }
7635              
7636             sub showPrivateKey {
7637 0     0   0 my $o = shift;
7638 0         0 my $keyPairToken = shift;
7639              
7640 0         0 my $rsaPrivateKey = $keyPairToken->keyPair->{rsaPrivateKey};
7641 0         0 $o->{ui}->space;
7642 0         0 $o->{ui}->title('Private key');
7643 0         0 $o->byteData('e ', CDS::C::privateKeyE($rsaPrivateKey));
7644 0         0 $o->byteData('p ', CDS::C::privateKeyP($rsaPrivateKey));
7645 0         0 $o->byteData('q ', CDS::C::privateKeyQ($rsaPrivateKey));
7646             }
7647              
7648             sub byteData {
7649 0     0   0 my $o = shift;
7650 0         0 my $label = shift;
7651 0         0 my $bytes = shift;
7652              
7653 0         0 my $hex = unpack('H*', $bytes);
7654 0         0 $o->{ui}->line($o->{ui}->darkBold($label), substr($hex, 0, 64));
7655              
7656 0         0 my $start = 64;
7657 0         0 my $spaces = ' ' x length $label;
7658 0         0 while ($start < length $hex) {
7659 0         0 $o->{ui}->line($spaces, substr($hex, $start, 64));
7660 0         0 $start += 64;
7661             }
7662             }
7663              
7664             # BEGIN AUTOGENERATED
7665             package CDS::Commands::ShowMessages;
7666              
7667             sub register {
7668 0     0   0 my $class = shift;
7669 0         0 my $cds = shift;
7670 0         0 my $help = shift;
7671              
7672 0         0 my $node000 = CDS::Parser::Node->new(0);
7673 0         0 my $node001 = CDS::Parser::Node->new(0);
7674 0         0 my $node002 = CDS::Parser::Node->new(0);
7675 0         0 my $node003 = CDS::Parser::Node->new(0);
7676 0         0 my $node004 = CDS::Parser::Node->new(0);
7677 0         0 my $node005 = CDS::Parser::Node->new(0);
7678 0         0 my $node006 = CDS::Parser::Node->new(0);
7679 0         0 my $node007 = CDS::Parser::Node->new(0);
7680 0         0 my $node008 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
7681 0         0 my $node009 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showMessagesOfSelected});
7682 0         0 my $node010 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showMyMessages});
7683 0         0 my $node011 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showOurMessages});
7684 0         0 my $node012 = CDS::Parser::Node->new(1);
7685 0         0 my $node013 = CDS::Parser::Node->new(0);
7686 0         0 my $node014 = CDS::Parser::Node->new(0);
7687 0         0 my $node015 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showMessages});
7688 0         0 $cds->addArrow($node001, 1, 0, 'show');
7689 0         0 $cds->addArrow($node002, 1, 0, 'show');
7690 0         0 $cds->addArrow($node003, 1, 0, 'show');
7691 0         0 $cds->addArrow($node004, 1, 0, 'show');
7692 0         0 $help->addArrow($node000, 1, 0, 'show');
7693 0         0 $node000->addArrow($node008, 1, 0, 'messages');
7694 0         0 $node001->addArrow($node005, 1, 0, 'messages');
7695 0         0 $node002->addArrow($node006, 1, 0, 'my');
7696 0         0 $node003->addArrow($node009, 1, 0, 'messages');
7697 0         0 $node004->addArrow($node007, 1, 0, 'our');
7698 0         0 $node005->addArrow($node012, 1, 0, 'of');
7699 0         0 $node006->addArrow($node010, 1, 0, 'messages');
7700 0         0 $node007->addArrow($node011, 1, 0, 'messages');
7701 0         0 $node012->addArrow($node013, 1, 0, 'ACTOR', \&collectActor);
7702 0         0 $node012->addArrow($node013, 1, 0, 'KEYPAIR', \&collectKeypair);
7703 0         0 $node012->addArrow($node015, 1, 1, 'ACCOUNT', \&collectAccount);
7704 0         0 $node012->addArrow($node015, 1, 0, 'ACTOR', \&collectActor1);
7705 0         0 $node012->addArrow($node015, 1, 0, 'ACTORGROUP', \&collectActorgroup);
7706 0         0 $node012->addArrow($node015, 1, 0, 'KEYPAIR', \&collectKeypair1);
7707 0         0 $node013->addArrow($node014, 1, 0, 'on');
7708 0         0 $node014->addArrow($node015, 1, 0, 'STORE', \&collectStore);
7709             }
7710              
7711             sub collectAccount {
7712 0     0   0 my $o = shift;
7713 0         0 my $label = shift;
7714 0         0 my $value = shift;
7715              
7716 0         0 push @{$o->{accountTokens}}, $value;
  0         0  
7717             }
7718              
7719             sub collectActor {
7720 0     0   0 my $o = shift;
7721 0         0 my $label = shift;
7722 0         0 my $value = shift;
7723              
7724 0         0 $o->{actorHash} = $value;
7725             }
7726              
7727             sub collectActor1 {
7728 0     0   0 my $o = shift;
7729 0         0 my $label = shift;
7730 0         0 my $value = shift;
7731              
7732 0         0 push @{$o->{accountTokens}}, CDS::AccountToken->new($o->{actor}->preferredStore, $value);
  0         0  
7733             }
7734              
7735             sub collectActorgroup {
7736 0     0   0 my $o = shift;
7737 0         0 my $label = shift;
7738 0         0 my $value = shift;
7739              
7740 0         0 for my $member ($value->actorGroup->members) {
7741 0         0 push @{$o->{accountTokens}}, CDS::AccountToken->new($member->actorOnStore->store, $member->actorOnStore->publicKey->hash);
  0         0  
7742             }
7743             }
7744              
7745             sub collectKeypair {
7746 0     0   0 my $o = shift;
7747 0         0 my $label = shift;
7748 0         0 my $value = shift;
7749              
7750 0         0 $o->{keyPairToken} = $value;
7751 0         0 $o->{actorHash} = $value->keyPair->publicKey->hash;
7752             }
7753              
7754             sub collectKeypair1 {
7755 0     0   0 my $o = shift;
7756 0         0 my $label = shift;
7757 0         0 my $value = shift;
7758              
7759 0         0 $o->{keyPairToken} = $value;
7760 0         0 push @{$o->{accountTokens}}, CDS::AccountToken->new($o->{actor}->preferredStore, $value->publicKey->hash);
  0         0  
7761             }
7762              
7763             sub collectStore {
7764 0     0   0 my $o = shift;
7765 0         0 my $label = shift;
7766 0         0 my $value = shift;
7767              
7768 0         0 push @{$o->{accountTokens}}, CDS::AccountToken->new($value, $o->{actorHash});
  0         0  
7769 0         0 delete $o->{actorHash};
7770             }
7771              
7772             sub new {
7773 0     0   0 my $class = shift;
7774 0         0 my $actor = shift;
7775 0         0 bless {actor => $actor, ui => $actor->ui} }
7776              
7777             # END AUTOGENERATED
7778              
7779             # HTML FOLDER NAME show-messages
7780             # HTML TITLE Show messages
7781             sub help {
7782 0     0   0 my $o = shift;
7783 0         0 my $cmd = shift;
7784              
7785 0         0 my $ui = $o->{ui};
7786 0         0 $ui->space;
7787 0         0 $ui->command('cds show messages of ACCOUNT');
7788 0         0 $ui->command('cds show messages of ACTOR|KEYPAIR [on STORE]');
7789 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.');
7790 0         0 $ui->space;
7791 0         0 $ui->command('cds show messages of ACTORGROUP');
7792 0         0 $ui->p('Shows all messages of all actors of that group.');
7793 0         0 $ui->space;
7794 0         0 $ui->command('cds show messages');
7795 0         0 $ui->p('Shows the messages of the selected key pair on the selected store.');
7796 0         0 $ui->space;
7797 0         0 $ui->command('cds show my messages');
7798 0         0 $ui->p('Shows your messages.');
7799 0         0 $ui->space;
7800 0         0 $ui->command('cds show our messages');
7801 0         0 $ui->p('Shows all messages of your actor group.');
7802 0         0 $ui->space;
7803 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.');
7804 0         0 $ui->space;
7805 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.');
7806 0         0 $ui->space;
7807 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.');
7808 0         0 $ui->space;
7809             }
7810              
7811             sub showMessagesOfSelected {
7812 0     0   0 my $o = shift;
7813 0         0 my $cmd = shift;
7814              
7815 0         0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken;
7816 0         0 $o->processAccounts(CDS::AccountToken->new($o->{actor}->preferredStore, $o->{actor}->preferredActorHash));
7817             }
7818              
7819             sub showMyMessages {
7820 0     0   0 my $o = shift;
7821 0         0 my $cmd = shift;
7822              
7823 0         0 $o->{keyPairToken} = $o->{actor}->keyPairToken;
7824 0         0 my $actorHash = $o->{actor}->keyPair->publicKey->hash;
7825 0         0 my $store = $o->{actor}->messagingStore;
7826 0         0 $o->processAccounts(CDS::AccountToken->new($store, $actorHash));
7827             }
7828              
7829             sub showOurMessages {
7830 0     0   0 my $o = shift;
7831 0         0 my $cmd = shift;
7832              
7833 0         0 $o->{keyPairToken} = $o->{actor}->keyPairToken;
7834              
7835 0         0 my @accountTokens;
7836 0         0 for my $child ($o->{actor}->actorGroupSelector->children) {
7837 0 0       0 next if $child->child('revoked')->isSet;
7838 0 0       0 next if ! $child->child('active')->isSet;
7839              
7840 0         0 my $record = $child->record;
7841 0   0     0 my $actorHash = $record->child('hash')->hashValue // next;
7842 0         0 my $storeUrl = $record->child('store')->textValue;
7843 0   0     0 my $store = $o->{actor}->storeForUrl($storeUrl) // next;
7844 0         0 push @accountTokens, CDS::AccountToken->new($store, $actorHash);
7845             }
7846              
7847 0         0 $o->processAccounts(@accountTokens);
7848             }
7849              
7850             sub showMessages {
7851 0     0   0 my $o = shift;
7852 0         0 my $cmd = shift;
7853              
7854 0         0 $o->{accountTokens} = [];
7855 0         0 $cmd->collect($o);
7856              
7857             # Unless a key pair was provided, use the selected key pair
7858 0 0       0 $o->{keyPairToken} = $o->{actor}->keyPairToken if ! $o->{keyPairToken};
7859              
7860 0         0 $o->processAccounts(@{$o->{accountTokens}});
  0         0  
7861             }
7862              
7863             sub processAccounts {
7864 0     0   0 my $o = shift;
7865              
7866             # Initialize the statistics
7867 0         0 $o->{countValid} = 0;
7868 0         0 $o->{countInvalid} = 0;
7869              
7870             # Show the messages of all selected accounts
7871 0         0 for my $accountToken (@_) {
7872 0         0 CDS::Commands::ShowMessages::ProcessAccount->new($o, $accountToken);
7873             }
7874              
7875             # Show the statistics
7876 0         0 $o->{ui}->space;
7877 0         0 $o->{ui}->title('Total');
7878 0 0       0 $o->{ui}->line(scalar @_, ' account', scalar @_ == 1 ? '' : 's');
7879 0 0       0 $o->{ui}->line($o->{countValid}, ' message', $o->{countValid} == 1 ? '' : 's');
7880 0 0       0 $o->{ui}->line($o->{countInvalid}, ' invalid message', $o->{countInvalid} == 1 ? '' : 's') if $o->{countInvalid};
    0          
7881 0         0 $o->{ui}->space;
7882             }
7883              
7884             package CDS::Commands::ShowMessages::ProcessAccount;
7885              
7886             sub new {
7887 0     0   0 my $class = shift;
7888 0         0 my $cmd = shift;
7889 0         0 my $accountToken = shift;
7890              
7891 0         0 my $o = bless {
7892             cmd => $cmd,
7893             accountToken => $accountToken,
7894             countValid => 0,
7895             countInvalid => 0,
7896             };
7897              
7898 0         0 $cmd->{ui}->space;
7899 0         0 $cmd->{ui}->title('Messages of ', $cmd->{actor}->blueAccountReference($accountToken));
7900              
7901             # Get the public key
7902 0   0     0 my $publicKey = $o->getPublicKey // return;
7903              
7904             # Read all messages
7905 0         0 my $publicKeyCache = CDS::PublicKeyCache->new(128);
7906 0         0 my $pool = CDS::MessageBoxReaderPool->new($cmd->{keyPairToken}->keyPair, $publicKeyCache, $o);
7907 0         0 my $reader = CDS::MessageBoxReader->new($pool, CDS::ActorOnStore->new($publicKey, $accountToken->cliStore));
7908 0         0 $reader->read;
7909              
7910 0 0       0 $cmd->{ui}->line($cmd->{ui}->gray('No messages.')) if $o->{countValid} + $o->{countInvalid} == 0;
7911             }
7912              
7913             sub getPublicKey {
7914 0     0   0 my $o = shift;
7915              
7916             # Use the keypair's public key if possible
7917 0 0       0 return $o->{cmd}->{keyPairToken}->keyPair->publicKey if $o->{accountToken}->actorHash->equals($o->{cmd}->{keyPairToken}->keyPair->publicKey->hash);
7918              
7919             # Retrieve the public key
7920 0         0 return $o->{cmd}->{actor}->uiGetPublicKey($o->{accountToken}->actorHash, $o->{accountToken}->cliStore, $o->{cmd}->{keyPairToken});
7921             }
7922              
7923             sub onMessageBoxVerifyStore {
7924 0     0   0 my $o = shift;
7925 0         0 my $senderStoreUrl = shift;
7926 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
7927 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
7928 0 0 0     0 my $senderHash = shift; die 'wrong type '.ref($senderHash).' for $senderHash' if defined $senderHash && ref $senderHash ne 'CDS::Hash';
  0         0  
7929              
7930 0         0 return $o->{cmd}->{actor}->storeForUrl($senderStoreUrl);
7931             }
7932              
7933             sub onMessageBoxEntry {
7934 0     0   0 my $o = shift;
7935 0         0 my $message = shift;
7936              
7937 0         0 $o->{countValid} += 1;
7938 0         0 $o->{cmd}->{countValid} += 1;
7939              
7940 0         0 my $ui = $o->{cmd}->{ui};
7941 0         0 my $sender = CDS::AccountToken->new($message->sender->store, $message->sender->publicKey->hash);
7942              
7943 0         0 $ui->space;
7944 0         0 $ui->title($message->source->hash->hex);
7945 0         0 $ui->line('from ', $o->{cmd}->{actor}->blueAccountReference($sender));
7946 0         0 $ui->line('for ', $o->{cmd}->{actor}->blueAccountReference($o->{accountToken}));
7947 0         0 $ui->space;
7948 0         0 $ui->recordChildren($message->content);
7949             }
7950              
7951             sub onMessageBoxInvalidEntry {
7952 0     0   0 my $o = shift;
7953 0 0 0     0 my $source = shift; die 'wrong type '.ref($source).' for $source' if defined $source && ref $source ne 'CDS::Source';
  0         0  
7954 0         0 my $reason = shift;
7955              
7956 0         0 $o->{countInvalid} += 1;
7957 0         0 $o->{cmd}->{countInvalid} += 1;
7958              
7959 0         0 my $ui = $o->{cmd}->{ui};
7960 0         0 my $hashHex = $source->hash->hex;
7961 0         0 my $storeReference = $o->{cmd}->{actor}->storeReference($o->{accountToken}->cliStore);
7962              
7963 0         0 $ui->space;
7964 0         0 $ui->title($hashHex);
7965 0         0 $ui->pOrange($reason);
7966 0         0 $ui->space;
7967 0         0 $ui->p('You may use the following commands to check out the envelope:');
7968 0         0 $ui->line($ui->gold(' cds open envelope ', $hashHex, ' on ', $storeReference));
7969 0         0 $ui->line($ui->gold(' cds show record ', $hashHex, ' on ', $storeReference));
7970 0         0 $ui->line($ui->gold(' cds show hashes and data of ', $hashHex, ' on ', $storeReference));
7971             }
7972              
7973             # BEGIN AUTOGENERATED
7974             package CDS::Commands::ShowObject;
7975              
7976             sub register {
7977 0     0   0 my $class = shift;
7978 0         0 my $cds = shift;
7979 0         0 my $help = shift;
7980              
7981 0         0 my $node000 = CDS::Parser::Node->new(0);
7982 0         0 my $node001 = CDS::Parser::Node->new(0);
7983 0         0 my $node002 = CDS::Parser::Node->new(0);
7984 0         0 my $node003 = CDS::Parser::Node->new(0);
7985 0         0 my $node004 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
7986 0         0 my $node005 = CDS::Parser::Node->new(1);
7987 0         0 my $node006 = CDS::Parser::Node->new(0);
7988 0         0 my $node007 = CDS::Parser::Node->new(0);
7989 0         0 my $node008 = CDS::Parser::Node->new(0);
7990 0         0 my $node009 = CDS::Parser::Node->new(0);
7991 0         0 my $node010 = CDS::Parser::Node->new(1);
7992 0         0 my $node011 = CDS::Parser::Node->new(0);
7993 0         0 my $node012 = CDS::Parser::Node->new(0);
7994 0         0 my $node013 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&show});
7995 0         0 $cds->addArrow($node000, 1, 0, 'show');
7996 0         0 $cds->addArrow($node001, 1, 0, 'show');
7997 0         0 $cds->addArrow($node003, 1, 0, 'show');
7998 0         0 $help->addArrow($node002, 1, 0, 'show');
7999 0         0 $node000->addArrow($node006, 1, 0, 'object', \&collectObject);
8000 0         0 $node001->addArrow($node006, 1, 0, 'record', \&collectRecord);
8001 0         0 $node002->addArrow($node004, 1, 0, 'bytes');
8002 0         0 $node002->addArrow($node004, 1, 0, 'data');
8003 0         0 $node002->addArrow($node004, 1, 0, 'hash');
8004 0         0 $node002->addArrow($node004, 1, 0, 'hashes');
8005 0         0 $node002->addArrow($node004, 1, 0, 'object');
8006 0         0 $node002->addArrow($node004, 1, 0, 'record');
8007 0         0 $node002->addArrow($node004, 1, 0, 'size');
8008 0         0 $node003->addArrow($node005, 1, 0, 'bytes', \&collectBytes);
8009 0         0 $node003->addArrow($node005, 1, 0, 'data', \&collectData);
8010 0         0 $node003->addArrow($node005, 1, 0, 'hash', \&collectHash);
8011 0         0 $node003->addArrow($node005, 1, 0, 'hashes', \&collectHashes);
8012 0         0 $node003->addArrow($node005, 1, 0, 'record', \&collectRecord);
8013 0         0 $node003->addArrow($node005, 1, 0, 'size', \&collectSize);
8014 0         0 $node005->addArrow($node003, 1, 0, 'and');
8015 0         0 $node005->addArrow($node006, 1, 0, 'of');
8016 0         0 $node006->addArrow($node007, 1, 0, 'HASH', \&collectHash1);
8017 0         0 $node006->addArrow($node010, 1, 1, 'FILE', \&collectFile);
8018 0         0 $node006->addArrow($node010, 1, 0, 'HASH', \&collectHash2);
8019 0         0 $node006->addArrow($node010, 1, 0, 'OBJECT', \&collectObject1);
8020 0         0 $node007->addArrow($node008, 1, 0, 'on');
8021 0         0 $node007->addArrow($node009, 0, 0, 'from');
8022 0         0 $node008->addArrow($node010, 1, 0, 'STORE', \&collectStore);
8023 0         0 $node009->addArrow($node010, 0, 0, 'STORE', \&collectStore);
8024 0         0 $node010->addArrow($node011, 1, 0, 'decrypted');
8025 0         0 $node010->addDefault($node013);
8026 0         0 $node011->addArrow($node012, 1, 0, 'with');
8027 0         0 $node012->addArrow($node013, 1, 0, 'AESKEY', \&collectAeskey);
8028             }
8029              
8030             sub collectAeskey {
8031 0     0   0 my $o = shift;
8032 0         0 my $label = shift;
8033 0         0 my $value = shift;
8034              
8035 0         0 $o->{aesKey} = $value;
8036             }
8037              
8038             sub collectBytes {
8039 0     0   0 my $o = shift;
8040 0         0 my $label = shift;
8041 0         0 my $value = shift;
8042              
8043 0         0 $o->{showBytes} = 1;
8044             }
8045              
8046             sub collectData {
8047 0     0   0 my $o = shift;
8048 0         0 my $label = shift;
8049 0         0 my $value = shift;
8050              
8051 0         0 $o->{showData} = 1;
8052             }
8053              
8054             sub collectFile {
8055 0     0   0 my $o = shift;
8056 0         0 my $label = shift;
8057 0         0 my $value = shift;
8058              
8059 0         0 $o->{file} = $value;
8060             }
8061              
8062             sub collectHash {
8063 0     0   0 my $o = shift;
8064 0         0 my $label = shift;
8065 0         0 my $value = shift;
8066              
8067 0         0 $o->{showHash} = 1;
8068             }
8069              
8070             sub collectHash1 {
8071 0     0   0 my $o = shift;
8072 0         0 my $label = shift;
8073 0         0 my $value = shift;
8074              
8075 0         0 $o->{hash} = $value;
8076             }
8077              
8078             sub collectHash2 {
8079 0     0   0 my $o = shift;
8080 0         0 my $label = shift;
8081 0         0 my $value = shift;
8082              
8083 0         0 $o->{hash} = $value;
8084 0         0 $o->{store} = $o->{actor}->preferredStore;
8085             }
8086              
8087             sub collectHashes {
8088 0     0   0 my $o = shift;
8089 0         0 my $label = shift;
8090 0         0 my $value = shift;
8091              
8092 0         0 $o->{showHashes} = 1;
8093             }
8094              
8095             sub collectObject {
8096 0     0   0 my $o = shift;
8097 0         0 my $label = shift;
8098 0         0 my $value = shift;
8099              
8100 0         0 $o->{showHashes} = 1;
8101 0         0 $o->{showData} = 1;
8102             }
8103              
8104             sub collectObject1 {
8105 0     0   0 my $o = shift;
8106 0         0 my $label = shift;
8107 0         0 my $value = shift;
8108              
8109 0         0 $o->{hash} = $value->hash;
8110 0         0 $o->{store} = $value->cliStore;
8111             }
8112              
8113             sub collectRecord {
8114 0     0   0 my $o = shift;
8115 0         0 my $label = shift;
8116 0         0 my $value = shift;
8117              
8118 0         0 $o->{showRecord} = 1;
8119             }
8120              
8121             sub collectSize {
8122 0     0   0 my $o = shift;
8123 0         0 my $label = shift;
8124 0         0 my $value = shift;
8125              
8126 0         0 $o->{showSize} = 1;
8127             }
8128              
8129             sub collectStore {
8130 0     0   0 my $o = shift;
8131 0         0 my $label = shift;
8132 0         0 my $value = shift;
8133              
8134 0         0 $o->{store} = $value;
8135             }
8136              
8137             sub new {
8138 0     0   0 my $class = shift;
8139 0         0 my $actor = shift;
8140 0         0 bless {actor => $actor, ui => $actor->ui} }
8141              
8142             # END AUTOGENERATED
8143              
8144             # HTML FOLDER NAME show-object
8145             # HTML TITLE Show objects
8146             sub help {
8147 0     0   0 my $o = shift;
8148 0         0 my $cmd = shift;
8149              
8150 0         0 my $ui = $o->{ui};
8151 0         0 $ui->space;
8152 0         0 $ui->command('cds show record OBJECT');
8153 0         0 $ui->command('cds show record HASH on STORE');
8154 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.');
8155 0         0 $ui->space;
8156 0         0 $ui->line('The following object properties can be displayed:');
8157 0         0 $ui->line(' cds show hash of …');
8158 0         0 $ui->line(' cds show size of …');
8159 0         0 $ui->line(' cds show bytes of …');
8160 0         0 $ui->line(' cds show hashes of …');
8161 0         0 $ui->line(' cds show data of …');
8162 0         0 $ui->line(' cds show record …');
8163 0         0 $ui->space;
8164 0         0 $ui->p('Multiple properties may be combined with "and", e.g.:');
8165 0         0 $ui->line(' cds show size and hashes and record of …');
8166 0         0 $ui->space;
8167 0         0 $ui->command('cds show record HASH');
8168 0         0 $ui->p('As above, but uses the selected store.');
8169 0         0 $ui->space;
8170 0         0 $ui->command('cds show record FILE');
8171 0         0 $ui->p('As above, but loads the object from FILE rather than from an object store.');
8172 0         0 $ui->space;
8173 0         0 $ui->command('… decrypted with AESKEY');
8174 0         0 $ui->p('Decrypts the object after retrieval.');
8175 0         0 $ui->space;
8176 0         0 $ui->command('cds show object …');
8177 0         0 $ui->p('A shortcut for "cds show hashes and data of …".');
8178 0         0 $ui->space;
8179 0         0 $ui->title('Related commands');
8180 0         0 $ui->line('cds get OBJECT [decrypted with AESKEY]');
8181 0         0 $ui->line('cds save [data of] OBJECT [decrypted with AESKEY] as FILE');
8182 0         0 $ui->line('cds open envelope OBJECT [on STORE] [using KEYPAIR]');
8183 0         0 $ui->line('cds show document OBJECT [on STORE]');
8184 0         0 $ui->space;
8185             }
8186              
8187             sub show {
8188 0     0   0 my $o = shift;
8189 0         0 my $cmd = shift;
8190              
8191 0         0 $cmd->collect($o);
8192              
8193             # Get and decrypt the object
8194 0 0       0 $o->{object} = defined $o->{file} ? $o->loadObjectFromFile : $o->loadObjectFromStore;
8195 0 0       0 return if ! $o->{object};
8196 0 0       0 $o->{object} = $o->{object}->crypt($o->{aesKey}) if defined $o->{aesKey};
8197              
8198             # Show the desired information
8199 0 0       0 $o->showHash if $o->{showHash};
8200 0 0       0 $o->showSize if $o->{showSize};
8201 0 0       0 $o->showBytes if $o->{showBytes};
8202 0 0       0 $o->showHashes if $o->{showHashes};
8203 0 0       0 $o->showData if $o->{showData};
8204 0 0       0 $o->showRecord if $o->{showRecord};
8205 0         0 $o->{ui}->space;
8206             }
8207              
8208             sub loadObjectFromFile {
8209 0     0   0 my $o = shift;
8210              
8211 0   0     0 my $bytes = CDS->readBytesFromFile($o->{file}) // return $o->{ui}->error('Unable to read "', $o->{file}, '".');
8212 0   0     0 return CDS::Object->fromBytes($bytes) // return $o->{ui}->error('"', $o->{file}, '" does not contain a valid Condensation object.');
8213             }
8214              
8215             sub loadObjectFromStore {
8216 0     0   0 my $o = shift;
8217              
8218 0         0 return $o->{actor}->uiGetObject($o->{hash}, $o->{store}, $o->{actor}->preferredKeyPairToken);
8219             }
8220              
8221             sub loadCommand {
8222 0     0   0 my $o = shift;
8223              
8224 0 0       0 my $decryption = defined $o->{aesKey} ? ' decrypted with '.unpack('H*', $o->{aesKey}) : '';
8225 0 0       0 return $o->{file}.$decryption if defined $o->{file};
8226 0         0 return $o->{hash}->hex.' on '.$o->{actor}->storeReference($o->{store}).$decryption;
8227             }
8228              
8229             sub showHash {
8230 0     0   0 my $o = shift;
8231              
8232 0         0 $o->{ui}->space;
8233 0         0 $o->{ui}->title('Object hash');
8234 0         0 $o->{ui}->line($o->{object}->calculateHash->hex);
8235             }
8236              
8237             sub showSize {
8238 0     0   0 my $o = shift;
8239              
8240 0         0 $o->{ui}->space;
8241 0         0 $o->{ui}->title('Object size');
8242 0         0 $o->{ui}->line($o->{ui}->niceFileSize(length $o->{object}->bytes), ' total (', length $o->{object}->bytes, ' bytes)');
8243 0         0 $o->{ui}->line($o->{object}->hashesCount, ' hashes (', length $o->{object}->header, ' bytes)');
8244 0         0 $o->{ui}->line($o->{ui}->niceFileSize(length $o->{object}->data), ' data (', length $o->{object}->data, ' bytes)');
8245             }
8246              
8247             sub showBytes {
8248 0     0   0 my $o = shift;
8249              
8250 0         0 $o->{ui}->space;
8251 0         0 my $bytes = $o->{object}->bytes;
8252 0         0 $o->{ui}->title('Object bytes (', $o->{ui}->niceFileSize(length $bytes), ')');
8253 0 0       0 return if ! length $bytes;
8254              
8255 0         0 my $hexDump = $o->{ui}->hexDump($bytes);
8256 0         0 my $dataStart = $hexDump->styleHashList(0);
8257 0 0       0 my $end = $dataStart ? $hexDump->styleRecord($dataStart) : 0;
8258 0         0 $hexDump->changeStyle({at => $end, style => $hexDump->reset});
8259 0         0 $hexDump->display;
8260             }
8261              
8262             sub showHashes {
8263 0     0   0 my $o = shift;
8264              
8265 0         0 $o->{ui}->space;
8266 0         0 my $hashesCount = $o->{object}->hashesCount;
8267 0 0       0 $o->{ui}->title($hashesCount == 1 ? '1 hash' : $hashesCount.' hashes');
8268 0         0 my $count = 0;
8269 0         0 for my $hash ($o->{object}->hashes) {
8270 0         0 $o->{ui}->line($o->{ui}->violet(unpack('H4', pack('S>', $count))), ' ', $hash->hex);
8271 0         0 $count += 1;
8272             }
8273             }
8274              
8275             sub showData {
8276 0     0   0 my $o = shift;
8277              
8278 0         0 $o->{ui}->space;
8279 0         0 my $data = $o->{object}->data;
8280 0         0 $o->{ui}->title('Data (', $o->{ui}->niceFileSize(length $data), ')');
8281 0 0       0 return if ! length $data;
8282              
8283 0         0 my $hexDump = $o->{ui}->hexDump($data);
8284 0         0 my $end = $hexDump->styleRecord(0);
8285 0         0 $hexDump->changeStyle({at => $end, style => $hexDump->reset});
8286 0         0 $hexDump->display;
8287             }
8288              
8289             sub showRecord {
8290 0     0   0 my $o = shift;
8291              
8292             # Title
8293 0         0 $o->{ui}->space;
8294 0         0 $o->{ui}->title('Data interpreted as record');
8295              
8296             # Empty object (empty record)
8297 0 0       0 return $o->{ui}->line($o->{ui}->gray('(empty record)')) if ! length $o->{object}->data;
8298              
8299             # Record
8300 0         0 my $record = CDS::Record->new;
8301 0         0 my $reader = CDS::RecordReader->new($o->{object});
8302 0         0 $reader->readChildren($record);
8303 0 0       0 if ($reader->hasError) {
8304 0         0 $o->{ui}->pRed('This is not a record.');
8305 0         0 $o->{ui}->space;
8306 0         0 $o->{ui}->p('You may use one of the following commands to check out the content:');
8307 0         0 $o->{ui}->line($o->{ui}->gold(' cds show object ', $o->loadCommand));
8308 0         0 $o->{ui}->line($o->{ui}->gold(' cds show data of ', $o->loadCommand));
8309 0         0 $o->{ui}->line($o->{ui}->gold(' cds save data of ', $o->loadCommand, ' as FILENAME'));
8310 0         0 return;
8311             }
8312              
8313 0 0       0 $o->{ui}->recordChildren($record, $o->{store} ? $o->{actor}->blueStoreReference($o->{store}) : '');
8314              
8315             # Trailer
8316 0         0 my $trailer = $reader->trailer;
8317 0 0       0 if (length $trailer) {
8318 0         0 $o->{ui}->space;
8319 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".');
8320 0         0 $o->{ui}->space;
8321             }
8322             }
8323              
8324             # BEGIN AUTOGENERATED
8325             package CDS::Commands::ShowPrivateData;
8326              
8327             sub register {
8328 0     0   0 my $class = shift;
8329 0         0 my $cds = shift;
8330 0         0 my $help = shift;
8331              
8332 0         0 my $node000 = CDS::Parser::Node->new(0);
8333 0         0 my $node001 = CDS::Parser::Node->new(0);
8334 0         0 my $node002 = CDS::Parser::Node->new(0);
8335 0         0 my $node003 = CDS::Parser::Node->new(0);
8336 0         0 my $node004 = CDS::Parser::Node->new(0);
8337 0         0 my $node005 = CDS::Parser::Node->new(0);
8338 0         0 my $node006 = CDS::Parser::Node->new(0);
8339 0         0 my $node007 = CDS::Parser::Node->new(0);
8340 0         0 my $node008 = CDS::Parser::Node->new(0);
8341 0         0 my $node009 = CDS::Parser::Node->new(0);
8342 0         0 my $node010 = CDS::Parser::Node->new(0);
8343 0         0 my $node011 = CDS::Parser::Node->new(0);
8344 0         0 my $node012 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
8345 0         0 my $node013 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showGroupData});
8346 0         0 my $node014 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showLocalData});
8347 0         0 my $node015 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showSentList});
8348 0         0 my $node016 = CDS::Parser::Node->new(0);
8349 0         0 my $node017 = CDS::Parser::Node->new(0);
8350 0         0 my $node018 = CDS::Parser::Node->new(0);
8351 0         0 my $node019 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showSentList});
8352 0         0 $cds->addArrow($node006, 1, 0, 'show');
8353 0         0 $cds->addArrow($node007, 1, 0, 'show');
8354 0         0 $cds->addArrow($node008, 1, 0, 'show');
8355 0         0 $help->addArrow($node000, 1, 0, 'show');
8356 0         0 $help->addArrow($node001, 1, 0, 'show');
8357 0         0 $help->addArrow($node002, 1, 0, 'show');
8358 0         0 $node000->addArrow($node003, 1, 0, 'group');
8359 0         0 $node001->addArrow($node004, 1, 0, 'local');
8360 0         0 $node002->addArrow($node005, 1, 0, 'sent');
8361 0         0 $node003->addArrow($node012, 1, 0, 'data');
8362 0         0 $node004->addArrow($node012, 1, 0, 'data');
8363 0         0 $node005->addArrow($node012, 1, 0, 'list');
8364 0         0 $node006->addArrow($node009, 1, 0, 'group');
8365 0         0 $node007->addArrow($node010, 1, 0, 'local');
8366 0         0 $node008->addArrow($node011, 1, 0, 'sent');
8367 0         0 $node009->addArrow($node013, 1, 0, 'data');
8368 0         0 $node010->addArrow($node014, 1, 0, 'data');
8369 0         0 $node011->addArrow($node015, 1, 0, 'list');
8370 0         0 $node015->addArrow($node016, 1, 0, 'ordered');
8371 0         0 $node016->addArrow($node017, 1, 0, 'by');
8372 0         0 $node017->addArrow($node018, 1, 0, 'envelope');
8373 0         0 $node017->addArrow($node019, 1, 0, 'date', \&collectDate);
8374 0         0 $node017->addArrow($node019, 1, 0, 'id', \&collectId);
8375 0         0 $node018->addArrow($node019, 1, 0, 'hash', \&collectHash);
8376             }
8377              
8378             sub collectDate {
8379 0     0   0 my $o = shift;
8380 0         0 my $label = shift;
8381 0         0 my $value = shift;
8382              
8383 0         0 $o->{orderedBy} = 'date';
8384             }
8385              
8386             sub collectHash {
8387 0     0   0 my $o = shift;
8388 0         0 my $label = shift;
8389 0         0 my $value = shift;
8390              
8391 0         0 $o->{orderedBy} = 'envelope hash';
8392             }
8393              
8394             sub collectId {
8395 0     0   0 my $o = shift;
8396 0         0 my $label = shift;
8397 0         0 my $value = shift;
8398              
8399 0         0 $o->{orderedBy} = 'id';
8400             }
8401              
8402             sub new {
8403 0     0   0 my $class = shift;
8404 0         0 my $actor = shift;
8405 0         0 bless {actor => $actor, ui => $actor->ui} }
8406              
8407             # END AUTOGENERATED
8408              
8409             # HTML FOLDER NAME show-private-data
8410             # HTML TITLE Show the private data
8411             sub help {
8412 0     0   0 my $o = shift;
8413 0         0 my $cmd = shift;
8414              
8415 0         0 my $ui = $o->{ui};
8416 0         0 $ui->space;
8417 0         0 $ui->command('cds show group data');
8418 0         0 $ui->p('Shows the group document. This document is shared among all group members.');
8419 0         0 $ui->space;
8420 0         0 $ui->command('cds show local data');
8421 0         0 $ui->p('Shows the local document. This document is stored locally, and private to this actor.');
8422 0         0 $ui->space;
8423 0         0 $ui->command('cds show sent list');
8424 0         0 $ui->p('Shows the list of sent messages with their expiry date, envelope hash, and content hash.');
8425 0         0 $ui->space;
8426 0         0 $ui->command('… ordered by id');
8427 0         0 $ui->command('… ordered by date');
8428 0         0 $ui->command('… ordered by envelope hash');
8429 0         0 $ui->p('Sorts the list accordingly. By default, the list is sorted by id.');
8430 0         0 $ui->space;
8431             }
8432              
8433             sub showGroupData {
8434 0     0   0 my $o = shift;
8435 0         0 my $cmd = shift;
8436              
8437 0         0 $o->{ui}->space;
8438 0         0 $o->{ui}->selector($o->{actor}->groupRoot, 'Group data');
8439 0         0 $o->{ui}->space;
8440             }
8441              
8442             sub showLocalData {
8443 0     0   0 my $o = shift;
8444 0         0 my $cmd = shift;
8445              
8446 0         0 $o->{ui}->space;
8447 0         0 $o->{ui}->selector($o->{actor}->localRoot, 'Local data');
8448 0         0 $o->{ui}->space;
8449             }
8450              
8451             sub showSentList {
8452 0     0   0 my $o = shift;
8453 0         0 my $cmd = shift;
8454              
8455 0         0 $o->{orderedBy} = 'id';
8456 0         0 $cmd->collect($o);
8457              
8458 0         0 $o->{ui}->space;
8459 0         0 $o->{ui}->title('Sent list');
8460              
8461 0   0     0 $o->{actor}->procureSentList // return;
8462 0         0 my $sentList = $o->{actor}->sentList;
8463 0         0 my @items = sort { $a->id cmp $b->id } values %{$sentList->{items}};
  0         0  
  0         0  
8464 0 0       0 @items = sort { $a->envelopeHashBytes cmp $b->envelopeHashBytes } @items if $o->{orderedBy} eq 'envelope hash';
  0         0  
8465 0 0       0 @items = sort { $a->validUntil <=> $b->validUntil } @items if $o->{orderedBy} eq 'date';
  0         0  
8466 0         0 my $noHash = '-' x 64;
8467 0         0 for my $item (@items) {
8468 0         0 my $id = $item->id;
8469 0         0 my $envelopeHash = $item->envelopeHash;
8470 0         0 my $message = $item->message;
8471 0         0 my $label = $o->{ui}->niceBytes($id, 32);
8472 0 0       0 $o->{ui}->line($o->{ui}->gray($o->{ui}->niceDateTimeLocal($item->validUntil)), ' ', $envelopeHash ? $envelopeHash->hex : $noHash, ' ', $o->{ui}->blue($label));
8473 0         0 $o->{ui}->recordChildren($message);
8474             }
8475              
8476 0         0 $o->{ui}->space;
8477             }
8478              
8479             # BEGIN AUTOGENERATED
8480             package CDS::Commands::ShowTree;
8481              
8482             sub register {
8483 0     0   0 my $class = shift;
8484 0         0 my $cds = shift;
8485 0         0 my $help = shift;
8486              
8487 0         0 my $node000 = CDS::Parser::Node->new(0);
8488 0         0 my $node001 = CDS::Parser::Node->new(0);
8489 0         0 my $node002 = CDS::Parser::Node->new(0);
8490 0         0 my $node003 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
8491 0         0 my $node004 = CDS::Parser::Node->new(0);
8492 0         0 my $node005 = CDS::Parser::Node->new(0);
8493 0         0 my $node006 = CDS::Parser::Node->new(0);
8494 0         0 my $node007 = CDS::Parser::Node->new(0);
8495 0         0 my $node008 = CDS::Parser::Node->new(0);
8496 0         0 my $node009 = CDS::Parser::Node->new(0);
8497 0         0 my $node010 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&showTree});
8498 0         0 $cds->addArrow($node001, 1, 0, 'show');
8499 0         0 $cds->addArrow($node002, 0, 0, 'show');
8500 0         0 $help->addArrow($node000, 1, 0, 'show');
8501 0         0 $node000->addArrow($node003, 1, 0, 'tree');
8502 0         0 $node001->addArrow($node004, 1, 0, 'tree');
8503 0         0 $node002->addArrow($node004, 0, 0, 'trees');
8504 0         0 $node004->addDefault($node005);
8505 0         0 $node004->addDefault($node006);
8506 0         0 $node004->addDefault($node007);
8507 0         0 $node005->addArrow($node005, 1, 0, 'HASH', \&collectHash);
8508 0         0 $node005->addArrow($node010, 1, 0, 'HASH', \&collectHash);
8509 0         0 $node006->addArrow($node006, 1, 0, 'HASH', \&collectHash);
8510 0         0 $node006->addArrow($node008, 1, 0, 'HASH', \&collectHash);
8511 0         0 $node007->addArrow($node007, 1, 0, 'OBJECT', \&collectObject);
8512 0         0 $node007->addArrow($node010, 1, 0, 'OBJECT', \&collectObject);
8513 0         0 $node008->addArrow($node009, 1, 0, 'on');
8514 0         0 $node009->addArrow($node010, 1, 0, 'STORE', \&collectStore);
8515             }
8516              
8517             sub collectHash {
8518 0     0   0 my $o = shift;
8519 0         0 my $label = shift;
8520 0         0 my $value = shift;
8521              
8522 0         0 push @{$o->{hashes}}, $value;
  0         0  
8523             }
8524              
8525             sub collectObject {
8526 0     0   0 my $o = shift;
8527 0         0 my $label = shift;
8528 0         0 my $value = shift;
8529              
8530 0         0 push @{$o->{objectTokens}}, $value;
  0         0  
8531             }
8532              
8533             sub collectStore {
8534 0     0   0 my $o = shift;
8535 0         0 my $label = shift;
8536 0         0 my $value = shift;
8537              
8538 0         0 $o->{store} = $value;
8539             }
8540              
8541             sub new {
8542 0     0   0 my $class = shift;
8543 0         0 my $actor = shift;
8544 0         0 bless {actor => $actor, ui => $actor->ui} }
8545              
8546             # END AUTOGENERATED
8547              
8548             # HTML FOLDER NAME show-tree
8549             # HTML TITLE Show trees
8550             sub help {
8551 0     0   0 my $o = shift;
8552 0         0 my $cmd = shift;
8553              
8554 0         0 my $ui = $o->{ui};
8555 0         0 $ui->space;
8556 0         0 $ui->command('cds show tree OBJECT*');
8557 0         0 $ui->command('cds show tree HASH* on STORE');
8558 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".');
8559 0         0 $ui->space;
8560 0         0 $ui->command('cds show tree HASH*');
8561 0         0 $ui->p('As above, but uses the selected store.');
8562 0         0 $ui->space;
8563             }
8564              
8565             sub showTree {
8566 0     0   0 my $o = shift;
8567 0         0 my $cmd = shift;
8568              
8569 0         0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken;
8570 0         0 $o->{objectTokens} = [];
8571 0         0 $o->{hashes} = [];
8572 0         0 $cmd->collect($o);
8573              
8574             # Process all trees
8575 0         0 for my $objectToken (@{$o->{objectTokens}}) {
  0         0  
8576 0         0 $o->{ui}->space;
8577 0         0 $o->process($objectToken->hash, $objectToken->cliStore);
8578             }
8579              
8580 0 0       0 if (scalar @{$o->{hashes}}) {
  0         0  
8581 0   0     0 my $store = $o->{store} // $o->{actor}->preferredStore;
8582 0         0 for my $hash (@{$o->{hashes}}) {
  0         0  
8583 0         0 $o->{ui}->space;
8584 0         0 $o->process($hash, $store);
8585             }
8586             }
8587              
8588             # Report the total size
8589 0         0 my $totalSize = 0;
8590 0         0 my $totalDataSize = 0;
8591 0         0 map { $totalSize += $_->{size} ; $totalDataSize += $_->{dataSize} } values %{$o->{objects}};
  0         0  
  0         0  
  0         0  
8592 0         0 $o->{ui}->space;
8593 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  
8594 0 0       0 $o->{ui}->pRed(scalar keys %{$o->{missingObjects}}, ' or more objects are missing') if scalar keys %{$o->{missingObjects}};
  0         0  
  0         0  
8595 0         0 $o->{ui}->space;
8596             }
8597              
8598             sub process {
8599 0     0   0 my $o = shift;
8600 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
8601 0         0 my $store = shift;
8602              
8603 0         0 my $hashHex = $hash->hex;
8604              
8605             # Check if we retrieved this object before
8606 0 0       0 if (exists $o->{objects}->{$hashHex}) {
8607 0         0 $o->{ui}->line($hash->hex, ' reported above') ;
8608 0         0 return 1;
8609             }
8610              
8611             # Retrieve the object
8612 0         0 my ($object, $storeError) = $store->get($hash, $o->{keyPairToken}->keyPair);
8613 0 0       0 return if defined $storeError;
8614              
8615 0 0       0 if (! $object) {
8616 0         0 $o->{missingObjects}->{$hashHex} = 1;
8617 0         0 return $o->{ui}->line($hashHex, ' ', $o->{ui}->red('is missing'));
8618             }
8619              
8620             # Display
8621 0         0 my $size = $object->byteLength;
8622 0         0 $o->{objects}->{$hashHex} = {size => $size, dataSize => length $object->data};
8623 0         0 $o->{ui}->line($hashHex, ' ', $o->{ui}->bold($o->{ui}->niceFileSize($size)), ' ', $o->{ui}->gray($object->hashesCount, ' hashes'));
8624              
8625             # Process all children
8626 0         0 $o->{ui}->pushIndent;
8627 0         0 foreach my $hash ($object->hashes) {
8628 0   0     0 $o->process($hash, $store) // return;
8629             }
8630 0         0 $o->{ui}->popIndent;
8631 0         0 return 1;
8632             }
8633              
8634             # BEGIN AUTOGENERATED
8635             package CDS::Commands::StartHTTPServer;
8636              
8637             sub register {
8638 0     0   0 my $class = shift;
8639 0         0 my $cds = shift;
8640 0         0 my $help = shift;
8641              
8642 0         0 my $node000 = CDS::Parser::Node->new(0);
8643 0         0 my $node001 = CDS::Parser::Node->new(0);
8644 0         0 my $node002 = CDS::Parser::Node->new(0);
8645 0         0 my $node003 = CDS::Parser::Node->new(0);
8646 0         0 my $node004 = CDS::Parser::Node->new(0);
8647 0         0 my $node005 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
8648 0         0 my $node006 = CDS::Parser::Node->new(0);
8649 0         0 my $node007 = CDS::Parser::Node->new(0);
8650 0         0 my $node008 = CDS::Parser::Node->new(0);
8651 0         0 my $node009 = CDS::Parser::Node->new(1);
8652 0         0 my $node010 = CDS::Parser::Node->new(0);
8653 0         0 my $node011 = CDS::Parser::Node->new(1);
8654 0         0 my $node012 = CDS::Parser::Node->new(0);
8655 0         0 my $node013 = CDS::Parser::Node->new(0);
8656 0         0 my $node014 = CDS::Parser::Node->new(0);
8657 0         0 my $node015 = CDS::Parser::Node->new(0);
8658 0         0 my $node016 = CDS::Parser::Node->new(1);
8659 0         0 my $node017 = CDS::Parser::Node->new(0);
8660 0         0 my $node018 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&startHttpServer});
8661 0         0 $cds->addArrow($node001, 1, 0, 'start');
8662 0         0 $help->addArrow($node000, 1, 0, 'http');
8663 0         0 $node000->addArrow($node005, 1, 0, 'server');
8664 0         0 $node001->addArrow($node002, 1, 0, 'http');
8665 0         0 $node002->addArrow($node003, 1, 0, 'server');
8666 0         0 $node003->addArrow($node004, 1, 0, 'for');
8667 0         0 $node004->addArrow($node006, 1, 0, 'STORE', \&collectStore);
8668 0         0 $node006->addArrow($node007, 1, 0, 'on');
8669 0         0 $node007->addArrow($node008, 1, 0, 'port');
8670 0         0 $node008->addArrow($node009, 1, 0, 'PORT', \&collectPort);
8671 0         0 $node009->addArrow($node010, 1, 0, 'at');
8672 0         0 $node009->addDefault($node011);
8673 0         0 $node010->addArrow($node011, 1, 0, 'TEXT', \&collectText);
8674 0         0 $node011->addArrow($node012, 1, 0, 'with');
8675 0         0 $node011->addDefault($node016);
8676 0         0 $node012->addArrow($node013, 1, 0, 'static');
8677 0         0 $node013->addArrow($node014, 1, 0, 'files');
8678 0         0 $node014->addArrow($node015, 1, 0, 'from');
8679 0         0 $node015->addArrow($node016, 1, 0, 'FOLDER', \&collectFolder);
8680 0         0 $node016->addArrow($node017, 1, 0, 'for');
8681 0         0 $node016->addDefault($node018);
8682 0         0 $node017->addArrow($node018, 1, 0, 'everybody', \&collectEverybody);
8683             }
8684              
8685             sub collectEverybody {
8686 0     0   0 my $o = shift;
8687 0         0 my $label = shift;
8688 0         0 my $value = shift;
8689              
8690 0         0 $o->{corsAllowEverybody} = 1;
8691             }
8692              
8693             sub collectFolder {
8694 0     0   0 my $o = shift;
8695 0         0 my $label = shift;
8696 0         0 my $value = shift;
8697              
8698 0         0 $o->{staticFolder} = $value;
8699             }
8700              
8701             sub collectPort {
8702 0     0   0 my $o = shift;
8703 0         0 my $label = shift;
8704 0         0 my $value = shift;
8705              
8706 0         0 $o->{port} = $value;
8707             }
8708              
8709             sub collectStore {
8710 0     0   0 my $o = shift;
8711 0         0 my $label = shift;
8712 0         0 my $value = shift;
8713              
8714 0         0 $o->{store} = $value;
8715             }
8716              
8717             sub collectText {
8718 0     0   0 my $o = shift;
8719 0         0 my $label = shift;
8720 0         0 my $value = shift;
8721              
8722 0         0 $o->{root} = $value;
8723             }
8724              
8725             sub new {
8726 0     0   0 my $class = shift;
8727 0         0 my $actor = shift;
8728 0         0 bless {actor => $actor, ui => $actor->ui} }
8729              
8730             # END AUTOGENERATED
8731              
8732             # HTML FOLDER NAME start-http-server
8733             # HTML TITLE HTTP store server
8734             sub help {
8735 0     0   0 my $o = shift;
8736 0         0 my $cmd = shift;
8737              
8738 0         0 my $ui = $o->{ui};
8739 0         0 $ui->space;
8740 0         0 $ui->command('cds start http server for STORE on port PORT');
8741 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.');
8742 0         0 $ui->p('You may need superuser (root) privileges to use the default HTTP port 80.');
8743 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.');
8744 0         0 $ui->space;
8745 0         0 $ui->command('… at TEXT');
8746 0         0 $ui->p('As above, but makes the store accessible at /TEXT/objects and /TEXT/accounts.');
8747 0         0 $ui->space;
8748 0         0 $ui->command('… with static files from FOLDER');
8749 0         0 $ui->p('Delivers static files from FOLDER for URLs outside of /objects and /accounts. This is useful for self-contained web apps.');
8750 0         0 $ui->space;
8751 0         0 $ui->command('… for everybody');
8752 0         0 $ui->p('Sets CORS headers to allow everybody to access the store from within a web browser.');
8753 0         0 $ui->space;
8754 0         0 $ui->p('For more options, write a Perl script instantiating and configuring a CDS::HTTPServer.');
8755 0         0 $ui->space;
8756             }
8757              
8758             sub startHttpServer {
8759 0     0   0 my $o = shift;
8760 0         0 my $cmd = shift;
8761              
8762 0         0 $cmd->collect($o);
8763              
8764 0         0 my $httpServer = CDS::HTTPServer->new($o->{port});
8765 0         0 $httpServer->setLogger(CDS::Commands::StartHTTPServer::Logger->new($o->{ui}));
8766 0         0 $httpServer->setCorsAllowEverybody($o->{corsAllowEverybody});
8767 0   0     0 $httpServer->addHandler(CDS::HTTPServer::StoreHandler->new($o->{root} // '/', $o->{store}));
8768 0 0 0     0 $httpServer->addHandler(CDS::HTTPServer::IdentificationHandler->new($o->{root} // '/')) if ! defined $o->{staticFolder};
8769 0 0       0 $httpServer->addHandler(CDS::HTTPServer::StaticFilesHandler->new('/', $o->{staticFolder}, 'index.html')) if defined $o->{staticFolder};
8770 0         0 eval { $httpServer->run; };
  0         0  
8771 0 0       0 if ($@) {
8772 0         0 my $error = $@;
8773 0 0       0 $error = $1 if $error =~ /^(.*?)( at |\n)/;
8774 0         0 $o->{ui}->space;
8775 0         0 $o->{ui}->p('Failed to run server on port '.$o->{port}.': '.$error);
8776 0         0 $o->{ui}->space;
8777             }
8778             }
8779              
8780             package CDS::Commands::StartHTTPServer::Logger;
8781              
8782             sub new {
8783 0     0   0 my $class = shift;
8784 0         0 my $ui = shift;
8785              
8786 0         0 return bless {ui => $ui};
8787             }
8788              
8789             sub onServerStarts {
8790 0     0   0 my $o = shift;
8791 0         0 my $port = shift;
8792              
8793 0         0 my $ui = $o->{ui};
8794 0         0 $ui->space;
8795 0         0 $ui->line($o->{ui}->gray($ui->niceDateTimeLocal), ' ', $ui->green('Server ready at http://localhost:', $port));
8796             }
8797              
8798             sub onRequestStarts {
8799 0     0   0 my $o = shift;
8800 0         0 my $request = shift;
8801             }
8802              
8803             sub onRequestError {
8804 0     0   0 my $o = shift;
8805 0         0 my $request = shift;
8806              
8807 0         0 my $ui = $o->{ui};
8808 0         0 $ui->line($o->{ui}->gray($ui->niceDateTimeLocal), ' ', $ui->blue($ui->left(15, $request->peerAddress)), ' ', $request->method, ' ', $request->path, ' ', $ui->red(@_));
8809             }
8810              
8811             sub onRequestDone {
8812 0     0   0 my $o = shift;
8813 0         0 my $request = shift;
8814 0         0 my $responseCode = shift;
8815              
8816 0         0 my $ui = $o->{ui};
8817 0         0 $ui->line($o->{ui}->gray($ui->niceDateTimeLocal), ' ', $ui->blue($ui->left(15, $request->peerAddress)), ' ', $request->method, ' ', $request->path, ' ', $ui->bold($responseCode));
8818             }
8819              
8820             # BEGIN AUTOGENERATED
8821             package CDS::Commands::Transfer;
8822              
8823             sub register {
8824 0     0   0 my $class = shift;
8825 0         0 my $cds = shift;
8826 0         0 my $help = shift;
8827              
8828 0         0 my $node000 = CDS::Parser::Node->new(0);
8829 0         0 my $node001 = CDS::Parser::Node->new(0);
8830 0         0 my $node002 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
8831 0         0 my $node003 = CDS::Parser::Node->new(0);
8832 0         0 my $node004 = CDS::Parser::Node->new(0);
8833 0         0 my $node005 = CDS::Parser::Node->new(0);
8834 0         0 my $node006 = CDS::Parser::Node->new(0);
8835 0         0 my $node007 = CDS::Parser::Node->new(0);
8836 0         0 my $node008 = CDS::Parser::Node->new(0);
8837 0         0 my $node009 = CDS::Parser::Node->new(0);
8838 0         0 my $node010 = CDS::Parser::Node->new(0);
8839 0         0 my $node011 = CDS::Parser::Node->new(0);
8840 0         0 my $node012 = CDS::Parser::Node->new(0);
8841 0         0 my $node013 = CDS::Parser::Node->new(0);
8842 0         0 my $node014 = CDS::Parser::Node->new(0);
8843 0         0 my $node015 = CDS::Parser::Node->new(0);
8844 0         0 my $node016 = CDS::Parser::Node->new(0);
8845 0         0 my $node017 = CDS::Parser::Node->new(1);
8846 0         0 my $node018 = CDS::Parser::Node->new(0);
8847 0         0 my $node019 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&transfer});
8848 0         0 $cds->addArrow($node000, 1, 0, 'thoroughly');
8849 0         0 $cds->addArrow($node001, 0, 0, 'leniently');
8850 0         0 $cds->addDefault($node003);
8851 0         0 $cds->addArrow($node003, 1, 0, 'leniently', \&collectLeniently);
8852 0         0 $cds->addArrow($node003, 1, 0, 'thoroughly', \&collectThoroughly);
8853 0         0 $help->addArrow($node002, 1, 0, 'transfer');
8854 0         0 $node000->addArrow($node003, 1, 0, 'leniently', \&collectLeniently1);
8855 0         0 $node001->addArrow($node003, 0, 0, 'thoroughly', \&collectLeniently1);
8856 0         0 $node003->addArrow($node004, 1, 0, 'transfer');
8857 0         0 $node004->addDefault($node005);
8858 0         0 $node004->addDefault($node006);
8859 0         0 $node004->addDefault($node007);
8860 0         0 $node004->addDefault($node008);
8861 0         0 $node004->addArrow($node009, 1, 0, 'message');
8862 0         0 $node004->addDefault($node010);
8863 0         0 $node004->addArrow($node011, 1, 0, 'private');
8864 0         0 $node004->addArrow($node012, 1, 0, 'public');
8865 0         0 $node004->addArrow($node013, 1, 0, 'all', \&collectAll);
8866 0         0 $node004->addArrow($node013, 0, 0, 'messages', \&collectMessages);
8867 0         0 $node004->addArrow($node013, 0, 0, 'private', \&collectPrivate);
8868 0         0 $node004->addArrow($node013, 0, 0, 'public', \&collectPublic);
8869 0         0 $node005->addArrow($node005, 1, 0, 'HASH', \&collectHash);
8870 0         0 $node005->addArrow($node017, 1, 0, 'HASH', \&collectHash);
8871 0         0 $node006->addArrow($node006, 1, 0, 'OBJECT', \&collectObject);
8872 0         0 $node006->addArrow($node017, 1, 0, 'OBJECT', \&collectObject);
8873 0         0 $node007->addArrow($node007, 1, 0, 'ACCOUNT', \&collectAccount);
8874 0         0 $node007->addArrow($node017, 1, 0, 'ACCOUNT', \&collectAccount);
8875 0         0 $node008->addArrow($node008, 1, 0, 'BOX', \&collectBox);
8876 0         0 $node008->addArrow($node017, 1, 0, 'BOX', \&collectBox);
8877 0         0 $node009->addArrow($node013, 1, 0, 'box', \&collectMessages);
8878 0         0 $node010->addArrow($node010, 1, 0, 'HASH', \&collectHash);
8879 0         0 $node010->addArrow($node015, 1, 0, 'HASH', \&collectHash);
8880 0         0 $node011->addArrow($node013, 1, 0, 'box', \&collectPrivate);
8881 0         0 $node012->addArrow($node013, 1, 0, 'box', \&collectPublic);
8882 0         0 $node013->addArrow($node014, 1, 0, 'of');
8883 0         0 $node014->addArrow($node014, 1, 0, 'HASH', \&collectHash1);
8884 0         0 $node014->addArrow($node015, 1, 0, 'HASH', \&collectHash1);
8885 0         0 $node015->addArrow($node016, 1, 0, 'from');
8886 0         0 $node016->addArrow($node017, 1, 0, 'STORE', \&collectStore);
8887 0         0 $node017->addArrow($node018, 1, 0, 'to');
8888 0         0 $node018->addArrow($node018, 1, 0, 'STORE', \&collectStore1);
8889 0         0 $node018->addArrow($node019, 1, 0, 'STORE', \&collectStore1);
8890             }
8891              
8892             sub collectAccount {
8893 0     0   0 my $o = shift;
8894 0         0 my $label = shift;
8895 0         0 my $value = shift;
8896              
8897 0         0 push @{$o->{accountTokens}}, $value;
  0         0  
8898             }
8899              
8900             sub collectAll {
8901 0     0   0 my $o = shift;
8902 0         0 my $label = shift;
8903 0         0 my $value = shift;
8904              
8905 0         0 push @{$o->{boxLabels}}, 'public', 'private', 'messages';
  0         0  
8906             }
8907              
8908             sub collectBox {
8909 0     0   0 my $o = shift;
8910 0         0 my $label = shift;
8911 0         0 my $value = shift;
8912              
8913 0         0 push @{$o->{boxTokens}}, $value;
  0         0  
8914             }
8915              
8916             sub collectHash {
8917 0     0   0 my $o = shift;
8918 0         0 my $label = shift;
8919 0         0 my $value = shift;
8920              
8921 0         0 push @{$o->{objectHashes}}, $value;
  0         0  
8922             }
8923              
8924             sub collectHash1 {
8925 0     0   0 my $o = shift;
8926 0         0 my $label = shift;
8927 0         0 my $value = shift;
8928              
8929 0         0 push @{$o->{accountHashes}}, $value;
  0         0  
8930             }
8931              
8932             sub collectLeniently {
8933 0     0   0 my $o = shift;
8934 0         0 my $label = shift;
8935 0         0 my $value = shift;
8936              
8937 0         0 $o->{leniently} = 1;
8938             }
8939              
8940             sub collectLeniently1 {
8941 0     0   0 my $o = shift;
8942 0         0 my $label = shift;
8943 0         0 my $value = shift;
8944              
8945 0         0 $o->{leniently} = 1;
8946 0         0 $o->{thoroughly} = 1;
8947             }
8948              
8949             sub collectMessages {
8950 0     0   0 my $o = shift;
8951 0         0 my $label = shift;
8952 0         0 my $value = shift;
8953              
8954 0         0 push @{$o->{boxLabels}}, 'messages';
  0         0  
8955             }
8956              
8957             sub collectObject {
8958 0     0   0 my $o = shift;
8959 0         0 my $label = shift;
8960 0         0 my $value = shift;
8961              
8962 0         0 push @{$o->{objectTokens}}, $value;
  0         0  
8963             }
8964              
8965             sub collectPrivate {
8966 0     0   0 my $o = shift;
8967 0         0 my $label = shift;
8968 0         0 my $value = shift;
8969              
8970 0         0 push @{$o->{boxLabels}}, 'private';
  0         0  
8971             }
8972              
8973             sub collectPublic {
8974 0     0   0 my $o = shift;
8975 0         0 my $label = shift;
8976 0         0 my $value = shift;
8977              
8978 0         0 push @{$o->{boxLabels}}, 'public';
  0         0  
8979             }
8980              
8981             sub collectStore {
8982 0     0   0 my $o = shift;
8983 0         0 my $label = shift;
8984 0         0 my $value = shift;
8985              
8986 0         0 $o->{fromStore} = $value;
8987             }
8988              
8989             sub collectStore1 {
8990 0     0   0 my $o = shift;
8991 0         0 my $label = shift;
8992 0         0 my $value = shift;
8993              
8994 0         0 push @{$o->{toStores}}, $value;
  0         0  
8995             }
8996              
8997             sub collectThoroughly {
8998 0     0   0 my $o = shift;
8999 0         0 my $label = shift;
9000 0         0 my $value = shift;
9001              
9002 0         0 $o->{thoroughly} = 1;
9003             }
9004              
9005             sub new {
9006 0     0   0 my $class = shift;
9007 0         0 my $actor = shift;
9008 0         0 bless {actor => $actor, ui => $actor->ui} }
9009              
9010             # END AUTOGENERATED
9011              
9012             # HTML FOLDER NAME transfer
9013             # HTML TITLE Transfer
9014             sub help {
9015 0     0   0 my $o = shift;
9016 0         0 my $cmd = shift;
9017              
9018 0         0 my $ui = $o->{ui};
9019 0         0 $ui->space;
9020 0         0 $ui->command('cds transfer BOX* to STORE*');
9021 0         0 $ui->command('cds transfer ACCOUNT* to STORE*');
9022 0         0 $ui->command('cds transfer all of HASH* from STORE to STORE*');
9023 0         0 $ui->command('cds transfer BOXLABEL of HASH* from STORE to STORE*');
9024 0         0 $ui->p('Copies an account (or some of its boxes) including all referenced trees from one store to another. If the source store is omitted, the selected store is used.');
9025 0         0 $ui->space;
9026 0         0 $ui->command('cds transfer OBJECT* to STORE*');
9027 0         0 $ui->command('cds transfer HASH* from STORE to STORE*');
9028 0         0 $ui->p('Copies a tree from one store to another. If the source store is omitted, the selected store is used.');
9029 0         0 $ui->space;
9030 0         0 $ui->command('cds ', $ui->underlined('leniently'), ' transfer …');
9031 0         0 $ui->p('Warns about missing objects, but ignores them and proceeds with the rest.');
9032 0         0 $ui->space;
9033 0         0 $ui->command('cds ', $ui->underlined('thoroughly'), ' transfer …');
9034 0         0 $ui->p('Check subtrees of objects existing at the destination. This may be used to fix missing objects on the destination store.');
9035 0         0 $ui->space;
9036             }
9037              
9038             sub transfer {
9039 0     0   0 my $o = shift;
9040 0         0 my $cmd = shift;
9041              
9042             # Collect the arguments
9043 0         0 $o->{keyPairToken} = $o->{actor}->preferredKeyPairToken;
9044 0         0 $o->{accountTokens} = [];
9045 0         0 $o->{accountHashes} = [];
9046 0         0 $o->{boxTokens} = [];
9047 0         0 $o->{boxLabels} = [];
9048 0         0 $o->{objectTokens} = [];
9049 0         0 $o->{objectHashes} = [];
9050 0         0 $o->{toStores} = [];
9051 0         0 $cmd->collect($o);
9052              
9053             # Use the selected store
9054 0 0 0     0 $o->{fromStore} = $o->{actor}->preferredStore if (scalar @{$o->{accountHashes}} || scalar @{$o->{objectHashes}}) && ! $o->{fromStore};
      0        
9055              
9056             # Prepare the object tokens
9057 0         0 for my $hash (@{$o->{objectHashes}}) {
  0         0  
9058 0         0 push @{$o->{objectTokens}}, CDS::ObjectToken->new($o->{fromStore}, $hash);
  0         0  
9059             }
9060              
9061             # Prepare the account tokens
9062 0         0 for my $hash (@{$o->{accountHashes}}) {
  0         0  
9063 0         0 push @{$o->{accountTokens}}, CDS::AccountToken->new($o->{fromStore}, $hash);
  0         0  
9064             }
9065              
9066             # Prepare the box tokens
9067 0         0 for my $accountToken (@{$o->{accountTokens}}) {
  0         0  
9068 0         0 for my $boxLabel (@{$o->{boxLabels}}) {
  0         0  
9069 0         0 push @{$o->{boxTokens}}, CDS::BoxToken->new($accountToken, $boxLabel);
  0         0  
9070             }
9071             }
9072              
9073             # Copy the public key of every account first
9074 0         0 my %done;
9075 0         0 for my $boxToken (@{$o->{boxTokens}}) {
  0         0  
9076 0         0 my $actorHash = $boxToken->accountToken->actorHash;
9077 0 0       0 next if $done{$actorHash->bytes};
9078 0         0 $done{$actorHash->bytes} = 1;
9079 0         0 push @{$o->{objectTokens}}, CDS::ObjectToken->new($boxToken->accountToken->cliStore, $actorHash);
  0         0  
9080             }
9081              
9082             # Prepare the destination stores
9083 0         0 my $toStores = [];
9084 0         0 for my $toStore (@{$o->{toStores}}) {
  0         0  
9085 0         0 push @$toStores, {store => $toStore, storeError => undef, needed => [1]};
9086             }
9087              
9088             # Print the stores
9089 0         0 $o->{ui}->space;
9090 0         0 my $n = scalar @$toStores;
9091 0         0 for my $i (0 .. $n - 1) {
9092 0         0 my $toStore = $toStores->[$i];
9093 0         0 $o->{ui}->line($o->{ui}->gray(' │' x $i, ' ┌', '──' x ($n - $i), ' ', $toStore->{store}->url));
9094             }
9095              
9096             # Process all trees
9097 0         0 $o->{objects} = {};
9098 0         0 $o->{missingObjects} = {};
9099 0         0 for my $objectToken (@{$o->{objectTokens}}) {
  0         0  
9100 0         0 $o->{ui}->line($o->{ui}->gray(' │' x $n));
9101 0         0 $o->process($objectToken->hash, $objectToken->cliStore, $toStores, 1);
9102             }
9103              
9104             # Process all accounts
9105 0         0 my $keyPair = $o->{keyPairToken}->keyPair;
9106 0         0 for my $boxToken (@{$o->{boxTokens}}) {
  0         0  
9107 0         0 $o->{ui}->line($o->{ui}->gray(' │' x $n));
9108 0         0 $o->{ui}->line($o->{ui}->gray(' │' x $n, ' Transferring ', $boxToken->boxLabel, ' box of ', $boxToken->accountToken->actorHash->hex));
9109 0         0 my ($hashes, $listError) = $boxToken->accountToken->cliStore->list($boxToken->accountToken->actorHash, $boxToken->boxLabel, 0, $keyPair);
9110 0 0       0 next if $listError;
9111              
9112 0         0 for my $hash (@$hashes) {
9113 0   0     0 $o->process($hash, $boxToken->accountToken->cliStore, $toStores, 1) // next;
9114              
9115 0         0 for my $toStore (@$toStores) {
9116 0 0       0 next if defined $toStore->{storeError};
9117 0         0 $toStore->{storeError} = $toStore->{store}->add($boxToken->accountToken->actorHash, $boxToken->boxLabel, $hash, $keyPair);
9118             }
9119             }
9120             }
9121              
9122             # Print the stores again, with their errors
9123 0         0 $o->{ui}->line($o->{ui}->gray(' │' x $n));
9124 0         0 for my $i (reverse 0 .. $n - 1) {
9125 0         0 my $toStore = $toStores->[$i];
9126 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}) : '');
9127             }
9128              
9129             # Report the total size
9130 0         0 my $totalSize = 0;
9131 0         0 my $totalDataSize = 0;
9132 0         0 map { $totalSize += $_->{size} ; $totalDataSize += $_->{dataSize} } values %{$o->{objects}};
  0         0  
  0         0  
  0         0  
9133 0         0 $o->{ui}->space;
9134 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  
9135 0 0       0 $o->{ui}->pOrange(scalar keys %{$o->{missingObjects}}, ' or more objects are missing') if scalar keys %{$o->{missingObjects}};
  0         0  
  0         0  
9136 0         0 $o->{ui}->space;
9137             }
9138              
9139             sub process {
9140 0     0   0 my $o = shift;
9141 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
9142 0         0 my $fromStore = shift;
9143 0         0 my $toStores = shift;
9144 0         0 my $depth = shift;
9145              
9146 0         0 my $hashHex = $hash->hex;
9147 0         0 my $keyPair = $o->{keyPairToken}->keyPair;
9148              
9149             # Check if we retrieved this object before
9150 0 0       0 if (exists $o->{objects}->{$hashHex}) {
9151 0         0 $o->report($hash->hex, $toStores, $depth, $o->{ui}->green('copied before'));
9152 0         0 return 1;
9153             }
9154              
9155             # Try to book the object on all active stores
9156 0         0 my $countNeeded = 0;
9157 0         0 my $hasActiveStore = 0;
9158 0         0 for my $toStore (@$toStores) {
9159 0 0       0 next if defined $toStore->{storeError};
9160 0         0 $hasActiveStore = 1;
9161 0 0 0     0 next if ! $o->{thoroughly} && ! $toStore->{needed}->[$depth - 1];
9162              
9163 0         0 my ($found, $bookError) = $toStore->{store}->book($hash);
9164 0 0       0 if (defined $bookError) {
9165 0         0 $toStore->{storeError} = $bookError;
9166 0         0 next;
9167             }
9168              
9169 0 0       0 next if $found;
9170 0         0 $toStore->{needed}->[$depth] = 1;
9171 0         0 $countNeeded += 1;
9172             }
9173              
9174             # Return if all stores reported an error
9175 0 0       0 return if ! $hasActiveStore;
9176              
9177             # Ignore existing subtrees at the destination unless "thoroughly" is set
9178 0 0 0     0 if (! $o->{thoroughly} && ! $countNeeded) {
9179 0         0 $o->report($hashHex, $toStores, $depth, $o->{ui}->gray('skipping subtree'));
9180 0         0 return 1;
9181             }
9182              
9183             # Retrieve the object
9184 0         0 my ($object, $getError) = $fromStore->get($hash, $keyPair);
9185 0 0       0 return if defined $getError;
9186              
9187 0 0       0 if (! defined $object) {
9188 0         0 $o->{missingObjects}->{$hashHex} = 1;
9189 0         0 $o->report($hashHex, $toStores, $depth, $o->{ui}->orange('is missing'));
9190 0 0       0 return if ! $o->{leniently};
9191             }
9192              
9193             # Display
9194 0         0 my $size = $object->byteLength;
9195 0         0 $o->{objects}->{$hashHex} = {needed => $countNeeded, size => $size, dataSize => length $object->data};
9196 0         0 $o->report($hashHex, $toStores, $depth, $o->{ui}->bold($o->{ui}->niceFileSize($size)), ' ', $o->{ui}->gray($object->hashesCount, ' hashes'));
9197              
9198             # Process all children
9199 0         0 foreach my $hash ($object->hashes) {
9200 0   0     0 $o->process($hash, $fromStore, $toStores, $depth + 1) // return;
9201             }
9202              
9203             # Write the object to all active stores
9204 0         0 for my $toStore (@$toStores) {
9205 0 0       0 next if defined $toStore->{storeError};
9206 0 0       0 next if ! $toStore->{needed}->[$depth];
9207 0         0 my $putError = $toStore->{store}->put($hash, $object, $keyPair);
9208 0 0       0 $toStore->{storeError} = $putError if $putError;
9209             }
9210              
9211 0         0 return 1;
9212             }
9213              
9214             sub report {
9215 0     0   0 my $o = shift;
9216 0         0 my $hashHex = shift;
9217 0         0 my $toStores = shift;
9218 0         0 my $depth = shift;
9219              
9220 0         0 my @text;
9221 0         0 for my $toStore (@$toStores) {
9222 0 0       0 if ($toStore->{storeError}) {
    0          
9223 0         0 push @text, $o->{ui}->red(' ⨯');
9224             } elsif ($toStore->{needed}->[$depth]) {
9225 0         0 push @text, $o->{ui}->green(' +');
9226             } else {
9227 0         0 push @text, $o->{ui}->green(' ‒');
9228             }
9229             }
9230              
9231 0         0 push @text, ' ', ' ' x ($depth - 1), $hashHex;
9232 0         0 push @text, ' ', @_;
9233 0         0 $o->{ui}->line(@text);
9234             }
9235              
9236             # BEGIN AUTOGENERATED
9237             package CDS::Commands::UseCache;
9238              
9239             sub register {
9240 0     0   0 my $class = shift;
9241 0         0 my $cds = shift;
9242 0         0 my $help = shift;
9243              
9244 0         0 my $node000 = CDS::Parser::Node->new(0);
9245 0         0 my $node001 = CDS::Parser::Node->new(0);
9246 0         0 my $node002 = CDS::Parser::Node->new(0);
9247 0         0 my $node003 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
9248 0         0 my $node004 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&useCache});
9249 0         0 my $node005 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&dropCache});
9250 0         0 my $node006 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&cache});
9251 0         0 $cds->addArrow($node000, 1, 0, 'use');
9252 0         0 $cds->addArrow($node002, 1, 0, 'drop');
9253 0         0 $cds->addArrow($node006, 1, 0, 'cache');
9254 0         0 $help->addArrow($node003, 1, 0, 'cache');
9255 0         0 $node000->addArrow($node001, 1, 0, 'cache');
9256 0         0 $node001->addArrow($node004, 1, 0, 'STORE', \&collectStore);
9257 0         0 $node002->addArrow($node005, 1, 0, 'cache');
9258             }
9259              
9260             sub collectStore {
9261 0     0   0 my $o = shift;
9262 0         0 my $label = shift;
9263 0         0 my $value = shift;
9264              
9265 0         0 $o->{store} = $value;
9266             }
9267              
9268             sub new {
9269 0     0   0 my $class = shift;
9270 0         0 my $actor = shift;
9271 0         0 bless {actor => $actor, ui => $actor->ui} }
9272              
9273             # END AUTOGENERATED
9274              
9275             # HTML FOLDER NAME use-cache
9276             # HTML TITLE Using a cache store
9277             sub help {
9278 0     0   0 my $o = shift;
9279 0         0 my $cmd = shift;
9280              
9281 0         0 my $ui = $o->{ui};
9282 0         0 $ui->space;
9283 0         0 $ui->command('cds use cache STORE');
9284 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.');
9285 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.');
9286 0         0 $ui->space;
9287 0         0 $ui->command('cds drop cache');
9288 0         0 $ui->p('Stops using the cache.');
9289 0         0 $ui->space;
9290 0         0 $ui->command('cds cache');
9291 0         0 $ui->p('Shows which cache store is used (if any).');
9292 0         0 $ui->space;
9293             }
9294              
9295             sub useCache {
9296 0     0   0 my $o = shift;
9297 0         0 my $cmd = shift;
9298              
9299 0         0 $cmd->collect($o);
9300              
9301 0         0 $o->{actor}->sessionRoot->child('use cache')->setText($o->{store}->url);
9302 0   0     0 $o->{actor}->saveOrShowError // return;
9303 0         0 $o->{ui}->pGreen('Using store "', $o->{store}->url, '" to cache objects.');
9304             }
9305              
9306             sub dropCache {
9307 0     0   0 my $o = shift;
9308 0         0 my $cmd = shift;
9309              
9310 0         0 $o->{actor}->sessionRoot->child('use cache')->clear;
9311 0   0     0 $o->{actor}->saveOrShowError // return;
9312 0         0 $o->{ui}->pGreen('Not using any cache any more.');
9313             }
9314              
9315             sub cache {
9316 0     0   0 my $o = shift;
9317 0         0 my $cmd = shift;
9318              
9319 0         0 my $storeUrl = $o->{actor}->sessionRoot->child('use cache')->textValue;
9320 0 0       0 return $o->{ui}->line('Not using any cache.') if ! length $storeUrl;
9321 0         0 return $o->{ui}->line('Using store "', $storeUrl, '" to cache objects.');
9322             }
9323              
9324             # BEGIN AUTOGENERATED
9325             package CDS::Commands::UseStore;
9326              
9327             sub register {
9328 0     0   0 my $class = shift;
9329 0         0 my $cds = shift;
9330 0         0 my $help = shift;
9331              
9332 0         0 my $node000 = CDS::Parser::Node->new(0);
9333 0         0 my $node001 = CDS::Parser::Node->new(0);
9334 0         0 my $node002 = CDS::Parser::Node->new(0);
9335 0         0 my $node003 = CDS::Parser::Node->new(0);
9336 0         0 my $node004 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
9337 0         0 my $node005 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&useStoreForMessaging});
9338 0         0 $cds->addArrow($node001, 1, 0, 'use');
9339 0         0 $help->addArrow($node000, 1, 0, 'messaging');
9340 0         0 $node000->addArrow($node004, 1, 0, 'store');
9341 0         0 $node001->addArrow($node002, 1, 0, 'STORE', \&collectStore);
9342 0         0 $node002->addArrow($node003, 1, 0, 'for');
9343 0         0 $node003->addArrow($node005, 1, 0, 'messaging');
9344             }
9345              
9346             sub collectStore {
9347 0     0   0 my $o = shift;
9348 0         0 my $label = shift;
9349 0         0 my $value = shift;
9350              
9351 0         0 $o->{store} = $value;
9352             }
9353              
9354             sub new {
9355 0     0   0 my $class = shift;
9356 0         0 my $actor = shift;
9357 0         0 bless {actor => $actor, ui => $actor->ui} }
9358              
9359             # END AUTOGENERATED
9360              
9361             # HTML FOLDER NAME use-store
9362             # HTML TITLE Set the messaging store
9363             sub help {
9364 0     0   0 my $o = shift;
9365 0         0 my $cmd = shift;
9366              
9367 0         0 my $ui = $o->{ui};
9368 0         0 $ui->space;
9369 0         0 $ui->command('cds use STORE for messaging');
9370 0         0 $ui->p('Uses STORE to send and receive messages.');
9371 0         0 $ui->space;
9372             }
9373              
9374             sub useStoreForMessaging {
9375 0     0   0 my $o = shift;
9376 0         0 my $cmd = shift;
9377              
9378 0         0 $cmd->collect($o);
9379              
9380 0         0 $o->{actor}->{configuration}->setMessagingStoreUrl($o->{store}->url);
9381 0         0 $o->{ui}->pGreen('The messaging store is now ', $o->{store}->url);
9382             }
9383              
9384             # BEGIN AUTOGENERATED
9385             package CDS::Commands::Welcome;
9386              
9387             sub register {
9388 0     0   0 my $class = shift;
9389 0         0 my $cds = shift;
9390 0         0 my $help = shift;
9391              
9392 0         0 my $node000 = CDS::Parser::Node->new(0);
9393 0         0 my $node001 = CDS::Parser::Node->new(0);
9394 0         0 my $node002 = CDS::Parser::Node->new(0);
9395 0         0 my $node003 = CDS::Parser::Node->new(0);
9396 0         0 my $node004 = CDS::Parser::Node->new(0);
9397 0         0 my $node005 = CDS::Parser::Node->new(0);
9398 0         0 my $node006 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
9399 0         0 my $node007 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&suppress});
9400 0         0 my $node008 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&enable});
9401 0         0 my $node009 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&show});
9402 0         0 $cds->addArrow($node000, 1, 0, 'suppress');
9403 0         0 $cds->addArrow($node002, 1, 0, 'enable');
9404 0         0 $cds->addArrow($node004, 1, 0, 'show');
9405 0         0 $help->addArrow($node006, 1, 0, 'welcome');
9406 0         0 $node000->addArrow($node001, 1, 0, 'welcome');
9407 0         0 $node001->addArrow($node007, 1, 0, 'message');
9408 0         0 $node002->addArrow($node003, 1, 0, 'welcome');
9409 0         0 $node003->addArrow($node008, 1, 0, 'message');
9410 0         0 $node004->addArrow($node005, 1, 0, 'welcome');
9411 0         0 $node005->addArrow($node009, 1, 0, 'message');
9412             }
9413              
9414             sub new {
9415 0     0   0 my $class = shift;
9416 0         0 my $actor = shift;
9417 0         0 bless {actor => $actor, ui => $actor->ui} }
9418              
9419             # END AUTOGENERATED
9420              
9421             # HTML FOLDER NAME welcome
9422             # HTML TITLE Welcome message
9423             sub help {
9424 0     0   0 my $o = shift;
9425 0         0 my $cmd = shift;
9426              
9427 0         0 my $ui = $o->{ui};
9428 0         0 $ui->space;
9429 0         0 $ui->command('cds suppress welcome message');
9430 0         0 $ui->p('Suppresses the welcome message when typing "cds".');
9431 0         0 $ui->space;
9432 0         0 $ui->command('cds enable welcome message');
9433 0         0 $ui->p('Enables the welcome message when typing "cds".');
9434 0         0 $ui->space;
9435 0         0 $ui->command('cds show welcome message');
9436 0         0 $ui->p('Shows the welcome message.');
9437 0         0 $ui->space;
9438             }
9439              
9440             sub suppress {
9441 0     0   0 my $o = shift;
9442 0         0 my $cmd = shift;
9443              
9444 0         0 $o->{actor}->localRoot->child('suppress welcome message')->setBoolean(1);
9445 0   0     0 $o->{actor}->saveOrShowError // return;
9446              
9447 0         0 $o->{ui}->space;
9448 0         0 $o->{ui}->p('The welcome message will not be shown any more.');
9449 0         0 $o->{ui}->space;
9450 0         0 $o->{ui}->line('You can manually display the message by typing:');
9451 0         0 $o->{ui}->line($o->{ui}->blue(' cds show welcome message'));
9452 0         0 $o->{ui}->line('or re-enable it using:');
9453 0         0 $o->{ui}->line($o->{ui}->blue(' cds enable welcome message'));
9454 0         0 $o->{ui}->space;
9455             }
9456              
9457             sub enable {
9458 0     0   0 my $o = shift;
9459 0         0 my $cmd = shift;
9460              
9461 0         0 $o->{actor}->localRoot->child('suppress welcome message')->clear;
9462 0   0     0 $o->{actor}->saveOrShowError // return;
9463              
9464 0         0 $o->{ui}->space;
9465 0         0 $o->{ui}->p('The welcome message will be shown when you type "cds".');
9466 0         0 $o->{ui}->space;
9467             }
9468              
9469             sub isEnabled {
9470 0     0   0 my $o = shift;
9471 0         0 ! $o->{actor}->localRoot->child('suppress welcome message')->isSet }
9472              
9473             sub show {
9474 0     0   0 my $o = shift;
9475 0         0 my $cmd = shift;
9476              
9477 0         0 my $ui = $o->{ui};
9478 0         0 $ui->space;
9479 0         0 $ui->title('Hi there!');
9480 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.');
9481 0         0 $ui->space;
9482 0         0 $ui->p('Commands resemble short english sentences. For example, the following "sentence" will show the record of an object:');
9483 0         0 $ui->line($ui->blue(' cds show record e5cbfc282e1f3e6fd0f3e5fffd41964c645f44d7fae8ef5cb350c2dfd2196c9f \\'));
9484 0         0 $ui->line($ui->blue(' from http://examples.condensation.io'));
9485 0         0 $ui->p('Type a "?" to explore possible commands, e.g.');
9486 0         0 $ui->line($ui->blue(' cds show ?'));
9487 0         0 $ui->p('or use TAB or TAB-TAB for command completion.');
9488 0         0 $ui->space;
9489 0         0 $ui->p('To get help, type');
9490 0         0 $ui->line($ui->blue(' cds help'));
9491 0         0 $ui->space;
9492 0         0 $ui->p('To suppress this welcome message, type');
9493 0         0 $ui->line($ui->blue(' cds suppress welcome message'));
9494 0         0 $ui->space;
9495             }
9496              
9497             package CDS::Commands::WhatIs;
9498              
9499             # BEGIN AUTOGENERATED
9500              
9501             sub register {
9502 0     0   0 my $class = shift;
9503 0         0 my $cds = shift;
9504 0         0 my $help = shift;
9505              
9506 0         0 my $node000 = CDS::Parser::Node->new(0);
9507 0         0 my $node001 = CDS::Parser::Node->new(0);
9508 0         0 my $node002 = CDS::Parser::Node->new(0);
9509 0         0 my $node003 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&help});
9510 0         0 my $node004 = CDS::Parser::Node->new(1, {constructor => \&new, function => \&whatIs});
9511 0         0 $cds->addArrow($node001, 1, 0, 'what');
9512 0         0 $help->addArrow($node000, 1, 0, 'what');
9513 0         0 $node000->addArrow($node003, 1, 0, 'is');
9514 0         0 $node001->addArrow($node002, 1, 0, 'is');
9515 0         0 $node002->addArrow($node004, 1, 0, 'TEXT', \&collectText);
9516             }
9517              
9518             sub collectText {
9519 0     0   0 my $o = shift;
9520 0         0 my $label = shift;
9521 0         0 my $value = shift;
9522              
9523 0         0 $o->{text} = $value;
9524             }
9525              
9526             sub new {
9527 0     0   0 my $class = shift;
9528 0         0 my $actor = shift;
9529 0         0 bless {actor => $actor, ui => $actor->ui} }
9530              
9531             # END AUTOGENERATED
9532              
9533             # HTML FOLDER NAME what-is
9534             # HTML TITLE What is
9535             sub help {
9536 0     0   0 my $o = shift;
9537 0         0 my $cmd = shift;
9538              
9539 0         0 my $ui = $o->{ui};
9540 0         0 $ui->space;
9541 0         0 $ui->command('cds what is TEXT');
9542 0         0 $ui->p('Tells what TEXT could be under the current configuration.');
9543 0         0 $ui->space;
9544             }
9545              
9546             sub whatIs {
9547 0     0   0 my $o = shift;
9548 0         0 my $cmd = shift;
9549              
9550 0         0 $cmd->collect($o);
9551 0         0 $o->{butNot} = [];
9552              
9553 0         0 $o->{ui}->space;
9554 0         0 $o->{ui}->title($o->{ui}->blue($o->{text}), ' may be …');
9555              
9556 0     0   0 $o->test('ACCOUNT', 'an ACCOUNT', sub { shift->url });
  0         0  
9557 0     0   0 $o->test('AESKEY', 'an AESKEY', sub { unpack('H*', shift) });
  0         0  
9558 0     0   0 $o->test('BOX', 'a BOX', sub { shift->url });
  0         0  
9559 0     0   0 $o->test('BOXLABEL', 'a BOXLABEL', sub { shift });
  0         0  
9560 0         0 $o->test('FILE', 'a FILE', \&fileResult);
9561 0         0 $o->test('FILENAME', 'a FILENAME', \&fileResult);
9562 0         0 $o->test('FOLDER', 'a FOLDER', \&fileResult);
9563 0     0   0 $o->test('GROUP', 'a GROUP on this system', sub { shift });
  0         0  
9564 0     0   0 $o->test('HASH', 'a HASH or ACTOR hash', sub { shift->hex });
  0         0  
9565 0         0 $o->test('KEYPAIR', 'a KEYPAIR', \&keyPairResult);
9566 0     0   0 $o->test('LABEL', 'a remembered LABEL', sub { shift });
  0         0  
9567 0     0   0 $o->test('OBJECT', 'an OBJECT', sub { shift->url });
  0         0  
9568 0         0 $o->test('OBJECTFILE', 'an OBJECTFILE', \&objectFileResult);
9569 0     0   0 $o->test('STORE', 'a STORE', sub { shift->url });
  0         0  
9570 0     0   0 $o->test('USER', 'a USER on this system', sub { shift });
  0         0  
9571              
9572 0         0 for my $butNot (@{$o->{butNot}}) {
  0         0  
9573 0         0 $o->{ui}->space;
9574 0         0 $o->{ui}->line('… but not ', $butNot->{text}, ', because:');
9575 0         0 for my $warning (@{$butNot->{warnings}}) {
  0         0  
9576 0         0 $o->{ui}->warning($warning);
9577             }
9578             }
9579              
9580 0         0 $o->{ui}->space;
9581             }
9582              
9583             sub test {
9584 0     0   0 my $o = shift;
9585 0         0 my $expect = shift;
9586 0         0 my $text = shift;
9587 0         0 my $resultHandler = shift;
9588              
9589 0         0 my $token = CDS::Parser::Token->new($o->{actor}, $o->{text});
9590 0         0 my $result = $token->produce($expect);
9591 0 0       0 if (defined $result) {
    0          
9592 0         0 my $whichOne = &$resultHandler($result);
9593 0         0 $o->{ui}->line('… ', $text, ' ', $o->{ui}->gray($whichOne));
9594 0         0 } elsif (scalar @{$token->{warnings}}) {
9595 0         0 push @{$o->{butNot}}, {text => $text, warnings => $token->{warnings}};
  0         0  
9596             }
9597             }
9598              
9599             sub keyPairResult {
9600 0     0   0 my $keyPairToken = shift;
9601              
9602 0         0 return $keyPairToken->file.' ('.$keyPairToken->keyPair->publicKey->hash->hex.')';
9603             }
9604              
9605             sub objectFileResult {
9606 0     0   0 my $objectFileToken = shift;
9607              
9608 0 0       0 return $objectFileToken->file if $objectFileToken->object->byteLength > 1024 * 1024;
9609 0         0 return $objectFileToken->file.' ('.$objectFileToken->object->calculateHash->hex.')';
9610             }
9611              
9612             sub fileResult {
9613 0     0   0 my $file = shift;
9614              
9615 0         0 my @s = stat $file;
9616 0 0       0 my $label =
    0          
    0          
    0          
    0          
    0          
    0          
    0          
9617             ! scalar @s ? ' (non-existing)' :
9618             Fcntl::S_ISDIR($s[2]) ? ' (folder)' :
9619             Fcntl::S_ISREG($s[2]) ? ' (file, '.$s[7].' bytes)' :
9620             Fcntl::S_ISLNK($s[2]) ? ' (symbolic link)' :
9621             Fcntl::S_ISBLK($s[2]) ? ' (block device)' :
9622             Fcntl::S_ISCHR($s[2]) ? ' (char device)' :
9623             Fcntl::S_ISSOCK($s[2]) ? ' (socket)' :
9624             Fcntl::S_ISFIFO($s[2]) ? ' (pipe)' : ' (unknown type)';
9625              
9626 0         0 return $file.$label;
9627             }
9628              
9629             package CDS::Configuration;
9630              
9631             our $xdgConfigurationFolder = ($ENV{XDG_CONFIG_HOME} || $ENV{HOME}.'/.config').'/condensation';
9632             our $xdgDataFolder = ($ENV{XDG_DATA_HOME} || $ENV{HOME}.'/.local/share').'/condensation';
9633              
9634             sub getOrCreateDefault {
9635 0     0   0 my $class = shift;
9636 0         0 my $ui = shift;
9637              
9638 0         0 my $configuration = $class->new($ui, $xdgConfigurationFolder, $xdgDataFolder);
9639 0         0 $configuration->createIfNecessary();
9640 0         0 return $configuration;
9641             }
9642              
9643             sub new {
9644 0     0   0 my $class = shift;
9645 0         0 my $ui = shift;
9646 0         0 my $folder = shift;
9647 0         0 my $defaultStoreFolder = shift;
9648              
9649 0         0 return bless {ui => $ui, folder => $folder, defaultStoreFolder => $defaultStoreFolder};
9650             }
9651              
9652 0     0   0 sub ui { shift->{ui} }
9653 0     0   0 sub folder { shift->{folder} }
9654              
9655             sub createIfNecessary {
9656 0     0   0 my $o = shift;
9657              
9658 0         0 my $keyPairFile = $o->{folder}.'/key-pair';
9659 0 0       0 return 1 if -f $keyPairFile;
9660              
9661 0         0 $o->{ui}->progress('Creating configuration folders …');
9662 0   0     0 $o->createFolder($o->{folder}) // return $o->{ui}->error('Failed to create the folder "', $o->{folder}, '".');
9663 0   0     0 $o->createFolder($o->{defaultStoreFolder}) // return $o->{ui}->error('Failed to create the folder "', $o->{defaultStoreFolder}, '".');
9664 0         0 CDS::FolderStore->new($o->{defaultStoreFolder})->createIfNecessary;
9665              
9666 0         0 $o->{ui}->progress('Generating key pair …');
9667 0         0 my $keyPair = CDS::KeyPair->generate;
9668 0   0     0 $keyPair->writeToFile($keyPairFile) // return $o->{ui}->error('Failed to write the configuration file "', $keyPairFile, '". Make sure that this location is writable.');
9669 0         0 $o->{ui}->removeProgress;
9670 0         0 return 1;
9671             }
9672              
9673             sub createFolder {
9674 0     0   0 my $o = shift;
9675 0         0 my $folder = shift;
9676              
9677 0         0 for my $path (CDS->intermediateFolders($folder)) {
9678 0         0 mkdir $path;
9679             }
9680              
9681 0         0 return -d $folder;
9682             }
9683              
9684             sub file {
9685 0     0   0 my $o = shift;
9686 0         0 my $filename = shift;
9687              
9688 0         0 return $o->{folder}.'/'.$filename;
9689             }
9690              
9691             sub messagingStoreUrl {
9692 0     0   0 my $o = shift;
9693              
9694 0   0     0 return $o->readFirstLine('messaging-store') // 'file://'.$o->{defaultStoreFolder};
9695             }
9696              
9697             sub storageStoreUrl {
9698 0     0   0 my $o = shift;
9699              
9700 0   0     0 return $o->readFirstLine('store') // 'file://'.$o->{defaultStoreFolder};
9701             }
9702              
9703             sub setMessagingStoreUrl {
9704 0     0   0 my $o = shift;
9705 0         0 my $storeUrl = shift;
9706              
9707 0         0 CDS->writeTextToFile($o->file('messaging-store'), $storeUrl);
9708             }
9709              
9710             sub setStorageStoreUrl {
9711 0     0   0 my $o = shift;
9712 0         0 my $storeUrl = shift;
9713              
9714 0         0 CDS->writeTextToFile($o->file('store'), $storeUrl);
9715             }
9716              
9717             sub keyPair {
9718 0     0   0 my $o = shift;
9719              
9720 0         0 return CDS::KeyPair->fromFile($o->file('key-pair'));
9721             }
9722              
9723             sub setKeyPair {
9724 0     0   0 my $o = shift;
9725 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
9726              
9727 0         0 $keyPair->writeToFile($o->file('key-pair'));
9728             }
9729              
9730             sub readFirstLine {
9731 0     0   0 my $o = shift;
9732 0         0 my $file = shift;
9733              
9734 0   0     0 my $content = CDS->readTextFromFile($o->file($file)) // return;
9735 0 0       0 $content = $1 if $content =~ /^(.*)\n/;
9736 0 0       0 $content = $1 if $content =~ /^\s*(.*?)\s*$/;
9737 0         0 return $content;
9738             }
9739              
9740             package CDS::DetachedDocument;
9741              
9742 1     1   33198 use parent -norequire, 'CDS::Document';
  1         2  
  1         13  
9743              
9744             sub new {
9745 0     0   0 my $class = shift;
9746 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
9747              
9748 0         0 return $class->SUPER::new($keyPair, CDS::InMemoryStore->create);
9749             }
9750              
9751             sub savingDone {
9752 0     0   0 my $o = shift;
9753 0         0 my $revision = shift;
9754 0         0 my $newPart = shift;
9755 0         0 my $obsoleteParts = shift;
9756              
9757             # We don't do anything
9758 0         0 $o->{unsaved}->savingDone;
9759             }
9760              
9761             package CDS::DiscoverActorGroup;
9762              
9763             sub discover {
9764 0     0   0 my $class = shift;
9765 0 0 0     0 my $builder = shift; die 'wrong type '.ref($builder).' for $builder' if defined $builder && ref $builder ne 'CDS::ActorGroupBuilder';
  0         0  
9766 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
9767 0         0 my $delegate = shift;
9768              
9769 0         0 my $o = bless {
9770             knownPublicKeys => $builder->knownPublicKeys, # A hashref of known public keys (e.g. from the existing actor group)
9771             keyPair => $keyPair,
9772             delegate => $delegate, # The delegate
9773             nodesByUrl => {}, # Nodes on which this actor group is active, by URL
9774             coverage => {}, # Hashes that belong to this actor group
9775             };
9776              
9777             # Add all active members
9778 0         0 for my $member ($builder->members) {
9779 0 0       0 next if $member->status ne 'active';
9780 0         0 my $node = $o->node($member->hash, $member->storeUrl);
9781 0 0       0 if ($node->{revision} < $member->revision) {
9782 0         0 $node->{revision} = $member->revision;
9783 0         0 $node->{status} = 'active';
9784             }
9785              
9786 0         0 $o->{coverage}->{$member->hash->bytes} = 1;
9787             }
9788              
9789             # Determine the revision at start
9790 0         0 my $revisionAtStart = 0;
9791 0         0 for my $node (values %{$o->{nodesByUrl}}) {
  0         0  
9792 0 0       0 $revisionAtStart = $node->{revision} if $revisionAtStart < $node->{revision};
9793             }
9794              
9795             # Reload the cards of all known accounts
9796 0         0 for my $node (values %{$o->{nodesByUrl}}) {
  0         0  
9797 0         0 $node->discover;
9798             }
9799              
9800             # From here, try extending to other accounts
9801 0         0 while ($o->extend) {}
9802              
9803             # Compile the list of actors and cards
9804 0         0 my @members;
9805             my @cards;
9806 0         0 for my $node (values %{$o->{nodesByUrl}}) {
  0         0  
9807 0 0       0 next if ! $node->{reachable};
9808 0 0       0 next if ! $node->{attachedToUs};
9809 0 0       0 next if ! $node->{actorOnStore};
9810 0 0       0 next if ! $node->isActiveOrIdle;
9811             #-- member ++ $node->{actorHash}->hex ++ $node->{cardsRead} ++ $node->{cards} // 'undef' ++ $node->{actorOnStore} // 'undef'
9812 0         0 push @members, CDS::ActorGroup::Member->new($node->{actorOnStore}, $node->{storeUrl}, $node->{revision}, $node->isActive);
9813 0         0 push @cards, @{$node->{cards}};
  0         0  
9814             }
9815              
9816             # Get the newest list of entrusted actors
9817 0         0 my $parser = CDS::ActorGroupBuilder->new;
9818 0         0 for my $card (@cards) {
9819 0         0 $parser->parseEntrustedActors($card->card->child('entrusted actors'), 0);
9820             }
9821              
9822             # Get the entrusted actors
9823 0         0 my $entrustedActors = [];
9824 0         0 for my $actor ($parser->entrustedActors) {
9825 0         0 my $store = $o->{delegate}->onDiscoverActorGroupVerifyStore($actor->storeUrl);
9826 0 0       0 next if ! $store;
9827              
9828 0         0 my $knownPublicKey = $o->{knownPublicKeys}->{$actor->hash->bytes};
9829 0 0       0 if ($knownPublicKey) {
9830 0         0 push @$entrustedActors, CDS::ActorGroup::EntrustedActor->new(CDS::ActorOnStore->new($knownPublicKey, $store), $actor->storeUrl);
9831 0         0 next;
9832             }
9833              
9834 0         0 my ($publicKey, $invalidReason, $storeError) = $keyPair->getPublicKey($actor->hash, $store);
9835              
9836 0 0       0 if (defined $invalidReason) {
9837 0         0 $o->{discoverer}->{delegate}->onDiscoverActorGroupInvalidPublicKey($actor->hash, $store, $invalidReason);
9838 0         0 next;
9839             }
9840              
9841 0 0       0 if (defined $storeError) {
9842 0         0 $o->{discoverer}->{delegate}->onDiscoverActorGroupStoreError($store, $storeError);
9843 0         0 next;
9844             }
9845              
9846 0         0 push @$entrustedActors, CDS::ActorGroup::EntrustedActor->new(CDS::ActorOnStore->new($publicKey, $store), $actor->storeUrl);
9847             }
9848              
9849 0 0       0 my $members = [sort { $b->{revision} <=> $a->{revision} || $b->{status} cmp $a->{status} } @members];
  0         0  
9850 0         0 return CDS::ActorGroup->new($members, $parser->entrustedActorsRevision, $entrustedActors), [@cards], [grep { $_->{attachedToUs} } values %{$o->{nodesByUrl}}];
  0         0  
  0         0  
9851             }
9852              
9853             sub node {
9854 0     0   0 my $o = shift;
9855 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
9856 0         0 my $storeUrl = shift;
9857             # private
9858 0         0 my $url = $storeUrl.'/accounts/'.$actorHash->hex;
9859 0         0 my $node = $o->{nodesByUrl}->{$url};
9860 0 0       0 return $node if $node;
9861 0         0 return $o->{nodesByUrl}->{$url} = CDS::DiscoverActorGroup::Node->new($o, $actorHash, $storeUrl);
9862             }
9863              
9864             sub covers {
9865 0     0   0 my $o = shift;
9866 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
9867 0         0 $o->{coverage}->{$hash->bytes} }
9868              
9869             sub extend {
9870 0     0   0 my $o = shift;
9871              
9872             # Start with the newest node
9873 0         0 my $mainNode;
9874 0         0 my $mainRevision = -1;
9875 0         0 for my $node (values %{$o->{nodesByUrl}}) {
  0         0  
9876 0 0       0 next if ! $node->{attachedToUs};
9877 0 0       0 next if $node->{revision} <= $mainRevision;
9878 0         0 $mainNode = $node;
9879 0         0 $mainRevision = $node->{revision};
9880             }
9881              
9882 0 0       0 return 0 if ! $mainNode;
9883              
9884             # Reset the reachable flag
9885 0         0 for my $node (values %{$o->{nodesByUrl}}) {
  0         0  
9886 0         0 $node->{reachable} = 0;
9887             }
9888 0         0 $mainNode->{reachable} = 1;
9889              
9890             # Traverse the graph along active links to find accounts to discover.
9891 0         0 my @toDiscover;
9892 0         0 my @toCheck = ($mainNode);
9893 0         0 while (1) {
9894 0   0     0 my $currentNode = shift(@toCheck) // last;
9895 0         0 for my $link (@{$currentNode->{links}}) {
  0         0  
9896 0         0 my $node = $link->{node};
9897 0 0       0 next if $node->{reachable};
9898 0 0       0 my $prospectiveStatus = $link->{revision} > $node->{revision} ? $link->{status} : $node->{status};
9899 0 0       0 next if $prospectiveStatus ne 'active';
9900 0         0 $node->{reachable} = 1;
9901 0 0       0 push @toCheck, $node if $node->{attachedToUs};
9902 0 0       0 push @toDiscover, $node if ! $node->{attachedToUs};
9903             }
9904             }
9905              
9906             # Discover these accounts
9907 0         0 my $hasChanges = 0;
9908 0         0 for my $node (sort { $b->{revision} <=> $a->{revision} } @toDiscover) {
  0         0  
9909 0         0 $node->discover;
9910 0 0       0 next if ! $node->{attachedToUs};
9911 0         0 $hasChanges = 1;
9912             }
9913              
9914 0         0 return $hasChanges;
9915             }
9916              
9917             package CDS::DiscoverActorGroup::Card;
9918              
9919             sub new {
9920 0     0   0 my $class = shift;
9921 0         0 my $storeUrl = shift;
9922 0 0 0     0 my $actorOnStore = shift; die 'wrong type '.ref($actorOnStore).' for $actorOnStore' if defined $actorOnStore && ref $actorOnStore ne 'CDS::ActorOnStore';
  0         0  
9923 0 0 0     0 my $envelopeHash = shift; die 'wrong type '.ref($envelopeHash).' for $envelopeHash' if defined $envelopeHash && ref $envelopeHash ne 'CDS::Hash';
  0         0  
9924 0 0 0     0 my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0         0  
9925 0 0 0     0 my $cardHash = shift; die 'wrong type '.ref($cardHash).' for $cardHash' if defined $cardHash && ref $cardHash ne 'CDS::Hash';
  0         0  
9926 0         0 my $card = shift;
9927              
9928 0         0 return bless {
9929             storeUrl => $storeUrl,
9930             actorOnStore => $actorOnStore,
9931             envelopeHash => $envelopeHash,
9932             envelope => $envelope,
9933             cardHash => $cardHash,
9934             card => $card,
9935             };
9936             }
9937              
9938 0     0   0 sub storeUrl { shift->{storeUrl} }
9939 0     0   0 sub actorOnStore { shift->{actorOnStore} }
9940 0     0   0 sub envelopeHash { shift->{envelopeHash} }
9941 0     0   0 sub envelope { shift->{envelope} }
9942 0     0   0 sub cardHash { shift->{cardHash} }
9943 0     0   0 sub card { shift->{card} }
9944              
9945             package CDS::DiscoverActorGroup::Link;
9946              
9947             sub new {
9948 0     0   0 my $class = shift;
9949 0         0 my $node = shift;
9950 0         0 my $revision = shift;
9951 0         0 my $status = shift;
9952              
9953 0         0 bless {
9954             node => $node,
9955             revision => $revision,
9956             status => $status,
9957             };
9958             }
9959              
9960 0     0   0 sub node { shift->{node} }
9961 0     0   0 sub revision { shift->{revision} }
9962 0     0   0 sub status { shift->{status} }
9963              
9964             package CDS::DiscoverActorGroup::Node;
9965              
9966             sub new {
9967 0     0   0 my $class = shift;
9968 0         0 my $discoverer = shift;
9969 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
9970 0         0 my $storeUrl = shift;
9971              
9972 0         0 return bless {
9973             discoverer => $discoverer,
9974             actorHash => $actorHash,
9975             storeUrl => $storeUrl,
9976             revision => -1,
9977             status => 'idle',
9978             reachable => 0, # whether this node is reachable from the main node
9979             store => undef,
9980             actorOnStore => undef,
9981             links => [], # all links found in the cards
9982             attachedToUs => 0, # whether the account belongs to us
9983             cardsRead => 0,
9984             cards => [],
9985             };
9986             }
9987              
9988             sub cards {
9989 0     0   0 my $o = shift;
9990 0         0 @{$o->{cards}} }
  0         0  
9991             sub isActive {
9992 0     0   0 my $o = shift;
9993 0         0 $o->{status} eq 'active' }
9994             sub isActiveOrIdle {
9995 0     0   0 my $o = shift;
9996 0 0       0 $o->{status} eq 'active' || $o->{status} eq 'idle' }
9997              
9998 0     0   0 sub actorHash { shift->{actorHash} }
9999 0     0   0 sub storeUrl { shift->{storeUrl} }
10000 0     0   0 sub revision { shift->{revision} }
10001 0     0   0 sub status { shift->{status} }
10002 0     0   0 sub attachedToUs { shift->{attachedToUs} }
10003             sub links {
10004 0     0   0 my $o = shift;
10005 0         0 @{$o->{links}} }
  0         0  
10006              
10007             sub discover {
10008 0     0   0 my $o = shift;
10009              
10010             #-- discover ++ $o->{actorHash}->hex
10011 0         0 $o->readCards;
10012 0         0 $o->attach;
10013             }
10014              
10015             sub readCards {
10016 0     0   0 my $o = shift;
10017              
10018 0 0       0 return if $o->{cardsRead};
10019 0         0 $o->{cardsRead} = 1;
10020             #-- read cards of ++ $o->{actorHash}->hex
10021              
10022             # Get the store
10023 0   0     0 my $store = $o->{discoverer}->{delegate}->onDiscoverActorGroupVerifyStore($o->{storeUrl}, $o->{actorHash}) // return;
10024              
10025             # Get the public key if necessary
10026 0 0       0 if (! $o->{actorOnStore}) {
10027 0         0 my $publicKey = $o->{discoverer}->{knownPublicKeys}->{$o->{actorHash}->bytes};
10028 0 0       0 if (! $publicKey) {
10029 0         0 my ($downloadedPublicKey, $invalidReason, $storeError) = $o->{discoverer}->{keyPair}->getPublicKey($o->{actorHash}, $store);
10030 0 0       0 return $o->{discoverer}->{delegate}->onDiscoverActorGroupStoreError($store, $storeError) if defined $storeError;
10031 0 0       0 return $o->{discoverer}->{delegate}->onDiscoverActorGroupInvalidPublicKey($o->{actorHash}, $store, $invalidReason) if defined $invalidReason;
10032 0         0 $publicKey = $downloadedPublicKey;
10033             }
10034              
10035 0         0 $o->{actorOnStore} = CDS::ActorOnStore->new($publicKey, $store);
10036             }
10037              
10038             # List the public box
10039 0         0 my ($hashes, $storeError) = $store->list($o->{actorHash}, 'public', 0, $o->{discoverer}->{keyPair});
10040 0 0       0 return $o->{discoverer}->{delegate}->onDiscoverActorGroupStoreError($store, $storeError) if defined $storeError;
10041              
10042 0         0 for my $envelopeHash (@$hashes) {
10043             # Open the envelope
10044 0         0 my ($object, $storeError) = $store->get($envelopeHash, $o->{discoverer}->{keyPair});
10045 0 0       0 return $o->{discoverer}->{delegate}->onDiscoverActorGroupStoreError($store, $storeError) if defined $storeError;
10046 0 0       0 if (! $object) {
10047 0         0 $o->{discoverer}->{delegate}->onDiscoverActorGroupInvalidCard($o->{actorOnStore}, $envelopeHash, 'Envelope object not found.');
10048 0         0 next;
10049             }
10050              
10051 0         0 my $envelope = CDS::Record->fromObject($object);
10052 0 0       0 if (! $envelope) {
10053 0         0 $o->{discoverer}->{delegate}->onDiscoverActorGroupInvalidCard($o->{actorOnStore}, $envelopeHash, 'Envelope is not a record.');
10054 0         0 next;
10055             }
10056              
10057 0         0 my $cardHash = $envelope->child('content')->hashValue;
10058 0 0       0 if (! $cardHash) {
10059 0         0 $o->{discoverer}->{delegate}->onDiscoverActorGroupInvalidCard($o->{actorOnStore}, $envelopeHash, 'Missing content hash.');
10060 0         0 next;
10061             }
10062              
10063 0 0       0 if (! CDS->verifyEnvelopeSignature($envelope, $o->{actorOnStore}->publicKey, $cardHash)) {
10064 0         0 $o->{discoverer}->{delegate}->onDiscoverActorGroupInvalidCard($o->{actorOnStore}, $envelopeHash, 'Invalid signature.');
10065 0         0 next;
10066             }
10067              
10068             # Read the card
10069 0         0 my ($cardObject, $storeError1) = $store->get($cardHash, $o->{discoverer}->{keyPair});
10070 0 0       0 return $o->{discoverer}->{delegate}->onDiscoverActorGroupStoreError($store, $storeError) if defined $storeError1;
10071 0 0       0 if (! $cardObject) {
10072 0         0 $o->{discoverer}->{delegate}->onDiscoverActorGroupInvalidCard($o->{actorOnStore}, $envelopeHash, 'Card object not found.');
10073 0         0 next;
10074             }
10075              
10076 0         0 my $card = CDS::Record->fromObject($cardObject);
10077 0 0       0 if (! $card) {
10078 0         0 $o->{discoverer}->{delegate}->onDiscoverActorGroupInvalidCard($o->{actorOnStore}, $envelopeHash, 'Card is not a record.');
10079 0         0 next;
10080             }
10081              
10082             # Add the card to the list of cards
10083 0         0 push @{$o->{cards}}, CDS::DiscoverActorGroup::Card->new($o->{storeUrl}, $o->{actorOnStore}, $envelopeHash, $envelope, $cardHash, $card);
  0         0  
10084              
10085             # Parse the account list
10086 0         0 my $builder = CDS::ActorGroupBuilder->new;
10087 0         0 $builder->parseMembers($card->child('actor group'), 0);
10088 0         0 for my $member ($builder->members) {
10089 0         0 my $node = $o->{discoverer}->node($member->hash, $member->storeUrl);
10090             #-- new link ++ $o->{actorHash}->hex ++ $status ++ $hash->hex
10091 0         0 push @{$o->{links}}, CDS::DiscoverActorGroup::Link->new($node, $member->revision, $member->status);
  0         0  
10092             }
10093             }
10094             }
10095              
10096             sub attach {
10097 0     0   0 my $o = shift;
10098              
10099 0 0       0 return if $o->{attachedToUs};
10100 0 0       0 return if ! $o->hasLinkToUs;
10101              
10102             # Attach this node
10103 0         0 $o->{attachedToUs} = 1;
10104              
10105             # Merge all links
10106 0         0 for my $link (@{$o->{links}}) {
  0         0  
10107 0         0 $link->{node}->merge($link->{revision}, $link->{status});
10108             }
10109              
10110             # Add the hash to the coverage
10111 0         0 $o->{discoverer}->{coverage}->{$o->{actorHash}->bytes} = 1;
10112             }
10113              
10114             sub merge {
10115 0     0   0 my $o = shift;
10116 0         0 my $revision = shift;
10117 0         0 my $status = shift;
10118              
10119 0 0       0 return if $o->{revision} >= $revision;
10120 0         0 $o->{revision} = $revision;
10121 0         0 $o->{status} = $status;
10122             }
10123              
10124             sub hasLinkToUs {
10125 0     0   0 my $o = shift;
10126              
10127 0 0       0 return 1 if $o->{discoverer}->covers($o->{actorHash});
10128 0         0 for my $link (@{$o->{links}}) {
  0         0  
10129 0 0       0 return 1 if $o->{discoverer}->covers($link->{node}->{actorHash});
10130             }
10131 0         0 return;
10132             }
10133              
10134             package CDS::Document;
10135              
10136             sub new {
10137 0     0   0 my $class = shift;
10138 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10139 0         0 my $store = shift;
10140              
10141 0         0 my $o = bless {
10142             keyPair => $keyPair,
10143             unsaved => CDS::Unsaved->new($store),
10144             itemsBySelector => {},
10145             parts => {},
10146             hasPartsToMerge => 0,
10147             }, $class;
10148              
10149 0         0 $o->{root} = CDS::Selector->root($o);
10150 0         0 $o->{changes} = CDS::Document::Part->new;
10151 0         0 return $o;
10152             }
10153              
10154 0     0   0 sub keyPair { shift->{keyPair} }
10155 0     0   0 sub unsaved { shift->{unsaved} }
10156             sub parts {
10157 0     0   0 my $o = shift;
10158 0         0 values %{$o->{parts}} }
  0         0  
10159 0     0   0 sub hasPartsToMerge { shift->{hasPartsToMerge} }
10160              
10161             ### Items
10162              
10163 0     0   0 sub root { shift->{root} }
10164             sub rootItem {
10165 0     0   0 my $o = shift;
10166 0         0 $o->getOrCreate($o->{root}) }
10167              
10168             sub get {
10169 0     0   0 my $o = shift;
10170 0 0 0     0 my $selector = shift; die 'wrong type '.ref($selector).' for $selector' if defined $selector && ref $selector ne 'CDS::Selector';
  0         0  
10171 0         0 $o->{itemsBySelector}->{$selector->{id}} }
10172              
10173             sub getOrCreate {
10174 0     0   0 my $o = shift;
10175 0 0 0     0 my $selector = shift; die 'wrong type '.ref($selector).' for $selector' if defined $selector && ref $selector ne 'CDS::Selector';
  0         0  
10176              
10177 0         0 my $item = $o->{itemsBySelector}->{$selector->{id}};
10178 0 0       0 $o->{itemsBySelector}->{$selector->{id}} = $item = CDS::Document::Item->new($selector) if ! $item;
10179 0         0 return $item;
10180             }
10181              
10182             sub prune {
10183 0     0   0 my $o = shift;
10184 0         0 $o->rootItem->pruneTree; }
10185              
10186             ### Merging
10187              
10188             sub merge {
10189 0     0   0 my $o = shift;
10190              
10191 0         0 for my $hashAndKey (@_) {
10192 0 0       0 next if ! $hashAndKey;
10193 0 0       0 next if $o->{parts}->{$hashAndKey->hash->bytes};
10194 0         0 my $part = CDS::Document::Part->new;
10195 0         0 $part->{hashAndKey} = $hashAndKey;
10196 0         0 $o->{parts}->{$hashAndKey->hash->bytes} = $part;
10197 0         0 $o->{hasPartsToMerge} = 1;
10198             }
10199             }
10200              
10201             sub read {
10202 0     0   0 my $o = shift;
10203              
10204 0 0       0 return 1 if ! $o->{hasPartsToMerge};
10205              
10206             # Load the parts
10207 0         0 for my $part (values %{$o->{parts}}) {
  0         0  
10208 0 0       0 next if $part->{isMerged};
10209 0 0       0 next if $part->{loadedRecord};
10210              
10211 0         0 my ($record, $object, $invalidReason, $storeError) = $o->{keyPair}->getAndDecryptRecord($part->{hashAndKey}, $o->{unsaved});
10212 0 0       0 return if defined $storeError;
10213              
10214 0 0       0 delete $o->{parts}->{$part->{hashAndKey}->hash->bytes} if defined $invalidReason;
10215 0         0 $part->{loadedRecord} = $record;
10216             }
10217              
10218             # Merge the loaded parts
10219 0         0 for my $part (values %{$o->{parts}}) {
  0         0  
10220 0 0       0 next if $part->{isMerged};
10221 0 0       0 next if ! $part->{loadedRecord};
10222 0 0       0 my $oldFormat = $part->{loadedRecord}->child('client')->textValue =~ /0.19/ ? 1 : 0;
10223 0         0 $o->mergeNode($part, $o->{root}, $part->{loadedRecord}->child('root'), $oldFormat);
10224 0         0 delete $part->{loadedRecord};
10225 0         0 $part->{isMerged} = 1;
10226             }
10227              
10228 0         0 $o->{hasPartsToMerge} = 0;
10229 0         0 return 1;
10230             }
10231              
10232             sub mergeNode {
10233 0     0   0 my $o = shift;
10234 0         0 my $part = shift;
10235 0 0 0     0 my $selector = shift; die 'wrong type '.ref($selector).' for $selector' if defined $selector && ref $selector ne 'CDS::Selector';
  0         0  
10236 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
10237 0         0 my $oldFormat = shift;
10238              
10239             # Prepare
10240 0         0 my @children = $record->children;
10241 0 0       0 return if ! scalar @children;
10242 0         0 my $item = $o->getOrCreate($selector);
10243              
10244             # Merge value
10245 0         0 my $valueRecord = shift @children;
10246 0 0       0 $valueRecord = $valueRecord->firstChild if $oldFormat;
10247 0         0 $item->mergeValue($part, $valueRecord->asInteger, $valueRecord);
10248              
10249             # Merge children
10250 0         0 for my $child (@children) { $o->mergeNode($part, $selector->child($child->bytes), $child, $oldFormat); }
  0         0  
10251             }
10252              
10253             # *** Saving
10254             # Call $document->save at any time to save the current state (if necessary).
10255              
10256             # This is called by the items whenever some data changes.
10257             sub dataChanged {
10258 0     0   0 my $o = shift;
10259             }
10260              
10261             sub save {
10262 0     0   0 my $o = shift;
10263              
10264 0         0 $o->{unsaved}->startSaving;
10265 0         0 my $revision = CDS->now;
10266 0         0 my $newPart = undef;
10267              
10268             #-- saving ++ $o->{changes}->{count}
10269 0 0       0 if ($o->{changes}->{count}) {
10270             # Take the changes
10271 0         0 $newPart = $o->{changes};
10272 0         0 $o->{changes} = CDS::Document::Part->new;
10273              
10274             # Select all parts smaller than 2 * changes
10275 0         0 $newPart->{selected} = 1;
10276 0         0 my $count = $newPart->{count};
10277 0         0 while (1) {
10278 0         0 my $addedPart = 0;
10279 0         0 for my $part (values %{$o->{parts}}) {
  0         0  
10280             #-- candidate ++ $part->{count} ++ $count
10281 0 0 0     0 next if ! $part->{isMerged} || $part->{selected} || $part->{count} >= $count * 2;
      0        
10282 0         0 $count += $part->{count};
10283 0         0 $part->{selected} = 1;
10284 0         0 $addedPart = 1;
10285             }
10286              
10287 0 0       0 last if ! $addedPart;
10288             }
10289              
10290             # Include the selected items
10291 0         0 for my $item (values %{$o->{itemsBySelector}}) {
  0         0  
10292 0 0       0 next if ! $item->{part}->{selected};
10293 0         0 $item->setPart($newPart);
10294 0         0 $item->createSaveRecord;
10295             }
10296              
10297 0         0 my $record = CDS::Record->new;
10298 0         0 $record->add('created')->addInteger($revision);
10299 0         0 $record->add('client')->add(CDS->version);
10300 0         0 $record->addRecord($o->rootItem->createSaveRecord);
10301              
10302             # Detach the save records
10303 0         0 for my $item (values %{$o->{itemsBySelector}}) {
  0         0  
10304 0         0 $item->detachSaveRecord;
10305             }
10306              
10307             # Serialize and encrypt the record
10308 0         0 my $key = CDS->randomKey;
10309 0         0 my $newObject = $record->toObject->crypt($key);
10310 0         0 $newPart->{hashAndKey} = CDS::HashAndKey->new($newObject->calculateHash, $key);
10311 0         0 $newPart->{isMerged} = 1;
10312 0         0 $newPart->{selected} = 0;
10313 0         0 $o->{parts}->{$newPart->{hashAndKey}->hash->bytes} = $newPart;
10314             #-- added ++ $o->{parts} ++ scalar keys %{$o->{parts}} ++ $newPart->{count}
10315 0         0 $o->{unsaved}->{savingState}->addObject($newPart->{hashAndKey}->hash, $newObject);
10316             }
10317              
10318             # Remove obsolete parts
10319 0         0 my $obsoleteParts = [];
10320 0         0 for my $part (values %{$o->{parts}}) {
  0         0  
10321 0 0       0 next if ! $part->{isMerged};
10322 0 0       0 next if $part->{count};
10323 0         0 push @$obsoleteParts, $part;
10324 0         0 delete $o->{parts}->{$part->{hashAndKey}->hash->bytes};
10325             }
10326              
10327             # Commit
10328             #-- saving done ++ $revision ++ $newPart ++ $obsoleteParts
10329 0         0 return $o->savingDone($revision, $newPart, $obsoleteParts);
10330             }
10331              
10332             package CDS::Document::Item;
10333              
10334             sub new {
10335 0     0   0 my $class = shift;
10336 0 0 0     0 my $selector = shift; die 'wrong type '.ref($selector).' for $selector' if defined $selector && ref $selector ne 'CDS::Selector';
  0         0  
10337              
10338 0         0 my $parentSelector = $selector->parent;
10339 0 0       0 my $parent = $parentSelector ? $selector->document->getOrCreate($parentSelector) : undef;
10340              
10341 0         0 my $o = bless {
10342             document => $selector->document,
10343             selector => $selector,
10344             parent => $parent,
10345             children => [],
10346             part => undef,
10347             revision => 0,
10348             record => CDS::Record->new
10349             };
10350              
10351 0 0       0 push @{$parent->{children}}, $o if $parent;
  0         0  
10352 0         0 return $o;
10353             }
10354              
10355             sub pruneTree {
10356 0     0   0 my $o = shift;
10357              
10358             # Try to remove children
10359 0         0 for my $child (@{$o->{children}}) { $child->pruneTree; }
  0         0  
  0         0  
10360              
10361             # Don't remove the root item
10362 0 0       0 return if ! $o->{parent};
10363              
10364             # Don't remove if the item has children, or a value
10365 0 0       0 return if scalar @{$o->{children}};
  0         0  
10366 0 0       0 return if $o->{revision} > 0;
10367              
10368             # Remove this from the tree
10369 0         0 $o->{parent}->{children} = [grep { $_ != $o } @{$o->{parent}->{children}}];
  0         0  
  0         0  
10370              
10371             # Remove this from the document hash
10372 0         0 delete $o->{document}->{itemsBySelector}->{$o->{selector}->{id}};
10373             }
10374              
10375             # Low-level part change.
10376             sub setPart {
10377 0     0   0 my $o = shift;
10378 0         0 my $part = shift;
10379              
10380 0 0       0 $o->{part}->{count} -= 1 if $o->{part};
10381 0         0 $o->{part} = $part;
10382 0 0       0 $o->{part}->{count} += 1 if $o->{part};
10383             }
10384              
10385             # Merge a value
10386              
10387             sub mergeValue {
10388 0     0   0 my $o = shift;
10389 0         0 my $part = shift;
10390 0         0 my $revision = shift;
10391 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
10392              
10393 0 0       0 return if $revision <= 0;
10394 0 0       0 return if $revision < $o->{revision};
10395 0 0 0     0 return if $revision == $o->{revision} && $part->{size} < $o->{part}->{size};
10396 0         0 $o->setPart($part);
10397 0         0 $o->{revision} = $revision;
10398 0         0 $o->{record} = $record;
10399 0         0 $o->{document}->dataChanged;
10400 0         0 return 1;
10401             }
10402              
10403             sub forget {
10404 0     0   0 my $o = shift;
10405              
10406 0 0       0 return if $o->{revision} <= 0;
10407 0         0 $o->{revision} = 0;
10408 0         0 $o->{record} = CDS::Record->new;
10409 0         0 $o->setPart;
10410             }
10411              
10412             # Saving
10413              
10414             sub createSaveRecord {
10415 0     0   0 my $o = shift;
10416              
10417 0 0       0 return $o->{saveRecord} if $o->{saveRecord};
10418 0 0       0 $o->{saveRecord} = $o->{parent} ? $o->{parent}->createSaveRecord->add($o->{selector}->{label}) : CDS::Record->new('root');
10419 0 0       0 if ($o->{part}->{selected}) {
10420 0 0       0 CDS->log('Item saving zero revision of ', $o->{selector}->label) if $o->{revision} <= 0;
10421 0         0 $o->{saveRecord}->addInteger($o->{revision})->addRecord($o->{record}->children);
10422             } else {
10423 0         0 $o->{saveRecord}->add('');
10424             }
10425 0         0 return $o->{saveRecord};
10426             }
10427              
10428             sub detachSaveRecord {
10429 0     0   0 my $o = shift;
10430              
10431 0 0       0 return if ! $o->{saveRecord};
10432 0         0 delete $o->{saveRecord};
10433 0 0       0 $o->{parent}->detachSaveRecord if $o->{parent};
10434             }
10435              
10436             package CDS::Document::Part;
10437              
10438             sub new {
10439 0     0   0 my $class = shift;
10440              
10441 0         0 return bless {
10442             isMerged => 0,
10443             hashAndKey => undef,
10444             size => 0,
10445             count => 0,
10446             selected => 0,
10447             };
10448             }
10449              
10450             # In this implementation, we only keep track of the number of values of the list, but
10451             # not of the corresponding items. This saves memory (~100 MiB for 1M items), but takes
10452             # more time (0.5 s for 1M items) when saving. Since command line programs usually write
10453             # the document only once, this is acceptable. Reading the tree anyway takes about 10
10454             # times more time.
10455              
10456             package CDS::ErrorHandlingStore;
10457              
10458 1     1   5082 use parent -norequire, 'CDS::Store';
  1         3  
  1         23  
10459              
10460             sub new {
10461 0     0   0 my $class = shift;
10462 0         0 my $store = shift;
10463 0         0 my $url = shift;
10464 0         0 my $errorHandler = shift;
10465              
10466 0         0 return bless {
10467             store => $store,
10468             url => $url,
10469             errorHandler => $errorHandler,
10470             }
10471             }
10472              
10473 0     0   0 sub store { shift->{store} }
10474 0     0   0 sub url { shift->{url} }
10475 0     0   0 sub errorHandler { shift->{errorHandler} }
10476              
10477             sub id {
10478 0     0   0 my $o = shift;
10479 0         0 'Error handling'."\n ".$o->{store}->id }
10480              
10481             sub get {
10482 0     0   0 my $o = shift;
10483 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
10484 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10485              
10486 0 0       0 return undef, 'Store disabled.' if $o->{errorHandler}->hasStoreError($o, 'GET');
10487              
10488 0         0 my ($object, $error) = $o->{store}->get($hash, $keyPair);
10489 0 0       0 if (defined $error) {
10490 0         0 $o->{errorHandler}->onStoreError($o, 'GET', $error);
10491 0         0 return undef, $error;
10492             }
10493              
10494 0         0 $o->{errorHandler}->onStoreSuccess($o, 'GET');
10495 0         0 return $object, $error;
10496             }
10497              
10498             sub book {
10499 0     0   0 my $o = shift;
10500 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
10501 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10502              
10503 0 0       0 return undef, 'Store disabled.' if $o->{errorHandler}->hasStoreError($o, 'BOOK');
10504              
10505 0         0 my ($booked, $error) = $o->{store}->book($hash, $keyPair);
10506 0 0       0 if (defined $error) {
10507 0         0 $o->{errorHandler}->onStoreError($o, 'BOOK', $error);
10508 0         0 return undef, $error;
10509             }
10510              
10511 0         0 $o->{errorHandler}->onStoreSuccess($o, 'BOOK');
10512 0         0 return $booked;
10513             }
10514              
10515             sub put {
10516 0     0   0 my $o = shift;
10517 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
10518 0 0 0     0 my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0         0  
10519 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10520              
10521 0 0       0 return 'Store disabled.' if $o->{errorHandler}->hasStoreError($o, 'PUT');
10522              
10523 0         0 my $error = $o->{store}->put($hash, $object, $keyPair);
10524 0 0       0 if (defined $error) {
10525 0         0 $o->{errorHandler}->onStoreError($o, 'PUT', $error);
10526 0         0 return $error;
10527             }
10528              
10529 0         0 $o->{errorHandler}->onStoreSuccess($o, 'PUT');
10530 0         0 return;
10531             }
10532              
10533             sub list {
10534 0     0   0 my $o = shift;
10535 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
10536 0         0 my $boxLabel = shift;
10537 0         0 my $timeout = shift;
10538 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10539              
10540 0 0       0 return undef, 'Store disabled.' if $o->{errorHandler}->hasStoreError($o, 'LIST');
10541              
10542 0         0 my ($hashes, $error) = $o->{store}->list($accountHash, $boxLabel, $timeout, $keyPair);
10543 0 0       0 if (defined $error) {
10544 0         0 $o->{errorHandler}->onStoreError($o, 'LIST', $error);
10545 0         0 return undef, $error;
10546             }
10547              
10548 0         0 $o->{errorHandler}->onStoreSuccess($o, 'LIST');
10549 0         0 return $hashes;
10550             }
10551              
10552             sub add {
10553 0     0   0 my $o = shift;
10554 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
10555 0         0 my $boxLabel = shift;
10556 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
10557 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10558              
10559 0 0       0 return 'Store disabled.' if $o->{errorHandler}->hasStoreError($o, 'ADD');
10560              
10561 0         0 my $error = $o->{store}->add($accountHash, $boxLabel, $hash, $keyPair);
10562 0 0       0 if (defined $error) {
10563 0         0 $o->{errorHandler}->onStoreError($o, 'ADD', $error);
10564 0         0 return $error;
10565             }
10566              
10567 0         0 $o->{errorHandler}->onStoreSuccess($o, 'ADD');
10568 0         0 return;
10569             }
10570              
10571             sub remove {
10572 0     0   0 my $o = shift;
10573 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
10574 0         0 my $boxLabel = shift;
10575 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
10576 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10577              
10578 0 0       0 return 'Store disabled.' if $o->{errorHandler}->hasStoreError($o, 'REMOVE');
10579              
10580 0         0 my $error = $o->{store}->remove($accountHash, $boxLabel, $hash, $keyPair);
10581 0 0       0 if (defined $error) {
10582 0         0 $o->{errorHandler}->onStoreError($o, 'REMOVE', $error);
10583 0         0 return $error;
10584             }
10585              
10586 0         0 $o->{errorHandler}->onStoreSuccess($o, 'REMOVE');
10587 0         0 return;
10588             }
10589              
10590             sub modify {
10591 0     0   0 my $o = shift;
10592 0         0 my $modifications = shift;
10593 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10594              
10595 0 0       0 return 'Store disabled.' if $o->{errorHandler}->hasStoreError($o, 'MODIFY');
10596              
10597 0         0 my $error = $o->{store}->modify($modifications, $keyPair);
10598 0 0       0 if (defined $error) {
10599 0         0 $o->{errorHandler}->onStoreError($o, 'MODIFY', $error);
10600 0         0 return $error;
10601             }
10602              
10603 0         0 $o->{errorHandler}->onStoreSuccess($o, 'MODIFY');
10604 0         0 return;
10605             }
10606              
10607             # A Condensation store on a local folder.
10608             package CDS::FolderStore;
10609              
10610 1     1   1283 use parent -norequire, 'CDS::Store';
  1         2  
  1         13  
10611              
10612             sub forUrl {
10613 0     0   0 my $class = shift;
10614 0         0 my $url = shift;
10615              
10616 0 0       0 return if substr($url, 0, 8) ne 'file:///';
10617 0         0 return $class->new(substr($url, 7));
10618             }
10619              
10620             sub new {
10621 0     0   0 my $class = shift;
10622 0         0 my $folder = shift;
10623              
10624 0         0 return bless {
10625             folder => $folder,
10626             permissions => CDS::FolderStore::PosixPermissions->forFolder($folder.'/accounts'),
10627             };
10628             }
10629              
10630             sub id {
10631 0     0   0 my $o = shift;
10632 0         0 'file://'.$o->{folder} }
10633 0     0   0 sub folder { shift->{folder} }
10634              
10635 0     0   0 sub permissions { shift->{permissions} }
10636             sub setPermissions {
10637 0     0   0 my $o = shift;
10638 0         0 my $permissions = shift;
10639 0         0 $o->{permissions} = $permissions; }
10640              
10641             sub get {
10642 0     0   0 my $o = shift;
10643 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
10644 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10645              
10646 0         0 my $hashHex = $hash->hex;
10647 0         0 my $file = $o->{folder}.'/objects/'.substr($hashHex, 0, 2).'/'.substr($hashHex, 2);
10648 0         0 return CDS::Object->fromBytes(CDS->readBytesFromFile($file));
10649             }
10650              
10651             sub book {
10652 0     0   0 my $o = shift;
10653 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
10654 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10655              
10656             # Book the object if it exists
10657 0         0 my $hashHex = $hash->hex;
10658 0         0 my $folder = $o->{folder}.'/objects/'.substr($hashHex, 0, 2);
10659 0         0 my $file = $folder.'/'.substr($hashHex, 2);
10660 0 0 0     0 return 1 if -e $file && utime(undef, undef, $file);
10661 0         0 return;
10662             }
10663              
10664             sub put {
10665 0     0   0 my $o = shift;
10666 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
10667 0 0 0     0 my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0         0  
10668 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10669              
10670             # Book the object if it exists
10671 0         0 my $hashHex = $hash->hex;
10672 0         0 my $folder = $o->{folder}.'/objects/'.substr($hashHex, 0, 2);
10673 0         0 my $file = $folder.'/'.substr($hashHex, 2);
10674 0 0 0     0 return if -e $file && utime(undef, undef, $file);
10675              
10676             # Write the file, set the permissions, and move it to the right place
10677 0         0 my $permissions = $o->{permissions};
10678 0         0 $permissions->mkdir($folder, $permissions->objectFolderMode);
10679 0   0     0 my $temporaryFile = $permissions->writeTemporaryFile($folder, $permissions->objectFileMode, $object->bytes) // return 'Failed to write object';
10680 0 0       0 rename($temporaryFile, $file) || return 'Failed to rename object.';
10681 0         0 return;
10682             }
10683              
10684             sub list {
10685 0     0   0 my $o = shift;
10686 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
10687 0         0 my $boxLabel = shift;
10688 0         0 my $timeout = shift;
10689 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10690              
10691 0 0       0 return undef, 'Invalid box label.' if ! CDS->isValidBoxLabel($boxLabel);
10692              
10693             # Prepare
10694 0         0 my $boxFolder = $o->{folder}.'/accounts/'.$accountHash->hex.'/'.$boxLabel;
10695              
10696             # List
10697 0 0       0 return $o->listFolder($boxFolder) if ! $timeout;
10698              
10699             # Watch
10700 0         0 my $hashes;
10701 0         0 my $watcher = CDS::FolderStore::Watcher->new($boxFolder);
10702 0         0 my $watchUntil = CDS->now + $timeout;
10703 0         0 while (1) {
10704             # List
10705 0         0 $hashes = $o->listFolder($boxFolder);
10706 0 0       0 last if scalar @$hashes;
10707              
10708             # Wait
10709 0   0     0 $watcher->wait($watchUntil - CDS->now, $watchUntil) // last;
10710             }
10711              
10712 0         0 $watcher->done;
10713 0         0 return $hashes;
10714             }
10715              
10716             sub listFolder {
10717 0     0   0 my $o = shift;
10718 0         0 my $boxFolder = shift;
10719             # private
10720 0         0 my $hashes = [];
10721 0         0 for my $file (CDS->listFolder($boxFolder)) {
10722 0   0     0 push @$hashes, CDS::Hash->fromHex($file) // next;
10723             }
10724              
10725 0         0 return $hashes;
10726             }
10727              
10728             sub add {
10729 0     0   0 my $o = shift;
10730 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
10731 0         0 my $boxLabel = shift;
10732 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
10733 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10734              
10735 0         0 my $permissions = $o->{permissions};
10736              
10737 0 0       0 return if ! CDS->isValidBoxLabel($boxLabel);
10738 0         0 my $accountFolder = $o->{folder}.'/accounts/'.$accountHash->hex;
10739 0         0 $permissions->mkdir($accountFolder, $permissions->accountFolderMode);
10740 0         0 my $boxFolder = $accountFolder.'/'.$boxLabel;
10741 0         0 $permissions->mkdir($boxFolder, $permissions->boxFolderMode($boxLabel));
10742 0         0 my $boxFileMode = $permissions->boxFileMode($boxLabel);
10743              
10744 0   0     0 my $temporaryFile = $permissions->writeTemporaryFile($boxFolder, $boxFileMode, '') // return 'Failed to write file.';
10745 0 0       0 rename($temporaryFile, $boxFolder.'/'.$hash->hex) || return 'Failed to rename file.';
10746 0         0 return;
10747             }
10748              
10749             sub remove {
10750 0     0   0 my $o = shift;
10751 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
10752 0         0 my $boxLabel = shift;
10753 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
10754 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10755              
10756 0 0       0 return if ! CDS->isValidBoxLabel($boxLabel);
10757 0         0 my $accountFolder = $o->{folder}.'/accounts/'.$accountHash->hex;
10758 0         0 my $boxFolder = $accountFolder.'/'.$boxLabel;
10759 0 0       0 return if ! -d $boxFolder;
10760 0         0 unlink $boxFolder.'/'.$hash->hex;
10761 0         0 return;
10762             }
10763              
10764             sub modify {
10765 0     0   0 my $o = shift;
10766 0         0 my $modifications = shift;
10767 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
10768              
10769 0         0 return $modifications->executeIndividually($o, $keyPair);
10770             }
10771              
10772             # Store administration functions
10773              
10774             sub exists {
10775 0     0   0 my $o = shift;
10776              
10777 0   0     0 return -d $o->{folder}.'/accounts' && -d $o->{folder}.'/objects';
10778             }
10779              
10780             # Creates the store if it does not exist. The store folder itself must exist.
10781             sub createIfNecessary {
10782 0     0   0 my $o = shift;
10783              
10784 0         0 my $accountsFolder = $o->{folder}.'/accounts';
10785 0         0 my $objectsFolder = $o->{folder}.'/objects';
10786 0         0 $o->{permissions}->mkdir($accountsFolder, $o->{permissions}->baseFolderMode);
10787 0         0 $o->{permissions}->mkdir($objectsFolder, $o->{permissions}->baseFolderMode);
10788 0   0     0 return -d $accountsFolder && -d $objectsFolder;
10789             }
10790              
10791             # Lists accounts. This is a non-standard extension.
10792             sub accounts {
10793 0     0   0 my $o = shift;
10794              
10795 0         0 return grep { defined $_ }
10796 0         0 map { CDS::Hash->fromHex($_) }
10797 0         0 CDS->listFolder($o->{folder}.'/accounts');
10798             }
10799              
10800             # Adds an account. This is a non-standard extension.
10801             sub addAccount {
10802 0     0   0 my $o = shift;
10803 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
10804              
10805 0         0 my $accountFolder = $o->{folder}.'/accounts/'.$accountHash->hex;
10806 0         0 $o->{permissions}->mkdir($accountFolder, $o->{permissions}->accountFolderMode);
10807 0         0 return -d $accountFolder;
10808             }
10809              
10810             # Removes an account. This is a non-standard extension.
10811             sub removeAccount {
10812 0     0   0 my $o = shift;
10813 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
10814              
10815 0         0 my $accountFolder = $o->{folder}.'/accounts/'.$accountHash->hex;
10816 0         0 my $trashFolder = $o->{folder}.'/accounts/.deleted-'.CDS->randomHex(16);
10817 0         0 rename $accountFolder, $trashFolder;
10818 0         0 system('rm', '-rf', $trashFolder);
10819 0         0 return ! -d $accountFolder;
10820             }
10821              
10822             # Checks (and optionally fixes) the POSIX permissions of all files and folders. This is a non-standard extension.
10823             sub checkPermissions {
10824 0     0   0 my $o = shift;
10825 0         0 my $logger = shift;
10826              
10827 0         0 my $permissions = $o->{permissions};
10828              
10829             # Check the accounts folder
10830 0         0 my $accountsFolder = $o->{folder}.'/accounts';
10831 0 0       0 $permissions->checkPermissions($accountsFolder, $permissions->baseFolderMode, $logger) || return;
10832              
10833             # Check the account folders
10834 0         0 for my $account (sort { $a cmp $b } CDS->listFolder($accountsFolder)) {
  0         0  
10835 0 0       0 next if $account !~ /^[0-9a-f]{64}$/;
10836 0         0 my $accountFolder = $accountsFolder.'/'.$account;
10837 0 0       0 $permissions->checkPermissions($accountFolder, $permissions->accountFolderMode, $logger) || return;
10838              
10839             # Check the box folders
10840 0         0 for my $boxLabel (sort { $a cmp $b } CDS->listFolder($accountFolder)) {
  0         0  
10841 0 0       0 next if $boxLabel =~ /^\./;
10842 0         0 my $boxFolder = $accountFolder.'/'.$boxLabel;
10843 0 0       0 $permissions->checkPermissions($boxFolder, $permissions->boxFolderMode($boxLabel), $logger) || return;
10844              
10845             # Check each file
10846 0         0 my $filePermissions = $permissions->boxFileMode($boxLabel);
10847 0         0 for my $file (sort { $a cmp $b } CDS->listFolder($boxFolder)) {
  0         0  
10848 0 0       0 next if $file !~ /^[0-9a-f]{64}/;
10849 0 0       0 $permissions->checkPermissions($boxFolder.'/'.$file, $filePermissions, $logger) || return;
10850             }
10851             }
10852             }
10853              
10854             # Check the objects folder
10855 0         0 my $objectsFolder = $o->{folder}.'/objects';
10856 0         0 my $fileMode = $permissions->objectFileMode;
10857 0         0 my $folderMode = $permissions->objectFolderMode;
10858 0 0       0 $permissions->checkPermissions($objectsFolder, $folderMode, $logger) || return;
10859              
10860             # Check the 256 sub folders
10861 0         0 for my $sub (sort { $a cmp $b } CDS->listFolder($objectsFolder)) {
  0         0  
10862 0 0       0 next if $sub !~ /^[0-9a-f][0-9a-f]$/;
10863 0         0 my $subFolder = $objectsFolder.'/'.$sub;
10864 0 0       0 $permissions->checkPermissions($subFolder, $folderMode, $logger) || return;
10865              
10866 0         0 for my $file (sort { $a cmp $b } CDS->listFolder($subFolder)) {
  0         0  
10867 0 0       0 next if $file !~ /^[0-9a-f]{62}/;
10868 0 0       0 $permissions->checkPermissions($subFolder.'/'.$file, $fileMode, $logger) || return;
10869             }
10870             }
10871              
10872 0         0 return 1;
10873             }
10874              
10875             # Handles POSIX permissions (user, group, and mode).
10876             package CDS::FolderStore::PosixPermissions;
10877              
10878             # Returns the permissions set corresponding to the mode, uid, and gid of the base folder.
10879             # If the permissions are ambiguous, the more restrictive set is chosen.
10880             sub forFolder {
10881 0     0   0 my $class = shift;
10882 0         0 my $folder = shift;
10883              
10884 0         0 my @s = stat $folder;
10885 0   0     0 my $mode = $s[2] // 0;
10886              
10887             return
10888 0 0       0 ($mode & 077) == 077 ? CDS::FolderStore::PosixPermissions::World->new :
    0          
10889             ($mode & 070) == 070 ? CDS::FolderStore::PosixPermissions::Group->new($s[5]) :
10890             CDS::FolderStore::PosixPermissions::User->new($s[4]);
10891             }
10892              
10893 0     0   0 sub uid { shift->{uid} }
10894 0     0   0 sub gid { shift->{gid} }
10895              
10896             sub user {
10897 0     0   0 my $o = shift;
10898              
10899 0   0     0 my $uid = $o->{uid} // return;
10900 0   0     0 return getpwuid($uid) // $uid;
10901             }
10902              
10903             sub group {
10904 0     0   0 my $o = shift;
10905              
10906 0   0     0 my $gid = $o->{gid} // return;
10907 0   0     0 return getgrgid($gid) // $gid;
10908             }
10909              
10910             sub writeTemporaryFile {
10911 0     0   0 my $o = shift;
10912 0         0 my $folder = shift;
10913 0         0 my $mode = shift;
10914              
10915             # Write the file
10916 0         0 my $temporaryFile = $folder.'/.'.CDS->randomHex(16);
10917 0 0       0 open(my $fh, '>:bytes', $temporaryFile) || return;
10918 0         0 print $fh @_;
10919 0         0 close $fh;
10920              
10921             # Set the permissions
10922 0         0 chmod $mode, $temporaryFile;
10923 0         0 my $uid = $o->uid;
10924 0         0 my $gid = $o->gid;
10925 0 0 0     0 chown $uid // -1, $gid // -1, $temporaryFile if defined $uid && $uid != $< || defined $gid && $gid != $(;
      0        
      0        
      0        
      0        
10926 0         0 return $temporaryFile;
10927             }
10928              
10929             sub mkdir {
10930 0     0   0 my $o = shift;
10931 0         0 my $folder = shift;
10932 0         0 my $mode = shift;
10933              
10934 0 0       0 return if -d $folder;
10935              
10936             # Create the folder (note: mode is altered by umask)
10937 0         0 my $success = mkdir $folder, $mode;
10938              
10939             # Set the permissions
10940 0         0 chmod $mode, $folder;
10941 0         0 my $uid = $o->uid;
10942 0         0 my $gid = $o->gid;
10943 0 0 0     0 chown $uid // -1, $gid // -1, $folder if defined $uid && $uid != $< || defined $gid && $gid != $(;
      0        
      0        
      0        
      0        
10944 0         0 return $success;
10945             }
10946              
10947             # Check the permissions of a file or folder, and fix them if desired.
10948             # A logger object is called for the different cases (access error, correct permissions, wrong permissions, error fixing permissions).
10949             sub checkPermissions {
10950 0     0   0 my $o = shift;
10951 0         0 my $item = shift;
10952 0         0 my $expectedMode = shift;
10953 0         0 my $logger = shift;
10954              
10955 0         0 my $expectedUid = $o->uid;
10956 0         0 my $expectedGid = $o->gid;
10957              
10958             # Stat the item
10959 0         0 my @s = stat $item;
10960 0 0       0 return $logger->accessError($item) if ! scalar @s;
10961 0         0 my $mode = $s[2] & 07777;
10962 0         0 my $uid = $s[4];
10963 0         0 my $gid = $s[5];
10964              
10965             # Check
10966 0   0     0 my $wrongUid = defined $expectedUid && $uid != $expectedUid;
10967 0   0     0 my $wrongGid = defined $expectedGid && $gid != $expectedGid;
10968 0         0 my $wrongMode = $mode != $expectedMode;
10969 0 0 0     0 if ($wrongUid || $wrongGid || $wrongMode) {
      0        
10970             # Something is wrong
10971 0 0       0 $logger->wrong($item, $uid, $gid, $mode, $expectedUid, $expectedGid, $expectedMode) || return 1;
10972              
10973             # Fix uid and gid
10974 0 0 0     0 if ($wrongUid || $wrongGid) {
10975 0   0     0 my $count = chown $expectedUid // -1, $expectedGid // -1, $item;
      0        
10976 0 0       0 return $logger->setError($item) if $count < 1;
10977             }
10978              
10979             # Fix mode
10980 0 0       0 if ($wrongMode) {
10981 0         0 my $count = chmod $expectedMode, $item;
10982 0 0       0 return $logger->setError($item) if $count < 1;
10983             }
10984             } else {
10985             # Everything is OK
10986 0         0 $logger->correct($item, $mode, $uid, $gid);
10987             }
10988              
10989 0         0 return 1;
10990             }
10991              
10992             # 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.
10993             # The resulting store will have files belonging to multiple users, but the same group.
10994             package CDS::FolderStore::PosixPermissions::Group;
10995              
10996 1     1   3008 use parent -norequire, 'CDS::FolderStore::PosixPermissions';
  1         3  
  1         5  
10997              
10998             sub new {
10999 0     0   0 my $class = shift;
11000 0         0 my $gid = shift;
11001              
11002 0   0     0 return bless {gid => $gid // $(};
11003             }
11004              
11005             sub target {
11006 0     0   0 my $o = shift;
11007 0         0 'members of the group '.$o->group }
11008 0     0   0 sub baseFolderMode { 0771 }
11009 0     0   0 sub objectFolderMode { 0771 }
11010 0     0   0 sub objectFileMode { 0664 }
11011 0     0   0 sub accountFolderMode { 0771 }
11012             sub boxFolderMode {
11013 0     0   0 my $o = shift;
11014 0         0 my $boxLabel = shift;
11015 0 0       0 $boxLabel eq 'public' ? 0775 : 0770 }
11016             sub boxFileMode {
11017 0     0   0 my $o = shift;
11018 0         0 my $boxLabel = shift;
11019 0 0       0 $boxLabel eq 'public' ? 0664 : 0660 }
11020              
11021             # 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.
11022             package CDS::FolderStore::PosixPermissions::User;
11023              
11024 1     1   244 use parent -norequire, 'CDS::FolderStore::PosixPermissions';
  1         2  
  1         4  
11025              
11026             sub new {
11027 0     0   0 my $class = shift;
11028 0         0 my $uid = shift;
11029              
11030 0   0     0 return bless {uid => $uid // $<};
11031             }
11032              
11033             sub target {
11034 0     0   0 my $o = shift;
11035 0         0 'user '.$o->user }
11036 0     0   0 sub baseFolderMode { 0711 }
11037 0     0   0 sub objectFolderMode { 0711 }
11038 0     0   0 sub objectFileMode { 0644 }
11039 0     0   0 sub accountFolderMode { 0711 }
11040             sub boxFolderMode {
11041 0     0   0 my $o = shift;
11042 0         0 my $boxLabel = shift;
11043 0 0       0 $boxLabel eq 'public' ? 0755 : 0700 }
11044             sub boxFileMode {
11045 0     0   0 my $o = shift;
11046 0         0 my $boxLabel = shift;
11047 0 0       0 $boxLabel eq 'public' ? 0644 : 0600 }
11048              
11049             # The store is open to everybody. This does not usually make sense, but is offered here for completeness.
11050             # This is the simplest permission scheme.
11051             package CDS::FolderStore::PosixPermissions::World;
11052              
11053 1     1   232 use parent -norequire, 'CDS::FolderStore::PosixPermissions';
  1         3  
  1         17  
11054              
11055             sub new {
11056 0     0   0 my $class = shift;
11057              
11058 0         0 return bless {};
11059             }
11060              
11061 0     0   0 sub target { 'everybody' }
11062 0     0   0 sub baseFolderMode { 0777 }
11063 0     0   0 sub objectFolderMode { 0777 }
11064 0     0   0 sub objectFileMode { 0666 }
11065 0     0   0 sub accountFolderMode { 0777 }
11066 0     0   0 sub boxFolderMode { 0777 }
11067 0     0   0 sub boxFileMode { 0666 }
11068              
11069             package CDS::FolderStore::Watcher;
11070              
11071             sub new {
11072 0     0   0 my $class = shift;
11073 0         0 my $folder = shift;
11074              
11075 0         0 return bless {folder => $folder};
11076             }
11077              
11078             sub wait {
11079 0     0   0 my $o = shift;
11080 0         0 my $remaining = shift;
11081 0         0 my $until = shift;
11082              
11083 0 0       0 return if $remaining <= 0;
11084 0         0 sleep 1;
11085 0         0 return 1;
11086             }
11087              
11088             sub done {
11089 0     0   0 my $o = shift;
11090             }
11091              
11092             package CDS::GroupDataSharer;
11093              
11094             sub new {
11095 0     0   0 my $class = shift;
11096 0         0 my $actor = shift;
11097              
11098 0         0 my $o = bless {
11099             actor => $actor,
11100             label => 'shared group data',
11101             dataHandlers => {},
11102             messageChannel => CDS::MessageChannel->new($actor, 'group data', CDS->MONTH),
11103             revision => 0,
11104             version => '',
11105             }, $class;
11106              
11107 0         0 $actor->storagePrivateRoot->addDataHandler($o->{label}, $o);
11108 0         0 return $o;
11109             }
11110              
11111             ### Group data handlers
11112              
11113             sub addDataHandler {
11114 0     0   0 my $o = shift;
11115 0         0 my $label = shift;
11116 0         0 my $dataHandler = shift;
11117              
11118 0         0 $o->{dataHandlers}->{$label} = $dataHandler;
11119             }
11120              
11121             sub removeDataHandler {
11122 0     0   0 my $o = shift;
11123 0         0 my $label = shift;
11124 0         0 my $dataHandler = shift;
11125              
11126 0         0 my $registered = $o->{dataHandlers}->{$label};
11127 0 0       0 return if $registered != $dataHandler;
11128 0         0 delete $o->{dataHandlers}->{$label};
11129             }
11130              
11131             ### MergeableData interface
11132              
11133             sub addDataTo {
11134 0     0   0 my $o = shift;
11135 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
11136              
11137 0 0       0 return if ! $o->{revision};
11138 0         0 $record->addInteger($o->{revision})->add($o->{version});
11139             }
11140              
11141             sub mergeData {
11142 0     0   0 my $o = shift;
11143 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
11144              
11145 0         0 for my $child ($record->children) {
11146 0         0 my $revision = $child->asInteger;
11147 0 0       0 next if $revision <= $o->{revision};
11148              
11149 0         0 $o->{revision} = $revision;
11150 0         0 $o->{version} = $child->bytesValue;
11151             }
11152             }
11153              
11154             sub mergeExternalData {
11155 0     0   0 my $o = shift;
11156 0         0 my $store = shift;
11157 0 0 0     0 my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0         0  
11158 0 0 0     0 my $source = shift; die 'wrong type '.ref($source).' for $source' if defined $source && ref $source ne 'CDS::Source';
  0         0  
11159              
11160 0         0 $o->mergeData($record);
11161 0 0       0 return if ! $source;
11162 0         0 $source->keep;
11163 0         0 $o->{actor}->storagePrivateRoot->unsaved->state->addMergedSource($source);
11164             }
11165              
11166             ### Sending messages
11167              
11168             sub createMessage {
11169 0     0   0 my $o = shift;
11170              
11171 0         0 my $message = CDS::Record->new;
11172 0         0 my $data = $message->add('group data');
11173 0         0 for my $label (keys %{$o->{dataHandlers}}) {
  0         0  
11174 0         0 my $dataHandler = $o->{dataHandlers}->{$label};
11175 0         0 $dataHandler->addDataTo($data->add($label));
11176             }
11177 0         0 return $message;
11178             }
11179              
11180             sub share {
11181 0     0   0 my $o = shift;
11182              
11183             # Get the group data members
11184 0   0     0 my $members = $o->{actor}->getGroupDataMembers // return;
11185 0 0       0 return 1 if ! scalar @$members;
11186              
11187             # Create the group data message, and check if it changed
11188 0         0 my $message = $o->createMessage;
11189 0         0 my $versionHash = $message->toObject->calculateHash;
11190 0 0       0 return if $versionHash->bytes eq $o->{version};
11191              
11192 0         0 $o->{revision} = CDS->now;
11193 0         0 $o->{version} = $versionHash->bytes;
11194 0         0 $o->{actor}->storagePrivateRoot->dataChanged;
11195              
11196             # Procure the sent list
11197 0   0     0 $o->{actor}->procureSentList // return;
11198              
11199             # Get the entrusted keys
11200 0   0     0 my $entrustedKeys = $o->{actor}->getEntrustedKeys // return;
11201              
11202             # Transfer the data
11203 0         0 $o->{messageChannel}->addTransfer([$message->dependentHashes], $o->{actor}->storagePrivateRoot->unsaved, 'group data message');
11204              
11205             # Send the message
11206 0         0 $o->{messageChannel}->setRecipients($members, $entrustedKeys);
11207 0         0 my ($submission, $missingObject) = $o->{messageChannel}->submit($message, $o);
11208 0 0       0 $o->{actor}->onMissingObject($missingObject) if $missingObject;
11209 0 0       0 return if ! $submission;
11210 0         0 return 1;
11211             }
11212              
11213             sub onMessageChannelSubmissionCancelled {
11214 0     0   0 my $o = shift;
11215             }
11216              
11217             sub onMessageChannelSubmissionRecipientDone {
11218 0     0   0 my $o = shift;
11219 0 0 0     0 my $recipientActorOnStore = shift; die 'wrong type '.ref($recipientActorOnStore).' for $recipientActorOnStore' if defined $recipientActorOnStore && ref $recipientActorOnStore ne 'CDS::ActorOnStore';
  0         0  
11220             }
11221              
11222             sub onMessageChannelSubmissionRecipientFailed {
11223 0     0   0 my $o = shift;
11224 0 0 0     0 my $recipientActorOnStore = shift; die 'wrong type '.ref($recipientActorOnStore).' for $recipientActorOnStore' if defined $recipientActorOnStore && ref $recipientActorOnStore ne 'CDS::ActorOnStore';
  0         0  
11225             }
11226              
11227             sub onMessageChannelSubmissionDone {
11228 0     0   0 my $o = shift;
11229 0         0 my $succeeded = shift;
11230 0         0 my $failed = shift;
11231             }
11232              
11233             ### Receiving messages
11234              
11235             sub processGroupDataMessage {
11236 0     0   0 my $o = shift;
11237 0         0 my $message = shift;
11238 0         0 my $section = shift;
11239              
11240 0 0       0 if (! $o->{actor}->isGroupMember($message->sender->publicKey->hash)) {
11241             # TODO:
11242             # 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.
11243             # 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).
11244 0         0 return;
11245             }
11246              
11247 0         0 for my $child ($section->children) {
11248 0   0     0 my $dataHandler = $o->{dataHandlers}->{$child->bytes} // next;
11249 0         0 $dataHandler->mergeExternalData($message->sender->store, $child, $message->source);
11250             }
11251              
11252 0         0 return 1;
11253             }
11254              
11255             package CDS::HTTPServer;
11256              
11257 1     1   1352 use parent -norequire, 'HTTP::Server::Simple';
  1         2  
  1         5  
11258              
11259             sub new {
11260 0     0   0 my $class = shift;
11261              
11262 0         0 my $o = $class->SUPER::new(@_);
11263 0         0 $o->{logger} = CDS::HTTPServer::Logger->new(*STDERR);
11264 0         0 $o->{handlers} = [];
11265 0         0 return $o;
11266             }
11267              
11268             sub addHandler {
11269 0     0   0 my $o = shift;
11270 0         0 my $handler = shift;
11271              
11272 0         0 push @{$o->{handlers}}, $handler;
  0         0  
11273             }
11274              
11275             sub setLogger {
11276 0     0   0 my $o = shift;
11277 0         0 my $logger = shift;
11278              
11279 0         0 $o->{logger} = $logger;
11280             }
11281              
11282 0     0   0 sub logger { shift->{logger} }
11283              
11284             sub setCorsAllowEverybody {
11285 0     0   0 my $o = shift;
11286 0         0 my $value = shift;
11287              
11288 0         0 $o->{corsAllowEverybody} = $value;
11289             }
11290              
11291 0     0   0 sub corsAllowEverybody { shift->{corsAllowEverybody} }
11292              
11293             # *** HTTP::Server::Simple interface
11294              
11295             sub print_banner {
11296 0     0   0 my $o = shift;
11297              
11298 0         0 $o->{logger}->onServerStarts($o->port);
11299             }
11300              
11301             sub setup {
11302 0     0   0 my $o = shift;
11303              
11304 0         0 my %parameters = @_;
11305             $o->{request} = CDS::HTTPServer::Request->new({
11306             logger => $o->logger,
11307             method => $parameters{method},
11308             path => $parameters{path},
11309             protocol => $parameters{protocol},
11310             queryString => $parameters{query_string},
11311             peerAddress => $parameters{peeraddr},
11312             peerPort => $parameters{peerport},
11313 0         0 headers => {},
11314             corsAllowEverybody => $o->corsAllowEverybody,
11315             });
11316             }
11317              
11318             sub headers {
11319 0     0   0 my $o = shift;
11320 0         0 my $headers = shift;
11321              
11322 0         0 while (scalar @$headers) {
11323 0         0 my $key = shift @$headers;
11324 0         0 my $value = shift @$headers;
11325 0         0 $o->{request}->setHeader($key, $value);
11326             }
11327              
11328             # Read the content length
11329 0   0     0 $o->{request}->setRemainingData($o->{request}->header('content-length') // 0);
11330             }
11331              
11332             sub handler {
11333 0     0   0 my $o = shift;
11334              
11335             # Start writing the log line
11336 0         0 $o->{logger}->onRequestStarts($o->{request});
11337              
11338             # Process the request
11339 0         0 my $responseCode = $o->process;
11340 0         0 $o->{logger}->onRequestDone($o->{request}, $responseCode);
11341              
11342             # Wrap up
11343 0         0 $o->{request}->dropData;
11344 0         0 $o->{request} = undef;
11345 0         0 return;
11346             }
11347              
11348             sub process {
11349 0     0   0 my $o = shift;
11350              
11351             # Run the handler
11352 0         0 for my $handler (@{$o->{handlers}}) {
  0         0  
11353 0   0     0 my $responseCode = $handler->process($o->{request}) || next;
11354 0         0 return $responseCode;
11355             }
11356              
11357             # Default handler
11358 0         0 return $o->{request}->reply404;
11359             }
11360              
11361             sub bad_request {
11362 0     0   0 my $o = shift;
11363              
11364 0         0 my $content = 'Bad Request';
11365 0         0 print 'HTTP/1.1 400 Bad Request', "\r\n";
11366 0         0 print 'Content-Length: ', length $content, "\r\n";
11367 0         0 print 'Content-Type: text/plain; charset=utf-8', "\r\n";
11368 0         0 print "\r\n";
11369 0         0 print $content;
11370 0         0 $o->{request} = undef;
11371             }
11372              
11373             package CDS::HTTPServer::IdentificationHandler;
11374              
11375             sub new {
11376 0     0   0 my $class = shift;
11377 0         0 my $root = shift;
11378              
11379 0         0 return bless {root => $root};
11380             }
11381              
11382             sub process {
11383 0     0   0 my $o = shift;
11384 0         0 my $request = shift;
11385              
11386 0   0     0 my $path = $request->pathAbove($o->{root}) // return;
11387 0 0       0 return if $path ne '/';
11388              
11389             # Options
11390 0 0       0 return $request->replyOptions('HEAD', 'GET') if $request->method eq 'OPTIONS';
11391              
11392             # Get
11393 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';
11394              
11395 0         0 return $request->reply405;
11396             }
11397              
11398             package CDS::HTTPServer::Logger;
11399              
11400             sub new {
11401 0     0   0 my $class = shift;
11402 0         0 my $fileHandle = shift;
11403              
11404 0         0 return bless {
11405             fileHandle => $fileHandle,
11406             lineStarted => 0,
11407             };
11408             }
11409              
11410             sub onServerStarts {
11411 0     0   0 my $o = shift;
11412 0         0 my $port = shift;
11413              
11414 0         0 my $fh = $o->{fileHandle};
11415 0         0 my @t = localtime(time);
11416 0         0 printf $fh '%04d-%02d-%02d %02d:%02d:%02d ', $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0];
11417 0         0 print $fh 'Server ready at http://localhost:', $port, "\n";
11418             }
11419              
11420             sub onRequestStarts {
11421 0     0   0 my $o = shift;
11422 0         0 my $request = shift;
11423              
11424 0         0 my $fh = $o->{fileHandle};
11425 0         0 my @t = localtime(time);
11426 0         0 printf $fh '%04d-%02d-%02d %02d:%02d:%02d ', $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0];
11427 0         0 print $fh $request->peerAddress, ' ', $request->method, ' ', $request->path;
11428 0         0 $o->{lineStarted} = 1;
11429             }
11430              
11431             sub onRequestError {
11432 0     0   0 my $o = shift;
11433 0         0 my $request = shift;
11434              
11435 0         0 my $fh = $o->{fileHandle};
11436 0 0       0 print $fh "\n" if $o->{lineStarted};
11437 0         0 print $fh ' ', @_, "\n";
11438 0         0 $o->{lineStarted} = 0;
11439             }
11440              
11441             sub onRequestDone {
11442 0     0   0 my $o = shift;
11443 0         0 my $request = shift;
11444 0         0 my $responseCode = shift;
11445              
11446 0         0 my $fh = $o->{fileHandle};
11447 0 0       0 print $fh ' ===> ' if ! $o->{lineStarted};
11448 0         0 print $fh ' ', $responseCode, "\n";
11449 0         0 $o->{lineStarted} = 0;
11450             }
11451              
11452             package CDS::HTTPServer::MessageGatewayHandler;
11453              
11454             sub new {
11455 0     0   0 my $class = shift;
11456 0         0 my $root = shift;
11457 0         0 my $actor = shift;
11458 0         0 my $store = shift;
11459 0 0 0     0 my $recipientHash = shift; die 'wrong type '.ref($recipientHash).' for $recipientHash' if defined $recipientHash && ref $recipientHash ne 'CDS::Hash';
  0         0  
11460              
11461 0         0 return bless {root => $root, actor => $actor, store => $store, recipientHash => $recipientHash};
11462             }
11463              
11464             sub process {
11465 0     0   0 my $o = shift;
11466 0         0 my $request = shift;
11467              
11468 0   0     0 my $path = $request->pathAbove($o->{root}) // return;
11469 0 0       0 return if $path ne '/';
11470              
11471             # Options
11472 0 0       0 return $request->replyOptions('HEAD', 'GET', 'PUT', 'POST', 'DELETE') if $request->method eq 'OPTIONS';
11473              
11474             # Prepare a message
11475 0         0 my $message = CDS::Record->new;
11476 0         0 $message->add('time')->addInteger(CDS->now);
11477 0         0 $message->add('ip')->add($request->peerAddress);
11478 0         0 $message->add('method')->add($request->method);
11479 0         0 $message->add('path')->add($request->path);
11480 0         0 $message->add('query string')->add($request->queryString);
11481              
11482 0         0 my $headersRecord = $message->add('headers');
11483 0         0 my $headers = $request->headers;
11484 0         0 for my $key (keys %$headers) {
11485 0         0 $headersRecord->add($key)->add($headers->{$key});
11486             }
11487              
11488             # Prepare a channel
11489 0         0 my $channel = CDS::MessageChannel->new($o->{actor}, CDS->randomBytes(8), CDS->WEEK);
11490 0         0 $o->{messageChannel}->setRecipients([$o->{recipientHash}], []);
11491              
11492             # Add the data
11493 0 0       0 if ($request->remainingData > 1024) {
    0          
11494             # Store the data as a separate object
11495 0         0 my $object = CDS::Object->create(CDS::Object->emptyHeader, $request->readData);
11496 0         0 my $key = CDS->randomKey;
11497 0         0 my $encryptedObject = $object->crypt($key);
11498 0         0 my $hash = $encryptedObject->calculateHash;
11499 0         0 $message->add('data')->addHash($hash);
11500 0         0 $channel->addObject($hash, $encryptedObject);
11501             } elsif ($request->remainingData) {
11502 0         0 $message->add('data')->add($request->readData)
11503             }
11504              
11505             # Submit
11506 0         0 my ($submission, $missingObject) = $channel->submit($message, $o);
11507 0         0 $o->{actor}->sendMessages;
11508              
11509 0 0       0 return $submission ? $request->reply200 : $request->reply500('Unable to send the message.');
11510             }
11511              
11512             sub onMessageChannelSubmissionCancelled {
11513 0     0   0 my $o = shift;
11514             }
11515              
11516             sub onMessageChannelSubmissionRecipientDone {
11517 0     0   0 my $o = shift;
11518 0 0 0     0 my $recipientActorOnStore = shift; die 'wrong type '.ref($recipientActorOnStore).' for $recipientActorOnStore' if defined $recipientActorOnStore && ref $recipientActorOnStore ne 'CDS::ActorOnStore';
  0         0  
11519             }
11520              
11521             sub onMessageChannelSubmissionRecipientFailed {
11522 0     0   0 my $o = shift;
11523 0 0 0     0 my $recipientActorOnStore = shift; die 'wrong type '.ref($recipientActorOnStore).' for $recipientActorOnStore' if defined $recipientActorOnStore && ref $recipientActorOnStore ne 'CDS::ActorOnStore';
  0         0  
11524             }
11525              
11526             sub onMessageChannelSubmissionDone {
11527 0     0   0 my $o = shift;
11528 0         0 my $succeeded = shift;
11529 0         0 my $failed = shift;
11530             }
11531              
11532             package CDS::HTTPServer::Request;
11533              
11534             sub new {
11535 0     0   0 my $class = shift;
11536 0         0 my $parameters = shift;
11537              
11538 0         0 return bless $parameters;
11539             }
11540              
11541 0     0   0 sub logger { shift->{logger} }
11542 0     0   0 sub method { shift->{method} }
11543 0     0   0 sub path { shift->{path} }
11544 0     0   0 sub queryString { shift->{queryString} }
11545 0     0   0 sub peerAddress { shift->{peerAddress} }
11546 0     0   0 sub peerPort { shift->{peerPort} }
11547 0     0   0 sub headers { shift->{headers} }
11548 0     0   0 sub remainingData { shift->{remainingData} }
11549 0     0   0 sub corsAllowEverybody { shift->{corsAllowEverybody} }
11550              
11551             # *** Path
11552              
11553             sub pathAbove {
11554 0     0   0 my $o = shift;
11555 0         0 my $root = shift;
11556              
11557 0 0       0 $root .= '/' if $root !~ /\/$/;
11558 0 0       0 return if substr($o->{path}, 0, length $root) ne $root;
11559 0         0 return substr($o->{path}, length($root) - 1);
11560             }
11561              
11562             # *** Request data
11563              
11564             sub setRemainingData {
11565 0     0   0 my $o = shift;
11566 0         0 my $remainingData = shift;
11567              
11568 0         0 $o->{remainingData} = $remainingData;
11569             }
11570              
11571             # Reads the request data
11572             sub readData {
11573 0     0   0 my $o = shift;
11574              
11575 0         0 my @buffers;
11576 0         0 while ($o->{remainingData} > 0) {
11577 0   0     0 my $read = sysread(STDIN, my $buffer, $o->{remainingData}) || return;
11578 0         0 $o->{remainingData} -= $read;
11579 0         0 push @buffers, $buffer;
11580             }
11581              
11582 0         0 return join('', @buffers);
11583             }
11584              
11585             # Read the request data and writes it directly to a file handle
11586             sub copyDataAndCalculateHash {
11587 0     0   0 my $o = shift;
11588 0         0 my $fh = shift;
11589              
11590 0         0 my $sha = Digest::SHA->new(256);
11591 0         0 while ($o->{remainingData} > 0) {
11592 0   0     0 my $read = sysread(STDIN, my $buffer, $o->{remainingData}) || return;
11593 0         0 $o->{remainingData} -= $read;
11594 0         0 $sha->add($buffer);
11595 0         0 print $fh $buffer;
11596             }
11597              
11598 0         0 return $sha->digest;
11599             }
11600              
11601             # Reads and drops the request data
11602             sub dropData {
11603 0     0   0 my $o = shift;
11604              
11605 0         0 while ($o->{remainingData} > 0) {
11606 0   0     0 $o->{remainingData} -= read(STDIN, my $buffer, $o->{remainingData}) || return;
11607             }
11608             }
11609              
11610             # *** Headers
11611              
11612             sub setHeader {
11613 0     0   0 my $o = shift;
11614 0         0 my $key = shift;
11615 0         0 my $value = shift;
11616              
11617 0         0 $o->{headers}->{lc($key)} = $value;
11618             }
11619              
11620             sub header {
11621 0     0   0 my $o = shift;
11622 0         0 my $key = shift;
11623              
11624 0         0 return $o->{headers}->{lc($key)};
11625             }
11626              
11627             # *** Query string
11628              
11629             sub parseQueryString {
11630 0     0   0 my $o = shift;
11631              
11632 0 0       0 return {} if ! defined $o->{queryString};
11633              
11634 0         0 my $values = {};
11635 0         0 for my $pair (split /&/, $o->{queryString}) {
11636 0 0       0 if ($pair =~ /^(.*?)=(.*)$/) {
11637 0         0 my $key = $1;
11638 0         0 my $value = $2;
11639 0         0 $values->{&uri_decode($key)} = &uri_decode($value);
11640             } else {
11641 0         0 $values->{&uri_decode($pair)} = 1;
11642             }
11643             }
11644              
11645 0         0 return $values;
11646             }
11647              
11648             sub uri_decode {
11649 0     0   0 my $encoded = shift;
11650              
11651 0         0 $encoded =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
  0         0  
11652 0         0 return $encoded;
11653             }
11654              
11655             # *** Condensation signature
11656              
11657             sub checkSignature {
11658 0     0   0 my $o = shift;
11659 0         0 my $store = shift;
11660 0         0 my $contentBytesToSign = shift;
11661              
11662             # Check the date
11663 0   0     0 my $dateString = $o->{headers}->{'condensation-date'} // $o->{headers}->{'date'} // return;
      0        
11664 0   0     0 my $date = HTTP::Date::str2time($dateString) // return;
11665 0         0 my $now = time;
11666 0 0 0     0 return if $date < $now - 120 || $date > $now + 60;
11667              
11668             # Get and check the actor
11669 0   0     0 my $actorHash = CDS::Hash->fromHex($o->{headers}->{'condensation-actor'}) // return;
11670 0         0 my ($publicKeyObject, $error) = $store->get($actorHash);
11671 0 0       0 return if ! $publicKeyObject;
11672 0 0       0 return if ! $publicKeyObject->calculateHash->equals($actorHash);
11673 0   0     0 my $publicKey = CDS::PublicKey->fromObject($publicKeyObject) // return;
11674              
11675             # Text to sign
11676 0         0 my $bytesToSign = $dateString."\0".uc($o->{method})."\0".$o->{headers}->{'host'}.$o->{path};
11677 0 0       0 $bytesToSign .= "\0".$contentBytesToSign if defined $contentBytesToSign;
11678 0         0 my $hashToSign = CDS::Hash->calculateFor($bytesToSign);
11679              
11680             # Check the signature
11681 0   0     0 my $signatureString = $o->{headers}->{'condensation-signature'} // return;
11682 0   0     0 $signatureString =~ /^\s*([0-9a-z]{512,512})\s*$/ // return;
11683 0         0 my $signature = pack('H*', $1);
11684 0 0       0 return if ! $publicKey->verifyHash($hashToSign, $signature);
11685              
11686             # Return the verified actor hash
11687 0         0 return $actorHash;
11688             }
11689              
11690             # *** Reply functions
11691              
11692             sub reply200 {
11693 0     0   0 my $o = shift;
11694 0   0     0 my $content = shift // '';
11695              
11696 0 0       0 return length $content ? $o->reply(200, 'OK', &textContentType, $content) : $o->reply(204, 'No Content', {});
11697             }
11698              
11699             sub reply200Bytes {
11700 0     0   0 my $o = shift;
11701 0   0     0 my $content = shift // '';
11702              
11703 0 0       0 return length $content ? $o->reply(200, 'OK', {'Content-Type' => 'application/octet-stream'}, $content) : $o->reply(204, 'No Content', {});
11704             }
11705              
11706             sub reply200HTML {
11707 0     0   0 my $o = shift;
11708 0   0     0 my $content = shift // '';
11709              
11710 0 0       0 return length $content ? $o->reply(200, 'OK', {'Content-Type' => 'text/html; charset=utf-8'}, $content) : $o->reply(204, 'No Content', {});
11711             }
11712              
11713             sub replyOptions {
11714 0     0   0 my $o = shift;
11715              
11716 0         0 my $headers = {};
11717 0         0 $headers->{'Allow'} = join(', ', @_, 'OPTIONS');
11718 0 0 0     0 $headers->{'Access-Control-Allow-Methods'} = join(', ', @_, 'OPTIONS') if $o->corsAllowEverybody && $o->{headers}->{'origin'};
11719 0         0 return $o->reply(200, 'OK', $headers);
11720             }
11721              
11722             sub replyFatalError {
11723 0     0   0 my $o = shift;
11724              
11725 0         0 $o->{logger}->onRequestError($o, @_);
11726 0         0 return $o->reply500;
11727             }
11728              
11729             sub reply303 {
11730 0     0   0 my $o = shift;
11731 0         0 my $location = shift;
11732 0         0 $o->reply(303, 'See Other', {'Location' => $location}) }
11733             sub reply400 {
11734 0     0   0 my $o = shift;
11735 0         0 $o->reply(400, 'Bad Request', &textContentType, @_) }
11736             sub reply403 {
11737 0     0   0 my $o = shift;
11738 0         0 $o->reply(403, 'Forbidden', &textContentType, @_) }
11739             sub reply404 {
11740 0     0   0 my $o = shift;
11741 0         0 $o->reply(404, 'Not Found', &textContentType, @_) }
11742             sub reply405 {
11743 0     0   0 my $o = shift;
11744 0         0 $o->reply(405, 'Method Not Allowed', &textContentType, @_) }
11745             sub reply500 {
11746 0     0   0 my $o = shift;
11747 0         0 $o->reply(500, 'Internal Server Error', &textContentType, @_) }
11748             sub reply503 {
11749 0     0   0 my $o = shift;
11750 0         0 $o->reply(503, 'Service Not Available', &textContentType, @_) }
11751              
11752             sub reply {
11753 0     0   0 my $o = shift;
11754 0         0 my $responseCode = shift;
11755 0         0 my $responseLabel = shift;
11756 0   0     0 my $headers = shift // {};
11757 0   0     0 my $content = shift // '';
11758              
11759             # Content-related headers
11760 0         0 $headers->{'Content-Length'} = length($content);
11761              
11762             # Origin
11763 0 0 0     0 if ($o->corsAllowEverybody && (my $origin = $o->{headers}->{'origin'})) {
11764 0         0 $headers->{'Access-Control-Allow-Origin'} = $origin;
11765 0         0 $headers->{'Access-Control-Allow-Headers'} = 'Content-Type';
11766 0         0 $headers->{'Access-Control-Max-Age'} = '86400';
11767             }
11768              
11769             # Write the reply
11770 0         0 print 'HTTP/1.1 ', $responseCode, ' ', $responseLabel, "\r\n";
11771 0         0 for my $key (keys %$headers) {
11772 0         0 print $key, ': ', $headers->{$key}, "\r\n";
11773             }
11774 0         0 print "\r\n";
11775 0 0       0 print $content if $o->{method} ne 'HEAD';
11776              
11777             # Return the response code
11778 0         0 return $responseCode;
11779             }
11780              
11781 0     0   0 sub textContentType { {'Content-Type' => 'text/plain; charset=utf-8'} }
11782              
11783             package CDS::HTTPServer::StaticContentHandler;
11784              
11785             sub new {
11786 0     0   0 my $class = shift;
11787 0         0 my $path = shift;
11788 0         0 my $content = shift;
11789 0         0 my $contentType = shift;
11790              
11791 0         0 return bless {
11792             path => $path,
11793             content => $content,
11794             contentType => $contentType,
11795             };
11796             }
11797              
11798             sub process {
11799 0     0   0 my $o = shift;
11800 0         0 my $request = shift;
11801              
11802 0 0       0 return if $request->path ne $o->{path};
11803              
11804             # Options
11805 0 0       0 return $request->replyOptions('HEAD', 'GET') if $request->method eq 'OPTIONS';
11806              
11807             # GET
11808 0 0       0 return $request->reply(200, 'OK', {'Content-Type' => $o->{contentType}}, $o->{content}) if $request->method eq 'GET';
11809              
11810             # Everything else
11811 0         0 return $request->reply405;
11812             }
11813              
11814             package CDS::HTTPServer::StaticFilesHandler;
11815              
11816             sub new {
11817 0     0   0 my $class = shift;
11818 0         0 my $root = shift;
11819 0         0 my $folder = shift;
11820 0   0     0 my $defaultFile = shift // '';
11821              
11822 0         0 return bless {
11823             root => $root,
11824             folder => $folder,
11825             defaultFile => $defaultFile,
11826             mimeTypesByExtension => {
11827             'css' => 'text/css',
11828             'gif' => 'image/gif',
11829             'html' => 'text/html',
11830             'jpg' => 'image/jpeg',
11831             'jpeg' => 'image/jpeg',
11832             'js' => 'application/javascript',
11833             'mp4' => 'video/mp4',
11834             'ogg' => 'video/ogg',
11835             'pdf' => 'application/pdf',
11836             'png' => 'image/png',
11837             'svg' => 'image/svg+xml',
11838             'txt' => 'text/plain',
11839             'webm' => 'video/webm',
11840             'zip' => 'application/zip',
11841             },
11842             };
11843             }
11844              
11845 0     0   0 sub folder { shift->{folder} }
11846 0     0   0 sub defaultFile { shift->{defaultFile} }
11847 0     0   0 sub mimeTypesByExtension { shift->{mimeTypesByExtension} }
11848              
11849             sub setContentType {
11850 0     0   0 my $o = shift;
11851 0         0 my $extension = shift;
11852 0         0 my $contentType = shift;
11853              
11854 0         0 $o->{mimeTypesByExtension}->{$extension} = $contentType;
11855             }
11856              
11857             sub process {
11858 0     0   0 my $o = shift;
11859 0         0 my $request = shift;
11860              
11861             # Options
11862 0 0       0 return $request->replyOptions('HEAD', 'GET') if $request->method eq 'OPTIONS';
11863              
11864             # Get
11865 0 0 0     0 return $o->get($request) if $request->method eq 'GET' || $request->method eq 'HEAD';
11866              
11867             # Anything else
11868 0         0 return $request->reply405;
11869             }
11870              
11871             sub get {
11872 0     0   0 my $o = shift;
11873 0         0 my $request = shift;
11874              
11875 0   0     0 my $path = $request->pathAbove($o->{root}) // return;
11876 0         0 return $o->deliverFileForPath($request, $path);
11877             }
11878              
11879             sub deliverFileForPath {
11880 0     0   0 my $o = shift;
11881 0         0 my $request = shift;
11882 0         0 my $path = shift;
11883              
11884             # Hidden files (starting with a dot), as well as "." and ".." never exist
11885 0         0 for my $segment (split /\/+/, $path) {
11886 0 0       0 return $request->reply404 if $segment =~ /^\./;
11887             }
11888              
11889             # If a folder is requested, we serve the default file
11890 0         0 my $file = $o->{folder}.$path;
11891 0 0       0 if (-d $file) {
11892 0 0       0 return $request->reply404 if ! length $o->{defaultFile};
11893 0 0       0 return $request->reply303($request->path.'/') if $file !~ /\/$/;
11894 0         0 $file .= $o->{defaultFile};
11895             }
11896              
11897 0         0 return $o->deliverFile($request, $file);
11898             }
11899              
11900             sub deliverFile {
11901 0     0   0 my $o = shift;
11902 0         0 my $request = shift;
11903 0         0 my $file = shift;
11904 0   0     0 my $contentType = shift // $o->guessContentType($file);
11905              
11906 0   0     0 my $bytes = $o->readFile($file) // return $request->reply404;
11907 0         0 return $request->reply(200, 'OK', {'Content-Type' => $contentType}, $bytes);
11908             }
11909              
11910             # Guesses the content type from the extension
11911             sub guessContentType {
11912 0     0   0 my $o = shift;
11913 0         0 my $file = shift;
11914              
11915 0 0       0 my $extension = $file =~ /\.([A-Za-z0-9]*)$/ ? lc($1) : '';
11916 0   0     0 return $o->{mimeTypesByExtension}->{$extension} // 'application/octet-stream';
11917             }
11918              
11919             # Reads a file
11920             sub readFile {
11921 0     0   0 my $o = shift;
11922 0         0 my $file = shift;
11923              
11924 0 0       0 open(my $fh, '<:bytes', $file) || return;
11925 0 0       0 if (! -f $fh) {
11926 0         0 close $fh;
11927 0         0 return;
11928             }
11929              
11930 0         0 local $/ = undef;
11931 0         0 my $bytes = <$fh>;
11932 0         0 close $fh;
11933 0         0 return $bytes;
11934             }
11935              
11936             package CDS::HTTPServer::StoreHandler;
11937              
11938             sub new {
11939 0     0   0 my $class = shift;
11940 0         0 my $root = shift;
11941 0         0 my $store = shift;
11942 0         0 my $checkPutHash = shift;
11943 0   0     0 my $checkSignatures = shift // 1;
11944              
11945 0         0 return bless {
11946             root => $root,
11947             store => $store,
11948             checkPutHash => $checkPutHash,
11949             checkEnvelopeHash => $checkPutHash,
11950             checkSignatures => $checkSignatures,
11951             maximumWatchTimeout => 0,
11952             };
11953             }
11954              
11955             sub process {
11956 0     0   0 my $o = shift;
11957 0         0 my $request = shift;
11958              
11959 0   0     0 my $path = $request->pathAbove($o->{root}) // return;
11960              
11961             # Objects request
11962 0 0       0 if ($request->path =~ /^\/objects\/([0-9a-f]{64})$/) {
11963 0         0 my $hash = CDS::Hash->fromHex($1);
11964 0         0 return $o->objects($request, $hash);
11965             }
11966              
11967             # Box request
11968 0 0       0 if ($request->path =~ /^\/accounts\/([0-9a-f]{64})\/(messages|private|public)$/) {
11969 0         0 my $accountHash = CDS::Hash->fromHex($1);
11970 0         0 my $boxLabel = $2;
11971 0         0 return $o->box($request, $accountHash, $boxLabel);
11972             }
11973              
11974             # Box entry request
11975 0 0       0 if ($request->path =~ /^\/accounts\/([0-9a-f]{64})\/(messages|private|public)\/([0-9a-f]{64})$/) {
11976 0         0 my $accountHash = CDS::Hash->fromHex($1);
11977 0         0 my $boxLabel = $2;
11978 0         0 my $hash = CDS::Hash->fromHex($3);
11979 0         0 return $o->boxEntry($request, $accountHash, $boxLabel, $hash);
11980             }
11981              
11982             # Account request
11983 0 0       0 if ($request->path =~ /^\/accounts\/([0-9a-f]{64})$/) {
11984 0 0       0 return $request->replyOptions if $request->method eq 'OPTIONS';
11985 0         0 return $request->reply405;
11986             }
11987              
11988             # Accounts request
11989 0 0       0 if ($request->path =~ /^\/accounts$/) {
11990 0         0 return $o->accounts($request);
11991             }
11992              
11993             # Other requests on /objects or /accounts
11994 0 0       0 if ($request->path =~ /^\/(accounts|objects)(\/|$)/) {
11995 0         0 return $request->reply404;
11996             }
11997              
11998             # Nothing for us
11999 0         0 return;
12000             }
12001              
12002             sub objects {
12003 0     0   0 my $o = shift;
12004 0         0 my $request = shift;
12005 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
12006              
12007             # Options
12008 0 0       0 if ($request->method eq 'OPTIONS') {
12009 0         0 return $request->replyOptions('HEAD', 'GET', 'PUT', 'POST');
12010             }
12011              
12012             # Retrieve object
12013 0 0 0     0 if ($request->method eq 'HEAD' || $request->method eq 'GET') {
12014 0         0 my ($object, $error) = $o->{store}->get($hash);
12015 0 0       0 return $request->replyFatalError($error) if defined $error;
12016 0 0       0 return $request->reply404 if ! $object;
12017             # We don't check the SHA256 sum here - this should be done by the client
12018 0         0 return $request->reply200Bytes($object->bytes);
12019             }
12020              
12021             # Put object
12022 0 0       0 if ($request->method eq 'PUT') {
12023 0   0     0 my $bytes = $request->readData // return $request->reply400('No data received.');
12024 0   0     0 my $object = CDS::Object->fromBytes($bytes) // return $request->reply400('Not a Condensation object.');
12025 0 0 0     0 return $request->reply400('SHA256 sum does not match hash.') if $o->{checkPutHash} && ! $object->calculateHash->equals($hash);
12026              
12027 0 0       0 if ($o->{checkSignatures}) {
12028 0         0 my $checkSignatureStore = CDS::CheckSignatureStore->new($o->{store});
12029 0         0 $checkSignatureStore->put($hash, $object);
12030 0 0       0 return $request->reply403 if ! $request->checkSignature($checkSignatureStore);
12031             }
12032              
12033 0         0 my $error = $o->{store}->put($hash, $object);
12034 0 0       0 return $request->replyFatalError($error) if defined $error;
12035 0         0 return $request->reply200;
12036             }
12037              
12038             # Book object
12039 0 0       0 if ($request->method eq 'POST') {
12040 0 0 0     0 return $request->reply403 if $o->{checkSignatures} && ! $request->checkSignature($o->{store});
12041 0 0       0 return $request->reply400('You cannot send data when booking an object.') if $request->remainingData;
12042 0         0 my ($booked, $error) = $o->{store}->book($hash);
12043 0 0       0 return $request->replyFatalError($error) if defined $error;
12044 0 0       0 return $booked ? $request->reply200 : $request->reply404;
12045             }
12046              
12047 0         0 return $request->reply405;
12048             }
12049              
12050             sub box {
12051 0     0   0 my $o = shift;
12052 0         0 my $request = shift;
12053 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
12054 0         0 my $boxLabel = shift;
12055              
12056             # Options
12057 0 0       0 if ($request->method eq 'OPTIONS') {
12058 0         0 return $request->replyOptions('HEAD', 'GET', 'PUT', 'POST');
12059             }
12060              
12061             # List box
12062 0 0 0     0 if ($request->method eq 'HEAD' || $request->method eq 'GET') {
12063 0 0       0 if ($o->{checkSignatures}) {
12064 0         0 my $actorHash = $request->checkSignature($o->{store});
12065 0 0       0 return $request->reply403 if ! $o->verifyList($actorHash, $accountHash, $boxLabel);
12066             }
12067              
12068 0   0     0 my $watch = $request->headers->{'condensation-watch'} // '';
12069 0 0       0 my $timeout = $watch =~ /^(\d+)\s*ms$/ ? $1 + 0 : 0;
12070 0 0       0 $timeout = $o->{maximumWatchTimeout} if $timeout > $o->{maximumWatchTimeout};
12071 0         0 my ($hashes, $error) = $o->{store}->list($accountHash, $boxLabel, $timeout);
12072 0 0       0 return $request->replyFatalError($error) if defined $error;
12073 0         0 return $request->reply200Bytes(join('', map { $_->bytes } @$hashes));
  0         0  
12074             }
12075              
12076 0         0 return $request->reply405;
12077             }
12078              
12079             sub boxEntry {
12080 0     0   0 my $o = shift;
12081 0         0 my $request = shift;
12082 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
12083 0         0 my $boxLabel = shift;
12084 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
12085              
12086             # Options
12087 0 0       0 if ($request->method eq 'OPTIONS') {
12088 0         0 return $request->replyOptions('HEAD', 'PUT', 'DELETE');
12089             }
12090              
12091             # Add
12092 0 0       0 if ($request->method eq 'PUT') {
12093 0 0       0 if ($o->{checkSignatures}) {
12094 0         0 my $actorHash = $request->checkSignature($o->{store});
12095 0 0       0 return $request->reply403 if ! $o->verifyAddition($actorHash, $accountHash, $boxLabel, $hash);
12096             }
12097              
12098 0         0 my $error = $o->{store}->add($accountHash, $boxLabel, $hash);
12099 0 0       0 return $request->replyFatalError($error) if defined $error;
12100 0         0 return $request->reply200;
12101             }
12102              
12103             # Remove
12104 0 0       0 if ($request->method eq 'DELETE') {
12105 0 0       0 if ($o->{checkSignatures}) {
12106 0         0 my $actorHash = $request->checkSignature($o->{store});
12107 0 0       0 return $request->reply403 if ! $o->verifyRemoval($actorHash, $accountHash, $boxLabel, $hash);
12108             }
12109              
12110 0         0 my ($booked, $error) = $o->{store}->remove($accountHash, $boxLabel, $hash);
12111 0 0       0 return $request->replyFatalError($error) if defined $error;
12112 0         0 return $request->reply200;
12113             }
12114              
12115 0         0 return $request->reply405;
12116             }
12117              
12118             sub accounts {
12119 0     0   0 my $o = shift;
12120 0         0 my $request = shift;
12121              
12122             # Options
12123 0 0       0 if ($request->method eq 'OPTIONS') {
12124 0         0 return $request->replyOptions('POST');
12125             }
12126              
12127             # Modify boxes
12128 0 0       0 if ($request->method eq 'POST') {
12129 0   0     0 my $bytes = $request->readData // return $request->reply400('No data received.');
12130 0         0 my $modifications = CDS::StoreModifications->fromBytes($bytes);
12131 0 0       0 return $request->reply400('Invalid modifications.') if ! $modifications;
12132              
12133 0 0       0 if ($o->{checkSignatures}) {
12134 0         0 my $actorHash = $request->checkSignature(CDS::CheckSignatureStore->new($o->{store}, $modifications->objects), $bytes);
12135 0 0       0 return $request->reply403 if ! $o->verifyModifications($actorHash, $modifications);
12136             }
12137              
12138 0         0 my $error = $o->{store}->modify($modifications);
12139 0 0       0 return $request->replyFatalError($error) if defined $error;
12140 0         0 return $request->reply200;
12141             }
12142              
12143 0         0 return $request->reply405;
12144             }
12145              
12146             sub verifyList {
12147 0     0   0 my $o = shift;
12148 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
12149 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
12150 0         0 my $boxLabel = shift;
12151              
12152 0 0       0 return 1 if $boxLabel eq 'public';
12153 0 0       0 return if ! $actorHash;
12154 0 0       0 return 1 if $accountHash->equals($actorHash);
12155 0         0 return;
12156             }
12157              
12158             sub verifyModifications {
12159 0     0   0 my $o = shift;
12160 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
12161 0         0 my $modifications = shift;
12162              
12163 0         0 for my $operation (@{$modifications->additions}) {
  0         0  
12164 0 0       0 return if ! $o->verifyAddition($actorHash, $operation->{accountHash}, $operation->{boxLabel}, $operation->{hash});
12165             }
12166              
12167 0         0 for my $operation (@{$modifications->removals}) {
  0         0  
12168 0 0       0 return if ! $o->verifyRemoval($actorHash, $operation->{accountHash}, $operation->{boxLabel}, $operation->{hash});
12169             }
12170              
12171 0         0 return 1;
12172             }
12173              
12174             sub verifyAddition {
12175 0     0   0 my $o = shift;
12176 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
12177 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
12178 0         0 my $boxLabel = shift;
12179 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
12180              
12181 0 0       0 return 1 if $boxLabel eq 'messages';
12182 0 0       0 return if ! $actorHash;
12183 0 0       0 return 1 if $accountHash->equals($actorHash);
12184 0         0 return;
12185             }
12186              
12187             sub verifyRemoval {
12188 0     0   0 my $o = shift;
12189 0 0 0     0 my $actorHash = shift; die 'wrong type '.ref($actorHash).' for $actorHash' if defined $actorHash && ref $actorHash ne 'CDS::Hash';
  0         0  
12190 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
12191 0         0 my $boxLabel = shift;
12192 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
12193              
12194 0 0       0 return if ! $actorHash;
12195 0 0       0 return 1 if $accountHash->equals($actorHash);
12196              
12197             # Get the envelope
12198 0         0 my ($bytes, $error) = $o->{store}->get($hash);
12199 0 0       0 return if defined $error;
12200 0 0       0 return 1 if ! defined $bytes;
12201 0   0     0 my $record = CDS::Record->fromObject(CDS::Object->fromBytes($bytes)) // return;
12202              
12203             # Allow anyone listed under "updated by"
12204 0         0 my $actorHashBytes24 = substr($actorHash->bytes, 0, 24);
12205 0         0 for my $child ($record->child('updated by')->children) {
12206 0         0 my $hashBytes24 = $child->bytes;
12207 0 0       0 next if length $hashBytes24 != 24;
12208 0 0       0 return 1 if $hashBytes24 eq $actorHashBytes24;
12209             }
12210              
12211 0         0 return;
12212             }
12213              
12214             # A Condensation store accessed through HTTP or HTTPS.
12215             package CDS::HTTPStore;
12216              
12217 1     1   6925 use parent -norequire, 'CDS::Store';
  1         3  
  1         4  
12218              
12219             sub forUrl {
12220 1     1   3 my $class = shift;
12221 1         3 my $url = shift;
12222              
12223 1 50       9 $url =~ /^(http|https):\/\// || return;
12224 1         4 return $class->new($url);
12225             }
12226              
12227             sub new {
12228 1     1   3 my $class = shift;
12229 1         2 my $url = shift;
12230              
12231 1         5 return bless {url => $url};
12232             }
12233              
12234             sub id {
12235 0     0   0 my $o = shift;
12236 0         0 $o->{url} }
12237              
12238             sub get {
12239 0     0   0 my $o = shift;
12240 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
12241 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
12242              
12243 0         0 my $response = $o->request('GET', $o->{url}.'/objects/'.$hash->hex, HTTP::Headers->new);
12244 0 0       0 return if $response->code == 404;
12245 0 0       0 return undef, 'get ==> HTTP '.$response->status_line if ! $response->is_success;
12246 0         0 return CDS::Object->fromBytes($response->decoded_content(charset => 'none'));
12247             }
12248              
12249             sub put {
12250 0     0   0 my $o = shift;
12251 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
12252 0 0 0     0 my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0         0  
12253 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
12254              
12255 0         0 my $headers = HTTP::Headers->new;
12256 0         0 $headers->header('Content-Type' => 'application/condensation-object');
12257 0         0 my $response = $o->request('PUT', $o->{url}.'/objects/'.$hash->hex, $headers, $keyPair, $object->bytes, 1);
12258 0 0       0 return if $response->is_success;
12259 0         0 return 'put ==> HTTP '.$response->status_line;
12260             }
12261              
12262             sub book {
12263 0     0   0 my $o = shift;
12264 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
12265 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
12266              
12267 0         0 my $response = $o->request('POST', $o->{url}.'/objects/'.$hash->hex, HTTP::Headers->new, $keyPair, undef, 1);
12268 0 0       0 return if $response->code == 404;
12269 0 0       0 return 1 if $response->is_success;
12270 0         0 return undef, 'book ==> HTTP '.$response->status_line;
12271             }
12272              
12273             sub list {
12274 0     0   0 my $o = shift;
12275 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
12276 0         0 my $boxLabel = shift;
12277 0         0 my $timeout = shift;
12278 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
12279              
12280 0         0 my $boxUrl = $o->{url}.'/accounts/'.$accountHash->hex.'/'.$boxLabel;
12281 0         0 my $headers = HTTP::Headers->new;
12282 0 0       0 $headers->header('Condensation-Watch' => $timeout.' ms') if $timeout > 0;
12283 0         0 my $needsSignature = $boxLabel ne 'public';
12284 0         0 my $response = $o->request('GET', $boxUrl, $headers, $keyPair, undef, $needsSignature);
12285 0 0       0 return undef, 'list ==> HTTP '.$response->status_line if ! $response->is_success;
12286 0         0 my $bytes = $response->decoded_content(charset => 'none');
12287              
12288 0 0       0 if (length($bytes) % 32 != 0) {
12289 0         0 print STDERR 'old procotol', "\n";
12290 0         0 my $hashes = [];
12291 0         0 for my $line (split /\n/, $bytes) {
12292 0   0     0 push @$hashes, CDS::Hash->fromHex($line) // next;
12293             }
12294 0         0 return $hashes;
12295             }
12296              
12297 0         0 my $countHashes = int(length($bytes) / 32);
12298 0         0 return [map { CDS::Hash->fromBytes(substr($bytes, $_ * 32, 32)) } 0 .. $countHashes - 1];
  0         0  
12299             }
12300              
12301             sub add {
12302 0     0   0 my $o = shift;
12303 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
12304 0         0 my $boxLabel = shift;
12305 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
12306 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
12307              
12308 0         0 my $headers = HTTP::Headers->new;
12309 0         0 my $needsSignature = $boxLabel ne 'messages';
12310 0         0 my $response = $o->request('PUT', $o->{url}.'/accounts/'.$accountHash->hex.'/'.$boxLabel.'/'.$hash->hex, $headers, $keyPair, undef, $needsSignature);
12311 0 0       0 return if $response->is_success;
12312 0         0 return 'add ==> HTTP '.$response->status_line;
12313             }
12314              
12315             sub remove {
12316 0     0   0 my $o = shift;
12317 0 0 0     0 my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0         0  
12318 0         0 my $boxLabel = shift;
12319 0 0 0     0 my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0         0  
12320 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
12321              
12322 0         0 my $headers = HTTP::Headers->new;
12323 0         0 my $response = $o->request('DELETE', $o->{url}.'/accounts/'.$accountHash->hex.'/'.$boxLabel.'/'.$hash->hex, $headers, $keyPair, undef, 1);
12324 0 0       0 return if $response->is_success;
12325 0         0 return 'remove ==> HTTP '.$response->status_line;
12326             }
12327              
12328             sub modify {
12329 0     0   0 my $o = shift;
12330 0         0 my $modifications = shift;
12331 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
12332              
12333 0         0 my $bytes = $modifications->toRecord->toObject->bytes;
12334 0         0 my $needsSignature = $modifications->needsSignature($keyPair);
12335 0         0 my $headers = HTTP::Headers->new;
12336 0         0 $headers->header('Content-Type' => 'application/condensation-modifications');
12337 0         0 my $response = $o->request('POST', $o->{url}.'/accounts', $headers, $keyPair, $bytes, $needsSignature, 1);
12338 0 0       0 return if $response->is_success;
12339 0         0 return 'modify ==> HTTP '.$response->status_line;
12340             }
12341              
12342             # Executes a HTTP request.
12343             sub request {
12344 0     0   0 my $class = shift;
12345 0         0 my $method = shift;
12346 0         0 my $url = shift;
12347 0         0 my $headers = shift;
12348 0 0 0     0 my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0         0  
12349 0         0 my $data = shift;
12350 0         0 my $addSignature = shift;
12351 0         0 my $signData = shift;
12352             # private
12353 0         0 $headers->date(time);
12354 0         0 $headers->header('User-Agent' => CDS->version);
12355              
12356 0 0 0     0 if ($addSignature && $keyPair) {
12357 0 0       0 my $hostAndPath = $url =~ /^https?:\/\/(.*)$/ ? $1 : $url;
12358 0         0 my $date = CDS::ISODate->millisecondString;
12359 0         0 my $bytesToSign = $date."\0".uc($method)."\0".$hostAndPath;
12360 0 0       0 $bytesToSign .= "\0".$data if $signData;
12361 0         0 my $hashBytesToSign = Digest::SHA::sha256($bytesToSign);
12362 0         0 my $signature = $keyPair->sign($hashBytesToSign);
12363 0         0 $headers->header('Condensation-Date' => $date);
12364 0         0 $headers->header('Condensation-Actor' => $keyPair->publicKey->hash->hex);
12365 0         0 $headers->header('Condensation-Signature' => unpack('H*', $signature));
12366             }
12367              
12368 0         0 return LWP::UserAgent->new->request(HTTP::Request->new($method, $url, $headers, $data));
12369             }
12370              
12371             # Models a hash, and offers binary and hexadecimal representation.
12372             package CDS::Hash;
12373              
12374             sub fromBytes {
12375 0     0   0 my $class = shift;
12376 0   0     0 my $hashBytes = shift // return;
12377              
12378 0 0       0 return if length $hashBytes != 32;
12379 0         0 return bless \$hashBytes;
12380             }
12381              
12382             sub fromHex {
12383 4     4   94 my $class = shift;
12384 4   50     15 my $hashHex = shift // return;
12385              
12386 4 100       31 $hashHex =~ /^\s*([a-fA-F0-9]{64,64})\s*$/ || return;
12387 2         18 my $hashBytes = pack('H*', $hashHex);
12388 2         12 return bless \$hashBytes;
12389             }
12390              
12391             sub calculateFor {
12392 0     0     my $class = shift;
12393 0           my $bytes = shift;
12394              
12395             # The Perl built-in SHA256 implementation is a tad faster than our SHA256 implementation.
12396             #return $class->fromBytes(CDS::C::sha256($bytes));
12397 0           return $class->fromBytes(Digest::SHA::sha256($bytes));
12398             }
12399              
12400             sub hex {
12401 0     0     my $o = shift;
12402              
12403 0           return unpack('H*', $$o);
12404             }
12405              
12406             sub shortHex {
12407 0     0     my $o = shift;
12408              
12409 0           return unpack('H*', substr($$o, 0, 8)) . '…';
12410             }
12411              
12412             sub bytes {
12413 0     0     my $o = shift;
12414 0           $$o }
12415              
12416             sub equals {
12417 0     0     my $this = shift;
12418 0           my $that = shift;
12419              
12420 0 0 0       return 1 if ! defined $this && ! defined $that;
12421 0 0 0       return if ! defined $this || ! defined $that;
12422 0           return $$this eq $$that;
12423             }
12424              
12425             sub cmp {
12426 0     0     my $this = shift;
12427 0           my $that = shift;
12428 0           $$this cmp $$that }
12429              
12430             # A hash with an AES key.
12431             package CDS::HashAndKey;
12432              
12433             sub new {
12434 0     0     my $class = shift;
12435 0 0 0       my $hash = shift // return; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0   0        
12436 0   0       my $key = shift // return;
12437              
12438 0           return bless {
12439             hash => $hash,
12440             key => $key,
12441             };
12442             }
12443              
12444 0     0     sub hash { shift->{hash} }
12445 0     0     sub key { shift->{key} }
12446              
12447             package CDS::ISODate;
12448              
12449             # Parses a date accepting various ISO variants, and calculates the timestamp using Time::Local
12450             sub parse {
12451 0     0     my $class = shift;
12452 0   0       my $dateString = shift // return;
12453              
12454 0 0         if ($dateString =~ /^(\d\d\d\d)-(\d\d)-(\d\d)$/) {
    0          
    0          
    0          
    0          
    0          
12455 0           return (timegm(0, 0, 0, $3, $2 - 1, $1 - 1900) + 86400 - 30) * 1000;
12456             } elsif ($dateString =~ /^(\d\d\d\d)-(\d\d)-(\d\d)(T|\s+)(\d\d):(\d\d):(\d\d|\d\d\.\d*)$/) {
12457 0           return (timelocal(0, $6, $5, $3, $2 - 1, $1 - 1900) + $7) * 1000;
12458             } elsif ($dateString =~ /^(\d\d\d\d)-(\d\d)-(\d\d)(T|\s+)(\d\d):(\d\d):(\d\d|\d\d\.\d*)Z$/) {
12459 0           return (timegm(0, $6, $5, $3, $2 - 1, $1 - 1900) + $7) * 1000;
12460             } 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)$/) {
12461 0           return (timegm(0, $6, $5, $3, $2 - 1, $1 - 1900) + $7 - $8 * 3600 - $9 * 60) * 1000;
12462             } 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)$/) {
12463 0           return (timegm(0, $6, $5, $3, $2 - 1, $1 - 1900) + $7 + $8 * 3600 + $9 * 60) * 1000;
12464             } elsif ($dateString =~ /^\s*(\d+)\s*$/) {
12465 0           return $1;
12466             } else {
12467 0           return;
12468             }
12469             }
12470              
12471             # Returns a properly formatted string with a precision of 1 day (i.e., the "date" only)
12472             sub dayString {
12473 0     0     my $class = shift;
12474 0   0       my $time = shift // 1000 * time;
12475              
12476 0           my @t = gmtime($time / 1000);
12477 0           return sprintf('%04d-%02d-%02d', $t[5] + 1900, $t[4] + 1, $t[3]);
12478             }
12479              
12480             # Returns a properly formatted string with a precision of 1 second (i.e., "time of day" and "date") using UTC
12481             sub secondString {
12482 0     0     my $class = shift;
12483 0   0       my $time = shift // 1000 * time;
12484              
12485 0           my @t = gmtime($time / 1000);
12486 0           return sprintf('%04d-%02d-%02dT%02d:%02d:%02dZ', $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0]);
12487             }
12488              
12489             # Returns a properly formatted string with a precision of 1 second (i.e., "time of day" and "date") using UTC
12490             sub millisecondString {
12491 0     0     my $class = shift;
12492 0   0       my $time = shift // 1000 * time;
12493              
12494 0           my @t = gmtime($time / 1000);
12495 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);
12496             }
12497              
12498             # Returns a properly formatted string with a precision of 1 second (i.e., "time of day" and "date") using local time
12499             sub localSecondString {
12500 0     0     my $class = shift;
12501 0   0       my $time = shift // 1000 * time;
12502              
12503 0           my @t = localtime($time / 1000);
12504 0           return sprintf('%04d-%02d-%02dT%02d:%02d:%02d', $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0]);
12505             }
12506              
12507             package CDS::InMemoryStore;
12508              
12509             sub create {
12510 0     0     my $class = shift;
12511              
12512 0           return CDS::InMemoryStore->new('inMemoryStore:'.unpack('H*', CDS->randomBytes(16)));
12513             }
12514              
12515             sub new {
12516 0     0     my $o = shift;
12517 0           my $id = shift;
12518              
12519 0           return bless {
12520             id => $id,
12521             objects => {},
12522             accounts => {},
12523             };
12524             }
12525              
12526 0     0     sub id { shift->{id} }
12527              
12528             sub accountForWriting {
12529 0     0     my $o = shift;
12530 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12531              
12532 0           my $account = $o->{accounts}->{$hash->bytes};
12533 0 0         return $account if $account;
12534 0           return $o->{accounts}->{$hash->bytes} = {messages => {}, private => {}, public => {}};
12535             }
12536              
12537             # *** Store interface
12538              
12539             sub get {
12540 0     0     my $o = shift;
12541 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12542 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12543              
12544 0   0       my $entry = $o->{objects}->{$hash->bytes} // return;
12545 0           return $entry->{object};
12546             }
12547              
12548             sub book {
12549 0     0     my $o = shift;
12550 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12551 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12552              
12553 0   0       my $entry = $o->{objects}->{$hash->bytes} // return;
12554 0           $entry->{booked} = CDS->now;
12555 0           return 1;
12556             }
12557              
12558             sub put {
12559 0     0     my $o = shift;
12560 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12561 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
12562 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12563              
12564 0           $o->{objects}->{$hash->bytes} = {object => $object, booked => CDS->now};
12565 0           return;
12566             }
12567              
12568             sub list {
12569 0     0     my $o = shift;
12570 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
12571 0           my $boxLabel = shift;
12572 0           my $timeout = shift;
12573 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12574              
12575 0   0       my $account = $o->{accounts}->{$accountHash->bytes} // return [];
12576 0   0       my $box = $account->{$boxLabel} // return undef, 'Invalid box label.';
12577 0           return values %$box;
12578             }
12579              
12580             sub add {
12581 0     0     my $o = shift;
12582 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
12583 0           my $boxLabel = shift;
12584 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12585 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12586              
12587 0   0       my $box = $o->accountForWriting($accountHash)->{$boxLabel} // return;
12588 0           $box->{$hash->bytes} = $hash;
12589             }
12590              
12591             sub remove {
12592 0     0     my $o = shift;
12593 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
12594 0           my $boxLabel = shift;
12595 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12596 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12597              
12598 0   0       my $box = $o->accountForWriting($accountHash)->{$boxLabel} // return;
12599 0           delete $box->{$hash->bytes};
12600             }
12601              
12602             sub modify {
12603 0     0     my $o = shift;
12604 0           my $modifications = shift;
12605 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12606              
12607 0           return $modifications->executeIndividually($o, $keyPair);
12608             }
12609              
12610             # Garbage collection
12611              
12612             sub collectGarbage {
12613 0     0     my $o = shift;
12614 0           my $graceTime = shift;
12615              
12616             # Mark all objects as not used
12617 0           for my $entry (values %{$o->{objects}}) {
  0            
12618 0           $entry->{inUse} = 0;
12619             }
12620              
12621             # Mark all objects newer than the grace time
12622 0           for my $entry (values %{$o->{objects}}) {
  0            
12623 0 0         $o->markEntry($entry) if $entry->{booked} > $graceTime;
12624             }
12625              
12626             # Mark all objects referenced from a box
12627 0           for my $account (values %{$o->{accounts}}) {
  0            
12628 0           for my $hash (values %{$account->{messages}}) { $o->markHash($hash); }
  0            
  0            
12629 0           for my $hash (values %{$account->{private}}) { $o->markHash($hash); }
  0            
  0            
12630 0           for my $hash (values %{$account->{public}}) { $o->markHash($hash); }
  0            
  0            
12631             }
12632              
12633             # Remove empty accounts
12634 0           while (my ($key, $account) = each %{$o->{accounts}}) {
  0            
12635 0 0         next if scalar keys %{$account->{messages}};
  0            
12636 0 0         next if scalar keys %{$account->{private}};
  0            
12637 0 0         next if scalar keys %{$account->{public}};
  0            
12638 0           delete $o->{accounts}->{$key};
12639             }
12640              
12641             # Remove obsolete objects
12642 0           while (my ($key, $entry) = each %{$o->{objects}}) {
  0            
12643 0 0         next if $entry->{inUse};
12644 0           delete $o->{objects}->{$key};
12645             }
12646             }
12647              
12648             sub markHash {
12649 0     0     my $o = shift;
12650 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12651             # private
12652 0   0       my $child = $o->{objects}->{$hash->bytes} // return;
12653 0           $o->mark($child);
12654             }
12655              
12656             sub markEntry {
12657 0     0     my $o = shift;
12658 0           my $entry = shift;
12659             # private
12660 0 0         return if $entry->{inUse};
12661 0           $entry->{inUse} = 1;
12662              
12663             # Mark all children
12664 0           for my $hash ($entry->{object}->hashes) {
12665 0           $o->markHash($hash);
12666             }
12667             }
12668              
12669             package CDS::KeyPair;
12670              
12671             sub transfer {
12672 0     0     my $o = shift;
12673 0           my $hashes = shift;
12674 0           my $sourceStore = shift;
12675 0           my $destinationStore = shift;
12676              
12677 0           for my $hash (@$hashes) {
12678 0           my ($missing, $store, $storeError) = $o->recursiveTransfer($hash, $sourceStore, $destinationStore, {});
12679 0 0         return $missing if $missing;
12680 0 0         return undef, $store, $storeError if defined $storeError;
12681             }
12682              
12683 0           return;
12684             }
12685              
12686             sub recursiveTransfer {
12687 0     0     my $o = shift;
12688 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12689 0           my $sourceStore = shift;
12690 0           my $destinationStore = shift;
12691 0           my $done = shift;
12692             # private
12693 0 0         return if $done->{$hash->bytes};
12694 0           $done->{$hash->bytes} = 1;
12695              
12696             # Book
12697 0           my ($booked, $bookError) = $destinationStore->book($hash, $o);
12698 0 0         return undef, $destinationStore, $bookError if defined $bookError;
12699 0 0         return if $booked;
12700              
12701             # Get
12702 0           my ($object, $getError) = $sourceStore->get($hash, $o);
12703 0 0         return undef, $sourceStore, $getError if defined $getError;
12704 0 0         return CDS::MissingObject->new($hash, $sourceStore) if ! defined $object;
12705              
12706             # Process children
12707 0           for my $child ($object->hashes) {
12708 0           my ($missing, $store, $error) = $o->recursiveTransfer($child, $sourceStore, $destinationStore, $done);
12709 0 0         return undef, $store, $error if defined $error;
12710 0 0         if (defined $missing) {
12711 0           push @{$missing->{path}}, $child;
  0            
12712 0           return $missing;
12713             }
12714             }
12715              
12716             # Put
12717 0           my $putError = $destinationStore->put($hash, $object, $o);
12718 0 0         return undef, $destinationStore, $putError if defined $putError;
12719 0           return;
12720             }
12721              
12722             sub createPublicEnvelope {
12723 0     0     my $o = shift;
12724 0 0 0       my $contentHash = shift; die 'wrong type '.ref($contentHash).' for $contentHash' if defined $contentHash && ref $contentHash ne 'CDS::Hash';
  0            
12725              
12726 0           my $envelope = CDS::Record->new;
12727 0           $envelope->add('content')->addHash($contentHash);
12728 0           $envelope->add('signature')->add($o->signHash($contentHash));
12729 0           return $envelope;
12730             }
12731              
12732             sub createPrivateEnvelope {
12733 0     0     my $o = shift;
12734 0           my $contentHashAndKey = shift;
12735 0           my $recipientPublicKeys = shift;
12736              
12737 0           my $envelope = CDS::Record->new;
12738 0           $envelope->add('content')->addHash($contentHashAndKey->hash);
12739 0           $o->addRecipientsToEnvelope($envelope, $contentHashAndKey->key, $recipientPublicKeys);
12740 0           $envelope->add('signature')->add($o->signHash($contentHashAndKey->hash));
12741 0           return $envelope;
12742             }
12743              
12744             sub createMessageEnvelope {
12745 0     0     my $o = shift;
12746 0           my $storeUrl = shift;
12747 0 0 0       my $messageRecord = shift; die 'wrong type '.ref($messageRecord).' for $messageRecord' if defined $messageRecord && ref $messageRecord ne 'CDS::Record';
  0            
12748 0           my $recipientPublicKeys = shift;
12749 0           my $expires = shift;
12750              
12751 0           my $contentRecord = CDS::Record->new;
12752 0           $contentRecord->add('store')->addText($storeUrl);
12753 0           $contentRecord->add('sender')->addHash($o->publicKey->hash);
12754 0           $contentRecord->addRecord($messageRecord->children);
12755 0           my $contentObject = $contentRecord->toObject;
12756 0           my $contentKey = CDS->randomKey;
12757 0           my $encryptedContent = CDS::C::aesCrypt($contentObject->bytes, $contentKey, CDS->zeroCTR);
12758             #my $hashToSign = $contentObject->calculateHash; # prior to 2020-05-05
12759 0           my $hashToSign = CDS::Hash->calculateFor($encryptedContent);
12760              
12761 0           my $envelope = CDS::Record->new;
12762 0           $envelope->add('content')->add($encryptedContent);
12763 0           $o->addRecipientsToEnvelope($envelope, $contentKey, $recipientPublicKeys);
12764 0           $envelope->add('updated by')->add(substr($o->publicKey->hash->bytes, 0, 24));
12765 0 0         $envelope->add('expires')->addInteger($expires) if defined $expires;
12766 0           $envelope->add('signature')->add($o->signHash($hashToSign));
12767 0           return $envelope;
12768             }
12769              
12770             sub addRecipientsToEnvelope {
12771 0     0     my $o = shift;
12772 0 0 0       my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0            
12773 0           my $key = shift;
12774 0           my $recipientPublicKeys = shift;
12775             # private
12776 0           my $encryptedKeyRecord = $envelope->add('encrypted for');
12777 0           my $myHashBytes24 = substr($o->{publicKey}->hash->bytes, 0, 24);
12778 0           $encryptedKeyRecord->add($myHashBytes24)->add($o->{publicKey}->encrypt($key));
12779 0           for my $publicKey (@$recipientPublicKeys) {
12780 0 0         next if $publicKey->hash->equals($o->{publicKey}->hash);
12781 0           my $hashBytes24 = substr($publicKey->hash->bytes, 0, 24);
12782 0           $encryptedKeyRecord->add($hashBytes24)->add($publicKey->encrypt($key));
12783             }
12784             }
12785              
12786             sub generate {
12787 0     0     my $class = shift;
12788              
12789             # Generate a new private key
12790 0           my $rsaPrivateKey = CDS::C::privateKeyGenerate();
12791              
12792             # Serialize the public key
12793 0           my $rsaPublicKey = CDS::C::publicKeyFromPrivateKey($rsaPrivateKey);
12794 0           my $record = CDS::Record->new;
12795 0           $record->add('e')->add(CDS::C::publicKeyE($rsaPublicKey));
12796 0           $record->add('n')->add(CDS::C::publicKeyN($rsaPublicKey));
12797 0           my $publicKey = CDS::PublicKey->fromObject($record->toObject);
12798              
12799             # Return a new CDS::KeyPair instance
12800 0           return CDS::KeyPair->new($publicKey, $rsaPrivateKey);
12801             }
12802              
12803             sub fromFile {
12804 0     0     my $class = shift;
12805 0           my $file = shift;
12806              
12807 0   0       my $bytes = CDS->readBytesFromFile($file) // return;
12808 0           my $record = CDS::Record->fromObject(CDS::Object->fromBytes($bytes));
12809 0           return $class->fromRecord($record);
12810             }
12811              
12812             sub fromHex {
12813 0     0     my $class = shift;
12814 0           my $hex = shift;
12815              
12816 0           return $class->fromRecord(CDS::Record->fromObject(CDS::Object->fromBytes(pack 'H*', $hex)));
12817             }
12818              
12819             sub fromRecord {
12820 0     0     my $class = shift;
12821 0 0 0       my $record = shift // return; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0   0        
12822              
12823 0   0       my $publicKey = CDS::PublicKey->fromObject(CDS::Object->fromBytes($record->child('public key object')->bytesValue)) // return;
12824 0           my $rsaKey = $record->child('rsa key');
12825 0           my $e = $rsaKey->child('e')->bytesValue;
12826 0           my $p = $rsaKey->child('p')->bytesValue;
12827 0           my $q = $rsaKey->child('q')->bytesValue;
12828 0   0       return $class->new($publicKey, CDS::C::privateKeyNew($e, $p, $q) // return);
12829             }
12830              
12831             sub new {
12832 0     0     my $class = shift;
12833 0 0 0       my $publicKey = shift; die 'wrong type '.ref($publicKey).' for $publicKey' if defined $publicKey && ref $publicKey ne 'CDS::PublicKey';
  0            
12834 0           my $rsaPrivateKey = shift;
12835              
12836 0           return bless {
12837             publicKey => $publicKey, # The public key
12838             rsaPrivateKey => $rsaPrivateKey, # The private key
12839             };
12840             }
12841              
12842 0     0     sub publicKey { shift->{publicKey} }
12843 0     0     sub rsaPrivateKey { shift->{rsaPrivateKey} }
12844              
12845             ### Serialization ###
12846              
12847             sub toRecord {
12848 0     0     my $o = shift;
12849              
12850 0           my $record = CDS::Record->new;
12851 0           $record->add('public key object')->add($o->{publicKey}->object->bytes);
12852 0           my $rsaKeyRecord = $record->add('rsa key');
12853 0           $rsaKeyRecord->add('e')->add(CDS::C::privateKeyE($o->{rsaPrivateKey}));
12854 0           $rsaKeyRecord->add('p')->add(CDS::C::privateKeyP($o->{rsaPrivateKey}));
12855 0           $rsaKeyRecord->add('q')->add(CDS::C::privateKeyQ($o->{rsaPrivateKey}));
12856 0           return $record;
12857             }
12858              
12859             sub toHex {
12860 0     0     my $o = shift;
12861              
12862 0           my $object = $o->toRecord->toObject;
12863 0           return unpack('H*', $object->header).unpack('H*', $object->data);
12864             }
12865              
12866             sub writeToFile {
12867 0     0     my $o = shift;
12868 0           my $file = shift;
12869              
12870 0           my $object = $o->toRecord->toObject;
12871 0           return CDS->writeBytesToFile($file, $object->bytes);
12872             }
12873              
12874             ### Private key interface ###
12875              
12876             sub decrypt {
12877 0     0     my $o = shift;
12878 0           my $bytes = shift;
12879             # decrypt(bytes) -> bytes
12880 0           return CDS::C::privateKeyDecrypt($o->{rsaPrivateKey}, $bytes);
12881             }
12882              
12883             sub sign {
12884 0     0     my $o = shift;
12885 0           my $digest = shift;
12886             # sign(bytes) -> bytes
12887 0           return CDS::C::privateKeySign($o->{rsaPrivateKey}, $digest);
12888             }
12889              
12890             sub signHash {
12891 0     0     my $o = shift;
12892 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12893             # signHash(hash) -> bytes
12894 0           return CDS::C::privateKeySign($o->{rsaPrivateKey}, $hash->bytes);
12895             }
12896              
12897             ### Retrieval ###
12898              
12899             # Retrieves an object from one of the stores, and decrypts it.
12900             sub getAndDecrypt {
12901 0     0     my $o = shift;
12902 0 0 0       my $hashAndKey = shift; die 'wrong type '.ref($hashAndKey).' for $hashAndKey' if defined $hashAndKey && ref $hashAndKey ne 'CDS::HashAndKey';
  0            
12903 0           my $store = shift;
12904              
12905 0           my ($object, $error) = $store->get($hashAndKey->hash, $o);
12906 0 0         return undef, undef, $error if defined $error;
12907 0 0         return undef, 'Not found.', undef if ! $object;
12908 0           return $object->crypt($hashAndKey->key);
12909             }
12910              
12911             # Retrieves an object from one of the stores, and parses it as record.
12912             sub getRecord {
12913 0     0     my $o = shift;
12914 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12915 0           my $store = shift;
12916              
12917 0           my ($object, $error) = $store->get($hash, $o);
12918 0 0         return undef, undef, undef, $error if defined $error;
12919 0 0         return undef, undef, 'Not found.', undef if ! $object;
12920 0   0       my $record = CDS::Record->fromObject($object) // return undef, undef, 'Not a record.', undef;
12921 0           return $record, $object;
12922             }
12923              
12924             # Retrieves an object from one of the stores, decrypts it, and parses it as record.
12925             sub getAndDecryptRecord {
12926 0     0     my $o = shift;
12927 0 0 0       my $hashAndKey = shift; die 'wrong type '.ref($hashAndKey).' for $hashAndKey' if defined $hashAndKey && ref $hashAndKey ne 'CDS::HashAndKey';
  0            
12928 0           my $store = shift;
12929              
12930 0           my ($object, $error) = $store->get($hashAndKey->hash, $o);
12931 0 0         return undef, undef, undef, $error if defined $error;
12932 0 0         return undef, undef, 'Not found.', undef if ! $object;
12933 0           my $decrypted = $object->crypt($hashAndKey->key);
12934 0   0       my $record = CDS::Record->fromObject($decrypted) // return undef, undef, 'Not a record.', undef;
12935 0           return $record, $object;
12936             }
12937              
12938             # Retrieves an public key object from one of the stores, and parses its public key.
12939             sub getPublicKey {
12940 0     0     my $o = shift;
12941 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
12942 0           my $store = shift;
12943              
12944 0           my ($object, $error) = $store->get($hash, $o);
12945 0 0         return undef, undef, $error if defined $error;
12946 0 0         return undef, 'Not found.', undef if ! $object;
12947 0   0       return CDS::PublicKey->fromObject($object) // return undef, 'Not a public key.', undef;
12948             }
12949              
12950             ### Equality ###
12951              
12952             sub equals {
12953 0     0     my $this = shift;
12954 0           my $that = shift;
12955              
12956 0 0 0       return 1 if ! defined $this && ! defined $that;
12957 0 0 0       return if ! defined $this || ! defined $that;
12958 0           return $this->publicKey->hash->equals($that->publicKey->hash);
12959             }
12960              
12961             ### Open envelopes ###
12962              
12963             sub decryptKeyOnEnvelope {
12964 0     0     my $o = shift;
12965 0 0 0       my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0            
12966              
12967             # Read the AES key
12968 0           my $hashBytes24 = substr($o->{publicKey}->hash->bytes, 0, 24);
12969 0           my $encryptedAesKey = $envelope->child('encrypted for')->child($hashBytes24)->bytesValue;
12970 0 0         $encryptedAesKey = $envelope->child('encrypted for')->child($o->{publicKey}->hash->bytes)->bytesValue if ! length $encryptedAesKey; # todo: remove this
12971 0 0         return if ! length $encryptedAesKey;
12972              
12973             # Decrypt the AES key
12974 0           my $aesKeyBytes = $o->decrypt($encryptedAesKey);
12975 0 0 0       return if ! $aesKeyBytes || length $aesKeyBytes != 32;
12976              
12977 0           return $aesKeyBytes;
12978             }
12979              
12980             # The result of parsing a KEYPAIR token (see Token.pm).
12981             package CDS::KeyPairToken;
12982              
12983             sub new {
12984 0     0     my $class = shift;
12985 0           my $file = shift;
12986 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
12987              
12988 0           return bless {
12989             file => $file,
12990             keyPair => $keyPair,
12991             };
12992             }
12993              
12994 0     0     sub file { shift->{file} }
12995 0     0     sub keyPair { shift->{keyPair} }
12996              
12997             package CDS::LoadActorGroup;
12998              
12999             sub load {
13000 0     0     my $class = shift;
13001 0 0 0       my $builder = shift; die 'wrong type '.ref($builder).' for $builder' if defined $builder && ref $builder ne 'CDS::ActorGroupBuilder';
  0            
13002 0           my $store = shift;
13003 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
13004 0           my $delegate = shift;
13005              
13006 0           my $o = bless {
13007             store => $store,
13008             keyPair => $keyPair,
13009             knownPublicKeys => $builder->knownPublicKeys,
13010             };
13011              
13012 0           my $members = [];
13013 0           for my $member ($builder->members) {
13014 0           my $isActive = $member->status eq 'active';
13015 0           my $isIdle = $member->status eq 'idle';
13016 0 0 0       next if ! $isActive && ! $isIdle;
13017              
13018 0           my ($publicKey, $storeError) = $o->getPublicKey($member->hash);
13019 0 0         return undef, $storeError if defined $storeError;
13020 0 0         next if ! $publicKey;
13021              
13022 0   0       my $accountStore = $delegate->onLoadActorGroupVerifyStore($member->storeUrl) // next;
13023 0           my $actorOnStore = CDS::ActorOnStore->new($publicKey, $accountStore);
13024 0           push @$members, CDS::ActorGroup::Member->new($actorOnStore, $member->storeUrl, $member->revision, $isActive);
13025             }
13026              
13027 0           my $entrustedActors = [];
13028 0           for my $actor ($builder->entrustedActors) {
13029 0           my ($publicKey, $storeError) = $o->getPublicKey($actor->hash);
13030 0 0         return undef, $storeError if defined $storeError;
13031 0 0         next if ! $publicKey;
13032              
13033 0   0       my $accountStore = $delegate->onLoadActorGroupVerifyStore($actor->storeUrl) // next;
13034 0           my $actorOnStore = CDS::ActorOnStore->new($publicKey, $accountStore);
13035 0           push @$entrustedActors, CDS::ActorGroup::EntrustedActor->new($actorOnStore, $actor->storeUrl);
13036             }
13037              
13038 0           return CDS::ActorGroup->new($members, $builder->entrustedActorsRevision, $entrustedActors);
13039             }
13040              
13041             sub getPublicKey {
13042 0     0     my $o = shift;
13043 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
13044              
13045 0           my $knownPublicKey = $o->{knownPublicKeys}->{$hash->bytes};
13046 0 0         return $knownPublicKey if $knownPublicKey;
13047              
13048 0           my ($publicKey, $invalidReason, $storeError) = $o->{keyPair}->getPublicKey($hash, $o->{store});
13049 0 0         return undef, $storeError if defined $storeError;
13050 0 0         return if defined $invalidReason;
13051              
13052 0           $o->{knownPublicKeys}->{$hash->bytes} = $publicKey;
13053 0           return $publicKey;
13054             };
13055              
13056             # A store that prints all accesses to a filehandle (STDERR by default).
13057             package CDS::LogStore;
13058              
13059 1     1   7299 use parent -norequire, 'CDS::Store';
  1         2  
  1         5  
13060              
13061             sub new {
13062 0     0     my $class = shift;
13063 0           my $store = shift;
13064 0   0       my $fileHandle = shift // *STDERR;
13065 0   0       my $prefix = shift // '';
13066              
13067 0           return bless {
13068             id => "Log Store\n".$store->id,
13069             store => $store,
13070             fileHandle => $fileHandle,
13071             prefix => '',
13072             };
13073             }
13074              
13075 0     0     sub id { shift->{id} }
13076 0     0     sub store { shift->{store} }
13077 0     0     sub fileHandle { shift->{fileHandle} }
13078 0     0     sub prefix { shift->{prefix} }
13079              
13080             sub get {
13081 0     0     my $o = shift;
13082 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
13083 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
13084              
13085 0           my $start = CDS::C::performanceStart();
13086 0           my ($object, $error) = $o->{store}->get($hash, $keyPair);
13087 0           my $elapsed = CDS::C::performanceElapsed($start);
13088 0 0         $o->log('get', $hash->shortHex, defined $object ? &formatByteLength($object->byteLength).' bytes' : defined $error ? 'failed: '.$error : 'not found', $elapsed);
    0          
13089 0           return $object, $error;
13090             }
13091              
13092             sub put {
13093 0     0     my $o = shift;
13094 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
13095 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
13096 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
13097              
13098 0           my $start = CDS::C::performanceStart();
13099 0           my $error = $o->{store}->put($hash, $object, $keyPair);
13100 0           my $elapsed = CDS::C::performanceElapsed($start);
13101 0 0         $o->log('put', $hash->shortHex . ' ' . &formatByteLength($object->byteLength) . ' bytes', defined $error ? 'failed: '.$error : 'OK', $elapsed);
13102 0           return $error;
13103             }
13104              
13105             sub book {
13106 0     0     my $o = shift;
13107 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
13108 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
13109              
13110 0           my $start = CDS::C::performanceStart();
13111 0           my ($booked, $error) = $o->{store}->book($hash, $keyPair);
13112 0           my $elapsed = CDS::C::performanceElapsed($start);
13113 0 0         $o->log('book', $hash->shortHex, defined $booked ? 'OK' : defined $error ? 'failed: '.$error : 'not found', $elapsed);
    0          
13114 0           return $booked, $error;
13115             }
13116              
13117             sub list {
13118 0     0     my $o = shift;
13119 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
13120 0           my $boxLabel = shift;
13121 0           my $timeout = shift;
13122 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
13123              
13124 0           my $start = CDS::C::performanceStart();
13125 0           my ($hashes, $error) = $o->{store}->list($accountHash, $boxLabel, $timeout, $keyPair);
13126 0           my $elapsed = CDS::C::performanceElapsed($start);
13127 0 0         $o->log('list', $accountHash->shortHex . ' ' . $boxLabel . ($timeout ? ' ' . $timeout . ' s' : ''), defined $hashes ? scalar(@$hashes).' entries' : 'failed: '.$error, $elapsed);
    0          
13128 0           return $hashes, $error;
13129             }
13130              
13131             sub add {
13132 0     0     my $o = shift;
13133 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
13134 0           my $boxLabel = shift;
13135 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
13136 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
13137              
13138 0           my $start = CDS::C::performanceStart();
13139 0           my $error = $o->{store}->add($accountHash, $boxLabel, $hash, $keyPair);
13140 0           my $elapsed = CDS::C::performanceElapsed($start);
13141 0 0         $o->log('add', $accountHash->shortHex . ' ' . $boxLabel . ' ' . $hash->shortHex, defined $error ? 'failed: '.$error : 'OK', $elapsed);
13142 0           return $error;
13143             }
13144              
13145             sub remove {
13146 0     0     my $o = shift;
13147 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
13148 0           my $boxLabel = shift;
13149 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
13150 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
13151              
13152 0           my $start = CDS::C::performanceStart();
13153 0           my $error = $o->{store}->remove($accountHash, $boxLabel, $hash, $keyPair);
13154 0           my $elapsed = CDS::C::performanceElapsed($start);
13155 0 0         $o->log('remove', $accountHash->shortHex . ' ' . $boxLabel . ' ' . $hash->shortHex, defined $error ? 'failed: '.$error : 'OK', $elapsed);
13156 0           return $error;
13157             }
13158              
13159             sub modify {
13160 0     0     my $o = shift;
13161 0           my $modifications = shift;
13162 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
13163              
13164 0           my $start = CDS::C::performanceStart();
13165 0           my $error = $o->{store}->modify($modifications, $keyPair);
13166 0           my $elapsed = CDS::C::performanceElapsed($start);
13167 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            
13168 0           return $error;
13169             }
13170              
13171             sub log {
13172 0     0     my $o = shift;
13173 0           my $cmd = shift;
13174 0           my $input = shift;
13175 0           my $output = shift;
13176 0           my $elapsed = shift;
13177              
13178 0   0       my $fh = $o->{fileHandle} // return;
13179 0           print $fh $o->{prefix}, &left(8, $cmd), &left(40, $input), ' => ', &left(40, $output), &formatDuration($elapsed), ' us', "\n";
13180             }
13181              
13182             sub left {
13183 0     0     my $width = shift;
13184 0           my $text = shift;
13185             # private
13186 0 0         return $text . (' ' x ($width - length $text)) if length $text < $width;
13187 0           return $text;
13188             }
13189              
13190             sub formatByteLength {
13191 0     0     my $byteLength = shift;
13192             # private
13193 0           my $s = ''.$byteLength;
13194 0 0         $s = ' ' x (9 - length $s) . $s if length $s < 9;
13195 0           my $len = length $s;
13196 0           return substr($s, 0, $len - 6).' '.substr($s, $len - 6, 3).' '.substr($s, $len - 3, 3);
13197             }
13198              
13199             sub formatDuration {
13200 0     0     my $elapsed = shift;
13201             # private
13202 0           my $s = ''.$elapsed;
13203 0 0         $s = ' ' x (9 - length $s) . $s if length $s < 9;
13204 0           my $len = length $s;
13205 0           return substr($s, 0, $len - 6).' '.substr($s, $len - 6, 3).' '.substr($s, $len - 3, 3);
13206             }
13207              
13208             # Reads the message box of an actor.
13209             package CDS::MessageBoxReader;
13210              
13211             sub new {
13212 0     0     my $class = shift;
13213 0           my $pool = shift;
13214 0 0 0       my $actorOnStore = shift; die 'wrong type '.ref($actorOnStore).' for $actorOnStore' if defined $actorOnStore && ref $actorOnStore ne 'CDS::ActorOnStore';
  0            
13215 0           my $streamTimeout = shift;
13216              
13217 0   0       return bless {
13218             pool => $pool,
13219             actorOnStore => $actorOnStore,
13220             streamCache => CDS::StreamCache->new($pool, $actorOnStore, $streamTimeout // CDS->MINUTE),
13221             entries => {},
13222             };
13223             }
13224              
13225 0     0     sub pool { shift->{pool} }
13226 0     0     sub actorOnStore { shift->{actorOnStore} }
13227              
13228             sub read {
13229 0     0     my $o = shift;
13230 0   0       my $timeout = shift // 0;
13231              
13232 0           my $store = $o->{actorOnStore}->store;
13233 0           my ($hashes, $listError) = $store->list($o->{actorOnStore}->publicKey->hash, 'messages', $timeout, $o->{pool}->{keyPair});
13234 0 0         return if defined $listError;
13235              
13236 0           for my $hash (@$hashes) {
13237 0           my $entry = $o->{entries}->{$hash->bytes};
13238 0 0         $o->{entries}->{$hash->bytes} = $entry = CDS::MessageBoxReader::Entry->new($hash) if ! $entry;
13239 0 0         next if $entry->{processed};
13240              
13241             # Check the sender store, if necessary
13242 0 0         if ($entry->{waitingForStore}) {
13243 0           my ($dummy, $checkError) = $entry->{waitingForStore}->get(CDS->emptyBytesHash, $o->{pool}->{keyPair});
13244 0 0         next if defined $checkError;
13245             }
13246              
13247             # Get the envelope
13248 0           my ($object, $getError) = $o->{actorOnStore}->store->get($entry->{hash}, $o->{pool}->{keyPair});
13249 0 0         return if defined $getError;
13250              
13251             # Mark the entry as processed
13252 0           $entry->{processed} = 1;
13253              
13254 0 0         if (! defined $object) {
13255 0           $o->invalid($entry, 'Envelope object not found.');
13256 0           next;
13257             }
13258              
13259             # Parse the record
13260 0           my $envelope = CDS::Record->fromObject($object);
13261 0 0         if (! $envelope) {
13262 0           $o->invalid($entry, 'Envelope is not a record.');
13263 0           next;
13264             }
13265              
13266 0 0 0       my $message =
13267             $envelope->contains('head') && $envelope->contains('mac') ?
13268             $o->readStreamMessage($entry, $envelope) :
13269             $o->readNormalMessage($entry, $envelope);
13270 0 0         next if ! $message;
13271              
13272 0           $o->{pool}->{delegate}->onMessageBoxEntry($message);
13273             }
13274              
13275 0           $o->{streamCache}->removeObsolete;
13276 0           return 1;
13277             }
13278              
13279             sub readNormalMessage {
13280 0     0     my $o = shift;
13281 0           my $entry = shift;
13282 0 0 0       my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0            
13283             # private
13284             # Read the embedded content object
13285 0           my $encryptedBytes = $envelope->child('content')->bytesValue;
13286 0 0         return $o->invalid($entry, 'Missing content object.') if ! length $encryptedBytes;
13287              
13288             # Decrypt the key
13289 0           my $aesKey = $o->{pool}->{keyPair}->decryptKeyOnEnvelope($envelope);
13290 0 0         return $o->invalid($entry, 'Not encrypted for us.') if ! $aesKey;
13291              
13292             # Decrypt the content
13293 0           my $contentObject = CDS::Object->fromBytes(CDS::C::aesCrypt($encryptedBytes, $aesKey, CDS->zeroCTR));
13294 0 0         return $o->invalid($entry, 'Invalid content object.') if ! $contentObject;
13295              
13296 0           my $content = CDS::Record->fromObject($contentObject);
13297 0 0         return $o->invalid($entry, 'Content object is not a record.') if ! $content;
13298              
13299             # Verify the sender hash
13300 0           my $senderHash = $content->child('sender')->hashValue;
13301 0 0         return $o->invalid($entry, 'Missing sender hash.') if ! $senderHash;
13302              
13303             # Verify the sender store
13304 0           my $storeRecord = $content->child('store');
13305 0 0         return $o->invalid($entry, 'Missing sender store.') if ! scalar $storeRecord->children;
13306              
13307 0           my $senderStoreUrl = $storeRecord->textValue;
13308 0           my $senderStore = $o->{pool}->{delegate}->onMessageBoxVerifyStore($senderStoreUrl, $entry->{hash}, $envelope, $senderHash);
13309 0 0         return $o->invalid($entry, 'Invalid sender store.') if ! $senderStore;
13310              
13311             # Retrieve the sender's public key
13312 0           my ($senderPublicKey, $invalidReason, $publicKeyStoreError) = $o->getPublicKey($senderHash, $senderStore);
13313 0 0         return if defined $publicKeyStoreError;
13314 0 0         return $o->invalid($entry, 'Failed to retrieve the sender\'s public key: '.$invalidReason) if defined $invalidReason;
13315              
13316             # Verify the signature
13317 0           my $signedHash = CDS::Hash->calculateFor($encryptedBytes);
13318 0 0         if (! CDS->verifyEnvelopeSignature($envelope, $senderPublicKey, $signedHash)) {
13319             # For backwards compatibility with versions before 2020-05-05
13320 0 0         return $o->invalid($entry, 'Invalid signature.') if ! CDS->verifyEnvelopeSignature($envelope, $senderPublicKey, $contentObject->calculateHash);
13321             }
13322              
13323             # The envelope is valid
13324 0           my $sender = CDS::ActorOnStore->new($senderPublicKey, $senderStore);
13325 0           my $source = CDS::Source->new($o->{pool}->{keyPair}, $o->{actorOnStore}, 'messages', $entry->{hash});
13326 0           return CDS::ReceivedMessage->new($o, $entry, $source, $envelope, $senderStoreUrl, $sender, $content);
13327             }
13328              
13329             sub readStreamMessage {
13330 0     0     my $o = shift;
13331 0           my $entry = shift;
13332 0 0 0       my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0            
13333             # private
13334             # Get the head
13335 0           my $head = $envelope->child('head')->hashValue;
13336 0 0         return $o->invalid($entry, 'Invalid head message hash.') if ! $head;
13337              
13338             # Get the head envelope
13339 0           my $streamHead = $o->{streamCache}->readStreamHead($head);
13340 0 0         return if ! $streamHead;
13341 0 0         return $o->invalid($entry, 'Invalid stream head: '.$streamHead->error) if $streamHead->error;
13342              
13343             # Read the embedded content object
13344 0           my $encryptedBytes = $envelope->child('content')->bytesValue;
13345 0 0         return $o->invalid($entry, 'Missing content object.') if ! length $encryptedBytes;
13346              
13347             # Get the CTR
13348 0           my $ctr = $envelope->child('ctr')->bytesValue;
13349 0 0         return $o->invalid($entry, 'Invalid CTR.') if length $ctr != 16;
13350              
13351             # Get the MAC
13352 0           my $mac = $envelope->child('mac')->bytesValue;
13353 0 0         return $o->invalid($entry, 'Invalid MAC.') if ! $mac;
13354              
13355             # Verify the MAC
13356 0           my $signedHash = CDS::Hash->calculateFor($encryptedBytes);
13357 0           my $expectedMac = CDS::C::aesCrypt($signedHash->bytes, $streamHead->aesKey, $ctr);
13358 0 0         return $o->invalid($entry, 'Invalid MAC.') if $mac ne $expectedMac;
13359              
13360             # Decrypt the content
13361 0           my $contentObject = CDS::Object->fromBytes(CDS::C::aesCrypt($encryptedBytes, $streamHead->aesKey, CDS::C::counterPlusInt($ctr, 2)));
13362 0 0         return $o->invalid($entry, 'Invalid content object.') if ! $contentObject;
13363              
13364 0           my $content = CDS::Record->fromObject($contentObject);
13365 0 0         return $o->invalid($entry, 'Content object is not a record.') if ! $content;
13366              
13367             # The envelope is valid
13368 0           my $source = CDS::Source->new($o->{pool}->{keyPair}, $o->{actorOnStore}, 'messages', $entry->{hash});
13369 0           return CDS::ReceivedMessage->new($o, $entry, $source, $envelope, $streamHead->senderStoreUrl, $streamHead->sender, $content, $streamHead);
13370             }
13371              
13372             sub invalid {
13373 0     0     my $o = shift;
13374 0           my $entry = shift;
13375 0           my $reason = shift;
13376             # private
13377 0           my $source = CDS::Source->new($o->{pool}->{keyPair}, $o->{actorOnStore}, 'messages', $entry->{hash});
13378 0           $o->{pool}->{delegate}->onMessageBoxInvalidEntry($source, $reason);
13379             }
13380              
13381             sub getPublicKey {
13382 0     0     my $o = shift;
13383 0 0 0       my $senderHash = shift; die 'wrong type '.ref($senderHash).' for $senderHash' if defined $senderHash && ref $senderHash ne 'CDS::Hash';
  0            
13384 0           my $senderStore = shift;
13385 0           my $senderStoreUrl = shift;
13386             # private
13387             # Use the account key if sender and recipient are the same
13388 0 0         return $o->{actorOnStore}->publicKey if $senderHash->equals($o->{actorOnStore}->publicKey->hash);
13389              
13390             # Reuse a cached public key
13391 0           my $cachedPublicKey = $o->{pool}->{publicKeyCache}->get($senderHash);
13392 0 0         return $cachedPublicKey if $cachedPublicKey;
13393              
13394             # Retrieve the sender's public key from the sender's store
13395 0           my ($publicKey, $invalidReason, $storeError) = $o->{pool}->{keyPair}->getPublicKey($senderHash, $senderStore);
13396 0 0         return undef, undef, $storeError if defined $storeError;
13397 0 0         return undef, $invalidReason if defined $invalidReason;
13398 0           $o->{pool}->{publicKeyCache}->add($publicKey);
13399 0           return $publicKey;
13400             }
13401              
13402             package CDS::MessageBoxReader::Entry;
13403              
13404             sub new {
13405 0     0     my $class = shift;
13406 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
13407              
13408 0           return bless {
13409             hash => $hash,
13410             processed => 0,
13411             };
13412             }
13413              
13414             package CDS::MessageBoxReaderPool;
13415              
13416             sub new {
13417 0     0     my $class = shift;
13418 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
13419 0           my $publicKeyCache = shift;
13420 0           my $delegate = shift;
13421              
13422 0           return bless {
13423             keyPair => $keyPair,
13424             publicKeyCache => $publicKeyCache,
13425             delegate => $delegate,
13426             };
13427             }
13428              
13429 0     0     sub keyPair { shift->{keyPair} }
13430 0     0     sub publicKeyCache { shift->{publicKeyCache} }
13431              
13432             # Delegate
13433             # onMessageBoxVerifyStore($senderStoreUrl, $hash, $envelope, $senderHash)
13434             # onMessageBoxEntry($receivedMessage)
13435             # onMessageBoxStream($receivedMessage)
13436             # onMessageBoxInvalidEntry($source, $reason)
13437              
13438             package CDS::MessageChannel;
13439              
13440             sub new {
13441 0     0     my $class = shift;
13442 0           my $actor = shift;
13443 0           my $label = shift;
13444 0           my $validity = shift;
13445              
13446 0           my $o = bless {
13447             actor => $actor,
13448             label => $label,
13449             validity => $validity,
13450             };
13451              
13452 0           $o->{unsaved} = CDS::Unsaved->new($actor->sentList->unsaved);
13453 0           $o->{transfers} = [];
13454 0           $o->{recipients} = [];
13455 0           $o->{entrustedKeys} = [];
13456 0           $o->{obsoleteHashes} = {};
13457 0           $o->{currentSubmissionId} = 0;
13458 0           return $o;
13459             }
13460              
13461 0     0     sub actor { shift->{actor} }
13462 0     0     sub label { shift->{label} }
13463 0     0     sub validity { shift->{validity} }
13464 0     0     sub unsaved { shift->{unsaved} }
13465             sub item {
13466 0     0     my $o = shift;
13467 0           $o->{actor}->sentList->getOrCreate($o->{label}) }
13468             sub recipients {
13469 0     0     my $o = shift;
13470 0           @{$o->{recipients}} }
  0            
13471             sub entrustedKeys {
13472 0     0     my $o = shift;
13473 0           @{$o->{entrustedKeys}} }
  0            
13474              
13475             sub addObject {
13476 0     0     my $o = shift;
13477 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
13478 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
13479              
13480 0           $o->{unsaved}->state->addObject($hash, $object);
13481             }
13482              
13483             sub addTransfer {
13484 0     0     my $o = shift;
13485 0           my $hashes = shift;
13486 0           my $sourceStore = shift;
13487 0           my $context = shift;
13488              
13489 0 0         return if ! scalar @$hashes;
13490 0           push @{$o->{transfers}}, {hashes => $hashes, sourceStore => $sourceStore, context => $context};
  0            
13491             }
13492              
13493             sub setRecipientActorGroup {
13494 0     0     my $o = shift;
13495 0 0 0       my $actorGroup = shift; die 'wrong type '.ref($actorGroup).' for $actorGroup' if defined $actorGroup && ref $actorGroup ne 'CDS::ActorGroup';
  0            
13496              
13497 0           $o->{recipients} = [map { $_->actorOnStore } $actorGroup->members];
  0            
13498 0           $o->{entrustedKeys} = [map { $_->actorOnStore->publicKey } $actorGroup->entrustedActors];
  0            
13499             }
13500              
13501             sub setRecipients {
13502 0     0     my $o = shift;
13503 0           my $recipients = shift;
13504 0           my $entrustedKeys = shift;
13505              
13506 0           $o->{recipients} = $recipients;
13507 0           $o->{entrustedKeys} = $entrustedKeys;
13508             }
13509              
13510             sub submit {
13511 0     0     my $o = shift;
13512 0           my $message = shift;
13513 0           my $done = shift;
13514              
13515             # Check if the sent list has been loaded
13516 0 0         return if ! $o->{actor}->sentListReady;
13517              
13518             # Transfer
13519 0           my $transfers = $o->{transfers};
13520 0           $o->{transfers} = [];
13521 0           for my $transfer (@$transfers) {
13522 0           my ($missingObject, $store, $error) = $o->{actor}->keyPair->transfer($transfer->{hashes}, $transfer->{sourceStore}, $o->{actor}->messagingPrivateRoot->unsaved);
13523 0 0         return if defined $error;
13524              
13525 0 0         if ($missingObject) {
13526 0           $missingObject->{context} = $transfer->{context};
13527 0           return undef, $missingObject;
13528             }
13529             }
13530              
13531             # Send the message
13532 0           return CDS::MessageChannel::Submission->new($o, $message, $done);
13533             }
13534              
13535             sub clear {
13536 0     0     my $o = shift;
13537              
13538 0           $o->item->clear(CDS->now + $o->{validity});
13539             }
13540              
13541             package CDS::MessageChannel::Submission;
13542              
13543             sub new {
13544 0     0     my $class = shift;
13545 0           my $channel = shift;
13546 0           my $message = shift;
13547 0           my $done = shift;
13548              
13549 0           $channel->{currentSubmissionId} += 1;
13550              
13551             my $o = bless {
13552             channel => $channel,
13553             message => $message,
13554             done => $done,
13555             submissionId => $channel->{currentSubmissionId},
13556 0           recipients => [$channel->recipients],
13557             entrustedKeys => [$channel->entrustedKeys],
13558             expires => CDS->now + $channel->validity,
13559             };
13560              
13561             # Add the current envelope hash to the obsolete hashes
13562 0           my $item = $channel->item;
13563 0 0         $channel->{obsoleteHashes}->{$item->envelopeHash->bytes} = $item->envelopeHash if $item->envelopeHash;
13564 0           $o->{obsoleteHashesSnapshot} = [values %{$channel->{obsoleteHashes}}];
  0            
13565              
13566             # Create an envelope
13567 0           my $publicKeys = [];
13568 0           push @$publicKeys, $channel->{actor}->keyPair->publicKey;
13569 0           push @$publicKeys, map { $_->publicKey } @{$o->{recipients}};
  0            
  0            
13570 0           push @$publicKeys, @{$o->{entrustedKeys}};
  0            
13571 0           $o->{envelopeObject} = $channel->{actor}->keyPair->createMessageEnvelope($channel->{actor}->messagingStoreUrl, $message, $publicKeys, $o->{expires})->toObject;
13572 0           $o->{envelopeHash} = $o->{envelopeObject}->calculateHash;
13573              
13574             # Set the new item and wait until it gets saved
13575 0           $channel->{unsaved}->startSaving;
13576 0           $channel->{unsaved}->savingState->addDataSavedHandler($o);
13577 0           $channel->{actor}->sentList->unsaved->state->merge($channel->{unsaved}->savingState);
13578 0           $item->set($o->{expires}, $o->{envelopeHash}, $message);
13579 0           $channel->{unsaved}->savingDone;
13580              
13581 0           return $o;
13582             }
13583              
13584 0     0     sub channel { shift->{channel} }
13585 0     0     sub message { shift->{message} }
13586             sub recipients {
13587 0     0     my $o = shift;
13588 0           @{$o->{recipients}} }
  0            
13589             sub entrustedKeys {
13590 0     0     my $o = shift;
13591 0           @{$o->{entrustedKeys}} }
  0            
13592 0     0     sub expires { shift->{expires} }
13593 0     0     sub envelopeObject { shift->{envelopeObject} }
13594 0     0     sub envelopeHash { shift->{envelopeHash} }
13595              
13596             sub onDataSaved {
13597 0     0     my $o = shift;
13598              
13599             # If we are not the head any more, give up
13600 0 0         return $o->{done}->onMessageChannelSubmissionCancelled if $o->{submissionId} != $o->{channel}->{currentSubmissionId};
13601 0           $o->{channel}->{obsoleteHashes}->{$o->{envelopeHash}->bytes} = $o->{envelopeHash};
13602              
13603             # Process all recipients
13604 0           my $succeeded = 0;
13605 0           my $failed = 0;
13606 0           for my $recipient (@{$o->{recipients}}) {
  0            
13607 0           my $modifications = CDS::StoreModifications->new;
13608              
13609             # Prepare the list of removals
13610 0           my $removals = [];
13611 0           for my $hash (@{$o->{obsoleteHashesSnapshot}}) {
  0            
13612 0           $modifications->remove($recipient->publicKey->hash, 'messages', $hash);
13613             }
13614              
13615             # Add the message entry
13616 0           $modifications->add($recipient->publicKey->hash, 'messages', $o->{envelopeHash}, $o->{envelopeObject});
13617 0           my $error = $recipient->store->modify($modifications, $o->{channel}->{actor}->keyPair);
13618              
13619 0 0         if (defined $error) {
13620 0           $failed += 1;
13621 0           $o->{done}->onMessageChannelSubmissionRecipientFailed($recipient, $error);
13622             } else {
13623 0           $succeeded += 1;
13624 0           $o->{done}->onMessageChannelSubmissionRecipientDone($recipient);
13625             }
13626             }
13627              
13628 0 0 0       if ($failed == 0 || scalar keys %{$o->{obsoleteHashes}} > 64) {
  0            
13629 0           for my $hash (@{$o->{obsoleteHashesSnapshot}}) {
  0            
13630 0           delete $o->{channel}->{obsoleteHashes}->{$hash->bytes};
13631             }
13632             }
13633              
13634 0           $o->{done}->onMessageChannelSubmissionDone($succeeded, $failed);
13635             }
13636              
13637             package CDS::MissingObject;
13638              
13639             sub new {
13640 0     0     my $class = shift;
13641 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
13642 0           my $store = shift;
13643              
13644 0           return bless {hash => $hash, store => $store, path => [], context => undef};
13645             }
13646              
13647 0     0     sub hash { shift->{hash} }
13648 0     0     sub store { shift->{store} }
13649             sub path {
13650 0     0     my $o = shift;
13651 0           @{$o->{path}} }
  0            
13652 0     0     sub context { shift->{context} }
13653              
13654             package CDS::NewAnnounce;
13655              
13656             sub new {
13657 0     0     my $class = shift;
13658 0           my $messagingStore = shift;
13659              
13660 0           my $o = bless {
13661             messagingStore => $messagingStore,
13662             unsaved => CDS::Unsaved->new($messagingStore->store),
13663             transfers => [],
13664             card => CDS::Record->new,
13665             };
13666              
13667 0           my $publicKey = $messagingStore->actor->keyPair->publicKey;
13668 0           $o->{card}->add('public key')->addHash($publicKey->hash);
13669 0           $o->addObject($publicKey->hash, $publicKey->object);
13670 0           return $o;
13671             }
13672              
13673 0     0     sub messagingStore { shift->{messagingStore} }
13674 0     0     sub card { shift->{card} }
13675              
13676             sub addObject {
13677 0     0     my $o = shift;
13678 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
13679 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
13680              
13681 0           $o->{unsaved}->state->addObject($hash, $object);
13682             }
13683              
13684             sub addTransfer {
13685 0     0     my $o = shift;
13686 0           my $hashes = shift;
13687 0           my $sourceStore = shift;
13688 0           my $context = shift;
13689              
13690 0 0         return if ! scalar @$hashes;
13691 0           push @{$o->{transfers}}, {hashes => $hashes, sourceStore => $sourceStore, context => $context};
  0            
13692             }
13693              
13694             sub addActorGroup {
13695 0     0     my $o = shift;
13696 0           my $actorGroupBuilder = shift;
13697              
13698 0           $actorGroupBuilder->addToRecord($o->{card}, 0);
13699             }
13700              
13701             sub submit {
13702 0     0     my $o = shift;
13703              
13704 0           my $keyPair = $o->{messagingStore}->actor->keyPair;
13705              
13706             # Create the public card
13707 0           my $cardObject = $o->{card}->toObject;
13708 0           my $cardHash = $cardObject->calculateHash;
13709 0           $o->addObject($cardHash, $cardObject);
13710              
13711             # Prepare the public envelope
13712 0           my $me = $keyPair->publicKey->hash;
13713 0           my $envelopeObject = $keyPair->createPublicEnvelope($cardHash)->toObject;
13714 0           my $envelopeHash = $envelopeObject->calculateHash;
13715 0           $o->addTransfer([$cardHash], $o->{unsaved}, 'Announcing');
13716              
13717             # Transfer all trees
13718 0           for my $transfer (@{$o->{transfers}}) {
  0            
13719 0           my ($missingObject, $store, $error) = $keyPair->transfer($transfer->{hashes}, $transfer->{sourceStore}, $o->{messagingStore}->store);
13720 0 0         return if defined $error;
13721              
13722 0 0         if ($missingObject) {
13723 0           $missingObject->{context} = $transfer->{context};
13724 0           return undef, $missingObject;
13725             }
13726             }
13727              
13728             # Prepare a modification
13729 0           my $modifications = CDS::StoreModifications->new;
13730 0           $modifications->add($me, 'public', $envelopeHash, $envelopeObject);
13731              
13732             # List the current cards to remove them
13733             # Ignore errors, in the worst case, we are going to have multiple entries in the public box
13734 0           my ($hashes, $error) = $o->{messagingStore}->store->list($me, 'public', 0, $keyPair);
13735 0 0         if ($hashes) {
13736 0           for my $hash (@$hashes) {
13737 0           $modifications->remove($me, 'public', $hash);
13738             }
13739             }
13740              
13741             # Modify the public box
13742 0           my $modifyError = $o->{messagingStore}->store->modify($modifications, $keyPair);
13743 0 0         return if defined $modifyError;
13744 0           return $envelopeHash, $cardHash;
13745             }
13746              
13747             package CDS::NewMessagingStore;
13748              
13749             sub new {
13750 0     0     my $class = shift;
13751 0           my $actor = shift;
13752 0           my $store = shift;
13753              
13754 0           return bless {
13755             actor => $actor,
13756             store => $store,
13757             };
13758             }
13759              
13760 0     0     sub actor { shift->{actor} }
13761 0     0     sub store { shift->{store} }
13762              
13763             # A Condensation object.
13764             # 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.
13765             package CDS::Object;
13766              
13767 0     0     sub emptyHeader { "\0\0\0\0" }
13768              
13769             sub create {
13770 0     0     my $class = shift;
13771 0           my $header = shift;
13772 0           my $data = shift;
13773              
13774 0 0         return if length $header < 4;
13775 0           my $hashesCount = unpack('L>', substr($header, 0, 4));
13776 0 0         return if length $header != 4 + $hashesCount * 32;
13777 0           return bless {
13778             bytes => $header.$data,
13779             hashesCount => $hashesCount,
13780             header => $header,
13781             data => $data
13782             };
13783             }
13784              
13785             sub fromBytes {
13786 0     0     my $class = shift;
13787 0   0       my $bytes = shift // return;
13788              
13789 0 0         return if length $bytes < 4;
13790              
13791 0           my $hashesCount = unpack 'L>', substr($bytes, 0, 4);
13792 0           my $dataStart = $hashesCount * 32 + 4;
13793 0 0         return if $dataStart > length $bytes;
13794              
13795 0           return bless {
13796             bytes => $bytes,
13797             hashesCount => $hashesCount,
13798             header => substr($bytes, 0, $dataStart),
13799             data => substr($bytes, $dataStart)
13800             };
13801             }
13802              
13803             sub fromFile {
13804 0     0     my $class = shift;
13805 0           my $file = shift;
13806              
13807 0           return $class->fromBytes(CDS->readBytesFromFile($file));
13808             }
13809              
13810 0     0     sub bytes { shift->{bytes} }
13811 0     0     sub header { shift->{header} }
13812 0     0     sub data { shift->{data} }
13813 0     0     sub hashesCount { shift->{hashesCount} }
13814             sub byteLength {
13815 0     0     my $o = shift;
13816 0           length($o->{header}) + length($o->{data}) }
13817              
13818             sub calculateHash {
13819 0     0     my $o = shift;
13820              
13821 0           return CDS::Hash->calculateFor($o->{bytes});
13822             }
13823              
13824             sub hashes {
13825 0     0     my $o = shift;
13826              
13827 0           return map { CDS::Hash->fromBytes(substr($o->{header}, $_ * 32 + 4, 32)) } 0 .. $o->{hashesCount} - 1;
  0            
13828             }
13829              
13830             sub hashAtIndex {
13831 0     0     my $o = shift;
13832 0   0       my $index = shift // return;
13833              
13834 0 0 0       return if $index < 0 || $index >= $o->{hashesCount};
13835 0           return CDS::Hash->fromBytes(substr($o->{header}, $index * 32 + 4, 32));
13836             }
13837              
13838             sub crypt {
13839 0     0     my $o = shift;
13840 0           my $key = shift;
13841              
13842 0           return CDS::Object->create($o->{header}, CDS::C::aesCrypt($o->{data}, $key, CDS->zeroCTR));
13843             }
13844              
13845             sub writeToFile {
13846 0     0     my $o = shift;
13847 0           my $file = shift;
13848              
13849 0           return CDS->writeBytesToFile($file, $o->{bytes});
13850             }
13851              
13852             # A store using a cache store to deliver frequently accessed objects faster, and a backend store.
13853             package CDS::ObjectCache;
13854              
13855 1     1   6382 use parent -norequire, 'CDS::Store';
  1         3  
  1         5  
13856              
13857             sub new {
13858 0     0     my $class = shift;
13859 0           my $backend = shift;
13860 0           my $cache = shift;
13861              
13862 0           return bless {
13863             id => "Object Cache\n".$backend->id."\n".$cache->id,
13864             backend => $backend,
13865             cache => $cache,
13866             };
13867             }
13868              
13869 0     0     sub id { shift->{id} }
13870 0     0     sub backend { shift->{backend} }
13871 0     0     sub cache { shift->{cache} }
13872              
13873             sub get {
13874 0     0     my $o = shift;
13875 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
13876 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
13877              
13878 0           my $objectFromCache = $o->{cache}->get($hash);
13879 0 0         return $objectFromCache if $objectFromCache;
13880              
13881 0           my ($object, $error) = $o->{backend}->get($hash, $keyPair);
13882 0 0         return undef, $error if ! defined $object;
13883 0           $o->{cache}->put($hash, $object, undef);
13884 0           return $object;
13885             }
13886              
13887             sub put {
13888 0     0     my $o = shift;
13889              
13890             # The important thing is that the backend succeeds. The cache is a nice-to-have.
13891 0           $o->{cache}->put(@_);
13892 0           return $o->{backend}->put(@_);
13893             }
13894              
13895             sub book {
13896 0     0     my $o = shift;
13897              
13898             # The important thing is that the backend succeeds. The cache is a nice-to-have.
13899 0           $o->{cache}->book(@_);
13900 0           return $o->{backend}->book(@_);
13901             }
13902              
13903             sub list {
13904 0     0     my $o = shift;
13905              
13906             # Just pass this through to the backend.
13907 0           return $o->{backend}->list(@_);
13908             }
13909              
13910             sub add {
13911 0     0     my $o = shift;
13912              
13913             # Just pass this through to the backend.
13914 0           return $o->{backend}->add(@_);
13915             }
13916              
13917             sub remove {
13918 0     0     my $o = shift;
13919              
13920             # Just pass this through to the backend.
13921 0           return $o->{backend}->remove(@_);
13922             }
13923              
13924             sub modify {
13925 0     0     my $o = shift;
13926              
13927             # Just pass this through to the backend.
13928 0           return $o->{backend}->modify(@_);
13929             }
13930              
13931             # The result of parsing an OBJECTFILE token (see Token.pm).
13932             package CDS::ObjectFileToken;
13933              
13934             sub new {
13935 0     0     my $class = shift;
13936 0           my $file = shift;
13937 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
13938              
13939 0           return bless {
13940             file => $file,
13941             object => $object,
13942             };
13943             }
13944              
13945 0     0     sub file { shift->{file} }
13946 0     0     sub object { shift->{object} }
13947              
13948             # The result of parsing an OBJECT token.
13949             package CDS::ObjectToken;
13950              
13951             sub new {
13952 0     0     my $class = shift;
13953 0           my $cliStore = shift;
13954 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
13955              
13956 0           return bless {
13957             cliStore => $cliStore,
13958             hash => $hash,
13959             };
13960             }
13961              
13962 0     0     sub cliStore { shift->{cliStore} }
13963 0     0     sub hash { shift->{hash} }
13964             sub url {
13965 0     0     my $o = shift;
13966 0           $o->{cliStore}->url.'/objects/'.$o->{hash}->hex }
13967              
13968             package CDS::Parser;
13969              
13970             sub new {
13971 0     0     my $class = shift;
13972 0           my $actor = shift;
13973 0           my $command = shift;
13974              
13975 0           my $start = CDS::Parser::Node->new(0);
13976 0           return bless {
13977             actor => $actor,
13978             ui => $actor->ui,
13979             start => $start,
13980             states => [CDS::Parser::State->new($start)],
13981             command => $command,
13982             };
13983             }
13984              
13985 0     0     sub actor { shift->{actor} }
13986 0     0     sub start { shift->{start} }
13987              
13988             sub execute {
13989 0     0     my $o = shift;
13990              
13991 0           my $processed = [$o->{command}];
13992 0           for my $arg (@_) {
13993 0 0         return $o->howToContinue($processed) if $arg eq '?';
13994 0 0         return $o->explain if $arg eq '??';
13995 0           my $token = CDS::Parser::Token->new($o->{actor}, $arg);
13996 0           $o->advance($token);
13997 0 0         return $o->invalid($processed, $token) if ! scalar @{$o->{states}};
  0            
13998 0           push @$processed, $arg;
13999             }
14000              
14001 0           my @results = grep { $_->runHandler } @{$o->{states}};
  0            
  0            
14002 0 0         return $o->howToContinue($processed) if ! scalar @results;
14003              
14004 0           my $maxWeight = 0;
14005 0           for my $result (@results) {
14006 0 0         $maxWeight = $result->cumulativeWeight if $maxWeight < $result->cumulativeWeight;
14007             }
14008              
14009 0           @results = grep { $_->cumulativeWeight == $maxWeight } @results;
  0            
14010 0 0         return $o->ambiguous if scalar @results > 1;
14011              
14012 0           my $result = shift @results;
14013 0           my $handler = $result->runHandler;
14014 0           my $instance = &{$handler->{constructor}}(undef, $o->{actor});
  0            
14015 0           &{$handler->{function}}($instance, $result);
  0            
14016             }
14017              
14018             sub advance {
14019 0     0     my $o = shift;
14020 0           my $token = shift;
14021              
14022 0           $o->{previousStates} = $o->{states};
14023 0           $o->{states} = [];
14024 0           for my $state (@{$o->{previousStates}}) {
  0            
14025 0           push @{$o->{states}}, $state->advance($token);
  0            
14026             }
14027             }
14028              
14029             sub showCompletions {
14030 0     0     my $o = shift;
14031 0           my $cmd = shift;
14032              
14033             # Parse the command line
14034 0           my $state = '';
14035 0           my $arg = '';
14036 0           my @args;
14037 0           for my $c (split //, $cmd) {
14038 0 0         if ($state eq '') {
    0          
    0          
    0          
    0          
14039 0 0         if ($c eq ' ') {
    0          
    0          
    0          
14040 0 0         push @args, $arg if length $arg;
14041 0           $arg = '';
14042             } elsif ($c eq '\'') {
14043 0 0         push @args, $arg if length $arg;
14044 0           $arg = '';
14045 0           $state = '\'';
14046             } elsif ($c eq '"') {
14047 0 0         push @args, $arg if length $arg;
14048 0           $arg = '';
14049 0           $state = '"';
14050             } elsif ($c eq '\\') {
14051 0           $state = '\\';
14052             } else {
14053 0           $arg .= $c;
14054             }
14055             } elsif ($state eq '\\') {
14056 0           $arg .= $c;
14057 0           $state = '';
14058             } elsif ($state eq '\'') {
14059 0 0         if ($c eq '\'') {
14060 0 0         push @args, $arg if length $arg;
14061 0           $arg = '';
14062 0           $state = '';
14063             } else {
14064 0           $arg .= $c;
14065             }
14066             } elsif ($state eq '"') {
14067 0 0         if ($c eq '"') {
    0          
14068 0 0         push @args, $arg if length $arg;
14069 0           $arg = '';
14070 0           $state = '';
14071             } elsif ($c eq '\\') {
14072 0           $state = '"\\';
14073             } else {
14074 0           $arg .= $c;
14075             }
14076             } elsif ($state eq '\\"') {
14077 0           $arg .= $c;
14078 0           $state = '"';
14079             }
14080             }
14081              
14082             # Use the last token to complete
14083 0           my $lastToken = CDS::Parser::Token->new($o->{actor}, $arg);
14084              
14085             # Look for possible states
14086 0           shift @args;
14087 0           for my $arg (@args) {
14088 0 0         return if $arg eq '?';
14089 0           $o->advance(CDS::Parser::Token->new($o->{actor}, $arg));
14090             }
14091              
14092             # Complete the last token
14093 0           my %possibilities;
14094 0           for my $state (@{$o->{states}}) {
  0            
14095 0           for my $possibility ($state->complete($lastToken)) {
14096 0           $possibilities{$possibility} = 1;
14097             }
14098             }
14099              
14100             # Print all possibilities
14101 0           for my $possibility (keys %possibilities) {
14102 0           print $possibility, "\n";
14103             }
14104             }
14105              
14106             sub ambiguous {
14107 0     0     my $o = shift;
14108              
14109 0           $o->{ui}->space;
14110 0           $o->{ui}->pRed('Your query is ambiguous. This is an error in the command grammar.');
14111 0           $o->explain;
14112             }
14113              
14114             sub explain {
14115 0     0     my $o = shift;
14116              
14117 0 0         for my $interpretation (sort { $b->cumulativeWeight <=> $a->cumulativeWeight || $b->isExecutable <=> $a->isExecutable } @{$o->{states}}) {
  0            
  0            
14118 0           $o->{ui}->space;
14119 0 0         $o->{ui}->title('Interpretation with weight ', $interpretation->cumulativeWeight, $interpretation->isExecutable ? $o->{ui}->green(' (executable)') : $o->{ui}->orange(' (incomplete)'));
14120 0           $o->showTuples($interpretation->path);
14121             }
14122              
14123 0           $o->{ui}->space;
14124             }
14125              
14126             sub showTuples {
14127 0     0     my $o = shift;
14128              
14129 0           for my $state (@_) {
14130 0           my $label = $state->label;
14131 0           my $value = $state->value;
14132              
14133 0           my $valueRef = ref $value;
14134 0 0 0       my $valueText =
    0          
    0          
    0          
14135             $valueRef eq '' ? $value // '' :
14136             $valueRef eq 'CDS::Hash' ? $value->hex :
14137             $valueRef eq 'CDS::ErrorHandlingStore' ? $value->url :
14138             $valueRef eq 'CDS::AccountToken' ? $value->actorHash->hex . ' on ' . $value->cliStore->url :
14139             $valueRef;
14140 0 0         $o->{ui}->line($o->{ui}->left(12, $label), $state->collectHandler ? $valueText : $o->{ui}->gray($valueText));
14141             }
14142             }
14143              
14144             sub cmd {
14145 0     0     my $o = shift;
14146 0           my $processed = shift;
14147              
14148 0           my $cmd = join(' ', map { $_ =~ s/(\\|'|")/\\$1/g ; $_ } @$processed);
  0            
  0            
14149 0 0         $cmd = '…'.substr($cmd, length($cmd) - 20, 20) if length $cmd > 30;
14150 0           return $cmd;
14151             }
14152              
14153             sub howToContinue {
14154 0     0     my $o = shift;
14155 0           my $processed = shift;
14156              
14157 0           my $cmd = $o->cmd($processed);
14158             #$o->displayWarnings($o->{states});
14159 0           $o->{ui}->space;
14160 0           for my $possibility (CDS::Parser::Continuations->collect($o->{states})) {
14161 0           $o->{ui}->line($o->{ui}->gray($cmd), $possibility);
14162             }
14163 0           $o->{ui}->space;
14164             }
14165              
14166             sub invalid {
14167 0     0     my $o = shift;
14168 0           my $processed = shift;
14169 0           my $invalid = shift;
14170              
14171 0           my $cmd = $o->cmd($processed);
14172 0           $o->displayWarnings($o->{previousStates});
14173 0           $o->{ui}->space;
14174              
14175 0           $o->{ui}->line($o->{ui}->gray($cmd), ' ', $o->{ui}->red($invalid->{text}));
14176 0 0         if (scalar @{$invalid->{warnings}}) {
  0            
14177 0           for my $warning (@{$invalid->{warnings}}) {
  0            
14178 0           $o->{ui}->warning($warning);
14179             }
14180             }
14181              
14182 0           $o->{ui}->space;
14183 0           $o->{ui}->title('Possible continuations');
14184 0           for my $possibility (CDS::Parser::Continuations->collect($o->{previousStates})) {
14185 0           $o->{ui}->line($o->{ui}->gray($cmd), $possibility);
14186             }
14187 0           $o->{ui}->space;
14188             }
14189              
14190             sub displayWarnings {
14191 0     0     my $o = shift;
14192 0           my $states = shift;
14193              
14194 0           for my $state (@$states) {
14195 0           my $current = $state;
14196 0           while ($current) {
14197 0           for my $warning (@{$current->{warnings}}) {
  0            
14198 0           $o->{ui}->warning($warning);
14199             }
14200 0           $current = $current->{previous};
14201             }
14202             }
14203             }
14204              
14205             # An arrow points from one node to another. The arrow is taken in State::advance if the next argument matches to the label.
14206             package CDS::Parser::Arrow;
14207              
14208             sub new {
14209 0     0     my $class = shift;
14210 0           my $node = shift;
14211 0           my $official = shift;
14212 0           my $weight = shift;
14213 0           my $label = shift;
14214 0           my $handler = shift;
14215              
14216 0           return bless {
14217             node => $node, # target node
14218             official => $official, # whether to show this arrow with '?'
14219             weight => $weight, # weight
14220             label => $label, # label
14221             handler => $handler, # handler to invoke if we take this arrow
14222             };
14223             }
14224              
14225             package CDS::Parser::Continuations;
14226              
14227             sub collect {
14228 0     0     my $class = shift;
14229 0           my $states = shift;
14230              
14231 0           my $o = bless {possibilities => {}};
14232              
14233 0           my $visitedNodes = {};
14234 0           for my $state (@$states) {
14235 0           $o->visit($visitedNodes, $state->node, '');
14236             }
14237              
14238 0           for my $possibility (keys %{$o->{possibilities}}) {
  0            
14239 0 0         delete $o->{possibilities}->{$possibility} if exists $o->{possibilities}->{$possibility.' …'};
14240             }
14241              
14242 0           return sort keys %{$o->{possibilities}};
  0            
14243             }
14244              
14245             sub visit {
14246 0     0     my $o = shift;
14247 0           my $visitedNodes = shift;
14248 0           my $node = shift;
14249 0           my $text = shift;
14250              
14251 0           $visitedNodes->{$node} = 1;
14252              
14253 0           my $arrows = [];
14254 0           $node->collectArrows($arrows);
14255              
14256 0           for my $arrow (@$arrows) {
14257 0 0         next if ! $arrow->{official};
14258              
14259 0           my $text = $text.' '.$arrow->{label};
14260 0 0         $o->{possibilities}->{$text} = 1 if $arrow->{node}->hasHandler;
14261 0 0 0       if ($arrow->{node}->endProposals || exists $visitedNodes->{$arrow->{node}}) {
14262 0 0         $o->{possibilities}->{$text . ($o->canContinue($arrow->{node}) ? ' …' : '')} = 1;
14263 0           next;
14264             }
14265              
14266 0           $o->visit($visitedNodes, $arrow->{node}, $text);
14267             }
14268              
14269 0           delete $visitedNodes->{$node};
14270             }
14271              
14272             sub canContinue {
14273 0     0     my $o = shift;
14274 0           my $node = shift;
14275              
14276 0           my $arrows = [];
14277 0           $node->collectArrows($arrows);
14278              
14279 0           for my $arrow (@$arrows) {
14280 0 0         next if ! $arrow->{official};
14281 0           return 1;
14282             }
14283              
14284 0           return;
14285             }
14286              
14287             # Nodes and arrows define the graph on which the parse state can move.
14288             package CDS::Parser::Node;
14289              
14290             sub new {
14291 0     0     my $class = shift;
14292 0           my $endProposals = shift;
14293 0           my $handler = shift;
14294              
14295 0           return bless {
14296             arrows => [], # outgoing arrows
14297             defaults => [], # default nodes, at which the current state could be as well
14298             endProposals => $endProposals, # if set, the proposal search algorithm stops at this node
14299             handler => $handler, # handler to be executed if parsing ends here
14300             };
14301             }
14302              
14303 0     0     sub endProposals { shift->{endProposals} }
14304              
14305             # Adds an arrow.
14306             sub addArrow {
14307 0     0     my $o = shift;
14308 0           my $to = shift;
14309 0           my $official = shift;
14310 0           my $weight = shift;
14311 0           my $label = shift;
14312 0           my $handler = shift;
14313              
14314 0           push @{$o->{arrows}}, CDS::Parser::Arrow->new($to, $official, $weight, $label, $handler);
  0            
14315             }
14316              
14317             # Adds a default node.
14318             sub addDefault {
14319 0     0     my $o = shift;
14320 0           my $node = shift;
14321              
14322 0           push @{$o->{defaults}}, $node;
  0            
14323             }
14324              
14325             sub collectArrows {
14326 0     0     my $o = shift;
14327 0           my $arrows = shift;
14328              
14329 0           push @$arrows, @{$o->{arrows}};
  0            
14330 0           for my $default (@{$o->{defaults}}) { $default->collectArrows($arrows); }
  0            
  0            
14331             }
14332              
14333             sub hasHandler {
14334 0     0     my $o = shift;
14335              
14336 0 0         return 1 if $o->{handler};
14337 0 0         for my $default (@{$o->{defaults}}) { return 1 if $default->hasHandler; }
  0            
  0            
14338 0           return;
14339             }
14340              
14341             sub getHandler {
14342 0     0     my $o = shift;
14343              
14344 0 0         return $o->{handler} if $o->{handler};
14345 0           for my $default (@{$o->{defaults}}) {
  0            
14346 0   0       my $handler = $default->getHandler // next;
14347 0           return $handler;
14348             }
14349 0           return;
14350             }
14351              
14352             # A parser state denotes a possible current state (after having parsed a certain number of arguments).
14353             # A parser keeps track of multiple states. When advancing, a state may disappear (if no possibility exists), or fan out (if multiple possibilities exist).
14354             # A state is immutable.
14355             package CDS::Parser::State;
14356              
14357             sub new {
14358 0     0     my $class = shift;
14359 0           my $node = shift;
14360 0           my $previous = shift;
14361 0           my $arrow = shift;
14362 0           my $value = shift;
14363 0           my $warnings = shift;
14364              
14365             return bless {
14366             node => $node, # current node
14367             previous => $previous, # previous state
14368             arrow => $arrow, # the arrow we took to get here
14369             value => $value, # the value we collected with the last arrow
14370             warnings => $warnings, # the warnings we collected with the last arrow
14371 0 0         cumulativeWeight => ($previous ? $previous->cumulativeWeight : 0) + ($arrow ? $arrow->{weight} : 0), # the weight we collected until here
    0          
14372             };
14373             }
14374              
14375 0     0     sub node { shift->{node} }
14376             sub runHandler {
14377 0     0     my $o = shift;
14378 0           $o->{node}->getHandler }
14379             sub isExecutable {
14380 0     0     my $o = shift;
14381 0 0         $o->{node}->getHandler ? 1 : 0 }
14382             sub collectHandler {
14383 0     0     my $o = shift;
14384 0 0         $o->{arrow} ? $o->{arrow}->{handler} : undef }
14385             sub label {
14386 0     0     my $o = shift;
14387 0 0         $o->{arrow} ? $o->{arrow}->{label} : 'cds' }
14388 0     0     sub value { shift->{value} }
14389 0     0     sub arrow { shift->{arrow} }
14390 0     0     sub cumulativeWeight { shift->{cumulativeWeight} }
14391              
14392             sub advance {
14393 0     0     my $o = shift;
14394 0           my $token = shift;
14395              
14396 0           my $arrows = [];
14397 0           $o->{node}->collectArrows($arrows);
14398              
14399             # Let the token know what possibilities we have
14400 0           for my $arrow (@$arrows) {
14401 0           $token->prepare($arrow->{label});
14402             }
14403              
14404             # Ask the token to interpret the text
14405 0           my @states;
14406 0           for my $arrow (@$arrows) {
14407 0   0       my $value = $token->as($arrow->{label}) // next;
14408 0           push @states, CDS::Parser::State->new($arrow->{node}, $o, $arrow, $value, $token->{warnings});
14409             }
14410              
14411 0           return @states;
14412             }
14413              
14414             sub complete {
14415 0     0     my $o = shift;
14416 0           my $token = shift;
14417              
14418 0           my $arrows = [];
14419 0           $o->{node}->collectArrows($arrows);
14420              
14421             # Let the token know what possibilities we have
14422 0           for my $arrow (@$arrows) {
14423 0 0         next if ! $arrow->{official};
14424 0           $token->prepare($arrow->{label});
14425             }
14426              
14427             # Ask the token to interpret the text
14428 0           for my $arrow (@$arrows) {
14429 0 0         next if ! $arrow->{official};
14430 0           $token->complete($arrow->{label});
14431             }
14432              
14433 0           return @{$token->{possibilities}};
  0            
14434             }
14435              
14436             sub arrows {
14437 0     0     my $o = shift;
14438              
14439 0           my $arrows = [];
14440 0           $o->{node}->collectArrows($arrows);
14441 0           return @$arrows;
14442             }
14443              
14444             sub path {
14445 0     0     my $o = shift;
14446              
14447 0           my @path;
14448 0           my $state = $o;
14449 0           while ($state) {
14450 0           unshift @path, $state;
14451 0           $state = $state->{previous};
14452             }
14453 0           return @path;
14454             }
14455              
14456             sub collect {
14457 0     0     my $o = shift;
14458 0           my $data = shift;
14459              
14460 0           for my $state ($o->path) {
14461 0   0       my $collectHandler = $state->collectHandler // next;
14462 0           &$collectHandler($data, $state->label, $state->value);
14463             }
14464             }
14465              
14466             package CDS::Parser::Token;
14467              
14468             sub new {
14469 0     0     my $class = shift;
14470 0           my $actor = shift;
14471 0           my $text = shift;
14472              
14473 0           return bless {
14474             actor => $actor,
14475             text => $text,
14476             keywords => {},
14477             cache => {},
14478             warnings => [],
14479             possibilities => [],
14480             };
14481             }
14482              
14483             sub prepare {
14484 0     0     my $o = shift;
14485 0           my $expect = shift;
14486              
14487 0 0         $o->{keywords}->{$expect} = 1 if $expect =~ /^[a-z0-9]*$/;
14488             }
14489              
14490             sub as {
14491 0     0     my $o = shift;
14492 0           my $expect = shift;
14493 0 0         exists $o->{cache}->{$expect} ? $o->{cache}->{$expect} : $o->{cache}->{$expect} = $o->produce($expect) }
14494              
14495             sub produce {
14496 0     0     my $o = shift;
14497 0           my $expect = shift;
14498              
14499 0 0         return $o->account if $expect eq 'ACCOUNT';
14500 0 0         return $o->hash if $expect eq 'ACTOR';
14501 0 0         return $o->actorGroup if $expect eq 'ACTORGROUP';
14502 0 0         return $o->aesKey if $expect eq 'AESKEY';
14503 0 0         return $o->box if $expect eq 'BOX';
14504 0 0         return $o->boxLabel if $expect eq 'BOXLABEL';
14505 0 0         return $o->file if $expect eq 'FILE';
14506 0 0         return $o->filename if $expect eq 'FILENAME';
14507 0 0         return $o->folder if $expect eq 'FOLDER';
14508 0 0         return $o->foldername if $expect eq 'FOLDERNAME';
14509 0 0         return $o->group if $expect eq 'GROUP';
14510 0 0         return $o->hash if $expect eq 'HASH';
14511 0 0         return $o->keyPair if $expect eq 'KEYPAIR';
14512 0 0         return $o->label if $expect eq 'LABEL';
14513 0 0         return $o->object if $expect eq 'OBJECT';
14514 0 0         return $o->objectFile if $expect eq 'OBJECTFILE';
14515 0 0         return $o->port if $expect eq 'PORT';
14516 0 0         return $o->store if $expect eq 'STORE';
14517 0 0         return $o->text if $expect eq 'TEXT';
14518 0 0         return $o->user if $expect eq 'USER';
14519 0 0         return $o->{text} eq $expect ? '' : undef;
14520             }
14521              
14522             sub complete {
14523 0     0     my $o = shift;
14524 0           my $expect = shift;
14525              
14526 0 0         return $o->completeAccount if $expect eq 'ACCOUNT';
14527 0 0         return $o->completeHash if $expect eq 'ACTOR';
14528 0 0         return $o->completeActorGroup if $expect eq 'ACTORGROUP';
14529 0 0         return if $expect eq 'AESKEY';
14530 0 0         return $o->completeBox if $expect eq 'BOX';
14531 0 0         return $o->completeBoxLabel if $expect eq 'BOXLABEL';
14532 0 0         return $o->completeFile if $expect eq 'FILE';
14533 0 0         return $o->completeFile if $expect eq 'FILENAME';
14534 0 0         return $o->completeFolder if $expect eq 'FOLDER';
14535 0 0         return $o->completeFolder if $expect eq 'FOLDERNAME';
14536 0 0         return $o->completeGroup if $expect eq 'GROUP';
14537 0 0         return $o->completeHash if $expect eq 'HASH';
14538 0 0         return $o->completeKeyPair if $expect eq 'KEYPAIR';
14539 0 0         return $o->completeLabel if $expect eq 'LABEL';
14540 0 0         return $o->completeObject if $expect eq 'OBJECT';
14541 0 0         return $o->completeObjectFile if $expect eq 'OBJECTFILE';
14542 0 0         return $o->completeStoreUrl if $expect eq 'STORE';
14543 0 0         return $o->completeUser if $expect eq 'USER';
14544 0 0         return if $expect eq 'TEXT';
14545 0           $o->addPossibility($expect);
14546             }
14547              
14548             sub addPossibility {
14549 0     0     my $o = shift;
14550 0           my $possibility = shift;
14551              
14552 0 0         push @{$o->{possibilities}}, $possibility.' ' if substr($possibility, 0, length $o->{text}) eq $o->{text};
  0            
14553             }
14554              
14555             sub addPartialPossibility {
14556 0     0     my $o = shift;
14557 0           my $possibility = shift;
14558              
14559 0 0         push @{$o->{possibilities}}, $possibility if substr($possibility, 0, length $o->{text}) eq $o->{text};
  0            
14560             }
14561              
14562             sub isKeyword {
14563 0     0     my $o = shift;
14564 0           exists $o->{keywords}->{$o->{text}} }
14565              
14566             sub account {
14567 0     0     my $o = shift;
14568              
14569             # From a remembered account
14570 0           my $record = $o->{actor}->remembered($o->{text});
14571 0           my $storeUrl = $record->child('store')->textValue;
14572 0           my $actorHash = CDS::Hash->fromBytes($record->child('actor')->bytesValue);
14573 0 0 0       if ($actorHash && length $storeUrl) {
14574 0   0       my $store = $o->{actor}->storeForUrl($storeUrl) // return $o->warning('Invalid store URL "', $storeUrl, '" in remembered account.');
14575 0           my $accountToken = CDS::AccountToken->new($store, $actorHash);
14576 0 0         return $o->warning('"', $o->{text}, '" is interpreted as a keyword. If you mean the account, write "', $accountToken->url, '".') if $o->isKeyword;
14577 0           return $accountToken;
14578             }
14579              
14580             # From a URL
14581 0 0         if ($o->{text} =~ /^\s*(.*?)\/accounts\/([0-9a-fA-F]{64,64})\/*\s*$/) {
14582 0           my $storeUrl = $1;
14583 0           my $actorHash = CDS::Hash->fromHex($2);
14584 0 0 0       $storeUrl = 'file://'.Cwd::abs_path($storeUrl) if $storeUrl !~ /^[a-zA-Z0-9_\+-]*:/ && -d $storeUrl;
14585 0   0       my $cliStore = $o->{actor}->storeForUrl($storeUrl) // return $o->warning('Invalid store URL "', $storeUrl, '".');
14586 0           return CDS::AccountToken->new($cliStore, $actorHash);
14587             }
14588              
14589 0           return;
14590             }
14591              
14592             sub completeAccount {
14593 0     0     my $o = shift;
14594              
14595 0           $o->completeUrl;
14596              
14597 0           my $records = $o->{actor}->rememberedRecords;
14598 0           for my $label (keys %$records) {
14599 0           my $record = $records->{$label};
14600 0           my $storeUrl = $record->child('store')->textValue;
14601 0 0         next if ! length $storeUrl;
14602 0   0       my $actorHash = CDS::Hash->fromBytes($record->child('actor')->bytesValue) // next;
14603              
14604 0           $o->addPossibility($label);
14605 0           $o->addPossibility($storeUrl.'/accounts/'.$actorHash->hex);
14606             }
14607              
14608 0           return;
14609             }
14610              
14611             sub aesKey {
14612 0     0     my $o = shift;
14613              
14614 0 0         $o->{text} =~ /^[0-9A-Fa-f]{64}$/ || return;
14615 0           return pack('H*', $o->{text});
14616             }
14617              
14618             sub box {
14619 0     0     my $o = shift;
14620              
14621             # From a URL
14622 0 0         if ($o->{text} =~ /^\s*(.*?)\/accounts\/([0-9a-fA-F]{64,64})\/(messages|private|public)\/*\s*$/) {
14623 0           my $storeUrl = $1;
14624 0           my $boxLabel = $3;
14625 0           my $actorHash = CDS::Hash->fromHex($2);
14626 0 0 0       $storeUrl = 'file://'.Cwd::abs_path($storeUrl) if $storeUrl !~ /^[a-zA-Z0-9_\+-]*:/ && -d $storeUrl;
14627 0   0       my $cliStore = $o->{actor}->storeForUrl($storeUrl) // return $o->warning('Invalid store URL "', $storeUrl, '".');
14628 0           my $accountToken = CDS::AccountToken->new($cliStore, $actorHash);
14629 0           return CDS::BoxToken->new($accountToken, $boxLabel);
14630             }
14631              
14632 0           return;
14633             }
14634              
14635             sub completeBox {
14636 0     0     my $o = shift;
14637              
14638 0           $o->completeUrl;
14639 0           return;
14640             }
14641              
14642             sub boxLabel {
14643 0     0     my $o = shift;
14644              
14645 0 0         return $o->{text} if $o->{text} eq 'messages';
14646 0 0         return $o->{text} if $o->{text} eq 'private';
14647 0 0         return $o->{text} if $o->{text} eq 'public';
14648 0           return;
14649             }
14650              
14651             sub completeBoxLabel {
14652 0     0     my $o = shift;
14653              
14654 0           $o->addPossibility('messages');
14655 0           $o->addPossibility('private');
14656 0           $o->addPossibility('public');
14657             }
14658              
14659             sub file {
14660 0     0     my $o = shift;
14661              
14662 0   0       my $file = Cwd::abs_path($o->{text}) // return;
14663 0 0         return if ! -f $file;
14664 0 0         return $o->warning('"', $o->{text}, '" is interpreted as keyword. If you mean the file, write "./', $o->{text}, '".') if $o->isKeyword;
14665 0           return $file;
14666             }
14667              
14668             sub completeFile {
14669 0     0     my $o = shift;
14670              
14671 0           my $folder = './';
14672 0           my $startFilename = $o->{text};
14673 0 0         $startFilename = $ENV{HOME}.'/'.$1 if $startFilename =~ /^~\/(.*)$/;
14674 0 0         if ($startFilename eq '~') {
    0          
14675 0           $folder = $ENV{HOME}.'/';
14676 0           $startFilename = '';
14677             } elsif ($startFilename =~ /^(.*\/)([^\/]*)$/) {
14678 0           $folder = $1;
14679 0           $startFilename = $2;
14680             }
14681              
14682 0           for my $filename (CDS->listFolder($folder)) {
14683 0 0         next if $filename eq '.';
14684 0 0         next if $filename eq '..';
14685 0 0         next if substr($filename, 0, length $startFilename) ne $startFilename;
14686 0           my $file = $folder.$filename;
14687 0 0         $file .= '/' if -d $file;
14688 0 0         $file .= ' ' if -f $file;
14689 0           push @{$o->{possibilities}}, $file;
  0            
14690             }
14691             }
14692              
14693             sub filename {
14694 0     0     my $o = shift;
14695              
14696 0 0         return $o->warning('"', $o->{text}, '" is interpreted as keyword. If you mean the file, write "./', $o->{text}, '".') if $o->isKeyword;
14697 0           return Cwd::abs_path($o->{text});
14698             }
14699              
14700             sub folder {
14701 0     0     my $o = shift;
14702              
14703 0   0       my $folder = Cwd::abs_path($o->{text}) // return;
14704 0 0         return if ! -d $folder;
14705 0 0         return $o->warning('"', $o->{text}, '" is interpreted as keyword. If you mean the folder, write "./', $o->{text}, '".') if $o->isKeyword;
14706 0           return $folder;
14707             }
14708              
14709             sub completeFolder {
14710 0     0     my $o = shift;
14711              
14712 0           my $folder = './';
14713 0           my $startFilename = $o->{text};
14714 0 0         if ($o->{text} =~ /^(.*\/)([^\/]*)$/) {
14715 0           $folder = $1;
14716 0           $startFilename = $2;
14717             }
14718              
14719 0           for my $filename (CDS->listFolder($folder)) {
14720 0 0         next if $filename eq '.';
14721 0 0         next if $filename eq '..';
14722 0 0         next if substr($filename, 0, length $startFilename) ne $startFilename;
14723 0           my $file = $folder.$filename;
14724 0 0         next if ! -d $file;
14725 0           push @{$o->{possibilities}}, $file.'/';
  0            
14726             }
14727             }
14728              
14729             sub foldername {
14730 0     0     my $o = shift;
14731              
14732 0 0         return $o->warning('"', $o->{text}, '" is interpreted as keyword. If you mean the folder, write "./', $o->{text}, '".') if $o->isKeyword;
14733 0           return Cwd::abs_path($o->{text});
14734             }
14735              
14736             sub group {
14737 0     0     my $o = shift;
14738              
14739 0 0         return int($1) if $o->{text} =~ /^\s*(\d{1,5})\s*$/;
14740 0           return getgrnam($o->{text});
14741             }
14742              
14743             sub completeGroup {
14744 0     0     my $o = shift;
14745              
14746 0           while (my $name = getgrent) {
14747 0           $o->addPossibility($name);
14748             }
14749             }
14750              
14751             sub hash {
14752 0     0     my $o = shift;
14753              
14754 0           my $hash = CDS::Hash->fromHex($o->{text});
14755 0 0         return $hash if $hash;
14756              
14757             # Check if it's a remembered actor hash
14758 0           my $record = $o->{actor}->remembered($o->{text});
14759 0   0       my $actorHash = CDS::Hash->fromBytes($record->child('actor')->bytesValue) // return;
14760 0 0         return $o->warning('"', $o->{text}, '" is interpreted as keyword. If you mean the actor, write "', $actorHash->hex, '".') if $o->isKeyword;
14761 0           return $actorHash;
14762             }
14763              
14764             sub completeHash {
14765 0     0     my $o = shift;
14766              
14767 0           my $records = $o->{actor}->rememberedRecords;
14768 0           for my $label (keys %$records) {
14769 0           my $record = $records->{$label};
14770 0   0       my $hash = CDS::Hash->fromBytes($record->child('actor')->bytesValue) // next;
14771 0           $o->addPossibility($label);
14772 0           $o->addPossibility($hash->hex);
14773             }
14774              
14775 0           for my $child ($o->{actor}->actorGroupSelector->children) {
14776 0   0       my $hash = $child->record->child('hash')->hashValue // next;
14777 0           $o->addPossibility($hash->hex);
14778             }
14779             }
14780              
14781             sub keyPair {
14782 0     0     my $o = shift;
14783              
14784             # Remembered key pair
14785 0           my $record = $o->{actor}->remembered($o->{text});
14786 0           my $file = $record->child('key pair')->textValue;
14787              
14788             # Key pair from file
14789 0 0         if (! length $file) {
14790 0   0       $file = Cwd::abs_path($o->{text}) // return;
14791 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;
14792             }
14793              
14794             # Load the key pair
14795 0 0         return if ! -f $file;
14796 0   0       my $bytes = CDS->readBytesFromFile($file) // return $o->warning('The key pair file "', $file, '" could not be read.');
14797 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.');
14798 0           return CDS::KeyPairToken->new($file, $keyPair);
14799             }
14800              
14801             sub completeKeyPair {
14802 0     0     my $o = shift;
14803              
14804 0           $o->completeFile;
14805              
14806 0           my $records = $o->{actor}->rememberedRecords;
14807 0           for my $label (keys %$records) {
14808 0           my $record = $records->{$label};
14809 0 0         next if ! length $record->child('key pair')->textValue;
14810 0           $o->addPossibility($label);
14811             }
14812             }
14813              
14814             sub label {
14815 0     0     my $o = shift;
14816              
14817 0           my $records = $o->{actor}->remembered($o->{text});
14818 0 0         return $o->{text} if $records->children;
14819 0           return;
14820             }
14821              
14822             sub completeLabel {
14823 0     0     my $o = shift;
14824              
14825 0           my $records = $o->{actor}->rememberedRecords;
14826 0           for my $label (keys %$records) {
14827 0 0         next if substr($label, 0, length $o->{text}) ne $o->{text};
14828 0           $o->addPossibility($label);
14829             }
14830             }
14831              
14832             sub object {
14833 0     0     my $o = shift;
14834              
14835             # Folder stores use the first two hex digits as folder
14836 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};
14837              
14838             # From a URL
14839 0 0         if ($url =~ /^\s*(.*?)\/objects\/([0-9a-fA-F]{64,64})\/*\s*$/) {
14840 0           my $storeUrl = $1;
14841 0           my $hash = CDS::Hash->fromHex($2);
14842 0 0 0       $storeUrl = 'file://'.Cwd::abs_path($storeUrl) if $storeUrl !~ /^[a-zA-Z0-9_\+-]*:/ && -d $storeUrl;
14843 0   0       my $cliStore = $o->{actor}->storeForUrl($storeUrl) // return $o->warning('Invalid store URL "', $storeUrl, '".');
14844 0           return CDS::ObjectToken->new($cliStore, $hash);
14845             }
14846              
14847 0           return;
14848             }
14849              
14850             sub completeObject {
14851 0     0     my $o = shift;
14852              
14853 0           $o->completeUrl;
14854 0           return;
14855             }
14856              
14857             sub objectFile {
14858 0     0     my $o = shift;
14859              
14860             # Key pair from file
14861 0   0       my $file = Cwd::abs_path($o->{text}) // return;
14862 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;
14863              
14864             # Load the object
14865 0 0         return if ! -f $file;
14866 0   0       my $bytes = CDS->readBytesFromFile($file) // return $o->warning('The object file "', $file, '" could not be read.');
14867 0   0       my $object = CDS::Object->fromBytes($bytes) // return $o->warning('The file "', $file, '" does not contain a Condensation object.');
14868 0           return CDS::ObjectFileToken->new($file, $object);
14869             }
14870              
14871             sub completeObjectFile {
14872 0     0     my $o = shift;
14873              
14874 0           $o->completeFile;
14875 0           return;
14876             }
14877              
14878             sub actorGroup {
14879 0     0     my $o = shift;
14880              
14881             # 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.
14882              
14883             # Check if it's an actor group label
14884 0           my $record = $o->{actor}->remembered($o->{text})->child('actor group');
14885 0 0         return if ! scalar $record->children;
14886 0 0         return $o->warning('"', $o->{text}, '" is interpreted as keyword. To refer to the actor group, rename it.') if $o->isKeyword;
14887              
14888 0           my $builder = CDS::ActorGroupBuilder->new;
14889 0           $builder->addKnownPublicKey($o->{actor}->keyPair->publicKey);
14890 0           $builder->parse($record, 1);
14891 0           my ($actorGroup, $storeError) = $builder->load($o->{actor}->groupDocument->unsaved, $o->{actor}->keyPair, $o);
14892 0 0         return $o->{actor}->storeError($o->{actor}->storageStore, $storeError) if defined $storeError;
14893 0           return CDS::ActorGroupToken->new($o->{text}, $actorGroup);
14894             }
14895              
14896             sub onLoadActorGroupVerifyStore {
14897 0     0     my $o = shift;
14898 0           my $storeUrl = shift;
14899 0           $o->{actor}->storeForUrl($storeUrl); }
14900              
14901             sub completeActorGroup {
14902 0     0     my $o = shift;
14903              
14904 0           my $records = $o->{actor}->rememberedRecords;
14905 0           for my $label (keys %$records) {
14906 0           my $record = $records->{$label};
14907 0 0         next if ! scalar $record->child('actor group')->children;
14908 0           $o->addPossibility($label);
14909             }
14910 0           return;
14911             }
14912              
14913             sub port {
14914 0     0     my $o = shift;
14915              
14916 0           my $port = int($o->{text});
14917 0 0 0       return if $port <= 0 || $port > 65536;
14918 0           return $port;
14919             }
14920              
14921             sub rememberedStoreUrl {
14922 0     0     my $o = shift;
14923              
14924 0           my $record = $o->{actor}->remembered($o->{text});
14925 0           my $storeUrl = $record->child('store')->textValue;
14926 0 0         return if ! length $storeUrl;
14927              
14928 0 0         return $o->warning('"', $o->{text}, '" is interpreted as keyword. If you mean the store, write "', $storeUrl, '".') if $o->isKeyword;
14929 0           return $storeUrl;
14930             }
14931              
14932             sub directStoreUrl {
14933 0     0     my $o = shift;
14934              
14935 0 0         return $o->warning('"', $o->{text}, '" is interpreted as keyword. If you mean the folder store, write "./', $o->{text}, '".') if $o->isKeyword;
14936 0 0         return if $o->{text} =~ /[0-9a-f]{32}/;
14937              
14938 0 0         return $o->{text} if $o->{text} =~ /^[a-zA-Z0-9_\+-]*:/;
14939 0 0 0       return 'file://'.Cwd::abs_path($o->{text}) if -d $o->{text} && -d $o->{text}.'/accounts' && -d $o->{text}.'/objects';
      0        
14940 0           return;
14941             }
14942              
14943             sub store {
14944 0     0     my $o = shift;
14945              
14946 0   0       my $url = $o->rememberedStoreUrl // $o->directStoreUrl // return;
      0        
14947 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.');
14948             }
14949              
14950             sub completeFolderStoreUrl {
14951 0     0     my $o = shift;
14952              
14953 0           my $folder = './';
14954 0           my $startFilename = $o->{text};
14955 0 0         if ($o->{text} =~ /^(.*\/)([^\/]*)$/) {
14956 0           $folder = $1;
14957 0           $startFilename = $2;
14958             }
14959              
14960 0           for my $filename (CDS->listFolder($folder)) {
14961 0 0         next if $filename eq '.';
14962 0 0         next if $filename eq '..';
14963 0 0         next if substr($filename, 0, length $startFilename) ne $startFilename;
14964 0           my $file = $folder.$filename;
14965 0 0         next if ! -d $file;
14966 0 0 0       push @{$o->{possibilities}}, $file . (-d $file.'/accounts' && -d $file.'/objects' ? ' ' : '/');
  0            
14967             }
14968             }
14969              
14970             sub completeStoreUrl {
14971 0     0     my $o = shift;
14972              
14973 0           $o->completeFolderStoreUrl;
14974 0           $o->completeUrl;
14975              
14976 0           my $records = $o->{actor}->rememberedRecords;
14977 0           for my $label (keys %$records) {
14978 0           my $record = $records->{$label};
14979 0 0         next if length $record->child('actor')->bytesValue;
14980 0           my $storeUrl = $record->child('store')->textValue;
14981 0 0         next if ! length $storeUrl;
14982 0           $o->addPossibility($label);
14983 0           $o->addPossibility($storeUrl);
14984             }
14985             }
14986              
14987             sub completeUrl {
14988 0     0     my $o = shift;
14989              
14990 0           $o->addPartialPossibility('http://');
14991 0           $o->addPartialPossibility('https://');
14992 0           $o->addPartialPossibility('ftp://');
14993 0           $o->addPartialPossibility('sftp://');
14994 0           $o->addPartialPossibility('file://');
14995             }
14996              
14997             sub text {
14998 0     0     my $o = shift;
14999              
15000 0           return $o->{text};
15001             }
15002              
15003             sub user {
15004 0     0     my $o = shift;
15005              
15006 0 0         return int($1) if $o->{text} =~ /^\s*(\d{1,5})\s*$/;
15007 0           return getpwnam($o->{text});
15008             }
15009              
15010             sub completeUser {
15011 0     0     my $o = shift;
15012              
15013 0           while (my $name = getpwent) {
15014 0           $o->addPossibility($name);
15015             }
15016             }
15017              
15018             sub warning {
15019 0     0     my $o = shift;
15020              
15021 0           push @{$o->{warnings}}, join('', @_);
  0            
15022 0           return;
15023             }
15024              
15025             # Reads the private box of an actor.
15026             package CDS::PrivateBoxReader;
15027              
15028             sub new {
15029 0     0     my $class = shift;
15030 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
15031 0           my $store = shift;
15032 0           my $delegate = shift;
15033              
15034 0           return bless {
15035             keyPair => $keyPair,
15036             actorOnStore => CDS::ActorOnStore->new($keyPair->publicKey, $store),
15037             delegate => $delegate,
15038             entries => {},
15039             };
15040             }
15041              
15042 0     0     sub keyPair { shift->{keyPair} }
15043 0     0     sub actorOnStore { shift->{actorOnStore} }
15044 0     0     sub delegate { shift->{delegate} }
15045              
15046             sub read {
15047 0     0     my $o = shift;
15048              
15049 0           my $store = $o->{actorOnStore}->store;
15050 0           my ($hashes, $listError) = $store->list($o->{actorOnStore}->publicKey->hash, 'private', 0, $o->{keyPair});
15051 0 0         return if defined $listError;
15052              
15053             # Keep track of the processed entries
15054 0           my $newEntries = {};
15055 0           for my $hash (@$hashes) {
15056 0   0       $newEntries->{$hash->bytes} = $o->{entries}->{$hash->bytes} // {hash => $hash, processed => 0};
15057             }
15058 0           $o->{entries} = $newEntries;
15059              
15060             # Process new entries
15061 0           for my $entry (values %$newEntries) {
15062 0 0         next if $entry->{processed};
15063              
15064             # Get the envelope
15065 0           my ($object, $getError) = $store->get($entry->{hash}, $o->{keyPair});
15066 0 0         return if defined $getError;
15067              
15068 0 0         if (! defined $object) {
15069 0           $o->invalid($entry, 'Envelope object not found.');
15070 0           next;
15071             }
15072              
15073             # Parse the record
15074 0           my $envelope = CDS::Record->fromObject($object);
15075 0 0         if (! $envelope) {
15076 0           $o->invalid($entry, 'Envelope is not a record.');
15077 0           next;
15078             }
15079              
15080             # Read the content hash
15081 0           my $contentHash = $envelope->child('content')->hashValue;
15082 0 0         if (! $contentHash) {
15083 0           $o->invalid($entry, 'Missing content hash.');
15084 0           next;
15085             }
15086              
15087             # Verify the signature
15088 0 0         if (! CDS->verifyEnvelopeSignature($envelope, $o->{keyPair}->publicKey, $contentHash)) {
15089 0           $o->invalid($entry, 'Invalid signature.');
15090 0           next;
15091             }
15092              
15093             # Decrypt the key
15094 0           my $aesKey = $o->{keyPair}->decryptKeyOnEnvelope($envelope);
15095 0 0         if (! $aesKey) {
15096 0           $o->invalid($entry, 'Not encrypted for us.');
15097 0           next;
15098             }
15099              
15100             # Retrieve the content
15101 0           my $contentHashAndKey = CDS::HashAndKey->new($contentHash, $aesKey);
15102 0           my ($contentRecord, $contentObject, $contentInvalidReason, $contentStoreError) = $o->{keyPair}->getAndDecryptRecord($contentHashAndKey, $store);
15103 0 0         return if defined $contentStoreError;
15104              
15105 0 0         if (defined $contentInvalidReason) {
15106 0           $o->invalid($entry, $contentInvalidReason);
15107 0           next;
15108             }
15109              
15110 0           $entry->{processed} = 1;
15111 0           my $source = CDS::Source->new($o->{keyPair}, $o->{actorOnStore}, 'private', $entry->{hash});
15112 0           $o->{delegate}->onPrivateBoxEntry($source, $envelope, $contentHashAndKey, $contentRecord);
15113             }
15114              
15115 0           return 1;
15116             }
15117              
15118             sub invalid {
15119 0     0     my $o = shift;
15120 0           my $entry = shift;
15121 0           my $reason = shift;
15122              
15123 0           $entry->{processed} = 1;
15124 0           my $source = CDS::Source->new($o->{actorOnStore}, 'private', $entry->{hash});
15125 0           $o->{delegate}->onPrivateBoxInvalidEntry($source, $reason);
15126             }
15127              
15128             # Delegate
15129             # onPrivateBoxEntry($source, $envelope, $contentHashAndKey, $contentRecord)
15130             # onPrivateBoxInvalidEntry($source, $reason)
15131              
15132             package CDS::PrivateRoot;
15133              
15134             sub new {
15135 0     0     my $class = shift;
15136 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
15137 0           my $store = shift;
15138 0           my $delegate = shift;
15139              
15140 0           my $o = bless {
15141             unsaved => CDS::Unsaved->new($store),
15142             delegate => $delegate,
15143             dataHandlers => {},
15144             hasChanges => 0,
15145             procured => 0,
15146             mergedEntries => [],
15147             };
15148              
15149 0           $o->{privateBoxReader} = CDS::PrivateBoxReader->new($keyPair, $store, $o);
15150 0           return $o;
15151             }
15152              
15153 0     0     sub delegate { shift->{delegate} }
15154 0     0     sub privateBoxReader { shift->{privateBoxReader} }
15155 0     0     sub unsaved { shift->{unsaved} }
15156 0     0     sub hasChanges { shift->{hasChanges} }
15157 0     0     sub procured { shift->{procured} }
15158              
15159             sub addDataHandler {
15160 0     0     my $o = shift;
15161 0           my $label = shift;
15162 0           my $dataHandler = shift;
15163              
15164 0           $o->{dataHandlers}->{$label} = $dataHandler;
15165             }
15166              
15167             sub removeDataHandler {
15168 0     0     my $o = shift;
15169 0           my $label = shift;
15170 0           my $dataHandler = shift;
15171              
15172 0           my $registered = $o->{dataHandlers}->{$label};
15173 0 0         return if $registered != $dataHandler;
15174 0           delete $o->{dataHandlers}->{$label};
15175             }
15176              
15177             # *** Procurement
15178              
15179             sub procure {
15180 0     0     my $o = shift;
15181 0           my $interval = shift;
15182              
15183 0           my $now = CDS->now;
15184 0 0         return $o->{procured} if $o->{procured} + $interval > $now;
15185 0   0       $o->{privateBoxReader}->read // return;
15186 0           $o->{procured} = $now;
15187 0           return $now;
15188             }
15189              
15190             # *** Merging
15191              
15192             sub onPrivateBoxEntry {
15193 0     0     my $o = shift;
15194 0 0 0       my $source = shift; die 'wrong type '.ref($source).' for $source' if defined $source && ref $source ne 'CDS::Source';
  0            
15195 0 0 0       my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0            
15196 0           my $contentHashAndKey = shift;
15197 0           my $content = shift;
15198              
15199 0           for my $section ($content->children) {
15200 0   0       my $dataHandler = $o->{dataHandlers}->{$section->bytes} // next;
15201 0           $dataHandler->mergeData($section);
15202             }
15203              
15204 0           push @{$o->{mergedEntries}}, $source->hash;
  0            
15205             }
15206              
15207             sub onPrivateBoxInvalidEntry {
15208 0     0     my $o = shift;
15209 0 0 0       my $source = shift; die 'wrong type '.ref($source).' for $source' if defined $source && ref $source ne 'CDS::Source';
  0            
15210 0           my $reason = shift;
15211              
15212 0           $o->{delegate}->onPrivateRootReadingInvalidEntry($source, $reason);
15213 0           $source->discard;
15214             }
15215              
15216             # *** Saving
15217              
15218             sub dataChanged {
15219 0     0     my $o = shift;
15220              
15221 0           $o->{hasChanges} = 1;
15222             }
15223              
15224             sub save {
15225 0     0     my $o = shift;
15226 0           my $entrustedKeys = shift;
15227              
15228 0           $o->{unsaved}->startSaving;
15229 0 0         return $o->savingSucceeded if ! $o->{hasChanges};
15230 0           $o->{hasChanges} = 0;
15231              
15232             # Create the record
15233 0           my $record = CDS::Record->new;
15234 0           $record->add('created')->addInteger(CDS->now);
15235 0           $record->add('client')->add(CDS->version);
15236 0           for my $label (keys %{$o->{dataHandlers}}) {
  0            
15237 0           my $dataHandler = $o->{dataHandlers}->{$label};
15238 0           $dataHandler->addDataTo($record->add($label));
15239             }
15240              
15241             # Submit the object
15242 0           my $key = CDS->randomKey;
15243 0           my $object = $record->toObject->crypt($key);
15244 0           my $hash = $object->calculateHash;
15245 0           $o->{unsaved}->savingState->addObject($hash, $object);
15246 0           my $hashAndKey = CDS::HashAndKey->new($hash, $key);
15247              
15248             # Create the envelope
15249 0           my $keyPair = $o->{privateBoxReader}->keyPair;
15250 0           my $publicKeys = [$keyPair->publicKey, @$entrustedKeys];
15251 0           my $envelopeObject = $keyPair->createPrivateEnvelope($hashAndKey, $publicKeys)->toObject;
15252 0           my $envelopeHash = $envelopeObject->calculateHash;
15253 0           $o->{unsaved}->savingState->addObject($envelopeHash, $envelopeObject);
15254              
15255             # Transfer
15256 0           my ($missing, $store, $storeError) = $keyPair->transfer([$hash], $o->{unsaved}, $o->{privateBoxReader}->actorOnStore->store);
15257 0 0 0       return $o->savingFailed($missing) if defined $missing || defined $storeError;
15258              
15259             # Modify the private box
15260 0           my $modifications = CDS::StoreModifications->new;
15261 0           $modifications->add($keyPair->publicKey->hash, 'private', $envelopeHash, $envelopeObject);
15262 0           for my $hash (@{$o->{mergedEntries}}) {
  0            
15263 0           $modifications->remove($keyPair->publicKey->hash, 'private', $hash);
15264             }
15265              
15266 0           my $modifyError = $o->{privateBoxReader}->actorOnStore->store->modify($modifications, $keyPair);
15267 0 0         return $o->savingFailed if defined $modifyError;
15268              
15269             # Set the new merged hashes
15270 0           $o->{mergedEntries} = [$envelopeHash];
15271 0           return $o->savingSucceeded;
15272             }
15273              
15274             sub savingSucceeded {
15275 0     0     my $o = shift;
15276              
15277             # Discard all merged sources
15278 0           for my $source ($o->{unsaved}->savingState->mergedSources) {
15279 0           $source->discard;
15280             }
15281              
15282             # Call all data saved handlers
15283 0           for my $handler ($o->{unsaved}->savingState->dataSavedHandlers) {
15284 0           $handler->onDataSaved;
15285             }
15286              
15287 0           $o->{unsaved}->savingDone;
15288 0           return 1;
15289             }
15290              
15291             sub savingFailed {
15292 0     0     my $o = shift;
15293 0           my $missing = shift;
15294             # private
15295 0           $o->{unsaved}->savingFailed;
15296 0           $o->{hasChanges} = 1;
15297 0           return undef, $missing;
15298             }
15299              
15300             # A public key of somebody.
15301             package CDS::PublicKey;
15302              
15303             sub fromObject {
15304 0     0     my $class = shift;
15305 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
15306              
15307 0   0       my $record = CDS::Record->fromObject($object) // return;
15308 0   0       my $rsaPublicKey = CDS::C::publicKeyNew($record->child('e')->bytesValue, $record->child('n')->bytesValue) // return;
15309 0           return bless {
15310             hash => $object->calculateHash,
15311             rsaPublicKey => $rsaPublicKey,
15312             object => $object,
15313             lastAccess => 0, # used by PublicKeyCache
15314             };
15315             }
15316              
15317 0     0     sub object { shift->{object} }
15318             sub bytes {
15319 0     0     my $o = shift;
15320 0           $o->{object}->bytes }
15321              
15322             ### Public key interface ###
15323              
15324 0     0     sub hash { shift->{hash} }
15325             sub encrypt {
15326 0     0     my $o = shift;
15327 0           my $bytes = shift;
15328 0           CDS::C::publicKeyEncrypt($o->{rsaPublicKey}, $bytes) }
15329             sub verifyHash {
15330 0     0     my $o = shift;
15331 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15332 0           my $signature = shift;
15333 0           CDS::C::publicKeyVerify($o->{rsaPublicKey}, $hash->bytes, $signature) }
15334              
15335             package CDS::PublicKeyCache;
15336              
15337             sub new {
15338 0     0     my $class = shift;
15339 0           my $maxSize = shift;
15340              
15341 0           return bless {
15342             cache => {},
15343             maxSize => $maxSize,
15344             };
15345             }
15346              
15347             sub add {
15348 0     0     my $o = shift;
15349 0 0 0       my $publicKey = shift; die 'wrong type '.ref($publicKey).' for $publicKey' if defined $publicKey && ref $publicKey ne 'CDS::PublicKey';
  0            
15350              
15351 0           $o->{cache}->{$publicKey->hash->bytes} = {publicKey => $publicKey, lastAccess => CDS->now};
15352 0           $o->deleteOldest;
15353 0           return;
15354             }
15355              
15356             sub get {
15357 0     0     my $o = shift;
15358 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15359              
15360 0   0       my $entry = $o->{cache}->{$hash->bytes} // return;
15361 0           $entry->{lastAccess} = CDS->now;
15362 0           return $entry->{publicKey};
15363             }
15364              
15365             sub deleteOldest {
15366 0     0     my $o = shift;
15367             # private
15368 0 0         return if scalar values %{$o->{cache}} < $o->{maxSize};
  0            
15369              
15370 0           my @entries = sort { $a->{lastAccess} <=> $b->{lastAccess} } values %{$o->{cache}};
  0            
  0            
15371 0           my $toRemove = int(scalar(@entries) - $o->{maxSize} / 2);
15372 0           for my $entry (@entries) {
15373 0           $toRemove -= 1;
15374 0 0         last if $toRemove <= 0;
15375 0           delete $o->{cache}->{$entry->{publicKey}->hash->bytes};
15376             }
15377             }
15378              
15379             package CDS::PutTree;
15380              
15381             sub new {
15382 0     0     my $o = shift;
15383 0           my $store = shift;
15384 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
15385 0           my $commitPool = shift;
15386              
15387 0           return bless {
15388             store => $store,
15389             commitPool => $commitPool,
15390             keyPair => $keyPair,
15391             done => {},
15392             };
15393             }
15394              
15395             sub put {
15396 0     0     my $o = shift;
15397 0 0 0       my $hash = shift // return; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0   0        
15398              
15399 0 0         return if $o->{done}->{$hash->bytes};
15400              
15401             # Get the item
15402 0   0       my $hashAndObject = $o->{commitPool}->object($hash) // return;
15403              
15404             # Upload all children
15405 0           for my $hash ($hashAndObject->object->hashes) {
15406 0           my $error = $o->put($hash);
15407 0 0         return $error if defined $error;
15408             }
15409              
15410             # Upload this object
15411 0           my $error = $o->{store}->put($hashAndObject->hash, $hashAndObject->object, $o->{keyPair});
15412 0 0         return $error if defined $error;
15413 0           $o->{done}->{$hash->bytes} = 1;
15414 0           return;
15415             }
15416              
15417             package CDS::ReceivedMessage;
15418              
15419             sub new {
15420 0     0     my $class = shift;
15421 0           my $messageBoxReader = shift;
15422 0           my $entry = shift;
15423 0 0 0       my $source = shift; die 'wrong type '.ref($source).' for $source' if defined $source && ref $source ne 'CDS::Source';
  0            
15424 0 0 0       my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0            
15425 0           my $senderStoreUrl = shift;
15426 0           my $sender = shift;
15427 0           my $content = shift;
15428 0           my $streamHead = shift;
15429              
15430 0           return bless {
15431             messageBoxReader => $messageBoxReader,
15432             entry => $entry,
15433             source => $source,
15434             envelope => $envelope,
15435             senderStoreUrl => $senderStoreUrl,
15436             sender => $sender,
15437             content => $content,
15438             streamHead => $streamHead,
15439             isDone => 0,
15440             };
15441             }
15442              
15443 0     0     sub source { shift->{source} }
15444 0     0     sub envelope { shift->{envelope} }
15445 0     0     sub senderStoreUrl { shift->{senderStoreUrl} }
15446 0     0     sub sender { shift->{sender} }
15447 0     0     sub content { shift->{content} }
15448              
15449             sub waitForSenderStore {
15450 0     0     my $o = shift;
15451              
15452 0           $o->{entry}->{waitingForStore} = $o->sender->store;
15453             }
15454              
15455             sub skip {
15456 0     0     my $o = shift;
15457              
15458 0           $o->{entry}->{processed} = 0;
15459             }
15460              
15461             # A record is a tree, whereby each nodes holds a byte sequence and an optional hash.
15462             # Child nodes are ordered, although the order does not always matter.
15463             package CDS::Record;
15464              
15465             sub fromObject {
15466 0     0     my $class = shift;
15467 0 0 0       my $object = shift // return; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0   0        
15468              
15469 0           my $root = CDS::Record->new;
15470 0   0       $root->addFromObject($object) // return;
15471 0           return $root;
15472             }
15473              
15474             sub new {
15475 0     0     my $class = shift;
15476 0           my $bytes = shift;
15477 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15478              
15479 0   0       bless {
15480             bytes => $bytes // '',
15481             hash => $hash,
15482             children => [],
15483             };
15484             }
15485              
15486             # *** Adding
15487              
15488             # Adds a record
15489             sub add {
15490 0     0     my $o = shift;
15491 0           my $bytes = shift;
15492 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15493              
15494 0           my $record = CDS::Record->new($bytes, $hash);
15495 0           push @{$o->{children}}, $record;
  0            
15496 0           return $record;
15497             }
15498              
15499             sub addText {
15500 0     0     my $o = shift;
15501 0           my $value = shift;
15502 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15503 0   0       $o->add(Encode::encode_utf8($value // ''), $hash) }
15504             sub addBoolean {
15505 0     0     my $o = shift;
15506 0           my $value = shift;
15507 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15508 0           $o->add(CDS->bytesFromBoolean($value), $hash) }
15509             sub addInteger {
15510 0     0     my $o = shift;
15511 0           my $value = shift;
15512 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15513 0   0       $o->add(CDS->bytesFromInteger($value // 0), $hash) }
15514             sub addUnsigned {
15515 0     0     my $o = shift;
15516 0           my $value = shift;
15517 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15518 0   0       $o->add(CDS->bytesFromUnsigned($value // 0), $hash) }
15519             sub addFloat32 {
15520 0     0     my $o = shift;
15521 0           my $value = shift;
15522 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15523 0   0       $o->add(CDS->bytesFromFloat32($value // 0), $hash) }
15524             sub addFloat64 {
15525 0     0     my $o = shift;
15526 0           my $value = shift;
15527 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15528 0   0       $o->add(CDS->bytesFromFloat64($value // 0), $hash) }
15529             sub addHash {
15530 0     0     my $o = shift;
15531 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15532 0           $o->add('', $hash) }
15533             sub addHashAndKey {
15534 0     0     my $o = shift;
15535 0 0 0       my $hashAndKey = shift; die 'wrong type '.ref($hashAndKey).' for $hashAndKey' if defined $hashAndKey && ref $hashAndKey ne 'CDS::HashAndKey';
  0            
15536 0 0         $hashAndKey ? $o->add($hashAndKey->key, $hashAndKey->hash) : $o->add('') }
15537             sub addRecord {
15538 0     0     my $o = shift;
15539 0           push @{$o->{children}}, @_; return; }
  0            
  0            
15540              
15541             sub addFromObject {
15542 0     0     my $o = shift;
15543 0 0 0       my $object = shift // return; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0   0        
15544              
15545 0 0         return 1 if ! length $object->data;
15546 0           return CDS::RecordReader->new($object)->readChildren($o);
15547             }
15548              
15549             # *** Set value
15550              
15551             sub set {
15552 0     0     my $o = shift;
15553 0           my $bytes = shift;
15554 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15555              
15556 0           $o->{bytes} = $bytes;
15557 0           $o->{hash} = $hash;
15558 0           return;
15559             }
15560              
15561             # *** Querying
15562              
15563             # Returns true if the record contains a child with the indicated bytes.
15564             sub contains {
15565 0     0     my $o = shift;
15566 0           my $bytes = shift;
15567              
15568 0           for my $child (@{$o->{children}}) {
  0            
15569 0 0         return 1 if $child->{bytes} eq $bytes;
15570             }
15571 0           return;
15572             }
15573              
15574             # 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).
15575             sub child {
15576 0     0     my $o = shift;
15577 0           my $bytes = shift;
15578              
15579 0           for my $child (@{$o->{children}}) {
  0            
15580 0 0         return $child if $child->{bytes} eq $bytes;
15581             }
15582 0           return $o->new($bytes);
15583             }
15584              
15585             # Returns the first child, or an empty record.
15586             sub firstChild {
15587 0     0     my $o = shift;
15588 0   0       $o->{children}->[0] // $o->new }
15589              
15590             # Returns the nth child, or an empty record.
15591             sub nthChild {
15592 0     0     my $o = shift;
15593 0           my $i = shift;
15594 0   0       $o->{children}->[$i] // $o->new }
15595              
15596             sub containsText {
15597 0     0     my $o = shift;
15598 0           my $text = shift;
15599 0   0       $o->contains(Encode::encode_utf8($text // '')) }
15600             sub childWithText {
15601 0     0     my $o = shift;
15602 0           my $text = shift;
15603 0   0       $o->child(Encode::encode_utf8($text // '')) }
15604              
15605             # *** Get value
15606              
15607 0     0     sub bytes { shift->{bytes} }
15608 0     0     sub hash { shift->{hash} }
15609             sub children {
15610 0     0     my $o = shift;
15611 0           @{$o->{children}} }
  0            
15612              
15613             sub asText {
15614 0     0     my $o = shift;
15615 0   0       Encode::decode_utf8($o->{bytes}) // '' }
15616             sub asBoolean {
15617 0     0     my $o = shift;
15618 0           CDS->booleanFromBytes($o->{bytes}) }
15619             sub asInteger {
15620 0     0     my $o = shift;
15621 0   0       CDS->integerFromBytes($o->{bytes}) // 0 }
15622             sub asUnsigned {
15623 0     0     my $o = shift;
15624 0   0       CDS->unsignedFromBytes($o->{bytes}) // 0 }
15625             sub asFloat {
15626 0     0     my $o = shift;
15627 0   0       CDS->floatFromBytes($o->{bytes}) // 0 }
15628              
15629             sub asHashAndKey {
15630 0     0     my $o = shift;
15631              
15632 0 0         return if ! $o->{hash};
15633 0 0         return if length $o->{bytes} != 32;
15634 0           return CDS::HashAndKey->new($o->{hash}, $o->{bytes});
15635             }
15636              
15637             sub bytesValue {
15638 0     0     my $o = shift;
15639 0           $o->firstChild->bytes }
15640             sub hashValue {
15641 0     0     my $o = shift;
15642 0           $o->firstChild->hash }
15643             sub textValue {
15644 0     0     my $o = shift;
15645 0           $o->firstChild->asText }
15646             sub booleanValue {
15647 0     0     my $o = shift;
15648 0           $o->firstChild->asBoolean }
15649             sub integerValue {
15650 0     0     my $o = shift;
15651 0           $o->firstChild->asInteger }
15652             sub unsignedValue {
15653 0     0     my $o = shift;
15654 0           $o->firstChild->asUnsigned }
15655             sub floatValue {
15656 0     0     my $o = shift;
15657 0           $o->firstChild->asFloat }
15658             sub hashAndKeyValue {
15659 0     0     my $o = shift;
15660 0           $o->firstChild->asHashAndKey }
15661              
15662             # *** Dependent hashes
15663              
15664             sub dependentHashes {
15665 0     0     my $o = shift;
15666              
15667 0           my $hashes = {};
15668 0           $o->traverseHashes($hashes);
15669 0           return values %$hashes;
15670             }
15671              
15672             sub traverseHashes {
15673 0     0     my $o = shift;
15674 0           my $hashes = shift;
15675             # private
15676 0 0         $hashes->{$o->{hash}->bytes} = $o->{hash} if $o->{hash};
15677 0           for my $child (@{$o->{children}}) {
  0            
15678 0           $child->traverseHashes($hashes);
15679             }
15680             }
15681              
15682             # *** Size
15683              
15684             sub countEntries {
15685 0     0     my $o = shift;
15686              
15687 0           my $count = 1;
15688 0           for my $child (@{$o->{children}}) { $count += $child->countEntries; }
  0            
  0            
15689 0           return $count;
15690             }
15691              
15692             sub calculateSize {
15693 0     0     my $o = shift;
15694              
15695 0           return 4 + $o->calculateSizeContribution;
15696             }
15697              
15698             sub calculateSizeContribution {
15699 0     0     my $o = shift;
15700             # private
15701 0           my $byteLength = length $o->{bytes};
15702 0 0         my $size = $byteLength < 30 ? 1 : $byteLength < 286 ? 2 : 9;
    0          
15703 0           $size += $byteLength;
15704 0 0         $size += 32 + 4 if $o->{hash};
15705 0           for my $child (@{$o->{children}}) {
  0            
15706 0           $size += $child->calculateSizeContribution;
15707             }
15708 0           return $size;
15709             }
15710              
15711             # *** Serialization
15712              
15713             # Serializes this record into a Condensation object.
15714             sub toObject {
15715 0     0     my $o = shift;
15716              
15717 0           my $writer = CDS::RecordWriter->new;
15718 0           $writer->writeChildren($o);
15719 0           return CDS::Object->create($writer->header, $writer->data);
15720             }
15721              
15722             package CDS::RecordReader;
15723              
15724             sub new {
15725 0     0     my $class = shift;
15726 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
15727              
15728 0           return bless {
15729             object => $object,
15730             data => $object->data,
15731             pos => 0,
15732             hasError => 0
15733             };
15734             }
15735              
15736 0     0     sub hasError { shift->{hasError} }
15737              
15738             sub readChildren {
15739 0     0     my $o = shift;
15740 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
15741              
15742 0           while (1) {
15743             # Flags
15744 0   0       my $flags = $o->readUnsigned8 // return;
15745              
15746             # Data
15747 0           my $length = $flags & 0x1f;
15748 0 0 0       my $byteLength = $length == 30 ? 30 + ($o->readUnsigned8 // return) : $length == 31 ? ($o->readUnsigned64 // return) : $length;
    0 0        
15749 0           my $bytes = $o->readBytes($byteLength);
15750 0 0 0       my $hash = $flags & 0x20 ? $o->{object}->hashAtIndex($o->readUnsigned32 // return) : undef;
15751 0 0         return if $o->{hasError};
15752              
15753             # Children
15754 0           my $child = $record->add($bytes, $hash);
15755 0 0 0       return if $flags & 0x40 && ! $o->readChildren($child);
15756 0 0         return 1 if ! ($flags & 0x80);
15757             }
15758             }
15759              
15760             sub use {
15761 0     0     my $o = shift;
15762 0           my $length = shift;
15763              
15764 0           my $start = $o->{pos};
15765 0           $o->{pos} += $length;
15766 0 0         return substr($o->{data}, $start, $length) if $o->{pos} <= length $o->{data};
15767 0           $o->{hasError} = 1;
15768 0           return;
15769             }
15770              
15771             sub readUnsigned8 {
15772 0     0     my $o = shift;
15773 0   0       unpack('C', $o->use(1) // return) }
15774             sub readUnsigned32 {
15775 0     0     my $o = shift;
15776 0   0       unpack('L>', $o->use(4) // return) }
15777             sub readUnsigned64 {
15778 0     0     my $o = shift;
15779 0   0       unpack('Q>', $o->use(8) // return) }
15780             sub readBytes {
15781 0     0     my $o = shift;
15782 0           my $length = shift;
15783 0           $o->use($length) }
15784             sub trailer {
15785 0     0     my $o = shift;
15786 0           substr($o->{data}, $o->{pos}) }
15787              
15788             package CDS::RecordWriter;
15789              
15790             sub new {
15791 0     0     my $class = shift;
15792              
15793 0           return bless {
15794             hashesCount => 0,
15795             hashes => '',
15796             data => ''
15797             };
15798             }
15799              
15800             sub header {
15801 0     0     my $o = shift;
15802 0           pack('L>', $o->{hashesCount}).$o->{hashes} }
15803 0     0     sub data { shift->{data} }
15804              
15805             sub writeChildren {
15806 0     0     my $o = shift;
15807 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
15808              
15809 0           my @children = @{$record->{children}};
  0            
15810 0 0         return if ! scalar @children;
15811 0           my $lastChild = pop @children;
15812 0           for my $child (@children) { $o->writeNode($child, 1); }
  0            
15813 0           $o->writeNode($lastChild, 0);
15814             }
15815              
15816             sub writeNode {
15817 0     0     my $o = shift;
15818 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
15819 0           my $hasMoreSiblings = shift;
15820              
15821             # Flags
15822 0           my $byteLength = length $record->{bytes};
15823 0 0         my $flags = $byteLength < 30 ? $byteLength : $byteLength < 286 ? 30 : 31;
    0          
15824 0 0         $flags |= 0x20 if defined $record->{hash};
15825 0           my $countChildren = scalar @{$record->{children}};
  0            
15826 0 0         $flags |= 0x40 if $countChildren;
15827 0 0         $flags |= 0x80 if $hasMoreSiblings;
15828 0           $o->writeUnsigned8($flags);
15829              
15830             # Data
15831 0 0         $o->writeUnsigned8($byteLength - 30) if ($flags & 0x1f) == 30;
15832 0 0         $o->writeUnsigned64($byteLength) if ($flags & 0x1f) == 31;
15833 0           $o->writeBytes($record->{bytes});
15834 0 0         $o->writeUnsigned32($o->addHash($record->{hash})) if $flags & 0x20;
15835              
15836             # Children
15837 0           $o->writeChildren($record);
15838             }
15839              
15840             sub writeUnsigned8 {
15841 0     0     my $o = shift;
15842 0           my $value = shift;
15843 0           $o->{data} .= pack('C', $value) }
15844             sub writeUnsigned32 {
15845 0     0     my $o = shift;
15846 0           my $value = shift;
15847 0           $o->{data} .= pack('L>', $value) }
15848             sub writeUnsigned64 {
15849 0     0     my $o = shift;
15850 0           my $value = shift;
15851 0           $o->{data} .= pack('Q>', $value) }
15852              
15853             sub writeBytes {
15854 0     0     my $o = shift;
15855 0           my $bytes = shift;
15856              
15857 0 0         warn $bytes.' is a utf8 string, not a byte string.' if utf8::is_utf8($bytes);
15858 0           $o->{data} .= $bytes;
15859             }
15860              
15861             sub addHash {
15862 0     0     my $o = shift;
15863 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
15864              
15865 0           my $index = $o->{hashesCount};
15866 0           $o->{hashes} .= $hash->bytes;
15867 0           $o->{hashesCount} += 1;
15868 0           return $index;
15869             }
15870              
15871             package CDS::RootDocument;
15872              
15873 1     1   14842 use parent -norequire, 'CDS::Document';
  1         3  
  1         5  
15874              
15875             sub new {
15876 0     0     my $class = shift;
15877 0           my $privateRoot = shift;
15878 0           my $label = shift;
15879              
15880 0           my $o = $class->SUPER::new($privateRoot->privateBoxReader->keyPair, $privateRoot->unsaved);
15881 0           $o->{privateRoot} = $privateRoot;
15882 0           $o->{label} = $label;
15883 0           $privateRoot->addDataHandler($label, $o);
15884              
15885             # State
15886 0           $o->{dataSharingMessage} = undef;
15887 0           return $o;
15888             }
15889              
15890 0     0     sub privateRoot { shift->{privateRoot} }
15891 0     0     sub label { shift->{label} }
15892              
15893             sub savingDone {
15894 0     0     my $o = shift;
15895 0           my $revision = shift;
15896 0           my $newPart = shift;
15897 0           my $obsoleteParts = shift;
15898              
15899 0           $o->{privateRoot}->unsaved->state->merge($o->{unsaved}->savingState);
15900 0           $o->{unsaved}->savingDone;
15901 0 0 0       $o->{privateRoot}->dataChanged if $newPart || scalar @$obsoleteParts;
15902             }
15903              
15904             sub addDataTo {
15905 0     0     my $o = shift;
15906 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
15907              
15908 0           for my $part (sort { $a->{hashAndKey}->hash->bytes cmp $b->{hashAndKey}->hash->bytes } values %{$o->{parts}}) {
  0            
  0            
15909 0           $record->addHashAndKey($part->{hashAndKey});
15910             }
15911             }
15912             sub mergeData {
15913 0     0     my $o = shift;
15914 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
15915              
15916 0           my @hashesAndKeys;
15917 0           for my $child ($record->children) {
15918 0   0       push @hashesAndKeys, $child->asHashAndKey // next;
15919             }
15920              
15921 0           $o->merge(@hashesAndKeys);
15922             }
15923              
15924             sub mergeExternalData {
15925 0     0     my $o = shift;
15926 0           my $store = shift;
15927 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
15928 0 0 0       my $source = shift; die 'wrong type '.ref($source).' for $source' if defined $source && ref $source ne 'CDS::Source';
  0            
15929              
15930 0           my @hashes;
15931             my @hashesAndKeys;
15932 0           for my $child ($record->children) {
15933 0   0       my $hashAndKey = $child->asHashAndKey // next;
15934 0 0         next if $o->{parts}->{$hashAndKey->hash->bytes};
15935 0           push @hashes, $hashAndKey->hash;
15936 0           push @hashesAndKeys, $hashAndKey;
15937             }
15938              
15939 0           my ($missing, $transferStore, $storeError) = $o->{keyPair}->transfer([@hashes], $store, $o->{privateRoot}->unsaved);
15940 0 0         return if defined $storeError;
15941 0 0         return if $missing;
15942              
15943 0 0         if ($source) {
15944 0           $source->keep;
15945 0           $o->{privateRoot}->unsaved->state->addMergedSource($source);
15946             }
15947              
15948 0           $o->merge(@hashesAndKeys);
15949 0           return 1;
15950             }
15951              
15952             package CDS::Selector;
15953              
15954             sub root {
15955 0     0     my $class = shift;
15956 0           my $document = shift;
15957              
15958 0           return bless {document => $document, id => 'ROOT', label => ''};
15959             }
15960              
15961 0     0     sub document { shift->{document} }
15962 0     0     sub parent { shift->{parent} }
15963 0     0     sub label { shift->{label} }
15964              
15965             sub child {
15966 0     0     my $o = shift;
15967 0           my $label = shift;
15968              
15969             return bless {
15970             document => $o->{document},
15971 0           id => $o->{id}.'/'.unpack('H*', $label),
15972             parent => $o,
15973             label => $label,
15974             };
15975             }
15976              
15977             sub childWithText {
15978 0     0     my $o = shift;
15979 0           my $label = shift;
15980              
15981 0   0       return $o->child(Encode::encode_utf8($label // ''));
15982             }
15983              
15984             sub children {
15985 0     0     my $o = shift;
15986              
15987 0   0       my $item = $o->{document}->get($o) // return;
15988 0           return map { $_->{selector} } @{$item->{children}};
  0            
  0            
15989             }
15990              
15991             # Value
15992              
15993             sub revision {
15994 0     0     my $o = shift;
15995              
15996 0   0       my $item = $o->{document}->get($o) // return 0;
15997 0           return $item->{revision};
15998             }
15999              
16000             sub isSet {
16001 0     0     my $o = shift;
16002              
16003 0   0       my $item = $o->{document}->get($o) // return;
16004 0           return scalar $item->{record}->children > 0;
16005             }
16006              
16007             sub record {
16008 0     0     my $o = shift;
16009              
16010 0   0       my $item = $o->{document}->get($o) // return CDS::Record->new;
16011 0           return $item->{record};
16012             }
16013              
16014             sub set {
16015 0     0     my $o = shift;
16016 0 0 0       my $record = shift // return; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0   0        
16017              
16018 0           my $now = CDS->now;
16019 0           my $item = $o->{document}->getOrCreate($o);
16020 0 0         $item->mergeValue($o->{document}->{changes}, $item->{revision} >= $now ? $item->{revision} + 1 : $now, $record);
16021             }
16022              
16023             sub merge {
16024 0     0     my $o = shift;
16025 0           my $revision = shift;
16026 0 0 0       my $record = shift // return; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0   0        
16027              
16028 0           my $item = $o->{document}->getOrCreate($o);
16029 0           return $item->mergeValue($o->{document}->{changes}, $revision, $record);
16030             }
16031              
16032             sub clear {
16033 0     0     my $o = shift;
16034 0           $o->set(CDS::Record->new) }
16035              
16036             sub clearInThePast {
16037 0     0     my $o = shift;
16038              
16039 0 0         $o->merge($o->revision + 1, CDS::Record->new) if $o->isSet;
16040             }
16041              
16042             sub forget {
16043 0     0     my $o = shift;
16044              
16045 0   0       my $item = $o->{document}->get($o) // return;
16046 0           $item->forget;
16047             }
16048              
16049             sub forgetBranch {
16050 0     0     my $o = shift;
16051              
16052 0           for my $child ($o->children) { $child->forgetBranch; }
  0            
16053 0           $o->forget;
16054             }
16055              
16056             # Convenience methods (simple interface)
16057              
16058             sub firstValue {
16059 0     0     my $o = shift;
16060              
16061 0   0       my $item = $o->{document}->get($o) // return CDS::Record->new;
16062 0           return $item->{record}->firstChild;
16063             }
16064              
16065             sub bytesValue {
16066 0     0     my $o = shift;
16067 0           $o->firstValue->bytes }
16068             sub hashValue {
16069 0     0     my $o = shift;
16070 0           $o->firstValue->hash }
16071             sub textValue {
16072 0     0     my $o = shift;
16073 0           $o->firstValue->asText }
16074             sub booleanValue {
16075 0     0     my $o = shift;
16076 0           $o->firstValue->asBoolean }
16077             sub integerValue {
16078 0     0     my $o = shift;
16079 0           $o->firstValue->asInteger }
16080             sub unsignedValue {
16081 0     0     my $o = shift;
16082 0           $o->firstValue->asUnsigned }
16083             sub floatValue {
16084 0     0     my $o = shift;
16085 0           $o->firstValue->asFloat }
16086             sub hashAndKeyValue {
16087 0     0     my $o = shift;
16088 0           $o->firstValue->asHashAndKey }
16089              
16090             # Sets a new value unless the node has that value already.
16091             sub setBytes {
16092 0     0     my $o = shift;
16093 0           my $bytes = shift;
16094 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16095              
16096 0           my $record = CDS::Record->new;
16097 0           $record->add($bytes, $hash);
16098 0           $o->set($record);
16099             }
16100              
16101             sub setHash {
16102 0     0     my $o = shift;
16103 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16104 0           $o->setBytes('', $hash); };
16105             sub setText {
16106 0     0     my $o = shift;
16107 0           my $value = shift;
16108 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16109 0           $o->setBytes(Encode::encode_utf8($value), $hash); };
16110             sub setBoolean {
16111 0     0     my $o = shift;
16112 0           my $value = shift;
16113 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16114 0           $o->setBytes(CDS->bytesFromBoolean($value), $hash); };
16115             sub setInteger {
16116 0     0     my $o = shift;
16117 0           my $value = shift;
16118 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16119 0           $o->setBytes(CDS->bytesFromInteger($value), $hash); };
16120             sub setUnsigned {
16121 0     0     my $o = shift;
16122 0           my $value = shift;
16123 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16124 0           $o->setBytes(CDS->bytesFromUnsigned($value), $hash); };
16125             sub setFloat32 {
16126 0     0     my $o = shift;
16127 0           my $value = shift;
16128 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16129 0           $o->setBytes(CDS->bytesFromFloat32($value), $hash); };
16130             sub setFloat64 {
16131 0     0     my $o = shift;
16132 0           my $value = shift;
16133 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16134 0           $o->setBytes(CDS->bytesFromFloat64($value), $hash); };
16135             sub setHashAndKey {
16136 0     0     my $o = shift;
16137 0 0 0       my $hashAndKey = shift; die 'wrong type '.ref($hashAndKey).' for $hashAndKey' if defined $hashAndKey && ref $hashAndKey ne 'CDS::HashAndKey';
  0            
16138 0           $o->setBytes($hashAndKey->key, $hashAndKey->hash); };
16139              
16140             # Adding objects and merged sources
16141              
16142             sub addObject {
16143 0     0     my $o = shift;
16144 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16145 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
16146              
16147 0           $o->{document}->{unsaved}->state->addObject($hash, $object);
16148             }
16149              
16150             sub addMergedSource {
16151 0     0     my $o = shift;
16152 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16153              
16154 0           $o->{document}->{unsaved}->state->addMergedSource($hash);
16155             }
16156              
16157             package CDS::SentItem;
16158              
16159 1     1   2396 use parent -norequire, 'CDS::UnionList::Item';
  1         2  
  1         5  
16160              
16161             sub new {
16162 0     0     my $class = shift;
16163 0           my $unionList = shift;
16164 0           my $id = shift;
16165              
16166 0           my $o = $class->SUPER::new($unionList, $id);
16167 0           $o->{validUntil} = 0;
16168 0           $o->{message} = CDS::Record->new;
16169 0           return $o;
16170             }
16171              
16172 0     0     sub validUntil { shift->{validUntil} }
16173             sub envelopeHash {
16174 0     0     my $o = shift;
16175 0           CDS::Hash->fromBytes($o->{message}->bytes) }
16176             sub envelopeHashBytes {
16177 0     0     my $o = shift;
16178 0           $o->{message}->bytes }
16179 0     0     sub message { shift->{message} }
16180              
16181             sub addToRecord {
16182 0     0     my $o = shift;
16183 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
16184              
16185 0           $record->add($o->{id})->addInteger($o->{validUntil})->addRecord($o->{message});
16186             }
16187              
16188             sub set {
16189 0     0     my $o = shift;
16190 0           my $validUntil = shift;
16191 0 0 0       my $envelopeHash = shift; die 'wrong type '.ref($envelopeHash).' for $envelopeHash' if defined $envelopeHash && ref $envelopeHash ne 'CDS::Hash';
  0            
16192 0 0 0       my $messageRecord = shift; die 'wrong type '.ref($messageRecord).' for $messageRecord' if defined $messageRecord && ref $messageRecord ne 'CDS::Record';
  0            
16193              
16194 0           my $message = CDS::Record->new($envelopeHash->bytes);
16195 0           $message->addRecord($messageRecord->children);
16196 0           $o->merge($o->{unionList}->{changes}, CDS->max($validUntil, $o->{validUntil} + 1), $message);
16197             }
16198              
16199             sub clear {
16200 0     0     my $o = shift;
16201 0           my $validUntil = shift;
16202              
16203 0           $o->merge($o->{unionList}->{changes}, CDS->max($validUntil, $o->{validUntil} + 1), CDS::Record->new);
16204             }
16205              
16206             sub merge {
16207 0     0     my $o = shift;
16208 0           my $part = shift;
16209 0           my $validUntil = shift;
16210 0           my $message = shift;
16211              
16212 0 0         return if $o->{validUntil} > $validUntil;
16213 0 0 0       return if $o->{validUntil} == $validUntil && $part->{size} < $o->{part}->{size};
16214 0           $o->{validUntil} = $validUntil;
16215 0           $o->{message} = $message;
16216 0           $o->setPart($part);
16217             }
16218              
16219             package CDS::SentList;
16220              
16221 1     1   595 use parent -norequire, 'CDS::UnionList';
  1         3  
  1         4  
16222              
16223             sub new {
16224 0     0     my $class = shift;
16225 0           my $privateRoot = shift;
16226              
16227 0           return $class->SUPER::new($privateRoot, 'sent list');
16228             }
16229              
16230             sub createItem {
16231 0     0     my $o = shift;
16232 0           my $id = shift;
16233              
16234 0           return CDS::SentItem->new($o, $id);
16235             }
16236              
16237             sub mergeRecord {
16238 0     0     my $o = shift;
16239 0           my $part = shift;
16240 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
16241              
16242 0           my $item = $o->getOrCreate($record->bytes);
16243 0           for my $child ($record->children) {
16244 0           my $validUntil = $child->asInteger;
16245 0           my $message = $child->firstChild;
16246 0           $item->merge($part, $validUntil, $message);
16247             }
16248             }
16249              
16250             sub forgetObsoleteItems {
16251 0     0     my $o = shift;
16252              
16253 0           my $now = CDS->now;
16254 0           my $toDelete = [];
16255 0           for my $item (values %{$o->{items}}) {
  0            
16256 0 0         next if $item->{validUntil} >= $now;
16257 0           $o->forgetItem($item);
16258             }
16259             }
16260              
16261             package CDS::Source;
16262              
16263             sub new {
16264 0     0     my $class = shift;
16265 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
16266 0 0 0       my $actorOnStore = shift; die 'wrong type '.ref($actorOnStore).' for $actorOnStore' if defined $actorOnStore && ref $actorOnStore ne 'CDS::ActorOnStore';
  0            
16267 0           my $boxLabel = shift;
16268 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16269              
16270 0           return bless {
16271             keyPair => $keyPair,
16272             actorOnStore => $actorOnStore,
16273             boxLabel => $boxLabel,
16274             hash => $hash,
16275             referenceCount => 1,
16276             };
16277             }
16278              
16279 0     0     sub keyPair { shift->{keyPair} }
16280 0     0     sub actorOnStore { shift->{actorOnStore} }
16281 0     0     sub boxLabel { shift->{boxLabel} }
16282 0     0     sub hash { shift->{hash} }
16283 0     0     sub referenceCount { shift->{referenceCount} }
16284              
16285             sub keep {
16286 0     0     my $o = shift;
16287              
16288 0 0         if ($o->{referenceCount} < 1) {
16289 0           warn 'The source '.$o->{actorOnStore}->publicKey->hash->hex.'/'.$o->{boxLabel}.'/'.$o->{hash}->hex.' has already been discarded, and cannot be kept any more.';
16290 0           return;
16291             }
16292              
16293 0           $o->{referenceCount} += 1;
16294             }
16295              
16296             sub discard {
16297 0     0     my $o = shift;
16298              
16299 0 0         if ($o->{referenceCount} < 1) {
16300 0           warn 'The source '.$o->{actorOnStore}->publicKey->hash->hex.'/'.$o->{boxLabel}.'/'.$o->{hash}->hex.' has already been discarded, and cannot be discarded again.';
16301 0           return;
16302             }
16303              
16304 0           $o->{referenceCount} -= 1;
16305 0 0         return if $o->{referenceCount} > 0;
16306              
16307 0           $o->{actorOnStore}->store->remove($o->{actorOnStore}->publicKey->hash, $o->{boxLabel}, $o->{hash}, $o->{keyPair});
16308             }
16309              
16310             # A store mapping objects and accounts to a group of stores.
16311             package CDS::SplitStore;
16312              
16313 1     1   715 use parent -norequire, 'CDS::Store';
  1         3  
  1         4  
16314              
16315             sub new {
16316 0     0     my $class = shift;
16317 0           my $key = shift;
16318              
16319 0           return bless {
16320             id => 'Split Store\n'.unpack('H*', CDS::C::aesCrypt(CDS->zeroCTR, $key, CDS->zeroCTR)),
16321             key => $key,
16322             accountStores => [],
16323             objectStores => [],
16324             };
16325             }
16326              
16327 0     0     sub id { shift->{id} }
16328              
16329             ### Store configuration
16330              
16331             sub assignAccounts {
16332 0     0     my $o = shift;
16333 0           my $fromIndex = shift;
16334 0           my $toIndex = shift;
16335 0           my $store = shift;
16336              
16337 0           for my $i ($fromIndex .. $toIndex) {
16338 0           $o->{accountStores}->[$i] = $store;
16339             }
16340             }
16341              
16342             sub assignObjects {
16343 0     0     my $o = shift;
16344 0           my $fromIndex = shift;
16345 0           my $toIndex = shift;
16346 0           my $store = shift;
16347              
16348 0           for my $i ($fromIndex .. $toIndex) {
16349 0           $o->{objectStores}->[$i] = $store;
16350             }
16351             }
16352              
16353             sub objectStore {
16354 0     0     my $o = shift;
16355 0           my $index = shift;
16356 0           $o->{objectStores}->[$index] }
16357             sub accountStore {
16358 0     0     my $o = shift;
16359 0           my $index = shift;
16360 0           $o->{accountStores}->[$index] }
16361              
16362             ### Hash encryption
16363              
16364             our $zeroCounter = "\0" x 16;
16365              
16366             sub storeIndex {
16367 0     0     my $o = shift;
16368 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16369              
16370             # To avoid attacks on a single store, the hash is encrypted with a key known to the operator only
16371 0           my $encryptedBytes = CDS::C::aesCrypt(substr($hash->bytes, 0, 16), $o->{key}, $zeroCounter);
16372              
16373             # Use the first byte as store index
16374 0           return ord(substr($encryptedBytes, 0, 1));
16375             }
16376              
16377             ### Store interface
16378              
16379             sub get {
16380 0     0     my $o = shift;
16381 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16382 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
16383              
16384 0   0       my $store = $o->objectStore($o->storeIndex($hash)) // return undef, 'No store assigned.';
16385 0           return $store->get($hash, $keyPair);
16386             }
16387              
16388             sub put {
16389 0     0     my $o = shift;
16390 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16391 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
16392 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
16393              
16394 0   0       my $store = $o->objectStore($o->storeIndex($hash)) // return undef, 'No store assigned.';
16395 0           return $store->put($hash, $object, $keyPair);
16396             }
16397              
16398             sub book {
16399 0     0     my $o = shift;
16400 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16401 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
16402              
16403 0   0       my $store = $o->objectStore($o->storeIndex($hash)) // return undef, 'No store assigned.';
16404 0           return $store->book($hash, $keyPair);
16405             }
16406              
16407             sub list {
16408 0     0     my $o = shift;
16409 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
16410 0           my $boxLabel = shift;
16411 0           my $timeout = shift;
16412 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
16413              
16414 0   0       my $store = $o->accountStore($o->storeIndex($accountHash)) // return undef, 'No store assigned.';
16415 0           return $store->list($accountHash, $boxLabel, $timeout, $keyPair);
16416             }
16417              
16418             sub add {
16419 0     0     my $o = shift;
16420 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
16421 0           my $boxLabel = shift;
16422 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16423 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
16424              
16425 0   0       my $store = $o->accountStore($o->storeIndex($accountHash)) // return 'No store assigned.';
16426 0           return $store->add($accountHash, $boxLabel, $hash, $keyPair);
16427             }
16428              
16429             sub remove {
16430 0     0     my $o = shift;
16431 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
16432 0           my $boxLabel = 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 $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
16435              
16436 0   0       my $store = $o->accountStore($o->storeIndex($accountHash)) // return 'No store assigned.';
16437 0           return $store->remove($accountHash, $boxLabel, $hash, $keyPair);
16438             }
16439              
16440             sub modify {
16441 0     0     my $o = shift;
16442 0           my $modifications = shift;
16443 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
16444              
16445             # Put objects
16446 0           my %objectsByStoreId;
16447 0           for my $entry (values %{$modifications->objects}) {
  0            
16448 0           my $store = $o->objectStore($o->storeIndex($entry->{hash}));
16449 0           my $target = $objectsByStoreId{$store->id};
16450 0           $objectsByStoreId{$store->id} = $target = {store => $store, modifications => CDS::StoreModifications->new};
16451 0           $target->modifications->put($entry->{hash}, $entry->{object});
16452             }
16453              
16454 0           for my $item (values %objectsByStoreId) {
16455 0           my $error = $item->{store}->modify($item->{modifications}, $keyPair);
16456 0 0         return $error if $error;
16457             }
16458              
16459             # Add box entries
16460 0           my %additionsByStoreId;
16461 0           for my $operation (@{$modifications->additions}) {
  0            
16462 0           my $store = $o->accountStore($o->storeIndex($operation->{accountHash}));
16463 0           my $target = $additionsByStoreId{$store->id};
16464 0           $additionsByStoreId{$store->id} = $target = {store => $store, modifications => CDS::StoreModifications->new};
16465 0           $target->modifications->add($operation->{accountHash}, $operation->{boxLabel}, $operation->{hash});
16466             }
16467              
16468 0           for my $item (values %additionsByStoreId) {
16469 0           my $error = $item->{store}->modify($item->{modifications}, $keyPair);
16470 0 0         return $error if $error;
16471             }
16472              
16473             # Remove box entries (but ignore errors)
16474 0           my %removalsByStoreId;
16475 0           for my $operation (@$modifications->removals) {
16476 0           my $store = $o->accountStore($o->storeIndex($operation->{accountHash}));
16477 0           my $target = $removalsByStoreId{$store->id};
16478 0           $removalsByStoreId{$store->id} = $target = {store => $store, modifications => CDS::StoreModifications->new};
16479 0           $target->modifications->add($operation->{accountHash}, $operation->{boxLabel}, $operation->{hash});
16480             }
16481              
16482 0           for my $item (values %removalsByStoreId) {
16483 0           $item->{store}->modify($item->{modifications}, $keyPair);
16484             }
16485              
16486 0           return;
16487             }
16488              
16489             # General
16490             # sub id($o) # () => String
16491             package CDS::Store;
16492              
16493             # Object store functions
16494             # sub get($o, $hash, $keyPair) # Hash, KeyPair? => Object?, String?
16495             # sub put($o, $hash, $object, $keyPair) # Hash, Object, KeyPair? => String?
16496             # sub book($o, $hash, $keyPair) # Hash, KeyPair? => 1?, String?
16497              
16498             # Account store functions
16499             # sub list($o, $accountHash, $boxLabel, $timeout, $keyPair) # Hash, String, Duration, KeyPair? => @$Hash, String?
16500             # sub add($o, $accountHash, $boxLabel, $hash, $keyPair) # Hash, String, Hash, KeyPair? => String?
16501             # sub remove($o, $accountHash, $boxLabel, $hash, $keyPair) # Hash, String, Hash, KeyPair? => String?
16502             # sub modify($o, $storeModifications, $keyPair) # StoreModifications, KeyPair? => String?
16503              
16504             package CDS::StoreModifications;
16505              
16506             sub new {
16507 0     0     my $class = shift;
16508              
16509 0           return bless {
16510             objects => {},
16511             additions => [],
16512             removals => [],
16513             };
16514             }
16515              
16516 0     0     sub objects { shift->{objects} }
16517 0     0     sub additions { shift->{additions} }
16518 0     0     sub removals { shift->{removals} }
16519              
16520             sub isEmpty {
16521 0     0     my $o = shift;
16522              
16523 0 0         return if scalar keys %{$o->{objects}};
  0            
16524 0 0         return if scalar @{$o->{additions}};
  0            
16525 0 0         return if scalar @{$o->{removals}};
  0            
16526 0           return 1;
16527             }
16528              
16529             sub put {
16530 0     0     my $o = shift;
16531 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16532 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
16533              
16534 0           $o->{objects}->{$hash->bytes} = {hash => $hash, object => $object};
16535             }
16536              
16537             sub add {
16538 0     0     my $o = shift;
16539 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
16540 0           my $boxLabel = shift;
16541 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16542 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
16543              
16544 0 0         $o->put($hash, $object) if $object;
16545 0           push @{$o->{additions}}, {accountHash => $accountHash, boxLabel => $boxLabel, hash => $hash};
  0            
16546             }
16547              
16548             sub remove {
16549 0     0     my $o = shift;
16550 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
16551 0           my $boxLabel = shift;
16552 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16553              
16554 0           push @{$o->{removals}}, {accountHash => $accountHash, boxLabel => $boxLabel, hash => $hash};
  0            
16555             }
16556              
16557             # Returns a text representation of box additions and removals.
16558             sub toRecord {
16559 0     0     my $o = shift;
16560              
16561 0           my $record = CDS::Record->new;
16562              
16563             # Objects
16564 0           my $objectsRecord = $record->add('put');
16565 0           for my $entry (values %{$o->{objects}}) {
  0            
16566 0           $objectsRecord->add($entry->{hash}->bytes)->add($entry->{object}->bytes);
16567             }
16568              
16569             # Box additions and removals
16570 0           &addEntriesToRecord($o->{additions}, $record->add('add'));
16571 0           &addEntriesToRecord($o->{removals}, $record->add('remove'));
16572              
16573 0           return $record;
16574             }
16575              
16576             sub addEntriesToRecord {
16577 0     0     my $unsortedEntries = shift;
16578 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
16579             # private
16580 0 0         my @additions = sort { ($a->{accountHash}->bytes cmp $b->{accountHash}->bytes) || ($a->{boxLabel} cmp $b->{boxLabel}) } @$unsortedEntries;
  0            
16581 0           my $entry = shift @additions;
16582 0           while (defined $entry) {
16583 0           my $accountHash = $entry->{accountHash};
16584 0           my $accountRecord = $record->add($accountHash->bytes);
16585              
16586 0   0       while (defined $entry && $entry->{accountHash}->bytes eq $accountHash->bytes) {
16587 0           my $boxLabel = $entry->{boxLabel};
16588 0           my $boxRecord = $accountRecord->add($boxLabel);
16589              
16590 0   0       while (defined $entry && $entry->{boxLabel} eq $boxLabel) {
16591 0           $boxRecord->add($entry->{hash}->bytes);
16592 0           $entry = shift @additions;
16593             }
16594             }
16595             }
16596             }
16597              
16598             sub fromBytes {
16599 0     0     my $class = shift;
16600 0           my $bytes = shift;
16601              
16602 0   0       my $object = CDS::Object->fromBytes($bytes) // return;
16603 0   0       my $record = CDS::Record->fromObject($object) // return;
16604 0           return $class->fromRecord($record);
16605             }
16606              
16607             sub fromRecord {
16608 0     0     my $class = shift;
16609 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
16610              
16611 0           my $modifications = $class->new;
16612              
16613             # Read objects (and "envelopes" entries used before 2022-01)
16614 0           for my $objectRecord ($record->child('put')->children, $record->child('envelopes')->children) {
16615 0   0       my $hash = CDS::Hash->fromBytes($objectRecord->bytes) // return;
16616 0   0       my $object = CDS::Object->fromBytes($objectRecord->firstChild->bytes) // return;
16617             #return if $o->{checkEnvelopeHash} && ! $object->calculateHash->equals($hash);
16618 0           $modifications->put($hash, $object);
16619             }
16620              
16621             # Read additions and removals
16622 0   0       &readEntriesFromRecord($modifications->{additions}, $record->child('add')) // return;
16623 0   0       &readEntriesFromRecord($modifications->{removals}, $record->child('remove')) // return;
16624              
16625 0           return $modifications;
16626             }
16627              
16628             sub readEntriesFromRecord {
16629 0     0     my $entries = shift;
16630 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
16631             # private
16632 0           for my $accountHashRecord ($record->children) {
16633 0   0       my $accountHash = CDS::Hash->fromBytes($accountHashRecord->bytes) // return;
16634 0           for my $boxLabelRecord ($accountHashRecord->children) {
16635 0           my $boxLabel = $boxLabelRecord->bytes;
16636 0 0         return if ! CDS->isValidBoxLabel($boxLabel);
16637              
16638 0           for my $hashRecord ($boxLabelRecord->children) {
16639 0   0       my $hash = CDS::Hash->fromBytes($hashRecord->bytes) // return;
16640 0           push @$entries, {accountHash => $accountHash, boxLabel => $boxLabel, hash => $hash};
16641             }
16642             }
16643             }
16644              
16645 0           return 1;
16646             }
16647              
16648             sub executeIndividually {
16649 0     0     my $o = shift;
16650 0           my $store = shift;
16651 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
16652              
16653             # Process objects
16654 0           for my $entry (values %{$o->{objects}}) {
  0            
16655 0           my $error = $store->put($entry->{hash}, $entry->{object}, $keyPair);
16656 0 0         return $error if $error;
16657             }
16658              
16659             # Process additions
16660 0           for my $entry (@{$o->{additions}}) {
  0            
16661 0           my $error = $store->add($entry->{accountHash}, $entry->{boxLabel}, $entry->{hash}, $keyPair);
16662 0 0         return $error if $error;
16663             }
16664              
16665             # Process removals (and ignore errors)
16666 0           for my $entry (@{$o->{removals}}) {
  0            
16667 0           $store->remove($entry->{accountHash}, $entry->{boxLabel}, $entry->{hash}, $keyPair);
16668             }
16669              
16670 0           return;
16671             }
16672              
16673             sub needsSignature {
16674 0     0     my $o = shift;
16675              
16676 0 0         return 0 if scalar @{$o->{removals}};
  0            
16677              
16678 0           for my $addition (@{$o->{additions}}) {
  0            
16679 0 0         return 1 if $addition->{boxLabel} ne 'messages';
16680             }
16681              
16682 0           return 0;
16683             }
16684              
16685             package CDS::StreamCache;
16686              
16687             sub new {
16688 0     0     my $class = shift;
16689 0           my $pool = shift;
16690 0 0 0       my $actorOnStore = shift; die 'wrong type '.ref($actorOnStore).' for $actorOnStore' if defined $actorOnStore && ref $actorOnStore ne 'CDS::ActorOnStore';
  0            
16691 0           my $timeout = shift;
16692              
16693 0           return bless {
16694             pool => $pool,
16695             actorOnStore => $actorOnStore,
16696             timeout => $timeout,
16697             cache => {},
16698             };
16699             }
16700              
16701 0     0     sub messageBoxReader { shift->{messageBoxReader} }
16702              
16703             sub removeObsolete {
16704 0     0     my $o = shift;
16705              
16706 0           my $limit = CDS->now - $o->{timeout};
16707 0           for my $key (%{$o->{knownStreamHeads}}) {
  0            
16708 0   0       my $streamHead = $o->{knownStreamHeads}->{$key} // next;
16709 0 0         next if $streamHead->lastUsed < $limit;
16710 0           delete $o->{knownStreamHeads}->{$key};
16711             }
16712             }
16713              
16714             sub readStreamHead {
16715 0     0     my $o = shift;
16716 0           my $head = shift;
16717              
16718 0           my $streamHead = $o->{knownStreamHeads}->{$head->hex};
16719 0 0         if ($streamHead) {
16720 0           $streamHead->stillInUse;
16721 0           return $streamHead;
16722             }
16723              
16724             # Retrieve the head envelope
16725 0           my ($object, $getError) = $o->{actorOnStore}->store->get($head, $o->{pool}->{keyPair});
16726 0 0         return if defined $getError;
16727              
16728             # Parse the head envelope
16729 0           my $envelope = CDS::Record->fromObject($object);
16730 0 0         return $o->invalid($head, 'Not a record.') if ! $envelope;
16731              
16732             # Read the embedded content object
16733 0           my $encryptedBytes = $envelope->child('content')->bytesValue;
16734 0 0         return $o->invalid($head, 'Missing content object.') if ! length $encryptedBytes;
16735              
16736             # Decrypt the key
16737 0           my $aesKey = $o->{pool}->{keyPair}->decryptKeyOnEnvelope($envelope);
16738 0 0         return $o->invalid($head, 'Not encrypted for us.') if ! $aesKey;
16739              
16740             # Decrypt the content
16741 0           my $contentObject = CDS::Object->fromBytes(CDS::C::aesCrypt($encryptedBytes, $aesKey, CDS->zeroCTR));
16742 0 0         return $o->invalid($head, 'Invalid content object.') if ! $contentObject;
16743              
16744 0           my $content = CDS::Record->fromObject($contentObject);
16745 0 0         return $o->invalid($head, 'Content object is not a record.') if ! $content;
16746              
16747             # Verify the sender hash
16748 0           my $senderHash = $content->child('sender')->hashValue;
16749 0 0         return $o->invalid($head, 'Missing sender hash.') if ! $senderHash;
16750              
16751             # Verify the sender store
16752 0           my $storeRecord = $content->child('store');
16753 0 0         return $o->invalid($head, 'Missing sender store.') if ! scalar $storeRecord->children;
16754              
16755 0           my $senderStoreUrl = $storeRecord->textValue;
16756 0           my $senderStore = $o->{pool}->{delegate}->onMessageBoxVerifyStore($senderStoreUrl, $head, $envelope, $senderHash);
16757 0 0         return $o->invalid($head, 'Invalid sender store.') if ! $senderStore;
16758              
16759             # Retrieve the sender's public key
16760 0           my ($senderPublicKey, $invalidReason, $publicKeyStoreError) = $o->getPublicKey($senderHash, $senderStore);
16761 0 0         return if defined $publicKeyStoreError;
16762 0 0         return $o->invalid($head, 'Failed to retrieve the sender\'s public key: '.$invalidReason) if defined $invalidReason;
16763              
16764             # Verify the signature
16765 0           my $signedHash = CDS::Hash->calculateFor($encryptedBytes);
16766 0 0         return $o->invalid($head, 'Invalid signature.') if ! CDS->verifyEnvelopeSignature($envelope, $senderPublicKey, $signedHash);
16767              
16768             # The envelope is valid
16769 0           my $sender = CDS::ActorOnStore->new($senderPublicKey, $senderStore);
16770 0           my $newStreamHead = CDS::StreamHead->new($head, $envelope, $senderStoreUrl, $sender, $aesKey, $content);
16771 0           $o->{knownStreamHeads}->{$head->hex} = $newStreamHead;
16772 0           return $newStreamHead;
16773             }
16774              
16775             sub invalid {
16776 0     0     my $o = shift;
16777 0           my $head = shift;
16778 0           my $reason = shift;
16779             # private
16780 0           my $newStreamHead = CDS::StreamHead->new($head, undef, undef, undef, undef, undef, $reason);
16781 0           $o->{knownStreamHeads}->{$head->hex} = $newStreamHead;
16782 0           return $newStreamHead;
16783             }
16784              
16785             package CDS::StreamHead;
16786              
16787             sub new {
16788 0     0     my $class = shift;
16789 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
16790 0 0 0       my $envelope = shift; die 'wrong type '.ref($envelope).' for $envelope' if defined $envelope && ref $envelope ne 'CDS::Record';
  0            
16791 0           my $senderStoreUrl = shift;
16792 0           my $sender = shift;
16793 0           my $content = shift;
16794 0           my $error = shift;
16795              
16796 0           return bless {
16797             hash => $hash,
16798             envelope => $envelope,
16799             senderStoreUrl => $senderStoreUrl,
16800             sender => $sender,
16801             content => $content,
16802             error => $error,
16803             lastUsed => CDS->now,
16804             };
16805             }
16806              
16807 0     0     sub hash { shift->{hash} }
16808 0     0     sub envelope { shift->{envelope} }
16809 0     0     sub senderStoreUrl { shift->{senderStoreUrl} }
16810 0     0     sub sender { shift->{sender} }
16811 0     0     sub content { shift->{content} }
16812 0     0     sub error { shift->{error} }
16813             sub isValid {
16814 0     0     my $o = shift;
16815 0           ! defined $o->{error} }
16816 0     0     sub lastUsed { shift->{lastUsed} }
16817              
16818             sub stillInUse {
16819 0     0     my $o = shift;
16820              
16821 0           $o->{lastUsed} = CDS->now;
16822             }
16823              
16824             package CDS::SubDocument;
16825              
16826 1     1   5145 use parent -norequire, 'CDS::Document';
  1         3  
  1         4  
16827              
16828             sub new {
16829 0     0     my $class = shift;
16830 0 0 0       my $parentSelector = shift; die 'wrong type '.ref($parentSelector).' for $parentSelector' if defined $parentSelector && ref $parentSelector ne 'CDS::Selector';
  0            
16831              
16832 0           my $o = $class->SUPER::new($parentSelector->document->keyPair, $parentSelector->document->unsaved);
16833 0           $o->{parentSelector} = $parentSelector;
16834 0           return $o;
16835             }
16836              
16837 0     0     sub parentSelector { shift->{parentSelector} }
16838              
16839             sub partSelector {
16840 0     0     my $o = shift;
16841 0 0 0       my $hashAndKey = shift; die 'wrong type '.ref($hashAndKey).' for $hashAndKey' if defined $hashAndKey && ref $hashAndKey ne 'CDS::HashAndKey';
  0            
16842              
16843 0           $o->{parentSelector}->child(substr($hashAndKey->hash->bytes, 0, 16));
16844             }
16845              
16846             sub read {
16847 0     0     my $o = shift;
16848              
16849 0           $o->merge(map { $_->hashAndKeyValue } $o->{parentSelector}->children);
  0            
16850 0           return $o->SUPER::read;
16851             }
16852              
16853             sub savingDone {
16854 0     0     my $o = shift;
16855 0           my $revision = shift;
16856 0           my $newPart = shift;
16857 0           my $obsoleteParts = shift;
16858              
16859 0           $o->{parentSelector}->document->unsaved->state->merge($o->{unsaved}->savingState);
16860              
16861             # Remove obsolete parts
16862 0           for my $part (@$obsoleteParts) {
16863 0           $o->partSelector($part->{hashAndKey})->merge($revision, CDS::Record->new);
16864             }
16865              
16866             # Add the new part
16867 0 0         if ($newPart) {
16868 0           my $record = CDS::Record->new;
16869 0           $record->addHashAndKey($newPart->{hashAndKey});
16870 0           $o->partSelector($newPart->{hashAndKey})->merge($revision, $record);
16871             }
16872              
16873 0           $o->{unsaved}->savingDone;
16874             }
16875              
16876             # Useful functions to display textual information on the terminal
16877             package CDS::UI;
16878              
16879             sub new {
16880 0     0     my $class = shift;
16881 0   0       my $fileHandle = shift // *STDOUT;
16882 0           my $pure = shift;
16883              
16884 0           binmode $fileHandle, ":utf8";
16885 0           return bless {
16886             fileHandle => $fileHandle,
16887             pure => $pure,
16888             indentCount => 0,
16889             indent => '',
16890             valueIndent => 16,
16891             hasSpace => 0,
16892             hasError => 0,
16893             hasWarning => 0,
16894             };
16895             }
16896              
16897 0     0     sub fileHandle { shift->{fileHandle} }
16898              
16899             ### Indent
16900              
16901             sub pushIndent {
16902 0     0     my $o = shift;
16903              
16904 0           $o->{indentCount} += 1;
16905 0           $o->{indent} = ' ' x $o->{indentCount};
16906 0           return;
16907             }
16908              
16909             sub popIndent {
16910 0     0     my $o = shift;
16911              
16912 0           $o->{indentCount} -= 1;
16913 0           $o->{indent} = ' ' x $o->{indentCount};
16914 0           return;
16915             }
16916              
16917             sub valueIndent {
16918 0     0     my $o = shift;
16919 0           my $width = shift;
16920              
16921 0           $o->{valueIndent} = $width;
16922             }
16923              
16924             ### Low-level (non-semantic) output
16925              
16926             sub print {
16927 0     0     my $o = shift;
16928              
16929 0   0       my $fh = $o->{fileHandle} // return;
16930 0           print $fh @_;
16931             }
16932              
16933             sub raw {
16934 0     0     my $o = shift;
16935              
16936 0           $o->removeProgress;
16937 0   0       my $fh = $o->{fileHandle} // return;
16938 0           binmode $fh, ":bytes";
16939 0           print $fh @_;
16940 0           binmode $fh, ":utf8";
16941 0           $o->{hasSpace} = 0;
16942 0           return;
16943             }
16944              
16945             sub space {
16946 0     0     my $o = shift;
16947              
16948 0           $o->removeProgress;
16949 0 0         return if $o->{hasSpace};
16950 0           $o->{hasSpace} = 1;
16951 0           $o->print("\n");
16952 0           return;
16953             }
16954              
16955             # A line of text (without word-wrap).
16956             sub line {
16957 0     0     my $o = shift;
16958              
16959 0           $o->removeProgress;
16960 0           my $span = CDS::UI::Span->new(@_);
16961 0           $o->print($o->{indent});
16962 0           $span->printTo($o);
16963 0           $o->print(chr(0x1b), '[0m', "\n");
16964 0           $o->{hasSpace} = 0;
16965 0           return;
16966             }
16967              
16968             # A line of word-wrapped text.
16969             sub p {
16970 0     0     my $o = shift;
16971              
16972 0           $o->removeProgress;
16973 0           my $span = CDS::UI::Span->new(@_);
16974 0           $span->wordWrap({lineLength => 0, maxLength => 100 - length $o->{indent}, indent => $o->{indent}});
16975 0           $o->print($o->{indent});
16976 0           $span->printTo($o);
16977 0           $o->print(chr(0x1b), '[0m', "\n");
16978 0           $o->{hasSpace} = 0;
16979 0           return;
16980             }
16981              
16982             # Line showing the progress.
16983             sub progress {
16984 0     0     my $o = shift;
16985              
16986 0 0         return if $o->{pure};
16987 0           $| = 1;
16988 0           $o->{hasProgress} = 1;
16989 0           my $text = ' '.join('', @_);
16990 0 0         $text = substr($text, 0, 79).'…' if length $text > 80;
16991 0 0         $text .= ' ' x (80 - length $text) if length $text < 80;
16992 0           $o->print($text, "\r");
16993             }
16994              
16995             # Progress line removal.
16996             sub removeProgress {
16997 0     0     my $o = shift;
16998              
16999 0 0         return if $o->{pure};
17000 0 0         return if ! $o->{hasProgress};
17001 0           $o->print(' ' x 80, "\r");
17002 0           $o->{hasProgress} = 0;
17003 0           $| = 0;
17004             }
17005              
17006             ### Low-level (non-semantic) formatting
17007              
17008             sub span {
17009 0     0     my $o = shift;
17010 0           CDS::UI::Span->new(@_) }
17011              
17012             sub bold {
17013 0     0     my $o = shift;
17014              
17015 0           my $span = CDS::UI::Span->new(@_);
17016 0           $span->{bold} = 1;
17017 0           return $span;
17018             }
17019              
17020             sub underlined {
17021 0     0     my $o = shift;
17022              
17023 0           my $span = CDS::UI::Span->new(@_);
17024 0           $span->{underlined} = 1;
17025 0           return $span;
17026             }
17027              
17028             sub foreground {
17029 0     0     my $o = shift;
17030 0           my $foreground = shift;
17031              
17032 0           my $span = CDS::UI::Span->new(@_);
17033 0           $span->{foreground} = $foreground;
17034 0           return $span;
17035             }
17036              
17037             sub background {
17038 0     0     my $o = shift;
17039 0           my $background = shift;
17040              
17041 0           my $span = CDS::UI::Span->new(@_);
17042 0           $span->{background} = $background;
17043 0           return $span;
17044             }
17045              
17046             sub red {
17047 0     0     my $o = shift;
17048 0           $o->foreground(196, @_) } # for failure
17049             sub green {
17050 0     0     my $o = shift;
17051 0           $o->foreground(40, @_) } # for success
17052             sub orange {
17053 0     0     my $o = shift;
17054 0           $o->foreground(166, @_) } # for warnings
17055             sub blue {
17056 0     0     my $o = shift;
17057 0           $o->foreground(33, @_) } # to highlight something (selection)
17058             sub violet {
17059 0     0     my $o = shift;
17060 0           $o->foreground(93, @_) } # to highlight something (selection)
17061             sub gold {
17062 0     0     my $o = shift;
17063 0           $o->foreground(238, @_) } # for commands that can be executed
17064             sub gray {
17065 0     0     my $o = shift;
17066 0           $o->foreground(246, @_) } # for additional (less important) information
17067              
17068             sub darkBold {
17069 0     0     my $o = shift;
17070              
17071 0           my $span = CDS::UI::Span->new(@_);
17072 0           $span->{bold} = 1;
17073 0           $span->{foreground} = 240;
17074 0           return $span;
17075             }
17076              
17077             ### Semantic output
17078              
17079             sub title {
17080 0     0     my $o = shift;
17081 0           $o->line($o->bold(@_)) }
17082              
17083             sub left {
17084 0     0     my $o = shift;
17085 0           my $width = shift;
17086 0           my $text = shift;
17087              
17088 0 0         return substr($text, 0, $width - 1).'…' if length $text > $width;
17089 0           return $text . ' ' x ($width - length $text);
17090             }
17091              
17092             sub right {
17093 0     0     my $o = shift;
17094 0           my $width = shift;
17095 0           my $text = shift;
17096              
17097 0 0         return substr($text, 0, $width - 1).'…' if length $text > $width;
17098 0           return ' ' x ($width - length $text) . $text;
17099             }
17100              
17101             sub keyValue {
17102 0     0     my $o = shift;
17103 0           my $key = shift;
17104 0           my $firstLine = shift;
17105              
17106 0           my $indent = $o->{valueIndent} - length $o->{indent};
17107 0 0 0       $key = substr($key, 0, $indent - 2).'…' if defined $firstLine && length $key >= $indent;
17108 0           $key .= ' ' x ($indent - length $key);
17109 0           $o->line($o->gray($key), $firstLine);
17110 0           my $noKey = ' ' x $indent;
17111 0           for my $line (@_) { $o->line($noKey, $line); }
  0            
17112 0           return;
17113             }
17114              
17115             sub command {
17116 0     0     my $o = shift;
17117 0           $o->line($o->bold(@_)) }
17118              
17119             sub verbose {
17120 0     0     my $o = shift;
17121 0 0         $o->line($o->foreground(45, @_)) if $o->{verbose} }
17122              
17123             sub pGreen {
17124 0     0     my $o = shift;
17125              
17126 0           $o->p($o->green(@_));
17127 0           return;
17128             }
17129              
17130             sub pOrange {
17131 0     0     my $o = shift;
17132              
17133 0           $o->p($o->orange(@_));
17134 0           return;
17135             }
17136              
17137             sub pRed {
17138 0     0     my $o = shift;
17139              
17140 0           $o->p($o->red(@_));
17141 0           return;
17142             }
17143              
17144             ### Warnings and errors
17145              
17146 0     0     sub hasWarning { shift->{hasWarning} }
17147 0     0     sub hasError { shift->{hasError} }
17148              
17149             sub warning {
17150 0     0     my $o = shift;
17151              
17152 0           $o->{hasWarning} = 1;
17153 0           $o->p($o->orange(@_));
17154 0           return;
17155             }
17156              
17157             sub error {
17158 0     0     my $o = shift;
17159              
17160 0           $o->{hasError} = 1;
17161 0           my $span = CDS::UI::Span->new(@_);
17162 0           $span->{background} = 196;
17163 0           $span->{foreground} = 15;
17164 0           $span->{bold} = 1;
17165 0           $o->line($span);
17166 0           return;
17167             }
17168              
17169             ### Semantic formatting
17170              
17171             sub a {
17172 0     0     my $o = shift;
17173 0           $o->underlined(@_) }
17174              
17175             ### Human readable formats
17176              
17177             sub niceBytes {
17178 0     0     my $o = shift;
17179 0           my $bytes = shift;
17180 0           my $maxLength = shift;
17181              
17182 0           my $length = length $bytes;
17183 0 0 0       my $text = defined $maxLength && $length > $maxLength ? substr($bytes, 0, $maxLength - 1).'…' : $bytes;
17184 0           $text =~ s/[\x00-\x1f\x7f-\xff]/./g;
17185 0           return $text;
17186             }
17187              
17188             sub niceFileSize {
17189 0     0     my $o = shift;
17190 0           my $fileSize = shift;
17191              
17192 0 0         return $fileSize.' bytes' if $fileSize < 1000;
17193 0 0         return sprintf('%0.1f', $fileSize / 1000).' KB' if $fileSize < 10000;
17194 0 0         return sprintf('%0.0f', $fileSize / 1000).' KB' if $fileSize < 1000000;
17195 0 0         return sprintf('%0.1f', $fileSize / 1000000).' MB' if $fileSize < 10000000;
17196 0 0         return sprintf('%0.0f', $fileSize / 1000000).' MB' if $fileSize < 1000000000;
17197 0 0         return sprintf('%0.1f', $fileSize / 1000000000).' GB' if $fileSize < 10000000000;
17198 0           return sprintf('%0.0f', $fileSize / 1000000000).' GB';
17199             }
17200              
17201             sub niceDateTimeLocal {
17202 0     0     my $o = shift;
17203 0   0       my $time = shift // time() * 1000;
17204              
17205 0           my @t = localtime($time / 1000);
17206 0           return sprintf('%04d-%02d-%02d %02d:%02d:%02d', $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0]);
17207             }
17208              
17209             sub niceDateTime {
17210 0     0     my $o = shift;
17211 0   0       my $time = shift // time() * 1000;
17212              
17213 0           my @t = gmtime($time / 1000);
17214 0           return sprintf('%04d-%02d-%02d %02d:%02d:%02d UTC', $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0]);
17215             }
17216              
17217             sub niceDate {
17218 0     0     my $o = shift;
17219 0   0       my $time = shift // time() * 1000;
17220              
17221 0           my @t = gmtime($time / 1000);
17222 0           return sprintf('%04d-%02d-%02d', $t[5] + 1900, $t[4] + 1, $t[3]);
17223             }
17224              
17225             sub niceTime {
17226 0     0     my $o = shift;
17227 0   0       my $time = shift // time() * 1000;
17228              
17229 0           my @t = gmtime($time / 1000);
17230 0           return sprintf('%02d:%02d:%02d UTC', $t[2], $t[1], $t[0]);
17231             }
17232              
17233             ### Special output
17234              
17235             sub record {
17236 0     0     my $o = shift;
17237 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
17238 0           my $storeUrl = shift;
17239 0           CDS::UI::Record->display($o, $record, $storeUrl) }
17240              
17241             sub recordChildren {
17242 0     0     my $o = shift;
17243 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
17244 0           my $storeUrl = shift;
17245              
17246 0           for my $child ($record->children) {
17247 0           CDS::UI::Record->display($o, $child, $storeUrl);
17248             }
17249             }
17250              
17251             sub selector {
17252 0     0     my $o = shift;
17253 0 0 0       my $selector = shift; die 'wrong type '.ref($selector).' for $selector' if defined $selector && ref $selector ne 'CDS::Selector';
  0            
17254 0           my $rootLabel = shift;
17255              
17256 0           my $item = $selector->document->get($selector);
17257 0 0         my $revision = $item->{revision} ? $o->green(' ', $o->niceDateTime($item->{revision})) : '';
17258              
17259 0 0         if ($selector->{id} eq 'ROOT') {
17260 0   0       $o->line($o->bold($rootLabel // 'Data tree'), $revision);
17261 0           $o->recordChildren($selector->record);
17262 0           $o->selectorChildren($selector);
17263             } else {
17264 0           my $label = $selector->label;
17265 0 0         my $labelText = length $label > 64 ? substr($label, 0, 64).'…' : $label;
17266 0           $labelText =~ s/[\x00-\x1f\x7f-\xff]/·/g;
17267 0           $o->line($o->blue($labelText), $revision);
17268              
17269 0           $o->pushIndent;
17270 0           $o->recordChildren($selector->record);
17271 0           $o->selectorChildren($selector);
17272 0           $o->popIndent;
17273             }
17274             }
17275              
17276             sub selectorChildren {
17277 0     0     my $o = shift;
17278 0 0 0       my $selector = shift; die 'wrong type '.ref($selector).' for $selector' if defined $selector && ref $selector ne 'CDS::Selector';
  0            
17279              
17280 0           for my $child (sort { $a->{id} cmp $b->{id} } $selector->children) {
  0            
17281 0           $o->selector($child);
17282             }
17283             }
17284              
17285             sub hexDump {
17286 0     0     my $o = shift;
17287 0           my $bytes = shift;
17288 0           CDS::UI::HexDump->new($o, $bytes) }
17289              
17290             package CDS::UI::HexDump;
17291              
17292             sub new {
17293 0     0     my $class = shift;
17294 0           my $ui = shift;
17295 0           my $bytes = shift;
17296              
17297 0           return bless {ui => $ui, bytes => $bytes, styleChanges => [], };
17298             }
17299              
17300 0     0     sub reset { chr(0x1b).'[0m' }
17301             sub foreground {
17302 0     0     my $o = shift;
17303 0           my $color = shift;
17304 0           chr(0x1b).'[0;38;5;'.$color.'m' }
17305              
17306             sub changeStyle {
17307 0     0     my $o = shift;
17308              
17309 0           push @{$o->{styleChanges}}, @_;
  0            
17310             }
17311              
17312             sub styleHashList {
17313 0     0     my $o = shift;
17314 0           my $offset = shift;
17315              
17316 0           my $hashesCount = unpack('L>', substr($o->{bytes}, $offset, 4));
17317 0           my $dataStart = $offset + 4 + $hashesCount * 32;
17318 0 0         return $offset if $dataStart > length $o->{bytes};
17319              
17320             # Styles
17321 0           my $darkGreen = $o->foreground(28);
17322 0           my $green0 = $o->foreground(40);
17323 0           my $green1 = $o->foreground(34);
17324              
17325             # Color the hash count
17326 0           my $pos = $offset;
17327 0           $o->changeStyle({at => $pos, style => $darkGreen, breakBefore => 1});
17328 0           $pos += 4;
17329              
17330             # Color the hashes
17331 0           my $alternate = 0;
17332 0           while ($hashesCount) {
17333 0 0         $o->changeStyle({at => $pos, style => $alternate ? $green1 : $green0, breakBefore => 1});
17334 0           $pos += 32;
17335 0           $alternate = 1 - $alternate;
17336 0           $hashesCount -= 1;
17337             }
17338              
17339 0           return $dataStart;
17340             }
17341              
17342             sub styleRecord {
17343 0     0     my $o = shift;
17344 0           my $offset = shift;
17345              
17346             # Styles
17347 0           my $blue = $o->foreground(33);
17348 0           my $black = $o->reset;
17349 0           my $violet = $o->foreground(93);
17350 0           my @styleChanges;
17351              
17352             # Prepare
17353 0           my $pos = $offset;
17354 0           my $hasError = 0;
17355 0           my $level = 0;
17356              
17357 0     0     my $use = sub { my $length = shift;
17358 0           my $start = $pos;
17359 0           $pos += $length;
17360 0 0         return substr($o->{bytes}, $start, $length) if $pos <= length $o->{bytes};
17361 0           $hasError = 1;
17362 0           return;
17363 0           };
17364              
17365 0   0 0     my $readUnsigned8 = sub { unpack('C', &$use(1) // return) };
  0            
17366 0   0 0     my $readUnsigned32 = sub { unpack('L>', &$use(4) // return) };
  0            
17367 0   0 0     my $readUnsigned64 = sub { unpack('Q>', &$use(8) // return) };
  0            
17368              
17369             # Parse all record nodes
17370 0           while ($level >= 0) {
17371             # Flags
17372 0           push @styleChanges, {at => $pos, style => $blue, breakBefore => 1};
17373 0   0       my $flags = &$readUnsigned8 // last;
17374              
17375             # Data
17376 0           my $length = $flags & 0x1f;
17377 0 0 0       my $byteLength = $length == 30 ? 30 + (&$readUnsigned8 // last) : $length == 31 ? (&$readUnsigned64 // last) : $length;
    0 0        
17378              
17379 0 0         if ($byteLength) {
17380 0           push @styleChanges, {at => $pos, style => $black};
17381 0   0       &$use($byteLength) // last;
17382             }
17383              
17384 0 0         if ($flags & 0x20) {
17385 0           push @styleChanges, {at => $pos, style => $violet};
17386 0   0       &$readUnsigned32 // last;
17387             }
17388              
17389             # Children
17390 0 0         $level += 1 if $flags & 0x40;
17391 0 0         $level -= 1 if ! ($flags & 0x80);
17392             }
17393              
17394             # Don't apply any styles if there are errors
17395 0 0         $hasError = 1 if $pos != length $o->{bytes};
17396 0 0         return $offset if $hasError;
17397              
17398 0           $o->changeStyle(@styleChanges);
17399 0           return $pos;
17400             }
17401              
17402             sub display {
17403 0     0     my $o = shift;
17404              
17405 0           $o->{ui}->valueIndent(8);
17406              
17407 0           my $resetStyle = chr(0x1b).'[0m';
17408 0           my $length = length($o->{bytes});
17409 0           my $lineStart = 0;
17410 0           my $currentStyle = '';
17411              
17412 0           my @styleChanges = sort { $a->{at} <=> $b->{at} } @{$o->{styleChanges}};
  0            
  0            
17413 0           push @styleChanges, {at => $length};
17414 0           my $nextChange = shift(@styleChanges);
17415              
17416 0           $o->{ui}->line($o->{ui}->gray('···· 0 1 2 3 4 5 6 7 8 9 a b c d e f 0123456789abcdef'));
17417 0           while ($lineStart < $length) {
17418 0           my $hexLine = $currentStyle;
17419 0           my $textLine = $currentStyle;
17420              
17421 0           my $k = 0;
17422 0           while ($k < 16) {
17423 0           my $index = $lineStart + $k;
17424 0 0         last if $index >= $length;
17425              
17426 0           my $break = 0;
17427 0           while ($index >= $nextChange->{at}) {
17428 0           $currentStyle = $nextChange->{style};
17429 0   0       $break = $nextChange->{breakBefore} && $k > 0;
17430 0           $hexLine .= $currentStyle;
17431 0           $textLine .= $currentStyle;
17432 0           $nextChange = shift @styleChanges;
17433 0 0         last if $break;
17434             }
17435              
17436 0 0         last if $break;
17437              
17438 0           my $byte = substr($o->{bytes}, $lineStart + $k, 1);
17439 0           $hexLine .= ' '.unpack('H*', $byte);
17440              
17441 0           my $code = ord($byte);
17442 0 0 0       $textLine .= $code >= 32 && $code <= 126 ? $byte : '·';
17443              
17444 0           $k += 1;
17445             }
17446              
17447 0           $hexLine .= ' ' x (16 - $k);
17448 0           $textLine .= ' ' x (16 - $k);
17449 0           $o->{ui}->line($o->{ui}->gray(unpack('H4', pack('S>', $lineStart))), ' ', $hexLine, $resetStyle, ' ', $textLine, $resetStyle);
17450              
17451 0           $lineStart += $k;
17452             }
17453             }
17454              
17455             package CDS::UI::ProgressStore;
17456              
17457 1     1   4148 use parent -norequire, 'CDS::Store';
  1         2  
  1         5  
17458              
17459             sub new {
17460 0     0     my $class = shift;
17461 0           my $store = shift;
17462 0           my $url = shift;
17463 0           my $ui = shift;
17464              
17465 0           return bless {
17466             store => $store,
17467             url => $url,
17468             ui => $ui,
17469             }
17470             }
17471              
17472 0     0     sub store { shift->{store} }
17473 0     0     sub url { shift->{url} }
17474 0     0     sub ui { shift->{ui} }
17475              
17476             sub id {
17477 0     0     my $o = shift;
17478 0           'Progress'."\n ".$o->{store}->id }
17479              
17480             ### Object store functions
17481              
17482             sub get {
17483 0     0     my $o = shift;
17484 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
17485 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
17486              
17487 0           $o->{ui}->progress('GET ', $hash->shortHex, ' on ', $o->{url});
17488 0           return $o->{store}->get($hash, $keyPair);
17489             }
17490              
17491             sub book {
17492 0     0     my $o = shift;
17493 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
17494 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
17495              
17496 0           $o->{ui}->progress('BOOK ', $hash->shortHex, ' on ', $o->{url});
17497 0           return $o->{store}->book($hash, $keyPair);
17498             }
17499              
17500             sub put {
17501 0     0     my $o = shift;
17502 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
17503 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
17504 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
17505              
17506 0           $o->{ui}->progress('PUT ', $hash->shortHex, ' (', $o->{ui}->niceFileSize($object->byteLength), ') on ', $o->{url});
17507 0           return $o->{store}->put($hash, $object, $keyPair);
17508             }
17509              
17510             ### Account store functions
17511              
17512             sub list {
17513 0     0     my $o = shift;
17514 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
17515 0           my $boxLabel = shift;
17516 0           my $timeout = shift;
17517 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
17518              
17519 0 0         $o->{ui}->progress($timeout == 0 ? 'LIST ' : 'WATCH ', $boxLabel, ' of ', $accountHash->shortHex, ' on ', $o->{url});
17520 0           return $o->{store}->list($accountHash, $boxLabel, $timeout, $keyPair);
17521             }
17522              
17523             sub add {
17524 0     0     my $o = shift;
17525 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
17526 0           my $boxLabel = shift;
17527 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
17528 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
17529              
17530 0           $o->{ui}->progress('ADD ', $accountHash->shortHex, ' ', $boxLabel, ' ', $hash->shortHex, ' on ', $o->{url});
17531 0           return $o->{store}->add($accountHash, $boxLabel, $hash, $keyPair);
17532             }
17533              
17534             sub remove {
17535 0     0     my $o = shift;
17536 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
17537 0           my $boxLabel = shift;
17538 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
17539 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
17540              
17541 0           $o->{ui}->progress('REMOVE ', $accountHash->shortHex, ' ', $boxLabel, ' ', $hash->shortHex, ' on ', $o->{url});
17542 0           return $o->{store}->remove($accountHash, $boxLabel, $hash, $keyPair);
17543             }
17544              
17545             sub modify {
17546 0     0     my $o = shift;
17547 0           my $modifications = shift;
17548 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
17549              
17550 0           $o->{ui}->progress('MODIFY +', scalar @{$modifications->additions}, ' -', scalar @{$modifications->removals}, ' on ', $o->{url});
  0            
  0            
17551 0           return $o->{store}->modify($modifications, $keyPair);
17552             }
17553              
17554             # Displays a record, and tries to guess the byte interpretation
17555             package CDS::UI::Record;
17556              
17557             sub display {
17558 0     0     my $class = shift;
17559 0           my $ui = shift;
17560 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
17561 0           my $storeUrl = shift;
17562              
17563 0 0         my $o = bless {
17564             ui => $ui,
17565             onStore => defined $storeUrl ? $ui->gray(' on ', $storeUrl) : '',
17566             };
17567              
17568 0           $o->record($record, '');
17569             }
17570              
17571             sub record {
17572 0     0     my $o = shift;
17573 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
17574 0           my $context = shift;
17575              
17576 0           my $bytes = $record->bytes;
17577 0           my $hash = $record->hash;
17578 0           my @children = $record->children;
17579              
17580             # Try to interpret the key / value pair with a set of heuristic rules
17581             my @value =
17582             ! length $bytes && $hash ? ($o->{ui}->gold('cds show record '), $hash->hex, $o->{onStore}) :
17583             ! length $bytes ? $o->{ui}->gray('empty') :
17584 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          
17585             $context eq 'e' ? $o->hexValue($bytes) :
17586             $context eq 'n' ? $o->hexValue($bytes) :
17587             $context eq 'p' ? $o->hexValue($bytes) :
17588             $context eq 'q' ? $o->hexValue($bytes) :
17589             $context eq 'encrypted for' ? $o->hexValue($bytes) :
17590             $context eq 'updated by' ? $o->hexValue($bytes) :
17591             $context =~ /(^| )id( |$)/ ? $o->hexValue($bytes) :
17592             $context =~ /(^| )key( |$)/ ? $o->hexValue($bytes) :
17593             $context =~ /(^| )signature( |$)/ ? $o->hexValue($bytes) :
17594             $context =~ /(^| )revision( |$)/ ? $o->revisionValue($bytes) :
17595             $context =~ /(^| )date( |$)/ ? $o->dateValue($bytes) :
17596             $context =~ /(^| )expires( |$)/ ? $o->dateValue($bytes) :
17597             $o->guessValue($bytes);
17598              
17599 0 0 0       push @value, ' ', $o->{ui}->blue($hash->hex), $o->{onStore} if $hash && ($bytes && length $bytes != 32);
      0        
17600 0           $o->{ui}->line(@value);
17601              
17602             # Children
17603 0           $o->{ui}->pushIndent;
17604 0           for my $child (@children) { $o->record($child, $bytes); }
  0            
17605 0           $o->{ui}->popIndent;
17606             }
17607              
17608             sub hexValue {
17609 0     0     my $o = shift;
17610 0           my $bytes = shift;
17611              
17612 0           my $length = length $bytes;
17613 0 0         return '#'.unpack('H*', substr($bytes, 0, $length)) if $length <= 64;
17614 0           return '#'.unpack('H*', substr($bytes, 0, 64)), '…', $o->{ui}->gray(' (', $length, ' bytes)');
17615             }
17616              
17617             sub guessValue {
17618 0     0     my $o = shift;
17619 0           my $bytes = shift;
17620              
17621 0           my $length = length $bytes;
17622 0 0         my $text = $length > 64 ? substr($bytes, 0, 64).'…' : $bytes;
17623 0           $text =~ s/[\x00-\x1f\x7f-\xff]/·/g;
17624 0           my @value = ($text);
17625              
17626 0 0         if ($length <= 8) {
17627 0           my $integer = CDS->integerFromBytes($bytes);
17628 0 0         push @value, $o->{ui}->gray(' = ', $integer, $o->looksLikeTimestamp($integer) ? ' = '.$o->{ui}->niceDateTime($integer).' = '.$o->{ui}->niceDateTimeLocal($integer) : '');
17629             }
17630              
17631 0 0 0       push @value, $o->{ui}->gray(' = ', CDS->floatFromBytes($bytes)) if $length == 4 || $length == 8;
17632 0 0         push @value, $o->{ui}->gray(' = ', CDS::Hash->fromBytes($bytes)->hex) if $length == 32;
17633 0 0         push @value, $o->{ui}->gray(' (', length $bytes, ' bytes)') if length $bytes > 64;
17634 0           return @value;
17635             }
17636              
17637             sub dateValue {
17638 0     0     my $o = shift;
17639 0           my $bytes = shift;
17640              
17641 0           my $integer = CDS->integerFromBytes($bytes);
17642 0 0         return $integer if ! $o->looksLikeTimestamp($integer);
17643 0           return $o->{ui}->niceDateTime($integer), ' ', $o->{ui}->gray($o->{ui}->niceDateTimeLocal($integer));
17644             }
17645              
17646             sub revisionValue {
17647 0     0     my $o = shift;
17648 0           my $bytes = shift;
17649              
17650 0           my $integer = CDS->integerFromBytes($bytes);
17651 0 0         return $integer if ! $o->looksLikeTimestamp($integer);
17652 0           return $o->{ui}->niceDateTime($integer);
17653             }
17654              
17655             sub looksLikeTimestamp {
17656 0     0     my $o = shift;
17657 0           my $integer = shift;
17658              
17659 0   0       return $integer > 100000000000 && $integer < 10000000000000;
17660             }
17661              
17662             package CDS::UI::Span;
17663              
17664             sub new {
17665 0     0     my $class = shift;
17666              
17667 0           return bless {
17668             text => [@_],
17669             };
17670             }
17671              
17672             sub printTo {
17673 0     0     my $o = shift;
17674 0           my $ui = shift;
17675 0           my $parent = shift;
17676              
17677 0 0         if ($parent) {
17678 0   0       $o->{appliedForeground} = $o->{foreground} // $parent->{appliedForeground};
17679 0   0       $o->{appliedBackground} = $o->{background} // $parent->{appliedBackground};
17680 0   0       $o->{appliedBold} = $o->{bold} // $parent->{appliedBold} // 0;
      0        
17681 0   0       $o->{appliedUnderlined} = $o->{underlined} // $parent->{appliedUnderlined} // 0;
      0        
17682             } else {
17683 0           $o->{appliedForeground} = $o->{foreground};
17684 0           $o->{appliedBackground} = $o->{background};
17685 0   0       $o->{appliedBold} = $o->{bold} // 0;
17686 0   0       $o->{appliedUnderlined} = $o->{underlined} // 0;
17687             }
17688              
17689 0           my $style = chr(0x1b).'[0';
17690 0 0         $style .= ';1' if $o->{appliedBold};
17691 0 0         $style .= ';4' if $o->{appliedUnderlined};
17692 0 0         $style .= ';38;5;'.$o->{appliedForeground} if defined $o->{appliedForeground};
17693 0 0         $style .= ';48;5;'.$o->{appliedBackground} if defined $o->{appliedBackground};
17694 0           $style .= 'm';
17695              
17696 0           my $needStyle = 1;
17697 0           for my $child (@{$o->{text}}) {
  0            
17698 0           my $ref = ref $child;
17699 0 0         if ($ref eq 'CDS::UI::Span') {
    0          
    0          
17700 0           $child->printTo($ui, $o);
17701 0           $needStyle = 1;
17702 0           next;
17703             } elsif (length $ref) {
17704 0           warn 'Printing REF';
17705 0           $child = $ref;
17706             } elsif (! defined $child) {
17707 0           warn 'Printing UNDEF';
17708 0           $child = 'UNDEF';
17709             }
17710              
17711 0 0         if ($needStyle) {
17712 0           $ui->print($style);
17713 0           $needStyle = 0;
17714             }
17715              
17716 0           $ui->print($child);
17717             }
17718             }
17719              
17720             sub wordWrap {
17721 0     0     my $o = shift;
17722 0           my $state = shift;
17723              
17724 0           my $index = -1;
17725 0           for my $child (@{$o->{text}}) {
  0            
17726 0           $index += 1;
17727              
17728 0 0         next if ! defined $child;
17729              
17730 0           my $ref = ref $child;
17731 0 0         if ($ref eq 'CDS::UI::Span') {
    0          
    0          
17732 0           $child->wordWrap($state);
17733 0           next;
17734             } elsif (length $ref) {
17735 0           warn 'Printing REF';
17736 0           $child = $ref;
17737             } elsif (! defined $child) {
17738 0           warn 'Printing UNDEF';
17739 0           $child = 'UNDEF';
17740             }
17741              
17742 0           my $position = -1;
17743 0           for my $char (split //, $child) {
17744 0           $position += 1;
17745 0           $state->{lineLength} += 1;
17746 0 0 0       if ($char eq ' ' || $char eq "\t") {
    0 0        
17747 0           $state->{wrapSpan} = $o;
17748 0           $state->{wrapIndex} = $index;
17749 0           $state->{wrapPosition} = $position;
17750 0           $state->{wrapReturn} = $state->{lineLength};
17751             } elsif ($state->{wrapSpan} && $state->{lineLength} > $state->{maxLength}) {
17752 0           my $text = $state->{wrapSpan}->{text}->[$state->{wrapIndex}];
17753 0           $text = substr($text, 0, $state->{wrapPosition})."\n".$state->{indent}.substr($text, $state->{wrapPosition} + 1);
17754 0           $state->{wrapSpan}->{text}->[$state->{wrapIndex}] = $text;
17755 0           $state->{lineLength} -= $state->{wrapReturn};
17756 0 0 0       $position += length $state->{indent} if $state->{wrapSpan} == $o && $state->{wrapIndex} == $index;
17757 0           $state->{wrapSpan} = undef;
17758             }
17759             }
17760             }
17761             }
17762              
17763             package CDS::UnionList;
17764              
17765             sub new {
17766 0     0     my $class = shift;
17767 0           my $privateRoot = shift;
17768 0           my $label = shift;
17769              
17770 0           my $o = bless {
17771             privateRoot => $privateRoot,
17772             label => $label,
17773             unsaved => CDS::Unsaved->new($privateRoot->unsaved),
17774             items => {},
17775             parts => {},
17776             hasPartsToMerge => 0,
17777             }, $class;
17778              
17779 0           $o->{unused} = CDS::UnionList::Part->new;
17780 0           $o->{changes} = CDS::UnionList::Part->new;
17781 0           $privateRoot->addDataHandler($label, $o);
17782 0           return $o;
17783             }
17784              
17785 0     0     sub privateRoot { shift->{privateRoot} }
17786 0     0     sub unsaved { shift->{unsaved} }
17787             sub items {
17788 0     0     my $o = shift;
17789 0           values %{$o->{items}} }
  0            
17790             sub parts {
17791 0     0     my $o = shift;
17792 0           values %{$o->{parts}} }
  0            
17793              
17794             sub get {
17795 0     0     my $o = shift;
17796 0           my $id = shift;
17797 0           $o->{items}->{$id} }
17798              
17799             sub getOrCreate {
17800 0     0     my $o = shift;
17801 0           my $id = shift;
17802              
17803 0           my $item = $o->{items}->{$id};
17804 0 0         return $item if $item;
17805 0           my $newItem = $o->createItem($id);
17806 0           $o->{items}->{$id} = $newItem;
17807 0           return $newItem;
17808             }
17809              
17810             # abstract sub createItem($o, $id)
17811             # abstract sub forgetObsoleteItems($o)
17812              
17813             sub forget {
17814 0     0     my $o = shift;
17815 0           my $id = shift;
17816              
17817 0   0       my $item = $o->{items}->{$id} // return;
17818 0           $item->{part}->{count} -= 1;
17819 0           delete $o->{items}->{$id};
17820             }
17821              
17822             sub forgetItem {
17823 0     0     my $o = shift;
17824 0           my $item = shift;
17825              
17826 0           $item->{part}->{count} -= 1;
17827 0           delete $o->{items}->{$item->id};
17828             }
17829              
17830             # *** MergeableData interface
17831              
17832             sub addDataTo {
17833 0     0     my $o = shift;
17834 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
17835              
17836 0           for my $part (sort { $a->{hashAndKey}->hash->bytes cmp $b->{hashAndKey}->hash->bytes } values %{$o->{parts}}) {
  0            
  0            
17837 0           $record->addHashAndKey($part->{hashAndKey});
17838             }
17839             }
17840              
17841             sub mergeData {
17842 0     0     my $o = shift;
17843 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
17844              
17845 0           my @hashesAndKeys;
17846 0           for my $child ($record->children) {
17847 0   0       push @hashesAndKeys, $child->asHashAndKey // next;
17848             }
17849              
17850 0           $o->merge(@hashesAndKeys);
17851             }
17852              
17853             sub mergeExternalData {
17854 0     0     my $o = shift;
17855 0           my $store = shift;
17856 0 0 0       my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
  0            
17857 0 0 0       my $source = shift; die 'wrong type '.ref($source).' for $source' if defined $source && ref $source ne 'CDS::Source';
  0            
17858              
17859 0           my @hashes;
17860             my @hashesAndKeys;
17861 0           for my $child ($record->children) {
17862 0   0       my $hashAndKey = $child->asHashAndKey // next;
17863 0 0         next if $o->{parts}->{$hashAndKey->hash->bytes};
17864 0           push @hashes, $hashAndKey->hash;
17865 0           push @hashesAndKeys, $hashAndKey;
17866             }
17867              
17868 0           my $keyPair = $o->{privateRoot}->privateBoxReader->keyPair;
17869 0           my ($missing, $transferStore, $storeError) = $keyPair->transfer([@hashes], $store, $o->{privateRoot}->unsaved);
17870 0 0         return if defined $storeError;
17871 0 0         return if $missing;
17872              
17873 0 0         if ($source) {
17874 0           $source->keep;
17875 0           $o->{privateRoot}->unsaved->state->addMergedSource($source);
17876             }
17877              
17878 0           $o->merge(@hashesAndKeys);
17879 0           return 1;
17880             }
17881              
17882             sub merge {
17883 0     0     my $o = shift;
17884              
17885 0           for my $hashAndKey (@_) {
17886 0 0         next if ! $hashAndKey;
17887 0 0         next if $o->{parts}->{$hashAndKey->hash->bytes};
17888 0           my $part = CDS::UnionList::Part->new;
17889 0           $part->{hashAndKey} = $hashAndKey;
17890 0           $o->{parts}->{$hashAndKey->hash->bytes} = $part;
17891 0           $o->{hasPartsToMerge} = 1;
17892             }
17893             }
17894              
17895             # *** Reading
17896              
17897             sub read {
17898 0     0     my $o = shift;
17899              
17900 0 0         return 1 if ! $o->{hasPartsToMerge};
17901              
17902             # Load the parts
17903 0           for my $part (values %{$o->{parts}}) {
  0            
17904 0 0         next if $part->{isMerged};
17905 0 0         next if $part->{loadedRecord};
17906              
17907 0           my ($record, $object, $invalidReason, $storeError) = $o->{privateRoot}->privateBoxReader->keyPair->getAndDecryptRecord($part->{hashAndKey}, $o->{privateRoot}->unsaved);
17908 0 0         return if defined $storeError;
17909              
17910 0 0         delete $o->{parts}->{$part->{hashAndKey}->hash->bytes} if defined $invalidReason;
17911 0           $part->{loadedRecord} = $record;
17912             }
17913              
17914             # Merge the loaded parts
17915 0           for my $part (values %{$o->{parts}}) {
  0            
17916 0 0         next if $part->{isMerged};
17917 0 0         next if ! $part->{loadedRecord};
17918              
17919             # Merge
17920 0           for my $child ($part->{loadedRecord}->children) {
17921 0           $o->mergeRecord($part, $child);
17922             }
17923              
17924 0           delete $part->{loadedRecord};
17925 0           $part->{isMerged} = 1;
17926             }
17927              
17928 0           $o->{hasPartsToMerge} = 0;
17929 0           return 1;
17930             }
17931              
17932             # abstract sub mergeRecord($o, $part, $record)
17933              
17934             # *** Saving
17935              
17936             sub hasChanges {
17937 0     0     my $o = shift;
17938 0           $o->{changes}->{count} > 0 }
17939              
17940             sub save {
17941 0     0     my $o = shift;
17942              
17943 0           $o->forgetObsoleteItems;
17944 0           $o->{unsaved}->startSaving;
17945              
17946 0 0         if ($o->{changes}->{count}) {
17947             # Take the changes
17948 0           my $newPart = $o->{changes};
17949 0           $o->{changes} = CDS::UnionList::Part->new;
17950              
17951             # Add all changes
17952 0           my $record = CDS::Record->new;
17953 0           for my $item (values %{$o->{items}}) {
  0            
17954 0 0         next if $item->{part} != $newPart;
17955 0           $item->addToRecord($record);
17956             }
17957              
17958             # Select all parts smaller than 2 * count elements
17959 0           my $count = $newPart->{count};
17960 0           while (1) {
17961 0           my $addedPart = 0;
17962 0           for my $part (values %{$o->{parts}}) {
  0            
17963 0 0 0       next if ! $part->{isMerged} || $part->{selected} || $part->{count} >= $count * 2;
      0        
17964 0           $count += $part->{count};
17965 0           $part->{selected} = 1;
17966 0           $addedPart = 1;
17967             }
17968              
17969 0 0         last if ! $addedPart;
17970             }
17971              
17972             # Include the selected items
17973 0           for my $item (values %{$o->{items}}) {
  0            
17974 0 0         next if ! $item->{part}->{selected};
17975 0           $item->setPart($newPart);
17976 0           $item->addToRecord($record);
17977             }
17978              
17979             # Serialize the new part
17980 0           my $key = CDS->randomKey;
17981 0           my $newObject = $record->toObject->crypt($key);
17982 0           my $newHash = $newObject->calculateHash;
17983 0           $newPart->{hashAndKey} = CDS::HashAndKey->new($newHash, $key);
17984 0           $newPart->{isMerged} = 1;
17985 0           $o->{parts}->{$newHash->bytes} = $newPart;
17986 0           $o->{privateRoot}->unsaved->state->addObject($newHash, $newObject);
17987 0           $o->{privateRoot}->dataChanged;
17988             }
17989              
17990             # Remove obsolete parts
17991 0           for my $part (values %{$o->{parts}}) {
  0            
17992 0 0         next if ! $part->{isMerged};
17993 0 0         next if $part->{count};
17994 0           delete $o->{parts}->{$part->{hashAndKey}->hash->bytes};
17995 0           $o->{privateRoot}->dataChanged;
17996             }
17997              
17998             # Propagate the unsaved state
17999 0           $o->{privateRoot}->unsaved->state->merge($o->{unsaved}->savingState);
18000 0           $o->{unsaved}->savingDone;
18001 0           return 1;
18002             }
18003              
18004             package CDS::UnionList::Item;
18005              
18006             sub new {
18007 0     0     my $class = shift;
18008 0           my $unionList = shift;
18009 0           my $id = shift;
18010              
18011 0           $unionList->{unused}->{count} += 1;
18012             return bless {
18013             unionList => $unionList,
18014             id => $id,
18015             part => $unionList->{unused},
18016 0           }, $class;
18017             }
18018              
18019 0     0     sub unionList { shift->{unionList} }
18020 0     0     sub id { shift->{id} }
18021              
18022             sub setPart {
18023 0     0     my $o = shift;
18024 0           my $part = shift;
18025              
18026 0           $o->{part}->{count} -= 1;
18027 0           $o->{part} = $part;
18028 0           $o->{part}->{count} += 1;
18029             }
18030              
18031             # abstract sub addToRecord($o, $record)
18032              
18033             package CDS::UnionList::Part;
18034              
18035             sub new {
18036 0     0     my $class = shift;
18037              
18038 0           return bless {
18039             isMerged => 0,
18040             hashAndKey => undef,
18041             size => 0,
18042             count => 0,
18043             selected => 0,
18044             };
18045             }
18046              
18047             package CDS::Unsaved;
18048              
18049 1     1   4662 use parent -norequire, 'CDS::Store';
  1         2  
  1         4  
18050              
18051             sub new {
18052 0     0     my $class = shift;
18053 0           my $store = shift;
18054              
18055 0           return bless {
18056             state => CDS::Unsaved::State->new,
18057             savingState => undef,
18058             store => $store,
18059             };
18060             }
18061              
18062 0     0     sub state { shift->{state} }
18063 0     0     sub savingState { shift->{savingState} }
18064              
18065             # *** Saving, state propagation
18066              
18067             sub isSaving {
18068 0     0     my $o = shift;
18069 0           defined $o->{savingState} }
18070              
18071             sub startSaving {
18072 0     0     my $o = shift;
18073              
18074 0 0         die 'Start saving, but already saving' if $o->{savingState};
18075 0           $o->{savingState} = $o->{state};
18076 0           $o->{state} = CDS::Unsaved::State->new;
18077             }
18078              
18079             sub savingDone {
18080 0     0     my $o = shift;
18081              
18082 0 0         die 'Not in saving state' if ! $o->{savingState};
18083 0           $o->{savingState} = undef;
18084             }
18085              
18086             sub savingFailed {
18087 0     0     my $o = shift;
18088              
18089 0 0         die 'Not in saving state' if ! $o->{savingState};
18090 0           $o->{state}->merge($o->{savingState});
18091 0           $o->{savingState} = undef;
18092             }
18093              
18094             # *** Store interface
18095              
18096             sub id {
18097 0     0     my $o = shift;
18098 0           'Unsaved'."\n".unpack('H*', CDS->randomBytes(16))."\n".$o->{store}->id }
18099              
18100             sub get {
18101 0     0     my $o = shift;
18102 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
18103 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
18104              
18105 0           my $stateObject = $o->{state}->{objects}->{$hash->bytes};
18106 0 0         return $stateObject->{object} if $stateObject;
18107              
18108 0 0         if ($o->{savingState}) {
18109 0           my $savingStateObject = $o->{savingState}->{objects}->{$hash->bytes};
18110 0 0         return $savingStateObject->{object} if $savingStateObject;
18111             }
18112              
18113 0           return $o->{store}->get($hash, $keyPair);
18114             }
18115              
18116             sub book {
18117 0     0     my $o = shift;
18118 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
18119 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
18120              
18121 0           return $o->{store}->book($hash, $keyPair);
18122             }
18123              
18124             sub put {
18125 0     0     my $o = shift;
18126 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
18127 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
18128 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
18129              
18130 0           return $o->{store}->put($hash, $object, $keyPair);
18131             }
18132              
18133             sub list {
18134 0     0     my $o = shift;
18135 0 0 0       my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
  0            
18136 0           my $boxLabel = shift;
18137 0           my $timeout = shift;
18138 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
18139              
18140 0           return $o->{store}->list($accountHash, $boxLabel, $timeout, $keyPair);
18141             }
18142              
18143             sub modify {
18144 0     0     my $o = shift;
18145 0           my $additions = shift;
18146 0           my $removals = shift;
18147 0 0 0       my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';
  0            
18148              
18149 0           return $o->{store}->modify($additions, $removals, $keyPair);
18150             }
18151              
18152             package CDS::Unsaved::State;
18153              
18154             sub new {
18155 0     0     my $class = shift;
18156              
18157 0           return bless {
18158             objects => {},
18159             mergedSources => [],
18160             dataSavedHandlers => [],
18161             };
18162             }
18163              
18164 0     0     sub objects { shift->{objects} }
18165             sub mergedSources {
18166 0     0     my $o = shift;
18167 0           @{$o->{mergedSources}} }
  0            
18168             sub dataSavedHandlers {
18169 0     0     my $o = shift;
18170 0           @{$o->{dataSavedHandlers}} }
  0            
18171              
18172             sub addObject {
18173 0     0     my $o = shift;
18174 0 0 0       my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
  0            
18175 0 0 0       my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
  0            
18176              
18177 0           $o->{objects}->{$hash->bytes} = {hash => $hash, object => $object};
18178             }
18179              
18180             sub addMergedSource {
18181 0     0     my $o = shift;
18182              
18183 0           push @{$o->{mergedSources}}, @_;
  0            
18184             }
18185              
18186             sub addDataSavedHandler {
18187 0     0     my $o = shift;
18188              
18189 0           push @{$o->{dataSavedHandlers}}, @_;
  0            
18190             }
18191              
18192             sub merge {
18193 0     0     my $o = shift;
18194 0           my $state = shift;
18195              
18196 0           for my $key (keys %{$state->{objects}}) {
  0            
18197 0           $o->{objects}->{$key} = $state->{objects}->{$key};
18198             }
18199              
18200 0           push @{$o->{mergedSources}}, @{$state->{mergedSources}};
  0            
  0            
18201 0           push @{$o->{dataSavedHandlers}}, @{$state->{dataSavedHandlers}};
  0            
  0            
18202             }