RDF::AllegroGraph::Repository4 - AllegroGraph repository handle for AGv4

package RDF::AllegroGraph::Repository4;

use strict;
use warnings;

use base qw(RDF::AllegroGraph::Repository);

use Data::Dumper;
use feature "switch";

use JSON;
use URI::Escape qw/uri_escape_utf8/;

use HTTP::Request::Common;

sub new {
    my $class = shift;
    my %options = @_;
    my $self = bless \%options, $class;
    $self->{path} = $self->{CATALOG}->{SERVER}->{ADDRESS} . ($self->{CATALOG}->{NAME} eq '/'
                                                             ? ''
                                                             : '/catalogs' . $self->{CATALOG}->{NAME} ) . '/repositories/' . $self->{id};
    return $self;
}

sub id {
    my $self = shift;
    return $self->{CATALOG}->{NAME} eq '/'
           ? '/' . $self->{id}
           : $self->{CATALOG}->{NAME} . '/' . $self->{id};
}

sub disband {
    my $self = shift;
    my $requ = HTTP::Request->new (DELETE => $self->{path});
    my $resp = $self->{CATALOG}->{SERVER}->{ua}->request ($requ);
    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
}

sub size {
    my $self = shift; 
    my $resp = $self->{CATALOG}->{SERVER}->{ua}->get ($self->{path} . '/size');
    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success; 
    return $resp->content;
}

