File Coverage

blib/lib/SeeAlso/Server.pm

Criterion	Covered	Total	%
statement	149	231	64.5
branch	75	146	51.3
condition	28	49	57.1
subroutine	18	25	72.0
pod	10	10	100.0
total	280	461	60.7

use strict;
use warnings;
package SeeAlso::Server;
{
  $SeeAlso::Server::VERSION = '0.71';
}
#ABSTRACT: SeeAlso Linkserver Protocol Server

use utf8;

use Carp qw(croak);
use CGI qw(-oldstyle_urls 3.0);

Carp::carp(__PACKAGE__." is deprecated - please use Plack::App::SeeAlso instead!");

use SeeAlso::Identifier;
use SeeAlso::Response;
use SeeAlso::Source;

use base 'Exporter';
our @EXPORT_OK = qw(xmlencode);


sub new {
    my ($class, %params) = @_;

    my $logger = $params{logger};

    my $cgi = $params{cgi};
    croak('Parameter cgi must be a CGI object!')
        if defined $cgi and not UNIVERSAL::isa($cgi, 'CGI');

    SeeAlso::Source::expand_from_config( \%params, 'Server' );

    my $self = bless {
        cgi => ($cgi || undef),
        logger => $logger,
        xslt => ($params{xslt} || undef),
        clientbase => ($params{clientbase} || undef),
        debug => ($params{debug} || 0),
        formats => { 'seealso' => { type => 'text/javascript' } },
        errors => [],
        idtype => ($params{idtype} || 'SeeAlso::Identifier'),
    }, $class;

## no critic
    eval "require " . $self->{idtype};
    croak $@ if $@;
    croak($self->{idtype} . ' is not a SeeAlso::Identifier')
        unless UNIVERSAL::isa( $self->{idtype}, 'SeeAlso::Identifier' );
## use critic

    $self->setExpires($params{expires}) if $params{expires};

    if ($params{formats}) {
        my %formats = %{$params{formats}};
        foreach my $name (keys %formats) {
            next if $name eq 'seealso' or $name eq 'debug';
            my $format = $formats{$name};
            my $value = $formats{$name};
            if (not $format) {
                $self->{formats}{$name} = 0;
            } elsif (ref($format) eq 'HASH') {
                # TODO: enable default format handlers with
                next unless defined $format->{type};
                next unless ref($format->{filter}) eq 'CODE' or
                            ref($format->{method}) eq 'CODE';
                $self->{formats}{$name} = {
                    "type" => $format->{type},
                    "docs" => $format->{docs},
                    "method" => $format->{method},
                    "filter" => $format->{filter},
                };
            } else {
                # enable default format handlers for known formats
                if ($name eq 'rdfjson') {
                    $self->{formats}{'rdfjson'} = {
                        type => "application/rdf+json",
                        filter => sub { return $_[0]->toRDFJSON; },
                    };
                } elsif ($name eq 'n3') {
                    $self->{formats}{'n3'} = {
                        type => "text/n3",
                        filter => sub { return $_[0]->toN3; },
                    };
                # } elsif ($name eq 'rdf') {
                    #$self->{formats}{'rdf'} = {
                    #    type => "application/rdf+xml",
                    #    filter => sub { return $_[0]->toRDFXML; },
                    #};
                } elsif ($name eq 'csv') {
                    $self->{formats}{'csv'} = {
                        type => "text/csv",
                        filter => sub { return $_[0]->toCSV; },
                    };
                } elsif ($name eq 'redirect') {
                    $self->{formats}{'redirect'} = {
                        type => "text/html",
                        raw => 1, # includes HTTP headers
                        filter => sub { return $_[0]->toRedirect($value); },
                    };
                }
                # TODO: ttl : (text/turtle)
            }
        }
    }

    # enable by default if not disabled
    if ( not defined $self->{formats}{opensearchdescription} ) {
        $self->{formats}{"opensearchdescription"} = {
            type=>"application/opensearchdescription+xml",
            docs=>"http://www.opensearch.org/Specifications/OpenSearch/1.1/Draft_3#OpenSearch_description_document"
        };
    }


    $self->logger($params{logger}) if defined $params{logger};

    return $self;
}


