#----------------------------------------------------------------------
=pod

=head1	NAME

    REST::Resource	-- Provide base class functionality for RESTful servers.

=head1	SYNOPSIS

    package My::Rest::Resource;
    use base "REST::Resource";

    sub new
    {
        my( $class )	= shift;
        my( $this )	= $this->SUPER::new( @_ );
        $this->method( "PUT",	\&Create, "This method handles the creation of My::Rest::Resource." );
        $this->method( "GET",	\&Read,   "This method handles the reading of My::Rest::Resource." );
        $this->method( "POST",	\&Update, "This method handles the updating of My::Rest::Resource." );
        $this->method( "DELETE",\&Delete, "This method handles the deletion of My::Rest::Resource." );
    }

    sub	Create	{ my( $this ) = shift;	my( $request_interface_instance ) = shift; ... }
    sub	Read	{ my( $this ) = shift;	my( $request_interface_instance ) = shift; ... }
    sub	Update	{ my( $this ) = shift;	my( $request_interface_instance ) = shift; ... }
    sub	Delete	{ my( $this ) = shift;	my( $request_interface_instance ) = shift; ... }

    package main;
    use My::Rest::Resource;

    my( $restful )	= new My::Rest::Resource();
    $restful->handle_request();				## One-shot CGI Context

=head1	DESCRIPTION

    This is a fork of WWW::Resource 0.01.  The major changes are:

    [] Full OO implementation
    [] Overt abstract base class design
    [] Support of Perl 5.6
    [] Support for use with CGI interface.
    [] Support for HEAD and TRACE.
    [] Method / handler registration to better support
       application-semantics over REST-semantics.

=head1	METHOD REGISTRATION

    HTTP method handlers should be members of your derived class and
    expect $this (or $self) as the first parameter.

    sub	Create	{ my( $this ) = shift;	my( $request_interface_instance ) = shift; ... }
    sub	Read	{ my( $this ) = shift;	my( $request_interface_instance ) = shift; ... }
    sub	Update	{ my( $this ) = shift;	my( $request_interface_instance ) = shift; ... }
    sub	Delete	{ my( $this ) = shift;	my( $request_interface_instance ) = shift; ... }

=head1	REQUEST INTERFACE INSTANCE

    $request_interface_instance is a wrapper for your favorite Common
    Gateway Interface implementation.  Mine is CGI.pm for server-side
    request interrogation and server-side response.

    If you don't like this, create a class modeled after REST::Request
    and register it with:

    my( $restful ) = new REST::Resource( request_interface => new My::REST::Request() );

    The REST::Resource constructor will validate that
    My::REST::Request implements the requisite methods new(), http(),
    param() and header() and then only use these methods to interace
    with the Common Gateway Interface variables.

=head1	REQUESTED RETURNED CONTENT-TYPE:

    The requesting client is responsible for specifying the
    returned Content-Type: header in one of two ways.

    [] Via the "Accept: application/xml" HTTP header.
    [] Via the CGI query parameter ?format=xml

    The Accept: header is preferred as it is semantically
    cleaner, but the CGI query parameter is also supported in
    recognition of the fact that sometimes it is easier to affect the
    request URL than it is to get at and specify the HTTP headers.

=head1	DEFAULT SUPPORTED CONTENT TYPES

    The supported content types provided by the base class are:

    []	?format=xml	or	Accept: application/xml
    []	?format=json	or	Accept: text/javascript
    []	?format=html	or	Accept: text/html

    HTML will be returned if the requestor appears to be a browser and
    no format is specified.

    XML will be returned if the requestor does NOT appear to be a
    browser and no format is specified.

=head1	AUTHOR

    frotz@acm.org				Fork of WWW::Resource into REST::Resource.

=head1	CREDITS

    Ira Woodhead <ira at sweetpota dot to>	For his WWW::Resource implementation.

=head1	METHODS

=cut

package REST::Resource;

use strict;			## Strict coding standards
use warnings;			## Very strict coding standards

use CGI	qw( :standard );
use HTTP::Status;		## Mneumonic HTTP Status codes.
use XML::Dumper;		## Output format: XML
use Data::Dumper;		## Output format: HTML
use JSON;			## Output format: JavaScript Object Notation