sub session {
    my $self = shift;
    my %opts = @_;
    $opts{autoCommit} ||= 'true';                                        # this is - by default - a session, so whatever we do, it will shine through
    my $resp = $self->{CATALOG}->{SERVER}->{ua}->post ($self->{path} . '/session', %opts);
    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success; 
    my $url = $resp->content;
    $url =~ s/^\"//; $url =~ s/\"$//;                                    # for some very odd reason we get this URI in the content
    {                                                                    # try to find authentication information inside the repo URL
	if ($self->{path} =~ m{http://(.+?@)}) {
	    my $auth = $1;
	    $url =~ s{http://}{http://$auth};
	}
    }
    if ($opts{autoCommit} eq 'true') {                                              # we do like 'true' strings ...
	use RDF::AllegroGraph::Session4;
	return new RDF::AllegroGraph::Session4     (path    => $url,                # the newly returned URL will be its home
						    CATALOG => $self->{CATALOG});   # and the catalog will be the same
    } else {
	use RDF::AllegroGraph::Transaction4;
	return new RDF::AllegroGraph::Transaction4 (path    => $url,                # the newly returned URL will be its home
						    CATALOG => $self->{CATALOG});   # and the catalog will be the same
    }
}

sub transaction {
    my $self = shift;
    return $self->session (autoCommit => 'false');
}

sub blanks {
    my $self = shift;
    my $amount = shift || 1;

    my $resp  = $self->{CATALOG}->{SERVER}->{ua}->post ($self->{path} . '/blankNodes', 
							'Content-Type' => 'application/x-www-form-urlencoded',
							'Accept' => 'application/json',
							'Content' => { 'amount' => $amount });
    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
    return @{ from_json ($resp->content) };
}

sub add {
    _put_post_stmts ('POST', @_);
}

sub _put_post_stmts {
    my $method = shift;
    my $self   = shift;

    my @stmts;                                                                  # collect triples there
    my $n3;                                                                     # collect N3 stuff there
    my @files;                                                                  # collect file names here
    use Regexp::Common qw/URI/;

    foreach my $item (@_) {                                                     # walk through what we got
	if (ref($item) eq 'ARRAY') {                                            # a triple statement
	    push @stmts, $item;
	} elsif (ref ($item)) {
	    die "don't know what to do with it";
	} elsif ($item =~ /^$RE{URI}{HTTP}/) {
	    push @files, $item;
	} elsif ($item =~ /^$RE{URI}{FTP}/) {
	    push @files, $item;
	} elsif ($item =~ /^$RE{URI}{file}/) {
	    push @files, $item;
	} else {                                                                # scalar => N3
	    $n3 .= $item;
	}
    }

    my $ua = $self->{CATALOG}->{SERVER}->{ua};                                  # local handle

    if (@stmts) {                                                               # if we have something to say to the server
	given ($method) {
	    when ('POST') {
		my $resp  = $ua->post ($self->{path} . '/statements',
				       'Content-Type' => 'application/json', 'Content' => encode_json (\@stmts) );
		die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
	    }
	    when ('PUT') {
		my $requ = HTTP::Request->new (PUT => $self->{path} . '/statements',
					       [ 'Content-Type' => 'application/json' ], encode_json (\@stmts));
		my $resp = $ua->request ($requ);
		die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
	    }
	    when ('DELETE') {                                                     # DELETE
		# first bulk delete facts, i.e. where there are no wildcards
		my @facts      = grep { defined $_->[0]   &&   defined $_->[1] &&   defined $_->[2] } @stmts;
		my $requ = HTTP::Request->new (POST => $self->{path} . '/statements/delete',
					       [ 'Content-Type' => 'application/json' ], encode_json (\@facts));
		my $resp = $ua->request ($requ);
		die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;

		# the delete one by one those with wildcards
		my @wildcarded = grep { ! defined $_->[0] || ! defined $_->[1] || ! defined $_->[2] } @stmts;
		foreach my $w (@wildcarded) {
		    my $requ = HTTP::Request->new (DELETE => _to_uri ($self->{path} . '/statements', $w, {}) );
		    my $resp = $ua->request ($requ);
		    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
		}
	    }
	    default { die "You should never end here: Unhandled '$method'"; }
	}
    }
    if ($n3) {                                                                  # if we have something to say to the server
	my $requ = HTTP::Request->new ($method => $self->{path} . '/statements', [ 'Content-Type' => 'text/plain' ], $n3);
	my $resp = $ua->request ($requ);
	die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
    }
    for my $file (@files) {                                                     # if we have something to say to the server
	use LWP::Simple;
	my $content = get ($file) or die "Could not open URL '$file'";
	my $mime;                                                               # lets guess the mime type
	given ($file) {                                                         # magic does not normally cope well with RDF/N3, so do it by extension
	    when (/\.n3$/)  { $mime = 'text/plain'; }                           # well, not really, since its text/n3
	    when (/\.nt$/)  { $mime = 'text/plain'; }
	    when (/\.xml$/) { $mime = 'application/rdf+xml'; }
	    when (/\.rdf$/) { $mime = 'application/rdf+xml'; }
	    default { die; }
	}

	my $requ = HTTP::Request->new ($method => $self->{path} . '/statements', [ 'Content-Type' => $mime ], $content);
	my $resp = $ua->request ($requ);
	die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;

	$method = 'POST';                                                        # whatever the first was, the others must add to it!
    }


}

sub _to_uri {
    my $path    = shift;
    my $w       = shift;
    my $options = shift;

    my $url = new URI ($path);
    $url->query_form ((defined $w->[0]
                             ? ('subj' => $w->[0])
                             : () ),
                          (defined $w->[1]
                             ? ('pred' => $w->[1])
                             : () ),
                          (ref ($w->[2]) eq 'ARRAY'
                             ? ('obj'    => $w->[2]->[0],
				'objEnd' => $w->[2]->[1]
				)
                             : (defined $w->[2]
                                ? ('obj'    => $w->[2])
                                : ()
				)),
			  (defined $options->{limit}
			   ? (limit => $options->{limit})
			   : ())
			  );
    return $url;
}

sub replace {
    _put_post_stmts ('PUT', @_);
}

sub delete {
    _put_post_stmts ('DELETE', @_);
}

sub match {
    my $self = shift;
    my $options = ref($_[0]) eq 'HASH' ? shift : {};

    my @stmts;
    my $ua = $self->{CATALOG}->{SERVER}->{ua};
    foreach my $w (@_) {
	my $resp  = $ua->get (_to_uri ($self->{path} . '/statements', $w, $options));
	die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
	push @stmts, @{ from_json ($resp->content) };
    }
    return @stmts;
}

sub _query {
    my $self  = shift;
    my $query = shift;
    my $lang  = shift || 'sparql';
    my %options = @_;

    $options{RETURN} ||= 'TUPLE_LIST';        # a good default
    my $NAMED = 0;
    ($NAMED, $options{RETURN}) = (1, 'TUPLE_LIST') if $options{RETURN} eq 'NAMED_TUPLE_LIST';        # store the info that we should return the names as well

    my @params;
    push @params, "queryLn=$lang";
    push @params, 'query='.uri_escape_utf8 ($query);
    push @params, 'infer='.uri_escape_utf8 ($options{INFERENCING}) if defined $options{INFERENCING};
    
    my $resp  = $self->{CATALOG}->{SERVER}->{ua}->get ($self->{path} . '?' . join ('&', @params) );
    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;

    my $json = from_json ($resp->content);
    given ($options{RETURN}) {
	when ('TUPLE_LIST') {
	    return $NAMED ? ($json) : @{ $json->{values} };
	}
	default { die };
    }
}

sub sparql {
    my $self = shift;
    my $query = shift;

    return _query ($self, $query, 'sparql', @_);
}

sub prolog {
    my $self = shift;
    my $query = shift;

    return _query ($self, $query, 'prolog', @_);
}

sub namespaces {
    my $self = shift;
    my $resp = $self->{CATALOG}->{SERVER}->{ua}->get ($self->{path} . '/namespaces');
    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
    return
	map { $_->{prefix} => $_->{namespace} }
	@{ from_json ($resp->content) };
}

sub namespace {
    my $self = shift;
    my $prefix = shift;

    my $uri = $self->{path} . '/namespaces/' . $prefix;
    if (scalar @_) {   # there was a second argument!
        if (my $nsuri = shift) {
	    my $requ = HTTP::Request->new ('PUT' => $uri, [ 'Content-Type' => 'text/plain' ], $nsuri);
	    my $resp = $self->{CATALOG}->{SERVER}->{ua}->request ($requ);
	    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
	    return $nsuri;
	} else {
	    my $requ = HTTP::Request->new ('DELETE' => $uri);
	    my $resp = $self->{CATALOG}->{SERVER}->{ua}->request ($requ);
	    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
	}
    } else {
	my $resp = $self->{CATALOG}->{SERVER}->{ua}->get ($uri);
	return undef if $resp->code == 404;
	die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
	return $resp->content =~ m/^"?(.*?)"?$/ && $1;
    }
}

sub geotypes {
    my $self = shift;
    my $resp = $self->{CATALOG}->{SERVER}->{ua}->get ($self->{path} . '/geo/types');
    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
    return  @{ from_json ($resp->content) };
}

sub spherical {
    my $self = shift;
    my $region = shift;
    my $scale  = shift;

    use Regexp::Common;
    die "scale information must be of the form 5 mile, or 10 km, or similar"
	unless ($scale =~ /($RE{num}{real})(\s+(degree|mile|km|radian))?/);

    my $stripW = $1;
    my $unit   = $3 if $2; # leave it undef otherwise

    my $url = new URI ($self->{path} . '/geo/types/spherical');
    $url->query_form (stripWidth => $stripW,
		      ($unit
		          ? (unit => $unit) # be explicit
		          : ()
		       )
		      );

    my $resp = $self->{CATALOG}->{SERVER}->{ua}->request (POST $url);
    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
    return $resp->content =~ m/^"?(.*?)"?$/ && $1;
}

sub cartesian {
    my $self = shift;

    my $url = new URI ($self->{path} . '/geo/types/cartesian');

    use Regexp::Common;
    if ($_[0] =~ /($RE{num}{real})x($RE{num}{real})(\+($RE{num}{real})\+($RE{num}{real}))?/) {
	shift;
	my ($W, $H, $X, $Y) = ($1, $2, $4||0, $5||0);
	my $stripW = shift;
	$url->query_form (stripWidth => $stripW, xmin => $X, xmax => $X+$W, ymin => $Y, ymax => $Y+$H);
    } else {
	my ($X1, $Y1, $X2, $Y2, $stripW) = @_;
	$url->query_form (stripWidth => $stripW, xmin => $X1, xmax => $X2, ymin => $Y1, ymax => $Y2);
    }

    my $resp = $self->{CATALOG}->{SERVER}->{ua}->request (POST $url);
    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
    return $resp->content =~ m/^"?(.*?)"?$/ && $1;
}

sub inBox {
    my $self    = shift;
    my $geotype = shift;
    my $pred    = shift;
    my ($xmin, $ymin, $xmax, $ymax) = @_;
    my $options = $_[4] || {};

    my $url = new URI ($self->{path} . '/geo/box');
    $url->query_form (type => $geotype,
		      predicate => $pred,
		      xmin => $xmin,
		      ymin => $ymin,
		      xmax => $xmax,
		      ymax => $ymax,
		      (defined $options->{limit}
		        ? (limit => $options->{limit})
			   : ())
		      );
    my $resp = $self->{CATALOG}->{SERVER}->{ua}->request (GET $url);
    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
    return @{ from_json ($resp->content) };
}

sub inCircle {
    my $self    = shift;
    my $geotype = shift;
    my $pred    = shift;
    my ($x, $y, $radius) = @_;
    my $options = $_[3] || {};

    my $url = new URI ($self->{path} . '/geo/circle');
    $url->query_form (type      => $geotype,
		      predicate => $pred,
		      x         => $x,
		      y         => $y,
		      radius    => $radius,
		      (defined $options->{limit}
		        ? (limit => $options->{limit})
			   : ())
		      );
    my $resp = $self->{CATALOG}->{SERVER}->{ua}->request (GET $url);
    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
    return @{ from_json ($resp->content) };
}

sub inPolygon {
    my $self    = shift;
    my $geotype = shift;
    my $pred    = shift;
    my @points;
    while (ref($_[0]) eq 'ARRAY') { 
	use RDF::AllegroGraph::Utils qw(coord2literal);
	push @points, coord2literal ($geotype, @{ shift @_ });
    }
    my $options = shift || {};

    my ($blank) = $self->blanks;                                           # get one blank node

    my $url  = new URI ($self->{path} . '/geo/polygon');                   # build request to park polygon temporarily
    $url->query_form (resource => $blank,                                  # under the blank node
		      point    => \@points                                 # with these points expanded
		      );
    my $resp = $self->{CATALOG}->{SERVER}->{ua}->request (PUT $url);       # AGv4 does seem to require to have that URL encoded (with PUT??)
    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;

    $url  = new URI ($self->{path} . '/geo/polygon');                      # build request to park polygon temporarily
    $url->query_form (polygon   => $blank,                                 # under the blank node
		      type      => $geotype,                               # for this geotype
		      predicate => $pred,                                  # and for this predicate
		      (defined $options->{limit}
		        ? (limit => $options->{limit})
			: ())
		      );
    $resp = $self->{CATALOG}->{SERVER}->{ua}->request (GET $url);          # now we make the real query
    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
    return @{ from_json ($resp->content) };
}

sub valid_indices {
    my $self = shift;
    my $url  = new URI ($self->{path} . '/indices?listValid=true');
    my $resp = $self->{CATALOG}->{SERVER}->{ua}->request (GET $url);
    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
    return @{ from_json ($resp->content) };
}

sub indices {
    my $self = shift;
    foreach my $sidx (@_) {                                                       # in the case we want changes to be made
	if ($sidx =~ m{\-(.+)}) {                                                 # removal of indices
	    my $url  = new URI ($self->{path} . '/indices/' . $1);
	    my $requ = HTTP::Request->new (DELETE => $url);
	    my $resp = $self->{CATALOG}->{SERVER}->{ua}->request ($requ);
	    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;

	} elsif ($sidx =~ m{\+(.+)}) {                                            # adding of indices
	    my $url  = new URI ($self->{path} . '/indices/' . $1);
	    my $requ = HTTP::Request->new (PUT => $url);
	    my $resp = $self->{CATALOG}->{SERVER}->{ua}->request ($requ);
	    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;

	} else {                                                                  # not sure what this is => ignorance is bliss
	    warn "not sure what to do with '$sidx', ignoring ...";
	}
    }
    # now collect the state of affairs from the server
    my $url  = new URI ($self->{path} . '/indices');
    my $resp = $self->{CATALOG}->{SERVER}->{ua}->request (GET $url);
    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
    return @{ from_json ($resp->content) };
}

sub _mode {
    my $ua = shift;
    my $path = shift;
    my $val  = shift;

    if (defined $val) {
	if ($val) {
	    my $resp = $ua->request (PUT $path, 'Content' => $val);
	    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
	} else {
	    my $requ = HTTP::Request->new (DELETE => $path);
	    my $resp = $ua->request ($requ);
	    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
	}
    }
    my $resp = $ua->get ($path);
    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
    return $resp->content eq 'true';
}

sub bulk_loading_mode {
    my $self = shift;
    my $val  = shift;

    return _mode ($self->{CATALOG}->{SERVER}->{ua}, $self->{path} . '/bulkMode', $val);

}

sub commit_mode {
    my $self = shift;
    my $val  = shift;

    return ! _mode ($self->{CATALOG}->{SERVER}->{ua}, $self->{path} . '/noCommit', defined $val ? abs($val-1) : undef);
}

sub duplicate_suppression_mode {
    my $self = shift;
    my $val  = shift;

    return _mode ($self->{CATALOG}->{SERVER}->{ua}, $self->{path} . '/deleteDuplicates', $val);
}

our $VERSION  = '0.07';

1;

__END__