view release on metacpan or  search on metacpan

lib/CDS.pm  view on Meta::CPAN

sub folder { shift->{folder} }
sub defaultFile { shift->{defaultFile} }
sub mimeTypesByExtension { shift->{mimeTypesByExtension} }

sub setContentType {
	my $o = shift;
	my $extension = shift;
	my $contentType = shift;

	$o->{mimeTypesByExtension}->{$extension} = $contentType;
}

sub process {
	my $o = shift;
	my $request = shift;

	# Options
	return $request->replyOptions('HEAD', 'GET') if $request->method eq 'OPTIONS';

	# Get
	return $o->get($request) if $request->method eq 'GET' || $request->method eq 'HEAD';

	# Anything else
	return $request->reply405;
}

sub get {
	my $o = shift;
	my $request = shift;

	my $path = $request->pathAbove($o->{root}) // return;
	return $o->deliverFileForPath($request, $path);
}

sub deliverFileForPath {
	my $o = shift;
	my $request = shift;
	my $path = shift;

	# Hidden files (starting with a dot), as well as "." and ".." never exist
	for my $segment (split /\/+/, $path) {
		return $request->reply404 if $segment =~ /^\./;
	}

	# If a folder is requested, we serve the default file
	my $file = $o->{folder}.$path;
	if (-d $file) {
		return $request->reply404 if ! length $o->{defaultFile};
		return $request->reply303($request->path.'/') if $file !~ /\/$/;
		$file .= $o->{defaultFile};
	}

	return $o->deliverFile($request, $file);
}

sub deliverFile {
	my $o = shift;
	my $request = shift;
	my $file = shift;
	my $contentType = shift // $o->guessContentType($file);

	my $bytes = $o->readFile($file) // return $request->reply404;
	return $request->reply(200, 'OK', {'Content-Type' => $contentType}, $bytes);
}

# Guesses the content type from the extension
sub guessContentType {
	my $o = shift;
	my $file = shift;

	my $extension = $file =~ /\.([A-Za-z0-9]*)$/ ? lc($1) : '';
	return $o->{mimeTypesByExtension}->{$extension} // 'application/octet-stream';
}

# Reads a file
sub readFile {
	my $o = shift;
	my $file = shift;

	open(my $fh, '<:bytes', $file) || return;
	if (! -f $fh) {
		close $fh;
		return;
	}

	local $/ = undef;
	my $bytes = <$fh>;
	close $fh;
	return $bytes;
}

package CDS::HTTPServer::StoreHandler;

sub new {
	my $class = shift;
	my $root = shift;
	my $store = shift;
	my $checkPutHash = shift;
	my $checkSignatures = shift // 1;

	return bless {
		root => $root,
		store => $store,
		checkPutHash => $checkPutHash,
		checkEnvelopeHash => $checkPutHash,
		checkSignatures => $checkSignatures,
		maximumWatchTimeout => 0,
		};
}

