Source

p5-moosex-semantic / lib / MooseX / Semantic / Role / RdfExport.pm

package MooseX::Semantic::Role::RdfExport;
use Moose::Role;
use RDF::Trine qw(iri);
use RDF::Trine::Namespace qw(rdf);
use LWP::UserAgent;
use HTTP::Headers;
use HTTP::Request;
use Scalar::Util qw(blessed);
use MooseX::Semantic::Types qw( TrineLiteral);
use Data::Dumper;

with (
    'MooseX::Semantic::Role::Resource',
    'MooseX::Semantic::Util::TypeConstraintWalker',
);

has _user_agent => (
    is   => 'rw',
    isa  => 'LWP::UserAgent',
    lazy => 1,
    builder => '_build_user_agent',
);

sub _build_user_agent {
    my $self  = shift;
    my $agent = sprintf('%s/%s %s/%s ',
        ref $self, ($self->VERSION||'undef'),
        __PACKAGE__, (__PACKAGE__->VERSION||'undef'),
        );
    LWP::UserAgent->new(
        agent           => $agent,
        parse_head      => 0,
        max_redirect    => 2,
    );
}

sub export_to_model {
    my $self = shift;
    my ($model) = @_;
    unless ($model) {
        warn "No model supplied, create temporary model";
        $model = RDF::Trine::Model->temporary_model;
    }

    # rdf:type
    for my $this_type (@{ $self->rdf_type }) {
        $model->add_statement(RDF::Trine::Statement->new(
            $self->rdf_about,
            $rdf->type,
            $this_type,
        ));
    }
    ATTR:
    for my $attr_name ($self->meta->get_attribute_list) {
        my $attr = $self->meta->get_attribute($attr_name);
        my $attr_type = $attr->type_constraint;
        my $val = $self->$attr_name;
        next unless ($val);
        next unless ($attr->does('MooseX::Semantic::Meta::Attribute::Trait'));
        # XXX if an attribute has no type constraint, just skip it for now. would
        # need heuristics otherwise, maybe later.
        next unless ($attr->type_constraint);
        my @rels_to_export;
        # TODO what's uri_writer supposed to do? Replace uri or add to it?
        push (@rels_to_export, $attr->uri) if $attr->has_uri;
        push (@rels_to_export, @{$attr->uri_writer}) if $attr->has_uri_writer;
        for my $rel (@rels_to_export) {
            if ($self->_find_parent_type($attr->type_constraint, 'Value')) {
                $self->_export_one_scalar($val, $rel, $model, $attr->rdf_lang, $attr->rdf_datatype);
            }
            elsif ($self->_find_parent_type($attr->type_constraint, 'Object')) {
                $self->_export_one_object($val, $rel, $model);
            }
            elsif ($self->_find_parent_type($attr->type_constraint, 'ArrayRef')) {

                # XXX TODO if an array isn't constrainted on its elements continue, heuristics needed
                # next unless $attr->type_constraint->can('type_parameter');

                # my $subtype = $attr->type_constraint->type_parameter;
                if ( ! $attr_type->can('type_parameter')
                    || $attr_type->type_parameter eq 'Str'
                    || $self->_find_parent_type( $attr_type->type_parameter, 'Num' )
                    || $self->_find_parent_type( $attr_type->type_parameter, 'Bool' ))
                {
                    for ( @{$val} ) {
                        $self->_export_one_scalar( $_, $rel, $model, $attr->rdf_lang, $attr->rdf_datatype );
                    }
                }
                elsif ( $self->_find_parent_type( $attr_type->type_parameter, 'Object' ) 
                   || $self->_find_parent_type( $attr_type->type_parameter, 'ClassName' ) ) {
                    for (@{$val}) {
                        $self->_export_one_object($_, $rel, $model);
                    }
                }
            }
            else {
                # TODO
                warn "Unimplemented for ref " . ref($val);
                next ATTR;
            }
        }
    }
    return $model;
}

sub _export_one_object {
    my ($self, $single_val, $rel, $model) = @_;
    if (blessed $single_val) {
        if ($single_val->does('MooseX::Semantic::Role::RdfExport')) {
            #
            # Here's the recursion
            #
            $single_val->export_to_model($model);
            $model->add_statement(RDF::Trine::Statement->new(
                $self->rdf_about,
                $rel,
                $single_val->rdf_about
            ));
        } else {
            warn "Can't export this object since it doesn't MooseX::Semantic::Role::RdfExport";
        }
    }
    else {
        confess 'Trying to export unblessed reference like an object';
    }
}
sub _export_one_scalar {
    my ($self, $val, $rel, $model, $lang, $datatype) = @_;
    my $lit;
    if ($lang) {
        $lit = RDF::Trine::Node::Literal->new($val, $lang);
    } elsif ($datatype) {
        $lit = RDF::Trine::Node::Literal->new($val, undef, $datatype);
    } else {
        $lit = TrineLiteral->coerce($val);
    }
    $model->add_statement(RDF::Trine::Statement->new(
        $self->rdf_about,
        $rel,
        $lit,
    ));
}

sub _get_serializer{
    my $self = shift;
    my (%opts) = @_;
    my $format =  $opts{format} || 'turtle';
    my $options = $opts{serializer_opts} || {};
    my $serializer = RDF::Trine::Serializer->new($format, %{$options} );
    return $serializer;
}

sub export_to_string {
    my ($self, %opts) = @_;
    my $model = $self->export_to_model($opts{model});
    # my $iter = $model->get_statements;
    # while ($_ = $iter->next) {
    #     warn Dumper [
    #         $_->subject->uri,
    #         $_->predicate->uri,
    #         $_->object->as_string,
    #     ];
    # }
    my $serializer = $self->_get_serializer(%opts)->serialize_model_to_string($model); 
}
sub export_to_file {
    my ($self, $fh, %opts) = @_;
    if (! ref $fh) {
        open $fh, ">", $fh;
    } elsif (ref $fh ne 'GLOB') {
        warn "can't open file for ref type " . ref $fh;
        return;
    }
    my $model = $self->export_to_model($opts{model});
    # TODO prove that data was actually written out to $fh
    # and return undef otherwise
    $self->_get_serializer(%opts)->serialize_model_to_file($fh, $model); 
    return 1;
}

sub export_to_web {
    my ($self, $method, $uri, %opts) = @_;
    confess "Method must be PUT or POST" unless $method =~ /^(PUT|POST)$/;
    
    ### XXX: It would be handy if there were an application/sparql-update
    ###      serializer for Trine.
    my $ser = $self->_get_serializer(%opts);
    my ($type) = $ser->media_types;
    
    my $req = HTTP::Request->new($method => $uri);
    $req->header(Content_Type => $type);
    $req->header(From => $opts{http_from}) if exists $opts{http_from};
    
    my $model = $self->export_to_model($opts{model});
    $req->content( $ser->serialize_model_to_string($model) );
    
    my $res = $self->_user_agent->request($req);
    $res->is_success or
        confess("<%s> HTTP %d Error: %s", $uri, $res->code, $res->message);
}


1;