The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package App::Web;

use strict;
use vars qw($VERSION);
use CGI::Cookie;
use Cwd                   qw( cwd );
use Data::Dumper          qw( Dumper );
use File::Spec::Functions qw( catdir );
use Log::Log4perl         qw( get_logger );
use Template;
use Workflow::Factory     qw( FACTORY );
use XML::Simple           qw( :strict );

$VERSION = '0.01';

# Default logfile name; can change with arg to init_logger()
my $DEFAULT_LOG_FILE = 'workflow.log';

my ( $log );

my %ACTION_DATA = ();
my %DISPATCH    = ();

########################################
# DISPATCHER

sub create_dispatcher {
    my ( $class, %params ) = @_;
    $log ||= get_logger();
    $log->is_info && $log->info( "Creating new dispatcher" );
    my $self = bless({
        cgi        => $params{cgi},
        cookie_in  => {},
        cookie_out => {},
        template   => undef }, $class );

    # Note that this creates $self->{params}, so don't assign before
    # this statement

    $self->_assign_args( $params{cgi} );
    $log->is_debug && $log->debug( "Assigned arguments ok" );

    $self->param( base_url => $params{base_url} );

    $self->_create_cookies( $params{cookie_text} );
    $log->is_debug && $log->debug( "Created cookies ok" );

    $self->_init_templating( $params{include_path} );

    return $self;
}

sub _assign_args {
    my ( $self, $cgi ) = @_;
    my %params = ();
    foreach my $name ( $cgi->param() ) {
        my @values = $cgi->param( $name );
        if ( scalar @values > 1 ) {
            $params{ $name } = \@values;
        }
        else {
            $params{ $name } = $values[0];
        }
    }
    return $self->{params} = \%params;
}

sub _create_cookies {
    my ( $self, $cookie_header ) = @_;
    $log->is_debug &&
        $log->debug( "Got cookie header from client '$cookie_header'" );
    my %cookies_in = CGI::Cookie->parse( $cookie_header );
    foreach my $name ( keys %cookies_in ) {
        my $value = $cookies_in{ $name }->value;
        $self->cookie_in( $name, $value );
        unless ( $self->param( $name ) ) {
            $self->param( $name, $value );
        }
    }
}

sub param {
    my ( $self, $name, $value ) = @_;
    if ( $name and $value ) {
        return $self->{params}{ $name } = $value;
    }
    elsif ( $name ) {
        return $self->{params}{ $name };
    }
    return $self->{params};
}

sub cookie_in {
    my ( $self, $name, $value ) = @_;
    if ( $name and $value ) {
        $log->is_debug &&
            $log->debug( "Adding inbound cookie: '$name' = '$value'" );
        $self->{cookie_in}{ $name } = $value;
    }
    if ( $name ) {
        return $self->{cookie_in}{ $name }
    }
    return $self->{cookie_in};
}

sub cookie_out {
    my ( $self, $name, $value ) = @_;
    if ( $name and $value ) {
        $log->is_debug &&
            $log->debug( "Adding outbound cookie: '$name' = '$value'" );
        $self->{cookie_out}{ $name } = $value;
    }
    if ( $name ) {
        return $self->{cookie_out}{ $name }
    }
    return $self->{cookie_out};
}

sub cookie_out_as_objects {
    my ( $self ) = @_;
    my @values = ();
    my $cookies_out = $self->cookie_out;
    if ( scalar keys %{ $cookies_out } ) {
        while ( my ( $name, $value ) = each %{ $cookies_out } ) {
            my $obj = CGI::Cookie->new( -name  => $name,
                                        -value => $value );
            my $cookie = $obj->as_string;
            push @values, $cookie;
            $log->is_debug && $log->debug( "Outbound cookie found: $cookie" );
        }
    }
    else {
        $log->is_info && $log->info( "No outbound cookies found" );
    }
    return \@values;
}

########################################
# DISPATCH MAPPINGS

