#
# Web::DataService::Execute
# 
# This module provides a role that is used by 'Web::DataService'.  It implements
# routines for executing requests.
# 
# Author: Michael McClennen

use strict;

package Web::DataService::Execute;

use Carp 'croak';
use Scalar::Util qw(reftype weaken);

use Moo::Role;



# new_request ( outer, attrs )
# 
# Generate a new request object, using the given attributes.  $outer should be
# a reference to an "outer" request object that was generated by the
# underlying framework (i.e. Dancer or Mojolicious) or undef if there is
# none.

sub new_request {

    my ($ds, $outer, $attrs) = @_;
    
    # First check the arguments to this method.
    
    croak "new_request: second argument must be a hashref\n"
	if defined $attrs && ref $attrs ne 'HASH';
    
    $attrs ||= {};
    
    # If this was called as a class method rather than as an instance method,
    # then call 'select' to figure out the appropriate data service.
    
    unless ( ref $ds eq 'Web::DataService' )
    {
	$ds = Web::DataService->select($outer);
    }
    
    # Grab the request parameters from the foundation plugin.
    
    my $request_params = $Web::DataService::FOUNDATION->get_params($outer);
    
    # If "path" was not specified as an attribute, determine it from the request
    # parameters and path.
    
    unless ( defined $attrs->{path} )
    {
	my $request_path = $Web::DataService::FOUNDATION->get_request_path($outer);
	
	$attrs->{path} = $ds->_determine_path($request_path, $request_params);
    }
    
    # Now set the other required attributes, and create an object to represent
    # this request.
    
    $attrs->{outer} = $outer;
    $attrs->{ds} = $ds;
    
    my $request = Web::DataService::Request->new($attrs);
    
    # Make sure that the outer object is linked back to this request object.
    # The link from the "inner" object to the "outer" must be weakened,
    # so that garbage collection works properly.
    
    weaken($request->{outer}) if ref $request->{outer};
    $Web::DataService::FOUNDATION->store_inner($outer, $request);
    
    # Return the new request object.
    
    return $request;
}


# _determine_path ( url_path, params )
# 
# Given the request URL path and parameters, determine what the request path
# should be.

sub _determine_path {
    
    my ($ds, $request_path, $request_params) = @_;
    
    # If the special parameter 'path' is active, then we determine the result
    # from its value.  If this parameter was not specified in the request, it
    # defaults to ''.
    
    if ( my $path_param = $ds->{special}{path} )
    {
	my $path = $request_params->{$path_param} // '';
	return $path;
    }
    
    # Otherwise, we use the request path.  In this case, if the data service
    # has a path regexp, use it to trim the path.
    
    elsif ( defined $request_path )
    {
	if ( defined $ds->{path_re} && $request_path =~ $ds->{path_re} )
	{
	    return $1 // '';
	}
	
	else
	{
	    return $request_path;
	}
    }
    
    # Otherwise, return the empty string.
    
    else
    {
	return '';
    }
}


# _select_service ( path )
# 
# Given a request path and parameters, determines which data service or
# subservice should handle it.  The return value is a list consisting of the
# selected data service, followed by the path with the prefix, if any,
# removed.

# sub _select_service {
    
#     my ($ds, $attrs, $request_params) = @_;
    
#     # If the attribute 'selector' was specified, then use it to select the
#     # appropriate service.
    
#     if ( $attrs->{selector} )
#     {
# 	# Check all of the subservices.  If any of them matches the key
# 	# specified by the 'selector' parameter, then select that one.
	
# 	foreach my $ss ( @{$ds->{subservice_list}} )
# 	{
# 	    return $ss if defined $ss->{service_key} && 
# 		$ss->{service_key} eq $attrs->{selector}
# 	}
	
# 	# Otherwise, check to see if it matches the main service.
	
# 	return $ds if defined $ds->{service_key} && $ds->{service_key} eq $attrs->{selector};
	
# 	# Otherwise, return a 500 error.
	
# 	die "500 Internal error";
#     }
    
#     # Otherwise, if the special parameter 'selector' is active, use it to select
#     # the service.
    
#     if ( my $selector_param = $ds->{special}{selector} )
#     {
# 	my $selector_value = $request_params->{$selector_param};
	
