view release on metacpan or  search on metacpan

lib/Class/Usul/TraitFor/ConnectInfo.pm  view on Meta::CPAN

package Class::Usul::TraitFor::ConnectInfo;

use namespace::autoclean;

use Class::Usul::Constants   qw( EXCEPTION_CLASS CONFIG_EXTN FALSE TRUE );
use Class::Usul::Crypt::Util qw( decrypt_from_config );
use Class::Usul::File;
use Class::Usul::Functions   qw( merge_attributes throw );
use File::Spec::Functions    qw( catfile );
use Scalar::Util             qw( blessed );
use Unexpected::Functions    qw( Unspecified );
use Moo::Role;

requires qw( config ); # As a class method

my $_cache = {};

# Private functions
my $_connect_attr = sub {
   return [ qw( class ctlfile ctrldir database dataclass_attr extension
                prefix read_secure salt seed seed_file subspace tempdir ) ];
};

my $_get_cache_key = sub {
   my $param = shift;
   my $db    = $param->{database}
      or throw 'Class [_1] has no database name', [ $param->{class} ];

   return $param->{subspace} ? "${db}.".$param->{subspace} : $db;
};

my $_get_credentials_file = sub {
   my $param = shift; my $file = $param->{ctlfile};

   defined $file and -f $file and return $file;

   my $dir = $param->{ctrldir}; my $db = $param->{database};

      $dir or throw Unspecified, [ 'ctrldir' ];
   -d $dir or throw 'Directory [_1] not found', [ $dir ];
       $db or throw 'Class [_1] has no database name', [ $param->{class} ];

   $file = catfile( $dir, $db.($param->{extension} // CONFIG_EXTN) );

   -f $file and return $file;

   return catfile( $dir, 'connect-info'.($param->{extension} // CONFIG_EXTN) );
};

my $_get_dataclass_schema = sub {
   return Class::Usul::File->dataclass_schema( @_ );
};

my $_unicode_options = sub {
   return { mysql  => { mysql_enable_utf8 => TRUE },
            pg     => { pg_enable_utf8    => TRUE },
            sqlite => { sqlite_unicode    => TRUE }, };
};

my $_dump_config_data = sub {
   my ($param, $cfg_data) = @_;

   my $ctlfile = $_get_credentials_file->( $param );
   my $schema  = $_get_dataclass_schema->( $param->{dataclass_attr} );

   return $schema->dump( { data => $cfg_data, path => $ctlfile } );
};

my $_extract_creds_from = sub {
   my ($param, $cfg_data) = @_; my $key = $_get_cache_key->( $param );

   ($cfg_data->{credentials} and defined $cfg_data->{credentials}->{ $key })
      or throw 'Path [_1] database [_2] no credentials',
               [ $_get_credentials_file->( $param ), $key ];

   return $cfg_data->{credentials}->{ $key };
};

my $_get_connect_options = sub {
   my $creds = shift;
   my $uopt  = $creds->{unicode_option}
            // $_unicode_options->()->{ lc $creds->{driver} } // {};

   return { AutoCommit =>  $creds->{auto_commit  } // TRUE,
            PrintError =>  $creds->{print_error  } // FALSE,
            RaiseError =>  $creds->{raise_error  } // TRUE,
            %{ $uopt }, %{ $creds->{database_attr} // {} }, };
};

my $_load_config_data = sub {
   my $schema = $_get_dataclass_schema->( $_[ 0 ]->{dataclass_attr} );

   return $schema->load( $_get_credentials_file->( $_[ 0 ] ) );
};

# Private methods
my $_merge_attributes = sub {
   return merge_attributes { class => blessed $_[ 0 ] || $_[ 0 ] },
                  $_[ 1 ], ($_[ 2 ] // {}), $_connect_attr->();
};

# Public methods
sub dump_config_data {
   my ($self, $config, $db, $cfg_data) = @_;

   my $param = $self->$_merge_attributes( $config, { database => $db } );

   return $_dump_config_data->( $param, $cfg_data );
}

sub extract_creds_from {
   my ($self, $config, $db, $cfg_data) = @_;

   my $param = $self->$_merge_attributes( $config, { database => $db } );

   return $_extract_creds_from->( $param, $cfg_data );
}

sub get_connect_info {
   my ($self, $app, $param) = @_; $app //= $self; $param //= {};

   merge_attributes $param, $app->config, $self->config, $_connect_attr->();

   my $class    = $param->{class} = blessed $self || $self;
   my $key      = $_get_cache_key->( $param );

   defined $_cache->{ $key } and return $_cache->{ $key };

   my $cfg_data = $_load_config_data->( $param );
   my $creds    = $_extract_creds_from->( $param, $cfg_data );
   my $dsn      = 'dbi:'.$creds->{driver}.':database='.$param->{database};
   my $password = decrypt_from_config $param, $creds->{password};
   my $opts     = $_get_connect_options->( $creds );

   $creds->{host} and $dsn .= ';host='.$creds->{host};
   $creds->{port} and $dsn .= ';port='.$creds->{port};

   return $_cache->{ $key } = [ $dsn, $creds->{user}, $password, $opts ];
}

sub load_config_data {
   my ($self, $config, $db) = @_;