our( $VERSION )	= '0.5.1.14';	## MODULE-VERSION-NUMBER

my( $mimetype_mapping )	=
{
    "xml"		=> "application/xml",
    "html"		=> "text/html",
    "text"		=> "text/plain",
    "json"		=> "text/javascript",

    "application/xml"	=> "application/xml",
    "text/html"		=> "text/html",
    "text/plain"	=> "text/plain",
    "text/javascript"	=> "text/javascript",
};





#----------------------------------------------------------------------
=pod

=head2	new()

USAGE:

    my( $restful ) = new REST::Resource();
    $restful->method( "GET", \&get_handler );
    $restful->handle_request();

    my( $restful ) = new REST::Resource( request_interface => new REST::Request() );

DESCRIPTION:

    Create an instance of a REST::Resource, or one of its
    derived classes.

    If you need a specific implementation of the REST::Request
    interface, pass it in as shown in the second constructor call.

=cut

sub	new
{
    my( $class )	= shift;
    $class 		= ref( $class )			if  (ref( $class ));
    my( %args )		= @_;
    my( $args )		= \%args;
    my( $this )		= bless( {}, $class );

    unless  (exists( $args->{request_interface} ))
    {
	use REST::Request;
	$args->{request_interface}	= new REST::Request();
    }
    my( $request )	= $args->{request_interface};
    unless  (UNIVERSAL::can( $request, "http" ))
    {
	die( "Interface [$args->{request_interface}] does not implement required method: http()\n" );
    }
    unless  (UNIVERSAL::can( $request, "param" ))
    {
	die( "Interface [$args->{request_interface}] does not implement required method: param()\n" );
    }
    unless  (UNIVERSAL::can( $request, "header" ))
    {
	die( "Interface [$args->{request_interface}] does not implement required method: header()\n" );
    }
    $this->{request_interface}	= $request;

    $this->{methods}	= {};
    $this->{formats}	= {};
    $this->{descriptions} = {};

    $this->method( "GET",		\&REST::Resource::unimplemented, "GET: Unimplemented read accessor." );
    $this->method( "PUT",		\&REST::Resource::unimplemented, "PUT: Unimplemented create mutator." );
    $this->method( "POST",		\&REST::Resource::unimplemented, "POST: Unimplemented update mutator." );
    $this->method( "DELETE",		\&REST::Resource::unimplemented, "DELETE: Unimplemented delete mutator." );
    $this->method( "TRACE",		\&REST::Resource::api, "TRACE: API identity / discoverability." );
    $this->method( "HEAD",		\&REST::Resource::api, "HEAD: API identity / discoverability." );
    $this->method( "authenticate",
		   \&REST::Resource::authenticate,
		   "authenticate: Default no-authorization-required authentication control implementation." );

    $this->format( "application/xml",	\&REST::Resource::format_xml, "Returns generic XML.  Request via 'Accept: application/xml' or '?format=xml'" );
    $this->format( "text/html",		\&REST::Resource::format_html, "Returns HTML UI.  Request via 'Accept: text/html' or '?format=html'" );
    $this->format( "text/plain",	\&REST::Resource::format_text, "Returns Text UI.  Request via 'Accept: text/plain' or '?format=text'" );
    $this->format( "text/javascript",	\&REST::Resource::format_json, "Returns Javascript Object Notation (JSON).  Request via 'Accept: text/javascript' or '?format=json'" );

    $this->{ttl}	= 60 * 60;
    return( $this );
}





#----------------------------------------------------------------------
=pod

=head2	run()		CAUTION

USAGE:

    my( $restful )	= new REST::Resource( new REST::RequestFast() );
    $restful->run();

    my( $restful )	= new Your::WWW::Resource::Implementation( new REST::RequestFast() );
    $restful->run();

DESCRIPTION:

    This method will run a REST::RequestFast instance.  It delegates
    request interpolation to the registered request instance via the
    constructor.  The default is a shim derived class of CGI.pm.

WWW::RESOURCE COMPATIBILITY:

    If your derived class provides the WWW::Resource suggested
    callbacks browserprint() and ttl(), this method will honor those
    and fold in the new code hook mechanism.

