File Coverage

blib/lib/Bb/Collaborate/Ultra/DAO.pm

Criterion	Covered	Total	%
statement	103	217	47.4
branch	19	72	26.3
condition	6	59	10.1
subroutine	20	32	62.5
pod	12	13	92.3
total	160	393	40.7

package Bb::Collaborate::Ultra::DAO;
use warnings; use strict;
use Mouse;
use parent qw{Class::Data::Inheritable};
use JSON;
use Bb::Collaborate::Ultra::Util;
use Mouse::Util::TypeConstraints;
use Data::Compare;
use Clone;

use 5.008003;

__PACKAGE__->mk_classdata('_types');
__PACKAGE__->mk_classdata('_db_data');
__PACKAGE__->mk_classdata('resource');
__PACKAGE__->mk_classdata('_query_params' => {
    limit => 'Int',
    offset => 'Int',
    fields => 'Str',
});
has '_connection' => ('is' => 'rw');
has '_parent' => ('is' => 'rw');

our %enums;

=pod

L is an abstract base class for various resource classes (e.g. L) and contains both builder and inherited methods from implementing these classes.

=head1 ABSTRACT METHODS

The following methods are inherited from this class.

=cut

=head2 new

Creates a new object.

=cut

=head2 post

Creates object on the server. E.g.

    my $start = time() + 60;
    my $end = $start + 900;
    my $session = Bb::Collaborate::Ultra::Session->post($connection, {
	    name => 'Test Session',
	    startTime => $start,
	    endTime   => $end,
	    },
	);

=cut

sub post {
    my $class = shift;
    my $connection = shift;
    my $data = shift;
    die 'usage: '.$class.'->post($connection, $data)'
	unless $connection && $data && $connection->can('POST');
    my %opt = @_;
    my $json = $class->_freeze($data);
    my $path = $opt{path} || $class->path
	or die "no POST path";

    my $msg = $connection->POST($path, $json, @_);
    $class->construct($msg, connection => $connection);
}

=head2 patch

Updates an existing object

    $session->name('Test Session - Updated');
    $session->endTime($session->endTime + 60);
    $session->patch; # enact updates

=cut

sub patch {
    my $self = shift;
    my $connection = shift || $self->connection
	|| die "no connected";
    my $update_data = shift || $self->_pending_updates;
    my $class = ref($self) || $self;
    my $path = $self->path;
    my $json = $class->_freeze($update_data);
    my $msg = $connection->PATCH($path, $json);
    my $obj = $self->construct($msg, connection => $connection);
    if ($self) {
	$self->_db_data( $obj->_db_data );
	$obj->parent($self->parent);
    }
    $obj;
}

=head2 get

Fetches one or more objects from the server.

    my @future_sessions = Bb::Collaborate::Ultra::Session->get($connection, {endTime => time(), limit => 50}, )

=cut

sub get {
    my $self = shift;
    my $connection = shift;
    my $query_data = shift || {};
    my %opt = @_;
    my $class = ref($self) || $self;
    die 'usage: '.$class.'->get($connection, [$query_data], %opt)'
	unless $connection && $connection->can('GET');

    my $path = $opt{path};
    $path ||= $query_data->{id}
	    ? $class->resource . '/' . $query_data->{id}
	    : $class->resource;
    if (keys %$query_data) {
	$path .= $connection->client->buildQuery($class->TO_JSON($query_data));
    }
    my $msg = $connection->GET($path);
    $msg->{results}
	? map { $class->construct($_, connection => $connection, parent => $opt{parent}) } @{ $msg->{results} }
	: $class->construct($msg, connection => $connection, parent => $opt{parent});
}

=head2 delete

Deletes an object from the server

    $session->delete;

=cut

sub delete {
    my $self = shift;
    my $connection = shift
	|| $self->connection
	|| die 'Not connected';
    my $data = shift || {id => $self->id};
    my $path = $self->resource;
    $connection->DELETE($path, $data);
}

=head2 find_or_create

Attempts a C on the object. If that fails, creates an new object on the server.

=cut

