FTN-Outbound-BSO
view release on metacpan or search on metacpan
lib/FTN/Outbound/BSO.pm view on Meta::CPAN
package FTN::Outbound::BSO;
$FTN::Outbound::BSO::VERSION = '20180823';
use strict;
use warnings;
use utf8;
# fts-5005.003 BinkleyTerm Style Outbound
# except s/Continuous/Crash/g
use Log::Log4perl ();
use Scalar::Util ();
use Encode::Locale ();
use Encode ();
use File::Spec ();
use Fcntl ();
use FTN::Addr ();
use FTN::Outbound::Reference_file ();
my %flavour_extension = ( immediate => [ qw/ iut ilo / ], # Xut (netmail) Xlo (reference file) by fts-5005.003
# continuous => [ qw/ c c / ], # except this one
crash => [ qw/ cut clo / ],
direct => [ qw/ dut dlo / ],
normal => [ qw/ out flo / ],
hold => [ qw/ hut hlo / ],
);
# Reference files consist of a number of lines (terminated by 0x0a or 0x0d,0x0a) each consisting of the name of the file to transfer to the remote system.
# file_type => extension. both keys and values should be unique in their sets
# content notes are from fts-5005.003
my %control_file_extension = ( file_request => 'req', # file requests
# The format of request files is documented in FTS-0006.
busy => 'bsy', # busy control file.
# may contain one line of PID information (less than 70 characters).
call => 'csy', # call control file
# may contain one line of PID information (less than 70 characters).
hold => 'hld', # hold control file
# must contain a one line string with the expiration of the hold period expressed in UNIX-time.
try => 'try', # try control file
# A try file (if implemented by a mailer) must contain the following:
# NOK - Number of good connects, expressed as a 16-bit, big-endian integer.
# NBAD - Number of bad connects, expressed as a 16-bit, big-endian integer.
# CLength - Length of comment in bytes, expressed as an 8-bit unsigned integer.
# Comment - CLength bytes, detailing the results of the most recent connection attempt.
# On completion of a successful session, NOK is incremented and NBAD is reset to zero.
# On completion of a failed session, NBAD is incremented.
# IF NBAD reaches the mailer's configured limit for failed sessions,
# the node is marked undialable, NOK and NBAD are reset to zero,
# and a hld control file is created in accordance with section 5.3.
);
=head1 NAME
FTN::Outbound::BSO - working with BinkleyTerm Style Outbound.
=head1 VERSION
version 20180823
=head1 SYNOPSIS
use Log::Log4perl ();
use Encode ();
use FTN::Outbound::BSO ();
Log::Log4perl -> easy_init( $Log::Log4perl::INFO );
my $bso = FTN::Outbound::BSO
-> new( outbound_root => '/var/lib/ftn/outbound',
domain => 'fidonet',
zone => 2,
domain_abbrev => { fidonet => '_out',
homenet => 'leftnet',
},
maximum_session_time => 3600, # one hour
) or die 'cannot create bso object';
my $addr = FTN::Addr -> new( '2:451/30' );
sub poll {
my $addr = shift;
my $bso = shift;
my $flo = $bso -> addr_file_to_change( $addr,
'reference_file',
'normal'
);
open my $fh, '>>', $flo
or die sprintf 'cannot open %s: %s', $flo, $!;
print $fh '';
close $fh;
}
$bso -> busy_protected_sub( $addr,
\ &poll,
);
=head1 DESCRIPTION
FTN::Outbound::BSO module is for working with BinkleyTerm Style Outbound in FTN following specifications from fts-5005.003 document. Figuring out correct file to process might be a tricky process: different casing, few our main domains, other differ...
=head1 OBJECT CREATION
=head2 new
Expects parameters as hash:
outbound_root - directory path as a character string where the whole outbound is located. Mandatory parameter. This directory should exist.
By standard constructor needs our domain and zone. They can be provided as:
our_addr - either FTN::Addr object representing our address or our address as a string which will be passed to FTN::Addr constructor.
or as a pair:
domain - domain part of our address as described in frl-1028.002.
zone - our zone in that domain
At least one of the ways should be provided. In case both are our_addr has higher priority.
domain_abbrev - hash reference where keys are known domains and values are directory names (without extension) in outbound_root for those domains. Mandatory parameter.
reference_file_read_line_transform_sub - reference to a function that receives an octet string and returns a character string. Will be passed to FTN::Outbound::Reference_file constructor. If not provided reference file content won't be processed.
maximum_session_time - maximum session time in seconds. If provided, all found busy files older than 2 * value will be removed during outbound scan.
Returns newly created object on success.
=cut
sub new {
my $logger = Log::Log4perl -> get_logger( __PACKAGE__ );
ref( my $class = shift ) and $logger -> logcroak( "I'm only a class method!" );
return
unless @_;
$logger -> logdie( sprintf 'constructor expects even number of arguments, but received %d of them',
scalar @_,
)
if @_ % 2;
my %option = @_;
my %self;
# validating
# mandatory parameters
$logger -> logdie( 'mandatory outbound_root is not provided' )
unless exists $option{outbound_root};
# outbound_root
my $outbound_root_fs = Encode::encode( locale_fs => $option{outbound_root} );
unless ( -e $outbound_root_fs ) {
$logger -> warn( sprintf 'outbound_root (%s) directory does not exist',
$option{outbound_root},
);
return;
}
unless ( -d _ ) { # if it exists it should be a directory
$logger -> warn( sprintf 'outbound_root (%s) does not point to the directory',
$option{outbound_root},
);
return;
}
$self{outbound_root} = $option{outbound_root};
$self{outbound_root_fs} = $outbound_root_fs;
# our_addr or ( domain + zone )
if ( exists $option{our_addr}
&& $option{our_addr}
) {
if ( ref $option{our_addr}
&& Scalar::Util::blessed $option{our_addr}
&& $option{our_addr} -> isa( 'FTN::Addr' )
) {
$self{our_addr} = $option{our_addr};
} else {
$self{our_addr} = FTN::Addr -> new( $option{our_addr} )
lib/FTN/Outbound/BSO.pm view on Meta::CPAN
}
# maximum_session_time
if ( exists $option{maximum_session_time} ) {
$logger -> logdie( sprintf 'incorrect value of maximum_session_time: %s',
defined $option{maximum_session_time} ?
$option{maximum_session_time}
: 'undef'
)
unless defined $option{maximum_session_time}
&& $option{maximum_session_time} =~ m/^\d+$/
&& $option{maximum_session_time}; # cannot be 0
$self{maximum_session_time} = $option{maximum_session_time};
}
bless \ %self, $class;
}
sub _store {
my $logger = Log::Log4perl -> get_logger( __PACKAGE__ );
ref( my $self = shift ) or $logger -> logcroak( "I'm only an object method!" );
my ( $file_prop,
$ext,
$target,
$net,
$node,
$point,
) = @_;
my %ext_netmail_flavour = map { $flavour_extension{ $_ }[ 0 ] => $_ } keys %flavour_extension;
my %ext_reference_file_flavour = map { $flavour_extension{ $_ }[ 1 ] => $_ } keys %flavour_extension;
my %ext_control_file = reverse %control_file_extension;
my $lc_ext = lc $ext;
if ( exists $ext_netmail_flavour{ $lc_ext } ) { # netmail
push @{ $target -> { $net }{ $node }{ $point }{netmail}{ $ext_netmail_flavour{ $lc_ext } } },
$file_prop;
} elsif ( exists $ext_reference_file_flavour{ $lc_ext } ) { # reference file
my $flavour = $ext_reference_file_flavour{ $lc_ext };
# referenced files
if ( $file_prop -> {size} # empty files are empty, right?
&& exists $self -> {reference_file_read_line_transform_sub}
) {
$file_prop -> {referenced_files} =
FTN::Outbound::Reference_file
-> new( $file_prop -> {full_name},
$self -> {reference_file_read_line_transform_sub},
)
-> read_existing_file
-> referenced_files;
}
push @{ $target -> { $net }{ $node }{ $point }{reference_file}{ $flavour } },
$file_prop;
} elsif ( exists $ext_control_file{ $lc_ext } ) {
my $age = $file_prop -> {mstat} ? time - $file_prop -> {mstat} : 0;
if ( $ext_control_file{ $lc_ext } eq 'busy'
&& exists $self -> {maximum_session_time}
&& $self -> {maximum_session_time} * 2 < $age
) { # try to remove if maximum_session_time is defined and busy is older than it
$logger -> info( sprintf 'removing expired busy %s (%d seconds old)',
$file_prop -> {full_name},
$age,
);
unlink Encode::encode( locale_fs => $file_prop -> {full_name} )
or $logger -> logdie( sprintf 'could not unlink %s: %s',
$file_prop -> {full_name},
$!,
);
} else {
push @{ $target -> { $net }{ $node }{ $point }{ $ext_control_file{ $lc_ext } } },
$file_prop;
}
}
}
=head1 OBJECT METHODS
=head2 scan
Scans outbound for all known domains. Old busy files might be removed.
Returns itself for chaining.
=cut
sub scan {
my $logger = Log::Log4perl -> get_logger( __PACKAGE__ );
ref( my $self = shift ) or $logger -> logcroak( "I'm only an object method!" );
$logger -> logdie( sprintf 'outbound_root (%s) directory does not exist',
$self -> {outbound_root},
)
unless -e $self -> {outbound_root_fs};
# if it exists it should be a directory
$logger -> logdie( sprintf 'outbound_root (%s) does not point to the directory',
$self -> {outbound_root},
)
unless -d _;
# check outbound_root for all domain abbrevs and zones
my $domain_abbr_re = join '|', values %{ $self -> {domain_abbrev} };
my %result;
opendir my $or_dh, $self -> {outbound_root_fs}
or $logger -> logdie( sprintf 'cannot opendir %s: %s',
$self -> {outbound_root},
$!,
);
while ( my $dz_out = readdir $or_dh ) { # looking for domain abbreviations directories
$dz_out = Encode::decode( locale_fs => $dz_out );
next # skipping hidden files and ..
if '.' eq substr $dz_out, 0, 1;
my $dir_name = File::Spec -> catdir( $self -> {outbound_root},
$dz_out,
);
my $dir_name_fs = Encode::encode( locale_fs => $dir_name );
next # looking only for directories
unless -d $dir_name_fs;
# our_domain_dir, our_domain_dir.7fff, other_domain.1999
next
unless $dz_out =~ /^($domain_abbr_re)(?:\.([1-7]?[0-9a-f]{3}))?$/i
&& ( $1 eq $self -> {domain_abbrev}{ $self -> {domain} }
|| defined $2
);
my ( $domain ) = grep $self -> {domain_abbrev}{ $_ } eq $1,
keys %{ $self -> {domain_abbrev} };
my $zone = defined $2 ? hex $2 : $self -> {zone};
next
unless 1 <= $zone && $zone <= 32767; # FRL-1002.001, frl-1028.002
lib/FTN/Outbound/BSO.pm view on Meta::CPAN
},
$ext,
$result{ $domain }{ $zone }{ $dz_out },
$net,
$node,
0, # point
);
}
}
closedir $dz_dh;
}
closedir $or_dh;
$self -> {scanned} = \ %result;
$self;
}
=head2 scanned_hash
Returns internal structure representing scanned outbound (hash in list context, hashref in scalar context). If scan method hasn't been called, it will be called implicitly by this method.
=cut
sub scanned_hash {
my $logger = Log::Log4perl -> get_logger( __PACKAGE__ );
ref( my $self = shift ) or $logger -> logcroak( "I'm only an object method!" );
$self -> scan
unless exists $self -> {scanned};
wantarray ?
%{ $self -> {scanned} }
: $self -> {scanned};
}
sub _validate_addr {
my $logger = Log::Log4perl -> get_logger( __PACKAGE__ );
ref( my $self = shift ) or $logger -> logcroak( "I'm only an object method!" );
my $addr = shift;
$logger -> logdie( 'no valid address passed' )
unless defined $addr
&& ref $addr
&& Scalar::Util::blessed $addr
&& $addr -> isa( 'FTN::Addr' );
$logger -> logdie( 'passed address has unknown domain: %s',
$addr -> domain,
)
unless exists $self -> {domain_abbrev}{ $addr -> domain };
$addr;
}
=head2 is_busy
Expects one parameter - address as FTN::Addr object. Returns true if that address is busy (connection session, mail processing, ...).
=cut
sub is_busy {
my $logger = Log::Log4perl -> get_logger( __PACKAGE__ );
ref( my $self = shift ) or $logger -> logcroak( "I'm only an object method!" );
my $addr = $self -> _validate_addr( shift );
$self -> scan
unless exists $self -> {scanned};
exists $self -> {scanned}{ $addr -> domain }
&& exists $self -> {scanned}{ $addr -> domain }{ $addr -> zone }
&& grep { exists $self -> {scanned}{ $addr -> domain }{ $addr -> zone }{ $_ }{ $addr -> net }
&& exists $self -> {scanned}{ $addr -> domain }{ $addr -> zone }{ $_ }{ $addr -> net }{ $addr -> node }
&& exists $self -> {scanned}{ $addr -> domain }{ $addr -> zone }{ $_ }{ $addr -> net }{ $addr -> node }{ $addr -> point }
&& exists $self -> {scanned}{ $addr -> domain }{ $addr -> zone }{ $_ }{ $addr -> net }{ $addr -> node }{ $addr -> point }{busy}
} keys %{ $self -> {scanned}{ $addr -> domain }{ $addr -> zone } };
}
sub _select_domain_zone_dir { # best one. for updating. for checking needs a list (another method or direct access to the structure)
# and makes one if it doesn't exist or isn't good enough (e.g. our_domain_abbr.our_zone)
my $logger = Log::Log4perl -> get_logger( __PACKAGE__ );
ref( my $self = shift ) or $logger -> logcroak( "I'm only an object method!" );
my $domain = shift;
my $zone = shift;
$logger -> logdie( 'unknown domain: %s',
$domain,
)
unless exists $self -> {domain_abbrev}{ $domain };
my $best_match = $self -> {domain_abbrev}{ $domain };
$best_match .= sprintf( '.%03x', $zone )
unless $domain eq $self -> {domain}
&& $zone == $self -> {zone};
$self -> scan
unless exists $self -> {scanned};
if ( exists $self -> {scanned}{ $domain }
&& exists $self -> {scanned}{ $domain }{ $zone }
&& ( $domain ne $self -> {domain} # other domains have zones in extensions
|| $zone != $self -> {zone} # other zones in our domain have zones in extensions
|| grep length( $_ ) == length( $best_match ),
keys %{ $self -> {scanned}{ $domain }{ $zone } }
)
) {
my @list = sort { length $a <=> length $b
|| $b cmp $a # we prefer lower case
}
keys %{ $self -> {scanned}{ $domain }{ $zone } };
my ( $t ) = grep $_ eq $best_match, @list; # might be exact case
$best_match = defined $t ?
$t
: $list[ 0 ]; # if didn't find the best match, use the very first existing one
} else { # need to create
my $dir_full_name = File::Spec -> catdir( $self -> {outbound_root},
$best_match,
);
$logger -> debug( sprintf 'creating directory for domain %s zone %d: %s',
$domain,
$zone,
$dir_full_name,
);
mkdir Encode::encode( locale_fs => $dir_full_name )
or $logger -> logdie( sprintf 'cannot create domain/zone %s directory: %s',
$dir_full_name,
$!,
);
lib/FTN/Outbound/BSO.pm view on Meta::CPAN
# domain zone dir might not exist at all
my $dz_out = $self -> _select_domain_zone_dir( $domain, $zone );
my $points_dir = sprintf( '%04x%04x.pnt',
$net,
$node,
);
# what if domain_abbr.zone (perfect one) doesn't have required points dir
# but domain_abbr.zOnE has?
my @dz_out_with_existing_points_dir = sort { $b cmp $a } # we prefer lower case of domain[.zone] dir
grep length $_ == length $dz_out # to filter out our_domain.our_zone versions
&& exists $self -> {scanned}{ $domain }{ $zone }{ $_ }{ $net }
&& exists $self -> {scanned}{ $domain }{ $zone }{ $_ }{ $net }{ $node }
&& exists $self -> {scanned}{ $domain }{ $zone }{ $_ }{ $net }{ $node }{points_dir},
keys %{ $self -> {scanned}{ $domain }{ $zone } };
if ( @dz_out_with_existing_points_dir ) { # ok, there is at least one with points dir. how do we select best of them?
# let's prioritize domain_abbr[.zone] betterness over points_dir betterness
unless ( grep $_ eq $dz_out,
@dz_out_with_existing_points_dir
) { # ok, there is no best domain_abbr[.zone]. let's try to find best points_dir
my ( $t ) = grep exists $self -> {scanned}{ $domain }{ $zone }{ $_ }{ $net }{ $node }{points_dir}{ $points_dir },
@dz_out_with_existing_points_dir;
$dz_out = defined $t ? $t : $dz_out_with_existing_points_dir[ 0 ]; # if no best in either place, just use the very first one
}
# now we've got best outbound. let's find best points dir. or just the very first
$points_dir = ( sort { $b cmp $a } # we prefer lower case of points dir
keys %{ $self -> {scanned}{ $domain }{ $zone }{ $dz_out }{ $net }{ $node }{points_dir} }
)[ 0 ]
unless exists $self -> {scanned}{ $domain }{ $zone }{ $dz_out }{ $net }{ $node }{points_dir}{ $points_dir };
} else { # doesn't exist. we need to create it using best domain_abbr[.zone] dir
my $dir_full_name = File::Spec -> catdir( $self -> {scanned}{ $domain }{ $zone }{ $dz_out }{dir},
$points_dir,
);
$logger -> debug( sprintf 'creating %s#%d:%d/%d points directory %s',
$domain,
$zone,
$net,
$node,
$dir_full_name,
);
mkdir Encode::encode( locale_fs => $dir_full_name )
or $logger -> logdie( sprintf 'cannot create points directory %s: %s',
$dir_full_name,
$!,
);
$self -> {scanned}{ $domain }{ $zone }{ $dz_out }{ $net }{ $node }{points_dir}{ $points_dir } = $dir_full_name;
}
# return ( dz_out, $points_dir) or full points directory path?
$self -> {scanned}{ $domain }{ $zone }{ $dz_out }{ $net }{ $node }{points_dir}{ $points_dir };
}
=head2 busy_protected_sub
Expects two parameters:
address going to be dealt with as a FTN::Addr object
function reference that will receive passed address and us ($self) as parameters and which should do all required operations related to the passed address.
This method infinitely waits (most likely will be changed in the future) until address is not busy. Then it creates busy flag and calls passed function reference providing itself as an argument for it. After function return removes created busy fla...
Returns itself for chaining.
=cut
sub busy_protected_sub { # address, sub_ref( self ). (order busy, execute sub, remove busy)
my $logger = Log::Log4perl -> get_logger( __PACKAGE__ );
ref( my $self = shift ) or $logger -> logcroak( "I'm only an object method!" );
my $addr = $self -> _validate_addr( shift );
$logger -> logdie( 'no valid sub_ref passed' )
unless @_
&& defined $_[ 0 ]
&& 'CODE' eq ref $_[ 0 ];
my $sub_ref = shift;
$self -> scan
unless exists $self -> {scanned};
# check that it's not already busy
while ( $self -> is_busy( $addr ) ) {
sleep( 4 ); # waiting...
$self -> scan;
}
# here there is no busy flag for passed address. make it in the best dir then
my $busy_name;
if ( $addr -> point ) { # possible dir creation
$busy_name = File::Spec -> catfile( $self -> _select_points_dir( $addr -> domain,
$addr -> zone,
$addr -> net,
$addr -> node,
),
sprintf( '%08x',
$addr -> point,
),
);
} else {
my $dz_out = $self -> _select_domain_zone_dir( $addr -> domain,
$addr -> zone,
);
$busy_name = File::Spec -> catfile( $self -> {scanned}{ $addr -> domain }{ $addr -> zone }{ $dz_out }{dir},
sprintf( '%04x%04x',
$addr -> net,
$addr -> node,
),
);
}
$busy_name .= '.' . $control_file_extension{busy};
my $busy_name_fs = Encode::encode( locale_fs => $busy_name );
sysopen my $fh, $busy_name_fs, Fcntl::O_WRONLY | Fcntl::O_CREAT | Fcntl::O_EXCL
or $logger -> logdie( 'cannot open %s for writing: %s',
$busy_name,
$!,
);
flock $fh, Fcntl::LOCK_EX
or $logger -> logdie( q[can't flock file %s: %s],
$busy_name,
$!
);
# For information purposes a bsy file may contain one line of PID information (less than 70 characters).
printf $fh '%d %s',
$$,
substr( __FILE__, 0, 70 - 1 - length( $$ ) );
eval {
$sub_ref -> ( $addr,
$self,
);
};
# remove busy first
close $fh;
unlink $busy_name_fs
or $logger -> logwarn( sprintf 'could not unlink %s: %s',
$busy_name,
$!,
);
if ( $@ ) { # something bad happened
$logger -> logdie( 'referenced sub execution failed: %s',
$@,
);
}
$self;
}
=head2 addr_file_to_change
Expects arguments:
address is going to be dealt with as a FTN::Addr object
file type is one of netmail, reference_file, file_request, busy, call, hold, try.
If file type is netmail or reference_file, then next parameter should be its flavour: immediate, crash, direct, normal, hold.
If optional function reference passed, then it will be called with one parameter - name of the file to process. After that information in internal structure about that file will be updated.
Does not deal with busy flag implicitly. Recommended usage is in the function passed to busy_protected_sub.
Returns full name of the file to process (might not exists yet though).
=cut
sub addr_file_to_change { # addr, type ( netmail, file_reference, .. ), [flavour], [ sub_ref( filename ) ].
# figures required filetype name (new or existing) and calls subref with that name.
# does not deal with busy implicitly
# returns full name of the file to be changed/created
my $logger = Log::Log4perl -> get_logger( __PACKAGE__ );
ref( my $self = shift ) or $logger -> logcroak( "I'm only an object method!" );
my $addr = $self -> _validate_addr( shift );
my @flavoured = qw/ netmail
reference_file
/;
$logger -> logdie( 'no type passed' )
unless @_;
my $type = shift;
$logger -> logdie( sprintf 'incorrect type: %s',
defined $type ? $type : 'undef',
)
unless defined $type
&& grep $type eq $_,
@flavoured,
keys %control_file_extension;
my $filename = $addr -> point ?
sprintf( '%08x.', $addr -> point )
: sprintf( '%04x%04x.',
$addr -> net,
$addr -> node,
);
my $flavoured = grep $type eq $_, @flavoured;
my $flavour;
if ( $flavoured ) {
$logger -> logdie( 'no flavour passed' )
unless @_;
$flavour = shift;
$logger -> logdie( sprintf 'incorrect flavour: %s',
defined $flavour ? $flavour : 'undef',
)
unless defined $flavour
&& exists $flavour_extension{ $flavour };
$filename .= $type eq $flavoured[ 0 ] ? # netmail
$flavour_extension{ $flavour }[ 0 ]
: $flavour_extension{ $flavour }[ 1 ];
} else {
$filename .= $control_file_extension{ $type };
}
my $sub_ref;
if ( @_ ) { # possible sub ref
$logger -> logdie( 'no valid sub_ref passed' )
unless defined $_[ 0 ]
&& 'CODE' eq ref $_[ 0 ];
$sub_ref = shift;
( run in 1.076 second using v1.01-cache-2.11-cpan-524268b4103 )