[Koha-patches] [PATCH] Multi-host helper for plack installations
Srdjan
srdjan at catalyst.net.nz
Fri Jan 29 04:30:18 CET 2016
Sort of an apocalypse
* C4::Context->new() must be called with at least config file param.
If you want current context, call C4::Context->current().
C4::Context->some_method() will still work as is.
* Koha::Database->new_schema() now takes optional context param.
* C4::Context->set_context() and restore_context() are synched with
database set_schema() and restore_schema().
Created run_within_context() that wraps set_context() and
restore_context() around code.
* Created Koha::Handler::Plack* to facilitate running same code within
different (database) contexts.
* This initial version does not run with memcached turned on. Next patch
will correct that.
https://bugs.koha-community.org/show_bug.cgi?id=15562
---
C4/Auth_with_cas.pm | 2 +-
C4/Auth_with_ldap.pm | 2 +-
C4/Context.pm | 304 +++++++++++-------------
Koha/Database.pm | 38 ++-
Koha/Handler/Plack.pm | 163 +++++++++++++
Koha/Handler/Plack/CGI.pm | 217 +++++++++++++++++
admin/systempreferences.pl | 2 +-
misc/plack/koha-multi.psgi | 29 +++
misc/translator/LangInstaller.pm | 2 +-
t/Context.t | 25 ++
t/Koha_Handler_Plack.t | 133 +++++++++++
t/conf/dummy/koha-conf.xml | 7 +
t/conf/koha1/koha-conf.xml | 7 +
t/conf/koha2/koha-conf.xml | 5 +
t/db_dependent/Amazon.t | 2 +-
t/db_dependent/Context.t | 2 +-
t/db_dependent/Koha_template_plugin_KohaDates.t | 2 +-
t/db_dependent/XISBN.t | 2 +-
t/db_dependent/sysprefs.t | 5 +-
19 files changed, 766 insertions(+), 183 deletions(-)
create mode 100644 Koha/Handler/Plack.pm
create mode 100644 Koha/Handler/Plack/CGI.pm
create mode 100644 misc/plack/koha-multi.psgi
create mode 100644 t/Koha_Handler_Plack.t
create mode 100644 t/conf/dummy/koha-conf.xml
create mode 100644 t/conf/koha1/koha-conf.xml
create mode 100644 t/conf/koha2/koha-conf.xml
diff --git a/C4/Auth_with_cas.pm b/C4/Auth_with_cas.pm
index 1749333..3dedb22 100644
--- a/C4/Auth_with_cas.pm
+++ b/C4/Auth_with_cas.pm
@@ -37,7 +37,7 @@ BEGIN {
@ISA = qw(Exporter);
@EXPORT = qw(check_api_auth_cas checkpw_cas login_cas logout_cas login_cas_url);
}
-my $context = C4::Context->new() or die 'C4::Context->new failed';
+my $context = C4::Context->current() or die 'No current context';
my $defaultcasserver;
my $casservers;
my $yamlauthfile = C4::Context->config('intranetdir') . "/C4/Auth_cas_servers.yaml";
diff --git a/C4/Auth_with_ldap.pm b/C4/Auth_with_ldap.pm
index 58484a2..f9ea649 100644
--- a/C4/Auth_with_ldap.pm
+++ b/C4/Auth_with_ldap.pm
@@ -54,7 +54,7 @@ sub ldapserver_error {
}
use vars qw($mapping @ldaphosts $base $ldapname $ldappassword);
-my $context = C4::Context->new() or die 'C4::Context->new failed';
+my $context = C4::Context->current() or die 'No current context';
my $ldap = C4::Context->config("ldapserver") or die 'No "ldapserver" in server hash from KOHA_CONF: ' . $ENV{KOHA_CONF};
my $prefhost = $ldap->{hostname} or die ldapserver_error('hostname');
my $base = $ldap->{base} or die ldapserver_error('base');
diff --git a/C4/Context.pm b/C4/Context.pm
index 1dcdce4..ec45d91 100644
--- a/C4/Context.pm
+++ b/C4/Context.pm
@@ -31,7 +31,7 @@ BEGIN {
eval {C4::Context->dbh();};
if ($@){
$debug_level = 1;
- }
+ }
else {
$debug_level = C4::Context->preference("DebugLevel");
}
@@ -49,7 +49,7 @@ BEGIN {
# a little example table with various version info";
print "
<h1>Koha error</h1>
- <p>The following fatal error has occurred:</p>
+ <p>The following fatal error has occurred:</p>
<pre><code>$msg</code></pre>
<table>
<tr><th>Apache</th><td> $versions{apacheVersion}</td></tr>
@@ -63,11 +63,11 @@ BEGIN {
} elsif ($debug_level eq "1"){
print "
<h1>Koha error</h1>
- <p>The following fatal error has occurred:</p>
+ <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);
@@ -103,6 +103,7 @@ use XML::Simple;
use POSIX ();
use DateTime::TimeZone;
use Module::Load::Conditional qw(can_load);
+use Data::Dumper;
use Carp;
use C4::Boolean;
@@ -169,10 +170,6 @@ environment variable to the pathname of a configuration file to use.
# 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
@@ -181,7 +178,7 @@ environment variable to the pathname of a configuration file to use.
# 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
+# 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.
@@ -191,52 +188,25 @@ environment variable to the pathname of a configuration file to use.
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,
+ # 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
- at 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:
+ # developers should set the KOHA_CONF environment variable
-The simple elements nested within the <config> element:
+ at context_stack = (); # Initially, no saved contexts
- my $pass = $koha->{'config'}->{'pass'};
+=head2 current
-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.
+Returns the current context
=cut
-sub read_config_file { # Pass argument naming config file to read
- my $koha = XMLin(shift, keyattr => ['id'], forcearray => ['listen', 'server', 'serverinfo'], suppressempty => '');
-
- if ($ismemcached) {
- $memcached->set('kohaconf',$koha);
- }
-
- return $koha; # Return value: ref-to-hash holding the configuration
+sub current {
+ return $context;
}
=head2 ismemcached
@@ -264,6 +234,15 @@ sub memcached {
}
}
+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);
@@ -284,20 +263,59 @@ sub import {
# 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
+ # 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!
- my ($pkg,$config_file) = @_ ;
+ 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
- $new_ctx->set_context;
- 1;
+ $context = $new_ctx;
+
+ if ($ismemcached) {
+ $memcached->set('kohaconf',$new_ctx);
+ }
}
+use Scalar::Util qw(openhandle);
=head2 new
$context = new C4::Context;
@@ -307,9 +325,23 @@ Allocates a new context. Initializes the context from the specified
file, which defaults to either the file given by the C<$KOHA_CONF>
environment variable, or F</etc/koha/koha-conf.xml>.
-It saves the koha-conf.xml values in the declared memcached server(s)
-if currently available and uses those values until them expire and
-re-reads them.
+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>.
@@ -321,46 +353,18 @@ 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; # Config file to load
- my $self = {};
+ my $conf_fname = shift or croak "No conf";
- # check that the specified config file exists and is not empty
- undef $conf_fname unless
- (defined $conf_fname && -s $conf_fname);
- # Figure out a good config file to load if none was specified.
- if (!defined($conf_fname))
- {
- # If the $KOHA_CONF environment variable is set, use
- # that. Otherwise, use the built-in default.
- if (exists $ENV{"KOHA_CONF"} and $ENV{'KOHA_CONF'} and -s $ENV{"KOHA_CONF"}) {
- $conf_fname = $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
- $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);
- }
+ 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;
- warn "read_config_file($conf_fname) returned undef" if !defined($self->{"config"});
- return if !defined($self->{"config"});
+ $self->{"config_file"} = "$conf_fname";
$self->{"Zconn"} = undef; # Zebra Connections
$self->{"marcfromkohafield"} = undef; # the hash with relations between koha table fields and MARC field/subfield
@@ -407,13 +411,18 @@ sub set_context
# break this assumption by playing silly buggers, but that's
# harder to do than doing it properly, and harder to check
# for.
+ my $schema;
if (ref($self) eq "")
{
# Class method. The new context is the next argument.
- $new_context = shift;
+ $new_context = shift or croak "No new context";
+ $schema = Koha::Database->new_schema($new_context);
} else {
# Instance method. The new context is $self.
$new_context = $self;
+
+ # undef $self->{schema} if $self->{schema} && !$self->{schema}->ping
+ $schema = $self->{schema} ||= Koha::Database->new_schema($self);
}
# Save the old context, if any, on the stack
@@ -421,6 +430,7 @@ sub set_context
# Set the new context
$context = $new_context;
+ Koha::Database->set_schema($schema);
}
=head2 restore_context
@@ -436,19 +446,38 @@ sub 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");
@@ -465,26 +494,32 @@ C<C4::Config-E<gt>new> will not return it.
=cut
sub _common_config {
- my $var = shift;
- my $term = shift;
- return if !defined($context->{$term});
+ 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 $context->{$term}->{$var};
+ return $self->{$term}->{$var};
}
sub config {
- return _common_config($_[1],'config');
+ my $self = shift;
+ return $self->_common_config($_[0],'config');
}
sub zebraconfig {
- return _common_config($_[1],'server');
+ my $self = shift;
+ return $self->_common_config($_[0],'server');
}
sub ModZebrations {
- return _common_config($_[1],'serverinfo');
+ my $self = shift;
+ return $self->_common_config($_[0],'serverinfo');
}
=head2 preference
@@ -517,8 +552,6 @@ sub preference {
return $self->{sysprefs}{$lc_var} if $use_syspref_cache && $self && exists $self->{sysprefs}{$lc_var};
- my $dbh = C4::Context->dbh or return 0;
-
my $value;
if ( defined $ENV{"OVERRIDE_SYSPREF_$var"} ) {
$value = $ENV{"OVERRIDE_SYSPREF_$var"};
@@ -626,7 +659,7 @@ sub set_preference {
Returns a connection to the Zebra database
-C<$self>
+C<$self>
C<$server> one of the servers defined in the koha-conf.xml file
@@ -737,8 +770,7 @@ creates one, and connects to the database.
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> and
-possibly C<&set_dbh>.
+times. If you need a second database handle, use C<&new_dbh>.
=cut
@@ -777,64 +809,6 @@ sub new_dbh
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
diff --git a/Koha/Database.pm b/Koha/Database.pm
index 82d831f..c066c84 100644
--- a/Koha/Database.pm
+++ b/Koha/Database.pm
@@ -46,12 +46,11 @@ __PACKAGE__->mk_accessors(qw( ));
# database connection from the data given in the current context, and
# returns it.
sub _new_schema {
+ my $context = shift || C4::Context->current();
require Koha::Schema;
- my $context = C4::Context->new();
-
- my $db_driver = $context->{db_driver};
+ my $db_driver = $context->db_driver;
my $db_name = $context->config("database");
my $db_host = $context->config("hostname");
@@ -122,16 +121,16 @@ sub schema {
return $database->{schema} if defined $database->{schema};
}
- $database->{schema} = &_new_schema();
+ $database->{schema} = &_new_schema($params->{context});
return $database->{schema};
}
=head2 new_schema
- $schema = $database->new_schema;
+ $schema = $database->new_schema($context);
-Creates a new connection to the Koha database for the current context,
-and returns the database handle (a C<DBI::db> object).
+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
@@ -143,7 +142,7 @@ connect to so that the caller doesn't have to know.
sub new_schema {
my $self = shift;
- return &_new_schema();
+ return &_new_schema(@_);
}
=head2 set_schema
@@ -200,6 +199,29 @@ sub restore_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.
diff --git a/Koha/Handler/Plack.pm b/Koha/Handler/Plack.pm
new file mode 100644
index 0000000..d42d833
--- /dev/null
+++ b/Koha/Handler/Plack.pm
@@ -0,0 +1,163 @@
+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::Builder;
+
+=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 ":no_config";
+
+ 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 $builder = Plack::Builder->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) {
+ $builder->mount("http://$host/" => sub {
+ my $env = shift;
+ return $context->run_within_context(sub { $app->($env) });
+ });
+ }
+ }
+ return $builder->to_app;
+}
+
+1;
diff --git a/Koha/Handler/Plack/CGI.pm b/Koha/Handler/Plack/CGI.pm
new file mode 100644
index 0000000..72a27f7
--- /dev/null
+++ b/Koha/Handler/Plack/CGI.pm
@@ -0,0 +1,217 @@
+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 ":no_config";
+
+=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>:
+ {
+ opac_hostname => 'koha1-opac.com',
+ intranet_hostname => 'koha1-intranet.com',
+ config => '/etc/koha/sites/koha1/koha-conf.xml'
+ },
+ {
+ 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 $config = $_->{config} or croak "Site without config";
+ my $context = C4::Context->new($config);
+ 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;
+
+ $opac_app->(@_);
+ },
+ context => $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;
+
+ $intranet_app->(@_);
+ },
+ context => $context,
+ };
+ }
+ @hd;
+ } @$sites;
+
+ return $class->app_per_host( \@host_def );
+}
+
+1;
diff --git a/admin/systempreferences.pl b/admin/systempreferences.pl
index 01c0300..8e6c6d9 100755
--- a/admin/systempreferences.pl
+++ b/admin/systempreferences.pl
@@ -422,7 +422,7 @@ output_html_with_http_headers $input, $cookie, $template->output;
# .pref files.
sub get_prefs_from_files {
- my $context = C4::Context->new();
+ my $context = C4::Context->current();
my $path_pref_en = $context->config('intrahtdocs') .
'/prog/en/modules/admin/preferences';
# Get all .pref file names
diff --git a/misc/plack/koha-multi.psgi b/misc/plack/koha-multi.psgi
new file mode 100644
index 0000000..e897f02
--- /dev/null
+++ b/misc/plack/koha-multi.psgi
@@ -0,0 +1,29 @@
+#!/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 );
diff --git a/misc/translator/LangInstaller.pm b/misc/translator/LangInstaller.pm
index 5244945..6bc8f85 100644
--- a/misc/translator/LangInstaller.pm
+++ b/misc/translator/LangInstaller.pm
@@ -56,7 +56,7 @@ sub new {
my $self = { };
- my $context = C4::Context->new();
+ my $context = C4::Context->current();
$self->{context} = $context;
$self->{path_pref_en} = $context->config('intrahtdocs') .
'/prog/en/modules/admin/preferences';
diff --git a/t/Context.t b/t/Context.t
index 8febdb4..c3855cd 100755
--- a/t/Context.t
+++ b/t/Context.t
@@ -59,3 +59,28 @@ is(C4::Context->interface('foobar'), 'intranet');
is(C4::Context->interface, 'intranet');
is(C4::Context->interface('OPAC'), 'opac');
is(C4::Context->interface, 'opac');
+
+my $DUMMY_KOHA_CONF = "<yazgfs><config><kohasite>TEST</kohasite></config></yazgfs>";
+my $ctx_a = C4::Context->new($DUMMY_KOHA_CONF, "a");
+my $ctx_b = C4::Context->new($DUMMY_KOHA_CONF, "b");
+my $cache_key = "test_C4::Context";
+
+SKIP: {
+ skip "No cache", 5 unless $ctx_a->cache->is_cache_active && $ctx_b->cache->is_cache_active;
+
+ # Light warm up
+ $ctx_a->cache->set_in_cache($cache_key, 'a');
+ $ctx_b->cache->set_in_cache($cache_key, 'b');
+ is(C4::Context->cache->get_from_cache($cache_key), 'c', "Correct default cache value");
+ is($ctx_a->cache->get_from_cache($cache_key), 'a', "Correct cache 'a' value");
+ is($ctx_b->cache->get_from_cache($cache_key), 'b', "Correct cache 'b' value");
+
+ # A bit more extravagant
+ $ctx_a->run_within_context( sub {
+ $ctx_b->cache->set_in_cache($cache_key, 'bb');
+ C4::Context->cache->set_in_cache($cache_key, 'aa');
+ } );
+ is($ctx_a->cache->get_from_cache($cache_key), 'aa', "Correct cache 'a' value");
+ is($ctx_b->cache->get_from_cache($cache_key), 'bb', "Correct cache 'b' value");
+ C4::Context->cache->set_in_cache($cache_key, 'c');
+}
diff --git a/t/Koha_Handler_Plack.t b/t/Koha_Handler_Plack.t
new file mode 100644
index 0000000..7666971
--- /dev/null
+++ b/t/Koha_Handler_Plack.t
@@ -0,0 +1,133 @@
+#!/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 ":no_config";
+
+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 = (
+ {
+ 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",
+ },
+ {
+ 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",
+ },
+);
+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);
+ }
+ }
+ };
diff --git a/t/conf/dummy/koha-conf.xml b/t/conf/dummy/koha-conf.xml
new file mode 100644
index 0000000..d4c96b0
--- /dev/null
+++ b/t/conf/dummy/koha-conf.xml
@@ -0,0 +1,7 @@
+<yazgfs>
+ <config>
+ <kohasite>dummy</kohasite>
+ <dummy>DUMMY</dummy>
+ <intrahtdocs>.</intrahtdocs>
+ </config>
+</yazgfs>
diff --git a/t/conf/koha1/koha-conf.xml b/t/conf/koha1/koha-conf.xml
new file mode 100644
index 0000000..371d039
--- /dev/null
+++ b/t/conf/koha1/koha-conf.xml
@@ -0,0 +1,7 @@
+<yazgfs>
+ <config>
+ <kohasite>koha1</kohasite>
+ <dummy>KOHA1</dummy>
+ <intrahtdocs>.</intrahtdocs>
+ </config>
+</yazgfs>
diff --git a/t/conf/koha2/koha-conf.xml b/t/conf/koha2/koha-conf.xml
new file mode 100644
index 0000000..437e772
--- /dev/null
+++ b/t/conf/koha2/koha-conf.xml
@@ -0,0 +1,5 @@
+<yazgfs>
+ <config>
+ <dummy>KOHA2</dummy>
+ </config>
+</yazgfs>
diff --git a/t/db_dependent/Amazon.t b/t/db_dependent/Amazon.t
index f8352c8..2b62f20 100755
--- a/t/db_dependent/Amazon.t
+++ b/t/db_dependent/Amazon.t
@@ -13,7 +13,7 @@ BEGIN {
use_ok('C4::External::Amazon');
}
-my $context = C4::Context->new();
+my $context = C4::Context->current();
my $locale = $context->preference('AmazonLocale');
diff --git a/t/db_dependent/Context.t b/t/db_dependent/Context.t
index 8c0abfd..cecb10e 100755
--- a/t/db_dependent/Context.t
+++ b/t/db_dependent/Context.t
@@ -48,7 +48,7 @@ C4::Context->clear_syspref_cache();
C4::Context->enable_syspref_cache();
$dbh->rollback;
-ok($koha = C4::Context->new, 'C4::Context->new');
+ok($koha = C4::Context->current, 'C4::Context->current');
my @keys = keys %$koha;
my $width = 0;
if (ok(@keys)) {
diff --git a/t/db_dependent/Koha_template_plugin_KohaDates.t b/t/db_dependent/Koha_template_plugin_KohaDates.t
index d48e3c9..f498009 100644
--- a/t/db_dependent/Koha_template_plugin_KohaDates.t
+++ b/t/db_dependent/Koha_template_plugin_KohaDates.t
@@ -13,7 +13,7 @@ BEGIN {
my $module_context = new Test::MockModule('C4::Context');
my $date = "1973-05-21";
-my $context = C4::Context->new();
+my $context = C4::Context->current();
my $filter = Koha::Template::Plugin::KohaDates->new();
ok ($filter, "new()");
diff --git a/t/db_dependent/XISBN.t b/t/db_dependent/XISBN.t
index 9486274..5785edb 100755
--- a/t/db_dependent/XISBN.t
+++ b/t/db_dependent/XISBN.t
@@ -25,7 +25,7 @@ my $search_module = new Test::MockModule('C4::Search');
$search_module->mock('SimpleSearch', \&Mock_SimpleSearch );
-my $context = C4::Context->new;
+my $context = C4::Context->current;
my ( $biblionumber_tag, $biblionumber_subfield ) =
GetMarcFromKohaField( 'biblio.biblionumber', '' );
diff --git a/t/db_dependent/sysprefs.t b/t/db_dependent/sysprefs.t
index f24390c..190f276 100755
--- a/t/db_dependent/sysprefs.t
+++ b/t/db_dependent/sysprefs.t
@@ -51,10 +51,11 @@ is( C4::Context->preference('IDoNotExist'), 'NonExistent', 'Test creation of non
delete $ENV{OVERRIDE_SYSPREF_opacheader};
-my $context1 = C4::Context->new();
+my $DUMMY_KOHA_CONF = "<yazgfs><config>DUMMY</config></yazgfs>";
+my $context1 = C4::Context->new($DUMMY_KOHA_CONF);
is( $context1->preference('opacheader'), $opacheader, 'context1 "opacheader"');
-my $context2 = C4::Context->new();
+my $context2 = C4::Context->new($DUMMY_KOHA_CONF);
$context2->set_preference( 'opacheader', $newopacheader );
is( $context1->preference('opacheader'), $opacheader, 'context1 "opacheader"');
is( $context2->preference('opacheader'), $newopacheader, 'context2 "opacheader"');
--
1.9.1
More information about the Koha-patches
mailing list