sub query {
    my ($self, $source, $identifier, $format, $callback) = @_;
    my $http = "";

    if (ref($source) eq "CODE") {
        $source = new SeeAlso::Source( $source );
    }
    croak('First parameter must be a SeeAlso::Source or code reference!')
        unless defined $source and UNIVERSAL::isa($source, 'SeeAlso::Source');

    if ( ref($identifier) eq 'CODE' ) {
        $identifier = &$identifier( $self->param('id') );
    } elsif (UNIVERSAL::isa( $identifier,'SeeAlso::Identifier::Factory' )) {
        $identifier = $identifier->create( $self->param('id') );
    } elsif (not defined $identifier) {
        $identifier = $self->param('id');
    }

## no critic
    if ( not UNIVERSAL::isa( $identifier, 'SeeAlso::Identifier' ) ) {
        my $class = $self->{idtype};
        $identifier = eval "new $class(\$identifier)"; # TODO: what if this fails?
    }
## use critic

    $format = $self->param('format') unless defined $format;
    $format = "" unless defined $format;
    $callback = $self->param('callback') unless defined $callback;
    $callback = "" unless defined $callback;

    # If everything is ok up to here, we should definitely return some valid stuff
    $format = "seealso" if ( $format eq "debug" && $self->{debug} == -1 );
    $format = "debug" if ( $format eq "seealso" && $self->{debug} == 1 );

    if ($format eq 'opensearchdescription') {
        $http = $self->openSearchDescription( $source );
        if ($http) {
            $http = CGI::header( -status => 200, -type => 'application/opensearchdescription+xml; charset: utf-8' ) . $http;
            return $http;
        }
    }

    $self->{errors} = []; # clean error list
    my $response;
    my $status = 200;

    if ( not $identifier ) {
        $self->errors( "invalid identifier" );
        $response = SeeAlso::Response->new;
    } elsif ($format eq "seealso" or $format eq "debug" or !$self->{formats}{$format}
                                  or $self->{formats}{$format}->{filter} ) {
        eval {
            local $SIG{'__WARN__'} = sub {
                $self->errors(shift);
            };
            $response = $source->query( $identifier );
        };
        if ($@) {
            $self->errors( $@ );
            undef $response;
        } else {
            if (defined $response && !UNIVERSAL::isa($response, 'SeeAlso::Response')) {
                $self->errors( ref($source) . "->query must return a SeeAlso::Response object but it did return '" . ref($response) . "'");
                undef $response;
            }
        }

        $response = SeeAlso::Response->new() unless defined $response;

        if ($callback && !($callback =~ /^[a-zA-Z0-9\._\[\]]+$/)) {
            $self->errors( "Invalid callback name specified" );
            undef $callback;
            $status = 400;
        }
    } else {
        $response = SeeAlso::Response->new( $identifier );
    }


    if ( $self->{logger} ) {
        my $service = $source->description( "ShortName" );
        eval {
            $self->{logger}->log( $self->{cgi}, $response, $service )
            || $self->errors("Logging failed");
        };
        $self->errors( $@ ) if $@;
    }

    if ( $format eq "seealso" ) {
        my %headers =  (-status => $status, -type => 'text/javascript; charset: utf-8');
        $headers{"-expires"} = $self->{expires} if ($self->{expires});
        $http .= CGI::header( %headers );
        $http .= $response->toJSON($callback);
    } elsif ( $format eq "debug") {
        $http .= CGI::header( -status => $status, -type => 'text/javascript; charset: utf-8' );
        $http .= "/*\n";

        # TODO
        # use Class::ISA; # deprecated
        # my %vars = ( Server => $self, Source => $source, Identifier => $identifier, Response => $response );
        # foreach my $var (keys %vars) {
        #     $http .= "$var is a " .
        #         join(", ", map { $_ . " " . $_->VERSION; }
        #         Class::ISA::self_and_super_path(ref($vars{$var})))
        #     . "\n"
        # }
        $http .= "\n";
        $http .= "HTTP response status code is $status\n";
        $http .= "\nInternally the following errors occured:\n- "
              . join("\n- ", $self->errors) . "\n" if $self->errors;
        $http .= "*/\n";
        $http .= $response->toJSON($callback) . "\n";
    } else { # other unAPI formats
        # TODO is this properly logged?
        # TODO: put 'seealso' as format method in the array
        my $f = $self->{formats}{$format};
        if ($f) {
            if ($f->{filter}) {
                $http = $f->{filter}($response); # TODO: what if this fails?!
            } else {
                $http = $f->{method}($identifier); # TODO: what if this fails?!
            }
            if (!$f->{raw}) { # TODO: Autodetect headers if already in HTTP
                my $type = $f->{type} . "; charset: utf-8";
                my $header = CGI::header( -status => $status, -type => $type );
                $http = $header . $http;
            }
        } else { # unknown format or not defined format
            $http = $self->listFormats($response);
        }
    }
    return $http;
}


sub param {
    my ($self, $name) = @_;
    if ( defined $self->{cgi} ) {
      1;
      return $self->{cgi}->param($name);
    }

    return defined $self->{cgi} ? $self->{cgi}->param($name) : CGI::param($name);

    return CGI::param($name);
}