# 	# If no value was specified, return a 400 error right away.
	
# 	return "400 You must specify a value for the parameter '$selector_param'"
# 	    unless defined $selector_value;
	
# 	# Check all of the subservices.  If any of them matches the key
# 	# specified by the 'selector' parameter, then select that one.
	
# 	foreach my $ss ( @{$ds->{subservice_list}} )
# 	{
# 	    return $ss if defined $ss->{service_key} && 
# 		$ss->{service_key} eq $selector_value
# 	}
	
# 	# Otherwise, check the selector of the main data service.
	
# 	return $ds if defined $ds->{service_key} && $ds->{service_key} eq $selector_value;
	
# 	# Otherwise, we have an invalid request.
	
# 	die "400 Bad value '$selector_value' for parameter '$selector_param'";
#     }
    
#     # If we have a request path, then see if we can use it to select the service.
    
#     if ( defined $attrs->{path} )
#     {
# 	# If the request path matches the regular expression for any
# 	# subservice, chooose that.
	
# 	foreach my $ss ( @{$ds->{subservice_list}} )
# 	{
# 	    return $ss if defined $ss->{path_re} && $attrs->{path} =~ $ss->{path_re};
# 	}
	
# 	# Otherwise, try the main service.
	
# 	return $ds if defined $ds->{path_re} && $attrs->{path} =~ $ds->{path_re};
	
# 	# Otherwise, return a 404 error.
	
# 	die "404 Not found";
#     }
    
#     # Otherwise, just return the main data service.
    
#     return $ds;
# }


# handle_request ( request )
# 
# Generate a new request object, match it to a data service node, and then execute
# it.  This is a convenience routine.

sub handle_request {

    my ($ds, $outer, $attrs) = @_;
    
    # If this was called as a class method rather than as an instance method,
    # then call 'select' to figure out the appropriate data service.
    
    unless ( ref $ds eq 'Web::DataService' )
    {
	$ds = Web::DataService->select($outer);
    }
    
    # Generate a new request object, then execute it.
    
    my $request = $ds->new_request($outer, $attrs);
    return $ds->execute_request($request);
}


# execute_request ( request )
# 
# Execute a request.  Depending upon the request path, it may either be
# interpreted as a request for documentation or a request to execute some
# operation and return a result.

sub execute_request {
    
    my ($ds, $request) = @_;
    
    my $path = $request->node_path;
    my $format = $request->output_format;
    
    # If this was called as a class method rather than as an instance method,
    # then call 'select' to figure out the appropriate data service.
    
    unless ( ref $ds eq 'Web::DataService' )
    {
	$ds = Web::DataService->select($request->outer);
    }
    
    # If a 'before_execute_hook' was defined for this request, call it now.
    
    $ds->_call_hooks($path, 'before_execute_hook', $request);
    
    # If the request has been tagged as an invalid path, then return a 404 error
    # right away.
    
    die "404\n" if $request->{is_invalid_request};
    
    # If the request has been tagged as a "documentation path", then show the
    # documentation.
    
    if ( $request->{is_node_path} && $request->{is_doc_request} && $ds->has_feature('documentation') )
    {
	return $ds->generate_doc($request);
    }
    
    # If the 'is_file_path' attribute is set, we should be sending a file.
    # Figure out the path and send it.
    
    elsif ( $request->{is_file_path} && $ds->has_feature('send_files') )
    {
	return $ds->send_file($request);
    }
    
    # If the selected node has an operation, execute it and return
    # the result.
    
    elsif ( $request->{is_node_path} && $ds->node_has_operation($path) )
    {
	$ds->configure_request($request);
	return $ds->generate_result($request);
    }
    
    # If the request cannot be satisfied in any of those ways (or is invalid)
    # then return a 404 error.
    
    die "404\n";
}


# send_file ( request )
# 
# Send a file using the attributes specified in the request node.

