./TravEpi/TRhIP/App.pm

• package MGH_Biostat::TravEpi::TRhIP::App
  • new
  • dispatch
  • recommendations
  • showrules
  • showlogs
  • _hash_to_hasharray
  • _check_parameter_errors
  • _synthesize_variables
  • _add_summary_variables
  • _format_dynamic_text
• __END__
• EOF

package MGH_Biostat::TravEpi::TRhIP::App;
use Modern::Perl '2012';
use experimental 'switch';
use utf8;

use Plack::Request;
use Template::Simple;
use File::Slurp qw(slurp read_dir);
use Encode;
use URI;
use HTML::FillInForm;
use HTTP::AcceptLanguage;
use Digest::SHA qw(sha256_hex);
use Set::Tiny qw(set);

use Package::Alias 'M_B::Countries' => 'MGH_Biostat::TravEpi::SimpleRulesBase::Countries';
use MGH_Biostat::TravEpi::SimpleRulesBase::Rules;
use MGH_Biostat::TravEpi::SimpleRulesBase::Translator;
use MGH_Biostat::TravEpi::SimpleRulesBase::DynamicText;

my $INCLUDE_DEBUG_INFORMATION = 0;

# #####################################################################################
# Object creation and initialization
# #####################################################################################

sub new {
    my $class = shift;
    my $self = bless {}, $class;

    # template engine
    $self->{'tmpl'} = Template::Simple->new(
        token_re                  => qr/[.\w-]+?/,
        search_dirs               => [ qw/templates/ ],
        disallow_template_strings => 1,
        template_binmode          => ':encoding(UTF-8)',
        pre_delim                 => qr/\<\?ts/,
        post_delim                => qr/\?\>/,
    );

    # create the lookout engines
    $self->{'translator'} = MGH_Biostat::TravEpi::SimpleRulesBase::Translator->new();

    # for each valid language, create a template of the questions and recommendations in that language
    # enclosed in the website shell
    my $shell_template = ${ $self->{'tmpl'}->_get_template('shell') };
    foreach my $class (qw(questions recommendations)) {
        my $class_template    = ${ $self->{'tmpl'}->_get_template($class) };
        my $composed_template = ( $shell_template =~ s/!!\$content/$class_template/r );
        foreach my $l ( $self->{'translator'}->valid_languages()->elements() ) {
            $self->{'tmpl'}->add_templates( { $class . '.' . $l => $self->{'translator'}->translate_template( $l, $composed_template ) } );
        }
    }

    # load the rules
    $self->{'rules'} = MGH_Biostat::TravEpi::SimpleRulesBase::Rules->new();

    return $self;
}

# #####################################################################################
# Page handlers
# #####################################################################################

