#!/usr/bin/perl =begin * provides same function as LIMS::Controller::Ajax::seek_new_messages * used for interval queries because HILIS function updates session atime so prevents idle timeout * doesn't work when called on port :8000 ?? * requires symlink in script/cgi -> logs =cut #------------------------------------------------------------------------------- my $LOG_QUERIES = 1; # logs/new_msgs.log #------------------------------------------------------------------------------- use strict; use warnings; use lib '/home/raj/perl5/lib/perl5'; # use CGI::Carp qw(fatalsToBrowser); # use for devel # use CGI::HTMLError (trace => 1); # don't want errs returning to browser ?? use CGI; use IO::All; use Template; use DateTime; use Path::Tiny; use Data::Dumper; use DBIx::Simple; use HTTP::BrowserDetect; use DateTime::Format::Strptime; use FindBin qw($RealBin); # warn $RealBin; use lib $RealBin . '/../../lib'; use LIMS::Local::Config; my $q = CGI->new(); print $q->header(); # otherwise get "Premature end of script headers" if script exits my $vars = $q->Vars(); # warn Dumper $vars; my $username = $vars->{username} || exit; # maybe not logged in my $service = $vars->{service} or die 'no service var passed'; # warn $service; my $tt = $vars->{tt}; # warn Dumper $tt; # exit if print-run or page where user can already see them: exit if grep $tt =~ /\b$_\.tt\Z/, qw(do hello user_messages); # set $ENV{CENTRE} *before* getting config: $ENV{CENTRE} = $service; my $config = LIMS::Local::Config->instance; # warn Dumper $config; my $dbix = DBIx::Simple->connect(@{ $config->{dbh_params} }); # warn $dbix->dbh->{mysql_thread_id}; # cgi script so no point using cached dbh's my $sql = q! SELECT COUNT(*) FROM user_message t1 JOIN users t2 ON (t1.recipient_id = t2.id) /* JOIN sessions t3 ON (t3.userid = t2.username) */ WHERE t1.`acknowledged` IS NULL AND /* t3.`time` >= DATE_SUB(NOW(), INTERVAL 10 MINUTE) AND */ t2.`username` = ?!; $dbix->query($sql, $username)->into(my $i); # warn $i; if ($i) { my $path = path($RealBin, '..', '..', 'templates')->realpath; my %data = ( count => $i, app_url => $vars->{url} ); my $tmpl = 'user/new_msg_alert.tt'; my $msg; Template->new({ INCLUDE_PATH => $path })->process($tmpl, \%data, \$msg); print $msg; } if ($LOG_QUERIES) { my $logfile = path($RealBin, 'logs', 'new_msgs.log')->realpath; # warn $logfile; my $format = DateTime::Format::Strptime->new(pattern => '%F %T'); my $time = DateTime->now(time_zone => 'Europe/London'); $time->set_formatter($format); # warn $dt; exit; # alternative to DateTime::Format: # no warnings 'redefine'; # sub DateTime::_stringify { shift->strftime('%F %T') } # warn DateTime->now->datetime . ':' . $username . '[' . $i . ']'; my $msg = sprintf "%s : %s [%s|%s] : %s : %s\n", $time, uc $username, $service, $ENV{REMOTE_ADDR}, $i, get_user_agent(); io($logfile)->append($msg); } sub get_user_agent { my $ua = HTTP::BrowserDetect->new($ENV{HTTP_USER_AGENT}); return sprintf '%s/%s-%s', map $ua->$_(), qw(os_string browser_string public_version); }