File Coverage

lib/Class/Usul/TraitFor/ConnectInfo.pm
Criterion Covered Total %
statement 42 51 82.3
branch 4 6 66.6
condition 3 8 37.5
subroutine 10 13 76.9
pod 4 4 100.0
total 63 82 76.8


line stmt bran cond sub pod time code
1             package Class::Usul::TraitFor::ConnectInfo;
2              
3 2     2   1595 use namespace::autoclean;
  2         8  
  2         20  
4              
5 2     2   210 use Class::Usul::Constants qw( EXCEPTION_CLASS CONFIG_EXTN FALSE TRUE );
  2         6  
  2         33  
6 2     2   2547 use Class::Usul::Crypt::Util qw( decrypt_from_config );
  2         9  
  2         130  
7 2     2   538 use Class::Usul::File;
  2         9  
  2         62  
8 2     2   11 use Class::Usul::Functions qw( merge_attributes throw );
  2         4  
  2         17  
9 2     2   2237 use File::Spec::Functions qw( catfile );
  2         5  
  2         130  
10 2     2   12 use Scalar::Util qw( blessed );
  2         6  
  2         72  
11 2     2   11 use Unexpected::Functions qw( Unspecified );
  2         4  
  2         13  
12 2     2   488 use Moo::Role;
  2         5  
  2         13  
