File Coverage

blib/lib/Protocol/Matrix.pm

Criterion	Covered	Total	%
statement	77	77	100.0
branch	20	32	62.5
condition	3	6	50.0
subroutine	19	19	100.0
pod	9	10	90.0
total	128	144	88.8

#  You may distribute under the terms of either the GNU General Public License
#  or the Artistic License (the same terms as Perl itself)
#
#  (C) Paul Evans, 2015 -- [e-mail]

package Protocol::Matrix;

use strict;
use warnings;
use 5.014; # s///r

our $VERSION = '0.02';

use Carp;

use Crypt::NaCl::Sodium;
use Digest::SHA qw( sha256 );
use JSON;
use MIME::Base64 qw( encode_base64 decode_base64 );

use Exporter 'import';
our @EXPORT_OK = qw(
   encode_json_for_signing
   encode_base64_unpadded
   decode_base64

   sign_json signed_json
   verify_json_signature

   redact_event redacted_event

   sign_event_json signed_event_json
   verify_event_json_signature
);

my $sign = Crypt::NaCl::Sodium->sign;

my $json_canon = JSON->new
                     ->convert_blessed
                     ->canonical
                     ->utf8;

=head1 NAME

C - Helper functions for the Matrix protocol

=head1 DESCRIPTION

This module provides some helper functions for implementing a F client
or server. Currently it only contains a few base-level functions to assist
with signing and verifying signatures on federation-level events.

=cut

=head1 FUNCTIONS

=cut

=head2 encode_json_for_signing

   $json = encode_json_for_signing( $data )

Encodes a given HASH reference as Canonical JSON, having removed the
C and C keys if present. This is the first step
towards signing it or verifying an embedded signature in it. The hash
referred to by C<$data> remains unmodified by this function.

=cut

sub encode_json_for_signing
{
   my ( $d ) = @_;

   # Remove keys that don't get signed
   my %to_sign = %$d;
   delete $to_sign{signatures};
   delete $to_sign{unsigned};

   return $json_canon->encode( \%to_sign );
}

=head2 encode_base64_unpadded

   $base64 = encode_base64( $bytes )

Returns a character string containing the Base-64 encoding of the given bytes,
with no internal linebreaks and no trailing padding.

=cut

sub encode_base64_unpadded
{
   return encode_base64( $_[0], "" ) =~ s/=+$//r;
}

=head2 decode_base64

   $bytes = decode_base64( $base64 )

Returns a byte string containing the bytes obtained by decoding the given
character string. This is re-exported from L for convenience.

=cut

=head2 sign_json

   sign_json( $data, secret_key => $key, origin => $name, key_id => $id )

Modifies the given HASH reference in-place to add a signature. This signature
is created from the given key, and annotated as being from the given origin
name and key ID. Existing signatures already in the hash are not disturbed.

The C<$key> should be a plain byte string or L object obtained
from L's C method.

=cut

sub sign_json
{
   my ( $data, %args ) = @_;

   my $key = $args{secret_key} or croak "Require a 'secret_key'";

   my $origin = $args{origin} or croak "Require an 'origin'";
   my $key_id = $args{key_id} or croak "Require a 'key_id'";

   my $signature = $sign->mac( encode_json_for_signing( $data ), $key );

   $data->{signatures}{$origin}{$key_id} = encode_base64_unpadded( $signature );
}

=head2 signed_json

   my $data = signed_json( $data, ... )

Returns a new HASH reference by cloning the original and applying
L to it. The originally-passed data is unmodified. Takes the same
arguments as L.

=cut

sub signed_json
{
   my ( $data, @args ) = @_;
   sign_json( $data = { %$data }, @args );
   return $data;
}

=head2 verify_json_signature

   verify_json_signature( $data, public_key => $key, origin => $name, key_id => $id )

Inspects the given HASH reference to check that it contains a signature from
the named origin, with the given key ID, and that it is actually valid.

This function does not return an interesting value; all failures are indicated
by thrown exceptions. If no exception is thrown, it can be presumed valid.

=cut

