view release on metacpan or  search on metacpan

lib/CohortExplorer/Application/Opal/Datasource.pm  view on Meta::CPAN

package CohortExplorer::Application::Opal::Datasource;

use strict;
use warnings;

our $VERSION = 0.14;

use base qw(CohortExplorer::Datasource);
use JSON qw( decode_json );

#-------
sub authenticate {
 my ( $self, %opts ) = @_;
 my $ds_name = $self->name;
 require LWP::UserAgent;
 require MIME::Base64;

 # Authenticate using Opal url
 # Default Opal url is http://localhost:8080
 my $ua = LWP::UserAgent->new( timeout => 10, ssl_opts => { verify_hostname => 0 } );
(my $url = $self->url || 'http://localhost:8080' ) =~ s/\/$//;
 my $req = HTTP::Request->new( GET => $url . "/ws/datasource/$ds_name" );
 $req->header(
             Authorization => "X-Opal-Auth "
               . MIME::Base64::encode( join ':', @opts{qw/username password/} ),
             Accept => "application/json"
 );
 my $res  = $ua->request($req);
 my $code = $res->code;
 if ( $code == 200 ) {
  my $json = decode_json( $res->decoded_content );
  if ( $json->{type} ne 'mongodb' ) {

   # Successful authentication returns tables and views accessible to the user
   my %view = map { $_ => 1 } @{ $json->{view} || [] };
   my @tables = @{ $json->{table} || [] };

   # Get all base tables ( i.e. exclude views )
   my @base_tables =
     defined $json->{view} ? grep { not $view{$_} } @tables : @tables;
   if ( @base_tables == 0 ) {
    die "No tables but views found in $ds_name\n";
   }
   return \@base_tables;
  }
  else {
   die "Storage type for $ds_name is not MySQL but MongoDB\n";
  }
 }
 elsif ( $code == 401 ) {
  return;
 }
 else {
  die "Failed to connect to Opal server using '$url' (error $code)\n";
 }
}

sub additional_params {
 my ( $self, $res, %opts ) = @_;
 my $ds_name = $self->name;

 # By default,
 # datasource type is standard (i.e. cross-sectional)
 # entity_type is participant
 # id_visit_separator is '_' (valid to longitudinal datasources only)
 my %param = (
               type        => $self->type        || 'standard',
               entity_type => $self->entity_type || 'Participant',
               allowed_tables => $res,
               username       => $opts{username}
 );

 if ( $param{type} eq 'longitudinal' ) {
     $param{id_visit_separator} = $self->id_visit_separator || '_';

  # Get static tables (if any) from datasource-config.properties and check them against @allowed_tables
  my @static_tables = ();
  my %table = map { $_ => 1 } @{ $param{allowed_tables} };
  $param{static_tables} = $self->static_tables || undef;
  if ( $param{static_tables} ) {
   for ( split /,\s*/, $param{static_tables} ) {
    push @static_tables, $_ if ( $table{$_} );
   }
  }
  $param{static_tables} = \@static_tables;
 }
 else {

  # id_visit_separator and visit_max is undefined for standard datasources
  @param{qw/id_visit_separator visit_max static_tables/} =
    ( undef, undef, $param{allowed_tables} );
 }

 # Get list of allowed variables from each table
 my $ua = LWP::UserAgent->new( timeout => 10, ssl_opts => { verify_hostname => 0 } );
(my $url = $self->url || 'http://localhost:8080' ) =~ s/\/$//;
 for my $t ( @{ $param{allowed_tables} } ) {
  my $entity_req =
    HTTP::Request->new(
                    GET => $url . "/ws/datasource/$ds_name/table/$t/entities" );
  $entity_req->header(
             Authorization => "X-Opal-Auth "
               . MIME::Base64::encode( join ':', @opts{qw/username password/} ),
             Accept => "application/json"
  );
  my $entity_res = $ua->request($entity_req);

  # Get the first identifier
  if ( $entity_res->code == 200 ) {
   my $decoded_json = decode_json( $entity_res->decoded_content );
   my $var_req =
     HTTP::Request->new(   GET => $url
                         . "/ws/datasource/$ds_name/table/$t/valueSet/"
                         . ( $decoded_json->[0]->{identifier} || '' ) );
   $var_req->header(
             Authorization => "X-Opal-Auth "
               . MIME::Base64::encode( join ':', @opts{qw/username password/} ),
             Accept => "application/json"
   );
   my $var_res = $ua->request($var_req);

   # Get all variables with accessible values
   if ( $var_res->code == 200 ) {
    $decoded_json = decode_json( $var_res->decoded_content );
    push @{ $param{allowed_variables} },
      map { "$t.$_" } @{ $decoded_json->{variables} };
   }
   else {
    die "Failed to fetch variable list via $url (error "
      . $var_res->code . ")\n";
   }
  }
  else {
   die "Failed to fetch variable list via $url (error "
     . $entity_res->code . ")\n";
  }
 }
 return \%param;
}

sub entity_structure {
 my ($self) = @_;
 my %struct = (
  -columns => [
                variable => 'var.name',
                value    => 'vsv.value',
                table    => 'vt.name'
  ],
  -from => [
   -join =>
     qw/variable_entity|ve id=variable_entity_id value_set|vs <=>{value_table_id=id} value_table|vt <=>{vs.id=value_set_id} value_set_value|vsv <=>{vsv.variable_id=id} variable|var <=>{vt.datasource_id=id} datasource|ds/
  ],
  -where => {
              've.type' => $self->entity_type,
              'ds.name' => $self->name
  }
 );

# For longitudinal datasources split identifier into entity_id and visit using id_split_separator
 if ( $self->type eq 'longitudinal' ) {
  my $id_visit_sep = $self->id_visit_separator;
  push @{ $struct{-columns} },
    entity_id => "SUBSTRING_INDEX( ve.identifier, '$id_visit_sep', 1)";
  my $visit = "CAST( SUBSTRING_INDEX( ve.identifier, '$id_visit_sep', IF( ve.identifier RLIKE '$id_visit_sep\[0-9\]+\$', -1, NULL ) ) AS UNSIGNED )";

  # Check for the presence of id_visit_sep
  push @{ $struct{-columns} }, visit => $visit;
  $struct{-order_by} = $visit;
 }
 else {
  push @{ $struct{-columns} }, entity_id => 've.identifier';
 }