13              
14             requires qw( config ); # As a class method
15              
16             my $_cache = {};
17              
18             # Private functions
19             my $_connect_attr = sub {
20             return [ qw( class ctlfile ctrldir database dataclass_attr extension
21             prefix read_secure salt seed seed_file subspace tempdir ) ];
22             };
23              
24             my $_get_cache_key = sub {
25             my $param = shift;
26             my $db = $param->{database}
27             or throw 'Class [_1] has no database name', [ $param->{class} ];
28              
29             return $param->{subspace} ? "${db}.".$param->{subspace} : $db;
30             };
31              
32             my $_get_credentials_file = sub {
33             my $param = shift; my $file = $param->{ctlfile};
34              
35             defined $file and -f $file and return $file;
36              
37             my $dir = $param->{ctrldir}; my $db = $param->{database};
38              
39             $dir or throw Unspecified, [ 'ctrldir' ];
40             -d $dir or throw 'Directory [_1] not found', [ $dir ];
41             $db or throw 'Class [_1] has no database name', [ $param->{class} ];
42              
43             $file = catfile( $dir, $db.($param->{extension} // CONFIG_EXTN) );
44              
45             -f $file and return $file;
46              
47             return catfile( $dir, 'connect-info'.($param->{extension} // CONFIG_EXTN) );
48             };
49              
50             my $_get_dataclass_schema = sub {
51             return Class::Usul::File->dataclass_schema( @_ );
52             };
53              
54             my $_unicode_options = sub {
55             return { mysql => { mysql_enable_utf8 => TRUE },
56             pg => { pg_enable_utf8 => TRUE },
57             sqlite => { sqlite_unicode => TRUE }, };
58             };
59              
60             my $_dump_config_data = sub {
61             my ($param, $cfg_data) = @_;
62              
63             my $ctlfile = $_get_credentials_file->( $param );
64             my $schema = $_get_dataclass_schema->( $param->{dataclass_attr} );
65              
66             return $schema->dump( { data => $cfg_data, path => $ctlfile } );
67             };
68              
69             my $_extract_creds_from = sub {
70             my ($param, $cfg_data) = @_; my $key = $_get_cache_key->( $param );
71              
72             ($cfg_data->{credentials} and defined $cfg_data->{credentials}->{ $key })
73             or throw 'Path [_1] database [_2] no credentials',
74             [ $_get_credentials_file->( $param ), $key ];
75              
76             return $cfg_data->{credentials}->{ $key };
77             };
78              
79             my $_get_connect_options = sub {
80             my $creds = shift;
81             my $uopt = $creds->{unicode_option}
82             // $_unicode_options->()->{ lc $creds->{driver} } // {};
83              
84             return { AutoCommit => $creds->{auto_commit } // TRUE,
85             PrintError => $creds->{print_error } // FALSE,
86             RaiseError => $creds->{raise_error } // TRUE,
87             %{ $uopt }, %{ $creds->{database_attr} // {} }, };
88             };
89              
90             my $_load_config_data = sub {
91             my $schema = $_get_dataclass_schema->( $_[ 0 ]->{dataclass_attr} );
92              
93             return $schema->load( $_get_credentials_file->( $_[ 0 ] ) );
94             };
95              
96             # Private methods
97             my $_merge_attributes = sub {
98             return merge_attributes { class => blessed $_[ 0 ] || $_[ 0 ] },
99             $_[ 1 ], ($_[ 2 ] // {}), $_connect_attr->();
100             };
101              
102             # Public methods
103             sub dump_config_data {
104 0     0 1 0 my ($self, $config, $db, $cfg_data) = @_;
105              
106 0         0 my $param = $self->$_merge_attributes( $config, { database => $db } );
107              
108 0         0 return $_dump_config_data->( $param, $cfg_data );
109             }
110              
111             sub extract_creds_from {
112 0     0 1 0 my ($self, $config, $db, $cfg_data) = @_;
113              
114 0         0 my $param = $self->$_merge_attributes( $config, { database => $db } );
115              
116 0         0 return $_extract_creds_from->( $param, $cfg_data );
117             }
118              
119             sub get_connect_info {
120 4   33 4 1 925 my ($self, $app, $param) = @_; $app //= $self; $param //= {};
  4   50     20  
  4         15  
121              
122 4         55 merge_attributes $param, $app->config, $self->config, $_connect_attr->();
123              
124 4   33     28 my $class = $param->{class} = blessed $self || $self;
125 4         18 my $key = $_get_cache_key->( $param );
126              
127 4 100       44 defined $_cache->{ $key } and return $_cache->{ $key };
128              
129 2         7 my $cfg_data = $_load_config_data->( $param );
130 2         45454 my $creds = $_extract_creds_from->( $param, $cfg_data );
131 2         8 my $dsn = 'dbi:'.$creds->{driver}.':database='.$param->{database};
132 2         13 my $password = decrypt_from_config $param, $creds->{password};
133 2         12 my $opts = $_get_connect_options->( $creds );
134              
135 2 50       13 $creds->{host} and $dsn .= ';host='.$creds->{host};
136 2 50       10 $creds->{port} and $dsn .= ';port='.$creds->{port};
137              
138 2         39 return $_cache->{ $key } = [ $dsn, $creds->{user}, $password, $opts ];
139             }
140              
141             sub load_config_data {
142 0     0 1   my ($self, $config, $db) = @_;
143              
144 0           my $param = $self->$_merge_attributes( $config, { database => $db } );
145              
146 0           return $_load_config_data->( $param );
147             }
148              
149             1;
150              
151             =pod
152              
153             =encoding utf-8
154              
155             =head1 Name
156              
157             Class::Usul::TraitFor::ConnectInfo - Provides the DBIC connect info array ref
158              
159             =head1 Synopsis
160              
161             package YourClass;
162              
163             use Moo;
164             use Class::Usul::Constants;
165             use Class::Usul::Types qw( NonEmptySimpleStr Object );
166              
167             with 'Class::Usul::TraitFor::ConnectInfo';
168              
169             has 'database' => is => 'ro', isa => NonEmptySimpleStr,
170             default => 'database_name';
171              
172             has 'schema' => is => 'lazy', isa => Object, builder => sub {
173             my $self = shift; my $extra = $self->config->connect_params;
174             $self->schema_class->connect( @{ $self->get_connect_info }, $extra ) };
175              
176             has 'schema_class' => is => 'ro', isa => NonEmptySimpleStr,
177             default => 'dbic_schema_class_name';
178              
179             sub config { # A class method
180             return { ...config parameters... }
181             }
182              
183             =head1 Description
184              
185             Provides the DBIC connect information array reference
186              
187             =head1 Configuration and Environment
188              
189             The JSON data looks like this:
190              
191             {
192             "credentials" : {
193             "schedule" : {
194             "driver" : "mysql",
195             "host" : "localhost",
196             "password" : "{Twofish}U2FsdGVkX1/xcBKZB1giOdQkIt8EFgfNDFGm/C+fZTs=",
197             "port" : "3306",
198             "user" : "username"
199             }
200             }
201             }
202              
203             where in this example C<schedule> is the database name
204              
205             =head1 Subroutines/Methods
206              
207             =head2 dump_config_data
208              
209             $dumped_data = $self->dump_config_data( $app_config, $db, $cfg_data );
210              
211             Call the L<dump method|File::DataClass::Schema/dump> to write the
212             configuration file back to disk
213              
214             =head2 extract_creds_from
215              
216             $creds = $self->extract_creds_from( $app_config, $db, $cfg_data );
217              
218             Returns the credential info for the specified database and (optional)
219             subspace. The subspace attribute of C<$app_config> is appended
220             to the database name to create a unique cache key
221              
222             =head2 get_connect_info
223              
224             $db_info_arr = $self->get_connect_info( $app_config, $db );
225              
226             Returns an array ref containing the information needed to make a
227             connection to a database; DSN, user id, password, and options hash
228             ref. The data is read from the configuration file in the config
229             C<ctrldir>. Multiple sets of data can be stored in the same file,
230             keyed by the C<$db> argument. The password is decrypted if
231             required
232              
233             =head2 load_config_data
234              
235             $cfg_data = $self->load_config_data( $app_config, $db );
236              
237             Returns a hash ref of configuration file data. The path to the file
238             can be specified in C<< $app_config->{ctlfile} >> or it will default
239             to the F<connect-info.$extension> file in the C<< $app_config->{ctrldir} >>
240             directory. The C<$extension> is either C<< $app_config->{extension} >>
241             or C<< $self->config->{extension} >> or the default extension given
242             by the C<CONFIG_EXTN> constant
243              
244             =head1 Diagnostics
245              
246             None
247              
248             =head1 Dependencies
249              
250             =over 3
251              
252             =item L<Moo::Role>
253              
254             =item L<Class::Usul::Crypt::Util>
255              
256             =item L<Class::Usul::File>
257              
258             =item L<Unexpected>
259              
260             =back
261              
262             =head1 Incompatibilities
263              
264             There are no known incompatibilities in this module
265              
266             =head1 Bugs and Limitations
267              
268             There are no known bugs in this module.
269             Please report problems to the address below.
270             Patches are welcome
271              
272             =head1 Acknowledgements
273              
274             Larry Wall - For the Perl programming language
275              
276             =head1 Author
277              
278             Peter Flanigan, C<< <pjfl@cpan.org> >>
279              
280             =head1 License and Copyright
281              
282             Copyright (c) 2017 Peter Flanigan. All rights reserved
283              
284             This program is free software; you can redistribute it and/or modify it
285             under the same terms as Perl itself. See L<perlartistic>
286              
287             This program is distributed in the hope that it will be useful,
288             but WITHOUT WARRANTY; without even the implied warranty of
289             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
290              
291             =cut
292              
293             # Local Variables:
294             # mode: perl
295             # tab-width: 3
296             # End: