LedgerSMB/RESTXML/Handler.pm



package LedgerSMB::RESTXML::Handler;
use strict;
use warnings;
use Carp;
use LedgerSMB::User;
use LedgerSMB::Sysconfig;
use LedgerSMB::Log;
use Scalar::Util qw(blessed);
use DBI;

=head3 cgi_handle

CGI_handle is the gateway for the RESTful lsmb API.

=head3 NOTES


=cut

sub cgi_handle {
    my $self = shift;

    my $method   = $ENV{REQUEST_METHOD};
    my $pathinfo = $ENV{PATH_INFO};

    #pull off the leading slash, we need it in the form document/arguments/foo
    $pathinfo =~ s#^/##;

    my $function = 'handle_' . lc($method);
    my ( $user, $module, @args ) = split '/', $pathinfo;
    $user = LedgerSMB::User->fetch_config($user);

    my $dbh = $self->connect_db($user);

    # non-word characters are forbidden, usually a sign of someone being sneaky.
    $module =~ s#\W##;

    my $document_module = $self->try_to_load($module);

    if ($document_module) {
        if ( $document_module->can($function) ) {
            my $returnValue = $document_module->$function(
                {
                    dbh     => $dbh,
                    args    => \@args,
                    handler => $self,
                    user    => $user
                }
            );

            #return $self->return_serialized_response($returnValue);

        }
        else {
            return $self->unsupported("$module cannot handle method $method");
        }
    }
    else {
        return $self->not_found(
            "Could not find a handler for document type $module: <pre>$@</pre>"
        );
    }
}

sub cgi_report_error {
    my $self    = shift;
    my $message = shift;
    my $code    = shift || 500;

    print "Status: $code\n";
    print "Content-Type: text/html\n\n";
    print "<html><body>\n";
    print "<h1>REST API error</h1>";
    print "<blockquote>$message</blockquote>";
    print "</body></html>";
}

sub cgi_read_query {
    my $self = shift;

    use CGI::Simple;
    my $cgi = CGI::Simple->new();

    return $cgi;
}

# ------------------------------------------------------------------------------------------------------------------------

=head3 try_to_load

try_to_load will try to load a RESTXML document handler module.  returns undef
if it cannot load the given module for any reason.  passed the type of RESTXML
document to try to load.  returns a blessed anonymous hashref if the module
*can*, and is successfully loaded.

=cut

sub try_to_load {
    my $self   = shift;
    my $module = shift;

    eval qq{ 
        use LedgerSMB::RESTXML::Document::$module;
    };
    if ($@) {
        warn "Cannot load $module: $@" unless $@ =~ /Can't locate LedgerSMB\//i;

        return undef;
    }
    else {
        return bless {}, "LedgerSMB::RESTXML::Document::$module";
    }
}

=head3 connect_db

Given  a user's config, returns a database connection handle.

=cut

sub connect_db {
    my ( $self, $myconfig ) = @_;

    my $dbh = DBI->connect( $myconfig->{dbconnect},
        $myconfig->{dbuser}, $myconfig->{dbpasswd} )
      or carp "Error connecting to the db :$DBI::errstr";
    $dbh->{pg_enable_utf8} = 1;

    return $dbh;
}

# lets see how far XML::Simple can take us.
use XML::Simple;
use Scalar::Util qw(blessed);

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

    print "Content-type: text/xml\n\n";

    if ( blessed $response && $response->isa('XML::Twig::Elt') ) {
        print qq{<?xml version="1.0"?>\n};
        print $response->sprint();
    }
    else {
        my $xs = XML::Simple->new(
            NoAttr   => 1,
            RootName => 'LedgerSMBResponse',
            XMLDecl  => 1
        );

        print $xs->XMLout($response);
    }

    return;
}

sub read_query {
    my ($self) = @_;

    # for now.
    return $self->cgi_read_query();
}

# =------------------------- POSSIBLE WAYS FOR MODULES TO RESPOND.
sub respond {
    my ( $self, $data ) = @_;

    return $self->return_serialized_response($data);
}

sub not_found {
    my ( $self, $message ) = @_;

    $self->cgi_report_error( $message, 404 );
}

sub unsupported {
    my ( $self, $message ) = @_;
    $self->cgi_report_error( $message, 501 );
}

sub error {
    my ( $self, $message ) = @_;

    $self->cgi_report_error( $message, 500 );
}

1;