CatalystX::Usul::Controller - Application independent common controller methods

   package CatalystX::Usul;
   use parent qw(Catalyst::Component CatalystX::Usul::Base);

   package CatalystX::Usul::Controller;
   use parent qw(CatalystX::Usul Catalyst::Controller);

   package YourApp::Controller::YourController;
   use parent qw(CatalystX::Usul::Controller);

   $types = $self->accepted_content_types( $c->req );

   $data = $self->deserialize( $c );

   $self->error_page( $c, $error_message_key, @args );

   my $value = $self->get_key( $c, $key_name );

   $language = $self->get_language( $c->config, $c->req );

   $self->load_keys( $c );

   $self->load_stash_from_user( $c );

   $self->load_stash_per_request( $c );

   $self->load_stash_with_browser_state( $c );

   $content_type = $self->preferred_content_type( $c->config, $c->req );

   $self->redirect_to_page( $c, $page_name );

   $self->redirect_to_path( $c, $action_path, @args );

   $self->set_key( $c, $key_name, $value );

   $bool = $self->user_agent_ok( $c );

   $class->_setup_plugins( $app );

   $bool = __is_language( $candidate, \@languages );

# @(#)$Id: Controller.pm 589 2009-06-13 12:24:29Z pjf $

package CatalystX::Usul::Controller;

use strict;
use warnings;
use version; our $VERSION = qv( sprintf '0.3.%d', q$Rev: 589 $ =~ /\d+/gmx );
use parent qw(CatalystX::Usul Catalyst::Controller);

use CatalystX::Usul::PersistentState;
use Class::C3;
use Config;
use HTTP::Headers::Util qw(split_header_words);
use List::Util qw(first);

__PACKAGE__->mk_accessors( qw(phase) );

my $HASH = chr 35;
my $NUL  = q();
my $SEP  = q(/);
my $SPC  = q( );
my $TTS  = q( ~ );

sub new {
   my ($self, $app, $config) = @_; my $class = ref $self || $self;

   $class->_setup_plugins( $app );

   my $ac      = $app->config || {};
   my $new     = $self->next::method( $app, $config );
   # Determine phase number from install path
   my $appldir = $new->basename( $ac->{appldir} || $NUL ) || $NUL;
   my ($phase) = $appldir =~ m{ \A v \d+ \. \d+ p (\d+) \z }msx;

   $new->phase( $phase || 3 );
   # This replaces what would have happened in Catalyst::Controller->new
   $new->_application( $app ) if ($Catalyst::VERSION < 0.08);

   return $new;
}

sub accepted_content_types {
   # Taken from jshirley's Catalyst::Action::REST
   my ($self, $req) = @_; my ($accept_header, $qvalue, $type, %types);

   # First, we use the content type in the HTTP Request.  It wins all.
   if ($req->method eq q(GET) and $type = $req->content_type) {
      $types{ $type } = 3;
   }

   if ($req->method eq q(GET) and $type = $req->param( q(content-type) )) {
      $types{ $type } = 2;
   }

   # Third, we parse the Accept header, and see if the client takes a
   # format we understand.  This is taken from chansen's
   # Apache2::UploadProgress.
   if ($accept_header = $req->header( q(accept) )) {
      my $counter = 0;

      for my $pair (split_header_words( $accept_header )) {
         ($type, $qvalue) = @{ $pair }[ 0, 3 ];

         next if ($types{ $type });

         $qvalue = 1 - (++$counter / 1_000) unless (defined $qvalue);

         $types{ $type } = sprintf q(%.3f), $qvalue;
      }
   }

   return [ reverse sort { $types{ $a } <=> $types{ $b } } keys %types ];
}