sub dispatch {
    my $self              = shift;
    my $env               = shift;
    my $req               = Plack::Request->new($env);
    my $params            = $req->parameters;
    my $_known_parameters = [ qw(hash age destination1 destination2 destination3 destination4 submit) ];

    # get the preferred language
    my $lang = $params->{'lang'}
      || HTTP::AcceptLanguage->new( $req->header('Accept-Language') )->match( @{ $self->{'translator'}->ordered_languages() } )
      || $self->{'translator'}->default_language()
      ;
    if ( !$self->{'translator'}->is_valid_language($lang) ) {
        die("Invalid language specified.\n");
    }

    my $data = {
        '_lang'            => $lang,
        '_othlang_include' => [],
        '_errors'          => '',
        '_template'        => 'questions',
    };

  DISPATCH_LOGIC: {

        # if there is no hash provided, this is the start of a new request
        $data->{'_hash'} = $params->{'hash'};
        if ( !defined( $data->{'_hash'} ) or ( $data->{'_hash'} eq '' ) ) {
            $data->{'_hash'} = sha256_hex( 'trhip' . localtime() . $$ . rand(10000) );
            last DISPATCH_LOGIC;
        }

        # if the "submitted" value doesn't exist, we're just changing languages
        # this should never be reached (right now), because we don't include the hash
        # in the keys to encode in the url
        # (ie, this may be a useless check and should possibly be removed. I'm leaving it
        # in case we decide we do want to track language changes for the questions page.)
        my $submitted = $params->{'submit'};
        if ( !$submitted ) {
            last DISPATCH_LOGIC;
        }

        # copy the original parameters into the data structure
        $data->{'_parameters'} = { map { $_ => ( $params->{$_} // '' ) } @$_known_parameters };

        # check for parameter errors
        $data->{'_errors'} = _check_parameter_errors( $data->{'_parameters'} );
        if ( $data->{'_errors'} ) {
            last DISPATCH_LOGIC;
        }

        # at this point, everything in good, so generate some recommendations
        $data->{'_template'}        = 'recommendations';
        $data->{'_othlang_include'} = $_known_parameters;
        $data->{'_variables'}       = _synthesize_variables( $data->{'_parameters'} );
        $data->{'_generated'}       = $self->recommendations( $data->{'_variables'}, $data );
    }

    foreach my $l ( @{ $self->{'translator'}->ordered_languages() } ) {
        next if ( $l eq $lang );
        my $u = URI->new('trhip');
        $u->query_form( 'lang' => $l, map { $_ => $data->{'_parameters'}{$_} } grep { $data->{'_parameters'}{$_} } @{ $data->{'_othlang_include'} } );
        push @{ $data->{'_other_languages_list'} }, { 'uri' => $u->as_string(), 'text' => $self->{'translator'}->get_inlanguage($l) };
    }

    my $out = {
        '_lang'                 => $data->{'_lang'},
        '_hash'                 => $data->{'_hash'},
        '_other_languages_list' => $data->{'_other_languages_list'},
        '_errors'               => $data->{'_errors'},
        '_generated'            => $data->{'_generated'} // '',
        '_debug'                => '',
    };

    if ($INCLUDE_DEBUG_INFORMATION) {
        use Data::Dump 'pp';
        $out->{'_debug'}{'_debug_text'} =
          "ENV:\n" . pp($env) . "\n\n" .
          "PARAMS:\n" . pp($params) . "\n\n" .
          "DATA\n" . pp($data) . "\n\n" .
          "OUT:\n" . pp($out)
          ;
    }

    # log the action
    $env->{'gten.logger'}->log( $env, $data->{'_hash'}, $lang, $data->{'_template'} );

    my $template = $data->{'_template'};

    my $res = $req->new_response(
        200,
        [ Content_Type => 'text/html; charset=utf-8' ],
        encode( 'utf-8', HTML::FillInForm->fill( $self->{'tmpl'}->render( "${template}.${lang}", $out ), $data->{'_parameters'} ) )
    );

    return $res->finalize();
}

sub recommendations {
    my $self = shift;
    my ( $vars, $info ) = @_;

    my $data = {};

    # put the summary variables in at the top
    $data->{'summary'} = _add_summary_variables($vars);

    # run the rules
    $self->{'rules'}->process_rule( 'master', $vars, $data );

    # add the destination links
    $data->{'cdc_links'} = newdt( 'destlinks', $vars->{'dests'}, { 'po-context' => 'Sort' } );

    # format any imported destinations
    $self->_format_dynamic_text( $data, $info->{'_lang'} );

    # it's a bit of a hack, but we want to add the hash value to the redirects, so we can use it at a higher level
    # @WARNING: this is a breach of data encapsulation...
    foreach ( @{ $data->{'cdc_links'} } ) {
        $_->{'dest_link'} .= '?' . $info->{'_hash'};
    }

    return $data;
}

sub showrules {
    my $self = shift;
    my $env  = shift;
    my $req  = Plack::Request->new($env);

    # get the template file
    my $tmpl = ${ $self->{'tmpl'}->_get_template('recommendations.en-US') };

    # although it would be great to use DOM::Tiny here to go through the instructions,
    # it doesn't work because it insists on making everything correct when it is inserted,
    # thus adding a '<div>' tag after the START instruction introduces a '</div>' where
    # we don't want it.
    # Thus, we are stuck falling back on regex.

    $tmpl =~ s/(<\?ts START .+?\?>)/$1<div class="rule-enclosure"><?ts _rule ?>/g;
    $tmpl =~ s/(<\?ts END .+?\?>)/<\/div>$1/g;

    # get the rule descriptions
    my $data = {
        '_generated' => {
            'master'    => $self->{'rules'}->describe_rule('master'),
            'summary'   => { 'age' => '[age]', 'dests' => '[list of destinations]' },
            'cdc_links' => { 'dest_link' => '#', 'dest_link_name' => '[list of destinations]' },
        },
    };

    my $res = $req->new_response( 200, [ Content_Type => 'text/html; charset=utf-8' ] );
    $res->body( encode( 'utf-8', ${ $self->{'tmpl'}->render( \$tmpl, $data ) } ) );
    return $res->finalize();
}

sub showlogs {
    my $self = shift;
    my $env  = shift;
    my $req  = Plack::Request->new($env);

    my $mindate = $req->param('min') || '0000-00-00';
    my $maxdate = $req->param('max') || '9999-99-99';

    use List::Util qw(minstr);
    use Socket;

    # read in all of the log files
    my @logs = grep { m/applog/; } read_dir( './logs', prefix => 1 );
    my $data = {};
    foreach my $f (@logs) {
        foreach my $line ( slurp( $f, 'chomp' => 1 ) ) {
            next unless ( $line =~ m/^keep:/ );
            $line =~ s/^keep: //;
            my ( $datetime, $hash, $ip, $lang, $action, $useragent, $extra ) = split( / ; /, $line );
            $useragent //= '';

            # process the date/time string
            my ( $date, $time ) = split( / /, $datetime );

            next if ( $date lt $mindate );
            next if ( $date gt $maxdate );

            push @{ $data->{'raw'}{$date}{$ip}{$hash} }, [ $time, $lang, $action ];
            push @{ $data->{'ips'}{$ip} }, $useragent;

        }
    }

    # clean up the ip to user agent mapping
    foreach my $fip ( keys %{ $data->{'ips'} } ) {
        $data->{'ips'}{$fip} = set( grep { $_; } @{ $data->{'ips'}{$fip} } );
    }

    foreach my $date ( sort keys %{ $data->{'raw'} } ) {

        my $processed = {
            'date'    => $date,
            'look'    => { count => 0 },
            'request' => { count => 0, numredirects => 0 },
            'items'   => [],
        };

        foreach my $ip ( sort keys %{ $data->{'raw'}{$date} } ) {

            foreach my $session ( keys %{ $data->{'raw'}{$date}{$ip} } ) {
                my $temp;
                $temp->{'time'} = '99:99:99';

                foreach my $ref ( @{ $data->{'raw'}{$date}{$ip}{$session} } ) {

                    my ( $time, $lang, $action ) = @$ref;
                    $temp->{'langs'}{$lang}++ unless ( $lang eq '!na' );

                    $temp->{'time'} = minstr( $temp->{'time'}, $time );

                    $temp->{'typecount'}{$action}++;
                    if ( ( $action eq 'questions' ) and !exists( $temp->{'type'} ) ) {
                        $temp->{'type'} = 'look';
                    }
                    if ( $action eq 'recommendations' ) {
                        $temp->{'type'} = 'request';
                    }
                    if ( $action =~ m/^redirect: (.+)/ ) {
                        $temp->{'redirects'}{$1}++;
                    }
                }
                push @{ $processed->{'items'} }, $temp;

                $processed->{ $temp->{'type'} }{'count'}++;

                foreach my $country ( keys %{ $temp->{'redirects'} } ) {
                    $processed->{'request'}{'redirects'}{'hash'}{$country} += $temp->{'redirects'}{$country};
                }
                if ( scalar( keys %{ $temp->{'redirects'} } ) ) {
                    $processed->{'request'}{'numredirects'}++;
                }

                my $langmax  = 0;
                my $langname = '';
                foreach my $lang ( keys %{ $temp->{'langs'} } ) {
                    if ( $temp->{'langs'}{$lang} > $langmax ) {
                        $langmax  = $temp->{'langs'}{$lang};
                        $langname = $lang;
                    }
                }
                $processed->{ $temp->{'type'} }{'langs'}{'hash'}{$langname}++;

                $processed->{ $temp->{'type'} }{'ips'}{'hash'}{$ip}++;
            }
        }

        foreach my $type (qw/look request/) {
            foreach my $subtype (qw/langs ips redirects/) {
                if ( scalar( keys %{ $processed->{$type}{$subtype}{'hash'} } ) ) {
                    $processed->{$type}{$subtype}{'array'} = _hash_to_hasharray( $processed->{$type}{$subtype}{'hash'}, 'key', 'count' );
                }
                else {
                    $processed->{$type}{$subtype} = '';
                }
            }

            if ( ref( $processed->{$type}{'ips'} ) ) {
                foreach ( @{ $processed->{$type}{'ips'}{'array'} } ) {
                    $_->{'useragents'} = join( '&#xD;&#xD;' => $data->{'ips'}{ $_->{'key'} }->members() );
                    if ( !defined( $_->{'useragents'} ) or ( $_->{'useragents'} eq '' ) ) {
                        $_->{'useragents'} = '(none)';
                    }
                }
            }
        }

        $data->{'processed'}{'total'}{'look'}      += $processed->{'look'}{'count'};
        $data->{'processed'}{'total'}{'request'}   += $processed->{'request'}{'count'};
        $data->{'processed'}{'total'}{'redirects'} += $processed->{'request'}{'numredirects'};

        push @{ $data->{'processed'}{'date'} }, $processed;
    }

    $data->{'processed'}{'mindate'} = $mindate;
    $data->{'processed'}{'maxdate'} = $maxdate;

    # get the template file
    my $tmpl = slurp( 'templates/log.tmpl', binmode => ':encoding(UTF-8)' );

    my $res = $req->new_response( 200, [ Content_Type => 'text/html; charset=utf-8' ] );
    $res->body( encode( 'utf-8', ${ $self->{'tmpl'}->render( \$tmpl, $data->{'processed'} ) } ) );
    return $res->finalize();
}

sub _hash_to_hasharray {
    my ( $hashref, $keyname, $valname ) = @_;
    my $ret = [];

    foreach my $k ( sort keys %$hashref ) {
        push @{$ret}, { $keyname => $k, $valname => $hashref->{$k} };
    }

    return $ret;
}

# #####################################################################################
# Parameter helper functions
# #####################################################################################

# verify that there are no missing values
sub _check_parameter_errors {
    my ($params) = @_;

    my $errors = {};

    if ( ( !$params->{'age'} ) or ( $params->{'age'} !~ m/^\s*\d+\s*$/ ) ) {
        $errors->{'age'} = {};
    }

    if ( !scalar( grep { $_ =~ m/\S/ } @{$params}{qw(destination1 destination2 destination3 destination4)} ) ) {    # ! note hash slice
        $errors->{'dests'} = {};
    }

    return ( %$errors ? $errors : '' );
}

# turn the parameters into the variables (ie, the sets, and undef if missing)
sub _synthesize_variables {
    my ($params) = @_;
    my $dests = set( [ grep { $_ =~ m/\S/; } @{$params}{qw(destination1 destination2 destination3 destination4)} ] );    # ! note hash slice

    my $vars = {};

    $vars->{'age'} = ( 0 + $params->{'age'} ) // undef;
    $vars->{'dests'} = M_B::Countries::mapped_countries($dests);
    if ( $vars->{'dests'}->is_empty() ) { $vars->{'dests'} = undef; }

    return $vars;
}

sub _add_summary_variables {
    my ($vars) = @_;

    # we know that these variables exist, because otherwise there would have been an error!
    return {
        'age'   => newdt( 'age',       $vars->{'age'} ),
        'dests' => newdt( 'countries', $vars->{'dests'} ),
    };

}

# go through the generated rule tree and realize any dynamic replacements
sub _format_dynamic_text {
    my $self = shift;
    my ( $tree, $lang ) = @_;

    foreach my $k ( keys %$tree ) {
        if ( ref( $tree->{$k} ) eq 'MGH_Biostat::TravEpi::SimpleRulesBase::DynamicText' ) {
            $tree->{$k} = $self->{'translator'}->translate_dynamic_text( $tree->{$k}, $lang );
        }
        elsif ( ref( $tree->{$k} ) eq 'HASH' ) {
            $self->_format_dynamic_text( $tree->{$k}, $lang )
        }
    }
}

1;

__END__