sub send_file {

    my ($ds, $request) = @_;
    
    die "404\n" if $request->{is_invalid_request};
    
    my $rest_path = $request->{rest_path};
    my $file_dir = $ds->node_attr($request, 'file_dir');
    my $file_path;
    
    # How we handle this depends upon whether 'file_dir' or 'file_path' was
    # set.  With 'file_dir', an empty file name will always return a 404
    # error, since the only other logical response would be a list of the base
    # directory and we don't want to provide that for security reasons.
    
    if ( $file_dir )
    {
	die "404\n" unless defined $rest_path && $rest_path ne '';
	
	# Concatenate the path components together, using the foundation plugin so
	# that this is done in a file-system-independent manner.
	
	$file_path = $Web::DataService::FOUNDATION->file_path($file_dir, $rest_path);
    }
    
    # Otherwise, $rest_path must be empty or else we send back a 404 error.
    
    else
    {
	die "404\n" if defined $rest_path && $rest_path ne '';
	
	$file_path = $ds->node_attr($request, 'file_path');
    }
    
    # If this file does not exist, return a 404 error.  This is necessary so
    # that the error handling will by done by Web::DataService rather than by
    # Dancer.  If the file exists but is not readable, return a 500 error.
    # This is not a permission error, it is an internal server error.
    
    unless ( $Web::DataService::FOUNDATION->file_readable($file_path) )
    {
	die "500" if $Web::DataService::FOUNDATION->file_exists($file_path);
	die "404\n"; # otherwise
    }
    
    # Otherwise, send the file.
    
    return $Web::DataService::FOUNDATION->send_file($request->outer, $file_path);
}


# node_has_operation ( path )
# 
# If this class has both a role and a method defined, then return the method
# name.  Return undefined otherwise.  This method can be used to determine
# whether a particular path is valid for executing a data service operation.

sub node_has_operation {
    
    my ($ds, $path) = @_;
    
    my $role = $ds->node_attr($path, 'role');
    my $method = $ds->node_attr($path, 'method');
    
    return $method if $role && $method;
}


# configure_request ( request )
# 
# Determine the attributes necessary for executing the data service operation
# corresponding to the specified request.