sub find_or_create {
    my $class = shift;
    my $connection = shift;
    my $data = shift;

    my $params = $class->query_params;
    my $props = $class->_property_types;
    my %query;
    my %body;

    for my $fld (keys %$data) {
	my $val = $data->{$fld};
	if (exists $params->{$fld}) {
	    $query{$fld} = $val;
	}
	elsif (exists $props->{$fld}) {
	    $body{$fld} = $val;
	}
	else {
	    warn "$class: ignoring unknown field: $fld";
	}
    }
    my @recs = $class->get($connection, \%query);
    my $rec;
    if (@recs) {
	warn "$class: ambiguous find_or_create query: @{[ keys %query ]}\n"
	    if @recs > 1;
	$rec = $recs[0];
	for (keys %body) {
	    $rec->$_($body{$_});
	}
    }
    else {
	$rec = $class->post($connection => $data);
    }
    $rec;
}

=head2 path

Computes a RESTful resource path for the object.

=cut

sub path {
    my $self = shift;
    my %opt = @_;
    my $parent = $opt{parent};
    $parent ||= $self->parent
	if ref($self);
    my $path = '';
    $path .= $parent->path . '/'
	if $parent;
    $path .= $self->resource;
    my $id = ref $self && $self->id;
    $path .= '/' . $id if $id;
    $path;
}

=head2 parent

Returns any parent class for the object. May be used to compute the path.

=cut

 sub parent { shift->_parent(@_)}

=head2 changed

Returns a list of fields that have been updated since the
object was last saved via a `patch`, or `post`, or fetched
via a `get`.

=cut

sub changed {
    my $self = shift;
    my @changed;

    if (my $old_data = $self->_db_data) {
	my $types = $self->_property_types;
	my $data = $self->_raw_data;
	# include only key and changed data
	for my $fld (sort keys %$data) {
	    # ignore time-stamps
	    next if $fld =~ /^(id|modified|created)$/;
	    my $new_val = $data->{$fld};
	    my $old_val = $old_data->{$fld};
	    push @changed, $fld
		    if !defined($old_val)
		    || $self->_compare($types->{$fld}, $old_val, $new_val);
	}
    }
    @changed;
}

sub _compare {
    my $self = shift;
    my $type = shift;
    my $v1 = shift;
    my $v2 = shift;
    $type eq 'Bool'
	? ($v1? 1: 0) != ($v2? 1 : 0)
	: ($type eq 'Date'
	      ? do { abs($v1 - $v2) > 1 }  # allow for rounding
              : !Compare($v1, $v2));
}

sub _pending_updates {
    my $self = shift;
    my $data = $self->_raw_data;
    my %pending;
    @pending{ $self->changed } = undef;
    # pass the primary key
    $pending{id} = undef;
    my %updates = map { $_ => $data->{$_} } (sort keys %pending);
    \%updates;
}

=head2 connection

Returns the connection associated with the object. Will be set if
the object has been fetched via a `get`, added via a `post` or updated via a `patch`.

=cut

sub connection { shift->_connection(@_)}


=head1 Internal METHODS

=cut

=head2 query_params

    __PACKAGE__->query_params(
        name => 'Str',
        extId => 'Str',
    );

This is used to specify any additional payload fields that may be
passed as query parameters, or returned along with object data.

=cut

sub query_params {
    my ($entity_class, %params) = @_;

    for (keys %params) {
	$entity_class->_query_params->{$_} = $params{$_};
    }

    return $entity_class->_query_params;
}

sub _property_types {
    my $class = shift;
    my $types = $class->_types;
    unless ($types) {
	my $meta = $class->meta;
	my @atts = grep { $_ !~ /^_/ } ($meta->get_attribute_list);

	$types = {
	    map {$_ => $meta->get_attribute($_)->{type_constraint}} @atts
	};
	$class->_types($types);
    }
    $types;
}

=head2 freeze

Serializes an object to JSON., with data conversion.

=over 4

=item Dates are converted from numeric Unix timestamps to date-strings

=item Booleans are converted from numeric (0, 1) to 'true', or 'false'.

=item Nested objects are recursively serialized.

=back

=cut

sub _freeze {
    my $self = shift;
    my $frozen = $self->TO_JSON(@_);
    to_json $frozen, { convert_blessed => 1};
}

