Attachment #50715 for bug #15562

View | Details | Raw Unified | Return to bug 15562
Collapse All | Expand All

Lines 36-42 BEGIN { Link Here

(-)a/C4/Auth_with_cas.pm (-1 / +1 lines)
36	@ISA = qw(Exporter);	36	@ISA = qw(Exporter);
37	@EXPORT = qw(check_api_auth_cas checkpw_cas login_cas logout_cas login_cas_url);	37	@EXPORT = qw(check_api_auth_cas checkpw_cas login_cas logout_cas login_cas_url);
38	}	38	}
39	my $context = C4::Context->new() or die 'C4::Context->new failed';	39	my $context = C4::Context->current() or die 'No current context';
40	my $defaultcasserver;	40	my $defaultcasserver;
41	my $casservers;	41	my $casservers;
42	my $yamlauthfile = C4::Context->config('intranetdir') . "/C4/Auth_cas_servers.yaml";	42	my $yamlauthfile = C4::Context->config('intranetdir') . "/C4/Auth_cas_servers.yaml";

Lines 53-59 sub ldapserver_error { Link Here

(-)a/C4/Auth_with_ldap.pm (-1 / +1 lines)
53	}	53	}
54		54
55	use vars qw($mapping @ldaphosts $base $ldapname $ldappassword);	55	use vars qw($mapping @ldaphosts $base $ldapname $ldappassword);
56	my $context = C4::Context->new() or die 'C4::Context->new failed';	56	my $context = C4::Context->current() or die 'No current context';
57	my $ldap = C4::Context->config("ldapserver") or die 'No "ldapserver" in server hash from KOHA_CONF: ' . $ENV{KOHA_CONF};	57	my $ldap = C4::Context->config("ldapserver") or die 'No "ldapserver" in server hash from KOHA_CONF: ' . $ENV{KOHA_CONF};
58	my $prefhost = $ldap->{hostname} or die ldapserver_error('hostname');	58	my $prefhost = $ldap->{hostname} or die ldapserver_error('hostname');
59	my $base = $ldap->{base} or die ldapserver_error('base');	59	my $base = $ldap->{base} or die ldapserver_error('base');




			    eval {C4::Context->dbh();};
			    if ($@){
				$debug_level = 1;
			    }
			    else {
				$debug_level =  C4::Context->preference("DebugLevel");
			    }

		# a little example table with various version info";
					print "
						<h1>Koha error</h1>
						<p>The following fatal error has occurred:</p>
                        <pre><code>$msg</code></pre>
						<table>
						<tr><th>Apache</th><td>  $versions{apacheVersion}</td></tr>

				} elsif ($debug_level eq "1"){
					print "
						<h1>Koha error</h1>
						<p>The following fatal error has occurred:</p>
                        <pre><code>$msg</code></pre>";
				} else {
					print "<p>production mode - trapped fatal error</p>";
				}
                print "</body></html>";
			}
		#CGI::Carp::set_message(\&handle_errors);

use POSIX ();
use DateTime::TimeZone;
use Module::Load::Conditional qw(can_load);
use Data::Dumper;
use Carp;

use C4::Boolean;

#    file (/etc/koha/koha-conf.xml).
# dbh
#    A handle to the appropriate database for this context.
# dbh_stack
#    Used by &set_dbh and &restore_dbh to hold other database
#    handles for this context.
# Zconn
#     A connection object for the Zebra server

# Koha's main configuration file koha-conf.xml

# 1. Path supplied via use C4::Context '/path/to/koha-conf.xml'
# 2. Path supplied in KOHA_CONF environment variable.
# 3. Path supplied in INSTALLED_CONFIG_FNAME, as long
#    as value has changed from its default of
#    '__KOHA_CONF_DIR__/koha-conf.xml', as happens
#    when Koha is installed in 'standard' or 'single'
#    mode.


use constant CONFIG_FNAME => "/etc/koha/koha-conf.xml";
                # Default config file, if none is specified

my $INSTALLED_CONFIG_FNAME = '__KOHA_CONF_DIR__/koha-conf.xml';
                # path to config file set by installer
                # __KOHA_CONF_DIR__ is set by rewrite-confg.PL
                # when Koha is installed in 'standard' or 'single'
                # mode.  If Koha was installed in 'dev' mode,
                # __KOHA_CONF_DIR__ is *not* rewritten; instead
                # developers should set the KOHA_CONF environment variable

$context = undef;        # Initially, no context is set
@context_stack = ();        # Initially, no saved contexts


=head2 read_config_file

Reads the specified Koha config file. 

Returns an object containing the configuration variables. The object's
structure is a bit complex to the uninitiated ... take a look at the
koha-conf.xml file as well as the XML::Simple documentation for details. Or,
here are a few examples that may give you what you need:

@context_stack = ();     # Initially, no saved contexts

=head2 current

Returns the current context

    my $listen = $koha->{'listen'}->{'biblioserver'}->{'content'};

The elements nested within the <server> element:

    my $ccl2rpn = $koha->{'server'}->{'biblioserver'}->{'cql2rpn'};

Returns undef in case of error.

=cut

sub current {
    return $context;

    if ($ismemcached) {
      $memcached->set('kohaconf',$koha);
    }

    return $koha;			# Return value: ref-to-hash holding the configuration
}

=head2 ismemcached

    }
}

sub db_driver {
    my $self = shift;

    $self = $context unless ref ($self);
    return unless $self;

    return $self->{db_driver};
}

=head2 db_scheme2dbi

    my $dbd_driver_name = C4::Context::db_schema2dbi($scheme);

    # Create the default context ($C4::Context::Context)
    # the first time the module is called
    # (a config file can be optionaly passed)
    # If ":no_config" is passed, no config load will be attempted
    # Config file defaults to either the file given by the $KOHA_CONF
    # environment variable, or /etc/koha/koha-conf.xml.
    # It saves the context values in the declared memcached server(s)
    # if currently available and uses those values until them expire and
    # re-reads them.

    my ($pkg,$config_file) = @_ ;

    # default context already exists?
    return if $context;

    if ($ismemcached) {
        # retrieve from memcached
        if (my $self = $memcached->get('kohaconf')) {
            $context = $self;
            return;
        }
    }

    # check that the specified config file exists and is not empty
    undef $config_file if defined $config_file &&
        !( ref($config_file) || openhandle($config_file) || -s $config_file );
    # Figure out a good config file to load if none was specified.
    if (!defined($config_file))
    {
        # If the $KOHA_CONF environment variable is set, use
        # that. Otherwise, use the built-in default.
        if ($ENV{'KOHA_CONF'} and ref($ENV{'KOHA_CONF'}) || -s  $ENV{"KOHA_CONF"}) {
            $config_file = $ENV{"KOHA_CONF"};
        } elsif ($INSTALLED_CONFIG_FNAME !~ /__KOHA_CONF_DIR/ and -s $INSTALLED_CONFIG_FNAME) {
            # NOTE: be careful -- don't change __KOHA_CONF_DIR in the above
            # regex to anything else -- don't want installer to rewrite it
            $config_file = $INSTALLED_CONFIG_FNAME;
        } elsif (-s CONFIG_FNAME) {
            $config_file = CONFIG_FNAME;
        } else {
            die "unable to locate Koha configuration file koha-conf.xml";
        }
    }

    # no ? so load it!
    return if $config_file && $config_file eq ":no_config";
    my $new_ctx = __PACKAGE__->new($config_file);
    return unless $new_ctx;

    # if successfully loaded, use it by default
    $context = $new_ctx;

    if ($ismemcached) {
      $memcached->set('kohaconf',$new_ctx);
    }
}

use Scalar::Util qw(openhandle);
=head2 new

  $context = new C4::Context;
  $context = new C4::Context("/path/to/koha-conf.xml");

Allocates a new context. Initializes the context from the specified
file.
environment variable, or F</etc/koha/koha-conf.xml>.

XML structure is a bit complex to the uninitiated ... take a look at the
koha-conf.xml file as well as the XML::Simple documentation for details. Or,
here are a few examples that may give you what you need:

The simple elements nested within the <config> element:

    my $pass = $koha->{'config'}->{'pass'};

The <listen> elements:

    my $listen = $koha->{'listen'}->{'biblioserver'}->{'content'};

The elements nested within the <server> element:

    my $ccl2rpn = $koha->{'server'}->{'biblioserver'}->{'cql2rpn'};

Returns undef in case of error.