sub configure_request {
    
    my ($ds, $request) = @_;
    
    my $path = $request->node_path;
    
    die "404\n" if $request->{is_invalid_request} || $ds->node_attr($path, 'disabled');
    
    $request->{_configured} = 1;
    
    # If we are in 'one request' mode, initialize this request's primary
    # role.  If we are not in this mode, then all of the roles will have
    # been previously initialized.
    
    if ( $Web::DataService::ONE_REQUEST )
    {
	my $role = $ds->node_attr($path, 'role');
	$ds->initialize_role($role);
    }
    
    # If a before_config_hook was specified for this node, call it now.
    
    $ds->_call_hooks($path, 'before_config_hook', $request);
    
    # Get the raw parameters for this request, if they have not already been gotten.
    
    $request->{raw_params} //= $Web::DataService::FOUNDATION->get_params($request);
    
    # Check to see if there is a ruleset corresponding to this path.  If
    # so, then validate the parameters according to that ruleset.
    
    my $rs_name = $ds->node_attr($path, 'ruleset');
    
    $rs_name //= $ds->determine_ruleset($path);
    
    if ( $rs_name )
    {
	my $context = { ds => $ds, request => $request };
	
	my $result = $ds->{validator}->check_params($rs_name, $context, $request->{raw_params});
	
	if ( $result->errors )
	{
	    die $result;
	}
	
	elsif ( $result->warnings )
	{
	    $request->add_warning($result->warnings);
	}
	
	$request->{clean_params} = $result->values;
	$request->{valid} = $result;
	$request->{ruleset} = $rs_name;
	
	if ( $ds->debug )
	{
	    print STDERR "Params:\n";
	    foreach my $p ( $result->keys )
	    {
		my $value = $result->value($p);
		$value = join(', ', @$value) if ref $value eq 'ARRAY';
		print STDERR "$p = $value\n";
	    }
	}
    }
    
    # Otherwise, just pass the raw parameters along with no validation or
    # processing.
    
    else
    {
	print STDERR "No ruleset could be determined for path '$path'" if $ds->debug;
	$request->{valid} = undef;
	$request->{clean_params} = $request->{raw_params};
    }
    
    # Now that the parameters have been processed, we can configure all of
    # the settings that might be specified or affected by parameter values:
    
    # If the output format is not already set, then try to determine what
    # it should be.
    
    unless ( $request->output_format )
    {
	# If the special parameter 'format' is enabled, check to see if a
	# value for that parameter was given.
	
	my $format;
	my $format_param = $ds->{special}{format};
	
	if ( $format_param )
	{
	    $format = $request->{clean_params}{$format_param};
	}
	
	# If we still don't have a format, and there is a default format
	# specified for this path, use that.
	
	$format //= $ds->node_attr($path, 'default_format');
	
	# Otherwise, use the first format defined.
	
	$format //= ${$ds->{format_list}}[0];
	
	# If we have successfully determined a format, then set the result
	# object's output format attribute.
	
	$request->output_format($format) if $format;
    }
    
    # Next, determine the result limit and offset, if any.  If the special
    # parameter 'limit' is active, then see if this request included it.
    # If we couldn't get a parameter value, see if a default limit was
    # specified for this node or for the data service as a whole.
    
    my $limit_value = $request->special_value('limit') //
	$ds->node_attr($path, 'default_limit');
    
    $request->result_limit($limit_value) if defined $limit_value;
    
    # If the special parameter 'offset' is active, then see if this result
    # included it.
    
    my $offset_value = $request->special_value('offset');
    
    $request->result_offset($offset_value) if defined $offset_value;
    
    # Determine whether we should show the optional header information in
    # the result.
    
    my $header_value = $request->special_value('header') //
	$ds->node_attr($path, 'default_header');
    
    $request->display_header($header_value) if defined $header_value;
    
    my $source_value = $request->special_value('datainfo') //
	$ds->node_attr($path, 'default_datainfo');
    
    $request->display_datainfo($source_value) if defined $source_value;
    
    my $count_value = $request->special_value('count') //
	$ds->node_attr($path, 'default_count');
    
    $request->display_counts($count_value) if defined $count_value;
    
    my $output_linebreak = $request->special_value('linebreak') ||
	$ds->node_attr($path, 'default_linebreak') || 'crlf';
    
    $request->output_linebreak($output_linebreak);
    
    my $save_specified = $request->special_given('save');
    my $save_value = $request->special_value('save') || '';
    
    if ( $save_specified )
    {
	if ( $save_value =~ qr{ ^ (?: no | off | 0 | false ) $ }xsi )
	{
	    $request->save_output(0);
	}
	
	else
	{
	    $request->save_output(1);
	    $request->save_filename($save_value) if $save_value ne '' &&
		$save_value !~ qr{ ^ (?: yes | on | 1 | true ) $ }xsi;
	}
    }
    
    # Determine which vocabulary to use.  If the special parameter 'vocab' is
    # active, check that first.
    
    my $vocab_value = $request->special_value('vocab');
    
    $request->output_vocab($vocab_value) if defined $vocab_value;
    
    # If an after_config_hook is defined for this path, call it.
    
    $ds->_call_hooks($path, 'after_config_hook', $request);
    
    my $a = 1;	# we can stop here when debugging
}


# generate_result ( request )
# 
# Execute the operation corresponding to the attributes of the node selected
# by the given request, and return the resulting data.  This routine is, in
# many ways, the core of this entire project.