sub verify_json_signature
{
   my ( $data, %args ) = @_;

   my $key = $args{public_key} or croak "Require a 'public_key'";

   my $origin = $args{origin} or croak "Require an 'origin'";
   my $key_id = $args{key_id} or croak "Require a 'key_id'";

   $data->{signatures} or
      croak "No 'signatures'";
   $data->{signatures}{$origin} or
      croak "No signatures from '$origin'";

   my $signature = $data->{signatures}{$origin}{$key_id} or
      croak "No signature from '$origin' using key '$key_id'";

   $sign->verify( decode_base64( $signature ), encode_json_for_signing( $data ), $key ) or
      croak "Signature verification failed";
}

=head2 redact_event

   redact_event( $event )

Modifies the given HASH reference in-place to apply the transformation given
by the Matrix Event Redaction specification.

=cut

my %ALLOWED_KEYS = map { $_ => 1 } qw(
   auth_events
   depth
   event_id
   hashes
   membership
   origin
   origin_server_ts
   prev_events
   prev_state
   room_id
   sender
   signatures
   state_key
   type
);

my %ALLOWED_CONTENT_BY_TYPE = (
   "m.room.aliases"            => [qw( aliases )],
   "m.room.create"             => [qw( creator )],
   "m.room.history_visibility" => [qw( history_visibility )],
   "m.room.join_rules"         => [qw( join_rule )],
   "m.room.member"             => [qw( membership )],
   "m.room.power_levels"       => [qw(
      users users_default events events_default state_default ban kick redact
   )],
);

sub redact_event
{
   my ( $event ) = @_;

   defined( my $type = $event->{type} ) or
      croak "Event requires a 'type'";

   my $old_content = delete $event->{content};
   my $old_unsigned = delete $event->{unsigned};

   $ALLOWED_KEYS{$_} or delete $event->{$_} for keys %$event;

   my $new_content = $event->{content} = {};

   if( my $allowed_content_keys = $ALLOWED_CONTENT_BY_TYPE{$type} ) {
      exists $old_content->{$_} and $new_content->{$_} = $old_content->{$_} for
         @$allowed_content_keys;
   }

   $event->{unsigned}{age_ts} = $old_unsigned->{age_ts} if exists $old_unsigned->{age_ts};
}

sub redacted_event
{
   my ( $event ) = @_;
   redact_event( $event = { %$event } );
   return $event;
}

=head2 sign_event_json

   sign_event_json( $data, secret_key => $key, origin => $name, key_id => $id )

Modifies the given HASH reference in-place to add a hash and signature,
presuming it to be a Matrix event structure. This operates in a fashion
analogous to L.

=cut

sub sign_event_json
{
   my ( $event, %args ) = @_;

   my $key = $args{secret_key} or croak "Require a 'secret_key'";

   my $origin = $args{origin} or croak "Require an 'origin'";
   my $key_id = $args{key_id} or croak "Require a 'key_id'";

   # 'hashes' records the original unredacted version
   {
      my %event_without_hashes = %$event; delete $event_without_hashes{hashes};
      my $bytes_to_hash = encode_json_for_signing( \%event_without_hashes );

      $event->{hashes}{sha256} = encode_base64_unpadded( sha256( $bytes_to_hash ) );
   }

   # Signature is of redacted version
   sign_json( my $signed = redacted_event( $event ), %args );

   $event->{signatures} = $signed->{signatures};
}

=head2 signed_event_json

   my $event = signed_event_json( $event, ... )

Returns a new HASH reference by cloning the original and applying
L to it. The originally-passed data is unmodified. Takes the
same arguments as L.

=cut

sub signed_event_json
{
   my ( $event, @args ) = @_;
   sign_event_json( $event = { %$event }, @args );
   return $event;
}

=head2 verify_event_json_signature

   verify_event_json_signature( $event, public_key => $key, origin => $name, key_id => $id )

=cut

sub verify_event_json_signature
{
   my ( $event, @args ) = @_;

   verify_json_signature( redacted_event( $event ), @args );
}

=head1 AUTHOR

Paul Evans

=cut

0x55AA;