The start of a new REST API, these modules only provide read-only access for now.

git-svn-id: https://ledger-smb.svn.sourceforge.net/svnroot/ledger-smb/trunk@750 4979c152-3d1c-0410-bac9-87ea11338e46

8 files changed, 421 insertions, 0 deletions

diff --git a/LedgerSMB/RESTXML/Document/Base.pm b/LedgerSMB/RESTXML/Document/Base.pm
new file mode 100644
index 00000000..e8feaa96
--- /dev/null
+++ b/LedgerSMB/RESTXML/Document/Base.pm
@@ -0,0 +1,63 @@
+package LedgerSMB::RESTXML::Document::Base;
+use strict;
+use warnings;
+use XML::Twig;
+use LedgerSMB::Log;
+use Carp;
+
+sub handle_post { 
+	my ($self, $args) = @_;
+
+	return $args->{handler}->unsupported('the POST method is not implemented.');
+}
+
+sub handle_put { 
+	my ($self, $args) = @_;
+	return $self->{handler}->unsupported('the PUT method is not implemented.');
+}
+
+sub handle_delete {
+	my ($self, $args) = @_;
+	return $self->{handler}->unsupported('the DELETE method is not implemented.');
+}
+
+sub handle_get {
+	my ($self, $args) = @_;
+
+	return $self->{handler}->unsupported('the GET method is not implemented.');
+}
+
+=head3 hash_to_twig
+
+Convinenve function to convert a hashref to a XML::Twig structure.
+
+passed a hashref, required arguments:
+
+hash - the hash to convert
+
+name - the name of the root element.
+
+optional arguments:
+
+sort - by default, on set to 0 to disable.  toggles whether or not hash keys are sorted
+in the resulting xml node created.  Disabling this may save some performance if converting a lot of
+nodes at once.
+
+=cut
+
+sub hash_to_twig { 
+	my ($self, $args) = @_;
+
+	my $hash = $args->{hash} || croak "Need a hash to convert to use hash_to_twig";
+	my $name = $args->{name} || croak "Need a root element name to use hash_to_twig";
+	my @keyorder = keys %$hash;	
+	
+	@keyorder = sort @keyorder unless defined($args->{sort}) and $args->{sort} == 0;
+
+	return XML::Twig::Elt->new($name,$args->{root_attr}||{}, map  {
+		XML::Twig::Elt->new($_, {'#CDATA'=>1}, $hash->{$_})
+	} @keyorder );
+}
+
+1;
+
diff --git a/LedgerSMB/RESTXML/Document/Customer.pm b/LedgerSMB/RESTXML/Document/Customer.pm
new file mode 100644
index 00000000..3a494965
--- /dev/null
+++ b/LedgerSMB/RESTXML/Document/Customer.pm
@@ -0,0 +1,23 @@
+package LedgerSMB::RESTXML::Document::Customer;
+use strict;
+use warnings;
+use base qw(LedgerSMB::RESTXML::Document::Base);
+
+
+sub handle_get { 
+	my ($self, $args) = @_;	
+	my $user = $args->{user};
+	my $dbh = $args->{dbh};
+	my $handler = $args->{handler};
+
+	my $res = $dbh->selectrow_hashref(q{SELECT * from customer where id = ?}, undef, $args->{args}[0]);
+
+	if(!$res) { 
+		$handler->not_found("No customer with the id $args->{args}[0] found");
+	} else { 
+		$handler->respond($self->hash_to_twig({name=>'Customer',hash=>$res}));
+	}
+}
+
+
+1;
diff --git a/LedgerSMB/RESTXML/Document/Customer_Search.pm b/LedgerSMB/RESTXML/Document/Customer_Search.pm
new file mode 100644
index 00000000..7456f9d3
--- /dev/null
+++ b/LedgerSMB/RESTXML/Document/Customer_Search.pm
@@ -0,0 +1,46 @@
+package LedgerSMB::RESTXML::Document::Customer_Search;
+use strict;
+use warnings;
+use base qw(LedgerSMB::RESTXML::Document::Base);
+use LedgerSMB::Log;
+
+sub handle_get { 
+	my ($self, $args) = @_;	
+	my $user = $args->{user};
+	my $dbh = $args->{dbh};
+	my $handler = $args->{handler};
+	
+	my $query = $handler->read_query();
+
+	my %terms;
+
+	for my $field ($query->param()) { 
+		# TODO: BIG GAPING HOLE HERE.
+		$terms{$field} = $query->param($field);	
+	}
+
+	if($terms{_keyword}) { 
+		%terms = (
+				name=>$terms{_keyword},
+				customernumber=>$terms{_keyword},
+				contact=>$terms{_keyword}
+		);
+	}
+	my $sql = 'SELECT id,name,phone,customernumber FROM customer WHERE '.join(' OR ',map { "$_ like ?" } sort keys %terms);
+	
+		
+	my $res = $dbh->prepare($sql);
+
+	$res->execute(map { "$terms{$_}\%" } sort keys %terms) or return $handler->error($dbh->errstr);
+
+	my @rows;
+	my $row;
+	push @rows, $row while $row = $res->fetchrow_hashref();
+	
+	$res->finish();
+	
+	$handler->respond(XML::Twig::Elt->new('Customer_Search_Response',{'xmlns:xlink'=>"http://www.w3.org/1999/xlink"},map {  
+			$self->hash_to_twig({name=>'Customer',root_attr=>{'xlink:href'=>"Customer/$_->{id}"}, hash=>$_});			
+		} @rows));
+}
+1;
diff --git a/LedgerSMB/RESTXML/Document/Part.pm b/LedgerSMB/RESTXML/Document/Part.pm
new file mode 100644
index 00000000..072f9b80
--- /dev/null
+++ b/LedgerSMB/RESTXML/Document/Part.pm
@@ -0,0 +1,23 @@
+package LedgerSMB::RESTXML::Document::Part;
+use strict;
+use warnings;
+use base qw(LedgerSMB::RESTXML::Document::Base);
+
+
+sub handle_get { 
+	my ($self, $args) = @_;	
+	my $user = $args->{user};
+	my $dbh = $args->{dbh};
+	my $handler = $args->{handler};
+
+	my $res = $dbh->selectrow_hashref(q{SELECT * from part where id = ?}, undef, $args->{args}[0]);
+
+	if(!$res) { 
+		$handler->not_found("No part with the id $args->{args}[0] found");
+	} else { 
+		$handler->respond($self->hash_to_twig({name=>'Customer',hash=>$res}));
+	}
+}
+
+
+1;
diff --git a/LedgerSMB/RESTXML/Document/Part_Search.pm b/LedgerSMB/RESTXML/Document/Part_Search.pm
new file mode 100644
index 00000000..927c67c0
--- /dev/null
+++ b/LedgerSMB/RESTXML/Document/Part_Search.pm
@@ -0,0 +1,45 @@
+package LedgerSMB::RESTXML::Document::Part_Search;
+use strict;
+use warnings;
+use base qw(LedgerSMB::RESTXML::Document::Base);
+use LedgerSMB::Log;
+
+sub handle_get { 
+	my ($self, $args) = @_;	
+	my $user = $args->{user};
+	my $dbh = $args->{dbh};
+	my $handler = $args->{handler};
+	
+	my $query = $handler->read_query();
+
+	my %terms;
+
+	for my $field ($query->param()) { 
+		# TODO: BIG GAPING HOLE HERE.
+		$terms{$field} = $query->param($field);	
+	}
+
+	if($terms{_keyword}) { 
+		%terms = (
+				description=>$terms{_keyword},
+				partnumber=>$terms{_keyword},
+		);
+	}
+	my $sql = 'SELECT id,description,partnumber FROM parts WHERE '.join(' OR ',map { "$_ like ?" } sort keys %terms);
+	
+		
+	my $res = $dbh->prepare($sql);
+
+	$res->execute(map { "$terms{$_}\%" } sort keys %terms) or return $handler->error($dbh->errstr);
+
+	my @rows;
+	my $row;
+	push @rows, $row while $row = $res->fetchrow_hashref();
+	
+	$res->finish();
+	
+	$handler->respond(XML::Twig::Elt->new('Part_Search_Response',{'xmlns:xlink'=>"http://www.w3.org/1999/xlink"},map {  
+			$self->hash_to_twig({name=>'Part',root_attr=>{'xlink:href'=>"Part/$_->{id}"}, hash=>$_});			
+		} @rows));
+}
+1;
diff --git a/LedgerSMB/RESTXML/Document/SalesOrder.pm b/LedgerSMB/RESTXML/Document/SalesOrder.pm
new file mode 100644
index 00000000..acb4d5aa
--- /dev/null
+++ b/LedgerSMB/RESTXML/Document/SalesOrder.pm
@@ -0,0 +1,17 @@
+package LedgerSMB::RESTXML::Document::SalesOrder;
+use strict;
+use warnings;
+use base qw(LedgerSMB::RESTXML::Document::Base);
+
+
+
+sub handle_get { 
+	my ($self, $args) = @_;	
+	
+	print "Content-type: text/html\n\n";
+	print "It still works";
+
+}
+
+
+1;
diff --git a/LedgerSMB/RESTXML/Document/Session.pm b/LedgerSMB/RESTXML/Document/Session.pm
new file mode 100644
index 00000000..1db36502
--- /dev/null
+++ b/LedgerSMB/RESTXML/Document/Session.pm
@@ -0,0 +1,33 @@
+
+=head1 NAME
+
+LedgerSMB::RESTXML::Document::Session
+
+=head1 SYNOPSIS
+
+This sets up an authentication session for iterativly accessing documents in LedgerSMB.  A user should
+post a login document to /Session/userid, and upon success, they will recieve a cookie which they can use to further
+access other resources.
+
+=cut
+
+package LedgerSMB::RESTXML::Document::Session;
+use strict;
+use warnings;
+use base qw(LedgerSMB::RESTXML::Document::Base);
+
+
+sub handle_get { 
+	my ($self, $args) = @_;	
+
+
+}
+
+sub handle_post { 
+	my ($self, $args) = @_;
+	print "Content-type: text/html\n\nhi";
+	
+}
+
+
+1;
diff --git a/LedgerSMB/RESTXML/Handler.pm b/LedgerSMB/RESTXML/Handler.pm
new file mode 100644
index 00000000..006c2ead
--- /dev/null
+++ b/LedgerSMB/RESTXML/Handler.pm
@@ -0,0 +1,171 @@
+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;
+	my $cgi = CGI->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";
+
+	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;