sub auto {
   # Allow access to authorised users. Forward the unwanted elsewhere
   my ($self, $c) = @_; my ($closed, $rv, $rooms);

   # Browser dependant content
   return 0 unless ($self->user_agent_ok( $c ));

   my $cfg = $c->config; my $s = $c->stash;

   # Select the room to authenticate
   my $name = $c->action->name || q(unknown);

   # Redirects are open to anyone always
   return 1 if ($name =~ m{ \A redirect_to }mx);

   # Handle closing of the application by administrators
   my $path = $cfg->{app_closed} || $NUL; $path =~ s{ \A root / }{}mx;

   return 1 if ($c->action->reverse eq $path);

   $self->redirect_to_page( $c, q(app_closed) ) if ($s->{app_closed});

   # If the state attribute is > 1 then the room is closed
   if ($rooms = $s->{rooms} and exists $rooms->{ $name }) {
      $closed = exists $rooms->{ $name }->{state}
              ? $rooms->{ $name }->{state} : 0;
   }
   else { $closed = 0 }

   $self->redirect_to_page( $c, q(room_closed) ) if ($closed > 1);

   # Rooms with the Public attribute are open to anyone
   return 1 if (exists $c->action->attributes->{ q(Public) });

   # Must have an authentication page configured
   unless ($path = $cfg->{authenticate}) {
      return $self->error_page( $c, 'Authentication page not specified' );
   }

   my $model = $c->model( q(Navigation) );

   # Zero return value from access_check grants access to wanted room
   return 1 unless ($rv = $model->access_check( q(rooms), $name ));

   if ($rv == 1) {
      # Err on the side of caution and deny access if no access list is found
      my $msg = 'Action [_1] has no ACL';

      return $self->error_page( $c, $msg, $c->action->reverse );
   }

   if ($rv == 2) {
      # Force the user to authenticate. Save the wanted room in session store
      $c->session->{wanted} = $c->action->reverse;
      $self->redirect_to_path( $c, $path );
   }

   # Access denied, user not authorised
   $self->redirect_to_page( $c, q(access_denied) ) if ($rv == 3);

   return 0;
}

sub begin {
   my ($self, $c, @rest) = @_; my $cfg;

   # No configuration game over. Implies we didn't parse homedir/appname.xml
   unless ($cfg = $c->config and $cfg->{default_action}) {
      $self->log_fatal( 'No config '.$cfg->{file} );
      return;
   }

   my $s = $c->stash; my $req = $c->req;

   # Stash the content type from the request. Default from config
   my $content_type = $self->preferred_content_type( $cfg, $req );

   $s->{content_type} = $content_type;

   # Select the view from the content type
   $s->{current_view} = $cfg->{content_map}->{ $content_type };

   # Derive the verb from the request. View dependant
   $s->{verb} = $c->view( $s->{current_view } )->get_verb( $s, $req );

   # Deserialize the request if necessary
   $s->{data} = $self->deserialize( $c );

   # Set the language to sane supported value
   $s->{lang} = $self->get_language( $cfg, $req );

   # Cut down on the number of $c->config calls
   $s->{admin_role} = $cfg->{admin_role};

   # Read the config files from cache
   $self->load_stash_per_request( $c );

   # Debug output mimics system debug but turned on within the application
   if ($s->{debug} && !$c->debug) {
      $self->log_debug( $req->method.$SPC.$req->path );
   }

   my $namespace = $c->action->namespace || $NUL;
   my $name      = $c->action->name      || $NUL;

   # Stuff some basic information into the stash
   $s->{application} = q(unknown) unless ($s->{application});
   $s->{body       } = 1;
   $s->{class      } = $self->prefix;
   $s->{dhtml      } = 1;
   $s->{domain     } = $req->uri->host;
   $s->{encoding   } = $self->encoding;
   $s->{host_port  } = $req->uri->host_port;
   $s->{host       } = (split m{ \. }mx, ucfirst $s->{domain})[0];
   $s->{is_popup   } = q(false);
   $s->{is_xml     } = 1 if ($content_type =~ m{ xml }mx);
   $s->{nbsp       } = q(&nbsp;);
   $s->{port       } = $req->uri->port;
   $s->{page       } = 1;
   $s->{platform   } = $s->{host_port} unless ($s->{platform});
   $s->{page_title } = $s->{application}.$SPC.$s->{platform};
   $s->{root       } = $cfg->{root};
   $s->{sess_path  } = $SEP;
   $s->{skindir    } = $cfg->{skindir};
   $s->{title      } = $s->{application}.$SPC.(ucfirst $namespace);
   $s->{token      } = $cfg->{token};
   $s->{version    } = eval { $self->version };

   # Generate and stash some uris
   my $help = q(root).$SEP.q(help);
   my $mark = join $HASH, split m{ $SEP }mx, $c->action;
   my $uri  = $self->uri_for( $c, $namespace.$SEP.$name, $s->{lang} );

   $s->{assets     } = $c->uri_for( $SEP.$cfg->{skins}.$SEP.$s->{skin} ).$SEP;
   $s->{form       } = { action => $uri, name => $name };
   $s->{help_url   } = $self->uri_for( $c, $help, $s->{lang}, $mark );
   $s->{help_url   } =~ s{ %23 }{$HASH}mx;
   $s->{static     } = $c->uri_for( $SEP.q(static) ).$SEP;
   $s->{url        } = $self->uri_for( $c, $namespace, $s->{lang} ).$SEP;
   return;
}