C<&new> does not set this context as the new default context; for
that, use C<&set_context>.

# 2004-08-10 A. Tarallo: Added check if the conf file is not empty
sub new {
    my $class = shift;
    my $conf_fname = shift or croak "No conf";
    my $namespace = shift;

    my $self = XMLin(
        $conf_fname,
        keyattr => ['id'],
        forcearray => ['listen', 'server', 'serverinfo'],
        suppressempty => '',
    );
    die "Invalid config ".(ref($conf_fname) ? $$conf_fname : $conf_fname).": ".Dumper($self)
      unless ref($self) && $self->{"config"};

    $self->{config_file} = $conf_fname;
    $self->{namespace} = $namespace;
    $self->{use_syspref_cache} = 1;
    $self->{syspref_cache} = Koha::Cache->new({namespace => $namespace});
            $conf_fname = $INSTALLED_CONFIG_FNAME;
        } elsif (-s CONFIG_FNAME) {
            $conf_fname = CONFIG_FNAME;
        } else {
            warn "unable to locate Koha configuration file koha-conf.xml";
            return;
        }
    }
    
    if ($ismemcached) {
        # retrieve from memcached
        $self = $memcached->get('kohaconf');
        if (not defined $self) {
            # not in memcached yet
            $self = read_config_file($conf_fname);
        }
    } else {
        # non-memcached env, read from file
        $self = read_config_file($conf_fname);
    }

    $self->{"config_file"} = $conf_fname;
    warn "read_config_file($conf_fname) returned undef" if !defined($self->{"config"});
    return if !defined($self->{"config"});

    $self->{"Zconn"} = undef;    # Zebra Connections
    $self->{"marcfromkohafield"} = undef; # the hash with relations between koha table fields and MARC field/subfield


=head2 set_context

  $context = new C4::Context;
  $context->set_context();
or
  set_context C4::Context $context;

    if (ref($self) eq "")
    {
        # Class method. The new context is the next argument.
        $new_context = shift or croak "No new context";
    } else {
        # Instance method. The new context is $self.
        $new_context = $self;
    }

    # undef $new_context->{schema} if $new_context->{schema} && !$new_context->{schema}->ping
    my $schema = $new_context->{schema} ||= Koha::Database->new_schema($new_context);

    # Save the old context on the stack
    push @context_stack, $context;

    # Set the new context
    $context = $new_context;
    Koha::Database->set_schema($schema);
}

=head2 restore_context

{
    my $self = shift;

    if ($#context_stack < 0)
    {
        # Stack underflow.
        die "Context stack underflow";
    }

    # Pop the old context and set it.
    $context = pop @context_stack;
    Koha::Database->restore_schema();

    # FIXME - Should this return something, like maybe the context
    # that was current when this was called?
}

=head2 run_within_context

  $context->run_within_context(sub {...});

Runs code within context

=cut

#'
sub run_within_context
{
    my $self = shift;
    my $code = shift or croak "No code";

    $self->set_context;

    local $@;
    my $ret = eval { $code->(@_) };
    my $died = $@;
    $self->restore_context;
    die $died if $died;
    return $ret;
}

=head2 config

  $value = C4::Context->config("config_variable");

=cut

sub _common_config {
    my $self = shift;
    my $var = shift;
    my $term = shift;

    $self = $context unless ref $self;
    return if !defined($self->{$term});
       # Presumably $self->{$term} might be
       # undefined if the config file given to &new
       # didn't exist, and the caller didn't bother
       # to check the return value.

    # Return the value of the requested config variable
    return $self->{$term}->{$var};
}

sub config {
    my $self = shift;
    return $self->_common_config($_[0],'config');
}
sub zebraconfig {
    my $self = shift;
    return $self->_common_config($_[0],'server');
}
sub ModZebrations {
    my $self = shift;
    return $self->_common_config($_[0],'serverinfo');
}

=head2 preference


=cut

my $syspref_cache = Koha::Cache->get_instance();
my $use_syspref_cache = 1;
sub preference {
    my $self = shift;
    $self = $context unless ref $self;
    my $var  = shift;    # The system preference to return

    $var = lc $var;

    return $ENV{"OVERRIDE_SYSPREF_$var"}
        if defined $ENV{"OVERRIDE_SYSPREF_$var"};

    my $cached_var = $self->{use_syspref_cache}
        ? $self->{syspref_cache}->get_from_cache("syspref_$var")
        : undef;
    return $cached_var if defined $cached_var;


    eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) };
    my $value = $syspref ? $syspref->value() : undef;

    if ( $self->{use_syspref_cache} ) {
        $self->{syspref_cache}->set_in_cache("syspref_$var", $value);
    }
    return $value;
}


sub enable_syspref_cache {
    my ($self) = @_;
    $self = $context unless ref $self;
    $self->{use_syspref_cache} = 1;
    # We need to clear the cache to have it up-to-date
    $self->clear_syspref_cache();
}


sub disable_syspref_cache {
    my ($self) = @_;
    $self = $context unless ref $self;
    $self->{use_syspref_cache} = 0;
    $self->clear_syspref_cache();
}


=cut

sub clear_syspref_cache {
    my ($self) = @_;
    $self = $context unless ref $self;
    return unless $self->{use_syspref_cache};
    $self->{syspref_cache}->flush_all;
}

=head2 set_preference


sub set_preference {
    my ( $self, $variable, $value, $explanation, $type, $options ) = @_;
    $self = $context unless ref $self;

    $variable = lc $variable;


        )->store();
    }

    if ( $self->{use_syspref_cache} ) {
        $self->{syspref_cache}->set_in_cache( "syspref_$variable", $value );
    }

    return $syspref;


sub delete_preference {
    my ( $self, $var ) = @_;
    $self = $context unless ref $self;

    if ( Koha::Config::SysPrefs->find( $var )->delete ) {
        if ( $self->{use_syspref_cache} ) {
            $self->{syspref_cache}->clear_from_cache("syspref_$var");
        }

        return 1;


Returns a connection to the Zebra database

C<$self>

C<$server> one of the servers defined in the koha-conf.xml file



This database handle is cached for future use: if you call
C<C4::Context-E<gt>dbh> twice, you will get the same handle both
times. If you need a second database handle, use C<&new_dbh>.
possibly C<&set_dbh>.

=cut


    return &dbh({ new => 1 });
}

=head2 set_dbh

  $my_dbh = C4::Connect->new_dbh;
  C4::Connect->set_dbh($my_dbh);
  ...
  C4::Connect->restore_dbh;

C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
C<&set_context> and C<&restore_context>.

C<&set_dbh> saves the current database handle on a stack, then sets
the current database handle to C<$my_dbh>.

C<$my_dbh> is assumed to be a good database handle.

=cut

#'
sub set_dbh
{
    my $self = shift;
    my $new_dbh = shift;

    # Save the current database handle on the handle stack.
    # We assume that $new_dbh is all good: if the caller wants to
    # screw himself by passing an invalid handle, that's fine by
    # us.
    push @{$context->{"dbh_stack"}}, $context->{"dbh"};
    $context->{"dbh"} = $new_dbh;
}

=head2 restore_dbh

  C4::Context->restore_dbh;

Restores the database handle saved by an earlier call to
C<C4::Context-E<gt>set_dbh>.

=cut

#'
sub restore_dbh
{
    my $self = shift;

    if ($#{$context->{"dbh_stack"}} < 0)
    {
        # Stack underflow
        die "DBH stack underflow";
    }

    # Pop the old database handle and set it.
    $context->{"dbh"} = pop @{$context->{"dbh_stack"}};

    # FIXME - If it is determined that restore_context should
    # return something, then this function should, too.
}

=head2 queryparser

  $queryparser = C4::Context->queryparser




    $value = clone( $value ) if ref($value) and not $unsafe;

    # Set in L1 cache
    $L1_cache{ $self->{namespace} }{ $key } = $value;

    # We consider an expiry of 0 to be inifinite
    if ( $expiry ) {

    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );

    # Return L1 cache value if exists
    if ( exists $L1_cache{ $self->{namespace} }{ $key } ) {
        # No need to deep copy if it's a scalar
        # Or if we do not need to deep copy
        return $L1_cache{ $self->{namespace} }{ $key }
            if not ref $L1_cache{ $self->{namespace} }{ $key } or $unsafe;
        return clone $L1_cache{ $self->{namespace} }{ $key };
    }

    my $get_sub = $self->{ref($self->{$cache}) . "_get"};

    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );

    # Clear from L1 cache
    delete $L1_cache{ $self->{namespace} }{ $key };

    return $self->{$cache}->delete($key)
      if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );


sub flush_L1_cache {
    my( $self ) = @_;
    delete $L1_cache{ $self->{namespace} };
}

=head1 TIED INTERFACE




# database connection from the data given in the current context, and
# returns it.
sub _new_schema {
    my $context = shift || C4::Context->current();

    my $db_driver = $context->db_driver;

    my $db_driver = $context->{db_driver};

    my $db_name   = $context->config("database");
    my $db_host   = $context->config("hostname");

        return $database->{schema} if defined $database->{schema};
    }

    $database->{schema} = &_new_schema($params->{context});
    return $database->{schema};
}

=head2 new_schema

  $schema = $database->new_schema($context);

Creates a new connection to the Koha database for the context
(current is default), and returns the database handle (a C<DBI::db> object).

The handle is not saved anywhere: this method is strictly a
convenience function; the point is that it knows which database to

sub new_schema {
    my $self = shift;

    return &_new_schema(@_);
}

=head2 set_schema

    # return something, then this function should, too.
}

=head2 run_with_schema

  $database->run_with_schema( $schema, sub {...} );

Restores the database handle saved by an earlier call to
C<$database-E<gt>set_schema> C<$database-E<gt>restore_schema> wrapper.

=cut

sub run_with_schema {
    my $self = shift;
    my $schema = shift or croak "No schema";
    my $code = shift or croak "No sub";

    $self->set_schema;
    local $@;
    my $ret = eval { $code->(@_) };
    my $died = $@;
    $self->restore_schema;
    die $died if $died;
    return $ret;
}

=head2 EXPORT

None by default.




package Koha::Handler::Plack;

# Copyright (c) 2016 Catalyst IT
#
# This file is part of Koha.
#
# Koha is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License as published by the Free Software
# Foundation; either version 2 of the License, or (at your option) any later
# version.
#
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along with
# Koha; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

=head1 NAME

  Koha::Handler::Plack - Plack helper

=head1 SYNOPSIS

  koha.psgi:
  use Koha::Handler::Plack;

  my %HOST_CONF = (
      'koha1.com' => { ...  },
      'koha2.com' => { ...  },
      ...
  );
  # last line
  Koha::Handler::Plack->app_per_host(\%HOST_CONF);

  See C<app_per_host()> below

=head1 DESCRIPTION

  Some handy function to help with Koha/Plack in a multi-host situation.

  The problem:
  Koha app relies on env vars. This should be changed, ie C4::Context should
  be upgraded to Koha::App, but until then we need a gap filler. That's
  because once up, there's no way to pass on new env to a psgi container.
  In Apache, for instance, we can specify env vars per virtual host. Plack
  has no such concept.

  Solution:
  We need to modify the environment in situ, per virtual host - app_per_host().
  We specify env for each hostname, and apply.

=cut

use Modern::Perl;
use Carp;

use Plack::App::URLMap;

=head1 CLASS METHODS

=head2 app_per_host($host_apps)

  App wrapper for per virtual host scenario.

  C<$host_apps>:
      {
          hostname => 'koha1.com',
          app => $app1,
          context => $context1,
      },
      {
          hostname => ['koha2.com', 'www.koha2.com'],
          app => $app2,
          context => $context2,
      },
      ...

  C<hostname> is mandatory.

  koha.psgi:

  use Plack::Builder;
  use Plack::App::CGIBin;

  use C4::Context;

  my $opac_app = builder {
      enable "Plack::Middleware::Static",
              path => qr{^/opac-tmpl/}, root => '/usr/share/koha/opac/htdocs/';

      enable 'StackTrace';
      mount "/cgi-bin/koha" => Plack::App::CGIBin->new(root => "/usr/share/koha/opac/cgi-bin/opac");
  };
  my $intranet_app = builder {
      enable "Plack::Middleware::Static",
              path => qr{^/intranet-tmpl/}, root => '/usr/share/koha/intranet/htdocs/';

      enable 'StackTrace';
      mount "/cgi-bin/koha" => Plack::App::CGIBin->new(root => "/usr/share/koha/cgi-bin");
  };

  my @host_def;

  my $conf_file_1 = "/etc/koha/site-1/koha_conf.xml";
  my $context_1 = C4::Context->new($conf_file_1);
  push @host_def,
      {
          hostname => [ "public.host.for.site-1", "www.public.host.for.site-1" ],
          app => $opac_app,
          context => $context_1,
      },
      {
          hostname => "intranet.host.for.site-1",
          app => $intranet_app,
          context => $context_1,
      };

  my $conf_file_2 = "/etc/koha/site-1/koha_conf.xml";
  my $context_2 = C4::Context->new($conf_file_2);
  push @host_def,
      {
          hostname => "public.host.for.site-2",
          app => $opac_app,
          context => $context_2,
      },
      {
          hostname => "intranet.host.for.site-2",
          app => $intranet_app,
          context => $context_2,
      };

  ...

  Koha::Handler::Plack->app_per_host( \@host_def );

=cut

sub app_per_host {
    my $class = shift;
    my $sites = shift or die "No sites spec";

    my $map = Plack::App::URLMap->new;
    foreach my $site_params ( @$sites ) {
        my $hosts = $site_params->{hostname} or croak "No hostname";
        $hosts = [$hosts] unless ref $hosts;

        my $app = $site_params->{app} or croak "No app";
        my $context = $site_params->{context} or croak "No Koha Context";

        foreach my $host (@$hosts) {
            $map->map("http://$host/" => sub {
                my $env = shift;

                return $context->run_within_context(sub { $app->($env) });
            });
        }
    }
    return $map->to_app;
}

1;




package Koha::Handler::Plack::CGI;

# Copyright (c) 2016 Catalyst IT
#
# This file is part of Koha.
#
# Koha is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License as published by the Free Software
# Foundation; either version 2 of the License, or (at your option) any later
# version.
#
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along with
# Koha; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

=head1 NAME

  Koha::Handler::Plack::CGI - Plack helper for CGI scripts

=head1 SYNOPSIS

  koha.psgi:
  use Koha::Handler::Plack::CGI;

  my %koha_env = (
      opac => {
          static_root => '/usr/share/koha/opac/htdocs',
          script_root => '/usr/share/koha/opac',
      },
      intranet => {
          static_root => '/usr/share/koha/intranet/htdocs',
          script_root => '/usr/share/koha/intranet'
      }
  );
  my @sites = (
      {
          opac_hostname => 'koha1-opac.com',
          intranet_hostname => 'koha1-intranet.com',
          config = '/etc/koha/koha1/koha-conf.xml'
      },
      {
          opac_hostname => ['opac.koha2.com', 'www.opackoha2.com'],
          intranet_hostname => ['intranet.koha2.com', 'www.intranetkoha2.com'],
          config = '/etc/koha/koha2/koha-conf.xml'
      },
  );

  # last line
  Koha::Handler::Plack::CGI->app_per_host(\%HOST_CONF);

  See C<app_per_host()> below

=head1 DESCRIPTION

  CGI script runner.

  One beautiful day wiwill move away from that and have proper App module
  with router and handlers</dream>

  See C<Koha::Handler::Plack>

=cut

use Modern::Perl;
use Carp;

use Plack::Builder;
use Plack::App::CGIBin;

use parent "Koha::Handler::Plack";

use C4::Context;

=head1 CLASS METHODS

=head2 app($context, $env)

  Plack app builder fora CGI app

  C<$context>: "opac" or "intranet"
  C<$env>:
      {
          static_root => '...',
          script_root => '...',
          pugins => [
              [ 'StackTrace' ],
              ...
          ],
      }

  koha.psgi:

  Koha::Handler::Plack::CGI->app( "opac", \%opac_app_env );

=cut