sub is_dispatchable {
    my ( $self, $action_name ) = @_;
    return undef unless ( $action_name );
    return defined $DISPATCH{ $action_name };
}

sub run {
    my ( $self, $action_name ) = @_;
    if ( $DISPATCH{ $action_name } ) {
        return $DISPATCH{ $action_name }->( $self );
    }
    else {
        die "No such action '$action_name'\n";
    }
}


# Each of these routines returns a template name

sub _action_create_workflow {
    my ( $self ) = @_;
    my $wf = FACTORY->create_workflow( 'Ticket' );
    $self->param( workflow => $wf );
    $self->cookie_out( workflow_id => $wf->id );
    return 'workflow_created.tmpl';
}

sub _action_fetch_workflow {
    my ( $self ) = @_;
    my $wf = $self->_get_workflow();
    $self->cookie_out( workflow_id => $wf->id );
    return 'workflow_fetched.tmpl';
}

sub _action_list_history {
    my ( $self ) = @_;
    my $wf = $self->_get_workflow();
    my @history = $wf->get_history();
    $self->param( history_list => \@history );
    return 'workflow_history.tmpl';
}

sub _action_execute_action {
    my ( $self ) = @_;
    my $wf = $self->_get_workflow();

    my $action = $self->param( 'action' );
    unless ( $action ) {
        die "To execute an action you must specify an action name!\n";
    }

    # If they haven't entered data yet, add the fields (as a map) to
    # the parameters and redirect to the form for entering it

    unless ( $self->param( '_action_data_entered' ) || ! $ACTION_DATA{ $action } ) {
        $self->param( status_msg =>
                      'Action cannot be executed until you enter its data' );
        my @fields = $wf->get_action_fields( $action );
        my %by_name = map { $_->name => $_ } @fields;
        $self->param( ACTION_FIELDS => \%by_name );
        return $ACTION_DATA{ $action };
    }

    # Otherwise, set the user data directly into the workflow context...
    $wf->context->param( $self->param );

    # ...and execute the action
    eval { $wf->execute_action( $self->param( 'action' ) ) };

    # ...if we catch a condition/validation exception, display the
    # error and go back to the data entry form

    if ( $@ && ( $@->isa( 'Workflow::Exception::Condition' ) ||
                 $@->isa( 'Workflow::Exception::Validation' ) ) ) {
        $log->error( "One or more conditions not met to execute action: $@; ",
                     "redirecting to form" );
        $self->param( error_msg => "Failed to execute action: $@" );
        return $ACTION_DATA{ $action };
    }
    $self->param( status_msg => "Action '$action' executed ok" );
    return $self->_action_list_history();
}

sub _action_login {
    my ( $self ) = @_;
    if ( my $user = $self->param( 'current_user' ) ) {
        $self->cookie_out( current_user => $user );
    }
    else {
        $self->param( error_msg => "Please specify a login name I can use!" );
    }
    return 'index.tmpl';
}

sub _get_workflow {
    my ( $self ) = @_;
    return $self->param( 'workflow' )  if ( $self->param( 'workflow' ) );
    my $log = get_logger();
    my $wf_id = $self->param( 'workflow_id' ) || $self->cookie_in( 'workflow_id' );
    unless ( $wf_id ) {
        die "No workflow ID given! Please fetch a workflow or create ",
            "a new one.\n";
    }
    $log->is_debug &&
        $log->debug( "Fetching workflow with ID '$wf_id'" );
    my $wf = FACTORY->fetch_workflow( 'Ticket', $wf_id );
    if ( $wf ) {
        $log->is_debug &&
            $log->debug( "Workflow found; current state: '", $wf->state, "'" );
        $self->param( workflow => $wf );
    }
    else {
        my $msg = "No workflow found with ID '$wf_id'";
        $log->warn( $msg );
        die "$msg\n";
    }
    $log->is_info &&
        $log->info( "Setting current user to: ", $self->cookie_in( 'current_user' ) );
    $wf->context->param( current_user => $self->cookie_in( 'current_user' ) );
    if ( my $ticket_id = $wf->context->param( 'ticket_id' ) ) {
        my $ticket = App::Ticket->fetch( $ticket_id );
        $log->info( "Adding ticket [ID: ", $ticket->id, "] to context" );
        $wf->context->param( ticket => $ticket );
    }
    return $wf;
}