sub deserialize {
   my ($self, $c) = @_; my $s = $c->stash;

   return unless ($s->{verb});

   my $should = (grep { $_ eq $s->{verb} } ( qw(options post put) )) ? 1 : 0;
   my $view   = $c->view( $s->{current_view } );

   return $should ? $view->deserialize( $s, $c->req ) : $NUL;
}

sub end {
   # Last controller method called by Catalyst
   my ($self, $c) = @_; my $errors;

   $self->maybe::next::method( $c );

   if (scalar @{ $c->error }) {
      for my $e (@{ $c->error }) {
         if (ref $e eq $self->exception_class) {
            $errors .= $self->loc( $c, $e->as_string, @{ $e->args } );
         }
         else { $errors .= $self->loc( $c, $e ) }
      }

      $self->error_page( $c, $errors );
      $c->clear_errors;
   }

   $c->forward( q(render) );
   return;
}

sub error_page {
   # Display an error message
   my ($self, $c, @rest) = @_; my $s = $c->stash; my $e;

   my $msg   = $self->loc( $c, @rest );
   my $model = $c->model( q(Navigation) );

   $s->{subHeading} = ucfirst $msg;
   $self->log_error( (ref $self).$SPC.$msg );
   $c->action->reverse( q(error_page) );

   eval {
      $model->clear_controls;
      $model->add_menu_back;
      $model->simple_page( q(error) );
   };

   $c->res->body( $msg.$TTS.$e->as_string ) if ($e = $self->catch);

   # Must return false for auto
   return 0;
}

sub get_key {
   my ($self, $c, @rest) = @_;

   return CatalystX::Usul::PersistentState->get_key( $c, @rest );
}

sub get_language {
   # Select from; captured args, request headers, config default or hard coded
   my ($self, $cfg, $req) = @_;

   my @languages  = split $SPC, $cfg->{languages} || q(en);
   my $candidate  = lc substr $req->captures->[0] || $NUL, 0, 2;

   return $candidate if (__is_language( $candidate, \@languages ));

   my @candidates = map    { (split m{ ; }mx, $_)[ 0 ] }
                    split m{ , }mx,
                    lc $req->headers->{ q(accept-language) } || $NUL;
   my $lang       = first  { __is_language( $_, \@languages ) } @candidates;

   return $lang || $cfg->{language} || q(en);
}

sub load_keys {
   my ($self, $c) = @_;

   return CatalystX::Usul::PersistentState->load_keys( $c );
}

sub load_stash_from_user {
   # Set user identity from the session state. Session state will be retained
   # for ninety days. User lasts for max_sess_time or two hours
   my ($self, $c) = @_; my $s = $c->stash; my $now = time;

   $s->{elapsed}  = $now - (($c->session && $c->session->{elapsed}) || $now);
   $s->{expires}  = $s->{max_sess_time} || 7_200;
   $s->{user   }  = $NUL;

   if ($c->user) {
      if ($s->{elapsed} < $s->{expires}) {
         $c->session->{elapsed} = $now;
         $s->{user      } = $c->user->username;
         $s->{name      } = $c->user->first_name.$SPC.$c->user->last_name;
         $s->{user_email} = $c->user->email_address;
         $s->{firstName } = $c->user->first_name;
         $s->{lastName  } = $c->user->last_name;
         $s->{roles     } = $c->user->roles;
      }
      else {
         my $msg = 'User [_1] session expired';

         $self->log_info( $self->loc( $c, $msg, $c->user->username ) );
         $c->session_expire_key( __user => 0 );
         $c->logout;
      }
   }

   unless ($s->{user}) {
      $s->{user      } = q(unknown);
      $s->{user_email} = $NUL;
      $s->{name      } = $NUL;
      $s->{firstName } = $NUL;
      $s->{lastName  } = $NUL;
      $s->{roles     } = [];
   }

   # Anyone in the administrators role gets access to all levels and rooms
   $s->{is_administrator}
      = (first { $_ eq $s->{admin_role} } @{ $s->{roles} }) ? 1 : 0;

   return;
}