WARNING:

    If your derived class contains the method "browserprint()",
    the calling semantics for _all_ methods will be \%query.

        $instance->$method( \%query_hash );

    If your derived class does NOT contain the method "browserprint()",
    it is assumed that you are using the new calling semantics where
    you method handler is passed the request instance.

        $instance->$method( $request_instance );

    Thus ref( $arg ) will be "HASH" for the old style and an object
    reference for the new style.

=cut

sub	run
{
    my( $this )	= shift;

    eval
    {
	require "REST/RequestFast.pm";			## Conditional environment fun and games.
    };
    if  (defined( %REST::RequestFast:: ))
    {
	my( $html )	= $this->can( "browserprint" );						## WWW::Resource signature method.
	my( $ttl )	= $this->can( "ttl" );
	$this->format( "html", $html, "WWW::Resource style html-format handler." )	if  ($html);
	$this->{ttl}	= $this->ttl()						if  ($ttl);
	$this->{starttime}	= time();

	my( $cgi );
	while( ($cgi = new REST::RequestFast()) )
	{
	    my( $authenticate )	= $this->method( "authenticate" );
	    my( $status, $data )= $this->$authenticate( $cgi );				## We presume that $authenticate always exists.
	    if  ($status == RC_OK)
	    {
		my( $method )	= $this->method( $cgi->http( "REQUEST_METHOD" ) );
		if  ($html)									## WWW::Resource 0.01 semantics detected.
		{
		    my( %query )	= map { split /=/ } split /;/, lc( $ENV{QUERY_STRING} );## Gratuitous case mangling.
			$this->_return_result( $cgi, $this->$method->( \%query ) );		## Old calling convention.
		}
		else
		{
		    $this->_return_result( $cgi, $this->$method( $cgi ) );			## New calling convention.
		}
	    }
	    else
	    {
		$this->_return_result( $cgi, $status, $data );
	    }
	    if ( (time() - $this->{starttime}) > $this->{ttl} )
	    {
		return;
	    }
	}
    }
    else
    {
	die "REST::Request did not load.  Presumably CGI::Fast and FCGI are unavailable.";
    }
}




#----------------------------------------------------------------------
=pod

=head2	handle_request()

USAGE:

    my( $restful ) = new REST::Resource( request_instance => new REST::Request() );
    $restful->handle_request();				## Implicit
    $restful->handle_request( new REST::Request() );	## Explicit
    $restful->handle_request( new CGI() );		## Explicit

DESCRIPTION:

    This method runs a single action handler.  Optionally pass in the
    CGI request to be handled.

=cut

sub	handle_request
{
    my( $this )		= shift;
    my( $req )		= shift;
    $req		= $this->get_request()				unless( $req );
    my( $method )	= $this->method( $req->http( "REQUEST_METHOD" ) );
    my( $authenticate )	= $this->method( "authenticate" );
    my( $status, $data )= $this->$authenticate( $req );			## We presume that $authenticate always exists.
    if  ($status == RC_OK  && defined( $method ))
    {
	$this->_return_result( $req, $this->$method( $req ) );
    }
    else
    {
	$this->_return_result( $req, $status, $data );			## Either 401/403
    }
}




#----------------------------------------------------------------------
=pod

=head2	method()

USAGE:

    my( $coderef ) = $restful->method( "GET" );		## OR
    my( $method )  = $restful->method( "GET", \&get_handler, $description );

    $restful->$method( $request_interface_instance );

DESCRIPTION:

    This accessor/mutator allows the caller to register or change the
    implementation behavior for a given HTTP method handler.  The standard
    event handlers that are pre-registered are:

        GET
        PUT
        POST
        DELETE
        TRACE
        HEAD

    Additionally, the following pseudo-methods provide over-ride control
    to derived class implementors.

        authenticate

    Unless otherwise overridden, the default implementation for each
    of these methods is REST::Resource->unimplemented().

=cut

sub	method
{
    my( $this )			= shift;
    my( $method )		= shift;
    my( $implementation )	= shift;
    my( $description )		= shift;
    $description		= "$method: No API semantics provided during method registration."	unless( $description );
    my( $old )			= $this->{methods}->{$method} || undef;
    if  (defined( $implementation ))
    {
	$this->{methods}->{$method} 		= $implementation;
	$this->{descriptions}->{$method}	= $description;
    }
    return( $old );
}





#----------------------------------------------------------------------
=pod

=head2	format()

USAGE:

    my( $format ) = $restful->format( "xml" );		## OR
    $description   = $restful->format( "xml", \&format_xml, $description );

    $restful->$format( $request_interface_instance, $status, $data );

DESCRIPTION:

    This accessor/mutator allows the caller to register or change the
    implementation behavior for a given output format.

=cut

sub	format
{
    my( $this )			= shift;
    my( $format )		= shift;
    $format			= $mimetype_mapping->{$format}		if (exists( $mimetype_mapping->{$format} ));
    my( $implementation )	= shift;
    my( $description )		= shift;
    $description		= "$format: No format semantics provided during format registration."	unless( $description );
    my( $old )			= undef;
    $old			= $this->{formats}->{$format}		if  (exists( $this->{formats}->{$format} ));
    if  (defined( $implementation ))
    {
	$this->{formats}->{$format}		= $implementation;
	$this->{descriptions}->{$format}	= $description;
	$mimetype_mapping->{$format}		= $format;
    }
    return( $old );
}





#----------------------------------------------------------------------
=pod

=head2	description()

USAGE:

    my( $restful )	= new REST::Resource();
    my( $description )	= $restful->description( $name );

DESCRIPTION:

    This accessor/mutator allows the caller to register or change the
    description for a given HTTP method handler or output format.

    This is used by REST::Resource->api() to provide a description
    of the API.

PARAMETERS:

    $type	-- "methods" or "formats"
    $name	-- See the names appropriate for the given $type.
    $description-- The description to be set (or returned).

=cut

sub	description
{
    my( $this )		= shift;
    my( $name )		= shift;
    my( $description )	= "No description is available for [$name].";
    if  (defined( $this->{descriptions}->{$name} ))
    {
	$description = $this->{descriptions}->{$name};
    }
    return( $description );
}





#----------------------------------------------------------------------
=pod

=head2	api()

USAGE:

    my( $status, $data ) = $this->api( $request_interface_instance );

DESCRIPTION:

    This method generates a resultset that can be returned through
    $this->_return_result( $status, $data );

=cut

sub	api
{
    my( $this )	 	= shift;
    my( $req )		= shift;	## Interface: REST::Request
    my( $status )	= RC_OK;
    my( $data )		=
    {
	version		=> $this->VERSION,
	implementation	=> ref( $this ),
    };
    my( $server_url )	= ($req->http( "SERVER_PORT" ) == 443
			   ? "https://" . $req->http( "SERVER_NAME" )
			   : "http://" . $req->http( "SERVER_NAME" )
			   );
    my( $uri )		= (defined( $req->http( "SCRIPT_NAME" ) )
			   ? $req->http( "SCRIPT_NAME" )
			   : "/dummy/testing/uri");
    foreach my $method (keys( %{ $this->{methods} } ))
    {
	my( $api )		= {};
	$api->{url}		= $server_url . $uri;
	$api->{description}	= $this->description( $method );
	$data->{$method}	= $api;
    }
    return( $status, $data );
}





#----------------------------------------------------------------------
=pod

=head2	authenticate()

USAGE:

    my( $status, $data ) = $this->authenticate( $request_interface_instance );

DESCRIPTION:

    This method may be overridden by a derived class that requires
    HTTP request authentication.

STATUS VALUES:

    RC_OK		(200)	-- Accept provided credentials, if any.
    RC_UNAUTHORIZED	(401)	-- Prompt user for credentials via dialog box.
    RC_FORBIDDEN	(403)	-- Reject provided credentials.

DERIVED IMPLEMENTATIONS:

    This method may be overridden in the derived class in order to
    require a specific set of credentials.

=cut

sub	authenticate
{
    my( $this )		= shift;
    my( $req )		= shift;
    my( $status )	= RC_OK;
    my( $data )		= undef;

    return( $status, $data );
}





#----------------------------------------------------------------------
=pod

=head2	format_xml()

USAGE:

    print $this->format_xml( $request_interface_instance, $status, $data );

