]> git.koha-community.org Git - koha.git/blob - Koha/Database.pm
Bug 15427 : Enable TLS support for MySQL
[koha.git] / Koha / Database.pm
1 package Koha::Database;
2
3 # Copyright 2013 Catalyst IT
4 # chrisc@catalyst.net.nz
5 #
6 # This file is part of Koha.
7 #
8 # Koha is free software; you can redistribute it and/or modify it under the
9 # terms of the GNU General Public License as published by the Free Software
10 # Foundation; either version 3 of the License, or (at your option) any later
11 # version.
12 #
13 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
14 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
15 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
16 #
17 # You should have received a copy of the GNU General Public License along
18 # with Koha; if not, write to the Free Software Foundation, Inc.,
19 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
20
21 =head1 NAME
22
23 Koha::Database
24
25 =head1 SYNOPSIS
26
27   use Koha::Database;
28   my $database = Koha::Database->new();
29   my $schema = $database->schema();
30
31 =head1 FUNCTIONS
32
33 =cut
34
35 use Modern::Perl;
36 use Carp;
37 use C4::Context;
38 use base qw(Class::Accessor);
39
40 use vars qw($database);
41
42 __PACKAGE__->mk_accessors(qw( ));
43
44 # _new_schema
45 # Internal helper function (not a method!). This creates a new
46 # database connection from the data given in the current context, and
47 # returns it.
48 sub _new_schema {
49
50     require Koha::Schema;
51
52     my $context = C4::Context->new();
53
54     my $db_driver = $context->{db_driver};
55
56     my $db_name   = $context->config("database");
57     my $db_host   = $context->config("hostname");
58     my $db_port   = $context->config("port") || '';
59     my $db_user   = $context->config("user");
60     my $db_passwd = $context->config("pass");
61     my $tls = $context->config("tls");
62     my $tls_options;
63     if ($tls eq 'yes'){
64         my $ca = $context->config('ca');
65         my $cert = $context->config('cert');
66         my $key = $context->config('key');
67         $tls_options = ";mysql_ssl=1;mysql_ssl_client_key=".$key.";mysql_ssl_client_cert=".$cert.";mysql_ssl_ca_file=".$ca;
68     }
69
70
71
72     my ( %encoding_attr, $encoding_query, $tz_query );
73     my $tz = $ENV{TZ};
74     if ( $db_driver eq 'mysql' ) {
75         %encoding_attr = ( mysql_enable_utf8 => 1 );
76         $encoding_query = "set NAMES 'utf8'";
77         $tz_query = qq(SET time_zone = "$tz") if $tz;
78     }
79     elsif ( $db_driver eq 'Pg' ) {
80         $encoding_query = "set client_encoding = 'UTF8';";
81         $tz_query = qq(SET TIME ZONE = "$tz") if $tz;
82     }
83     my $schema = Koha::Schema->connect(
84         {
85             dsn => "dbi:$db_driver:database=$db_name;host=$db_host;port=$db_port".($tls_options? $tls_options : ""),
86             user => $db_user,
87             password => $db_passwd,
88             %encoding_attr,
89             RaiseError => $ENV{DEBUG} ? 1 : 0,
90             PrintError => 1,
91             unsafe => 1,
92             quote_names => 1,
93             on_connect_do => [
94                 $encoding_query || (),
95                 $tz_query || (),
96             ]
97         }
98     );
99
100     my $dbh = $schema->storage->dbh;
101     eval {
102         $dbh->{RaiseError} = 1;
103         if ( $ENV{KOHA_DB_DO_NOT_RAISE_OR_PRINT_ERROR} ) {
104             $dbh->{RaiseError} = 0;
105             $dbh->{PrintError} = 0;
106         }
107         $dbh->do(q|
108             SELECT * FROM systempreferences WHERE 1 = 0 |
109         );
110         $dbh->{RaiseError} = $ENV{DEBUG} ? 1 : 0;
111     };
112     $dbh->{RaiseError} = 0 if $@;
113
114     return $schema;
115 }
116
117 =head2 schema
118
119     $schema = $database->schema;
120
121 Returns a database handle connected to the Koha database for the
122 current context. If no connection has yet been made, this method
123 creates one, and connects to the database.
124
125 This database handle is cached for future use: if you call
126 C<$database-E<gt>schema> twice, you will get the same handle both
127 times. If you need a second database handle, use C<&new_schema> and
128 possibly C<&set_schema>.
129
130 =cut
131
132 sub schema {
133     my $self = shift;
134     my $params = shift;
135
136     unless ( $params->{new} ) {
137         return $database->{schema} if defined $database->{schema};
138     }
139
140     $database->{schema} = &_new_schema();
141     return $database->{schema};
142 }
143
144 =head2 new_schema
145
146   $schema = $database->new_schema;
147
148 Creates a new connection to the Koha database for the current context,
149 and returns the database handle (a C<DBI::db> object).
150
151 The handle is not saved anywhere: this method is strictly a
152 convenience function; the point is that it knows which database to
153 connect to so that the caller doesn't have to know.
154
155 =cut
156
157 #'
158 sub new_schema {
159     my $self = shift;
160
161     return &_new_schema();
162 }
163
164 =head2 set_schema
165
166   $my_schema = $database->new_schema;
167   $database->set_schema($my_schema);
168   ...
169   $database->restore_schema;
170
171 C<&set_schema> and C<&restore_schema> work in a manner analogous to
172 C<&set_context> and C<&restore_context>.
173
174 C<&set_schema> saves the current database handle on a stack, then sets
175 the current database handle to C<$my_schema>.
176
177 C<$my_schema> is assumed to be a good database handle.
178
179 =cut
180
181 sub set_schema {
182     my $self       = shift;
183     my $new_schema = shift;
184
185     # Save the current database handle on the handle stack.
186     # We assume that $new_schema is all good: if the caller wants to
187     # screw himself by passing an invalid handle, that's fine by
188     # us.
189     push @{ $database->{schema_stack} }, $database->{schema};
190     $database->{schema} = $new_schema;
191 }
192
193 =head2 restore_schema
194
195   $database->restore_schema;
196
197 Restores the database handle saved by an earlier call to
198 C<$database-E<gt>set_schema>.
199
200 =cut
201
202 sub restore_schema {
203     my $self = shift;
204
205     if ( $#{ $database->{schema_stack} } < 0 ) {
206
207         # Stack underflow
208         die "SCHEMA stack underflow";
209     }
210
211     # Pop the old database handle and set it.
212     $database->{schema} = pop @{ $database->{schema_stack} };
213
214     # FIXME - If it is determined that restore_context should
215     # return something, then this function should, too.
216 }
217
218 =head2 EXPORT
219
220 None by default.
221
222
223 =head1 AUTHOR
224
225 Chris Cormack, E<lt>chrisc@catalyst.net.nzE<gt>
226
227 =cut
228
229 1;
230
231 __END__