sub generate_result {
    
    my ($ds, $request) = @_;
    
    croak "generate_result: you must first call the method 'configure'\n"
	unless $request->{_configured};
    
    my $path = $request->node_path;
    my $format = $request->output_format;
    
    my $method = $ds->node_attr($path, 'method');
    my $arg = $ds->node_attr($path, 'arg');
    
    # First check to make sure that the specified format is valid for the
    # specified path.
    
    unless ( $ds->valid_format_for($path, $format) )
    {
	die "415\n";
    }
    
    #	defined $format && ref $ds->{format}{$format} &&
    #	 ! $ds->{format}{$format}{disabled} &&
    #	 $attrs->{allow_format}{$format} )
    
    # Then we need to make sure that an output vocabulary is selected.  If no
    # vocabulary was explicitly specified, then try the default for the
    # selected format.  As a backup, we use the first vocabulary defined for
    # the data service, which will be the default vocabulary if none were
    # explicitly defined.
    
    unless ( my $vocab_value = $request->output_vocab )
    {
	$vocab_value = $ds->{format}{$format}{default_vocab} ||
	    $ds->{vocab_list}[0];
	
	$request->output_vocab($vocab_value);
    }
    
    # Now that we know the format, we can set the response headers.
    
    $ds->_set_cors_header($request);
    $ds->_set_content_type($request);
    
    # If the format indicates that the output should be returned as an
    # attachment (which tells the browser to save it to disk), note this fact.
    
    my $save_flag = $request->save_output;
    my $disp = $ds->{format}{$format}{disposition};
    
    if ( defined $save_flag && $save_flag eq '0' )
    {
	#$ds->_set_content_disposition($request, 'inline');
	$ds->_set_content_type($request, 'text/plain') if $ds->{format}{$format}{is_text};
    }
    
    elsif ( ( defined $disp && $disp eq 'attachment' ) ||
	    $save_flag )
    {
	$ds->_set_content_disposition($request, 'attachment', $request->save_filename);
    }
    
    # Then set up the output.  This involves constructing a list of
    # specifiers that indicate which fields will be included in the output
    # and how they will be processed.
    
    $ds->_setup_output($request);
    
    # Now determine the class that corresponds to this request's primary role
    # and bless the request into that class.
    
    my $role = $ds->node_attr($request, 'role');
    bless $request, $ds->execution_class($role);
    
    # If an after_setup_hook is defined for this path, call it.
    
    $ds->_call_hooks($path, 'after_setup_hook', $request);
    
    # Prepare to time the query operation.
    
    my (@starttime) = Time::HiRes::gettimeofday();
    
    # Now execute the query operation.  This is the central step of this
    # entire routine; everything before and after is in support of this call.
	
    $request->$method($arg);
    
    # Determine how long the query took.
    
    my (@endtime) = Time::HiRes::gettimeofday();
    $request->{elapsed} = Time::HiRes::tv_interval(\@starttime, \@endtime);
    
    # If an after_operation_hook is defined for this path, call it.
    
    $ds->_call_hooks($path, 'after_operation_hook', $request);
    
    # Then we use the output configuration and the result of the query
    # operation to generate the actual output.  How we do this depends
    # upon how the operation method chooses to return its data.  It must
    # set one of the following fields in the request object, as described:
    # 
    # main_data		A scalar, containing data which is to be 
    #			returned as-is without further processing.
    # 
    # main_record	A hashref, representing a single record to be
    #			returned according to the output format.
    # 
    # main_result	A list of hashrefs, representing multiple
    #			records to be returned according to the output
    # 			format.
    # 
    # main_sth		A DBI statement handle, from which all 
    #			records that can be read should be returned
    #			according to the output format.
    # 
    # It is okay for main_result and main_sth to both be set, in which
    # case the records in the former will be sent first and then the
    # latter will be read.
    
    if ( ref $request->{main_record} )
    {
	return $ds->_generate_single_result($request);
    }
    
    elsif ( ref $request->{main_sth} or ref $request->{main_result} )
    {
	my $threshold = $ds->node_attr($path, 'streaming_threshold')
	    unless $request->{do_not_stream};
	
	return $ds->_generate_compound_result($request, $threshold);
    }
    
    elsif ( defined $request->{main_data} )
    {
	return $request->{main_data};
    }
    
    # If none of these fields are set, then the result set is empty.
    
    else
    {
	return $ds->_generate_empty_result($request);
    }
}


# _call_hooks ( path, hook, request )
# 
# If the specified hook has been defined for the specified path, call each of
# the defined values.  If the value is a code reference, call it with the
# request as the only parameter.  If it is a string, call it as a method of
# the request object.

sub _call_hooks {
    
    my ($ds, $path, $hook, $request, @args) = @_;
    
    # Skip this processing entirely unless we know that the specified hook has
    # been defined for at least one node in this data service.
    
    return unless $ds->{hook_enabled}{$hook};
    
    # Otherwise, look up the value for this hook which should either be an
    # array ref or undefined.
    
    my $hook_value = $ds->node_attr($path, $hook) || return;
    
    foreach my $code ( @$hook_value )
    {
	if ( ref $code eq 'CODE' )
	{
	    return &$code($request);
	}
	
	elsif ( defined $code )
	{
	    return $request->$code();
	}
    }
}