sub _raw_data {
    my $self = shift;
    my $types = $self->_property_types;
    my %data = (map { $_ => $self->$_ }
		grep { defined $self->$_ }
		(keys %$types));
    \%data;
}

sub TO_JSON {
    my $self = shift;
    my $props = $self->_property_types;
    my $params = $self->query_params;
    my $data = shift || $self->_raw_data;

    my %frozen;

    for my $fld (keys %$data) {
	my $type = $props->{$fld} || $params->{$fld} || do {
	    warn((ref($self) || $self).": unknown field/query-parameter: $fld");
	    'Str'
	};

	my $val = $data->{$fld};
	$frozen{$fld} = Bb::Collaborate::Ultra::Util::_freeze($val, $type)
	    if defined $val;
    }
    \%frozen;
}

=head2 thaw

The reverse of `freeze`. Deserializes JSON data to objects, with conversion of dates, boolean values or nested objects.

=cut

sub _thaw {
    my $self = shift;
    my $data = shift;
    my $types = $self->_property_types;
    my %thawed;

    for my $fld (keys %$data) {
	if (exists $types->{$fld}) {
	    my $val = $data->{$fld};
	    $thawed{$fld} = Bb::Collaborate::Ultra::Util::_thaw($val, $types->{$fld})
		if defined $val;
	}
	else {
	    my $class = ref($self) || $self;
	    warn $class." ignoring field: $fld";
	}
    }
    \%thawed;
}

=head2 construct

Constructs a new object from server data.

=cut

sub construct {
    my $class = shift;
    my $payload = shift;
    my %opt = @_;
    my $data = $class->_thaw($payload);
    my $obj = $class->new($data);
    for ($opt{connection}) {
	$obj->connection($_) if $_
    }
    for ($opt{parent}) {
	$obj->parent($_) if $_;
    }
    # make a copy, so we can detect updates
    $obj->_db_data(Clone::clone $data);
    $obj;
}

=head2 load_schema

Constructs the object class from JSON schema data

=cut

sub load_schema {
    my $class = shift;
    my $data = join("", @_);
    my $schema = from_json($data);
    my $properties = $schema->{properties}
	or die 'schema has no properties';

    foreach my $prop (sort keys %$properties) {
	next if $class->meta->get_attribute($prop);
	my $prop_spec = $properties->{$prop};
	my $isa = $class->_build_isa( $prop, $prop_spec);
	my $required = $prop_spec->{required} ? 1 : 0;
	$class->meta->add_attribute(
	    $prop => (isa => $isa, is => 'rw', required => $required),
	    );
    }
}

sub _build_isa {
    my $class = shift;
    my $prop = shift;
    my $prop_spec = shift;
    my $isa;
    my $type = $prop_spec->{type}
       or die "property has no type: $prop";
    if ($type eq 'array') {
       my $of_type = $class->_build_isa($prop, $prop_spec->{items});
       $isa = 'ArrayRef[' . $of_type . ']';
    }
    elsif (my $enum = $prop_spec->{enum}) {
       my @enum = map { lc } (@$enum);
       # create an anonymous enumeration
       my $enum_name = 'enum_' . join('_', @enum);
       $isa = $enums{$enum_name} ||= Mouse::Util::TypeConstraints::enum( $enum_name, \@enum);
    }
    else {
       $isa = {string => 'Str',
               boolean => 'Bool',
               integer => 'Int',
               object => 'Object',
       }->{$type}
           or die "unknown type: $type";
       if ($isa eq 'Object' || $isa eq 'Array') {
           warn "unknown $prop object. Predeclare in $class?";
       }
    }
    my $format = $prop_spec->{format};
    $isa = 'Date' if $format && $format eq 'DATE_TIME';
    $isa;
}

#
# Shared subtypes
#
BEGIN {
    use Mouse::Util::TypeConstraints;

    subtype 'Date'
	=> as 'Num'
	=> where {m{^\d+(\.\d*)?$}}
	=> message {"invalid date: $_"};
}

=head1 LICENSE AND COPYRIGHT

Copyright 2016 David Warring.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

1;