########################################
# TEMPLATE PROCESSING

sub process_template {
    my ( $self, $template_name ) = @_;
    $log->is_debug &&
        $log->debug( "Processing template '$template_name'..." );
    my ( $content );
    my $t = $self->{template};
    my %template_params = (
        dispatcher => $self,
        cgi        => $self->{cgi},
        %{ $self->param },
    );
#    local $Data::Dumper::Indent = 1;
#    $log->is_debug &&
#        $log->debug( "Sending the following parameters: ", Dumper( \%template_params ) );
    $t->process( $template_name, \%template_params, \$content )
        || die "Cannot process template '$template_name': ", $t->error, "\n";
    $log->is_debug &&
        $log->debug( "Processed template ok" );
    return $content;
}

sub _init_templating {
    my ( $self, $include_path ) = @_;
    unless ( $include_path ) {
        $include_path = catdir( cwd(), 'web_templates' );
    }
    $log->is_info &&
        $log->info( "Initializing the template object with path: $include_path" );
    my $template = Template->new( INCLUDE_PATH => $include_path );
    $log->is_info &&
        $log->info( "Finished initializing the template object" );
    return $self->{template} = $template;
}



########################################
# INITIALIZATION

sub init_logger {
    my ( $log_file ) = @_;
    $log_file ||= $DEFAULT_LOG_FILE;
    if ( -f $log_file ) {
        my $log_mod_time = (stat $log_file)[9];
        if ( time - $log_mod_time > 600 ) { # 10 minutes
            unlink( $log_file );
        }
    }
    Log::Log4perl::init( 'log4perl.conf' );
    $log = get_logger();
}

sub init_factory {
    $log->is_info &&
        $log->info( "Starting to configure workflow factory" );

    $log->warn( "Will use parser of class: ", Workflow::Config->get_factory_class( 'xml' ) );

    FACTORY->add_config_from_file(
        workflow  => 'workflow.xml',
        action    => 'workflow_action.xml',
        validator => 'workflow_validator.xml',
        condition => 'workflow_condition.xml',
        persister => 'workflow_persister.xml'
    );
    $log->is_info &&
        $log->info( "Finished configuring workflow factory" );
}

sub init_url_mappings {
    my ( $class, $mapping_file ) = @_;
    $log->is_info &&
        $log->info( "Initializing the URL and action mappings" );
    my %options = (
        ForceArray => [ 'url-mapping', 'action-display' ],
        KeyAttr    => [],
    );
    my $config = XMLin( $mapping_file, %options );
    no strict 'refs';
    foreach my $url_map ( @{ $config->{'url-mapping'} } ) {
        my $map_class  = $url_map->{class};
        my $map_method = $url_map->{method};
        eval "require $map_class";
        if ( $@ ) {
            die "Cannot include class '$map_class': $@\n";
        }

        # All dispatch methods begin with '_action_'
        my $method = \&{ $map_class . '::_action_' . $map_method };
        unless ( $method ) {
            die "No method '$map_class->$map_method'\n";
        }
        $DISPATCH{ $url_map->{url} } = $method;
    }

    foreach my $action_template ( @{ $config->{'action-display'} } ) {
        $ACTION_DATA{ $action_template->{name} } = $action_template->{template};
    }

    $log->is_info &&
        $log->info( "Finished initializing the URL and action mappings" );
    return $config;
}

# DEPRECATED

sub lookup_dispatch {
    my ( $self, $action_name ) = @_;
    warn "Method 'lookup_dispatch()' is deprecated; just use 'run()' to ",
         "actually dispatch the action\n";
    return $DISPATCH{ $action_name };
}

1;