DESCRIPTION:

    This method will format $data as XML via XML::Dumper with an
    included in-document DTD.

=cut

sub	format_xml
{
    my( $this )		= shift;
    my( $req )		= shift;
    my( $status )	= shift;
    my( $data )		= shift;
    my( $xml )		= new XML::Dumper();
    $xml->dtd;					## Include an in-document DTD
    return( join( "",
		  $req->header( -status		=> $status,
				-expires	=> "+15s",
				-content_type	=> "application/xml" ),
		  $xml->pl2xml( $data ),
		  )
	    );
}





#----------------------------------------------------------------------
=pod

=head2	format_text()

USAGE:

    print $this->format_text( $request_interface_instance, $status, $data );

DESCRIPTION:

    Use Data::Dumper to emit $data in text/plain format.

=cut

sub	format_text
{
    my( $this )		= shift;
    my( $req )		= shift;
    my( $status )	= shift;
    my( $data )		= shift;
    return( join( "",
		  $req->header( -status => $status,
				-expires => "+15s",
				-content_type => "text/plain" ),
		  Dumper( $data ),
		  )
	    );
}





#----------------------------------------------------------------------
=pod

=head2	format_html()

USAGE:

    print $this->format_html( $request_interface_instance, $status, $data );

DESCRIPTION:

    Use Data::Dumper to emit $data, then translate it via simple <pre>
    tags with limited CSS to control the font-size.

=cut

sub	format_html
{
    my( $this )		= shift;
    my( $req )		= shift;
    my( $status )	= shift;
    my( $data )		= shift;
    my( $dumped )	= substr( Dumper( $data ), 7 );
    return( join( "",
		  $req->header( -status => $status,
				-expires => "+15s",
				-content_type => "text/html" ),
		  "<html>",
		  "<head>",
		  "<title>Structured Data</title>",
		  "</head>",
		  "<body>",
		  "<h3>Structured Data</h3>",
		  "<pre style='font-size:0.8em; font-family:sans-serif;'>",	## 80% of normal size
		  $dumped,
		  "</pre>",
		  "</body>",
		  "</html>",
		  )
	    );
}





#----------------------------------------------------------------------
=pod

=head2	format_json()

USAGE:

    print $this->format_json( $request_interface_instance, $status, $data );

DESCRIPTION:

    This method will format $data in JSON (JavaScript Object
    Notation).

=cut

sub	format_json
{
    my( $this )		= shift;
    my( $req )		= shift;
    my( $status )	= shift;
    my( $data )		= shift;
    return( join( "",
		  $req->header( -status => $status,
				-expires => "+15s",
				-content_type => "text/javascript" ),
		  &objToJson( $data,
			      {
				  pretty => 1,
				  indent => 4,
			      }
			      )
		  )
	    );
}





#----------------------------------------------------------------------
=pod

=head2	unimplemented()

USAGE:

    N/A

DESCRIPTION:

    This method is invoked if an unregistered HTTP REQUEST_METHOD is
    invoked.

=cut

sub	unimplemented
{
    my( $this )		= shift;
    my( $req )		= shift;	## Interface: REST::Request
    my( $status )	= RC_OK;	## Don't let the browser whine.  We get to do that...
    my( $data )		=
    {
	ERROR		=> "No RESTful implementation defined for " . $req->http( "REQUEST_METHOD" ),
	RESOURCE	=> $req->http( "SCRIPT_NAME" ),
	PARAMETERS	=> $req->http( "PATH_INFO" ),
    };
    return( $status, $data );
}





#----------------------------------------------------------------------
=pod

=head2	default_format()

USAGE:

    my( $format )	= $this->default_format( $request_interface_instance );
    print $this->$format( $status, $data );

DESCRIPTION:

    This method will return the requested format.  We look in two
    places.  The first is in the query parameter list for the
    parameter "format".  If that is defined, we return that value.

    Otherwise, we scan through the list of q=1.0 Accept: headers and
    return the first matching MIME-type.