sub app {
    my $class = shift;
    my $context = shift;
    croak "Invalid app context '$context' - must be 'opac' or 'intranet'"
      unless $context =~ m/^(opac|intranet)$/;
    my $env = shift or croak "No $context env details";

    my $static_root = $env->{static_root} or croak "No $context static_root";
    $static_root = "$static_root/" unless $static_root =~ m!/$!;
    my $script_root = $env->{script_root} or croak "No $context script_root";
    $script_root =~ s!/$!!;
    my $plugins = $env->{plugins} || [];
    my $is_intranet = $context eq "intranet";

    builder {
        enable "Plack::Middleware::Static",
                path => qr{^/$context-tmpl/}, root => $static_root;

        map enable(@$_), @$plugins;

        mount "/cgi-bin/koha" => Plack::App::CGIBin->new(root => $script_root)->to_app;
        mount "/" => sub {
            return [ 302, [ Location => '/cgi-bin/koha/' . ( $is_intranet ? 'mainpage.pl' : 'opac-main.pl' ) ], [] ];
        };
    };
}

=head2 multi_site($env, $sites)

  App wrapper for per virtual host scenario.

  C<$env>:
      {
          opac => {
              static_root => '/usr/share/koha/opac/htdocs',
              script_root => '/usr/share/koha/opac/cgi-bin/opac',
              pugins => [
                  [ 'StackTrace' ],
              ],
          },
          intranet => {
              static_root => '/usr/share/koha/intranet/htdocs',
              script_root => '/usr/share/koha/cgi-bin'
          }
      }
  C<$sites>:
      {
          namespace => 'koha1',
          opac_hostname => 'koha1-opac.com',
          intranet_hostname => 'koha1-intranet.com',
          config => '/etc/koha/sites/koha1/koha-conf.xml',
          shared_config => 1
      },
      {
          namespace => 'koha2',
          opac_hostname => ['opac.koha2.com', 'www.opackoha2.com'],
          intranet_hostname => ['intranet.koha2.com', 'www.intranetkoha2.com'],
          config => '/etc/koha/sites/koha2/koha-conf.xml'
      },
      ...

  koha.psgi:

  Koha::Handler::Plack::CGI->multi_site( \%koha_app_env, \@sites );

=cut

my $DUMMY_KOHA_CONF = "<yazgfs><config>DUMMY</config></yazgfs>";
sub multi_site {
    my $class = shift;
    my $env = shift or croak "No Koha env details";
    my $sites = shift or croak "No sites spec";

    my ($opac_app, $intranet_app);

    if (my $opac = $env->{opac}) {
        $opac_app = $class->app('opac', $opac);
    }

    if (my $intranet = $env->{intranet}) {
        $intranet_app = $class->app('intranet', $intranet);
    }

    my @host_def = map {
        my $namespace      = $_->{namespace} or croak "No namespace";
        my $config         = $_->{config}    or croak "Site without config";
        my $shared_context = $_->{shared_context};

        my $context = C4::Context->new($config, $namespace);

        my @hd;
        if (my $hostname = $_->{opac_hostname}) {
            croak "You have OPAC hosts without OPAC env details" unless $opac_app;
            push @hd, {
                hostname => $hostname,
                app => sub {
                    # XXX this may need some rethinking
                    local $ENV{KOHA_CONF} = \$DUMMY_KOHA_CONF;
                    local $ENV{MEMCACHED_NAMESPACE} = $namespace;

                    $opac_app->(@_);
                },
                context => $context,
                shared_context => $shared_context,
            };
        }
        if (my $hostname = $_->{intranet_hostname}) {
            croak "You have Intranet hosts without Intranet env details" unless $intranet_app;
            push @hd, {
                hostname => $hostname,
                app => sub {
                    # XXX this may need some rethinking
                    local $ENV{KOHA_CONF} = \$DUMMY_KOHA_CONF;
                    local $ENV{MEMCACHED_NAMESPACE} = $namespace;

                    $intranet_app->(@_);
                },
                context => $context,
                shared_context => $shared_context,
            };
        }
        @hd;
    } @$sites;

    return $class->app_per_host( \@host_def );
}

1;

Lines 92-98 my $warnIsRootUser = (! $loggedinuser); Link Here