sub _set_cors_header {
    
    my ($ds, $request, $arg) = @_;
    
    # If this is a public-access data service, we add a universal CORS header.
    # At some point we need to add provision for authenticated access.
    
    if ( (defined $arg && $arg eq '*') || $ds->node_attr($request, 'public_access') )
    {
	$Web::DataService::FOUNDATION->set_cors_header("*");
    }
}


sub _set_content_type {

    my ($ds, $request, $ct) = @_;
    
    # If the content type was not explicitly given, choose it based on the
    # output format.
    
    unless ( $ct )
    {
	my $format = $request->output_format;
	$ct = $ds->{format}{$format}{content_type} || 'text/plain';
    }
    
    $Web::DataService::FOUNDATION->set_content_type($request, $ct);
}


sub _set_content_disposition {
    
    my ($ds, $request, $disp, $filename) = @_;
    
    # If we were given a disposition of 'inline', then set that.
    
    if ( $disp eq 'inline' )
    {
	$Web::DataService::FOUNDATION->set_header($request, 'Content-Disposition' => 'inline');
	return;
    }
    
    # If we weren't given an explicit filename, check to see if one was set
    # for this node.
    
    $filename //= $ds->node_attr($request, 'default_save_filename');
    
    # If we still don't have a filename, return without doing anything.
    
    return unless $filename;
    
    # Otherwise, set the appropriate header.  If the filename does not already
    # include a suffix, add the format.
    
    unless ( $filename =~ qr{ [^.] [.] \w+ $ }xs )
    {
	$filename .= '.' . $request->output_format;
    }
    
    $Web::DataService::FOUNDATION->set_header($request, 'Content-Disposition' => 
					 qq{attachment; filename="$filename"});
}


# valid_format_for ( path, format )
# 
# Return true if the specified format is valid for the specified path, false
# otherwise. 

sub valid_format_for {
    
    my ($ds, $path, $format) = @_;
    
    my $allow_format = $ds->node_attr($path, 'allow_format');
    return unless ref $allow_format eq 'HASH';
    return $allow_format->{$format};
}


# determine_ruleset ( )
# 
# Determine the ruleset that should apply to this request.  If a ruleset name
# was explicitly specified for the request path, then use that if it is
# defined or throw an exception if not.  Otherwise, try the path with slashes
# turned into commas and the optional ruleset_prefix applied.

sub determine_ruleset {
    
    my ($ds, $path) = @_;
    
    my $validator = $ds->{validator};
    my $ruleset = $ds->node_attr($path, 'ruleset');
    
    # If a ruleset name was explicitly given, then use that or throw an
    # exception if not defined.
    
    if ( defined $ruleset && $ruleset ne '' )
    {
	croak "unknown ruleset '$ruleset' for path $path"
	    unless $validator->ruleset_defined($ruleset);
	
	return $ruleset;
    }
    
    # If the ruleset was explicitly specified as '', do not process the
    # parameters for this path.
    
    return if defined $ruleset;
    
    # If the path is either empty or the root node '/', likewise return false.
    
    return unless defined $path && $path ne '' && $path ne '/';
    
    # Otherwise, try the path with / replaced by :.  If that is not defined,
    # then return empty.  The parameters for this path will not be processed.
    
    $path =~ s{/}{:}g;
    
    $path = $ds->{ruleset_prefix} . $path
	if defined $ds->{ruleset_prefix} && $ds->{ruleset_prefix} ne '';
    
    return $path if $validator->ruleset_defined($path);
}


# determine_output_names {
# 
# Determine the output block(s) and/or map(s) that should be used for this
# request.  If any output names were explicitly specified for the request
# path, then use them or throw an error if any are undefined.  Otherwise, try
# the path with slashes turned into colons and either ':default' or
# ':default_map' appended.