SAMPLE OPERA Accept: / User-Agent: HEADERS:
    Accept: text/html, application/xml;q=0.9, application/xhtml+xml,
            image/png, image/jpeg, image/gif, image/x-xbitmap, */*;q=0.1
    User-Agent: Opera/9.10 (X11; Linux i686; U; en)

SAMPLE FIREFOX Accept: / User-Agent: HEADERS:
    Accept: text/xml, application/xml, application/xhtml+xml, text/html;
            q=0.9, text/plain;
            q=0.8, image/png, */*;
            q=0.5
    User-Agent: Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.8.1.3)
                Gecko/20070309 Firefox/2.0.0.3

SAMPLE MSIE Accept: / User-Agent: HEADERS:
    Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg,
            application/x-shockwave-flash, application/vnd.ms-powerpoint,
            application/vnd.ms-excel, application/msword, */*
    User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1;
                             .NET CLR 1.1.4322; .NET CLR 2.0.50727)

SUGGESTIONS FOR JSON DEVELOPERS:
    Use "Accept: text/javascript" or "?format=json" to get JSON
    output.  The default algorithm will presume that the client is a
    human behind a browser and try to encourage html.

SUGGESTIONS FOR AJAX DEVELOPERS:
    Use "Accept: application/xml" or "?format=xml" to get XML output.
    The default algorithm will presume that the client is a human
    behind a browser and try to encourage html.

=cut

sub	default_format
{
    my( $this )		= shift;
    my( $req )		= shift;
    my( $format )	= $req->param( "format" );
    my( $useragent )	= $req->http( "HTTP_USER_AGENT" );
    my( $accept )	= $req->http( "HTTP_ACCEPT" ) || ";";
    my( $explicit )	= (split( ";", $accept ))[0];		## Only q=1.0 entries

    if  (defined( $format ))
    {
	return( $format );
    }
    elsif (defined( $explicit ))
    {
	my( @mimetypes )	= split( /\,\s*/, $explicit );
	my( $mimetypes )	= {};
	foreach $format (@mimetypes)
	{
	    $mimetypes->{$format} = 1;
	}
	if (defined( $useragent ) &&
	    $useragent =~ /Gecko/i)
	{
	    return( "html" )	    if  ($mimetypes->{"text/html"} &&			## Firefox default is xml, but
					 $mimetypes->{"application/xml"});		## should be html.
	}
	foreach $format (@mimetypes)
	{
	    return( $format )	    if (exists( $this->{formats}->{$format} ));		## Return specified MIME-type.
	}
	if  ($useragent =~ /MSIE/)
	{
	    return( "html" );								## MSIE doesn't auto-match, so push HTML
	}
    }
    return( "xml" );
}





#----------------------------------------------------------------------
=pod

=head2	get_request()

USAGE:

    my( $request )	= $restful->get_request();

DESCRIPTION:

    Return a new request_interface instance.  This instance must
    support the methods: new(), http(), param() and header().

SEE ALSO:

    REST::Request

=cut

sub	get_request
{
    my( $this )		= shift;
    my( $interface )	= $this->{request_interface};
    return( $interface->new() );
}





#----------------------------------------------------------------------
=pod

=head2	_return_result()	PRIVATE

USAGE:

    $this->_return_result( $request_interface_instance, $http_status, $data );

DESCRIPTION:

    This method is handed output of a given REQUEST_METHOD handler and
    is responsible for appropriate status code emission and $data
    formatting.

=cut

sub	_return_result
{
    my( $this )		= shift;
    my( $req )		= shift;
    my( $status )	= shift;
    my( $data )		= shift;

    my( $status_msg )	= $status;
    $status_msg		.= &status_message( $status )		if (defined( $status ));
    chomp( $status_msg )					if (defined( $status_msg ));
    if ( &is_error( $status ))
    {
	print $req->header( -status => $status_msg );
    }
    else
    {
	my( $format ) = $this->default_format( $req );
	my( $formatter ) = $this->format( $format );
	print join( "",
		    $this->$formatter( $req, $status, $data ),
		    );
    }
}




#----------------------------------------------------------------------
=pod

=head2	SEE ALSO

    WWW::Resource
    http://www.peej.co.uk/articles/restfully-delicious.html
    http://www.xfront.com/REST-Web-Services.html
    http://www.ics.uci.edu/~fielding/pubs/dissertation/rest_arch_style.htm

=cut

1;