sub process {
	my $o = shift;
	my $request = shift;

	my $path = $request->pathAbove($o->{root}) // return;

	# Objects request
	if ($request->path =~ /^\/objects\/([0-9a-f]{64})$/) {
		my $hash = CDS::Hash->fromHex($1);
		return $o->objects($request, $hash);
	}

	# Box request
	if ($request->path =~ /^\/accounts\/([0-9a-f]{64})\/(messages|private|public)$/) {
		my $accountHash = CDS::Hash->fromHex($1);
		my $boxLabel = $2;
		return $o->box($request, $accountHash, $boxLabel);

lib/CDS.pm  view on Meta::CPAN

	my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';

	$o->{ui}->progress('BOOK ', $hash->shortHex, ' on ', $o->{url});
	return $o->{store}->book($hash, $keyPair);
}

sub put {
	my $o = shift;
	my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
	my $object = shift; die 'wrong type '.ref($object).' for $object' if defined $object && ref $object ne 'CDS::Object';
	my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';

	$o->{ui}->progress('PUT ', $hash->shortHex, ' (', $o->{ui}->niceFileSize($object->byteLength), ') on ', $o->{url});
	return $o->{store}->put($hash, $object, $keyPair);
}

### Account store functions

sub list {
	my $o = shift;
	my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
	my $boxLabel = shift;
	my $timeout = shift;
	my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';

	$o->{ui}->progress($timeout == 0 ? 'LIST ' : 'WATCH ', $boxLabel, ' of ', $accountHash->shortHex, ' on ', $o->{url});
	return $o->{store}->list($accountHash, $boxLabel, $timeout, $keyPair);
}

sub add {
	my $o = shift;
	my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
	my $boxLabel = shift;
	my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
	my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';

	$o->{ui}->progress('ADD ', $accountHash->shortHex, ' ', $boxLabel, ' ', $hash->shortHex, ' on ', $o->{url});
	return $o->{store}->add($accountHash, $boxLabel, $hash, $keyPair);
}

sub remove {
	my $o = shift;
	my $accountHash = shift; die 'wrong type '.ref($accountHash).' for $accountHash' if defined $accountHash && ref $accountHash ne 'CDS::Hash';
	my $boxLabel = shift;
	my $hash = shift; die 'wrong type '.ref($hash).' for $hash' if defined $hash && ref $hash ne 'CDS::Hash';
	my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';

	$o->{ui}->progress('REMOVE ', $accountHash->shortHex, ' ', $boxLabel, ' ', $hash->shortHex, ' on ', $o->{url});
	return $o->{store}->remove($accountHash, $boxLabel, $hash, $keyPair);
}

sub modify {
	my $o = shift;
	my $modifications = shift;
	my $keyPair = shift; die 'wrong type '.ref($keyPair).' for $keyPair' if defined $keyPair && ref $keyPair ne 'CDS::KeyPair';

	$o->{ui}->progress('MODIFY +', scalar @{$modifications->additions}, ' -', scalar @{$modifications->removals}, ' on ', $o->{url});
	return $o->{store}->modify($modifications, $keyPair);
}

# Displays a record, and tries to guess the byte interpretation
package CDS::UI::Record;

sub display {
	my $class = shift;
	my $ui = shift;
	my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
	my $storeUrl = shift;

	my $o = bless {
		ui => $ui,
		onStore => defined $storeUrl ? $ui->gray(' on ', $storeUrl) : '',
		};

	$o->record($record, '');
}

sub record {
	my $o = shift;
	my $record = shift; die 'wrong type '.ref($record).' for $record' if defined $record && ref $record ne 'CDS::Record';
	my $context = shift;

	my $bytes = $record->bytes;
	my $hash = $record->hash;
	my @children = $record->children;

	# Try to interpret the key / value pair with a set of heuristic rules
	my @value =
		! length $bytes && $hash ? ($o->{ui}->gold('cds show record '), $hash->hex, $o->{onStore}) :
		! length $bytes ? $o->{ui}->gray('empty') :
		length $bytes == 32 && $hash ? ($o->{ui}->gold('cds show record '), $hash->hex, $o->{onStore}, $o->{ui}->gold(' decrypted with ', unpack('H*', $bytes))) :
		$context eq 'e' ? $o->hexValue($bytes) :
		$context eq 'n' ? $o->hexValue($bytes) :
		$context eq 'p' ? $o->hexValue($bytes) :
		$context eq 'q' ? $o->hexValue($bytes) :
		$context eq 'encrypted for' ? $o->hexValue($bytes) :
		$context eq 'updated by' ? $o->hexValue($bytes) :
		$context =~ /(^| )id( |$)/ ? $o->hexValue($bytes) :
		$context =~ /(^| )key( |$)/ ? $o->hexValue($bytes) :
		$context =~ /(^| )signature( |$)/ ? $o->hexValue($bytes) :
		$context =~ /(^| )revision( |$)/ ? $o->revisionValue($bytes) :
		$context =~ /(^| )date( |$)/ ? $o->dateValue($bytes) :
		$context =~ /(^| )expires( |$)/ ? $o->dateValue($bytes) :
			$o->guessValue($bytes);

	push @value, ' ', $o->{ui}->blue($hash->hex), $o->{onStore} if $hash && ($bytes && length $bytes != 32);
	$o->{ui}->line(@value);

	# Children
	$o->{ui}->pushIndent;
	for my $child (@children) { $o->record($child, $bytes); }
	$o->{ui}->popIndent;
}

sub hexValue {
	my $o = shift;
	my $bytes = shift;

	my $length = length $bytes;
	return '#'.unpack('H*', substr($bytes, 0, $length)) if $length <= 64;
	return '#'.unpack('H*', substr($bytes, 0, 64)), '…', $o->{ui}->gray(' (', $length, ' bytes)');
}

sub guessValue {
	my $o = shift;
	my $bytes = shift;

	my $length = length $bytes;
	my $text = $length > 64 ? substr($bytes, 0, 64).'…' : $bytes;
	$text =~ s/[\x00-\x1f\x7f-\xff]/·/g;
	my @value = ($text);

	if ($length <= 8) {
		my $integer = CDS->integerFromBytes($bytes);
		push @value, $o->{ui}->gray(' = ', $integer, $o->looksLikeTimestamp($integer) ? ' = '.$o->{ui}->niceDateTime($integer).' = '.$o->{ui}->niceDateTimeLocal($integer) : '');
	}

	push @value, $o->{ui}->gray(' = ', CDS->floatFromBytes($bytes)) if $length == 4 || $length == 8;
	push @value, $o->{ui}->gray(' = ', CDS::Hash->fromBytes($bytes)->hex) if $length == 32;
	push @value, $o->{ui}->gray(' (', length $bytes, ' bytes)') if length $bytes > 64;
	return @value;
}

sub dateValue {
	my $o = shift;
	my $bytes = shift;

	my $integer = CDS->integerFromBytes($bytes);
	return $integer if ! $o->looksLikeTimestamp($integer);
	return $o->{ui}->niceDateTime($integer), '  ', $o->{ui}->gray($o->{ui}->niceDateTimeLocal($integer));
}

sub revisionValue {
	my $o = shift;
	my $bytes = shift;

	my $integer = CDS->integerFromBytes($bytes);
	return $integer if ! $o->looksLikeTimestamp($integer);
	return $o->{ui}->niceDateTime($integer);
}

sub looksLikeTimestamp {
	my $o = shift;
	my $integer = shift;

	return $integer > 100000000000 && $integer < 10000000000000;
}

package CDS::UI::Span;

sub new {
	my $class = shift;

	return bless {
		text => [@_],
		};
}

sub printTo {
	my $o = shift;
	my $ui = shift;
	my $parent = shift;

	if ($parent) {