sub load_stash_per_request {
   # Read the XML config from the cached copy in the data model
   my ($self, $c) = @_; my $s = $c->stash; my ($e, $namespace);

   # Merge the hashes from each file in order. My phase allows for multiple
   # installations of the same version for different purposes
   my $files = [ q(os_).$Config{osname}, q(phase).$self->phase,
                 q(default),             q(default_).$s->{lang} ];

   # Add a controller specific file to the list
   if ($namespace = $c->action->namespace) {
      push @{ $files }, $namespace, $namespace.q(_).$s->{lang};
   }

   my $config = eval { $c->model( q(Config) )->load_files( @{ $files } ) };

   if ($e = $self->catch) {
      $self->error_page( $c, $e->as_string, @{ $e->args } );
   }
   else {
      # Copy the config to the stash
      while (my ($key, $value) = each %{ $config }) {
         $s->{ $key } = $value;
      }

      # Raise the "level" of the globals in the stash
      my $globals = delete $s->{globals};

      while (my ($key, $value) = each %{ $globals }) {
         $s->{ $key } = $value->{value};
      }
   }

   # Recover the user identity from the session store
   $self->load_stash_from_user( $c );

   # Recover attributes from cookies set by javascript in the browser
   $self->load_stash_with_browser_state( $c );

   return;
}

sub load_stash_with_browser_state {
   # Extract key/value pairs from the browser state cookie
   my ($self, $c) = @_; my $cfg = $c->config; my $s = $c->stash;

   $s->{cookiep}  = $self->app_prefix( $cfg->{name} );
   $s->{cname  }  = $s->{cookiep}.q(_state);

   # Set some defaults
   $s->{debug  }  = $c->debug;
   $s->{fstate }  = 1;
   $s->{pwidth }  = $s->{pwidth} || 40;
   $s->{sbstate}  = 0;
   $s->{skin   }  = $cfg->{default_skin};
   $s->{width  }  = 1024;

   # Call the plugin parent class method if it's loaded
   $self->maybe::next::method( $c );
   return;
}

sub preferred_content_type {
   my ($self, $cfg, $req) = @_; my $type;

   # Set the content type from the request header
   if ($cfg->{negotiate_content_type}) {
      $type = $self->accepted_content_types( $req )->[ 0 ];
   }

   # Default the content type if it's not already set
   $type = $cfg->{content_type} if (!$type || $type eq q(*/*));

   return $type;
}

sub redirect_to_page {
   # Redirects to a private action path via a config attribute
   my ($self, $c, $page) = @_; my $path;

   unless ($path = $c->config->{ $page }) {
      return $self->error_page( $c, 'Page [_1] unknown', $page );
   }

   my $namespace = $c->action->namespace;
   my $name      = $c->action->name || q(unknown);

   $self->redirect_to_path( $c, $path, $namespace, $name );
   return;
}

sub redirect_to_path {
   # Does a response redirect and detach
   my ($self, $c, $path, @rest) = @_; my $s = $c->stash;

   $path ||= $c->config->{default_action}; delete $s->{token};
   $c->res->redirect( $self->uri_for( $c, $path, $s->{lang}, @rest ) );
   $c->detach(); # Never returns
   return;
}

sub set_key {
   my ($self, $c, @rest) = @_;

   return CatalystX::Usul::PersistentState->set_key( $c, @rest );
}

sub user_agent_ok {
   my ($self, $c) = @_; my $cfg = $c->config; my $s = $c->stash;

   my $ua = $c->req->headers->{ q(user-agent) } || $NUL;

   if (($cfg->{misery_page} or $cfg->{misery_skin}) and $ua =~ m{ msie }imsx) {
      unless ($cfg->{misery_skin}) {
         $c->res->redirect( $cfg->{misery_page} );
         $c->detach(); # Never returns
         return 0;
      }

      $s->{skin  } = $cfg->{misery_skin};
      $s->{assets} = $c->uri_for( $SEP.$cfg->{skins}.$SEP.$s->{skin} ).$SEP;
   }

   return 1;
}

# Private methods

sub _parse_HasActions_attr { ## no critic
   # Adding the HasActions attribute to a controller action causes our apps
   # action class handler to be called for each request
   my ($self, $c, $name, $value) = @_;

   return ( q(ActionClass), $c->config->{action_class} );
}

sub _setup_plugins {
   # Load the controller plugins
   my ($self, $app) = @_;

   unless (__PACKAGE__->get_inherited( q(_c_plugins) )) {
      my $config  = { search_paths => [ qw(::Plugin::Controller ::Plugin::C) ],
                      %{ $app->config->{ setup_plugins } || {} } };
      my $plugins = __PACKAGE__->setup_plugins( $config );

      # So we'll do this only once
      __PACKAGE__->set_inherited( q(_c_plugins), $plugins );
   }

   return;
}

# Private subroutines

sub __is_language {
   # Is this one if the languages the application supports
   my ($candidate, $languages) = @_;

   return (first { $_ eq $candidate } @{ $languages }) ? 1 : 0;
}

1;

__END__

# Local Variables:
# mode: perl
# tab-width: 3
# End: