EMDIS-ECS
view release on metacpan or search on metacpan
lib/EMDIS/ECS.pm view on Meta::CPAN
#!/usr/bin/perl -w
#
# Copyright (C) 2002-2026 National Marrow Donor Program. All rights reserved.
#
# For a description of this module, please refer to the POD documentation
# embedded at the bottom of the file (e.g. perldoc EMDIS::ECS).
package EMDIS::ECS;
use Authen::SASL qw(Perl);
use CPAN::Version;
use Fcntl qw(:DEFAULT :flock);
use File::Basename;
use File::Copy;
use File::Spec::Functions qw(catfile);
use File::Temp qw(tempfile);
use IO::File;
use IO::Handle;
use IPC::Open2;
use MIME::Base64;
use Net::SMTP;
use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS
$ECS_CFG $ECS_NODE_TBL $FILEMODE @LOG_LEVEL
$configured $pidfile $cmd_output $pid_saved);
# load OS specific modules at compile time, in BEGIN block
BEGIN
{
if( $^O =~ /MSWin32/ )
{
# Win32 only modules
eval "require Win32::Process";
}
}
# module/package version
$VERSION = '0.49';
# file creation mode (octal, a la chmod)
$FILEMODE = 0660;
# subclass Exporter and define Exporter set up
require Exporter;
@ISA = qw(Exporter);
@EXPORT = (); # items exported by default
@EXPORT_OK = (); # items exported by request
%EXPORT_TAGS = ( # tags for groups of items
ALL => [ qw($ECS_CFG $ECS_NODE_TBL $FILEMODE $VERSION
load_ecs_config delete_old_files dequote ecs_is_configured
log log_debug log_info log_warn log_error log_fatal
copy_to_dir move_to_dir read_ecs_message_id
send_admin_email send_amqp_message send_ecs_message
send_email send_encrypted_message format_datetime
format_doc_filename
format_msg_filename openpgp_decrypt openpgp_encrypt
pgp2_decrypt pgp2_encrypt check_pid save_pid
timelimit_cmd remove_pidfile trim valid_encr_typ EOL
is_yes is_no get_oauth_token) ] );
Exporter::export_ok_tags('ALL'); # use tag handling fn to define EXPORT_OK
BEGIN {
$configured = ''; # boolean indicates whether ECS has been configured
@LOG_LEVEL = ('DEBUG', 'INFO', 'WARNING', 'ERROR', 'FATAL');
$pid_saved = '';
}
# ----------------------------------------------------------------------
# Return platform specific end-of-line string
sub EOL
{
return "\r\n" if $^O =~ /MSWin32/;
return "\n";
}
# ----------------------------------------------------------------------
# test for YES or TRUE
sub is_yes
{
my $val = shift;
return 0 if not defined $val;
return 1 if $val =~ /^\s*YES\s*$/io or $val =~ /^\s*TRUE\s*$/io;
return 0;
}
# ----------------------------------------------------------------------
# test for NO or FALSE
sub is_no
{
my $val = shift;
return 0 if not defined $val;
return 1 if $val =~ /^\s*NO\s*$/io or $val =~ /^\s*FALSE\s*$/io;
return 0;
}
# ----------------------------------------------------------------------
# Load ECS configuration into global variables.
# returns empty string if successful or error message if error encountered
sub load_ecs_config
{
lib/EMDIS/ECS.pm view on Meta::CPAN
my @stat = stat $filename;
if($stat[9] < $cutoff_time)
{
unlink $filename
or warn "Unable to delete file: $filename";
}
}
}
# ----------------------------------------------------------------------
# Return string value with enclosing single or double quotes removed.
sub dequote {
my $str = shift;
return if not defined $str;
if($str =~ /^"(.*)"$/) {
$str = $1;
}
elsif($str =~ /^'(.*)'$/) {
$str = $1;
}
return $str;
}
# ----------------------------------------------------------------------
# Return boolean indicating whether ECS has been configured.
sub ecs_is_configured {
return $configured;
}
# ----------------------------------------------------------------------
# Write message to ECS log file. Takes two arguments: a level which is
# used to classify logged messages and the text to be logged.
# Push an aditional email to admin if the error is encountering
# the MAIL_LEVEL.
# Returns empty string if successful or error message if error encountered.
sub log {
if(not ecs_is_configured()) {
my $warning = "EMDIS::ECS::log(): ECS has not been configured.";
warn "$warning\n";
return $warning;
}
my $cfg = $ECS_CFG;
my $level = shift;
$level = '1' if (not defined $level) or
($level < 0) or ($level > $#LOG_LEVEL);
return if $level < $cfg->LOG_LEVEL && ! $cfg->ECS_DEBUG; # check log-level
my $text = join("\n ", @_);
$text = '' if not defined $text;
my $timestamp = localtime;
my $origin = $0;
my $log_msg = join("|",$timestamp,$origin,$LOG_LEVEL[$level],$text);
if('__STDOUT__' eq $cfg->LOG_FILE) {
print "$log_msg\n";
}
else {
my $setmode = not -e $cfg->LOG_FILE;
if(open LOG, ">>" . $cfg->LOG_FILE) {
print LOG "$log_msg\n";
close LOG;
chmod $FILEMODE, $cfg->LOG_FILE if $setmode;
}
else {
warn "Error within ECS library: $! " . $cfg->LOG_FILE;
print "$log_msg\n";
};
}
if ( $level >= $cfg->MAIL_LEVEL )
{
send_admin_email ($log_msg);
}
return '';
}
# logging subroutines for specific logging levels
sub log_debug { return &log(0, @_); }
sub log_info { return &log(1, @_); }
sub log_warn { return &log(2, @_); }
sub log_error { return &log(3, @_); }
sub log_fatal { return &log(4, @_); }
# ----------------------------------------------------------------------
# Copy file to specified directory. If necessary, rename file to avoid
# filename collision.
# Returns empty string if successful or error message if error encountered.
sub copy_to_dir {
my $filename = shift;
my $targetdir = shift;
my $err;
return "file not found: $filename" unless -f $filename;
return "directory not found: $targetdir" unless -d $targetdir;
# do some fancy footwork to avoid name collision in target dir,
# then copy file
my $basename = basename($filename);
my $template = $basename;
my $suffix = '';
if($basename =~ /^(\d{8}_\d{6}_(.+_)?).{4}(\..{3})$/) {
$template = "$1XXXX";
$suffix = $3;
}
else {
$template .= '_XXXX';
}
my ($fh, $tempfilename) = tempfile($template,
DIR => $targetdir,
SUFFIX => $suffix);
return "unable to open tempfile in directory $targetdir: $!"
unless $fh;
$err = "unable to copy $filename to $tempfilename: $!"
unless copy($filename, $fh);
close $fh;
chmod $FILEMODE, $tempfilename;
return $err;
}
# ----------------------------------------------------------------------
# Move file to specified directory. If necessary, rename file to avoid
# filename collision.
# Returns empty string if successful or error message if error encountered.
sub move_to_dir {
my $filename = shift;
my $targetdir = shift;
my $err = copy_to_dir($filename, $targetdir);
unlink $filename unless $err;
return $err;
}
# ----------------------------------------------------------------------
# Execute AUTHN_OAUTH_TOKEN_CMD to get OAuth access token
# Returns two-element list: ($err, $access_token)
sub get_oauth_token {
my $timelimit = shift;
my $token_cmd = shift;
my $desc = shift;
# execute command
my $err = timelimit_cmd($timelimit, $token_cmd);
return("EMDIS::ECS::get_oauth_token(): $desc command execution failed: $err", undef)
if $err;
# get command output from module-level variable
my $access_token = $EMDIS::ECS::cmd_output
or return("EMDIS::ECS::get_oauth_token(): $desc command returned no access token", undef);
chomp $access_token; # remove any trailing EOL, just in case
return('', $access_token);
}
# ----------------------------------------------------------------------
# Read ECS message id from specified file. File is presumed to be in the
# format of an email message; message id is comprised of node_id and seq_num,
# with optional $part_num and $num_parts or DOC suffix.
# Returns empty array if unable to retrieve ECS message id from file.
sub read_ecs_message_id
{
my $filename = shift;
return "EMDIS::ECS::read_ecs_message_id(): ECS has not been configured."
unless ecs_is_configured();
my $mail_mrk = $ECS_CFG->MAIL_MRK;
my $fh = new IO::File;
return () unless $fh->open("< $filename");
while(<$fh>) {
/^Subject:.*$mail_mrk:(\S+?):(\d+):(\d+)\/(\d+)\s*$/io and do {
return ($1,$2,$3,$4,0);
};
/^Subject:.*$mail_mrk:(\S+?):(\d+)\s*$/io and do {
return ($1,$2,1,1,0);
};
/^Subject:.*$mail_mrk:(\S+?):(\d+):DOC\s*$/io and do {
return ($1,$2,1,1,1);
};
/^Subject:.*$mail_mrk:(\S+)\s*$/io and do {
return ($1,undef,undef,undef,0);
};
/^$/ and last; # blank line marks end of mail headers
}
close $fh;
return (); # return empty array
}
# ----------------------------------------------------------------------
# Send email to administrator and also archive the email message in the
# mboxes/out directory. Takes one or more arguments: the body lines to
# be emailed.
# Returns empty string if successful or error message if error encountered.
# Also logs error if error encountered.
sub send_admin_email {
my $err = '';
$err = "EMDIS::ECS::send_admin_email(): ECS has not been configured."
unless ecs_is_configured();
my $cfg = $ECS_CFG;
# record message contents in 'out' file
if(not $err) {
my $template = format_datetime(time, '%04d%02d%02d_%02d%02d%02d_XXXX');
my ($fh, $filename) = tempfile($template,
DIR => $cfg->ECS_MBX_OUT_DIR,
SUFFIX => '.msg');
$err = "EMDIS::ECS::send_admin_email(): unable to create 'out' file"
unless $fh;
if($fh) {
print $fh @_;
close $fh;
chmod $FILEMODE, $filename;
}
}
if(not $err)
{
my @recipients = split /,/, $cfg->ADM_ADDR;
foreach my $recipient (@recipients)
{
$err = send_email($recipient, '[' . $cfg->MAIL_MRK . '] ECS Error',
undef, "Origin: $0\n", @_);
log_error("Unable to send admin email to $recipient: $err")
if $err and $_[$#_] !~ /Unable to send admin email/iso;
}
}
return $err;
}
# ----------------------------------------------------------------------
# Send ECS email message.
# Returns empty string if successful or error message if error encountered.
sub send_ecs_message {
my $node_id = shift;
my $seq_num = shift;
# @_ now contains message body
# initialize
return "EMDIS::ECS::send_ecs_message(): ECS has not been configured."
unless ecs_is_configured();
my $cfg = $ECS_CFG;
my $node_tbl = $ECS_NODE_TBL;
my $err = '';
# do some validation
my ($hub_rcv, $hub_snd);
if($seq_num && !$node_id) {
# parse FML to determing $node_id:
# do some cursory validation, extract HUB_RCV and HUB_SND
my $fml = join('', @_);
return "EMDIS::ECS::send_ecs_message(): message does not contain valid FML"
unless $fml =~ /^.+:.+;/s;
if($fml =~ /HUB_RCV\s*=\s*([^,;]+)/is) { # presumes [^,;] in HUB_RCV
$hub_rcv = dequote(trim($1));
}
else {
return "EMDIS::ECS::send_ecs_message(): message does not specify " .
"HUB_RCV";
}
if($fml =~ /HUB_SND\s*=\s*([^,;]+)/is) { # presumes [^,;] in HUB_SND
$hub_snd = dequote(trim($1));
}
else {
return "EMDIS::ECS::send_ecs_message(): message does not specify " .
"HUB_SND";
}
return "EMDIS::ECS::send_ecs_message(): HUB_SND is incorrect: $hub_snd"
unless $hub_snd eq $ECS_CFG->THIS_NODE;
$node_id = $hub_rcv unless $node_id;
return "EMDIS::ECS::send_ecs_message(): node_id ($node_id) and FML " .
lib/EMDIS/ECS.pm view on Meta::CPAN
$node_tbl->ERROR;
}
my $node = $node_tbl->read($node_id);
if(not $node) {
$node_tbl->unlock() unless $was_locked; # unlock node_tbl if needed
return "EMDIS::ECS::send_ecs_message(): node not found: " . $node_id;
}
if(not $node->{addr}) {
$node_tbl->unlock() unless $was_locked; # unlock node_tbl if needed
return "EMDIS::ECS::send_ecs_message(): addr not defined for node: $node_id";
}
if($seq_num =~ /auto/i) {
# automatically get next sequence number
$node->{out_seq}++;
$seq_num = $node->{out_seq};
}
my $subject = $cfg->MAIL_MRK . ':' . $cfg->THIS_NODE;
$subject .= ":$seq_num" if $seq_num;
my $filename;
# if not meta-message, copy to mboxes/out_NODE subdirectory
if($seq_num) {
$filename = format_msg_filename($node_id,$seq_num);
# create directory if it doesn't already exist
my $dirname = dirname($filename);
mkdir $dirname unless -e $dirname;
}
else {
# if meta-message, copy to mboxes/out subdirectory
$filename = sprintf("%s_%s_%s.msg",
$cfg->THIS_NODE, $node_id, "META");
my $dirname = $cfg->ECS_MBX_OUT_DIR;
# create directory if it doesn't already exist
mkdir $dirname unless -e $dirname;
$filename = catfile($dirname, $filename);
}
# don't overwrite $filename file if it already exists
my $fh;
if(-e $filename) {
my $template = $filename . "_XXXX";
($fh, $filename) = tempfile($template);
return "EMDIS::ECS::send_ecs_message(): unable to open _XXXX file: " .
"$filename"
unless $fh;
}
else {
$fh = new IO::File;
return "EMDIS::ECS::send_ecs_message(): unable to open file: " .
"$filename"
unless $fh->open("> $filename");
}
$fh->print("Subject: $subject\n");
$fh->print("To: $node->{addr}\n");
$fh->print("From: " . $cfg->SMTP_FROM . "\n\n");
$fh->print(@_);
$fh->close();
chmod $FILEMODE, $filename;
if ( $err ) {
$err = "EMDIS::ECS::send_ecs_message(): unable to update node $node_id: $err";
}
elsif ( not $seq_num and ($node->{encr_meta} !~ /true/i) ) {
# if indicated, don't encrypt meta-message
if(is_yes($cfg->ENABLE_AMQP) and exists $node->{amqp_addr_meta} and $node->{amqp_addr_meta}) {
# send meta-message via AMQP (if indicated by node config)
$err = send_amqp_message(
$node->{amqp_addr_meta},
$subject,
$node,
undef,
@_);
}
elsif(is_yes($node->{amqp_only})) {
$err = "EMDIS::ECS::send_ecs_message(): unable to send " .
"email META message to node " . $node->{node} .
": amqp_only selected.";
}
else {
$err = send_email($node->{addr}, $subject, undef, @_);
}
}
else {
# otherwise, send encrypted message
$err = send_encrypted_message(
$node->{encr_typ},
$node->{addr_r},
$node->{addr},
$node->{encr_out_keyid},
$node->{encr_out_passphrase},
$node,
$subject,
undef,
@_);
}
if ( ! $err ) {
# update node last_out, possibly out_seq
$node->{last_out} = time();
$err = $node_tbl->ERROR
unless $node_tbl->write($node_id, $node);
}
$node_tbl->unlock() # unlock node_tbl
unless $was_locked;
return $err;
}
# ----------------------------------------------------------------------
# Send email message. Takes four or more arguments: the recipient,
# subject line, custom headers (hash ref), and body lines to be emailed.
# Returns empty string if successful or error message if error encountered.
sub send_email {
my $recipient = shift;
my $subject = shift;
my $custom_headers = shift;
# @_ now contains message body
lib/EMDIS/ECS.pm view on Meta::CPAN
if $send_opts->{amqp_truststore};
$cmd .= sprintf(' --sslcert %s --sslkey %s',
$send_opts->{amqp_sslcert},
$send_opts->{amqp_sslkey})
if $send_opts->{amqp_sslcert} and $send_opts->{amqp_sslkey};
$cmd .= sprintf(' --username %s', $send_opts->{amqp_username})
if $send_opts->{amqp_username};
foreach my $prop (keys %$send_props) {
$cmd .= sprintf(' --property %s=%s', $prop, $send_props->{$prop})
if $send_props->{$prop};
}
# set environment variables containing passwords:
# ECS_AMQP_PASSWORD and ECS_AMQP_SSLPASS
$ENV{ECS_AMQP_PASSWORD} = $send_opts->{amqp_password}
if $send_opts->{amqp_password};
$ENV{ECS_AMQP_SSLPASS} = $send_opts->{amqp_sslpass}
if $send_opts->{amqp_sslpass};
# execute command to send AMQP message
print "<DEBUG>: AMQP send command: $cmd\n"
if $ECS_CFG->ECS_DEBUG > 0;
my $err = timelimit_cmd($ECS_CFG->AMQP_SEND_TIMELIMIT, $cmd, join('', @_));
if($err) {
return "send_amqp_message(): unable to send AMQP message to $amqp_addr: $err";
}
return '';
}
# ----------------------------------------------------------------------
# Send encrypted email message.
# Returns empty string if successful or error message if error encountered.
sub send_encrypted_message
{
my $encr_typ = shift;
my $encr_recip = shift;
my $recipient = shift;
my $encr_out_keyid = shift;
my $encr_out_passphrase = shift;
my $node = shift;
my $subject = shift;
my $custom_headers = shift;
# @_ now contains message body
return "EMDIS::ECS::send_encrypted_message(): ECS has not been configured."
unless ecs_is_configured();
my $cfg = $ECS_CFG;
# compose template for name of temp file
my $template = format_datetime(time, '%04d%02d%02d_%02d%02d%02d_XXXX');
# write message body to temp file
my ($fh, $filename) = tempfile($template,
DIR => $cfg->ECS_TMP_DIR,
SUFFIX => '.tmp');
return "EMDIS::ECS::send_encrypted_message(): unable to create temporary file"
unless $fh;
print $fh @_;
close $fh;
chmod $FILEMODE, $filename;
# create file containing encrypted message
my $encr_filename = "$filename.pgp";
my $result = '';
for ($encr_typ) {
/PGP2/i and do {
$result = pgp2_encrypt($filename, $encr_filename, $encr_recip,
$encr_out_keyid, $encr_out_passphrase);
last;
};
/OpenPGP/i and do {
$result = openpgp_encrypt($filename, $encr_filename, $encr_recip,
$encr_out_keyid, $encr_out_passphrase);
last;
};
$result = "unrecognized encr_typ: $encr_typ";
}
# delete first temp file
unlink $filename;
# check for error
return "EMDIS::ECS::send_encrypted_message(): $result" if $result;
# read contents of encrypted file
$fh = new IO::File;
return "EMDIS::ECS::send_encrypted_message(): unable to open file: " .
"$encr_filename"
unless $fh->open("< $encr_filename");
my @body = $fh->getlines();
$fh->close();
# delete encrypted (temp) file
unlink $encr_filename;
if(is_yes($cfg->ENABLE_AMQP)) {
# send message via AMQP, if indicated by node config
my $amqp_addr = '';
if($subject =~ /^[^:]+:[^:]+$/io) {
return "EMDIS::ECS::send_encrypted_message(): unable to send " .
"AMQP META message to node " . $node->{node} . ": amqp_only " .
"selected, but amqp_addr_meta not configured."
if not $node->{amqp_addr_meta} and is_yes($node->{amqp_only});
$amqp_addr = $node->{amqp_addr_meta};
}
elsif($subject =~ /^[^:]+:[^:]+:[0123456789]+:DOC/io) {
return "EMDIS::ECS::send_encrypted_message(): unable to send " .
"AMQP document to node " . $node->{node} . ": amqp_only " .
"selected, but amqp_addr_doc not configured."
if not $node->{amqp_addr_doc} and is_yes($node->{amqp_only});
$amqp_addr = $node->{amqp_addr_doc};
}
elsif($subject =~ /^[^:]+:[^:]+:[0123456789]+/io) {
return "EMDIS::ECS::send_encrypted_message(): unable to send " .
"AMQP regular message to node " . $node->{node} . ": amqp_only " .
"selected, but amqp_addr_msg not configured."
if not $node->{amqp_addr_msg} and is_yes($node->{amqp_only});
$amqp_addr = $node->{amqp_addr_msg};
}
elsif(is_yes($node->{amqp_only})) {
lib/EMDIS/ECS.pm view on Meta::CPAN
my $encr_out_keyid = shift;
my $encr_out_passphrase = shift;
# initialize
return "EMDIS::ECS::pgp2_encrypt(): ECS has not been configured."
unless ecs_is_configured();
my $cfg = $ECS_CFG;
# compose command
my $keyid = (defined $encr_out_keyid and 0 < length $encr_out_keyid) ?
$encr_out_keyid : $cfg->PGP_KEYID;
my $cmd = $cfg->PGP2_CMD_ENCRYPT;
$cmd =~ s/__INPUT__/$input_filename/g;
$cmd =~ s/__OUTPUT__/$output_filename/g;
$cmd =~ s/__RECIPIENT__/$recipient/g;
$cmd =~ s/__SELF__/$keyid/g;
print "<DEBUG> pgp2_encrypt() command: $cmd\n"
if $cfg->ECS_DEBUG > 0;
# set PGPPATH and PGPPASS environment variables
$ENV{PGPPATH} = $cfg->PGP_HOMEDIR;
my $passphrase = (defined $encr_out_passphrase and 0 < length $encr_out_passphrase) ?
$encr_out_passphrase : $cfg->PGP_PASSPHRASE;
$ENV{PGPPASS} = $passphrase;
# attempt to execute command - pipe passphrase to cmd, to support usage of gpg1 in place of pgp2
my $result = timelimit_cmd($cfg->T_MSG_PROC, $cmd, $passphrase);
$result = "EMDIS::ECS::pgp2_encrypt(): $result" if $result;
return $result;
}
# ----------------------------------------------------------------------
# Check whether another copy of the program is already running.
# If so, this one dies.
sub check_pid
{
die "EMDIS::ECS::check_pid(): ECS has not been configured."
unless ecs_is_configured();
if(open PIDFILE, $pidfile) {
my $pid = <PIDFILE>;
$pid =~ s/\s+//g;
die "Error: $0 is already running (pid $pid).\n"
if kill(0, $pid);
close PIDFILE;
}
save_pid();
}
# ----------------------------------------------------------------------
# Update PID file.
sub save_pid
{
die "EMDIS::ECS::save_pid(): ECS has not been configured."
unless ecs_is_configured();
open PIDFILE, ">$pidfile";
print PIDFILE "$$\n";
close PIDFILE;
chmod $FILEMODE, $pidfile;
$pid_saved = 1;
}
# ----------------------------------------------------------------------
# Select the Win32 or Unix version of timelimit_cmd
sub timelimit_cmd
{
$^O =~ /MSWin32/ ? timelimit_cmd_win32(@_) : timelimit_cmd_unix(@_);
}
# Returns empty string if successful or error message if error encountered.
sub timelimit_cmd_win32
{
my $timelimit = shift;
my $cmd = shift;
my $input_data = shift;
my $cfg = $ECS_CFG;
my @msgs = ();
my $result = "";
my ($ProcessObj, $rc, $appname, $cmdline);
# reset module-level variable containing command output
$cmd_output = '';
pipe(READ, WRITE);
select(WRITE);
$| = 1;
select(STDOUT);
open(OLDIN, "< &STDIN") || die "Can not save STDIN\n";
open(STDIN, "< &READ") || die "Can not redirect STDIN\n";
open(OLDOUT, ">&STDOUT") || die "Can not save STDOUT\n";
open(STDOUT, ">$$.txt" ) || die( "Unable to redirect STDOUT ");
open(OLDERR, ">&STDERR" ) || die "Can not redirect STDERR\n";
open(STDERR, ">&STDOUT" ) || die( "Unable to dup STDOUT to STDERR" );
select(STDERR);
$| = 1;
select(STDIN);
$| = 1;
select(STDOUT);
if(! defined $input_data) { $input_data = ""; }
# compute $appname and $cmdline
$cmd =~ /\s*(\S+)\s*(.*)/;
$appname = $1;
$cmdline = "$1 $2";
# if applicable, append .exe or .bat extension to $appname
if(-x "$appname.exe")
{
$appname = "$appname.exe";
}
elsif(-x "$appname.bat")
{
$appname = "$appname.bat";
}
( run in 0.629 second using v1.01-cache-2.11-cpan-39bf76dae61 )