sub logger {
    my $self = shift;
    my $logger = shift;
    return $self->{logger} unless defined $logger;
    if (!UNIVERSAL::isa($logger, 'SeeAlso::Logger')) {
        $logger = SeeAlso::Logger->new($logger);
    }
    $self->{logger} = $logger;
}


sub setExpires {
    my ($self, $expires) = @_;
    $self->{expires} = $expires;
}


sub listFormats {
    my ($self, $response) = @_;

    my $status = 200;
    my $id = $response->query();
    if ($response->query() ne "") {
        $status = $response->size ? 300 : 404;
    }

    my $headers = CGI::header( -status => $status, -type => 'application/xml; charset: utf-8' );
    $headers .= '' . "\n";

    if ($self->{xslt}) {
        $headers .= "{xslt}) . "\"?>\n";
        $headers .= "baseURL) . "?>\n";
    }
    if ($self->{clientbase}) {
        $headers .= "{clientbase}) . "?>\n";
    }

    return _unapiListFormats( $self->{formats}, $id, $headers );
}

# $formats: hash reference
# $id : scalar (optional)
# $headers : scalar (optional, use undef to disable)
sub _unapiListFormats { # TODO: move this to HTTP::unAPI or such
    my ($formats, $id, $headers) = @_;

    $headers = '' unless defined $headers;

    my @xml;
    if ($id ne "") {
        push @xml, '';
    } else {
        push @xml, '';
    }

    foreach my $name (sort({$b cmp $a} keys(%$formats))) {
        my $format = $formats->{$name};
        if ( $format && $name ne 'debug' ) {
            my $fstr = "{type}) . "\"";
            $fstr .= " docs=\"" . xmlencode($format->{docs}) . "\"" if defined $format->{docs};
            push @xml, $fstr . " />";
        }
    }

    push @xml, '';

    return $headers . join("\n", @xml) . "\n";
}


sub errors {
    my $self = shift;
    my $message = shift;
    if ( defined $message ) {
        chomp $message;
        push @{ $self->{errors} }, $message;
    }
    return @{ $self->{errors} };
}


sub openSearchDescription {
    my ($self, $source) = @_;

    my $baseURL = $self->baseURL;

    return unless $source and UNIVERSAL::isa( $source, "SeeAlso::Source" );
    my %descr = %{ $source->description };

    my @xml = '';
    push @xml, '';

    my $shortName = $descr{"ShortName"}; # TODO: shorten to 16 chars maximum
    push @xml, "  " . xmlencode( $shortName ) . ""
        if defined $shortName;

    my $longName = $descr{"LongName"}; # TODO: shorten to 48 chars maximum
    push @xml, "  " . xmlencode( $longName ) . ""
        if defined $longName;

    my $description = $descr{"Description"}; # TODO: shorten to 1024 chars maximum
    push @xml, "  " . xmlencode( $description ) . ""
        if defined $description;

    $baseURL = $descr{"BaseURL"}  # overwrites standard
        if defined $descr{"BaseURL"};

    my $modified = $descr{"DateModified"};
    push @xml, "  " . xmlencode( $modified ) . ""
        if defined $modified;

    my $src = $descr{"Source"};
    push @xml, "  " . xmlencode( $src ) . ""
        if defined $src;

    if ($descr{"Examples"}) { # TODO: add more parameters
        foreach my $example ( @{ $descr{"Examples"} } ) {
            my $id = $example->{id};
            my $args = "searchTerms=\"" . xmlencode($id) . "\"";
            my $response = $example->{response};
            if (defined $response) {
                $args .= " seealso:response=\"" . xmlencode($response) . "\"";
            }
            push @xml, "  ";
        }
    }

    my $template = $baseURL . (($baseURL =~ /\?/) ? '&' : '?')
                 . "id={searchTerms}&format=seealso&callback={callback}";
    push @xml, "  ";
    push @xml, "";

    return join("\n", @xml);
}


sub baseURL {
    my $self = shift;
    my $cgi = $self->{cgi};

    my $url = (defined $cgi ? $cgi->url : CGI::url());

    # remove id, format, and callback parameter
    my $q = "&" . (defined $cgi ? $cgi->query_string() : CGI::query_string());
    $q =~ s/&(id|format|callback)=[^&]*//g;
    $q =~ s/^&//;

    $url .= "?$q" if $q;
    return $url;
}


sub xmlencode {
    my $data = shift;
    if ($data =~ /[\&\<\>"]/) {
      $data =~ s/\&/\&\;/g;
      $data =~ s/\
      $data =~ s/\>/\>\;/g;
      $data =~ s/"/\"\;/g;
    }
    return $data;
}

1;

__END__