(-)a/about.pl (-1 / +1 lines)
92	my $warnNoActiveCurrency = (! defined Koha::Acquisition::Currencies->get_active);	92	my $warnNoActiveCurrency = (! defined Koha::Acquisition::Currencies->get_active);
93	my @xml_config_warnings;	93	my @xml_config_warnings;
94		94
95	my $context = new C4::Context;	95	my $context = C4::Context->current;
96		96
97	if ( ! defined C4::Context->config('zebra_bib_index_mode') ) {	97	if ( ! defined C4::Context->config('zebra_bib_index_mode') ) {
98	push @xml_config_warnings, {	98	push @xml_config_warnings, {

Lines 387-393 output_html_with_http_headers $input, $cookie, $template->output; Link Here

(-)a/admin/systempreferences.pl (-1 / +1 lines)
387	# .pref files.	387	# .pref files.
388		388
389	sub get_prefs_from_files {	389	sub get_prefs_from_files {
390	my $context = C4::Context->new();	390	my $context = C4::Context->current();
391	my $path_pref_en = $context->config('intrahtdocs') .	391	my $path_pref_en = $context->config('intrahtdocs') .
392	'/prog/en/modules/admin/preferences';	392	'/prog/en/modules/admin/preferences';
393	# Get all .pref file names	393	# Get all .pref file names

Lines 190-196 sub check_all_url { Link Here

(-)a/misc/cronjobs/check-url.pl (-1 / +1 lines)
190	my $checker = C4::URL::Checker->new($timeout,$agent);	190	my $checker = C4::URL::Checker->new($timeout,$agent);
191	$checker->{ host_default } = $host;	191	$checker->{ host_default } = $host;
192		192
193	my $context = new C4::Context( );	193	my $context = C4::Context->current();
194	my $dbh = $context->dbh;	194	my $dbh = $context->dbh;
195	my $sth = $dbh->prepare(	195	my $sth = $dbh->prepare(
196	"SELECT biblionumber FROM biblioitems WHERE url <> ''" );	196	"SELECT biblionumber FROM biblioitems WHERE url <> ''" );




#!/usr/bin/perl

# This is a minimal example. You can include all frills from koha.psgi
# To try it:
# plackup -I /usr/share/koha/lib --port 5010 koha-multi.psgi

my %KOHA_ENV = (
  opac => {
      static_root => '/usr/share/koha/opac/htdocs',
      script_root => '/usr/share/koha/opac/cgi-bin/opac',
      pugins => [
	# don't enable this plugin in production, since stack traces reveal too much information
	# about system to potential attackers!
          [ 'StackTrace' ],
      ],
  },
  intranet => {
      static_root => '/usr/share/koha/intranet/htdocs',
      script_root => '/usr/share/koha/intranet/cgi-bin',
  }
);
my @SITES = map {
    namespace => $_,
    opac_hostname => "opac.$_.my-koha-multisite.net",
    intranet_hostname => "intranet.$_.my-koha-multisite.net",
    config => "/etc/koha/sites/$_/koha-conf.xml"
}, qw(koha1 koha2 koha3);

Koha::Handler::Plack::CGI->multi_site( \%KOHA_ENV, \@SITES );

Lines 56-62 sub new { Link Here

(-)a/misc/translator/LangInstaller.pm (-2 / +2 lines)
56		56
57	my $self = { };	57	my $self = { };
58		58
59	my $context = C4::Context->new();	59	my $context = C4::Context->current();
60	$self->{context} = $context;	60	$self->{context} = $context;
61	$self->{path_pref_en} = $context->config('intrahtdocs') .	61	$self->{path_pref_en} = $context->config('intrahtdocs') .
62	'/prog/en/modules/admin/preferences';	62	'/prog/en/modules/admin/preferences';
Lines 140-146 sub new { Link Here
140	sub po_filename {	140	sub po_filename {
141	my $self = shift;	141	my $self = shift;
142		142
143	my $context = C4::Context->new;	143	my $context = C4::Context->current();
144	my $trans_path = $Bin . '/po';	144	my $trans_path = $Bin . '/po';
145	my $trans_file = "$trans_path/" . $self->{lang} . "-pref.po";	145	my $trans_file = "$trans_path/" . $self->{lang} . "-pref.po";
146	return $trans_file;	146	return $trans_file;




#!/usr/bin/perl

use Test::More tests => 15;
use Plack::Test;
use Plack::Test::MockHTTP;
use Test::Mock::LWP::Dispatch;
use Test::MockModule;
use HTTP::Request::Common;
use FindBin qw($Bin);
use Data::Dumper;

use_ok("Koha::Handler::Plack");
use_ok("Koha::Handler::Plack::CGI");

use C4::Context;

my $db = Test::MockModule->new('Koha::Database');
$db->mock(
    _new_schema => sub {
        return $_[0];
    }
);

sub make_response {
    return join ";", map defined($_) ? $_ : "", @_;
}
sub dummy_val {
    return C4::Context->config("dummy");
}
sub check_context {
    my $dummy_val = dummy_val();
    is $dummy_val, undef, "context preserved"
      or diag("dummy val: $dummy_val");
}

my $app = sub {
    return [
        200,
        [ 'Content-Type' => 'text/plain' ],
        [ make_response(dummy_val()) ]
    ];
};
my $generic_url = "http://dummyhost.com/";

my $KOHA_CONF_XML = <<EOS;
<yazgfs>
    <config>
        <kohasite>test</kohasite>
        <dummy>XML</dummy>
        <intrahtdocs>.</intrahtdocs>
    </config>
</yazgfs>
EOS

my @HOST_CONF = (
    {
        hostname => ['koha-file.com', 'www.koha-file.com'],
        app => $app,
        context => C4::Context->new("$Bin/conf/koha1/koha-conf.xml"),
        _dummy => "KOHA1"
    },
    {
        hostname => ['koha-xml.com', 'www.koha-xml.com'],
        app => $app,
        context => C4::Context->new(\$KOHA_CONF_XML),
        _dummy => "XML"
    },
);
test_psgi
    app => Koha::Handler::Plack->app_per_host(\@HOST_CONF),
    client => sub {
        my $cb  = shift;

        foreach my $site_params ( @HOST_CONF ) {
            my $valid_response = make_response(
                $site_params->{_dummy}
            );
            foreach (@{$site_params->{hostname}}) {
                my $res = $cb->(GET "http://$_/");
                is $res->content, $valid_response, $_
                  or diag(Dumper($site_params, $_, $res->as_string));
                check_context();
            }
        }

        $res = $cb->(GET $generic_url);
        is $res->code, 404, "app_per_host unknown host"
          or diag($res->as_string);
    };

my %MULTI_HOST_ENV = (
    opac => {
        static_root => "$Bin/../koha-tmpl/opac-tmpl/bootstrap",
        script_root => "$Bin/../opac",
    },
    intranet => {
        static_root => "$Bin/../koha-tmpl/intranet-tmpl/bootstrap",
        script_root => "$Bin/.."
    }
);
my @MULTI_HOST_SITES = (
    {
        namespace => 'koha1',
        opac_hostname => ['opac.koha1.com', 'www.opac.koha1.com'],
        intranet_hostname => ['intranet.koha1.com', 'www.intranet.koha1.com'],
        config => "$Bin/conf/koha1/koha-conf.xml",
    },
    {
        namespace => 'koha2',
        opac_hostname => ['opac.koha2.com', 'www.opac.koha2.com'],
        intranet_hostname => ['intranet.koha2.com', 'www.intranet.koha2.com'],
        config => "$Bin/conf/koha2/koha-conf.xml",
        shared_context => 1,
    },
);
test_psgi
    app => Koha::Handler::Plack::CGI->multi_site(\%MULTI_HOST_ENV, \@MULTI_HOST_SITES),
    client => sub {
        my $cb  = shift;

        foreach my $site (@MULTI_HOST_SITES) {
            my $opac = $site->{opac_hostname};
            foreach my $host (@$opac) {
# this is not really a test, but cannot do any better atm
# TODO: a complex test involving two database connections
                my $res = $cb->(GET "http://$host/");
                # A future implementation may not redirect
                if ($res->is_redirect) {
                    my $loc = $res->header("Location");
                    $res = $cb->(GET "http://$host$loc");
                }
                is $res->code, 500, "multi_site() $host"
                  or diag($res->as_string);
            }
        }
    };

Line 0 Link Here

(-)a/t/conf/dummy/koha-conf.xml (+7 lines)
	1	<yazgfs>
	2	<config>
	3	<kohasite>dummy</kohasite>
	4	<dummy>DUMMY</dummy>
	5	<intrahtdocs>.</intrahtdocs>
	6	</config>
	7	</yazgfs>

Line 0 Link Here

(-)a/t/conf/koha1/koha-conf.xml (+7 lines)
	1	<yazgfs>
	2	<config>
	3	<kohasite>koha1</kohasite>
	4	<dummy>KOHA1</dummy>
	5	<intrahtdocs>.</intrahtdocs>
	6	</config>
	7	</yazgfs>

Line 0 Link Here

(-)a/t/conf/koha2/koha-conf.xml (+5 lines)
	1	<yazgfs>
	2	<config>
	3	<dummy>KOHA2</dummy>
	4	</config>
	5	</yazgfs>

Lines 14-20 BEGIN { Link Here

(-)a/t/db_dependent/Amazon.t (-1 / +1 lines)
14	use_ok('C4::External::Amazon');	14	use_ok('C4::External::Amazon');
15	}	15	}
16		16
17	my $context = C4::Context->new();	17	my $context = C4::Context->current();
18		18
19	my $locale = $context->preference('AmazonLocale');	19	my $locale = $context->preference('AmazonLocale');
20		20

Lines 47-53 C4::Context->clear_syspref_cache(); Link Here

(-)a/t/db_dependent/Context.t (-1 / +1 lines)
47	C4::Context->enable_syspref_cache();	47	C4::Context->enable_syspref_cache();
48	$dbh->rollback;	48	$dbh->rollback;
49		49
50	ok($koha = C4::Context->new, 'C4::Context->new');	50	ok($koha = C4::Context->current, 'C4::Context->current');
51	my @keys = keys %$koha;	51	my @keys = keys %$koha;
52	my $width = 0;	52	my $width = 0;
53	if (ok(@keys)) {	53	if (ok(@keys)) {

Lines 14-20 BEGIN { Link Here

(-)a/t/db_dependent/Template/Plugin/KohaDates.t (-1 / +1 lines)
14	my $module_context = new Test::MockModule('C4::Context');	14	my $module_context = new Test::MockModule('C4::Context');
15		15
16	my $date = "1973-05-21";	16	my $date = "1973-05-21";
17	my $context = C4::Context->new();	17	my $context = C4::Context->current();
18		18
19	my $filter = Koha::Template::Plugin::KohaDates->new();	19	my $filter = Koha::Template::Plugin::KohaDates->new();
20	ok ($filter, "new()");	20	ok ($filter, "new()");

Lines 26-32 my $search_module = new Test::MockModule('C4::Search'); Link Here

(-)a/t/db_dependent/XISBN.t (-1 / +1 lines)
26		26
27	$search_module->mock('SimpleSearch', \&Mock_SimpleSearch );	27	$search_module->mock('SimpleSearch', \&Mock_SimpleSearch );
28		28
29	my $context = C4::Context->new;	29	my $context = C4::Context->current;
30		30
31	my ( $biblionumber_tag, $biblionumber_subfield ) =	31	my ( $biblionumber_tag, $biblionumber_subfield ) =
32	GetMarcFromKohaField( 'biblio.biblionumber', '' );	32	GetMarcFromKohaField( 'biblio.biblionumber', '' );




# along with Koha; if not, see <http://www.gnu.org/licenses>.

use Modern::Perl;
use Test::More tests => 11;
use C4::Context;

# Start transaction

C4::Context->clear_syspref_cache();
is(C4::Context->preference('testpreference'), undef, 'clearing preference cache');

delete $ENV{OVERRIDE_SYSPREF_opacheader};

my $DUMMY_KOHA_CONF = "<yazgfs><config><dummy>DUMMY</dummy></config></yazgfs>";
my $context1 = C4::Context->new($DUMMY_KOHA_CONF, "context1");
is( $context1->preference('opacheader'), $opacheader, 'context1 "opacheader"');

my $context2 = C4::Context->new($DUMMY_KOHA_CONF, "context2");
$context2->set_preference( 'opacheader', $newopacheader );
is( $context1->preference('opacheader'), $opacheader, 'context1 "opacheader"');
is( $context2->preference('opacheader'), $newopacheader, 'context2 "opacheader"');

$dbh->rollback;
- 

Return to bug 15562

Lines 286-292 sub set_in_cache { Link Here

(-)a/Koha/Cache.pm (-7 / +7 lines)
286	$value = clone( $value ) if ref($value) and not $unsafe;	286	$value = clone( $value ) if ref($value) and not $unsafe;
287		287
288	# Set in L1 cache	288	# Set in L1 cache
289	$L1_cache{ $key } = $value;	289	$L1_cache{ $self->{namespace} }{ $key } = $value;
290		290
291	# We consider an expiry of 0 to be inifinite	291	# We consider an expiry of 0 to be inifinite
292	if ( $expiry ) {	292	if ( $expiry ) {
Lines 337-348 sub get_from_cache { Link Here
337	return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );	337	return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
338		338
339	# Return L1 cache value if exists	339	# Return L1 cache value if exists
340	if ( exists $L1_cache{$key} ) {	340	if ( exists $L1_cache{ $self->{namespace} }{ $key } ) {
341	# No need to deep copy if it's a scalar	341	# No need to deep copy if it's a scalar
342	# Or if we do not need to deep copy	342	# Or if we do not need to deep copy
343	return $L1_cache{$key}	343	return $L1_cache{ $self->{namespace} }{ $key }
344	if not ref $L1_cache{$key} or $unsafe;	344	if not ref $L1_cache{ $self->{namespace} }{ $key } or $unsafe;
345	return clone $L1_cache{$key};	345	return clone $L1_cache{ $self->{namespace} }{ $key };
346	}	346	}
347		347
348	my $get_sub = $self->{ref($self->{$cache}) . "_get"};	348	my $get_sub = $self->{ref($self->{$cache}) . "_get"};
Lines 373-379 sub clear_from_cache { Link Here
373	return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );	373	return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
374		374
375	# Clear from L1 cache	375	# Clear from L1 cache
376	delete $L1_cache{$key};	376	delete $L1_cache{ $self->{namespace} }{ $key };
377		377
378	return $self->{$cache}->delete($key)	378	return $self->{$cache}->delete($key)
379	if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );	379	if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
Lines 402-408 sub flush_all { Link Here
402		402
403	sub flush_L1_cache {	403	sub flush_L1_cache {
404	my( $self ) = @_;	404	my( $self ) = @_;
405	%L1_cache = ();	405	delete $L1_cache{ $self->{namespace} };
406	}	406	}
407		407
408	=head1 TIED INTERFACE	408	=head1 TIED INTERFACE

Lines 47-56 __PACKAGE__->mk_accessors(qw( )); Link Here

(-)a/Koha/Database.pm (-8 / +30 lines)
47	# database connection from the data given in the current context, and	47	# database connection from the data given in the current context, and
48	# returns it.	48	# returns it.
49	sub _new_schema {	49	sub _new_schema {
		50	my $context = shift \|\| C4::Context->current();
50		51
51	my $context = C4::Context->new();	52	my $db_driver = $context->db_driver;
52
53	my $db_driver = $context->{db_driver};
54		53
55	my $db_name = $context->config("database");	54	my $db_name = $context->config("database");
56	my $db_host = $context->config("hostname");	55	my $db_host = $context->config("hostname");
Lines 122-137 sub schema { Link Here
122	return $database->{schema} if defined $database->{schema};	121	return $database->{schema} if defined $database->{schema};
123	}	122	}
124		123
125	$database->{schema} = &_new_schema();	124	$database->{schema} = &_new_schema($params->{context});
126	return $database->{schema};	125	return $database->{schema};
127	}	126	}
128		127
129	=head2 new_schema	128	=head2 new_schema
130		129
131	$schema = $database->new_schema;	130	$schema = $database->new_schema($context);
132		131
133	Creates a new connection to the Koha database for the current context,	132	Creates a new connection to the Koha database for the context
134	and returns the database handle (a C<DBI::db> object).	133	(current is default), and returns the database handle (a C<DBI::db> object).
135		134
136	The handle is not saved anywhere: this method is strictly a	135	The handle is not saved anywhere: this method is strictly a
137	convenience function; the point is that it knows which database to	136	convenience function; the point is that it knows which database to
Lines 143-149 connect to so that the caller doesn't have to know. Link Here
143	sub new_schema {	142	sub new_schema {
144	my $self = shift;	143	my $self = shift;
145		144
146	return &_new_schema();	145	return &_new_schema(@_);
147	}	146	}
148		147
149	=head2 set_schema	148	=head2 set_schema
Lines 200-205 sub restore_schema { Link Here
200	# return something, then this function should, too.	199	# return something, then this function should, too.
201	}	200	}
202		201
		202	=head2 run_with_schema
		203
		204	$database->run_with_schema( $schema, sub {...} );
		205
		206	Restores the database handle saved by an earlier call to
		207	C<$database-E<gt>set_schema> C<$database-E<gt>restore_schema> wrapper.
		208
		209	=cut
		210
		211	sub run_with_schema {
		212	my $self = shift;
		213	my $schema = shift or croak "No schema";
		214	my $code = shift or croak "No sub";
		215
		216	$self->set_schema;
		217	local $@;
		218	my $ret = eval { $code->(@_) };
		219	my $died = $@;
		220	$self->restore_schema;
		221	die $died if $died;
		222	return $ret;
		223	}
		224
203	=head2 EXPORT	225	=head2 EXPORT
204		226
205	None by default.	227	None by default.

Line 0 Link Here

(-)a/Koha/Handler/Plack.pm (+163 lines)
		1	package Koha::Handler::Plack;
		2
		3	# Copyright (c) 2016 Catalyst IT
		4	#
		5	# This file is part of Koha.
		6	#
		7	# Koha is free software; you can redistribute it and/or modify it under the
		8	# terms of the GNU General Public License as published by the Free Software
		9	# Foundation; either version 2 of the License, or (at your option) any later
		10	# version.
		11	#
		12	# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
		13	# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
		14	# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
		15	#
		16	# You should have received a copy of the GNU General Public License along with
		17	# Koha; if not, write to the Free Software Foundation, Inc.,
		18	# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
		19
		20	=head1 NAME
		21
		22	Koha::Handler::Plack - Plack helper
		23
		24	=head1 SYNOPSIS
		25
		26	koha.psgi:
		27	use Koha::Handler::Plack;
		28
		29	my %HOST_CONF = (
		30	'koha1.com' => { ... },
		31	'koha2.com' => { ... },
		32	...
		33	);
		34	# last line
		35	Koha::Handler::Plack->app_per_host(\%HOST_CONF);
		36
		37	See C<app_per_host()> below
		38
		39	=head1 DESCRIPTION
		40
		41	Some handy function to help with Koha/Plack in a multi-host situation.
		42
		43	The problem:
		44	Koha app relies on env vars. This should be changed, ie C4::Context should
		45	be upgraded to Koha::App, but until then we need a gap filler. That's
		46	because once up, there's no way to pass on new env to a psgi container.
		47	In Apache, for instance, we can specify env vars per virtual host. Plack
		48	has no such concept.
		49
		50	Solution:
		51	We need to modify the environment in situ, per virtual host - app_per_host().
		52	We specify env for each hostname, and apply.
		53
		54	=cut
		55
		56	use Modern::Perl;
		57	use Carp;
		58
		59	use Plack::App::URLMap;
		60
		61	=head1 CLASS METHODS
		62
		63	=head2 app_per_host($host_apps)
		64
65	App wrapper for per virtual host scenario.
66
67	C<$host_apps>:
68	{
69	hostname => 'koha1.com',
70	app => $app1,
71	context => $context1,
72	},
73	{
74	hostname => ['koha2.com', 'www.koha2.com'],
75	app => $app2,
76	context => $context2,
77	},
78	...
79
80	C<hostname> is mandatory.
81
82	koha.psgi:
83
84	use Plack::Builder;
85	use Plack::App::CGIBin;
86
87	use C4::Context;
88
89	my $opac_app = builder {
90	enable "Plack::Middleware::Static",
91	path => qr{^/opac-tmpl/}, root => '/usr/share/koha/opac/htdocs/';
92
93	enable 'StackTrace';
94	mount "/cgi-bin/koha" => Plack::App::CGIBin->new(root => "/usr/share/koha/opac/cgi-bin/opac");
95	};
96	my $intranet_app = builder {
97	enable "Plack::Middleware::Static",
98	path => qr{^/intranet-tmpl/}, root => '/usr/share/koha/intranet/htdocs/';
99
100	enable 'StackTrace';
101	mount "/cgi-bin/koha" => Plack::App::CGIBin->new(root => "/usr/share/koha/cgi-bin");
102	};
103
104	my @host_def;
105
106	my $conf_file_1 = "/etc/koha/site-1/koha_conf.xml";
107	my $context_1 = C4::Context->new($conf_file_1);
108	push @host_def,
109	{
110	hostname => [ "public.host.for.site-1", "www.public.host.for.site-1" ],
111	app => $opac_app,
112	context => $context_1,
113	},
114	{
115	hostname => "intranet.host.for.site-1",
116	app => $intranet_app,
117	context => $context_1,
118	};
119
120	my $conf_file_2 = "/etc/koha/site-1/koha_conf.xml";
121	my $context_2 = C4::Context->new($conf_file_2);
122	push @host_def,
123	{
124	hostname => "public.host.for.site-2",
125	app => $opac_app,
126	context => $context_2,
127	},
128	{
129	hostname => "intranet.host.for.site-2",
130	app => $intranet_app,
131	context => $context_2,
132	};
133
134	...
135
136	Koha::Handler::Plack->app_per_host( \@host_def );
137
138	=cut
139
140	sub app_per_host {
141	my $class = shift;
142	my $sites = shift or die "No sites spec";
143
144	my $map = Plack::App::URLMap->new;
145	foreach my $site_params ( @$sites ) {
146	my $hosts = $site_params->{hostname} or croak "No hostname";
147	$hosts = [$hosts] unless ref $hosts;
148
149	my $app = $site_params->{app} or croak "No app";
150	my $context = $site_params->{context} or croak "No Koha Context";
151
152	foreach my $host (@$hosts) {
153	$map->map("http://$host/" => sub {
154	my $env = shift;
155
156	return $context->run_within_context(sub { $app->($env) });
157	});
158	}
159	}
160	return $map->to_app;
161	}
162
163	1;

Line 0 Link Here

(-)a/Koha/Handler/Plack/CGI.pm (+228 lines)
		1	package Koha::Handler::Plack::CGI;
		2
		3	# Copyright (c) 2016 Catalyst IT
		4	#
		5	# This file is part of Koha.
		6	#
		7	# Koha is free software; you can redistribute it and/or modify it under the
		8	# terms of the GNU General Public License as published by the Free Software
		9	# Foundation; either version 2 of the License, or (at your option) any later
		10	# version.
		11	#
		12	# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
		13	# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
		14	# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
		15	#
		16	# You should have received a copy of the GNU General Public License along with
		17	# Koha; if not, write to the Free Software Foundation, Inc.,
		18	# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
		19
		20	=head1 NAME
		21
		22	Koha::Handler::Plack::CGI - Plack helper for CGI scripts
		23
		24	=head1 SYNOPSIS
		25
		26	koha.psgi:
		27	use Koha::Handler::Plack::CGI;
		28
		29	my %koha_env = (
		30	opac => {
		31	static_root => '/usr/share/koha/opac/htdocs',
		32	script_root => '/usr/share/koha/opac',
		33	},
		34	intranet => {
		35	static_root => '/usr/share/koha/intranet/htdocs',
		36	script_root => '/usr/share/koha/intranet'
		37	}
		38	);
		39	my @sites = (
		40	{
		41	opac_hostname => 'koha1-opac.com',
		42	intranet_hostname => 'koha1-intranet.com',
		43	config = '/etc/koha/koha1/koha-conf.xml'
		44	},
		45	{
		46	opac_hostname => ['opac.koha2.com', 'www.opackoha2.com'],
		47	intranet_hostname => ['intranet.koha2.com', 'www.intranetkoha2.com'],
		48	config = '/etc/koha/koha2/koha-conf.xml'
		49	},
		50	);
		51
		52	# last line
		53	Koha::Handler::Plack::CGI->app_per_host(\%HOST_CONF);
		54
		55	See C<app_per_host()> below
		56
		57	=head1 DESCRIPTION
		58
		59	CGI script runner.
		60
		61	One beautiful day wiwill move away from that and have proper App module
		62	with router and handlers</dream>
		63
		64	See C<Koha::Handler::Plack>
65
66	=cut
67
68	use Modern::Perl;
69	use Carp;
70
71	use Plack::Builder;
72	use Plack::App::CGIBin;
73
74	use parent "Koha::Handler::Plack";
75
76	use C4::Context;
77
78	=head1 CLASS METHODS
79
80	=head2 app($context, $env)
81
82	Plack app builder fora CGI app
83
84	C<$context>: "opac" or "intranet"
85	C<$env>:
86	{
87	static_root => '...',
88	script_root => '...',
89	pugins => [
90	[ 'StackTrace' ],
91	...
92	],
93	}
94
95	koha.psgi:
96
97	Koha::Handler::Plack::CGI->app( "opac", \%opac_app_env );
98
99	=cut
100
101	sub app {
102	my $class = shift;
103	my $context = shift;
104	croak "Invalid app context '$context' - must be 'opac' or 'intranet'"
105	unless $context =~ m/^(opac\|intranet)$/;
106	my $env = shift or croak "No $context env details";
107
108	my $static_root = $env->{static_root} or croak "No $context static_root";
109	$static_root = "$static_root/" unless $static_root =~ m!/$!;
110	my $script_root = $env->{script_root} or croak "No $context script_root";
111	$script_root =~ s!/$!!;
112	my $plugins = $env->{plugins} \|\| [];
113	my $is_intranet = $context eq "intranet";
114
115	builder {
116	enable "Plack::Middleware::Static",
117	path => qr{^/$context-tmpl/}, root => $static_root;
118
119	map enable(@$_), @$plugins;
120
121	mount "/cgi-bin/koha" => Plack::App::CGIBin->new(root => $script_root)->to_app;
122	mount "/" => sub {
123	return [ 302, [ Location => '/cgi-bin/koha/' . ( $is_intranet ? 'mainpage.pl' : 'opac-main.pl' ) ], [] ];
124	};
125	};
126	}
127
128	=head2 multi_site($env, $sites)
129
130	App wrapper for per virtual host scenario.
131
132	C<$env>:
133	{
134	opac => {
135	static_root => '/usr/share/koha/opac/htdocs',
136	script_root => '/usr/share/koha/opac/cgi-bin/opac',
137	pugins => [
138	[ 'StackTrace' ],
139	],
140	},
141	intranet => {
142	static_root => '/usr/share/koha/intranet/htdocs',
143	script_root => '/usr/share/koha/cgi-bin'
144	}
145	}
146	C<$sites>:
147	{
148	namespace => 'koha1',
149	opac_hostname => 'koha1-opac.com',
150	intranet_hostname => 'koha1-intranet.com',
151	config => '/etc/koha/sites/koha1/koha-conf.xml',
152	shared_config => 1
153	},
154	{
155	namespace => 'koha2',
156	opac_hostname => ['opac.koha2.com', 'www.opackoha2.com'],
157	intranet_hostname => ['intranet.koha2.com', 'www.intranetkoha2.com'],
158	config => '/etc/koha/sites/koha2/koha-conf.xml'
159	},
160	...
161
162	koha.psgi:
163
164	Koha::Handler::Plack::CGI->multi_site( \%koha_app_env, \@sites );
165
166	=cut
167
168	my $DUMMY_KOHA_CONF = "<yazgfs><config>DUMMY</config></yazgfs>";
169	sub multi_site {
170	my $class = shift;
171	my $env = shift or croak "No Koha env details";
172	my $sites = shift or croak "No sites spec";
173
174	my ($opac_app, $intranet_app);
175
176	if (my $opac = $env->{opac}) {
177	$opac_app = $class->app('opac', $opac);
178	}
179
180	if (my $intranet = $env->{intranet}) {
181	$intranet_app = $class->app('intranet', $intranet);
182	}
183
184	my @host_def = map {
185	my $namespace = $_->{namespace} or croak "No namespace";
186	my $config = $_->{config} or croak "Site without config";
187	my $shared_context = $_->{shared_context};
188
189	my $context = C4::Context->new($config, $namespace);
190
191	my @hd;
192	if (my $hostname = $_->{opac_hostname}) {
193	croak "You have OPAC hosts without OPAC env details" unless $opac_app;
194	push @hd, {
195	hostname => $hostname,
196	app => sub {
197	# XXX this may need some rethinking
198	local $ENV{KOHA_CONF} = \$DUMMY_KOHA_CONF;
199	local $ENV{MEMCACHED_NAMESPACE} = $namespace;
200
201	$opac_app->(@_);
202	},
203	context => $context,
204	shared_context => $shared_context,
205	};
206	}
207	if (my $hostname = $_->{intranet_hostname}) {
208	croak "You have Intranet hosts without Intranet env details" unless $intranet_app;
209	push @hd, {
210	hostname => $hostname,
211	app => sub {
212	# XXX this may need some rethinking
213	local $ENV{KOHA_CONF} = \$DUMMY_KOHA_CONF;
214	local $ENV{MEMCACHED_NAMESPACE} = $namespace;
215
216	$intranet_app->(@_);
217	},
218	context => $context,
219	shared_context => $shared_context,
220	};
221	}
222	@hd;
223	} @$sites;
224
225	return $class->app_per_host( \@host_def );
226	}
227
228	1;

Line 0 Link Here

(-)a/misc/plack/koha-multi.psgi (+29 lines)
	1	#!/usr/bin/perl
	2
	3	# This is a minimal example. You can include all frills from koha.psgi
	4	# To try it:
	5	# plackup -I /usr/share/koha/lib --port 5010 koha-multi.psgi
	6
	7	my %KOHA_ENV = (
	8	opac => {
	9	static_root => '/usr/share/koha/opac/htdocs',
	10	script_root => '/usr/share/koha/opac/cgi-bin/opac',
	11	pugins => [
	12	# don't enable this plugin in production, since stack traces reveal too much information
	13	# about system to potential attackers!
	14	[ 'StackTrace' ],
	15	],
	16	},
	17	intranet => {
	18	static_root => '/usr/share/koha/intranet/htdocs',
	19	script_root => '/usr/share/koha/intranet/cgi-bin',
	20	}
	21	);
	22	my @SITES = map {
	23	namespace => $_,
	24	opac_hostname => "opac.$_.my-koha-multisite.net",
	25	intranet_hostname => "intranet.$_.my-koha-multisite.net",
	26	config => "/etc/koha/sites/$_/koha-conf.xml"
	27	}, qw(koha1 koha2 koha3);
	28
	29	Koha::Handler::Plack::CGI->multi_site( \%KOHA_ENV, \@SITES );

Line 0 Link Here

(-)a/t/Koha_Handler_Plack.t (+136 lines)
		1	#!/usr/bin/perl
		2
		3	use Test::More tests => 15;
		4	use Plack::Test;
		5	use Plack::Test::MockHTTP;
		6	use Test::Mock::LWP::Dispatch;
		7	use Test::MockModule;
		8	use HTTP::Request::Common;
		9	use FindBin qw($Bin);
		10	use Data::Dumper;
		11
		12	use_ok("Koha::Handler::Plack");
		13	use_ok("Koha::Handler::Plack::CGI");
		14
		15	use C4::Context;
		16
		17	my $db = Test::MockModule->new('Koha::Database');
		18	$db->mock(
		19	_new_schema => sub {
		20	return $_[0];
		21	}
		22	);
		23
		24	sub make_response {
		25	return join ";", map defined($_) ? $_ : "", @_;
		26	}
		27	sub dummy_val {
		28	return C4::Context->config("dummy");
		29	}
		30	sub check_context {
		31	my $dummy_val = dummy_val();
		32	is $dummy_val, undef, "context preserved"
		33	or diag("dummy val: $dummy_val");
		34	}
		35
		36	my $app = sub {
		37	return [
		38	200,
		39	[ 'Content-Type' => 'text/plain' ],
		40	[ make_response(dummy_val()) ]
		41	];
		42	};
		43	my $generic_url = "http://dummyhost.com/";
		44
		45	my $KOHA_CONF_XML = <<EOS;
		46	<yazgfs>
		47	<config>
		48	<kohasite>test</kohasite>
		49	<dummy>XML</dummy>
		50	<intrahtdocs>.</intrahtdocs>
		51	</config>
		52	</yazgfs>
		53	EOS
		54
		55	my @HOST_CONF = (
		56	{
		57	hostname => ['koha-file.com', 'www.koha-file.com'],
		58	app => $app,
		59	context => C4::Context->new("$Bin/conf/koha1/koha-conf.xml"),
		60	_dummy => "KOHA1"
		61	},
		62	{
		63	hostname => ['koha-xml.com', 'www.koha-xml.com'],
		64	app => $app,
65	context => C4::Context->new(\$KOHA_CONF_XML),
66	_dummy => "XML"
67	},
68	);
69	test_psgi
70	app => Koha::Handler::Plack->app_per_host(\@HOST_CONF),
71	client => sub {
72	my $cb = shift;
73
74	foreach my $site_params ( @HOST_CONF ) {
75	my $valid_response = make_response(
76	$site_params->{_dummy}
77	);
78	foreach (@{$site_params->{hostname}}) {
79	my $res = $cb->(GET "http://$_/");
80	is $res->content, $valid_response, $_
81	or diag(Dumper($site_params, $_, $res->as_string));
82	check_context();
83	}
84	}
85
86	$res = $cb->(GET $generic_url);
87	is $res->code, 404, "app_per_host unknown host"
88	or diag($res->as_string);
89	};
90
91	my %MULTI_HOST_ENV = (
92	opac => {
93	static_root => "$Bin/../koha-tmpl/opac-tmpl/bootstrap",
94	script_root => "$Bin/../opac",
95	},
96	intranet => {
97	static_root => "$Bin/../koha-tmpl/intranet-tmpl/bootstrap",
98	script_root => "$Bin/.."
99	}
100	);
101	my @MULTI_HOST_SITES = (
102	{
103	namespace => 'koha1',
104	opac_hostname => ['opac.koha1.com', 'www.opac.koha1.com'],
105	intranet_hostname => ['intranet.koha1.com', 'www.intranet.koha1.com'],
106	config => "$Bin/conf/koha1/koha-conf.xml",
107	},
108	{
109	namespace => 'koha2',
110	opac_hostname => ['opac.koha2.com', 'www.opac.koha2.com'],
111	intranet_hostname => ['intranet.koha2.com', 'www.intranet.koha2.com'],
112	config => "$Bin/conf/koha2/koha-conf.xml",
113	shared_context => 1,
114	},
115	);
116	test_psgi
117	app => Koha::Handler::Plack::CGI->multi_site(\%MULTI_HOST_ENV, \@MULTI_HOST_SITES),
118	client => sub {
119	my $cb = shift;
120
121	foreach my $site (@MULTI_HOST_SITES) {
122	my $opac = $site->{opac_hostname};
123	foreach my $host (@$opac) {
124	# this is not really a test, but cannot do any better atm
125	# TODO: a complex test involving two database connections
126	my $res = $cb->(GET "http://$host/");
127	# A future implementation may not redirect
128	if ($res->is_redirect) {
129	my $loc = $res->header("Location");
130	$res = $cb->(GET "http://$host$loc");
131	}
132	is $res->code, 500, "multi_site() $host"
133	or diag($res->as_string);
134	}
135	}
136	};

Lines 19-25 Link Here

(-)a/t/db_dependent/sysprefs.t (-2 / +12 lines)
19	# along with Koha; if not, see <http://www.gnu.org/licenses>.	19	# along with Koha; if not, see <http://www.gnu.org/licenses>.
20		20
21	use Modern::Perl;	21	use Modern::Perl;
22	use Test::More tests => 8;	22	use Test::More tests => 11;
23	use C4::Context;	23	use C4::Context;
24		24
25	# Start transaction	25	# Start transaction
Lines 60-63 is(C4::Context->preference('testpreference'), 'def', 'caching preferences'); Link Here
60	C4::Context->clear_syspref_cache();	60	C4::Context->clear_syspref_cache();
61	is(C4::Context->preference('testpreference'), undef, 'clearing preference cache');	61	is(C4::Context->preference('testpreference'), undef, 'clearing preference cache');
62		62
		63	delete $ENV{OVERRIDE_SYSPREF_opacheader};
		64
		65	my $DUMMY_KOHA_CONF = "<yazgfs><config><dummy>DUMMY</dummy></config></yazgfs>";
		66	my $context1 = C4::Context->new($DUMMY_KOHA_CONF, "context1");
		67	is( $context1->preference('opacheader'), $opacheader, 'context1 "opacheader"');
		68
		69	my $context2 = C4::Context->new($DUMMY_KOHA_CONF, "context2");
		70	$context2->set_preference( 'opacheader', $newopacheader );
		71	is( $context1->preference('opacheader'), $opacheader, 'context1 "opacheader"');
		72	is( $context2->preference('opacheader'), $newopacheader, 'context2 "opacheader"');
		73
63	$dbh->rollback;	74	$dbh->rollback;
64	-