sub determine_output_names {

    my ($self) = @_;
    
    my $ds = $self->{ds};
    my $path = $self->{path};
    my @output_list = @{$self->{attrs}{output}} if ref $self->{attrs}{output} eq 'ARRAY';
    
    # If any output names were explicitly given, then check to make sure each
    # one corresponds to a known block or set.  Otherwise, throw an exception.
    
    foreach my $output_name ( @output_list )
    {
	croak "the string '$output_name' does not correspond to a defined output block or map"
	    unless ref $ds->{set}{$output_name} eq 'Web::DataService::Set' ||
		ref $ds->{block}{$output_name} eq 'Web::DataService::Block';
    }
    
    # Return the list.
    
    return @output_list;
}


# determine_output_format ( outer, inner )
# 
# This method is called by the error reporting routine if we do not know the
# output format.  We are given (possibly) both types of objects and need to
# determine the appropriate output format based on the data service
# configuration and the request path and parameters.
# 
# This method need only return a value if that value is not 'html', because
# that is the default.

sub determine_output_format {

    my ($ds, $outer, $inner) = @_;
    
    # If the data service has the feature 'format_suffix', then check the
    # URL path.  If no format is specified, we return the empty string.
    
    if ( $ds->{feature}{format_suffix} )
    {
	my $path = $Web::DataService::FOUNDATION->get_request_path($outer);
	
	$path =~ qr{ [.] ( [^.]+ ) $ }xs;
	return $1 || '';
    }
    
    # Otherwise, if the special parameter 'format' is enabled, check to see if
    # a value for that parameter was given.
    
    if ( my $format_param = $ds->{special}{format} )
    {
	# If the parameters have already been validated, check the cleaned
	# parameter values.
	
	if ( ref $inner && reftype $inner eq 'HASH' && $inner->{clean_params} )
	{
	    return $inner->{clean_params}{$format_param}
		if $inner->{clean_params}{$format_param};
	}
	
	# Otherwise, check the raw parameter values.
	
	else
	{
	    my $params = $Web::DataService::FOUNDATION->get_params($outer);
	    
	    return lc $params->{$format_param} if $params->{$format_param};
	}
    }
    
    # If no parameter value was found, see if we have identified a data
    # service node for this request.  If so, check to see if a default format
    # was established.
    
    if ( ref $inner && $inner->isa('Web::DataService::Request') )
    {
	my $default_format = $ds->node_attr($inner, 'default_format');
	
	return $default_format if $default_format;
    }
    
    # If we really can't tell, then return the empty string which will cause
    # the format to default to 'html'.
    
    return '';
}


my %CODE_STRING = ( 400 => "Bad Request", 
		    404 => "Not Found",
		    415 => "Invalid Media Type",
		    500 => "Server Error" );

# error_result ( error, request )
# 
# Send an error response back to the client.  This routine is designed to be
# as flexible as possible about its arguments.  At minimum, it only needs a
# request object - either the one generated by the foundation framework or
# the one generated by Web::DataService.

