App-MHFS
view release on metacpan or search on metacpan
MHFS::BitTorrent::Bencoding, MHFS::Util - export with @EXPORT_OK
Add running tests to release process
Switch much of the error handling to try catch with Feature::Compat::Try
Mostly in MHFS::Plugin::Kodi and MHFS::Util
MHFS::Promise: use actual exceptions instead of fake exception system
Fix circular dependencies with MHFS::Kodi::* and MHFS::Plugin::Kodi
Fix output_dir_versatile not properly terminating some directories,
Fix SendLocalFile having some unnecessary lock checks
Disable global Carp::confess
Add debug flag to turn on Carp::confess on $SIG{ __DIE__ }
MHFS::Util - croak instead of die, warnif instead of say for warnings
`/kodi/tv` better organizing and metadata loading
music player - build with WASM_BIGINT, emscripten 4.0.7 compat
get_printable_utf8 - fix invalid UTF-8 causing valid characters to be
omitted from the output, improve implementation, add tests
v0.6.0 2024-10-21
Kodi JSON API `/kodi/movies` and `/kodi/tv`
- TMDB metadata and art fetching
- Supports multiple editions of movies and multiple files per movie.
Multi-part rar is not supported yet.
lib/App/MHFS.pm view on Meta::CPAN
}
if($help) {
print $USAGE;
exit 0;
}
elsif($versionflag) {
print __PACKAGE__." $VERSION";
exit 0;
}
say __PACKAGE__ .": parsed command line args";
$launchsettings{flush} = $flush if($flush);
$launchsettings{CFGDIR} = $cfgdir if($cfgdir);
$launchsettings{FALLBACK_DATA_ROOT} = $fallback_data_root if($fallback_data_root);
$launchsettings{APPDIR} = $appdir if($appdir);
$launchsettings{debug} = $debug if ($debug);
# start the server (blocks)
say __PACKAGE__.": starting MHFS::HTTP::Server";
my $server = MHFS::HTTP::Server->new(\%launchsettings,
['MHFS::Plugin::MusicLibrary',
'MHFS::Plugin::GetVideo',
'MHFS::Plugin::VideoLibrary',
'MHFS::Plugin::Youtube',
'MHFS::Plugin::BitTorrent::Tracker',
'MHFS::Plugin::OpenDirectory',
'MHFS::Plugin::Playlist',
'MHFS::Plugin::Kodi',
'MHFS::Plugin::BitTorrent::Client::Interface'],
lib/MHFS/BitTorrent/Bencoding.pm view on Meta::CPAN
my $node = [$firstchar];
push @{$nodestack[-1]}, $node;
push @nodestack, $node;
}
elsif(substr($$contents, $foffset-1) =~ /^i(0|\-?[1-9][0-9]*)e/) {
my $node = ['int', $1];
$foffset += length($1)+1;
push @{$nodestack[-1]}, $node;
}
else {
say "bad elm $firstchar $foffset";
return undef;
}
}
else {
say "bad elm $foffset";
return undef;
}
if(scalar(@nodestack) == 1) {
return [$headnode[1], $foffset-$startoffset];
}
}
}
1;
lib/MHFS/BitTorrent/Client.pm view on Meta::CPAN
sub rtxmlrpc {
my ($server, $params, $cb, $inputdata) = @_;
my $process;
my @cmd = ('rtxmlrpc', @$params, '--config-dir', $server->{settings}{'CFGDIR'} . '/.pyroscope/');
print "$_ " foreach @cmd;
print "\n";
$process = MHFS::Process->new_io_process($server->{evp}, \@cmd, sub {
my ($output, $error) = @_;
chomp $output;
#say 'rtxmlrpc output: ' . $output;
$cb->($output);
}, $inputdata);
if(! $process) {
$cb->(undef);
}
return $process;
}
lib/MHFS/BitTorrent/Client.pm view on Meta::CPAN
# lookup the findex for the file and then set the priority on it
# ENOTIMPLEMENTED
sub torrent_set_file_priority {
my ($server, $infohash, $file, $priority, $callback) = @_;
rtxmlrpc($server, ['f.multicall', $infohash, '', 'f.path='], sub {
my ($output) = @_;
if($output =~ /ERROR/) {
$callback->(undef);
return;
}
say "torrent_set_file_priority";
say $output;
die;
$callback->($output);
});
}
sub torrent_list_torrents {
my ($server, $callback) = @_;
rtxmlrpc($server, ['d.multicall2', '', 'default', 'd.name=', 'd.hash=', 'd.size_bytes=', 'd.bytes_done=', 'd.is_private='], sub {
my ($output) = @_;
lib/MHFS/BitTorrent/Client.pm view on Meta::CPAN
$output = undef;
}
# pase the name and size arrays
my %files;
my @lines = split(/\n/, $output);
while(1) {
my $line = shift @lines;
last if(!defined $line);
if(substr($line, 0, 1) ne '[') {
say "fail parse";
$cb->(undef);
return;
}
while(substr($line, -1) ne ']') {
my $newline = shift @lines;
if(!defined $newline) {
say "fail parse";
$cb->(undef);
return;
}
$line .= $newline;
}
my ($file, $size) = $line =~ /^\[.(.+).,\s(\d+)\]$/;
if((! defined $file) || (!defined $size)) {
say "fail parse";
$cb->(undef);
return;
}
$files{$file} = {'size' => $size};
}
my @fkeys = (keys %files);
if(@fkeys == 1) {
my $key = $fkeys[0];
torrent_d_is_multi_file($server, $infohash, sub {
lib/MHFS/BitTorrent/Client.pm view on Meta::CPAN
});
}
sub torrent_start {
my ($server, $torrentData, $saveto, $cb) = @_;
my $torrent = MHFS::BitTorrent::Metainfo::Parse($torrentData);
if(! $torrent) {
$cb->{on_failure}->(); return;
}
my $asciihash = $torrent->InfohashAsHex();
say 'infohash ' . $asciihash;
# see if the hash is already in rtorrent
torrent_d_bytes_done($server, $asciihash, sub {
my ($bytes_done) = @_;
if(! defined $bytes_done) {
# load, set directory, and download it (race condition)
# 02/05/2020 what race condition?
torrent_load_raw_verbose($server, $$torrentData, sub {
if(! defined $_[0]) { $cb->{on_failure}->(); return;}
torrent_d_directory_set($server, $asciihash, $saveto, sub {
if(! defined $_[0]) { $cb->{on_failure}->(); return;}
torrent_d_start($server, $asciihash, sub {
if(! defined $_[0]) { $cb->{on_failure}->(); return;}
say 'starting ' . $asciihash;
$cb->{on_success}->($asciihash);
})})});
}
else {
# set the priority and download
torrent_set_priority($server, $asciihash, '1', sub {
if(! defined $_[0]) { $cb->{on_failure}->(); return;}
torrent_d_start($server, $asciihash, sub {
if(! defined $_[0]) { $cb->{on_failure}->(); return;}
say 'starting (existing) ' . $asciihash;
$cb->{on_success}->($asciihash);
})});
}
});
}
1;
lib/MHFS/BitTorrent/Metainfo.pm view on Meta::CPAN
return MHFS::BitTorrent::Metainfo->_new($tree->[0]);
}
sub mktor {
my ($evp, $params, $cb) = @_;
my $process;
my @cmd = ('mktor', @$params);
$process = MHFS::Process->new_output_process($evp, \@cmd, sub {
my ($output, $error) = @_;
chomp $output;
say 'mktor output: ' . $output;
$cb->($output);
});
return $process;
}
sub Create {
my ($evp, $opt, $cb) = @_;
if((! exists $opt->{src}) || (! exists $opt->{dest_metafile}) || (! exists $opt->{tracker})) {
say "MHFS::BitTorrent::Metainfo::Create - Invalid opts";
$cb->(undef);
return;
}
my @params;
push @params, '-p' if($opt->{private});
push @params, ('-o', $opt->{dest_metafile});
push @params, $opt->{src};
push @params, $opt->{tracker};
print "$_ " foreach @params;
lib/MHFS/BitTorrent/Metainfo.pm view on Meta::CPAN
sub InfohashAsHex {
my ($self) = @_;
return uc(unpack('H*', $self->{'infohash'}));
}
sub _bdictfind {
my ($node, $keys, $valuetype) = @_;
NEXTKEY: foreach my $key (@{$keys}) {
if($node->[0] ne 'd') {
say "cannot search non dictionary";
return undef;
}
for(my $i = 1; $i < scalar(@{$node}); $i+=2) {
if($node->[$i][1] eq $key) {
$node = $node->[$i+1];
last NEXTKEY;
}
}
say "failed to find key $key";
return undef;
}
if(($valuetype) && ($node->[0] ne $valuetype)) {
say "node has wrong type, expected $valuetype got ". $node->[0];
return undef;
}
return $node;
}
sub _bdictgetkeys {
my ($node) = @_;
if($node->[0] ne 'd') {
say "cannot search non dictionary";
return undef;
}
my @keys;
for(my $i = 1; $i < scalar(@{$node}); $i+=2) {
push @keys, $node->[$i][1];
}
return \@keys;
}
sub _new {
lib/MHFS/EventLoop/Poll/Base.pm view on Meta::CPAN
sub new {
my ($class) = @_;
my %self = ('poll' => IO::Poll->new(), 'fh_map' => {}, 'timers' => [], 'children' => {}, 'deadchildren' => []);
bless \%self, $class;
$SIG{CHLD} = sub {
while((my $child = waitpid(-1, WNOHANG)) > 0) {
my ($wstatus, $exitcode) = ($?, $?>> 8);
if(defined $self{'children'}{$child}) {
say "PID $child reaped (func) $exitcode";
push @{$self{'deadchildren'}}, [$self{'children'}{$child}, $child, $wstatus];
$self{'children'}{$child} = undef;
}
else {
say "PID $child reaped (No func) $exitcode";
}
}
};
return \%self;
}
sub register_child {
my ($self, $pid, $cb) = @_;
$self->{'children'}{$pid} = $cb;
}
sub run_dead_children_callbacks {
my ($self) = @_;
while(my $chld = shift(@{$self->{'deadchildren'}})) {
say "PID " . $chld->[1] . ' running SIGCHLD cb';
$chld->[0]($chld->[2]);
}
}
sub set {
my ($self, $handle, $obj, $events) = @_;
$self->{'poll'}->mask($handle, $events);
$self->{'fh_map'}{$handle} = $obj;
}
lib/MHFS/EventLoop/Poll/Base.pm view on Meta::CPAN
$timer->{'id'} = $id if(defined $id);
return _insert_timer($self, $timer);
}
sub remove_timer_by_id {
my ($self, $id) = @_;
my $lastindex = scalar(@{$self->{'timers'}}) - 1;
for my $i (0 .. $lastindex) {
next if(! defined $self->{'timers'}[$i]{'id'});
if($self->{'timers'}[$i]{'id'} == $id) {
#say "Removing timer with id: $id";
splice(@{$self->{'timers'}}, $i, 1);
return;
}
}
say "unable to remove timer $id, not found";
}
sub requeue_timers {
my ($self, $timers, $current_time) = @_;
foreach my $timer (@$timers) {
$timer->{'desired'} = $current_time + $timer->{'interval'};
_insert_timer($self, $timer);
}
}
lib/MHFS/EventLoop/Poll/Base.pm view on Meta::CPAN
}
sub do_poll {
my ($self, $loop_interval, $poll) = @_;
my $pollret = $poll->poll($loop_interval);
if($pollret > 0){
foreach my $handle ($poll->handles()) {
my $revents = $poll->events($handle);
my $obj = $self->{'fh_map'}{$handle};
if($revents & POLLIN) {
#say "read Ready " .$$;
if(! defined($obj->onReadReady)) {
$self->remove($handle);
say "poll has " . scalar ( $self->{'poll'}->handles) . " handles";
next;
}
}
if($revents & POLLOUT) {
#say "writeReady";
if(! defined($obj->onWriteReady)) {
$self->remove($handle);
say "poll has " . scalar ( $self->{'poll'}->handles) . " handles";
next;
}
}
if($revents & (POLLHUP | POLLRDHUP )) {
say "Hangup $handle, before ". scalar ( $self->{'poll'}->handles);
$obj->onHangUp();
$self->remove($handle);
say "poll has " . scalar ( $self->{'poll'}->handles) . " handles";
}
}
}
elsif($pollret == 0) {
#say "pollret == 0";
}
elsif(! $!{EINTR}){
say "Poll ERROR $!";
#return undef;
}
$self->run_dead_children_callbacks;
}
sub run {
my ($self, $loop_interval) = @_;
my $default_lp_interval = $loop_interval // -1;
my $poll = $self->{'poll'};
for(;;)
{
check_timers($self);
print "do_poll $$";
if($self->{'timers'}) {
say " timers " . scalar(@{$self->{'timers'}}) . ' handles ' . scalar($self->{'poll'}->handles());
}
else {
print "\n";
}
# we don't need to expire until a timer is expiring
if(@{$self->{'timers'}}) {
$loop_interval = $self->{'timers'}[0]{'desired'} - clock_gettime(CLOCK_MONOTONIC);
}
else {
$loop_interval = $default_lp_interval;
lib/MHFS/EventLoop/Poll/Linux.pm view on Meta::CPAN
my $class = shift;
my $self = $class->SUPER::new(@_);
$self->{'evp_timer'} = MHFS::EventLoop::Poll::Linux::Timer->new($self);
return $self;
};
sub add_timer {
my ($self, $start) = @_;
shift @_;
if($self->SUPER::add_timer(@_) == 0) {
say __PACKAGE__.": add_timer, updating linux timer to $start";
$self->{'evp_timer'}->settime_linux($start, 0);
}
};
sub requeue_timers {
my $self = shift @_;
$self->SUPER::requeue_timers(@_);
my ($timers, $current_time) = @_;
if(@{$self->{'timers'}}) {
my $start = $self->{'timers'}[0]{'desired'} - $current_time;
say __PACKAGE__.": requeue_timers, updating linux timer to $start";
$self->{'evp_timer'}->settime_linux($start, 0);
}
};
sub run {
my ($self, $loop_interval) = @_;
$loop_interval //= -1;
my $poll = $self->{'poll'};
for(;;)
{
print __PACKAGE__.": do_poll LINUX_X86_64 $$";
if($self->{'timers'}) {
say " timers " . scalar(@{$self->{'timers'}}) . ' handles ' . scalar($self->{'poll'}->handles());
}
else {
print "\n";
}
$self->SUPER::do_poll($loop_interval, $poll);
}
};
1;
lib/MHFS/EventLoop/Poll/Linux/Timer.pm view on Meta::CPAN
$self{'evp'} = $evp;
return \%self;
}
sub packitimerspec {
my ($times) = @_;
my $it_interval_sec = int($times->{'it_interval'});
my $it_interval_nsec = floor(($times->{'it_interval'} - $it_interval_sec) * 1000000000);
my $it_value_sec = int($times->{'it_value'});
my $it_value_nsec = floor(($times->{'it_value'} - $it_value_sec) * 1000000000);
#say "packing $it_interval_sec, $it_interval_nsec, $it_value_sec, $it_value_nsec";
return pack 'qqqq', $it_interval_sec, $it_interval_nsec, $it_value_sec, $it_value_nsec;
}
sub settime_linux {
my ($self, $start, $interval) = @_;
# assume start 0 is supposed to run immediately not try to cancel a timer
$start = ($start > 0.000000001) ? $start : 0.000000001;
my $new_value = packitimerspec({'it_interval' => $interval, 'it_value' => $start});
my $settime_success = syscall(SYS_timerfd_settime(), $self->{'timerfd'}, 0, $new_value,0);
($settime_success == 0) or die("timerfd_settime failed: $!");
}
sub onReadReady {
my ($self) = @_;
my $nread;
my $buf;
while($nread = sysread($self->{'timerhandle'}, $buf, 8)) {
if($nread < 8) {
say "timer hit, ignoring $nread bytes";
next;
}
my $expirations = unpack 'Q', $buf;
say "Linux::Timer there were $expirations expirations";
}
if(! defined $nread) {
if( ! $!{EAGAIN}) {
say "sysread failed with $!";
}
}
$self->{'evp'}->check_timers;
return 1;
};
1;
lib/MHFS/FD/Reader.pm view on Meta::CPAN
package MHFS::FD::Reader v0.7.0;
use 5.014;
use strict; use warnings;
use feature 'say';
use Time::HiRes qw( usleep clock_gettime CLOCK_MONOTONIC);
use IO::Poll qw(POLLIN POLLOUT POLLHUP);
use Scalar::Util qw(looks_like_number weaken);
sub new {
my ($class, $process, $fd, $func) = @_;
my %self = ('time' => clock_gettime(CLOCK_MONOTONIC), 'process' => $process, 'fd' => $fd, 'onReadReady' => $func);
say "PID " . $self{'process'}{'pid'} . 'FD ' . $self{'fd'};
weaken($self{'process'});
return bless \%self, $class;
}
sub onReadReady {
my ($self) = @_;
my $ret = $self->{'onReadReady'}($self->{'fd'});
if($ret == 0) {
$self->{'process'}->remove($self->{'fd'});
return 1;
lib/MHFS/FD/Reader.pm view on Meta::CPAN
}
sub onHangUp {
}
sub DESTROY {
my $self = shift;
print "PID " . $self->{'process'}{'pid'} . ' ' if($self->{'process'});
print "FD " . $self->{'fd'};
say ' reader DESTROY called';
}
1;
lib/MHFS/FD/Writer.pm view on Meta::CPAN
package MHFS::FD::Writer v0.7.0;
use 5.014;
use strict; use warnings;
use feature 'say';
use Time::HiRes qw( usleep clock_gettime CLOCK_MONOTONIC);
use IO::Poll qw(POLLIN POLLOUT POLLHUP);
use Scalar::Util qw(looks_like_number weaken);
sub new {
my ($class, $process, $fd, $func) = @_;
my %self = ('time' => clock_gettime(CLOCK_MONOTONIC), 'process' => $process, 'fd' => $fd, 'onWriteReady' => $func);
say "PID " . $self{'process'}{'pid'} . 'FD ' . $self{'fd'};
weaken($self{'process'});
return bless \%self, $class;
}
sub onWriteReady {
my ($self) = @_;
my $ret = $self->{'onWriteReady'}($self->{'fd'});
if($ret == 0) {
$self->{'process'}->remove($self->{'fd'});
return 1;
lib/MHFS/FD/Writer.pm view on Meta::CPAN
return 1;
}
}
sub onHangUp {
}
sub DESTROY {
my $self = shift;
say "PID " . $self->{'process'}{'pid'} . " FD " . $self->{'fd'}.' writer DESTROY called';
}
1;
lib/MHFS/FS.pm view on Meta::CPAN
sub lookup {
my ($self, $name, $sid) = @_;
if(! exists $self->{'sources'}{$sid}) {
return undef;
}
my $src = $self->{'sources'}{$sid};
if($src->{'type'} ne 'local') {
say "unhandled src type ". $src->{'type'};
return undef;
}
my $location = $src->{'folder'};
my $absolute = abs_path($location.'/'.$name);
return undef if( ! $absolute);
return undef if ($absolute !~ /^$location/);
return _media_filepath_to_src_file($absolute, $location);
}
sub _media_filepath_to_src_file {
lib/MHFS/HTTP/Server.pm view on Meta::CPAN
local $SIG{PIPE} = sub {
print STDERR "SIGPIPE @_\n";
};
local $SIG{ __DIE__ } = \&Carp::confess if ($launchsettings->{debug});
binmode(STDOUT, ":utf8");
binmode(STDERR, ":utf8");
# load settings
say __PACKAGE__.": loading settings";
my $settings = MHFS::Settings::load($launchsettings);
if((exists $settings->{'flush'}) && ($settings->{'flush'})) {
say __PACKAGE__.": setting autoflush on STDOUT and STDERR";
STDOUT->autoflush(1);
STDERR->autoflush(1);
}
# make the temp dirs
make_path($settings->{'VIDEO_TMPDIR'}, $settings->{'MUSIC_TMPDIR'}, $settings->{'RUNTIME_DIR'}, $settings->{'GENERIC_TMPDIR'});
make_path($settings->{'SECRET_TMPDIR'}, {chmod => 0600});
make_path($settings->{'DATADIR'}, $settings->{'MHFS_TRACKER_TORRENT_DIR'});
my $sock = IO::Socket::INET->new(Listen => 10000, LocalAddr => $settings->{'HOST'}, LocalPort => $settings->{'PORT'}, Proto => 'tcp', Reuse => 1, Blocking => 0);
if(! $sock) {
say "server: Cannot create self socket";
return undef;
}
if(! $sock->setsockopt( SOL_SOCKET, SO_KEEPALIVE, 1)) {
say "server: cannot setsockopt";
return undef;
}
my $TCP_KEEPIDLE = 4;
my $TCP_KEEPINTVL = 5;
my $TCP_KEEPCNT = 6;
my $TCP_USER_TIMEOUT = 18;
#$SERVER->setsockopt(IPPROTO_TCP, $TCP_KEEPIDLE, 1) or die;
#$SERVER->setsockopt(IPPROTO_TCP, $TCP_KEEPINTVL, 1) or die;
#$SERVER->setsockopt(IPPROTO_TCP, $TCP_KEEPCNT, 10) or die;
#$SERVER->setsockopt(IPPROTO_TCP, $TCP_USER_TIMEOUT, 10000) or die; #doesn't work?
lib/MHFS/HTTP/Server.pm view on Meta::CPAN
}
my $evp = MHFS::EventLoop::Poll->new;
my %self = ( 'settings' => $settings, 'routes' => $routes, 'route_default' => sub { $_[0]->SendDirectory($settings->{'DOCUMENTROOT'}); }, 'plugins' => $plugins, 'sock' => $sock, 'evp' => $evp, 'uploaders' => [], 'sesh' =>
{ 'newindex' => 0, 'sessions' => {}}, 'resources' => {}, 'loaded_plugins' => {});
bless \%self, $class;
$evp->set($sock, \%self, POLLIN);
my $fs = MHFS::FS->new($settings->{'SOURCES'});
if(! $fs) {
say "failed to open MHFS::FS";
return undef;
}
$self{'fs'} = $fs;
# load the plugins
foreach my $pluginname (@{$plugins}) {
eval "use $pluginname; 1;" or do {
say __PACKAGE__.": module $pluginname not found!";
next;
};
next if(defined $settings->{$pluginname}{'enabled'} && (!$settings->{$pluginname}{'enabled'}));
my $plugin = $pluginname->new($settings, \%self);
next if(! $plugin);
foreach my $timer (@{$plugin->{'timers'}}) {
say __PACKAGE__.': adding '.ref($plugin).' timer';
$self{'evp'}->add_timer(@{$timer});
}
if(my $func = $plugin->{'uploader'}) {
say __PACKAGE__.': adding '. ref($plugin) .' uploader';
push (@{$self{'uploaders'}}, $func);
}
foreach my $route (@{$plugin->{'routes'}}) {
say __PACKAGE__.': adding ' . ref($plugin) . ' route ' . $route->[0];
push @{$self{'routes'}}, $route;
}
$plugin->{'server'} = \%self;
$self{'loaded_plugins'}{$pluginname} = $plugin;
}
$evp->run();
return \%self;
}
lib/MHFS/HTTP/Server.pm view on Meta::CPAN
my ($self, $filename) = @_;
$self->{'resources'}{$filename} //= read_text_file($filename);
return \$self->{'resources'}{$filename};
}
sub onReadReady {
my ($server) = @_;
# accept the connection
my $csock = $server->{'sock'}->accept();
if(! $csock) {
say "server: cannot accept client";
return 1;
}
# gather connection details and verify client host is acceptable
my $peerhost = $csock->peerhost();
if(! $peerhost) {
say "server: no peerhost";
return 1;
}
my $peerip = do {
try { parse_ipv4($peerhost) }
catch ($e) {
say "server: error parsing ip $peerhost";
return 1;
}
};
my $ah;
foreach my $allowedHost (@{$server->{'settings'}{'ARIPHOSTS_PARSED'}}) {
if(($peerip & $allowedHost->{'subnetmask'}) == $allowedHost->{'ip'}) {
$ah = $allowedHost;
last;
}
}
if(!$ah) {
say "server: $peerhost not allowed";
return 1;
}
my $peerport = $csock->peerport();
if(! $peerport) {
say "server: no peerport";
return 1;
}
# finally create the client
say "-------------------------------------------------";
say "NEW CONN " . $peerhost . ':' . $peerport;
my $cref = MHFS::HTTP::Server::Client->new($csock, $server, $ah, $peerip);
return 1;
}
1;
lib/MHFS/HTTP/Server/Client.pm view on Meta::CPAN
bless \%self, $class;
$self{'request'} = MHFS::HTTP::Server::Client::Request->new(\%self);
return \%self;
}
# add a connection timeout timer
sub AddClientCloseTimer {
my ($self, $timelength, $id, $is_requesttimeout) = @_;
weaken($self); #don't allow this timer to keep the client object alive
my $server = $self->{'server'};
say "CCT | add timer: $id";
$server->{'evp'}->add_timer($timelength, 0, sub {
if(! defined $self) {
say "CCT | $id self undef";
return undef;
}
# Commented out as with connection reuse on, Apache 2.4.10 seems sometimes
# pass 408 on to the next client.
#if($is_requesttimeout) {
# say "CCT | \$timelength ($timelength) exceeded, sending 408";
# $self->{request}->Send408;
# CT_WRITE($self);
#}
say "CCT | \$timelength ($timelength) exceeded, closing CONN $id";
say "-------------------------------------------------";
$server->{'evp'}->remove($self->{'sock'});
say "poll has " . scalar ( $server->{'evp'}{'poll'}->handles) . " handles";
return undef;
}, $id);
return $id;
}
sub KillClientCloseTimer {
my ($self, $id) = @_;
my $server = $self->{'server'};
say "CCT | removing timer: $id";
$server->{'evp'}->remove_timer_by_id($id);
}
sub SetEvents {
my ($self, $events) = @_;
$self->{'server'}{'evp'}->set($self->{'sock'}, $self, $events);
}
use constant {
RECV_SIZE => 65536,
lib/MHFS/HTTP/Server/Client.pm view on Meta::CPAN
# CT_DONE also returns control to the poll loop, it is called on error or when the client connection should be closed or is closed
sub CT_READ {
my ($self) = @_;
my $tempdata;
if(!defined($self->{'sock'}->recv($tempdata, RECV_SIZE))) {
if(! ($!{EAGAIN} || $!{EWOULDBLOCK})) {
print ("CT_READ RECV errno: $!\n");
return CT_DONE;
}
say "CT_YIELD: $!";
return CT_YIELD;
}
if(length($tempdata) == 0) {
say 'Server::Client read 0 bytes, client read closed';
return CT_DONE;
}
$self->{'inbuf'} .= $tempdata;
goto &CT_PROCESS;
}
sub CT_PROCESS {
my ($self) = @_;
$self->{'request'} //= MHFS::HTTP::Server::Client::Request->new($self);
if(!defined($self->{'request'}{'on_read_ready'})) {
lib/MHFS/HTTP/Server/Client.pm view on Meta::CPAN
sub CT_WRITE {
my ($self) = @_;
if(!defined $self->{'request'}{'response'}) {
die("went into CT_WRITE in bad state");
return CT_YIELD;
}
# TODO only TrySendResponse if there is data in buf or to be read
my $tsrRet = $self->TrySendResponse;
if(!defined($tsrRet)) {
say "-------------------------------------------------";
return CT_DONE;
}
elsif($tsrRet ne '') {
if($self->{'request'}{'outheaders'}{'Connection'} && ($self->{'request'}{'outheaders'}{'Connection'} eq 'close')) {
say "Connection close header set closing conn";
say "-------------------------------------------------";
return CT_DONE;
}
$self->{'request'} = undef;
goto &CT_PROCESS;
}
return CT_YIELD;
}
sub do_on_data {
my ($self) = @_;
my $res = $self->{'request'}{'on_read_ready'}->($self->{'request'});
if($res) {
if(defined $self->{'request'}{'response'}) {
#say "do_on_data: goto onWriteReady";
goto &onWriteReady;
#return onWriteReady($self);
}
#else {
elsif(defined $self->{'request'}{'on_read_ready'}) {
#say "do_on_data: goto onReadReady inbuf " . length($self->{'inbuf'});
goto &onReadReady;
#return onReadReady($self);
}
else {
say "do_on_data: response and on_read_ready not defined, response by timer or poll?";
}
}
return $res;
}
sub onReadReady {
goto &CT_READ;
my ($self) = @_;
my $tempdata;
if(defined($self->{'sock'}->recv($tempdata, RECV_SIZE))) {
if(length($tempdata) == 0) {
say 'Server::Client read 0 bytes, client read closed';
return undef;
}
$self->{'inbuf'} .= $tempdata;
goto &do_on_data;
}
if(! $!{EAGAIN}) {
print ("MHFS::HTTP::Server::Client onReadReady RECV errno: $!\n");
return undef;
}
return '';
}
sub onWriteReady {
goto &CT_WRITE;
my ($client) = @_;
# send the response
if(defined $client->{'request'}{'response'}) {
# TODO only TrySendResponse if there is data in buf or to be read
my $tsrRet = $client->TrySendResponse;
if(!defined($tsrRet)) {
say "-------------------------------------------------";
return undef;
}
elsif($tsrRet ne '') {
if($client->{'request'}{'outheaders'}{'Connection'} && ($client->{'request'}{'outheaders'}{'Connection'} eq 'close')) {
say "Connection close header set closing conn";
say "-------------------------------------------------";
return undef;
}
$client->{'request'} = MHFS::HTTP::Server::Client::Request->new($client);
# handle possible existing read data
goto &do_on_data;
}
}
else {
say "response not defined, probably set later by a timer or poll";
}
return 1;
}
sub _TSRReturnPrint {
my ($sentthiscall) = @_;
if($sentthiscall > 0) {
say "wrote $sentthiscall bytes";
}
}
sub TrySendResponse {
my ($client) = @_;
my $csock = $client->{'sock'};
my $dataitem = $client->{'request'}{'response'};
defined($dataitem->{'buf'}) or die("dataitem must always have a buf");
my $sentthiscall = 0;
do {
lib/MHFS/HTTP/Server/Client.pm view on Meta::CPAN
if(defined $dataitem->{'fh'}) {
my $FH = $dataitem->{'fh'};
my $req_length = $dataitem->{'get_current_length'}->();
my $filepos = $dataitem->{'fh_pos'};
# TODO, remove this assert
if($filepos != tell($FH)) {
die('tell mismatch');
}
if($req_length && ($filepos >= $req_length)) {
if($filepos > $req_length) {
say "Reading too much tell: $filepos req_length: $req_length";
}
say "file read done";
close($FH);
}
else {
my $readamt = 24000;
if($req_length) {
my $tmpsend = $req_length - $filepos;
$readamt = $tmpsend if($tmpsend < $readamt);
}
# this is blocking, it shouldn't block for long but it could if it's a pipe especially
my $bytesRead = read($FH, $newdata, $readamt);
if(! defined($bytesRead)) {
$newdata = undef;
say "READ ERROR: $!";
}
elsif($bytesRead == 0) {
# read EOF, better remove the error
if(! $req_length) {
say '$req_length not set and read 0 bytes, treating as EOF';
$newdata = undef;
}
else {
say 'FH EOF ' .$filepos;
seek($FH, 0, 1);
_TSRReturnPrint($sentthiscall);
return '';
}
}
else {
$dataitem->{'fh_pos'} += $bytesRead;
}
}
}
lib/MHFS/HTTP/Server/Client.pm view on Meta::CPAN
$newdata = $sizeline.$newdata."\r\n";
}
# add the new data to the dataitem buffer
$dataitem->{'buf'} .= $newdata;
} while(length($dataitem->{'buf'}));
$client->{'request'}{'response'} = undef;
_TSRReturnPrint($sentthiscall);
say "DONE Sending Data";
return 'RequestDone'; # not undef because keep-alive
}
sub TrySendItem {
my ($csock, $dataref) = @_;
my $sret = send($csock, $$dataref, 0);
if(! defined($sret)) {
if($!{EAGAIN}) {
#say "SEND EAGAIN\n";
return 0;
}
elsif($!{ECONNRESET}) {
print "ECONNRESET\n";
}
elsif($!{EPIPE}) {
print "EPIPE\n";
}
else {
print "send errno $!\n";
lib/MHFS/HTTP/Server/Client.pm view on Meta::CPAN
return $sret;
}
sub onHangUp {
my ($client) = @_;
return undef;
}
sub DESTROY {
my $self = shift;
say "$$ MHFS::HTTP::Server::Client destructor: ";
say "$$ ".'X-MHFS-CONN-ID: ' . $self->{'outheaders'}{'X-MHFS-CONN-ID'};
if($self->{'sock'}) {
#shutdown($self->{'sock'}, 2);
close($self->{'sock'});
}
}
1;
lib/MHFS/HTTP/Server/Client/Request.pm view on Meta::CPAN
my $ipos = index($self->{'client'}{'inbuf'}, "\r\n");
if($ipos != -1) {
if(substr($self->{'client'}{'inbuf'}, 0, $ipos+2, '') =~ /^(([^\s]+)\s+([^\s]+)\s+(?:HTTP\/1\.([0-1])))\r\n/) {
my $rl = $1;
$self->{'method'} = $2;
$self->{'uri'} = $3;
$self->{'httpproto'} = $4;
my $rid = int(clock_gettime(CLOCK_MONOTONIC) * rand()); # insecure uid
$self->{'outheaders'}{'X-MHFS-REQUEST-ID'} = sprintf("%X", $rid);
say "X-MHFS-CONN-ID: " . $self->{'outheaders'}{'X-MHFS-CONN-ID'} . " X-MHFS-REQUEST-ID: " . $self->{'outheaders'}{'X-MHFS-REQUEST-ID'};
say "RECV: $rl";
if(($self->{'method'} ne 'GET') && ($self->{'method'} ne 'HEAD') && ($self->{'method'} ne 'PUT')) {
say "X-MHFS-CONN-ID: " . $self->{'outheaders'}{'X-MHFS-CONN-ID'} . 'Invalid method: ' . $self->{'method'}. ', closing conn';
return undef;
}
my ($path, $querystring) = ($self->{'uri'} =~ /^([^\?]+)(?:\?)?(.*)$/g);
say("raw path: $path\nraw querystring: $querystring");
# transformations
## Path
$path = uri_unescape($path);
my %pathStruct = ( 'unescapepath' => $path );
# collapse slashes
$path =~ s/\/{2,}/\//g;
say "collapsed: $path";
$pathStruct{'unsafecollapse'} = $path;
# without trailing slash
if(index($pathStruct{'unsafecollapse'}, '/', length($pathStruct{'unsafecollapse'})-1) != -1) {
chop($path);
say "no slash path: $path ";
}
$pathStruct{'unsafepath'} = $path;
## Querystring
my %qsStruct;
# In the querystring spaces are sometimes encoded as + for legacy reasons unfortunately
$querystring =~ s/\+/%20/g;
my @qsPairs = split('&', $querystring);
foreach my $pair (@qsPairs) {
my($key, $value) = split('=', $pair);
lib/MHFS/HTTP/Server/Client/Request.pm view on Meta::CPAN
}
}
$self->{'path'} = \%pathStruct;
$self->{'qs'} = \%qsStruct;
$self->{'on_read_ready'} = \&want_headers;
#return want_headers($self);
goto &want_headers;
}
else {
say "X-MHFS-CONN-ID: " . $self->{'outheaders'}{'X-MHFS-CONN-ID'} . ' Invalid Request line, closing conn';
return undef;
}
}
elsif(length($self->{'client'}{'inbuf'}) > MAX_REQUEST_SIZE) {
say "X-MHFS-CONN-ID: " . $self->{'outheaders'}{'X-MHFS-CONN-ID'} . ' No Request line, closing conn';
return undef;
}
return 1;
}
sub want_headers {
my ($self) = @_;
my $ipos;
while($ipos = index($self->{'client'}{'inbuf'}, "\r\n")) {
if($ipos == -1) {
if(length($self->{'client'}{'inbuf'}) > MAX_REQUEST_SIZE) {
say "X-MHFS-CONN-ID: " . $self->{'outheaders'}{'X-MHFS-CONN-ID'} . ' Headers too big, closing conn';
return undef;
}
return 1;
}
elsif(substr($self->{'client'}{'inbuf'}, 0, $ipos+2, '') =~ /^(([^:]+):\s*(.*))\r\n/) {
say "RECV: $1";
$self->{'header'}{$2} = $3;
}
else {
say "X-MHFS-CONN-ID: " . $self->{'outheaders'}{'X-MHFS-CONN-ID'} . ' Invalid header, closing conn';
return undef;
}
}
# when $ipos is 0 we recieved the end of the headers: \r\n\r\n
# verify correct host is specified when required
if($self->{'client'}{'serverhostname'}) {
if((! $self->{'header'}{'Host'}) ||
($self->{'header'}{'Host'} ne $self->{'client'}{'serverhostname'})) {
my $printhostname = $self->{'header'}{'Host'} // '';
say "Host: $printhostname does not match ". $self->{'client'}{'serverhostname'};
return undef;
}
}
$self->{'ip'} = $self->{'client'}{'ip'};
# check if we're trusted (we can trust the headers such as from reverse proxy)
my $trusted;
if($self->{'client'}{'X-MHFS-PROXY-KEY'} && $self->{'header'}{'X-MHFS-PROXY-KEY'}) {
$trusted = $self->{'client'}{'X-MHFS-PROXY-KEY'} eq $self->{'header'}{'X-MHFS-PROXY-KEY'};
}
# drops conns for naughty client's using forbidden headers
if(!$trusted) {
my @absolutelyforbidden = ('X-MHFS-PROXY-KEY', 'X-Forwarded-For');
foreach my $forbidden (@absolutelyforbidden) {
if( exists $self->{'header'}{$forbidden}) {
say "header $forbidden is forbidden!";
return undef;
}
}
}
# process reverse proxy headers
else {
delete $self->{'header'}{'X-MHFS-PROXY-KEY'};
try { $self->{'ip'} = parse_ipv4($self->{'header'}{'X-Forwarded-For'}) if($self->{'header'}{'X-Forwarded-For'}); }
catch ($e) { say "ip not updated, unable to parse X-Forwarded-For: " . $self->{'header'}{'X-Forwarded-For'}; }
}
my $netmap = $self->{'client'}{'server'}{'settings'}{'NETMAP'};
if($netmap && (($self->{'ip'} >> 24) == $netmap->[0])) {
say "HACK for netmap converting to local ip";
$self->{'ip'} = ($self->{'ip'} & 0xFFFFFF) | ($netmap->[1] << 24);
}
# remove the final \r\n
substr($self->{'client'}{'inbuf'}, 0, 2, '');
if((defined $self->{'header'}{'Range'}) && ($self->{'header'}{'Range'} =~ /^bytes=([0-9]+)\-([0-9]*)$/)) {
$self->{'header'}{'_RangeStart'} = $1;
$self->{'header'}{'_RangeEnd'} = ($2 ne '') ? $2 : undef;
}
$self->{'on_read_ready'} = undef;
lib/MHFS/HTTP/Server/Client/Request.pm view on Meta::CPAN
sub getAbsoluteURL {
my ($self) = @_;
return $self->{'client'}{'absurl'} // (defined($self->{'header'}{'Host'}) ? 'http://'.$self->{'header'}{'Host'} : undef);
}
sub _ReqDataLength {
my ($self, $datalength) = @_;
$datalength //= 99999999999;
my $end = $self->{'header'}{'_RangeEnd'} // ($datalength-1);
my $dl = $end+1;
say "_ReqDataLength returning: $dl";
return $dl;
}
sub _SendResponse {
my ($self, $fileitem) = @_;
if(Encode::is_utf8($fileitem->{'buf'})) {
warn "_SendResponse: UTF8 flag is set, turning off";
Encode::_utf8_off($fileitem->{'buf'});
}
if($self->{'outheaders'}{'Transfer-Encoding'} && ($self->{'outheaders'}{'Transfer-Encoding'} eq 'chunked')) {
say "chunked response";
$fileitem->{'is_chunked'} = 1;
}
$self->{'response'} = $fileitem;
$self->{'client'}->SetEvents(POLLOUT | MHFS::EventLoop::Poll->ALWAYSMASK );
}
sub _SendDataItem {
my ($self, $dataitem, $opt) = @_;
my $size = $opt->{'size'};
lib/MHFS/HTTP/Server/Client/Request.pm view on Meta::CPAN
my $contentlength;
# range request
if($code == 206) {
my $start = $self->{'header'}{'_RangeStart'};
my $end = $self->{'header'}{'_RangeEnd'};
if(defined $end) {
$contentlength = $end - $start + 1;
}
elsif(defined $size) {
say 'Implicitly setting end to size';
$end = $size - 1;
$contentlength = $end - $start + 1;
}
# no end and size unknown. we have 4 choices:
# set end to the current end (the satisfiable range on RFC 7233 2.1). Dumb clients don't attempt to request the rest of the data ...
# send non partial response (200). This will often disable range requests.
# send multipart. "A server MUST NOT generate a multipart response to a request for a single range"(RFC 7233 4.1) guess not
# LIE, use a large value to signify infinite size. RFC 8673 suggests doing so when client signifies it can.
# Current clients don't however, so lets hope they can.
else {
say 'Implicitly setting end to 999999999999 to signify unknown end';
$end = 999999999999;
}
if($end < $start) {
say "_SendDataItem, end < start";
$self->Send403();
return;
}
$self->{'outheaders'}{'Content-Range'} = "bytes $start-$end/" . ($size // '*');
}
# everybody else
else {
$contentlength = $size;
}
lib/MHFS/HTTP/Server/Client/Request.pm view on Meta::CPAN
307 => "HTTP/1.1 307 Temporary Redirect\r\n",
403 => "HTTP/1.1 403 Forbidden\r\n",
404 => "HTTP/1.1 404 File Not Found\r\n",
408 => "HTTP/1.1 408 Request Timeout\r\n",
416 => "HTTP/1.1 416 Range Not Satisfiable\r\n",
503 => "HTTP/1.1 503 Service Unavailable\r\n"
);
my $headtext = $lookup{$code};
if(!$headtext) {
say "_SendDataItem, bad code $code";
$self->Send403();
return;
}
my $mime = $opt->{'mime'};
$headtext .= "Content-Type: $mime\r\n";
my $filename = $opt->{'filename'};
my $disposition = 'inline';
if($opt->{'attachment'}) {
$disposition = 'attachment';
lib/MHFS/HTTP/Server/Client/Request.pm view on Meta::CPAN
my $sendablebytes = encode('UTF-8', get_printable_utf8($filename));
$headtext .= "Content-Disposition: $disposition; filename*=UTF-8''".uri_escape($sendablebytes)."; filename=\"$sendablebytes\"\r\n";
}
$self->{'outheaders'}{'Accept-Ranges'} //= 'bytes';
$self->{'outheaders'}{'Connection'} //= $self->{'header'}{'Connection'};
$self->{'outheaders'}{'Connection'} //= 'keep-alive';
# SharedArrayBuffer
if($opt->{'allowSAB'}) {
say "sending SAB headers";
$self->{'outheaders'}{'Cross-Origin-Opener-Policy'} = 'same-origin';
$self->{'outheaders'}{'Cross-Origin-Embedder-Policy'} = 'require-corp';
}
# serialize the outgoing headers
foreach my $header (keys %{$self->{'outheaders'}}) {
$headtext .= "$header: " . $self->{'outheaders'}{$header} . "\r\n";
}
$headtext .= "\r\n";
lib/MHFS/HTTP/Server/Client/Request.pm view on Meta::CPAN
my ($self, $requestfile) = @_;
my $start = $self->{'header'}{'_RangeStart'};
my $client = $self->{'client'};
# open the file and get the size
my %fileitem = ('requestfile' => $requestfile);
my $currentsize;
if($self->{'method'} ne 'HEAD') {
my $FH;
if(! open($FH, "<", $requestfile)) {
say "SLF: open failed";
$self->Send404;
return;
}
binmode($FH);
my $st = stat($FH);
if(! $st) {
$self->Send404();
return;
}
$currentsize = $st->size;
lib/MHFS/HTTP/Server/Client/Request.pm view on Meta::CPAN
if(defined $self->{'header'}{'_RangeStart'}) {
my $start = $self->{'header'}{'_RangeStart'};
my $end = $self->{'header'}{'_RangeEnd'} // ($size - 1);
my $bytestoskip = $start;
my $count = $end - $start + 1;
@cmd = (@sshcmd, 'dd', 'skip='.$bytestoskip, 'count='.$count, 'bs=1', 'if='.$fullescapedname);
}
else{
@cmd = (@sshcmd, 'cat', $fullescapedname);
}
say "SendFromSSH (BLOCKING)";
open(my $cmdh, '-|', @cmd) or die("SendFromSSH $!");
$self->SendPipe($cmdh, basename($filename), $size);
return 1;
}
# ENOTIMPLEMENTED
sub Proxy {
my ($self, $proxy, $node) = @_;
die;
lib/MHFS/HTTP/Server/Client/Request.pm view on Meta::CPAN
}
# HACK, use LD_PRELOAD to hook tar to calculate the size quickly
my @tarcmd = ('tar', '-C', dirname($requestfile), basename($requestfile), '-c', '--owner=0', '--group=0');
$self->{'process'} = MHFS::Process->new(\@tarcmd, $self->{'client'}{'server'}{'evp'}, {
'SIGCHLD' => sub {
my $out = $self->{'process'}{'fd'}{'stdout'}{'fd'};
my $size;
read($out, $size, 50);
chomp $size;
say "size: $size";
$self->{'process'} = MHFS::Process->new(\@tarcmd, $self->{'client'}{'server'}{'evp'}, {
'STDOUT' => sub {
my($out) = @_;
say "tar sending response";
$self->{'outheaders'}{'Accept-Ranges'} = 'none';
my %fileitem = ('fh' => $out, 'get_current_length' => sub { return undef });
$self->_SendDataItem(\%fileitem, {
'size' => $size,
'mime' => 'application/x-tar',
'code' => 200,
'attachment' => basename($requestfile).'.tar'
});
return 0;
}
lib/MHFS/HTTP/Server/Client/Request.pm view on Meta::CPAN
{
'LD_PRELOAD' => $libtarsize
});
}
sub SendDirectory {
my ($request, $droot) = @_;
# otherwise attempt to send a file from droot
my $requestfile = abs_path($droot . $request->{'path'}{'unsafecollapse'});
say "abs requestfile: $requestfile" if(defined $requestfile);
# not a file or is outside of the document root
if(( ! defined $requestfile) ||
(rindex($requestfile, $droot, 0) != 0)){
$request->Send404;
}
# is regular file
elsif (-f $requestfile) {
if(index($request->{'path'}{'unsafecollapse'}, '/', length($request->{'path'}{'unsafecollapse'})-1) == -1) {
$request->SendFile($requestfile);
lib/MHFS/HTTP/Server/Client/Request.pm view on Meta::CPAN
else {
$request->Send404;
}
}
sub SendDirectoryListing {
my ($self, $absdir, $urldir) = @_;
my $urf = $absdir .'/'.substr($self->{'path'}{'unsafepath'}, length($urldir));
my $requestfile = abs_path($urf);
my $ml = $absdir;
say "rf $requestfile " if(defined $requestfile);
if (( ! defined $requestfile) || (rindex($requestfile, $ml, 0) != 0)){
$self->Send404;
return;
}
if(-f $requestfile) {
if(index($self->{'path'}{'unsafecollapse'}, '/', length($self->{'path'}{'unsafecollapse'})-1) == -1) {
$self->SendFile($requestfile);
}
else {
lib/MHFS/HTTP/Server/Client/Request.pm view on Meta::CPAN
my ($self, $handler) = @_;
if(length($self->{'client'}{'inbuf'}) < $self->{'header'}{'Content-Length'}) {
$self->{'client'}->SetEvents(POLLIN | MHFS::EventLoop::Poll->ALWAYSMASK );
}
my $sdata;
$self->{'on_read_ready'} = sub {
my $contentlength = $self->{'header'}{'Content-Length'};
$sdata .= $self->{'client'}{'inbuf'};
my $dlength = length($sdata);
if($dlength >= $contentlength) {
say 'PUTBuf datalength ' . $dlength;
my $data;
if($dlength > $contentlength) {
$data = substr($sdata, 0, $contentlength);
$self->{'client'}{'inbuf'} = substr($sdata, $contentlength);
$dlength = length($data)
}
else {
$data = $sdata;
$self->{'client'}{'inbuf'} = '';
}
lib/MHFS/HTTP/Server/Client/Request.pm view on Meta::CPAN
}
#return '';
return 1;
};
$self->{'on_read_ready'}->();
}
sub PUTBuf {
my ($self, $handler) = @_;
if($self->{'header'}{'Content-Length'} > 20000000) {
say "PUTBuf too big";
$self->{'client'}->SetEvents(POLLIN | MHFS::EventLoop::Poll->ALWAYSMASK );
$self->{'on_read_ready'} = sub { return undef };
return;
}
if(length($self->{'client'}{'inbuf'}) < $self->{'header'}{'Content-Length'}) {
$self->{'client'}->SetEvents(POLLIN | MHFS::EventLoop::Poll->ALWAYSMASK );
}
$self->{'on_read_ready'} = sub {
my $contentlength = $self->{'header'}{'Content-Length'};
my $dlength = length($self->{'client'}{'inbuf'});
if($dlength >= $contentlength) {
say 'PUTBuf datalength ' . $dlength;
my $data;
if($dlength > $contentlength) {
$data = substr($self->{'client'}{'inbuf'}, 0, $contentlength, '');
}
else {
$data = $self->{'client'}{'inbuf'};
$self->{'client'}{'inbuf'} = '';
}
$self->{'on_read_ready'} = undef;
$handler->($data);
lib/MHFS/HTTP/Server/Client/Request.pm view on Meta::CPAN
return 1;
};
$self->{'on_read_ready'}->();
}
sub SendFile {
my ($self, $requestfile) = @_;
foreach my $uploader (@{$self->{'client'}{'server'}{'uploaders'}}) {
return if($uploader->($self, $requestfile));
}
say "SendFile - SendLocalFile $requestfile";
return $self->SendLocalFile($requestfile);
}
1;
lib/MHFS/Plugin/BitTorrent/Client/Interface.pm view on Meta::CPAN
$torrent{'size_bytes'} = $4;
$torrent{'bytes_done'} = $5;
$torrent{'private'} = $6;
if($is_unicode) {
my $escaped_unicode = $torrent{'name'};
$torrent{'name'} =~ s/\\u(.{4})/chr(hex($1))/eg;
$torrent{'name'} =~ s/\\x(.{2})/chr(hex($1))/eg;
my $decoded_as = $torrent{'name'};
$torrent{'name'} = ${escape_html($torrent{'name'})};
if($qs->{'logunicode'}) {
say 'unicode escaped: ' . $escaped_unicode;
say 'decoded as: ' . $decoded_as;
say 'html escaped ' . $torrent{'name'};
}
}
$buf .= '<tr><td>' . $torrent{'name'} . '</td><td>' . $torrent{'hash'} . '</td><td>' . $torrent{'size_bytes'} . '</td><td>' . $torrent{'bytes_done'} . '</td><td>' . $torrent{'private'} . '</td></tr>';
$curtor = '';
}
else {
my $line = shift @lines;
if(! $line) {
last;
}
lib/MHFS/Plugin/BitTorrent/Client/Interface.pm view on Meta::CPAN
my $packagename = __PACKAGE__;
my $self = $request->{'client'}{server}{'loaded_plugins'}{$packagename};
if((exists $request->{'qs'}{'dlsubsystem'}) && (exists $request->{'qs'}{'privdata'}) ) {
my $subsystem = $request->{'qs'}{'dlsubsystem'};
if(exists $self->{'dlsubsystems'}{$subsystem}) {
my $server = $request->{'client'}{'server'};
$self->{'dlsubsystems'}{$subsystem}->dl($server, $request->{'qs'}{'privdata'}, sub {
my ($result, $destdir) = @_;
if(! $result) {
say "failed to dl torrent";
$request->Send404;
return;
}
MHFS::BitTorrent::Client::torrent_start($server, \$result, $destdir, {
'on_success' => sub {
my ($hexhash) = @_;
$request->SendRedirectRawURL(301, 'view?infohash=' . $hexhash);
},
'on_failure' => sub {
$request->Send404;
lib/MHFS/Plugin/BitTorrent/Tracker.pm view on Meta::CPAN
sub createTorrent {
my ($self, $request) = @_;
my $fileitem = $self->{fs}->lookup($request->{'qs'}{'name'}, $request->{'qs'}{'sid'});
if(!$fileitem) {
$request->Send404;
return;
}
my $absurl = $request->getAbsoluteURL;
if(! $absurl) {
say 'unable to $request->getAbsoluteURL';
$request->Send404;
}
print Dumper($fileitem);
my $outputname = $self->{'settings'}{'MHFS_TRACKER_TORRENT_DIR'}.'/'.$fileitem->{'name'}.'.torrent';
my %maketorrent = ( private => 1,
dest_metafile => $outputname,
src => $fileitem->{filepath},
tracker => $absurl.'/torrent/tracker');
my $server = $request->{'client'}{'server'};
my $evp = $server->{'evp'};
lib/MHFS/Plugin/BitTorrent/Tracker.pm view on Meta::CPAN
catch ($e) {
$request->Send404;
return;
}
};
my $torrent = MHFS::BitTorrent::Metainfo::Parse(\$torrentData);
if(! $torrent) {
$request->Send404; return;
}
my $asciihash = $torrent->InfohashAsHex();
say "asciihash: $asciihash";
$self->{'torrents'}{pack('H*', $asciihash)} //= {};
MHFS::BitTorrent::Client::torrent_start($server, \$torrentData, $fileitem->{'containingdir'}, {
'on_success' => sub {
$request->{'responseopt'}{'cd_file'} = 'attachment';
$request->SendLocalFile($outputname, 'applications/x-bittorrent');
},
'on_failure' => sub {
$request->Send404;
}
lib/MHFS/Plugin/BitTorrent/Tracker.pm view on Meta::CPAN
}
sub peertostring {
my ($peer) = @_;
my @pvals = unpack('CCCCCC', $peer);
return "$pvals[0].$pvals[1].$pvals[2].$pvals[3]:" . (($pvals[4] << 8) | $pvals[5]);
}
sub removeTorrentPeer {
my ($self, $infohash, $peer, $reason) = @_;
say __PACKAGE__.": removing torrent peer ".peertostring($peer). " - $reason";
delete $self->{torrents}{$infohash}{$peer};
}
sub announce {
my ($self, $request) = @_;
# hide the tracker if the required parameters aren't there
foreach my $key ('port', 'left', 'info_hash') {
if(! exists $request->{'qs'}{$key}) {
say __PACKAGE__.": missing $key";
$request->Send404;
return;
}
}
my $dictref;
while(1) {
my $port = $request->{'qs'}{'port'};
if($port ne unpack('S', pack('S', $port))) {
$dictref = announce_error("bad port");
lib/MHFS/Plugin/BitTorrent/Tracker.pm view on Meta::CPAN
}
my $rih = $request->{'qs'}{'info_hash'};
if(!exists $self->{torrents}{$rih}) {
$dictref = announce_error("The torrent does not exist!");
last;
}
my $ip = $request->{'ip'};
my $ipport = pack('Nn', $ip, $port);
say __PACKAGE__.": announce from ".peertostring($ipport);
my $event = $request->{'qs'}{'event'};
#if( (! exists $self->{torrents}{$rih}{$ipport}) &&
#((! defined $event) || ($event ne 'started'))) {
# $dictref = announce_error("first announce must include started event");
# last;
#}
if($left == 0) {
$self->{torrents}{$rih}{$ipport}{'completed'} = 1;
}
$self->{torrents}{$rih}{$ipport}{'last_announce'} = clock_gettime(CLOCK_MONOTONIC);
if(defined $event) {
say __PACKAGE__.": announce event $event";
if($event eq 'started') {
#$self->{torrents}{$rih}{$ipport} = {'exists' => 1};
}
elsif($event eq 'stopped') {
$self->removeTorrentPeer($rih, $ipport, " received stopped message");
}
elsif($event eq 'completed') {
#$self->{torrents}{$rih}{$ipport}{'completed'} = 1;
}
}
lib/MHFS/Plugin/BitTorrent/Tracker.pm view on Meta::CPAN
}
else {
$incomplete++;
}
if($i++ < $numwant) {
if($peer ne $ipport) {
my @values = unpack('CCCCCC', $peer);
my $netmap = $request->{'client'}{'server'}{'settings'}{'NETMAP'};
my $pubip = $self->{pubip};
if($netmap && (($values[0] == $netmap->[1]) && (unpack('C', $ipport) != $netmap->[1])) && $pubip) {
say "HACK converting local peer to public ip";
$peer = pack('Nn', $pubip, (($values[4] << 8) | $values[5]));
}
say __PACKAGE__.": sending peer ".peertostring($peer);
$pstr .= $peer;
}
}
}
#push @dict, ['bstr', 'complete'], ['int', $complete];
#push @dict, ['bstr', 'incomplete'], ['int', $incomplete];
push @dict, ['bstr', 'peers'], ['bstr', $pstr];
$dictref = \@dict;
last;
}
# bencode and send
my $bdata = bencode($dictref);
if($bdata) {
$request->SendBytes('text/plain', $bdata);
}
else {
say "Critical: Failed to bencode!";
$request->Send404;
}
}
sub new {
my ($class, $settings, $server) = @_;
my $ai = ($settings->{'BitTorrent::Tracker'} && $settings->{'BitTorrent::Tracker'}{'announce_interval'}) ? $settings->{'BitTorrent::Tracker'}{'announce_interval'} : undef;
$ai //= 1800;
my $self = {'settings' => $settings, 'torrents' => \%{$settings->{'TORRENTS'}}, 'announce_interval' => $ai, 'fs' => $server->{'fs'}};
bless $self, $class;
say __PACKAGE__.": announce interval: ".$self->{'announce_interval'};
if (exists $settings->{'PUBLICIP'}) {
try { $self->{pubip} = parse_ipv4($settings->{'PUBLICIP'}); }
catch ($e) {}
}
# load the existing torrents
my $odres = opendir(my $tdh, $settings->{'MHFS_TRACKER_TORRENT_DIR'});
if(! $odres){
say __PACKAGE__.":failed to open torrent dir";
return undef;
}
while(my $file = readdir($tdh)) {
next if(substr($file, 0, 1) eq '.');
my $fullpath = $settings->{'MHFS_TRACKER_TORRENT_DIR'}."/$file";
my $torrentcontents = do {
try { read_file($fullpath) }
catch ($e) {
say __PACKAGE__.": error reading $fullpath";
return;
}
};
my $torrent = MHFS::BitTorrent::Metainfo::Parse(\$torrentcontents);
if(! $torrent) {
say __PACKAGE__.": error parsing $fullpath";
return undef;
}
$self->{'torrents'}{$torrent->{'infohash'}} = {};
say __PACKAGE__.": added torrent ".$torrent->InfohashAsHex() . ' '.$file;
}
$self->{'routes'} = [
['/torrent/tracker', sub {
my ($request) = @_;
$self->announce($request);
}],
['/torrent/create', sub {
my ($request) = @_;
$self->createTorrent($request);
}],
];
$self->{'timers'} = [
# once an hour evict peers that left the swarm ungracefully
[0, 3600, sub {
my ($timer, $current_time, $evp) = @_;
say __PACKAGE__.": evict peers timer";
foreach my $infohash (keys %{$self->{'torrents'}}) {
foreach my $peer (keys %{$self->{'torrents'}{$infohash}}) {
my $peerdata = $self->{'torrents'}{$infohash}{$peer};
if(($current_time - $peerdata->{'last_announce'}) > ($self->{'announce_interval'}+60)) {
$self->removeTorrentPeer($infohash, $peer, " timeout");
}
}
}
return 1;
}],
lib/MHFS/Plugin/GetVideo.pm view on Meta::CPAN
[
'/get_video', \&get_video
],
];
return $self;
}
sub get_video {
my ($request) = @_;
say "/get_video ---------------------------------------";
my $packagename = __PACKAGE__;
my $server = $request->{'client'}{'server'};
my $self = $server->{'loaded_plugins'}{$packagename};
my $settings = $server->{'settings'};
my $videoformats = $self->{VIDEOFORMATS};
$request->{'responseopt'}{'cd_file'} = 'inline';
my $qs = $request->{'qs'};
$qs->{'fmt'} //= 'noconv';
my %video = ('out_fmt' => $self->video_get_format($qs->{'fmt'}));
if(defined($qs->{'name'})) {
lib/MHFS/Plugin/GetVideo.pm view on Meta::CPAN
return undef;
}
}
else {
$request->Send404;
return undef;
}
print Dumper($video{'src_file'});
# no conversion necessary, just SEND IT
if($video{'out_fmt'} eq 'noconv') {
say "NOCONV: SEND IT";
$request->SendFile($video{'src_file'}{'filepath'});
return 1;
}
elsif($video{'out_fmt'} eq 'mkvinfo') {
get_video_mkvinfo($request, $video{'src_file'}{'filepath'});
return 1;
}
elsif($video{'out_fmt'} eq 'fmp4') {
get_video_fmp4($request, $video{'src_file'}{'filepath'});
return;
lib/MHFS/Plugin/GetVideo.pm view on Meta::CPAN
}
# Determine the full path to the desired file
my $fmt = $video{'out_fmt'};
$video{'out_location'} = $settings->{'VIDEO_TMPDIR'} . '/' . $video{'out_base'};
$video{'out_filepath'} = $video{'out_location'} . '/' . $video{'out_base'} . '.' . $videoformats->{$video{'out_fmt'}}{'ext'};
$video{'out_location_url'} = 'get_video?'.$settings->{VIDEO_TMPDIR_QS}.'&fmt=noconv&name='.$video{'out_base'}.'%2F';
# Serve it up if it has been created
if(-e $video{'out_filepath'}) {
say $video{'out_filepath'} . " already exists";
$request->SendFile($video{'out_filepath'});
return 1;
}
# otherwise create it
mkdir($video{'out_location'});
if(($videoformats->{$fmt}{'lock'} == 1) && (LOCK_WRITE($video{'out_filepath'}) != 1)) {
say "FAILED to LOCK";
# we should do something here
}
if($video{'plugin'}) {
$video{'plugin'}->downloadAndServe($request, \%video);
return 1;
}
elsif(defined($videoformats->{$fmt}{'create_cmd'})) {
my @cmd = @{$videoformats->{$fmt}{'create_cmd'}->(\%video)};
print "$_ " foreach @cmd;
print "\n";
video_on_streams(\%video, $request, sub {
#say "there should be no pids around";
#$request->Send404;
#return undef;
if($fmt eq 'hls') {
$video{'on_exists'} = \&video_hls_write_master_playlist;
}
# deprecated
$video{'pid'} = ASYNC(\&shellcmd_unlock, \@cmd, $video{'out_filepath'});
# our file isn't ready yet, so create a timer to check the progress and act
weaken($request); # the only one who should be keeping $request alive is the client
$request->{'client'}{'server'}{'evp'}->add_timer(0, 0, sub {
if(! defined $request) {
say "\$request undef, ignoring CB";
return undef;
}
# test if its ready to send
while(1) {
my $filename = $video{'out_filepath'};
if(! -e $filename) {
last;
}
my $minsize = $videoformats->{$fmt}{'minsize'};
if(defined($minsize) && ((-s $filename) < $minsize)) {
last;
}
if(defined $video{'on_exists'}) {
last if (! $video{'on_exists'}->($settings, \%video));
}
say "get_video_timer is destructing";
$request->SendLocalFile($filename);
return undef;
}
# 404, if we didn't send yet the process is not running
if(pid_running($video{'pid'})) {
return 1;
}
say "pid not running: " . $video{'pid'} . " get_video_timer done with 404";
$request->Send404;
return undef;
});
say "get_video: added timer " . $video{'out_filepath'};
});
}
else {
say "out_fmt: " . $video{'out_fmt'};
$request->Send404;
return undef;
}
return 1;
}
sub video_get_format {
my ($self, $fmt) = @_;
if(defined($fmt)) {
lib/MHFS/Plugin/GetVideo.pm view on Meta::CPAN
}
sub video_hls_write_master_playlist {
# Rebuilt the master playlist because reasons; YOU ARE TEARING ME APART, FFMPEG!
my ($settings, $video) = @_;
my $requestfile = $video->{'out_filepath'};
# fix the path to the video playlist to be correct
my $m3ucontent = do {
try { read_text_file($requestfile) }
catch ($e) {
say "$requestfile does not exist or is not UTF-8";
''
}
};
my $subm3u;
my $newm3ucontent = '';
foreach my $line (split("\n", $m3ucontent)) {
# master playlist doesn't get written with base url ...
if($line =~ /^(.+)\.m3u8_v$/) {
$subm3u = "get_video?".$settings->{VIDEO_TMPDIR_QS}."&fmt=noconv&name=" . uri_escape("$1/$1");
$line = $subm3u . '.m3u8_v';
lib/MHFS/Plugin/GetVideo.pm view on Meta::CPAN
}
# Always start at 0, even if we encoded half of the movie
#$newm3ucontent .= '#EXT-X-START:TIME-OFFSET=0,PRECISE=YES' . "\n";
# if ffmpeg created a sub include it in the playlist
($requestfile =~ /^(.+)\.m3u8$/);
my $reqsub = "$1_vtt.m3u8";
if($subm3u && -e $reqsub) {
$subm3u .= "_vtt.m3u8";
say "subm3u $subm3u";
my $default = 'NO';
my $forced = 'NO';
foreach my $sub (@{$video->{'subtitle'}}) {
$default = 'YES' if($sub->{'is_default'});
$forced = 'YES' if($sub->{'is_forced'});
}
# assume its in english
$newm3ucontent .= '#EXT-X-MEDIA:TYPE=SUBTITLES,GROUP-ID="subs",NAME="English",DEFAULT='.$default.',FORCED='.$forced.',URI="' . $subm3u . '",LANGUAGE="en"' . "\n";
}
try { write_text_file($requestfile, $newm3ucontent); }
catch ($e) { say "writing new m3u failed"; }
return 1;
}
sub get_video_mkvinfo {
my ($request, $fileabspath) = @_;
my $matroska = matroska_open($fileabspath);
if(! $matroska) {
$request->Send404;
return;
}
lib/MHFS/Plugin/GetVideo.pm view on Meta::CPAN
}
sub hls_audio_formattime {
my ($ttime) = @_;
my $hours = int($ttime / 3600);
$ttime -= ($hours * 3600);
my $minutes = int($ttime / 60);
$ttime -= ($minutes*60);
#my $seconds = int($ttime);
#$ttime -= $seconds;
#say "ttime $ttime";
#my $mili = int($ttime * 1000000);
#say "mili $mili";
#my $tstring = sprintf "%02d:%02d:%02d.%06d", $hours, $minutes, $seconds, $mili;
my $tstring = sprintf "%02d:%02d:%f", $hours, $minutes, $ttime;
return $tstring;
}
sub adts_get_packet_size {
my ($buf) = @_;
my ($sync, $stuff, $rest) = unpack('nCN', $buf);
if(!defined($sync)) {
say "no pack, len " . length($buf);
return undef;
}
if($sync != 0xFFF1) {
say "bad sync";
return undef;
}
my $size = ($rest >> 13) & 0x1FFF;
return $size;
}
sub ebml_read {
my $ebml = $_[0];
my $buf = \$_[1];
lib/MHFS/Plugin/GetVideo.pm view on Meta::CPAN
}
sub ebml_find_id {
my ($ebml, $id) = @_;
for(;;) {
my $elm = ebml_read_element($ebml);
$elm or return undef;
if($elm->{'id'} == $id) {
return $elm;
}
#say "id " . $elm->{'id'};
ebml_skip($ebml) or return undef;
}
}
sub ebml_make_elms {
my @elms = @_;
my @bufstack = ('');
while(@elms) {
my $elm = $elms[0];
if(! $elm) {
lib/MHFS/Plugin/GetVideo.pm view on Meta::CPAN
'EBMLID_SimpleBlock' => 0xA3,
'EBMLID_BlockGroup' => 0xA0,
'EBMLID_Block' => 0xA1
};
sub matroska_cluster_parse_simpleblock_or_blockgroup {
my ($elm) = @_;
my $data = $elm->{'data'};
if($elm->{'id'} == EBMLID_BlockGroup) {
say "blockgroup";
while(1) {
my $width;
my $id = read_vint_from_buf(\$data, \$width);
defined($id) or return undef;
my $size = read_and_parse_vint_from_buf(\$data);
defined($size) or return undef;
say "blockgroup item: $id $size";
last if($id == EBMLID_Block);
substr($data, 0, $size, '');
}
say "IS BLOCK";
}
elsif($elm->{'id'} == EBMLID_SimpleBlock) {
#say "IS SIMPLEBLOCK";
}
else {
die "unhandled block type";
}
my $trackno = read_and_parse_vint_from_buf(\$data);
if((!defined $trackno) || (length($data) < 3)) {
return undef;
}
my $rawts = substr($data, 0, 2, '');
my $rawflag = substr($data, 0, 1, '');
lib/MHFS/Plugin/GetVideo.pm view on Meta::CPAN
push @sizes, $last;
my $sum = $last;
for(my $i = 0; $i < ($framecnt - 2); $i++) {
my $width;
my $offset = read_and_parse_vint_from_buf(\$data, \$width);
# multiple by 2^bitwidth - 1 (with adjusted bitwidth)
my $desiredbits = (8 * $width) - ($width+1);
my $subtract = (1 << $desiredbits) - 1;
my $result = $offset - $subtract;
$last += $result;
say "offset $offset width $width factor: " . sprintf("0x%X ", $subtract) . "result $result evaled $last";
push @sizes, $last;
$sum += $last;
}
my $lastlast = length($data) - $sum;
say "lastlast $lastlast";
push @sizes, $lastlast;
}
# fixed
elsif($lacing == 0x4) {
$framecnt = unpack('C', substr($data, 0, 1, ''))+1;
my $framesize = length($data) / $framecnt;
for(my $i = 0; $i < $framecnt; $i++) {
push @sizes, $framesize;
}
}
lib/MHFS/Plugin/GetVideo.pm view on Meta::CPAN
my $fh = $_[0];
my $type = \$_[1];
my $done = \$_[2];
my $buf;
my $headread = read($fh, $buf, 4);
($headread && ($headread == 4)) or return undef;
my ($blocktypelast, $sizehi, $sizemid, $sizelo) = unpack('CCCC',$buf);
$$done = $blocktypelast & 0x80;
$$type = $blocktypelast & 0x7F;
my $size = ($sizehi << 16) | ($sizemid << 8) | ($sizelo);
#say "islast $$done type $type size $size";
$$type != 0x7F or return undef;
my $tbuf;
my $dataread = read($fh, $tbuf, $size);
($dataread && ($dataread == $size)) or return undef;
$buf .= $tbuf;
return \$buf;
}
sub flac_parseStreamInfo {
# https://metacpan.org/source/DANIEL/Audio-FLAC-Header-2.4/Header.pm
lib/MHFS/Plugin/GetVideo.pm view on Meta::CPAN
my $ebml = ebml_open($filename);
if(! $ebml) {
return undef;
}
# find segment
my $foundsegment = ebml_find_id($ebml, EBMLID_Segment);
if(!$foundsegment) {
return undef;
}
say "Found segment";
my %segment = (id => EBMLID_Segment, 'infsize' => 1, 'elms' => []);
# find segment info
my $foundsegmentinfo = ebml_find_id($ebml, EBMLID_SegmentInfo);
if(!$foundsegmentinfo) {
return undef;
}
say "Found segment info";
my %segmentinfo = (id => EBMLID_SegmentInfo, elms => []);
# find TimestampScale
my $tselm = ebml_find_id($ebml, EBMLID_TimestampScale);
if(!$tselm) {
return undef;
}
say "Found ts elm";
my $tsbinary;
if(!ebml_read($ebml, $tsbinary, $tselm->{'size'})) {
return undef;
}
Dump($tsbinary);
my $tsval = parse_uinteger_str($tsbinary);
defined($tsval) or return undef;
say "tsval: $tsval";
if(!ebml_skip($ebml)) {
return undef;
}
push @{$segmentinfo{'elms'}}, {id => EBMLID_TimestampScale, data => $tsbinary};
# find Duration
my $durationelm = ebml_find_id($ebml, EBMLID_Duration);
if(!$durationelm) {
return undef;
}
say "Found duration elm";
my $durbin;
if(!ebml_read($ebml, $durbin, $durationelm->{'size'})) {
return undef;
}
Dump($durbin);
my $scaledduration = parse_float_str($durbin);
say "scaledduration $scaledduration";
my $duration = ($tsval * $scaledduration)/1000000000;
say "duration: $duration";
# exit duration
if(!ebml_skip($ebml)) {
return undef;
}
# exit segment informations
if(!ebml_skip($ebml)) {
return undef;
}
lib/MHFS/Plugin/GetVideo.pm view on Meta::CPAN
# loop through the Tracks
my %CodecPCMFrameLength = ( 'AAC' => 1024, 'EAC3' => 1536, 'AC3' => 1536, 'PCM' => 1);
my %CodecGetSegment = ('AAC' => sub {
my ($seginfo, $dataref) = @_;
my $targetpackets = $seginfo->{'expected'} / $CodecPCMFrameLength{'AAC'};
my $start = 0;
my $packetsread = 0;
while(1) {
my $packetsize = adts_get_packet_size(substr($$dataref, $start, 7));
$packetsize or return undef;
say "packet size $packetsize";
$start += $packetsize;
$packetsread++;
if($packetsread == $targetpackets) {
return {'mime' => 'audio/aac', 'data' => hls_audio_get_id3($seginfo->{'stime'}).substr($$dataref, 0, $start, '')};
}
}
return undef;
}, 'PCM' => sub {
my ($seginfo, $dataref) = @_;
my $targetsize = 2 * $seginfo->{'channels'}* $seginfo->{'expected'};
lib/MHFS/Plugin/GetVideo.pm view on Meta::CPAN
my $telm = ebml_read_element($ebml);
if(!$telm) {
ebml_skip($ebml);
last;
}
# save the element into tracks
my %elm = ('id' => $telm->{'id'}, 'data' => '');
ebml_read($ebml, $elm{'data'}, $telm->{'size'});
if($elm{'id'} == EBMLID_TrackNumber) {
say "trackno";
$elm{'value'} = unpack('C', $elm{'data'});
$track{$elm{'id'}} = \%elm;
}
elsif($elm{'id'} == EBMLID_CodecID) {
say "codec " . $elm{'data'};
if($elm{'data'} =~ /^([A-Z]+_)([A-Z0-9]+)(?:\/([A-Z0-9_\/]+))?$/) {
$track{'CodecID_Prefix'} = $1;
$track{'CodecID_Major'} = $2;
if($3) {
$track{'CodecID_Minor'} = $3;
}
$track{'PCMFrameLength'} = $CodecPCMFrameLength{$track{'CodecID_Major'}} if($track{'CodecID_Prefix'} eq 'A_');
}
$track{$elm{'id'}} = \%elm;
}
elsif($elm{'id'} == EBMLID_TrackType) {
say "tracktype";
$elm{'value'} = unpack('C', $elm{'data'});
$track{$elm{'id'}} = \%elm;
}
elsif($elm{'id'} == EBMLID_TrackUID) {
say "trackuid";
$track{$elm{'id'}} = \%elm;
}
elsif($elm{'id'} == EBMLID_DefaulDuration) {
say "defaultduration";
$elm{'value'} = parse_uinteger_str($elm{'data'});
$track{$elm{'id'}} = \%elm;
$track{'fps'} = int(((1/($elm{'value'} / 1000000000)) * 1000) + 0.5)/1000;
}
elsif($elm{'id'} == EBMLID_AudioTrack) {
say "audiotrack";
my $buf = $elm{'data'};
while(length($buf)) {
# read the id, size, and data
my $vintwidth;
my $id = read_vint_from_buf(\$buf, \$vintwidth);
if(!$id) {
last;
}
say "elmid $id width $vintwidth";
say sprintf("0x%X 0x%X", ord(substr($buf, 0, 1)), ord(substr($buf, 1, 1)));
my $size = read_and_parse_vint_from_buf(\$buf);
if(!$size) {
last;
}
say "size $size";
my $data = substr($buf, 0, $size, '');
# save metadata
if($id == EBMLID_AudioSampleRate) {
$track{$id} = parse_float_str($data);
say "samplerate " . $track{$id};
}
elsif($id == EBMLID_AudioChannels) {
$track{$id} = parse_uinteger_str($data);
say "channels " . $track{$id};
}
}
}
ebml_skip($ebml);
}
# add the fake track
if(($track{'CodecID_Major'} eq 'EAC3') || ($track{'CodecID_Major'} eq 'AC3')) {
$track{'faketrack'} = {
'PCMFrameLength' => $CodecPCMFrameLength{'AAC'},
lib/MHFS/Plugin/GetVideo.pm view on Meta::CPAN
my %cluster = ( 'fileoffset' => tell($ebml->{'fh'}), 'size' => $custer->{'size'}, 'Segment_sizeleft' => $ebml->{'elements'}[0]{'size'});
# find the cluster timestamp
for(;;) {
my $belm = ebml_read_element($ebml);
if(!$belm) {
ebml_skip($ebml);
last;
}
my %elm = ('id' => $belm->{'id'}, 'data' => '');
#say "elm size " . $belm->{'size'};
ebml_read($ebml, $elm{'data'}, $belm->{'size'});
if($elm{'id'} == EBMLID_ClusterTimestamp) {
$cluster{'rawts'} = parse_uinteger_str($elm{'data'});
$cluster{'ts'} = $cluster{'rawts'} * $matroska->{'tsscale'};
# exit ClusterTimestamp
ebml_skip($ebml);
# exit cluster
ebml_skip($ebml);
return \%cluster;
}
lib/MHFS/Plugin/GetVideo.pm view on Meta::CPAN
sub matroska_get_track_block {
my ($matroska, $tid) = @_;
my $ebml = $matroska->{'ebml'};
for(;;) {
my $belm = ebml_read_element($ebml);
if(!$belm) {
ebml_skip($ebml); # leave cluster
my $cluster = matroska_read_cluster_metadata($matroska);
if($cluster) {
say "advancing cluster";
$matroska->{'dc'} = $cluster;
ebml_set_cluster($ebml, $matroska->{'dc'});
next;
}
last;
}
my %elm = ('id' => $belm->{'id'}, 'data' => '');
#say "elm size " . $belm->{'size'};
ebml_read($ebml, $elm{'data'}, $belm->{'size'});
if(($elm{'id'} == EBMLID_SimpleBlock) || ($elm{'id'} == EBMLID_BlockGroup)) {
my $block = matroska_cluster_parse_simpleblock_or_blockgroup(\%elm);
if($block && ($block->{'trackno'} == $tid)) {
ebml_skip($ebml);
return $block;
}
}
ebml_skip($ebml);
lib/MHFS/Plugin/GetVideo.pm view on Meta::CPAN
if($prevcluster) {
$prevcluster->{'prevcluster'} = undef;
$desiredcluster->{'prevcluster'} = $prevcluster;
}
}
if($ctime >= $timeinseconds) {
last;
}
}
say "before dc check";
return undef if(! $desiredcluster);
say "cur rawts " . $desiredcluster->{'rawts'};
say "last rawts " . $desiredcluster->{'prevcluster'}{'rawts'} if($desiredcluster->{'prevcluster'});
# restore to the the cluster that probably has the GOP
my $ebml = $matroska->{'ebml'};
ebml_set_cluster($ebml, $desiredcluster);
$matroska->{'dc'} = $desiredcluster;
# find a valid track block that includes pcmFrameIndex;
my $block;
my $blocktime;
while(1) {
lib/MHFS/Plugin/GetVideo.pm view on Meta::CPAN
$block = undef;
}
if(! $matroska->{'dc'}{'firstblk'}) {
$matroska->{'dc'}{'firstblk'} = $blocktime;
}
}
if(! $block) {
if(! $prevcluster) {
return undef;
}
say "revert cluster";
$matroska->{'dc'} = $prevcluster;
ebml_set_cluster($ebml, $matroska->{'dc'});
next;
}
$prevcluster = undef;
my $blockduration = ((1/24) * scalar(@{$block->{'frame_lengths'}}));
if($timeinseconds < ($blocktime + $blockduration)) {
say 'got GOP at ' . $matroska->{'dc'}{'firstblk'};
return {'goptime' => $matroska->{'dc'}{'firstblk'}};
last;
}
}
}
sub matroska_seek_track {
my ($matroska, $track, $pcmFrameIndex) = @_;
my $tid = $track->{&EBMLID_TrackNumber}{'value'};
lib/MHFS/Plugin/GetVideo.pm view on Meta::CPAN
if($prevcluster) {
$prevcluster->{'prevcluster'} = undef;
$desiredcluster->{'prevcluster'} = $prevcluster;
}
}
# this cluster is at or past the frame, breakout
if($curframe >= $pcmFrameIndex){
last;
}
}
say "before dc check";
return undef if(! $desiredcluster);
say "cur rawts " . $desiredcluster->{'rawts'};
say "last rawts " . $desiredcluster->{'prevcluster'}{'rawts'} if($desiredcluster->{'prevcluster'});
# restore to the the cluster that probably has our audio
my $ebml = $matroska->{'ebml'};
ebml_set_cluster($ebml, $desiredcluster);
$matroska->{'dc'} = $desiredcluster;
# find a valid track block that includes pcmFrameIndex;
my $block;
my $blockframe;
while(1) {
lib/MHFS/Plugin/GetVideo.pm view on Meta::CPAN
if($block) {
$blockframe = matroska_block_calc_frame($matroska, $block, $samplerate, $pcmFrameLen);
if($blockframe > $pcmFrameIndex) {
$block = undef;
}
}
if(! $block) {
if(! $prevcluster) {
return undef;
}
say "revert cluster";
$matroska->{'dc'} = $prevcluster;
ebml_set_cluster($ebml, $matroska->{'dc'});
next;
}
$prevcluster = undef;
my $pcmSampleCount = ($pcmFrameLen * scalar(@{$block->{'frame_lengths'}}));
if($pcmFrameIndex < ($blockframe + $pcmSampleCount)) {
if((($pcmFrameIndex - $blockframe) % $pcmFrameLen) != 0) {
say "Frame index does not align with block!";
return undef;
}
last;
}
}
# add the data to packs
my $offset = 0;
while($blockframe < $pcmFrameIndex) {
my $len = shift @{$block->{'frame_lengths'}};
lib/MHFS/Plugin/GetVideo.pm view on Meta::CPAN
$matroska->{'curframe'} = $pcmFrameIndex;
foreach my $len (@{$block->{'frame_lengths'}}) {
push @{$matroska->{'curpaks'}}, substr($block->{'data'}, $offset, $len);
$offset += $len;
}
return 1;
}
sub matroska_calc_block_fullts {
my ($matroska, $block) = @_;
say 'clusterts ' . ($matroska->{'dc'}->{'ts'}/1000000000);
say 'blockts ' . $block->{'ts'};
my $time = ($matroska->{'dc'}->{'rawts'} + $block->{'ts'}) * $matroska->{'tsscale'};
return ($time/1000000000);
}
sub matroska_block_calc_frame {
my ($matroska, $block, $samplerate, $pcmFrameLen) = @_;
say 'clusterts ' . ($matroska->{'dc'}->{'ts'}/1000000000);
say 'blockts ' . $block->{'ts'};
my $time = ($matroska->{'dc'}->{'rawts'} + $block->{'ts'}) * $matroska->{'tsscale'};
say 'blocktime ' . ($time/1000000000);
my $calcframe = matroska_ts_to_sample($matroska, $samplerate, $time);
return round($calcframe/$pcmFrameLen)*$pcmFrameLen;
}
sub matroska_read_track {
my ($matroska, $track, $pcmFrameIndex, $numsamples, $formatpacket) = @_;
my $tid = $track->{&EBMLID_TrackNumber}{'value'};
my $samplerate = $track->{&EBMLID_AudioSampleRate};
my $pcmFrameLen = $track->{'PCMFrameLength'};
if(!$pcmFrameLen) {
warn("Unknown codec");
return undef;
}
# find the cluster that might have the start of our audio
if($matroska->{'curframe'} != $pcmFrameIndex) {
say "do seek";
if(!matroska_seek_track($matroska, $track, $pcmFrameIndex)) {
return undef;
}
}
my $outdata;
my $destframe = $matroska->{'curframe'} + $numsamples;
while(1) {
# add read audio
while(@{$matroska->{'curpaks'}}) {
my $pak = shift @{$matroska->{'curpaks'}};
$outdata .= $formatpacket->($pak, $samplerate);
$matroska->{'curframe'} += $pcmFrameLen;
if($matroska->{'curframe'} == $destframe) {
say "done, read enough";
return $outdata;
}
}
# load a block
my $block = matroska_get_track_block($matroska, $tid);
if(! $block) {
if(($matroska->{'ebml'}{'elements'}[0]{'id'} == EBMLID_Segment) && ($matroska->{'ebml'}{'elements'}[0]{'size'} == 0)) {
say "done, EOF";
}
else {
say "done, Error";
}
return $outdata;
}
# add the data to paks
my $offset = 0;
foreach my $len (@{$block->{'frame_lengths'}}) {
push @{$matroska->{'curpaks'}}, substr($block->{'data'}, $offset, $len);
$offset += $len;
}
lib/MHFS/Plugin/GetVideo.pm view on Meta::CPAN
$current_element->{'is_forced'} = 1 if($current_element->{'fmt'} =~ /FORCED/i);
if($type =~ /audio/i) {
push @{$video->{'audio'}} , $current_element;
}
elsif($type =~ /video/i) {
push @{$video->{'video'}} , $current_element;
}
elsif($type =~ /subtitle/i) {
push @{$video->{'subtitle'}} , $current_element;
}
say $eline;
}
elsif($eline =~ /^\s+Duration:\s+(\d\d):(\d\d):(\d\d)\.(\d\d)/) {
#TODO add support for over day long video
$video->{'duration'} //= "PT$1H$2M$3.$4S";
try { write_text_file($video->{'out_location'} . '/duration', $video->{'duration'}); }
catch ($e) { say "writing new duration file failed"; }
}
elsif(defined $current_stream) {
if($eline !~ /^\s\s+/) {
$current_stream = undef;
$current_element = undef;
next;
}
$current_element->{'metadata'} .= $eline;
if($eline =~ /\s+title\s*:\s*(.+)$/) {
$current_element->{'title'} = $1;
lib/MHFS/Plugin/Kodi.pm view on Meta::CPAN
warn "Error in opening dir $b_tvdir\n";
return;
}
my @diritems;
while (my $b_filename = readdir($dh)) {
next if(($b_filename eq '.') || ($b_filename eq '..'));
next if(!(-s "$b_tvdir/$b_filename"));
my $filename = decode('UTF-8', $b_filename, Encode::FB_DEFAULT | Encode::LEAVE_SRC);
next if (! -d _ && $filename !~ /\.(?:avi|mkv|mp4|m4v)$/);
if ($filename !~ /^(.+?)(?:[\.\s]+(\d{4}))?[\.\s]+S(?:eason\s)?0*(\d+)/) {
say "suspicious: $filename";
}
if ($filename =~ /S(?:eason\s)?0*(\d+)\-S(?:eason\s)?0*(\d+)/) {
$self->readtvdir($tvshows, $source, "$b_tvdir/$b_filename");
next;
}
my $showname = $1 || $filename;
my $year = $2;
my $season = $3 // 0;
next if (! $showname);
$showname =~ s/\./ /g;
lib/MHFS/Plugin/Kodi.pm view on Meta::CPAN
}
};
# build the tv show library
if(! exists $self->{tvshows} || $request_path eq $kodidir) {
$self->{tvshows} = $self->_build_tv_library($sources);
}
my $tvshows = $self->{tvshows};
my $tvitem;
if ($request_path ne $kodidir) {
my $fulltvpath = substr($request_path, length($kodidir)+1);
say "fulltvpath $fulltvpath";
my ($showid, $season, $source, $b64_item, $slurp) = split('/', $fulltvpath, 5);
if ($slurp) {
say "too many parts";
$request->Send400;
return;
}
$showid = fold_case($showid);
$season // do {
say "no season provided";
$request->Send400;
return;
};
try {
$tvitem = $self->_get_tv_item($tvshows, $showid, $season, $source, $b64_item);
} catch($e) {
say "exception $e";
$request->Send404;
return;
}
if (substr($request->{'path'}{'unescapepath'}, -1) ne '/') {
# redirect if we aren't accessing a file
if (!exists $tvitem->{b_path}) {
$request->SendRedirect(301, substr($request->{'path'}{'unescapepath'}, rindex($request->{'path'}{'unescapepath'}, '/')+1).'/');
} else {
$request->SendFile($tvitem->{b_path});
}
lib/MHFS/Plugin/Kodi.pm view on Meta::CPAN
};
# build the movie library
if(! exists $self->{movies} || $request_path eq $kodidir) {
$self->{movies} = $self->_build_movie_library($sources);
}
my $movies = $self->{movies};
# find the movie item
my $movieitem;
if($request_path ne $kodidir) {
my $fullmoviepath = substr($request_path, length($kodidir)+1);
say "fullmoviepath $fullmoviepath";
my ($movieid, $source, $b64_editionname, $b64_partname, $b64_subpath, $subname, $slurp) = split('/', $fullmoviepath, 7);
if ($slurp) {
say "too many parts";
$request->Send404;
return;
}
say "movieid $movieid";
my $editionname;
my $partname;
my $subfile;
try {
if ($source) {
say "source $source";
if ($b64_editionname) {
$editionname = base64url_to_str($b64_editionname);
say "editionname $editionname";
if ($b64_partname) {
if (length($b64_partname) < 3) {
warn "$b64_partname has invalid format";
$request->Send404;
return;
}
$b64_partname = substr($b64_partname, 0, -3);
$partname = base64url_to_str($b64_partname);
say "partname $partname";
if ($b64_subpath && $subname) {
if (length($b64_subpath) < 3) {
warn "$b64_subpath has invalid format";
$request->Send404;
return;
}
$b64_subpath = substr($b64_subpath, 0, -3);
my $subpath = base64url_to_str($b64_subpath);
$subfile = "$subpath$subname";
say "subfile $subfile";
}
}
}
}
$movieitem = $self->_search_movie_library($movies, $movieid, $source, $editionname, $partname, $subfile);
} catch ($e) {
$request->Send404;
return;
}
if (substr($request->{'path'}{'unescapepath'}, -1) ne '/') {
lib/MHFS/Plugin/Kodi.pm view on Meta::CPAN
<platform>all</platform>
<language></language>
<license>GPL-2.0-or-later</license>
<forum>https://github.com/G4Vi/MHFS/issues</forum>
<website>computoid.com</website>
<source>https://github.com/G4Vi/MHFS</source>
</extension>
</addon>
END_XML
my $tmpdir = $request->{client}{server}{settings}{GENERIC_TMPDIR};
say "tmpdir $tmpdir";
my $addondir = "$tmpdir/repository.mhfs";
make_path($addondir);
open(my $fh, '>', "$addondir/addon.xml") or do {
warn "failed to open $addondir/addon.xml";
$request->Send404;
return;
};
print $fh $xml;
close($fh) or do {
warn "failed to close";
lib/MHFS/Plugin/Kodi.pm view on Meta::CPAN
my ($self, $request) = @_;
my $request_path = do {
try { decode_utf_8($request->{path}{unsafepath}) }
catch($e) {
warn "$request->{path}{unsafepath} is not, UTF-8, 400";
$request->Send400;
return;
}
};
my ($mediatype, $metadatatype, $medianame, $season, $episode) = $request_path =~ m!^/kodi/metadata/(movies|tv)/(thumb|fanart|plot)/([^/]+)(?:/0*(\d+)(?:/0*(\d+))?)?$! or do {
say "no match";
$request->Send400;
return;
};
if ($medianame =~ /^.(.)?$/ || ($mediatype eq 'movies' && defined $season)) {
say "no match";
$request->Send400;
return;
}
if ($metadatatype eq 'fanart') {
($season, $episode) = (undef, undef);
}
$medianame = fold_case($medianame);
say "mt $mediatype mmt $metadatatype mn $medianame". (defined $season ? " season $season". (defined $episode ? " episode $episode" : '') : '');
my %allmediaparams = ( 'movies' => {
'meta' => $self->{moviemeta},
'search' => 'movie',
}, 'tv' => {
'meta' => $self->{tvmeta},
'search' => 'tv'
});
my $params = $allmediaparams{$mediatype};
my $b_metadir = $params->{meta} . '/' . encode_utf8($medianame) . (defined $season ? '/'.encode_utf8($season). (defined $episode ? '/'.encode_utf8($episode) : '') : '');
my $b_plotfile = $params->{meta} . '/' . encode_utf8($medianame) . '/'. (defined $season ? encode_utf8($season).'/season.json' : 'plot.txt');
lib/MHFS/Plugin/Kodi.pm view on Meta::CPAN
}
}
# slow path, download it
$request->{client}{server}{settings}{TMDB} or do {
$request->Send404;
return;
};
# find the movie or tv show
my $searchname = $medianame;
$searchname =~ s/\s\(\d\d\d\d\)// if($mediatype eq 'movies');
say "searchname $searchname";
weaken($request);
_TMDB_api_promise($request->{client}{server}, 'search/'.$params->{search}, {'query' => $searchname})->then(sub {
my $json = $_[0]->{results}[0];
$json or die "Failed to find item";
$season // return $json;
# find the season and then the episode if applicable
my $showid = $json->{id} // die "showid not available";
_TMDB_api_promise($request->{client}{server}, "tv/$showid/season/$season")->then(sub {
if ($metadatatype eq 'plot' || ! -f $b_plotfile) {
make_path($b_metadir);
my $bytes = encode_json($_[0]);
try { write_file($b_plotfile, $bytes) }
catch ($e) { say "wierd, creating file failed?"; }
}
$episode // return $_[0];
MHFS::Kodi::Season::_get_season_episode($_[0], $episode)
})
})->then(sub {
# get the metadata
if (! defined $season && ($metadatatype eq 'plot' || ! -f "$b_metadir/plot.txt")) {
make_path($b_metadir);
try { write_text_file_lossy("$b_metadir/plot.txt", $_[0]->{overview}) }
catch ($e) { say "wierd, creating file failed?"; }
}
if($metadatatype eq 'plot') {
$request->SendText('text/plain; charset=utf-8', $_[0]->{overview});
return;
}
# thumb or fanart
my $imagepartial = ($metadatatype eq 'thumb') ? (! defined $episode ? $_[0]->{poster_path} : $_[0]->{still_path}) : $_[0]->{backdrop_path};
if (!$imagepartial || $imagepartial !~ /(\.[^\.]+)$/) {
die 'path not matched '.$imagepartial;
}
lib/MHFS/Plugin/MusicLibrary.pm view on Meta::CPAN
$self->{'musicdbhtml'} = encode('UTF-8', $buf, Encode::FB_CROAK);
$self->{'musicdbjson'} = toJSON($self);
}
sub SendLibrary {
my ($self, $request) = @_;
# maybe not allow everyone to do these commands?
if($request->{'qs'}{'forcerefresh'}) {
say __PACKAGE__.": forcerefresh";
$self->BuildLibraries();
}
elsif($request->{'qs'}{'refresh'}) {
say __PACKAGE__.": refresh";
UpdateLibrariesAsync($self, $request->{'client'}{'server'}{'evp'}, sub {
say __PACKAGE__.": refresh done";
$request->{'qs'}{'refresh'} = 0;
SendLibrary($self, $request);
});
return 1;
}
# deduce the format if not provided
my $fmt = $request->{'qs'}{'fmt'};
if(! $fmt) {
$fmt = 'worklet';
lib/MHFS/Plugin/MusicLibrary.pm view on Meta::CPAN
return $request->SendBytes("text/html; charset=utf-8", $self->{'musicdbhtml'});
}
elsif($fmt eq 'gapless') {
$qs->{fmt} = 'musicinc';
return $request->SendRedirect(301, "music", $qs);
}
elsif($fmt eq 'musicinc') {
return $request->SendRedirect(307, 'static/music_inc/', $qs);
}
elsif($fmt eq 'legacy') {
say __PACKAGE__.": legacy";
return $request->SendBytes("text/html; charset=utf-8", $self->{'html'});
}
else {
return $request->Send404;
}
}
my $SEGMENT_DURATION = 5;
my %TRACKDURATION;
my %TRACKINFO;
sub SendTrack {
my ($request, $tosend) = @_;
if(defined $request->{'qs'}{'part'}) {
if(! HAS_MHFS_XS) {
say __PACKAGE__.": route not available without XS";
$request->Send503();
return;
}
if(! $TRACKDURATION{$tosend}) {
say __PACKAGE__.": failed to get track duration";
$request->Send503();
return;
}
say "no proc, duration cached";
my $pv = MHFS::XS::new($tosend);
$request->{'outheaders'}{'X-MHFS-NUMSEGMENTS'} = ceil($TRACKDURATION{$tosend} / $SEGMENT_DURATION);
$request->{'outheaders'}{'X-MHFS-TRACKDURATION'} = $TRACKDURATION{$tosend};
$request->{'outheaders'}{'X-MHFS-MAXSEGDURATION'} = $SEGMENT_DURATION;
my $samples_per_seg = $TRACKINFO{$tosend}{'SAMPLERATE'} * $SEGMENT_DURATION;
my $spos = $samples_per_seg * ($request->{'qs'}{'part'} - 1);
my $samples_left = $TRACKINFO{$tosend}{'TOTALSAMPLES'} - $spos;
my $res = MHFS::XS::get_flac($pv, $spos, $samples_per_seg < $samples_left ? $samples_per_seg : $samples_left);
$request->SendBytes('audio/flac', $res);
}
elsif(defined $request->{'qs'}{'fmt'} && ($request->{'qs'}{'fmt'} eq 'wav')) {
if(! HAS_MHFS_XS) {
say __PACKAGE__.": route not available without XS";
$request->Send503();
return;
}
my $pv = MHFS::XS::new($tosend);
my $outbuf = '';
my $wavsize = (44+ $TRACKINFO{$tosend}{'TOTALSAMPLES'} * ($TRACKINFO{$tosend}{'BITSPERSAMPLE'}/8) * $TRACKINFO{$tosend}{'NUMCHANNELS'});
my $startbyte = $request->{'header'}{'_RangeStart'} || 0;
my $endbyte = $request->{'header'}{'_RangeEnd'} // $wavsize-1;
say "start byte" . $startbyte;
say "end byte " . $endbyte;
say "MHFS::XS::wavvfs_read_range " . $startbyte . ' ' . $endbyte;
my $maxsendsize;
$maxsendsize = 1048576/2;
say "maxsendsize $maxsendsize " . ' bytespersample ' . ($TRACKINFO{$tosend}{'BITSPERSAMPLE'}/8) . ' numchannels ' . $TRACKINFO{$tosend}{'NUMCHANNELS'};
$request->SendCallback(sub{
my ($fileitem) = @_;
my $actual_endbyte = $startbyte + $maxsendsize - 1;
if($actual_endbyte >= $endbyte) {
$actual_endbyte = $endbyte;
$fileitem->{'cb'} = undef;
say "SendCallback last send";
}
my $actual_startbyte = $startbyte;
$startbyte = $actual_endbyte+1;
say "SendCallback wavvfs_read_range " . $actual_startbyte . ' ' . $actual_endbyte;
return MHFS::XS::wavvfs_read_range($pv, $actual_startbyte, $actual_endbyte);
}, {
'mime' => 'audio/wav',
'size' => $wavsize,
});
}
else {
if($request->{'qs'}{'action'} && ($request->{'qs'}{'action'} eq 'dl')) {
$request->{'responseopt'}{'cd_file'} = 'attachment';
}
# Send the total pcm frame count for mp3
elsif(lc(substr($tosend, -4)) eq '.mp3') {
if(HAS_MHFS_XS) {
if(! $TRACKINFO{$tosend}) {
$TRACKINFO{$tosend} = { 'TOTALSAMPLES' => MHFS::XS::get_totalPCMFrameCount($tosend) };
say "mp3 totalPCMFrames: " . $TRACKINFO{$tosend}{'TOTALSAMPLES'};
}
$request->{'outheaders'}{'X-MHFS-totalPCMFrameCount'} = $TRACKINFO{$tosend}{'TOTALSAMPLES'};
}
}
$request->SendLocalFile($tosend);
}
}
sub parseStreamInfo {
# https://metacpan.org/source/DANIEL/Audio-FLAC-Header-2.4/Header.pm
lib/MHFS/Plugin/MusicLibrary.pm view on Meta::CPAN
if(!$is_flac) {
$filebase =~ s/\.[^.]+$/.lossy.flac/;
$request->{'localtrack'}{'basename'} = $filebase;
my $tlossy = $tmpfileloc . $filebase;
if(-e $tlossy ) {
$is_flac = 1;
$file = $tlossy;
if(defined LOCK_GET_LOCKDATA($tlossy)) {
# unlikely
say "SendLocalTrack: lossy flac exists and is locked 503";
$request->Send503;
return;
}
}
else {
make_path($tmpfileloc, {chmod => 0755});
my @cmd = ('ffmpeg', '-i', $file, '-c:a', 'flac', '-sample_fmt', 's16', $tlossy);
my $buf;
if(LOCK_WRITE($tlossy)) {
$request->{'process'} = MHFS::Process->new(\@cmd, $evp, {
lib/MHFS/Plugin/MusicLibrary.pm view on Meta::CPAN
UNLOCK_WRITE($tlossy);
SendLocalTrack($request,$tlossy);
},
'STDERR' => sub {
my ($terr) = @_;
read($terr, $buf, 4096);
}});
}
else {
# unlikely
say "SendLocalTrack: lossy flac is locked 503";
$request->Send503;
}
return;
}
}
# everything should be flac now, grab the track info
if(!defined($TRACKINFO{$file}))
{
$TRACKINFO{$file} = GetTrackInfo($file);
$TRACKDURATION{$file} = $TRACKINFO{$file}{'duration'};
}
my $max_sample_rate = $request->{'qs'}{'max_sample_rate'} // 192000;
my $bitdepth = $request->{'qs'}{'bitdepth'} // ($max_sample_rate > 48000 ? 24 : 16);
# check to see if the raw file fullfills the requirements
my $samplerate = $TRACKINFO{$file}{'SAMPLERATE'};
my $inbitdepth = $TRACKINFO{$file}{'BITSPERSAMPLE'};
say "input: samplerate $samplerate inbitdepth $inbitdepth";
say "maxsamplerate $max_sample_rate bitdepth $bitdepth";
if(($samplerate <= $max_sample_rate) && ($inbitdepth <= $bitdepth)) {
say "samplerate is <= max_sample_rate, not resampling";
SendTrack($request, $file);
return;
}
# determine the acceptable samplerate, bitdepth combinations to send
my %rates = (
'48000' => [192000, 96000, 48000],
'44100' => [176400, 88200, 44100]
);
my @acceptable_settings = ( [24, 192000], [24, 96000], [24, 48000], [24, 176400], [24, 88200], [16, 48000], [16, 44100]);
lib/MHFS/Plugin/MusicLibrary.pm view on Meta::CPAN
foreach my $setting (@acceptable_settings) {
if(($setting->[0] <= $bitdepth) && ($setting->[1] <= $max_sample_rate)) {
push @desired, $setting;
}
}
# if we already transcoded/resampled, don't waste time doing it again
foreach my $setting (@desired) {
my $tmpfile = $tmpfileloc . $setting->[0] . '_' . $setting->[1] . '_' . $filebase;
if(-e $tmpfile) {
say "No need to resample $tmpfile exists";
SendTrack($request, $tmpfile);
return;
}
}
make_path($tmpfileloc, {chmod => 0755});
# resampling
my $desiredrate;
RATE_FACTOR: foreach my $key (keys %rates) {
if(($samplerate % $key) == 0) {
foreach my $rate (@{$rates{$key}}) {
if(($rate <= $samplerate) && ($rate <= $max_sample_rate)) {
$desiredrate = $rate;
last RATE_FACTOR;
}
}
}
}
$desiredrate //= $max_sample_rate;
say "desired rate: $desiredrate";
# build the command
my $outfile = $tmpfileloc . $bitdepth . '_' . $desiredrate . '_' . $filebase;
my @cmd = ('sox', $file, '-G', '-b', $bitdepth, $outfile, 'rate', '-v', '-L', $desiredrate, 'dither');
say "cmd: " . join(' ', @cmd);
if(LOCK_WRITE($outfile)) {
$request->{'process'} = MHFS::Process->new(\@cmd, $evp, {
'SIGCHLD' => sub {
UNLOCK_WRITE($outfile);
# BUG? files isn't necessarily flushed to disk on SIGCHLD. filesize can be wrong
SendTrack($request, $outfile);
},
'STDERR' => sub {
my ($terr) = @_;
my $buf;
read($terr, $buf, 4096);
}});
}
else {
# unlikely
say "SendLocalTrack: sox is locked 503";
$request->Send503;
}
return;
}
sub BuildLibraries {
my ($self) = @_;
my @wholeLibrary;
$self->{'sources'} = [];
foreach my $sid (@{$self->{'settings'}{'MEDIASOURCES'}{'music'}}) {
my $source = $self->{'settings'}{'SOURCES'}{$sid};
my $lib;
if($source->{'type'} eq 'local') {
say __PACKAGE__.": building music " . clock_gettime(CLOCK_MONOTONIC);
$lib = BuildLibrary($source->{'folder'});
say __PACKAGE__.": done building music " . clock_gettime(CLOCK_MONOTONIC);
}
elsif($source->{'type'} eq 'ssh') {
}
elsif($source->{'type'} eq 'mhfs') {
}
if(!$lib) {
warn "invalid source: " . $source->{'type'};
warn 'folder: '. $source->{'folder'} if($source->{'type'} eq 'local');
next;
lib/MHFS/Plugin/MusicLibrary.pm view on Meta::CPAN
my $nameloc;
if($utf8name =~ /(.+\/).+$/) {
$nameloc = $1;
}
my $source = $self->{'settings'}{'SOURCES'}{$msource->[0]};
if($sendFiles{$source->{'type'}}->($request, $node->{'path'}, $node->{'node'}, $source, $nameloc)) {
return 1;
}
}
say "SendFromLibrary: did not find in library, 404ing";
say "name: " . $request->{'qs'}{'name'};
$request->Send404;
}
sub SendResources {
my ($self, $request) = @_;
if(! HAS_MHFS_XS) {
say __PACKAGE__.": route not available without XS";
$request->Send503();
return;
}
my $utf8name = decode('UTF-8', $request->{'qs'}{'name'});
foreach my $msource (@{$self->{'sources'}}) {
my $node = $self->FindInLibrary($msource, $utf8name);
next if ! $node;
my $comments = MHFS::XS::get_vorbis_comments($node->{'path'});
my $commenthash = {};
foreach my $comment (@{$comments}) {
$comment = decode('UTF-8', $comment);
my ($key, $value) = split('=', $comment);
$commenthash->{$key} = $value;
}
$request->SendAsJSON($commenthash);
return 1;
}
say "SendFromLibrary: did not find in library, 404ing";
say "name: " . $request->{'qs'}{'name'};
$request->Send404;
}
sub SendArt {
my ($self, $request) = @_;
my $utf8name = decode('UTF-8', $request->{'qs'}{'name'});
foreach my $msource (@{$self->{'sources'}}) {
my $node = $self->FindInLibrary($msource, $utf8name);
next if ! $node;
lib/MHFS/Plugin/MusicLibrary.pm view on Meta::CPAN
}
my $tosend = "$dname/" . $files[0];
foreach my $file (@files) {
foreach my $expname ('cover', 'front', 'album') {
if(substr($file, 0, length($expname)) eq $expname) {
$tosend = "$dname/$file";
last;
}
}
}
say "tosend $tosend";
$request->SendLocalFile($tosend);
return 1;
}
}
sub UpdateLibrariesAsync {
my ($self, $evp, $onUpdateEnd) = @_;
MHFS::Process->new_output_child($evp, sub {
# done in child
my ($datachannel) = @_;
lib/MHFS/Plugin/MusicLibrary.pm view on Meta::CPAN
push @updates, [$pupdate, $self->{$pupdate}];
}
}
# serialize and output
my $pipedata = freeze(\@updates);
print $datachannel $pipedata;
exit 0;
}, sub {
my ($out, $err) = @_;
say "BEGIN_FROM_CHILD---------";
print $err;
say "END_FROM_CHILD-----------";
my $unthawed;
{
local $@;
unless (eval {
$unthawed = thaw($out);
return 1;
}) {
warn("thaw threw exception");
}
}
if($unthawed){
foreach my $update (@$unthawed) {
say "Updating " . $update->[0];
$self->{$update->[0]} = $update->[1];
}
}
else {
say "failed to thaw, library not updated.";
}
$onUpdateEnd->();
});
}
sub new {
my ($class, $settings) = @_;
my $self = {'settings' => $settings};
bless $self, $class;
my $pstart = __PACKAGE__.":";
lib/MHFS/Plugin/MusicLibrary.pm view on Meta::CPAN
['/music_art', sub {
my ($request) = @_;
return $self->SendArt($request);
}]
];
$self->{'timers'} = [
# update the library at start and periodically
[0, 300, sub {
my ($timer, $current_time, $evp) = @_;
say "$pstart library timer";
UpdateLibrariesAsync($self, $evp, sub {
say "$pstart library timer done";
});
return 1;
}],
];
return $self;
}
1;
lib/MHFS/Plugin/Playlist.pm view on Meta::CPAN
$video{'src_file'} = $server->{'fs'}->lookup($nametolookup, $sid);
if( ! $video{'src_file'} ) {
$request->Send404;
return undef;
}
$video{'out_base'} = $video{'src_file'}{'name'};
my $fmt = $request->{'qs'}{'fmt'} // 'm3u8';
if($fmt eq 'm3u8') {
my $absurl = $request->getAbsoluteURL;
if(! $absurl) {
say 'unable to $request->getAbsoluteURL';
$request->Send404;
return undef;
}
my $m3u8 = video_get_m3u8(\%video, $absurl . '/get_video?sid='. $sid . '&name=');
$video{'src_file'}{'ext'} = $video{'src_file'}{'ext'} ? '.'. $video{'src_file'}{'ext'} : '';
$request->{'responseopt'}{'cd_file'} = 'inline';
$request->SendText('application/x-mpegURL', $$m3u8, {'filename' => $video{'src_file'}{'name'} . $video{'src_file'}{'ext'} . '.m3u8'});
return 1;
}
}
lib/MHFS/Plugin/VideoLibrary.pm view on Meta::CPAN
my $packagename = __PACKAGE__;
my $settings = $server->{'settings'};
my $self = $request->{'client'}{'server'}{'loaded_plugins'}{$packagename};
my $buf = "<html>";
$buf .= "<head>";
$buf .= '<style type="text/css">';
my $temp = do {
try { $server->GetTextResource($settings->{'DOCUMENTROOT'} . '/static/' . 'video_style.css') }
catch ($e) {
say "video_style.css not found";
\''
}
};
$buf .= $$temp;
$buf .= '.searchfield { width: 50%; margin: 30px;}';
$buf .= '</style>';
$buf .= "</head>";
$buf .= "<body>";
$qs->{'action'} //= 'library';
lib/MHFS/Plugin/VideoLibrary.pm view on Meta::CPAN
next if(! $libhtmlcontent);
$buf .= "<h1>" . $libraryprint{$library} . "</h1><ul>\n";
$buf .= $libhtmlcontent.'</ul>';
}
$buf .= '</div>';
# add the video player
$temp = do {
try { $server->GetTextResource($server->{'loaded_plugins'}{'MHFS::Plugin::GetVideo'}{'VIDEOFORMATS'}{$fmt}->{'player_html'}) }
catch ($e) {
say "player_html not found";
\''
}
};
$buf .= $$temp;
$buf .= '<script>';
$temp = do {
try { $server->GetTextResource($settings->{'DOCUMENTROOT'} . '/static/' . 'setVideo.js'); }
catch ($e) {
say "setVideo.js not found";
\''
}
};
$buf .= $$temp;
$buf .= '</script>';
$buf .= "</body>";
$buf .= "</html>";
$request->SendHTML($buf);
}
lib/MHFS/Plugin/Youtube.pm view on Meta::CPAN
my @curlcmd = ('curl', '-G', '-d', $youtubequery, 'https://www.googleapis.com/youtube/v3/search');
print "$_ " foreach @curlcmd;
print "\n";
state $tprocess;
$tprocess = MHFS::Process->new(\@curlcmd, $evp, {
'SIGCHLD' => sub {
my $stdout = $tprocess->{'fd'}{'stdout'}{'fd'};
my $buf;
while(length($tosend) == 0) {
while(read($stdout, $buf, 24000)) {
say "did read sigchld";
$tosend .= $buf;
}
}
undef $tprocess;
$request->{'qs'}{'fmt'} //= 'html';
if($request->{'qs'}{'fmt'} eq 'json'){
$request->SendBytes('application/json', $tosend);
}
else {
$self->sendAsHTML($request, $tosend);
lib/MHFS/Plugin/Youtube.pm view on Meta::CPAN
}
sub downloadAndServe {
my ($self, $request, $video) = @_;
weaken($request);
my $filename = $video->{'out_filepath'};
my $sendit = sub {
# we can send the file
if(! $request) {
return;
}
say "sending!!!!";
$request->SendLocalFile($filename);
};
my $qs = $request->{'qs'};
my @cmd = ($self->{'youtube-dl'}, '--no-part', '--print-traffic', '-f', $self->{'fmts'}{$qs->{"media"} // "video"} // "best", '-o', $video->{"out_filepath"}, '--', $qs->{"id"});
$request->{'process'} = MHFS::Process->new_cmd_process($request->{'client'}{'server'}{'evp'}, \@cmd, {
'on_stdout_data' => sub {
my ($context) = @_;
# determine the size of the file
# relies on receiving content-length header last
my ($cl) = $context->{'stdout'} =~ /^.*Content\-Length:\s(\d+)/s;
return 1 if(! $cl);
my ($cr) = $context->{'stdout'} =~ /^.*Content\-Range:\sbytes\s\d+\-\d+\/(\d+)/s;
if($cr) {
say "cr $cr";
$cl = $cr if($cr > $cl);
}
say "cl is $cl";
UNLOCK_WRITE($filename);
LOCK_WRITE($filename, $cl);
# make sure the file exists and within our parameters
my $st = stat($filename);
$st or return;
my $minsize = 16384;
$minsize = $cl if($cl < $minsize);
return if($st->size < $minsize);
say "sending, currentsize " . $st->size . ' totalsize ' . $cl;
# dont need to check the new data anymore
$context->{'on_stdout_data'} = undef;
$sendit->();
$request = undef;
},
'at_exit' => sub {
my ($context) = @_;
UNLOCK_WRITE($filename);
# last ditch effort, try to send it if we haven't
$sendit->();
lib/MHFS/Plugin/Youtube.pm view on Meta::CPAN
$html .= $self->ytplayer($request);
$request->SendHTML($html);
}],
['/ytembedplayer', sub {
my ($request) = @_;
$request->SendHTML($self->ytplayer($request));
}],
];
$self->{'fmts'} = {'music' => 'bestaudio', 'video' => 'best'};
$self->{'minsize'} = '1048576';
say __PACKAGE__.': adding video format yt';
$server->{'loaded_plugins'}{'MHFS::Plugin::GetVideo'}{'VIDEOFORMATS'}{yt} = {'lock' => 1, 'ext' => 'yt', 'plugin' => $self};
my $pstart = __PACKAGE__.": ";
# check for youtube-dl and install if not specified
my $youtubedl = $settings->{'Youtube'}{'youtube-dl'};
my $installed;
if(!$youtubedl) {
my $mhfsytdl = $settings->{'GENERIC_TMPDIR'}.'/youtube-dl';
if(! -e $mhfsytdl) {
say $pstart."Attempting to download youtube-dl";
if(system('curl', '-L', 'https://yt-dl.org/downloads/latest/youtube-dl', '-o', $mhfsytdl) != 0) {
say $pstart . "Failed to download youtube-dl. plugin load failed";
return undef;
}
if(system('chmod', 'a+rx', $mhfsytdl) != 0) {
say $pstart . "Failed to set youtube-dl permissions. plugin load failed";
return undef;
}
$installed = 1;
say $pstart."youtube-dl successfully installed!";
}
$youtubedl = $mhfsytdl;
}
elsif( ! -e $youtubedl) {
say $pstart . "youtube-dl not found. plugin load failed";
return undef;
}
$self->{'youtube-dl'} = $youtubedl;
# update if we didn't just install
if(! $installed) {
say $pstart . "Attempting to update youtube-dl";
if(fork() == 0)
{
system "$youtubedl", "-U";
exit 0;
}
}
return $self;
}
1;
lib/MHFS/Process.pm view on Meta::CPAN
use MHFS::FD::Reader;
use MHFS::FD::Writer;
use MHFS::EventLoop::Poll;
use Carp;
#my %CHILDREN;
#$SIG{CHLD} = sub {
# while((my $child = waitpid(-1, WNOHANG)) > 0) {
# my ($wstatus, $exitcode) = ($?, $?>> 8);
# if(defined $CHILDREN{$child}) {
# say "PID $child reaped (func) $exitcode";
# $CHILDREN{$child}->($exitcode);
# # remove file handles here?
# $CHILDREN{$child} = undef;
# }
# else {
# say "PID $child reaped (No func) $exitcode";
# }
# }
#};
sub _setup_handlers {
my ($self, $in, $out, $err, $fddispatch, $handlesettings) = @_;
my $pid = $self->{'pid'};
my $evp = $self->{'evp'};
if($fddispatch->{'SIGCHLD'}) {
say "PID $pid custom SIGCHLD handler";
#$CHILDREN{$pid} = $fddispatch->{'SIGCHLD'};
$evp->register_child($pid, $fddispatch->{'SIGCHLD'});
}
if($fddispatch->{'STDIN'}) {
$self->{'fd'}{'stdin'} = MHFS::FD::Writer->new($self, $in, $fddispatch->{'STDIN'});
$evp->set($in, $self->{'fd'}{'stdin'}, POLLOUT | MHFS::EventLoop::Poll->ALWAYSMASK);
}
else {
$self->{'fd'}{'stdin'}{'fd'} = $in;
}
lib/MHFS/Process.pm view on Meta::CPAN
my %oldenvvars;
if($env) {
foreach my $key(keys %{$env}) {
# save current value
$oldenvvars{$key} = $ENV{$key};
# set new value
$ENV{$key} = $env->{$key};
my $oldval = $oldenvvars{$key} // '{undef}';
my $newval = $env->{$key} // '{undef}';
say "Changed \$ENV{$key} from $oldval to $newval";
}
}
my ($pid, $in, $out, $err);
eval{ $pid = open3($in, $out, $err = gensym, @$torun); };
if($@) {
say "BAD process";
return undef;
}
$self{'pid'} = $pid;
say 'PID '. $pid . ' NEW PROCESS: ' . $torun->[0];
if($env) {
# restore environment
foreach my $key(keys %oldenvvars) {
$ENV{$key} = $oldenvvars{$key};
my $oldval = $env->{$key} // '{undef}';
my $newval = $oldenvvars{$key} // '{undef}';
say "Restored \$ENV{$key} from $oldval to $newval";
}
}
_setup_handlers(\%self, $in, $out, $err, $fddispatch, $handlesettings);
return bless \%self, $class;
}
sub _new_ex {
my ($make_process, $make_process_args, $context) = @_;
my $process;
$context->{'stdout'} = '';
lib/MHFS/Process.pm view on Meta::CPAN
$context->{'stderr'} .= $buf;
}
return 1;
},
'SIGCHLD' => sub {
$context->{exit_status} = $_[0];
my $obuf;
my $handle = $process->{'fd'}{'stdout'}{'fd'};
while(read($handle, $obuf, 100000)) {
$context->{'stdout'} .= $obuf;
say "stdout sigchld read";
}
my $ebuf;
$handle = $process->{'fd'}{'stderr'}{'fd'};
while(read($handle, $ebuf, 100000)) {
$context->{'stderr'} .= $ebuf;
say "stderr sigchld read";
}
if($context->{'on_stdout_data'}) {
$context->{'on_stdout_data'}->($context);
}
$context->{'at_exit'}->($context);
},
};
if($context->{'input'}) {
$prochandlers->{'STDIN'} = sub {
my ($fh) = @_;
while(1) {
my $curbuf = $context->{'curbuf'};
if($curbuf) {
my $rv = syswrite($fh, $curbuf, length($curbuf));
if(!defined($rv)) {
if(! $!{EAGAIN}) {
say "Critical write error";
return -1;
}
return 1;
}
elsif($rv != length($curbuf)) {
substr($context->{'curbuf'}, 0, $rv, '');
return 1;
}
else {
say "wrote all";
}
}
$context->{'curbuf'} = $context->{'input'}->($context);
if(! defined $context->{'curbuf'}) {
return 0;
}
}
};
}
lib/MHFS/Process.pm view on Meta::CPAN
return _new_ex(\&_new_cmd, $mpa, $context);
}
# subset of command process, just need the data on SIGCHLD
sub new_output_process {
my ($class, $evp, $cmd, $handler) = @_;
return new_cmd_process($class, $evp, $cmd, {
'at_exit' => sub {
my ($context) = @_;
say 'run handler';
$handler->($context->{'stdout'}, $context->{'stderr'});
}
});
}
sub new_io_process {
my ($class, $evp, $cmd, $handler, $inputdata) = @_;
my $ctx = {
'at_exit' => sub {
my ($context) = @_;
say 'run handler';
$handler->($context->{'stdout'}, $context->{'stderr'});
}
};
if(defined $inputdata) {
$ctx->{'curbuf'} = $inputdata;
$ctx->{'input'} = sub {
say "all written";
return undef;
};
}
return new_cmd_process($class, $evp, $cmd, $ctx);
}
# launch a process without a new exe with poll handlers
sub _new_child {
my ($mpa, $prochandlers, $handlesettings) = @_;
my %self = ('time' => clock_gettime(CLOCK_MONOTONIC), 'evp' => $mpa->{'evp'});
# inreader/inwriter is the parent to child data channel
# outreader/outwriter is the child to parent data channel
# errreader/errwriter is the child to parent log channel
pipe(my $inreader, my $inwriter) or die("pipe failed $!");
pipe(my $outreader, my $outwriter) or die("pipe failed $!");
pipe(my $errreader, my $errwriter) or die("pipe failed $!");
# the childs stderr will be UTF-8 text
binmode($errreader, ':encoding(UTF-8)');
my $pid = fork() // do {
say "failed to fork";
return undef;
};
if($pid == 0) {
close($inwriter);
close($outreader);
close($errreader);
open(STDIN, "<&", $inreader) or die("Can't dup \$inreader to STDIN");
open(STDOUT, ">&", $errwriter) or die("Can't dup \$errwriter to STDOUT");
open(STDERR, ">&", $errwriter) or die("Can't dup \$errwriter to STDERR");
$mpa->{'func'}->($outwriter);
exit 0;
}
close($inreader);
close($outwriter);
close($errwriter);
$self{'pid'} = $pid;
say 'PID '. $pid . ' NEW CHILD';
_setup_handlers(\%self, $inwriter, $outreader, $errreader, $prochandlers, $handlesettings);
return bless \%self, $mpa->{'class'};
}
sub cmd_to_sock {
my ($name, $cmd, $sockfh) = @_;
if(fork() == 0) {
open(STDOUT, ">&", $sockfh) or die("Can't dup \$sockfh to STDOUT");
exec(@$cmd);
die;
lib/MHFS/Process.pm view on Meta::CPAN
'at_exit' => sub {
my ($context) = @_;
$handler->($context->{'stdout'}, $context->{'stderr'}, $context->{exit_status});
}
});
}
sub remove {
my ($self, $fd) = @_;
$self->{'evp'}->remove($fd);
say "poll has " . scalar ( $self->{'evp'}{'poll'}->handles) . " handles";
foreach my $key (keys %{$self->{'fd'}}) {
if(defined($self->{'fd'}{$key}{'fd'}) && ($fd == $self->{'fd'}{$key}{'fd'})) {
$self->{'fd'}{$key} = undef;
last;
}
}
}
sub DESTROY {
my $self = shift;
say "PID " . $self->{'pid'} . ' DESTROY called';
foreach my $key (keys %{$self->{'fd'}}) {
if(defined($self->{'fd'}{$key}{'fd'})) {
#Dump($self->{'fd'}{$key});
$self->{'evp'}->remove($self->{'fd'}{$key}{'fd'});
$self->{'fd'}{$key} = undef;
}
}
}
1;
lib/MHFS/Promise.pm view on Meta::CPAN
}
sub _new {
my ($class, $evp) = @_;
my %self = ( 'evp' => $evp, 'waiters' => [], 'state' => MHFS_PROMISE_PENDING);
bless \%self, $class;
$self{fulfill} = sub {
my $value = $_[0];
if(ref($value) eq $class) {
$self{state} = MHFS_PROMISE_ADOPT;
say "adopting promise";
} else {
$self{state} = MHFS_PROMISE_SUCCESS;
#say "resolved with " . ($_[0] // 'undef');
}
$self{end_value} = $_[0];
finale(\%self);
};
$self{reject} = sub {
$self{state} = MHFS_PROMISE_FAILURE;
$self{end_value} = $_[0];
finale(\%self);
};
return \%self;
lib/MHFS/Settings.pm view on Meta::CPAN
my ($SETTINGS, $filepath) = @_;
my $indentcnst = 4;
my $indentspace = '';
my $settingscontents = "#!/usr/bin/perl\nuse strict; use warnings;\n\nmy \$SETTINGS = ";
# we only encode SCALARS. Loop through expanding HASH and ARRAY refs into SCALARS
my @values = ($SETTINGS);
while(@values) {
my $value = shift @values;
my $type = reftype($value);
say "value: $value type: " . ($type // 'undef');
my $raw;
my $noindent;
if(! defined $type) {
if(defined $value) {
# process lead control code if provided
$raw = ($value eq '__raw');
$noindent = ($value eq '__noindent');
if($raw || $noindent) {
$value = shift @values;
}
lib/MHFS/Settings.pm view on Meta::CPAN
substr($indentspace, -4, 4, '');
# don't actually encode anything
$value = '';
$type = 'NOP';
}
else {
$type = reftype($value) // 'SCALAR';
}
}
say "v2: $value type $type";
if($type eq 'NOP') {
next;
}
$settingscontents .= $indentspace if(! $noindent);
if($type eq 'SCALAR') {
# encode the value
if(! $raw) {
$value =~ s/'/\\'/g;
$value = "'".$value."'";
lib/MHFS/Settings.pm view on Meta::CPAN
push @toprepend, '__indent-', '__raw', "],\n";
unshift(@values, @toprepend);
}
else {
die("Unknown type: $type");
}
}
chop $settingscontents;
chop $settingscontents;
$settingscontents .= ";\n\n\$SETTINGS;\n";
say "making settings folder $filepath";
make_path(dirname($filepath));
write_text_file($filepath, $settingscontents);
}
sub calc_source_id {
my ($source) = @_;
if($source->{'type'} ne 'local') {
say "only local sources supported right now";
return undef;
}
return encode_base64url(md5('local:'.$source->{folder}));
}
sub add_source {
my ($sources, $source) = @_;
my $id = calc_source_id($source);
my $len = 6;
my $shortid = substr($id, 0, $len);
lib/MHFS/Settings.pm view on Meta::CPAN
# write the default settings
if(! -f $SETTINGS_FILE) {
write_settings_file($SETTINGS, $SETTINGS_FILE);
}
$SETTINGS->{'CFGDIR'} = $CFGDIR;
$SETTINGS->{flush} = $launchsettings->{flush} if(exists $launchsettings->{flush});
# locate files based on appdir
$APPDIR ||= $SETTINGS->{'APPDIR'} || dist_dir('App-MHFS');
$APPDIR = abs_path($APPDIR);
say __PACKAGE__.": using APPDIR " . $APPDIR;
$SETTINGS->{'APPDIR'} = $APPDIR;
# determine the fallback data root
$FALLBACK_DATA_ROOT ||= $SETTINGS->{'FALLBACK_DATA_ROOT'} || $ENV{'HOME'};
$FALLBACK_DATA_ROOT ||= ($ENV{APPDATA}.'/mhfs') if($ENV{APPDATA}); # Windows
if($FALLBACK_DATA_ROOT) {
$FALLBACK_DATA_ROOT = abs_path($FALLBACK_DATA_ROOT);
}
# determine the allowed remoteip host combos. only ipv4 now sorry
$SETTINGS->{'ARIPHOSTS_PARSED'} = [];
lib/MHFS/Settings.pm view on Meta::CPAN
my $srcs = $SETTINGS->{'MEDIALIBRARIES'}{$lib};
if(ref($srcs) ne 'ARRAY') {
$srcs = [$srcs];
}
my @subsrcs;
foreach my $source (@$srcs) {
my $stype = ref($source);
my $tohash = $source;
if($stype ne 'HASH') {
if($stype ne '') {
say __PACKAGE__.": skipping source";
next;
}
$tohash = {type => 'local', folder => $source};
}
if ($tohash->{type} eq 'local') {
my $absfolder = abs_path($tohash->{folder});
$absfolder // do {
say __PACKAGE__.": skipping source $tohash->{folder} - abs_path failed";
next;
};
$tohash->{folder} = $absfolder;
}
my $sid = add_source(\%sources, $tohash);
push @subsrcs, $sid;
}
$mediasources{$lib} = \@subsrcs;
}
$SETTINGS->{'MEDIASOURCES'} = \%mediasources;
lib/MHFS/Util.pm view on Meta::CPAN
sub ASYNC {
my $func = shift;
my $pid = fork();
if($pid == 0) {
$func->(@_);
#exit 0;
POSIX::_exit(0);
}
else {
say "PID $pid ASYNC";
return $pid;
}
}
sub space2us {
my ($string) = @_;
$string =~ s/\s/_/g;
return $string;
}
sub escape_html {
lib/MHFS/Util.pm view on Meta::CPAN
@files = (undef, @files);
goto ON_DIR;
}
my $unsafePath = $path;
if($root) {
$unsafePath =~ s/^$root(\/)?//;
}
my $size = -s $path;
if(! defined $size) {
say "size not defined path $path file $file";
next;
}
next if( $size < $options->{'min_file_size'});
$options->{'on_file'}->($path, $unsafePath, $file) if($options->{'on_file'});
}
return;
}
# perform multiple async actions at the same time.
# continue on with $result_func on failure or completion of all actions
lib/MHFS/Util.pm view on Meta::CPAN
$result_func->(undef);
return;
}
# yield if not all the results in
foreach my $m2 (@mkeys) {
return if(! defined $data{$m2});
}
# all results in we can continue
$result_func->(\%data);
};
say "launching multiple key: $multiple";
$multiples->{$multiple}->($multiple_cb);
}
}
sub getMIME {
my ($filename) = @_;
my %combined = (
# audio
'mp3' => 'audio/mp3',
lib/MHFS/Util.pm view on Meta::CPAN
$res .= $toappend;
substr($octets, 0, $toremove, '');
}
return $res;
}
# save space by not precent encoding valid UTF-8 characters
sub small_url_encode {
my ($octets) = @_;
say "before $octets";
my $escapedoctets = ${escape_html($octets)};
my $res;
while(length($escapedoctets)) {
$res .= decode('UTF-8', $escapedoctets, Encode::FB_QUIET);
last if(!length($escapedoctets));
my $oct = ord(substr($escapedoctets, 0, 1, ''));
$res .= sprintf ("%%%02X", $oct);
}
say "now: $res";
return $res;
}
sub uri_escape_path {
my ($b_path) = @_;
uri_escape($b_path, qr/[^A-Za-z0-9\-\._~\/]/)
}
sub uri_escape_path_utf8 {
my ($path) = @_;
share/public_html/static/music_inc/src/miniaudio.h view on Meta::CPAN
/* DirectSound can support all formats. */
pDeviceInfo->formatCount = ma_format_count - 1; /* Minus one because we don't want to include ma_format_unknown. */
for (iFormat = 0; iFormat < pDeviceInfo->formatCount; ++iFormat) {
pDeviceInfo->formats[iFormat] = (ma_format)(iFormat + 1); /* +1 to skip over ma_format_unknown. */
}
ma_IDirectSound_Release(pDirectSound);
} else {
/*
Capture. This is a little different to playback due to the say the supported formats are reported. Technically capture
devices can support a number of different formats, but for simplicity and consistency with ma_device_init() I'm just
reporting the best format.
*/
ma_IDirectSoundCapture* pDirectSoundCapture;
WORD channels;
WORD bitsPerSample;
DWORD sampleRate;
result = ma_context_create_IDirectSoundCapture__dsound(pContext, shareMode, pDeviceID, &pDirectSoundCapture);
if (result != MA_SUCCESS) {
share/public_html/static/music_worklet_inprogress/decoder/deps/miniaudio/miniaudio.h view on Meta::CPAN
pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].format = ma_format_unknown;
pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].channels = channels;
pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].sampleRate = caps.dwMaxSecondarySampleRate;
pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].flags = 0;
pDeviceInfo->nativeDataFormatCount += 1;
}
ma_IDirectSound_Release(pDirectSound);
} else {
/*
Capture. This is a little different to playback due to the say the supported formats are reported. Technically capture
devices can support a number of different formats, but for simplicity and consistency with ma_device_init() I'm just
reporting the best format.
*/
ma_IDirectSoundCapture* pDirectSoundCapture;
WORD channels;
WORD bitsPerSample;
DWORD sampleRate;
result = ma_context_create_IDirectSoundCapture__dsound(pContext, ma_share_mode_shared, pDeviceID, &pDirectSoundCapture);
if (result != MA_SUCCESS) {
share/public_html/static/music_worklet_inprogress/decoder/deps/miniaudio/miniaudio.h view on Meta::CPAN
miniaudio's context and they map to each other quite well. You have one context to many streams, which is basically the same as miniaudio's
one `ma_context` to many `ma_device`s. Here's where it starts to get annoying, however. When you first create the PulseAudio context, which
is done with `pa_context_new()`, it's not actually connected to anything. When you connect, you call `pa_context_connect()`. However, if
you remember, PulseAudio is an asynchronous API. That means you cannot just assume the context is connected after `pa_context_context()`
has returned. You instead need to wait for it to connect. To do this, you need to either wait for a callback to get fired, which you can
set with `pa_context_set_state_callback()`, or you can continuously poll the context's state. Either way, you need to run this in a loop.
All objects from here out are created from the context, and, I believe, you can't be creating these objects until the context is connected.
This waiting loop is therefore unavoidable. In order for the waiting to ever complete, however, the main loop needs to be running. Before
attempting to connect the context, the main loop needs to be started with `pa_threaded_mainloop_start()`.
The reason for this asynchronous design is to support cases where you're connecting to a remote server, say through a local network or an
internet connection. However, the *VAST* majority of cases don't involve this at all - they just connect to a local "server" running on the
host machine. The fact that this would be the default rather than making `pa_context_connect()` synchronous tends to boggle the mind.
Once the context has been created and connected you can start creating a stream. A PulseAudio stream is analogous to miniaudio's device.
The initialization of a stream is fairly standard - you configure some attributes (analogous to miniaudio's device config) and then call
`pa_stream_new()` to actually create it. Here is where we start to get into "operations". When configuring the stream, you can get
information about the source (such as sample format, sample rate, etc.), however it's not synchronous. Instead, a `pa_operation` object
is returned from `pa_context_get_source_info_by_name()` (capture) or `pa_context_get_sink_info_by_name()` (playback). Then, you need to
run a loop (again!) to wait for the operation to complete which you can determine via a callback or polling, just like we did with the
context. Then, as an added bonus, you need to decrement the reference counter of the `pa_operation` object to ensure memory is cleaned up.
( run in 2.486 seconds using v1.01-cache-2.11-cpan-d7a12ab2c7f )