sub error_result {

    my ($ds, $error, $request) = @_;
    
    # If we are in 'debug' mode, then print out the error message.
    
    if ( Web::DataService->is_mode('debug') )
    {
	unless ( defined $error )
	{
	    Dancer::debug("CAUGHT UNKNOWN ERROR");
	}
	
	elsif ( ! ref $error )
	{
	    Dancer::debug("CAUGHT ERROR: " . $error);
	}
	
	elsif ( $error->isa('HTTP::Validate::Result') )
	{
	    Dancer::debug("CAUGHT HTTP::VALIDATE RESULT");
	}
	
	elsif ( $error->isa('Dancer::Exception::Base') )
	{
	    Dancer::debug("CAUGHT ERROR: " . $error->message);
	}
	
	else
	{
	    Dancer::debug("CAUGHT OTHER ERROR");
	}
    }
    
    # Then figure out which kind of request object we have.
    
    my ($inner, $outer);
    
    # If we were given the 'inner' request object, we can retrieve the 'outer'
    # one from that.
    
    if ( ref $request && $request->isa('Web::DataService::Request') )
    {
	$inner = $request;
	$outer = $request->outer;
    }
    
    # If we were given the 'outer' object, ask the foundation framework to
    # tell us the corresponding 'inner' one.
    
    elsif ( defined $request )
    {
	$outer = $request;
	$inner = $Web::DataService::FOUNDATION->retrieve_inner($outer);
    }
    
    # Otherwise, ask the foundation framework to tell us the current request.
    
    else
    {
	$outer = $Web::DataService::FOUNDATION->retrieve_outer();
	$inner = $Web::DataService::FOUNDATION->retrieve_inner($outer);
    }
    
    # Get the proper data service instance from the inner request, in case we
    # were called as a class method.
    
    $ds = defined $inner && $inner->isa('Web::DataService::Request') ? $inner->ds
	: $Web::DataService::WDS_INSTANCES[0];
    
    # Next, try to determine the format of the result
    
    my $format;
    $format ||= $inner->output_format if $inner;
    $format ||= $ds->determine_output_format($outer, $inner);
    
    my ($code);
    my (@errors, @warnings);
    
    @warnings = $inner->warnings if ref $inner && $inner->isa('Web::DataService::Request');
    
    # If the error is actually a response object from HTTP::Validate, then
    # extract the error and warning messages.  In this case, the error code
    # should be "400 bad request".
    
    if ( ref $error eq 'HTTP::Validate::Result' )
    {
	@errors = $error->errors;
	push @warnings, $error->warnings;
	$code = "400";
    }
    
    # If the error message begins with a 3-digit number, then that should be
    # used as the code and the rest of the message as the error text.
    
    elsif ( $error =~ qr{ ^ (\d\d\d) \s+ (.+) }xs )
    {
	$code = $1;
	@errors = $2;
    }
    
    elsif ( $error =~ qr{ ^ (\d\d\d) }xs )
    {
	$code = $1;
	
	if ( $code eq '404' )
	{
	    my $path = $Web::DataService::FOUNDATION->get_request_path($outer);
	    if ( defined $path && $path ne '' )
	    {
		@errors = ("The path '$path' was not found on this server.");
	    }
	    
	    else
	    {
		@errors = ("This request is invalid.");
	    }
	}
	
	elsif ( $CODE_STRING{$code} )
	{
	    @errors = $CODE_STRING{$code};
	}
	
	else
	{
	    @errors = "Error";
	}
    }
    
    # Otherwise, this is an internal error and all that we should report to
    # the user (for security reasons) is that an error occurred.  The actual
    # message is written to the server error log.
    
    else
    {
	$code = 500;
	warn $error;
	@errors = "A server error occurred.  Please contact the server administrator.";
    }
    
    # If we know the format and if the corresponding format class knows how to
    # generate error messages, then take advantage of that functionality.
    
    my $format_class = $ds->{format}{$format}{package} if $format;
    
    if ( $format_class && $format_class->can('emit_error') )
    {
	my $error_body = $format_class->emit_error($code, \@errors, \@warnings);
	my $content_type = $ds->{format}{$format}{content_type} || 'text/plain';
	
	$Web::DataService::FOUNDATION->set_content_type($outer, $content_type);
	$Web::DataService::FOUNDATION->set_cors_header($outer, "*");
	$Web::DataService::FOUNDATION->set_status($outer, $code);
	$Web::DataService::FOUNDATION->set_body($outer, $error_body);
    }
    
    # Otherwise, generate a generic HTML response (we'll add template
    # capability later...)
    
    else
    {
	my $text = $CODE_STRING{$code} || 'Error';
	my $error = "<ul>\n";
	my $warning = '';
	
	$error .= "<li>$_</li>\n" foreach @errors;
	$error .= "</ul>\n";
	
	shift @warnings unless $warnings[0];
	
	if ( @warnings )
	{
	    $warning .= "<h2>Warnings:</h2>\n<ul>\n";
	    $warning .= "<li>$_</li>\n" foreach @warnings;
	    $warning .= "</ul>\n";
	}
	
	my $body = <<END_BODY;
<html><head><title>$code $text</title></head>
<body><h1>$code $text</h1>
$error
$warning
</body></html>
END_BODY
    
	$Web::DataService::FOUNDATION->set_content_type($outer, 'text/html');
	$Web::DataService::FOUNDATION->set_status($outer, $code);
	$Web::DataService::FOUNDATION->set_body($outer, $body);
    }
}


1;
